{-# LANGUAGE Safe #-}
{- arch-tag: HVFS instance helpers
Copyright (c) 2004-2011 John Goerzen <jgoerzen@complete.org>

All rights reserved.

For license and copyright information, see the file LICENSE
-}

{- |
   Module     : System.IO.HVFS.InstanceHelpers
   Copyright  : Copyright (C) 2004-2011 John Goerzen
   SPDX-License-Identifier: BSD-3-Clause

   Stability  : stable
   Portability: portable

Utilities for creating instances of the items defined in
"System.IO.HVFS".

-}

module System.IO.HVFS.InstanceHelpers(-- * HVFSStat objects
                                        SimpleStat(..),
                                        -- * HVFS objects & types
                                        -- ** MemoryVFS
                                        MemoryVFS,
                                        newMemoryVFS, newMemoryVFSRef,
                                        MemoryNode,
                                        MemoryEntry(..),
                                        -- * Utilities
                                        nice_slice, getFullPath,
                                        getFullSlice)
    where

import           Data.IORef            (IORef, newIORef, readIORef, writeIORef)
import           Data.List             (genericLength)
import           System.FilePath       (isPathSeparator, pathSeparator, (</>))
import           System.IO
import           System.IO.Error       (doesNotExistErrorType,
                                        illegalOperationErrorType,
                                        permissionErrorType)
import           System.IO.HVFS
import           System.IO.HVIO        (newStreamReader)
import           System.Path           (absNormPath)
import           System.Path.NameManip (slice_path)

{- | A simple "System.IO.HVFS.HVFSStat"
class that assumes that everything is either a file
or a directory. -}
data SimpleStat = SimpleStat {
                              SimpleStat -> Bool
isFile   :: Bool, -- ^ True if file, False if directory
                              SimpleStat -> FileOffset
fileSize :: FileOffset -- ^ Set to 0 if unknown or a directory
                             } 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
showList :: [SimpleStat] -> ShowS
$cshowList :: [SimpleStat] -> ShowS
show :: SimpleStat -> String
$cshow :: SimpleStat -> String
showsPrec :: Int -> SimpleStat -> ShowS
$cshowsPrec :: Int -> SimpleStat -> ShowS
Show, SimpleStat -> SimpleStat -> Bool
(SimpleStat -> SimpleStat -> Bool)
-> (SimpleStat -> SimpleStat -> Bool) -> Eq SimpleStat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SimpleStat -> SimpleStat -> Bool
$c/= :: SimpleStat -> SimpleStat -> Bool
== :: SimpleStat -> SimpleStat -> Bool
$c== :: 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

----------------------------------------------------------------------
-- In-Memory Tree Types
----------------------------------------------------------------------
{- | The basic node of a 'MemoryVFS'.  The String corresponds to the filename,
and the entry to the contents. -}
type MemoryNode = (String, MemoryEntry)

{- | The content of a file or directory in a 'MemoryVFS'. -}
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
/= :: MemoryEntry -> MemoryEntry -> Bool
$c/= :: MemoryEntry -> MemoryEntry -> Bool
== :: MemoryEntry -> MemoryEntry -> Bool
$c== :: 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
showList :: [MemoryEntry] -> ShowS
$cshowList :: [MemoryEntry] -> ShowS
show :: MemoryEntry -> String
$cshow :: MemoryEntry -> String
showsPrec :: Int -> MemoryEntry -> ShowS
$cshowsPrec :: Int -> MemoryEntry -> ShowS
Show)

{- | An in-memory read\/write filesystem.  Think of it as a dynamically
resizable ramdisk written in Haskell. -}
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>"

-- | Create a new 'MemoryVFS' object from an existing tree.
-- An empty filesystem may be created by using @[]@ for the parameter.
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

-- | Create a new 'MemoryVFS' object using an IORef to an
-- existing tree.
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 (m :: * -> *) a. Monad m => a -> m a
return (MemoryVFS {content :: IORef [MemoryNode]
content = IORef [MemoryNode]
r, cwd :: IORef String
cwd = IORef String
c})

{- | Similar to 'System.Path.NameManip' but the first element
won't be @\/@.

>nice_slice "/" -> []
>nice_slice "/foo/bar" -> ["foo", "bar"]
-}
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. [a] -> a
head [String]
sliced1
          t :: [String]
t = [String] -> [String]
forall a. [a] -> [a]
tail [String]
sliced1
          newh :: String
newh =  if Char -> Bool
isPathSeparator (String -> Char
forall a. [a] -> a
head String
h) then ShowS
forall a. [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

{- | Gets a full path, after investigating the cwd.
-}
getFullPath :: HVFS a => a -> String -> IO String
getFullPath :: forall a. HVFS a => a -> String -> IO String
getFullPath a
fs String
path =
    do String
cwd <- a -> IO String
forall a. HVFS a => a -> IO String
vGetCurrentDirectory a
fs
       case (String -> String -> Maybe String
absNormPath String
cwd String
path) of
           Maybe String
Nothing -> a -> IOErrorType -> String -> Maybe String -> IO String
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
cwd String -> ShowS
</> String
path))
           Just String
newpath -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
newpath

{- | Gets the full path via 'getFullPath', then splits it via 'nice_slice'.
-}
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 (m :: * -> *) a. Monad m => a -> m a
return (String -> [String]
nice_slice String
newpath)

-- | Find an element on the tree, assuming a normalized path
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MemoryEntry -> IO MemoryEntry
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. [a] -> a
head [String]
sliced1
        t :: [String]
t = [String] -> [String]
forall a. [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. [a] -> a
head String
h) then ShowS
forall a. [a] -> [a]
tail String
h else String
h
        sliced2 :: [String]
sliced2 = String
newh String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
t

        -- Walk the tree
        walk :: MemoryEntry -> [String] -> Either String MemoryEntry
        -- Empty list -- return the item we have
        walk :: MemoryEntry -> [String] -> Either String MemoryEntry
walk MemoryEntry
y [String]
zs
          | [String] -> 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. [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. [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. [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. [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
vRaiseError MemoryVFS
x IOErrorType
doesNotExistErrorType String
err Maybe String
forall a. Maybe a
Nothing
         Right MemoryEntry
result -> MemoryEntry -> IO MemoryEntry
forall (m :: * -> *) a. Monad m => a -> m a
return MemoryEntry
result

-- | Find an element on the tree, normalizing the path first
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
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
           -- Make sure new dir is valid
           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
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 -> -- should never happen due to above getMelem call
                                  MemoryVFS -> IOErrorType -> String -> Maybe String -> IO ()
forall a c.
HVFS a =>
a -> 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 =
        do MemoryEntry
elem <- MemoryVFS -> String -> IO MemoryEntry
getMelem MemoryVFS
x String
fp
           case MemoryEntry
elem of
                     (MemoryFile String
y) -> HVFSStatEncap -> IO HVFSStatEncap
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 (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 =
        do MemoryEntry
elem <- MemoryVFS -> String -> IO MemoryEntry
getMelem MemoryVFS
x String
fp
           case MemoryEntry
elem of
                MemoryFile String
_ -> MemoryVFS -> IOErrorType -> String -> Maybe String -> IO [String]
forall a c.
HVFS a =>
a -> 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 (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) =
        do MemoryEntry
elem <- MemoryVFS -> String -> IO MemoryEntry
getMelem MemoryVFS
x String
fp
           case MemoryEntry
elem of
                MemoryDirectory [MemoryNode]
_ -> MemoryVFS
-> IOErrorType -> String -> Maybe String -> IO HVFSOpenEncap
forall a c.
HVFS a =>
a -> 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HVFSOpenEncap -> IO HVFSOpenEncap
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
vRaiseError MemoryVFS
x IOErrorType
permissionErrorType
                     String
"Only ReadMode is supported with MemoryVFS files"
                     (String -> Maybe String
forall a. a -> Maybe a
Just String
fp)