{- 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)