{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module System.IO.HVFS.InstanceHelpers(
SimpleStat(..),
MemoryVFS,
newMemoryVFS, newMemoryVFSRef,
MemoryNode,
MemoryEntry(..),
nice_slice, getFullPath,
getFullSlice)
where
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.List (genericLength)
import System.FilePath (isPathSeparator, pathSeparator, (</>))
import System.IO ( IOMode(ReadMode) )
import System.IO.Error (doesNotExistErrorType,
illegalOperationErrorType,
permissionErrorType)
import System.IO.HVFS
( FileOffset,
HVFSOpenable(vOpen),
HVFS(vGetDirectoryContents, vGetFileStatus, vSetCurrentDirectory,
vRaiseError, vGetCurrentDirectory),
HVFSStat(vIsRegularFile, vFileSize, vIsDirectory),
HVFSOpenEncap(HVFSOpenEncap),
HVFSStatEncap(HVFSStatEncap) )
import System.IO.HVIO (newStreamReader)
import System.Path (absNormPath)
import System.Path.NameManip (slice_path)
data SimpleStat = SimpleStat {
SimpleStat -> Bool
isFile :: Bool,
SimpleStat -> FileOffset
fileSize :: FileOffset
} deriving (Int -> SimpleStat -> ShowS
[SimpleStat] -> ShowS
SimpleStat -> String
(Int -> SimpleStat -> ShowS)
-> (SimpleStat -> String)
-> ([SimpleStat] -> ShowS)
-> Show SimpleStat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SimpleStat -> ShowS
showsPrec :: Int -> SimpleStat -> ShowS
$cshow :: SimpleStat -> String
show :: SimpleStat -> String
$cshowList :: [SimpleStat] -> ShowS
showList :: [SimpleStat] -> ShowS
Show, SimpleStat -> SimpleStat -> Bool
(SimpleStat -> SimpleStat -> Bool)
-> (SimpleStat -> SimpleStat -> Bool) -> Eq SimpleStat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SimpleStat -> SimpleStat -> Bool
== :: SimpleStat -> SimpleStat -> Bool
$c/= :: SimpleStat -> SimpleStat -> Bool
/= :: SimpleStat -> SimpleStat -> Bool
Eq)
instance HVFSStat SimpleStat where
vIsRegularFile :: SimpleStat -> Bool
vIsRegularFile SimpleStat
x = SimpleStat -> Bool
isFile SimpleStat
x
vIsDirectory :: SimpleStat -> Bool
vIsDirectory SimpleStat
x = Bool -> Bool
not (SimpleStat -> Bool
isFile SimpleStat
x)
vFileSize :: SimpleStat -> FileOffset
vFileSize SimpleStat
x = SimpleStat -> FileOffset
fileSize SimpleStat
x
type MemoryNode = (String, MemoryEntry)
data MemoryEntry = MemoryDirectory [MemoryNode]
| MemoryFile String
deriving (MemoryEntry -> MemoryEntry -> Bool
(MemoryEntry -> MemoryEntry -> Bool)
-> (MemoryEntry -> MemoryEntry -> Bool) -> Eq MemoryEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MemoryEntry -> MemoryEntry -> Bool
== :: MemoryEntry -> MemoryEntry -> Bool
$c/= :: MemoryEntry -> MemoryEntry -> Bool
/= :: MemoryEntry -> MemoryEntry -> Bool
Eq, Int -> MemoryEntry -> ShowS
[MemoryEntry] -> ShowS
MemoryEntry -> String
(Int -> MemoryEntry -> ShowS)
-> (MemoryEntry -> String)
-> ([MemoryEntry] -> ShowS)
-> Show MemoryEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MemoryEntry -> ShowS
showsPrec :: Int -> MemoryEntry -> ShowS
$cshow :: MemoryEntry -> String
show :: MemoryEntry -> String
$cshowList :: [MemoryEntry] -> ShowS
showList :: [MemoryEntry] -> ShowS
Show)
data MemoryVFS = MemoryVFS
{ MemoryVFS -> IORef [MemoryNode]
content :: IORef [MemoryNode],
MemoryVFS -> IORef String
cwd :: IORef FilePath
}
instance Show MemoryVFS where
show :: MemoryVFS -> String
show MemoryVFS
_ = String
"<MemoryVFS>"
newMemoryVFS :: [MemoryNode] -> IO MemoryVFS
newMemoryVFS :: [MemoryNode] -> IO MemoryVFS
newMemoryVFS [MemoryNode]
s = do IORef [MemoryNode]
r <- [MemoryNode] -> IO (IORef [MemoryNode])
forall a. a -> IO (IORef a)
newIORef [MemoryNode]
s
IORef [MemoryNode] -> IO MemoryVFS
newMemoryVFSRef IORef [MemoryNode]
r
newMemoryVFSRef :: IORef [MemoryNode] -> IO MemoryVFS
newMemoryVFSRef :: IORef [MemoryNode] -> IO MemoryVFS
newMemoryVFSRef IORef [MemoryNode]
r = do
IORef String
c <- String -> IO (IORef String)
forall a. a -> IO (IORef a)
newIORef [Char
pathSeparator]
MemoryVFS -> IO MemoryVFS
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MemoryVFS {content :: IORef [MemoryNode]
content = IORef [MemoryNode]
r, cwd :: IORef String
cwd = IORef String
c})
nice_slice :: String -> [String]
nice_slice :: String -> [String]
nice_slice String
path
| String
path String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== [Char
pathSeparator] = []
| Bool
otherwise =
let sliced1 :: [String]
sliced1 = String -> [String]
slice_path String
path
h :: String
h = [String] -> String
forall a. HasCallStack => [a] -> a
head [String]
sliced1
t :: [String]
t = [String] -> [String]
forall a. HasCallStack => [a] -> [a]
tail [String]
sliced1
newh :: String
newh = if Char -> Bool
isPathSeparator (String -> Char
forall a. HasCallStack => [a] -> a
head String
h) then ShowS
forall a. HasCallStack => [a] -> [a]
tail String
h else String
h
sliced2 :: [String]
sliced2 = String
newh String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
t
in [String]
sliced2
getFullPath :: HVFS a => a -> String -> IO String
getFullPath :: forall a. HVFS a => a -> String -> IO String
getFullPath a
fs String
path =
do String
dir <- a -> IO String
forall a. HVFS a => a -> IO String
vGetCurrentDirectory a
fs
case (String -> String -> Maybe String
absNormPath String
dir String
path) of
Maybe String
Nothing -> a -> IOErrorType -> String -> Maybe String -> IO String
forall c. a -> IOErrorType -> String -> Maybe String -> IO c
forall a c.
HVFS a =>
a -> IOErrorType -> String -> Maybe String -> IO c
vRaiseError a
fs IOErrorType
doesNotExistErrorType
(String
"Trouble normalizing path " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
path) (String -> Maybe String
forall a. a -> Maybe a
Just (String
dir String -> ShowS
</> String
path))
Just String
newpath -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
newpath
getFullSlice :: HVFS a => a -> String -> IO [String]
getFullSlice :: forall a. HVFS a => a -> String -> IO [String]
getFullSlice a
fs String
fp =
do String
newpath <- a -> String -> IO String
forall a. HVFS a => a -> String -> IO String
getFullPath a
fs String
fp
[String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [String]
nice_slice String
newpath)
findMelem :: MemoryVFS -> String -> IO MemoryEntry
findMelem :: MemoryVFS -> String -> IO MemoryEntry
findMelem MemoryVFS
x String
path
| String
path String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== [Char
pathSeparator] = IORef [MemoryNode] -> IO [MemoryNode]
forall a. IORef a -> IO a
readIORef (MemoryVFS -> IORef [MemoryNode]
content MemoryVFS
x) IO [MemoryNode]
-> ([MemoryNode] -> IO MemoryEntry) -> IO MemoryEntry
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MemoryEntry -> IO MemoryEntry
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MemoryEntry -> IO MemoryEntry)
-> ([MemoryNode] -> MemoryEntry) -> [MemoryNode] -> IO MemoryEntry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MemoryNode] -> MemoryEntry
MemoryDirectory
| Bool
otherwise =
let sliced1 :: [String]
sliced1 = String -> [String]
slice_path String
path
h :: String
h = [String] -> String
forall a. HasCallStack => [a] -> a
head [String]
sliced1
t :: [String]
t = [String] -> [String]
forall a. HasCallStack => [a] -> [a]
tail [String]
sliced1
newh :: String
newh = if (String
h String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char
pathSeparator]) Bool -> Bool -> Bool
&& Char -> Bool
isPathSeparator (String -> Char
forall a. HasCallStack => [a] -> a
head String
h) then ShowS
forall a. HasCallStack => [a] -> [a]
tail String
h else String
h
sliced2 :: [String]
sliced2 = String
newh String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
t
walk :: MemoryEntry -> [String] -> Either String MemoryEntry
walk :: MemoryEntry -> [String] -> Either String MemoryEntry
walk MemoryEntry
y [String]
zs
| [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
zs = MemoryEntry -> Either String MemoryEntry
forall a b. b -> Either a b
Right MemoryEntry
y
| [String]
zs [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
== [[Char
pathSeparator]] = MemoryEntry -> Either String MemoryEntry
forall a b. b -> Either a b
Right MemoryEntry
y
| Bool
otherwise = case MemoryEntry
y of
MemoryFile String
_ -> String -> Either String MemoryEntry
forall a b. a -> Either a b
Left (String -> Either String MemoryEntry)
-> String -> Either String MemoryEntry
forall a b. (a -> b) -> a -> b
$ String
"Attempt to look up name " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. HasCallStack => [a] -> a
head [String]
zs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in file"
MemoryDirectory [MemoryNode]
y ->
let newentry :: Either String MemoryEntry
newentry = case String -> [MemoryNode] -> Maybe MemoryEntry
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ([String] -> String
forall a. HasCallStack => [a] -> a
head [String]
zs) [MemoryNode]
y of
Maybe MemoryEntry
Nothing -> String -> Either String MemoryEntry
forall a b. a -> Either a b
Left (String -> Either String MemoryEntry)
-> String -> Either String MemoryEntry
forall a b. (a -> b) -> a -> b
$ String
"Couldn't find entry " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. HasCallStack => [a] -> a
head [String]
zs
Just MemoryEntry
a -> MemoryEntry -> Either String MemoryEntry
forall a b. b -> Either a b
Right MemoryEntry
a
in do MemoryEntry
newobj <- Either String MemoryEntry
newentry
MemoryEntry -> [String] -> Either String MemoryEntry
walk MemoryEntry
newobj ([String] -> [String]
forall a. HasCallStack => [a] -> [a]
tail [String]
zs)
in do
[MemoryNode]
c <- IORef [MemoryNode] -> IO [MemoryNode]
forall a. IORef a -> IO a
readIORef (IORef [MemoryNode] -> IO [MemoryNode])
-> IORef [MemoryNode] -> IO [MemoryNode]
forall a b. (a -> b) -> a -> b
$ MemoryVFS -> IORef [MemoryNode]
content MemoryVFS
x
case MemoryEntry -> [String] -> Either String MemoryEntry
walk ([MemoryNode] -> MemoryEntry
MemoryDirectory [MemoryNode]
c) ([String]
sliced2) of
Left String
err -> MemoryVFS
-> IOErrorType -> String -> Maybe String -> IO MemoryEntry
forall a c.
HVFS a =>
a -> IOErrorType -> String -> Maybe String -> IO c
forall c.
MemoryVFS -> IOErrorType -> String -> Maybe String -> IO c
vRaiseError MemoryVFS
x IOErrorType
doesNotExistErrorType String
err Maybe String
forall a. Maybe a
Nothing
Right MemoryEntry
result -> MemoryEntry -> IO MemoryEntry
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MemoryEntry
result
getMelem :: MemoryVFS -> String -> IO MemoryEntry
getMelem :: MemoryVFS -> String -> IO MemoryEntry
getMelem MemoryVFS
x String
s =
do String
base <- IORef String -> IO String
forall a. IORef a -> IO a
readIORef (IORef String -> IO String) -> IORef String -> IO String
forall a b. (a -> b) -> a -> b
$ MemoryVFS -> IORef String
cwd MemoryVFS
x
case String -> String -> Maybe String
absNormPath String
base String
s of
Maybe String
Nothing -> MemoryVFS
-> IOErrorType -> String -> Maybe String -> IO MemoryEntry
forall a c.
HVFS a =>
a -> IOErrorType -> String -> Maybe String -> IO c
forall c.
MemoryVFS -> IOErrorType -> String -> Maybe String -> IO c
vRaiseError MemoryVFS
x IOErrorType
doesNotExistErrorType
(String
"Trouble normalizing path " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s) (String -> Maybe String
forall a. a -> Maybe a
Just String
s)
Just String
newpath -> MemoryVFS -> String -> IO MemoryEntry
findMelem MemoryVFS
x String
newpath
instance HVFS MemoryVFS where
vGetCurrentDirectory :: MemoryVFS -> IO String
vGetCurrentDirectory MemoryVFS
x = IORef String -> IO String
forall a. IORef a -> IO a
readIORef (IORef String -> IO String) -> IORef String -> IO String
forall a b. (a -> b) -> a -> b
$ MemoryVFS -> IORef String
cwd MemoryVFS
x
vSetCurrentDirectory :: MemoryVFS -> String -> IO ()
vSetCurrentDirectory MemoryVFS
x String
fp =
do String
curpath <- MemoryVFS -> IO String
forall a. HVFS a => a -> IO String
vGetCurrentDirectory MemoryVFS
x
MemoryEntry
newdir <- MemoryVFS -> String -> IO MemoryEntry
getMelem MemoryVFS
x String
fp
case MemoryEntry
newdir of
(MemoryFile String
_) -> MemoryVFS -> IOErrorType -> String -> Maybe String -> IO ()
forall a c.
HVFS a =>
a -> IOErrorType -> String -> Maybe String -> IO c
forall c.
MemoryVFS -> IOErrorType -> String -> Maybe String -> IO c
vRaiseError MemoryVFS
x IOErrorType
doesNotExistErrorType
(String
"Attempt to cwd to non-directory " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fp)
(String -> Maybe String
forall a. a -> Maybe a
Just String
fp)
(MemoryDirectory [MemoryNode]
_) ->
case String -> String -> Maybe String
absNormPath String
curpath String
fp of
Maybe String
Nothing ->
MemoryVFS -> IOErrorType -> String -> Maybe String -> IO ()
forall a c.
HVFS a =>
a -> IOErrorType -> String -> Maybe String -> IO c
forall c.
MemoryVFS -> IOErrorType -> String -> Maybe String -> IO c
vRaiseError MemoryVFS
x IOErrorType
illegalOperationErrorType
String
"Bad internal error" (String -> Maybe String
forall a. a -> Maybe a
Just String
fp)
Just String
y -> IORef String -> String -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (MemoryVFS -> IORef String
cwd MemoryVFS
x) String
y
vGetFileStatus :: MemoryVFS -> String -> IO HVFSStatEncap
vGetFileStatus MemoryVFS
x String
fp =
MemoryVFS -> String -> IO MemoryEntry
getMelem MemoryVFS
x String
fp IO MemoryEntry
-> (MemoryEntry -> IO HVFSStatEncap) -> IO HVFSStatEncap
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
(MemoryFile String
y) -> HVFSStatEncap -> IO HVFSStatEncap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HVFSStatEncap -> IO HVFSStatEncap)
-> HVFSStatEncap -> IO HVFSStatEncap
forall a b. (a -> b) -> a -> b
$ SimpleStat -> HVFSStatEncap
forall a. HVFSStat a => a -> HVFSStatEncap
HVFSStatEncap (SimpleStat -> HVFSStatEncap) -> SimpleStat -> HVFSStatEncap
forall a b. (a -> b) -> a -> b
$
SimpleStat {isFile :: Bool
isFile = Bool
True,
fileSize :: FileOffset
fileSize = (String -> FileOffset
forall i a. Num i => [a] -> i
genericLength String
y)}
(MemoryDirectory [MemoryNode]
_) -> HVFSStatEncap -> IO HVFSStatEncap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HVFSStatEncap -> IO HVFSStatEncap)
-> HVFSStatEncap -> IO HVFSStatEncap
forall a b. (a -> b) -> a -> b
$ SimpleStat -> HVFSStatEncap
forall a. HVFSStat a => a -> HVFSStatEncap
HVFSStatEncap (SimpleStat -> HVFSStatEncap) -> SimpleStat -> HVFSStatEncap
forall a b. (a -> b) -> a -> b
$
SimpleStat {isFile :: Bool
isFile = Bool
False,
fileSize :: FileOffset
fileSize = FileOffset
0}
vGetDirectoryContents :: MemoryVFS -> String -> IO [String]
vGetDirectoryContents MemoryVFS
x String
fp =
MemoryVFS -> String -> IO MemoryEntry
getMelem MemoryVFS
x String
fp IO MemoryEntry -> (MemoryEntry -> IO [String]) -> IO [String]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
MemoryFile String
_ -> MemoryVFS -> IOErrorType -> String -> Maybe String -> IO [String]
forall a c.
HVFS a =>
a -> IOErrorType -> String -> Maybe String -> IO c
forall c.
MemoryVFS -> IOErrorType -> String -> Maybe String -> IO c
vRaiseError MemoryVFS
x IOErrorType
doesNotExistErrorType
String
"Can't list contents of a file"
(String -> Maybe String
forall a. a -> Maybe a
Just String
fp)
MemoryDirectory [MemoryNode]
c -> [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (MemoryNode -> String) -> [MemoryNode] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map MemoryNode -> String
forall a b. (a, b) -> a
fst [MemoryNode]
c
instance HVFSOpenable MemoryVFS where
vOpen :: MemoryVFS -> String -> IOMode -> IO HVFSOpenEncap
vOpen MemoryVFS
x String
fp (IOMode
ReadMode) =
MemoryVFS -> String -> IO MemoryEntry
getMelem MemoryVFS
x String
fp IO MemoryEntry
-> (MemoryEntry -> IO HVFSOpenEncap) -> IO HVFSOpenEncap
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
MemoryDirectory [MemoryNode]
_ -> MemoryVFS
-> IOErrorType -> String -> Maybe String -> IO HVFSOpenEncap
forall a c.
HVFS a =>
a -> IOErrorType -> String -> Maybe String -> IO c
forall c.
MemoryVFS -> IOErrorType -> String -> Maybe String -> IO c
vRaiseError MemoryVFS
x IOErrorType
doesNotExistErrorType
String
"Can't open a directory"
(String -> Maybe String
forall a. a -> Maybe a
Just String
fp)
MemoryFile String
y -> String -> IO StreamReader
newStreamReader String
y IO StreamReader
-> (StreamReader -> IO HVFSOpenEncap) -> IO HVFSOpenEncap
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HVFSOpenEncap -> IO HVFSOpenEncap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HVFSOpenEncap -> IO HVFSOpenEncap)
-> (StreamReader -> HVFSOpenEncap)
-> StreamReader
-> IO HVFSOpenEncap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamReader -> HVFSOpenEncap
forall a. HVIO a => a -> HVFSOpenEncap
HVFSOpenEncap
vOpen MemoryVFS
x String
fp IOMode
_ = MemoryVFS
-> IOErrorType -> String -> Maybe String -> IO HVFSOpenEncap
forall a c.
HVFS a =>
a -> IOErrorType -> String -> Maybe String -> IO c
forall c.
MemoryVFS -> IOErrorType -> String -> Maybe String -> IO c
vRaiseError MemoryVFS
x IOErrorType
permissionErrorType
String
"Only ReadMode is supported with MemoryVFS files"
(String -> Maybe String
forall a. a -> Maybe a
Just String
fp)