MissingH-1.0.0: src/System/IO/HVFS/InstanceHelpers.hs
{- arch-tag: HVFS instance helpers
Copyright (C) 2004 John Goerzen <jgoerzen@complete.org>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{- |
Module : System.IO.HVFS.InstanceHelpers
Copyright : Copyright (C) 2004 John Goerzen
License : GNU GPL, version 2 or above
Maintainer : John Goerzen <jgoerzen@complete.org>
Stability : provisional
Portability: portable
Utilities for creating instances of the items defined in
"System.IO.HVFS".
Copyright (c) 2004 John Goerzen, jgoerzen\@complete.org
-}
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 (newIORef, readIORef, writeIORef, IORef())
import Data.List (genericLength)
import System.IO -- (ReadMode)
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 {
isFile :: Bool, -- ^ True if file, False if directory
fileSize :: FileOffset -- ^ Set to 0 if unknown or a directory
} deriving (Show, Eq)
instance HVFSStat SimpleStat where
vIsRegularFile x = isFile x
vIsDirectory x = not (isFile x)
vFileSize x = fileSize 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 (Eq, Show)
{- | An in-memory read\/write filesystem. Think of it as a dynamically
resizable ramdisk written in Haskell. -}
data MemoryVFS = MemoryVFS
{ content :: IORef [MemoryNode],
cwd :: IORef FilePath
}
instance Show MemoryVFS where
show _ = "<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 s = do r <- newIORef s
newMemoryVFSRef r
-- | Create a new 'MemoryVFS' object using an IORef to an
-- existing tree.
newMemoryVFSRef :: IORef [MemoryNode] -> IO MemoryVFS
newMemoryVFSRef r = do
c <- newIORef "/"
return (MemoryVFS {content = r, cwd = 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 "/" = []
nice_slice path =
let sliced1 = slice_path path
h = head sliced1
t = tail sliced1
newh = if head h == '/' then tail h else h
sliced2 = newh : t
in sliced2
{- | Gets a full path, after investigating the cwd.
-}
getFullPath :: HVFS a => a -> String -> IO String
getFullPath fs path =
do cwd <- vGetCurrentDirectory fs
case (absNormPath cwd path) of
Nothing -> vRaiseError fs doesNotExistErrorType
("Trouble normalizing path " ++ path) (Just (cwd ++ "/" ++ path))
Just newpath -> return newpath
{- | Gets the full path via 'getFullPath', then splits it via 'nice_slice'.
-}
getFullSlice :: HVFS a => a -> String -> IO [String]
getFullSlice fs fp =
do newpath <- getFullPath fs fp
return (nice_slice newpath)
-- | Find an element on the tree, assuming a normalized path
findMelem :: MemoryVFS -> String -> IO MemoryEntry
findMelem x "/" = readIORef (content x) >>= return . MemoryDirectory
findMelem x path =
let sliced1 = slice_path path
h = head sliced1
t = tail sliced1
newh = if (h /= "/") && head h == '/' then tail h else h
sliced2 = newh : t
-- Walk the tree
walk :: MemoryEntry -> [String] -> Either String MemoryEntry
-- Empty list -- return the item we have
walk y [] = Right y
-- Root directory -- return the item we have
walk y ["/"] = Right y
-- File but stuff: error
walk (MemoryFile _) (z : _) =
Left $ "Attempt to look up name " ++ z ++ " in file"
walk (MemoryDirectory y) (z : zs) =
let newentry = case lookup z y of
Nothing -> Left $ "Couldn't find entry " ++ z
Just a -> Right a
in do newobj <- newentry
walk newobj zs
in do
c <- readIORef $ content x
case walk (MemoryDirectory c) (sliced2) of
Left err -> vRaiseError x doesNotExistErrorType err Nothing
Right result -> return result
-- | Find an element on the tree, normalizing the path first
getMelem :: MemoryVFS -> String -> IO MemoryEntry
getMelem x s =
do base <- readIORef $ cwd x
case absNormPath base s of
Nothing -> vRaiseError x doesNotExistErrorType
("Trouble normalizing path " ++ s) (Just s)
Just newpath -> findMelem x newpath
instance HVFS MemoryVFS where
vGetCurrentDirectory x = readIORef $ cwd x
vSetCurrentDirectory x fp =
do curpath <- vGetCurrentDirectory x
-- Make sure new dir is valid
newdir <- getMelem x fp
case newdir of
(MemoryFile _) -> vRaiseError x doesNotExistErrorType
("Attempt to cwd to non-directory " ++ fp)
(Just fp)
(MemoryDirectory _) ->
case absNormPath curpath fp of
Nothing -> -- should never happen due to above getMelem call
vRaiseError x illegalOperationErrorType
"Bad internal error" (Just fp)
Just y -> writeIORef (cwd x) y
vGetFileStatus x fp =
do elem <- getMelem x fp
case elem of
(MemoryFile y) -> return $ HVFSStatEncap $
SimpleStat {isFile = True,
fileSize = (genericLength y)}
(MemoryDirectory _) -> return $ HVFSStatEncap $
SimpleStat {isFile = False,
fileSize = 0}
vGetDirectoryContents x fp =
do elem <- getMelem x fp
case elem of
MemoryFile _ -> vRaiseError x doesNotExistErrorType
"Can't list contents of a file"
(Just fp)
MemoryDirectory c -> return $ map fst c
instance HVFSOpenable MemoryVFS where
vOpen x fp (ReadMode) =
do elem <- getMelem x fp
case elem of
MemoryDirectory _ -> vRaiseError x doesNotExistErrorType
"Can't open a directory"
(Just fp)
MemoryFile y -> newStreamReader y >>= return . HVFSOpenEncap
vOpen x fp _ = vRaiseError x permissionErrorType
"Only ReadMode is supported with MemoryVFS files"
(Just fp)