{- 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
   License    : BSD3

   Maintainer : John Goerzen <jgoerzen@complete.org>
   Stability  : provisional
   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 (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)
import System.FilePath ((</>), pathSeparator, isPathSeparator)

{- | 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 [pathSeparator]
                    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 path
  | path == [pathSeparator] = []
  | otherwise = 
      let sliced1 = slice_path path
          h = head sliced1
          t = tail sliced1
          newh =  if isPathSeparator (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 path
  | path == [pathSeparator] = readIORef (content x) >>= return . MemoryDirectory
  | otherwise =
    let sliced1 = slice_path path
        h = head sliced1
        t = tail sliced1
        newh = if (h /= [pathSeparator]) && isPathSeparator (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 zs
          | null zs = Right y
          | zs == [[pathSeparator]] = Right y
          | otherwise = case y of
              MemoryFile _ -> Left $ "Attempt to look up name " ++ head zs ++ " in file"
              MemoryDirectory y ->
                let newentry = case lookup (head zs) y of
                                  Nothing -> Left $ "Couldn't find entry " ++ head zs
                                  Just a -> Right a
                in do newobj <- newentry
                      walk newobj (tail 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)