{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Halfs
--
-- Maintainer  :  Isaac Jones <ijones@galois.com>
-- Stability   :  alpha
-- Portability :  GHC
--
-- High-level interface to Halfs, the Haskell Filesystem.

module Halfs (
              -- * Write-related functions
              unlink, rmdir, rename, mkdir, addChildWrite, openWrite
              ,openAppend, write, writeString, closeWrite
              ,openFileAtPathWrite

              -- * Read-related functions
              ,stat, fstat, openRead ,Halfs.read, closeRead
              ,seek, openFileAtPathRead

              -- * Meta-data functions
              ,fsStats, getDirectoryContents, isDirectory, getDirectoryDetails

              -- * Creating new filesystems
              ,newFS, withNewFSWrite

              -- * Mounting filesystems
              ,mountFS ,unmountFS, unmountWriteFS, mountFSMV
              ,withFSRead, withFSWrite

              -- * Evaluating the 'FSRead' and 'FSWrite' moands
              ,evalFSWriteIOMV, evalFSReadIOMV

              -- * fsck
              ,fsck, fsckWrite
              ,syncPeriodicallyWrite, readReadRef

              -- * Types (most are re-exported from elsewhere)
              ,FSWrite, FSRead, TimeT(..), SizeT
              ,FileHandle, FileMode(..), Halfs.Buffer.Buffer
              ,DeviceLocation, InodeMetadata(..), Inode(..)

              -- * Types to make abstract (FIX)
              ,StateHandle(..), RdStat(..), FileSystemStats(..), FSStatus(..)

              -- * testing
              ,makeFiles, unitTests
              ) where

import Halfs.BasicIO (getMemoryBlock,
                      getInodesBin, readInodeBootStrap,
                      getInodeWrite, getInodeRead, allBlocksInInode)
import Halfs.Blocks(numBlocksForSize)
import Halfs.Buffer(Buffer, buffGetHandle, strToNewBuff, newBuff, buffToStr)
import Halfs.BufferBlockCache(clearBBCache, createCache, checkBBCache)
import qualified Halfs.TheBlockMap as BM (newFS)
import qualified Binary(resetBin)
import Halfs.TheBlockMap (bmTotalSize, freeBlocks)
import Halfs.BuiltInFiles (readInodeMapFile, readBlockMapFile)
import Halfs.CompatFilePath (splitFileName)
import Halfs.Directory (Directory(..), addChild, hasChild,
                        getChildrenNames, emptyDirectoryCache, directoryCacheToList)
import qualified Halfs.FSState (get, put)
import Halfs.FSState(StateHandle(..)
                     -- writing
                     ,FSWrite, readToWrite, modify, runFSWrite
                     ,evalFSWriteIO, runFSWriteIO, unsafeWriteGet
--UNUSED:	     ,unsafeReadGet
		     ,get, put
                     ,updateInodeCacheWrite, evalFSWriteIOMV
                     ,modifyFSWrite
                     -- reading
                     ,FSRead
                     ,runFSRead
                     ,newReadRef, readReadRef, modifyReadRef, writeReadRef
--                     ,readMVarRW
                     ,modifyMVarRW_'
                     ,evalFSReadIOMV
                     -- misc
                     ,evalStateT
                     ,forkFSWrite
                     -- exceptions
                     ,throwError
                     ,alreadyExistsEx
                     -- unsafe FIX: REMOVE
                     ,unsafeLiftIOWrite
                     ,unsafeLiftIORead
                     ,putStrLnWriteRead
                    )

import Halfs.FSRoot(FSRoot(..), FileSystemStats(..),
                    fsRootInode, fsStats, FSStatus(..),
                    fsRootUpdateInodeCache, addToInodeCache, InodeCacheAddStyle(..),
                    getFromInodeCache, fsRootBmInode, emptyInodeCache,
                    InodeCache, fsRootUpdateDirectoryCache,
                    fsRootAllInodeNums)
import Halfs.FileHandle(FileMode(..), fhSeek, allocateInodeWrite
                       ,getDirectoryAtPath, newDirectory
                       ,getInodeAtPath, openFileAtPath, getSomethingAtPath
                       ,fhRead, fhWrite, fhCloseRead
                       ,fhOpenWrite, fhCloseWrite
                       ,fhOpenTruncate, doesPathExist)
import Halfs.TheInodeMap (TheInodeMap(..), emptyInodeMap)
import qualified Halfs.FileHandle as FH (FileHandle(..), unlink, fhInode, fileHandle')
import Halfs.Inode (Inode(..), InodeMetadata(..),
                    newInode, goodInodeMagic,
                    newFSRootDirInode, newFSRootInode, newFSBlockMapInode,
                    newFSInodeMapInode,
                    rootInodeDiskAddr)
import Halfs.SyncStructures (syncFSRoot, syncDirectoryToFile, shortSyncFSRoot)
import Halfs.TestFramework (Test(..), UnitTests, hunitToUnitTest,
                            assertEqual)
import System.RawDevice( RawDevice, makeRawDevice, devBufferRead
                      , newDevice, finalizeDevice)
import Data.Integral(INInt, INLong, fromIntegral' )
import Halfs.Utils(FileType(..), firstFreeInodeNum
                   ,rootInodeMagicNum, otherInodeMagicNum
                   ,mRemoveFile, DiskAddress
                   ,unimplemented, fromJustErr
                   -- inode numbers
                   ,blockMapInodeNum, inodeMapInodeNum, rootDirInodeNum,
                   rootInodeNum
                  )
import Halfs.BufferBlock(mkBufferBlock)
-- base
import Control.Exception -- (assert,catch,throwIO)
import Control.Concurrent(newMVar, MVar, threadDelay, readMVar,myThreadId)
import Control.Monad(unless, when)
import Control.Monad.Error (throwError)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.IORef (IORef)
import Data.Set(Set)
import qualified Data.Set as Set
import Data.Queue (queueToList)
import Foreign.Storable (Storable)
import Foreign.C.Types (CLong)
import Data.List(group,sort)
import System.Exit(exitFailure)

--import System.IO (hPutStrLn,stderr,hFlush)

type FileHandle = IORef FH.FileHandle

-- |The location of a device might be a path to the device on a Linux
-- filesystem.
type DeviceLocation = String

-- |Move this filehandle to given position.
seek :: FileHandle
     -> INLong -- ^What byte offset to move the filehandle to.  Must be > 0 and < the number of bytes in the file.
     -> FSRead ()
seek fh pos = modifyReadRef fh (\fh' -> fhSeek fh' pos)

-- ------------------------------------------------------------
-- * Writing
-- ------------------------------------------------------------

-- |Delete this file.  Currently can be used to delete a directory,
-- but that should probably be FIXED.

unlink :: FilePath -> FSWrite ()
unlink path = do
  let (pathTo, theName) = splitFileName path
  dir@Directory{dirFile=FH.FileHandle{FH.fhInodeNum=_fi, FH.fhSeekPos=_fs}}
      <- readToWrite $ getDirectoryAtPath pathTo
  FH.unlink dir theName
  --ignore the returned directory; FH.unlink updates it in cache
  return ()
--  updateDirectory newDir{dirFile=FH.FileHandle fi fs WriteMode}

-- Remove this empty directory
--                        case mode $ metaData inode of
--                          File -> return () -- no problem
--                          Dir -> do d <- readToWrite $ readDirectory inode
--                                    when (length (filePathsNoDots(getChildrenNames d))
--                                          > 0)
--                                         (throwError (userError ("directory not empty")))
--                          SymLink -> unimplemented "Symlinks"


-- |Unlink this directory.  Should only be called on empty
-- directories.  Does /not/ descent into sub-directories. Should fail
-- if given a file or if the directory is non-empty (but currently
-- doesn't: FIX).
rmdir  :: FilePath -> FSWrite ()
rmdir = unlink -- FIX: fail if it's a file, fail if it's non-empty

-- |Rename this file.  Rename the file named as /From/ to the file
-- named as /To/.  Can throw an exception if /From/ doesn't exist.
rename :: FilePath -- ^From
       -> FilePath -- ^To
       -> FSWrite ()
rename fromPath toPath = do
  let (toParentPath, toName)     = splitFileName toPath
   -- Q: what's the purpose of this next action? Its side-effect?
  _fromInode <- readToWrite $ getInodeAtPath fromPath
  toDirTemp <- readToWrite $ getDirectoryAtPath toParentPath
  toDir <- if toDirTemp `hasChild` toName
               then FH.unlink toDirTemp toName
               else return toDirTemp
  fromInode <- readToWrite $ getInodeAtPath fromPath
  addChildWrite toDir fromInode toName
  unlink fromPath

-- |Create an empty directory at this path.  Throws an error if
-- something already exists at this path.
mkdir :: FilePath -> FSWrite ()
mkdir dirPath = do
  theNewInode <- newChildInode dirPath Dir -- throws error if exists. that's good.
  let dir@Directory{dirFile=FH.FileHandle{FH.fhInodeNum=fi, FH.fhSeekPos=fs}}
          = newDirectory (inode_num $ metaData theNewInode)
  updateDirectory dir{dirFile=FH.fileHandle' fi fs WriteMode}

-- |Like Direcotry.addChild, but in the FSWrite monad, and syncs this
-- directory.
addChildWrite :: Directory   -- ^to add to /directory/
              -> Inode       -- ^new child's /inode/
              -> String      -- ^Name of child to create inside /directory/.
              -> FSWrite Inode
addChildWrite d i f =
  let mRet = addChild d i f
  in case mRet of
      Nothing -> throwError (alreadyExistsEx ("addChildWrite:" ++ f))
      Just (d', i') -> do updateDirectory d'
                          updateInodeCacheWrite i'
                          return i'

-- |Creates child inode based on the path
newChildInode :: FilePath -- ^path components, last component is name, previous components are parent directories. all parents must exist, child must not exist.
              -> FileType
              -> FSWrite Inode
newChildInode dirs filetype = do
  let (pathTo, childFileName) = splitFileName dirs
  parentDirTemp <- readToWrite $ getDirectoryAtPath pathTo
  parentDir <- if parentDirTemp `hasChild` childFileName
               then FH.unlink parentDirTemp childFileName
               else return parentDirTemp
  inodeNum <- allocateInodeWrite
  let inode = newInode inodeNum filetype
  addChildWrite parentDir inode (assert (goodInodeMagic inode) childFileName)

{-
-- |Open the given file for writing. FIX: Test
openTrunc :: FilePath
          -> FSWrite FileHandle
openTrunc path =
  (openFileAtPathWrite WriteMode path File True >>= readToWrite . newReadRef)
-}

-- |Open the given file for writing.  If a file exists at this
-- location, it gets overwritten. FIX: Test
openWrite :: FilePath
          -> FSWrite FileHandle
openWrite = openHelper WriteMode

-- |Open the given file for appending. If a file already exists at
-- this location, it gets opened for writing, and the file pointer is
-- pointing to the end.  FIX: Test, what does it do if no such file exists.
openAppend :: FilePath
           -> FSWrite FileHandle
openAppend = openHelper AppendMode

-- |Abstraction over 'openWrite' and 'openAppend'.
openHelper :: FileMode
           -> FilePath
           -> FSWrite FileHandle
openHelper mode path
    = openFileAtPathWrite mode path File False >>= readToWrite . newReadRef

-- |Much like getDirectoryAtPath, builds a handle out of this
-- filepath.  May throw IO Error! FIX: annotate w\/ errors
-- thrown. FIX: throw errors for incorrect mode.

openFileAtPathWrite :: FileMode
                    -> FilePath
                    -> FileType -- for WriteMode only
                    -> Bool     -- truncate?
                    -> FSWrite FH.FileHandle
openFileAtPathWrite WriteMode path _theMode True = do
  inode <- readToWrite $ getSomethingAtPath (\i -> return i) path
  fhOpenTruncate $ inode_num $ metaData inode
openFileAtPathWrite WriteMode path theMode False = do
  inode <- newChildInode path theMode
  fhOpenWrite $ inode_num $ metaData inode
openFileAtPathWrite AppendMode path _ _ = do
  Inode{metaData=InodeMetadata{mode=m
                              ,inode_num=i
                              ,num_bytes=loc}}
      <- readToWrite (getSomethingAtPath (\i -> return i) path)
  case m of
    File -> do fh <- fhOpenWrite i
               return fh{FH.fhMode=AppendMode
                        ,FH.fhSeekPos=loc}
    Dir -> throwError (userError (dirFileError path))
    SymLink -> unimplemented "Symlinks"
openFileAtPathWrite md path _ _ =
  throwError (userError ("openFileAtPathWrite: unsupported file mode " ++ show (md,path)))

openFileAtPathRead :: FilePath
                   -> FSRead FH.FileHandle
openFileAtPathRead path =
  getSomethingAtPath (\Inode{metaData=InodeMetadata{mode=m
                                                  ,inode_num=i}}
                          -> case m of
                              File -> do
                                         return $ FH.fileHandle' i 0 ReadMode
                              Dir -> throwError (userError (dirFileError path))
                              SymLink -> unimplemented "Symlinks")
                      path

dirFileError :: FilePath -> String
dirFileError path = "directory encountered where file expected: " ++ path

-- |Write from the given buffer into the file.
write :: FileHandle
      -> Buffer -- ^Buffer to write from
      -> INInt  -- ^Offset into above buffer FIX: should we allow current loc
      -> INInt  -- ^How many to write
      -> FSWrite INInt
write fRef b off num = do
  f <- readToWrite $ readReadRef fRef
  (outF, i) <- fhWrite f (buffGetHandle b) off num
  readToWrite $ writeReadRef fRef outF
  return i

-- |Helpfer function for writing a string to a file.
writeString :: FileHandle
            -> String
            -> FSWrite INInt
writeString h s = do
  b <- unsafeLiftIOWrite $ strToNewBuff s
  write h b 0 (fromIntegral $ length s)

-- |Close a file that's open for writing.
closeWrite :: FileHandle -> FSWrite ()
closeWrite f = do (readToWrite $ readReadRef f) >>= fhCloseWrite
--		  fsckWrite

-- ------------------------------------------------------------
-- * Reading
-- ------------------------------------------------------------

-- |Get basic information about the file at this path.
stat :: FilePath -> FSRead RdStat
stat f = do
  h <- openRead f
  s <- fstat h
  closeRead h
  return s

-- |Get basic information about this file handle.
fstat :: FileHandle -> FSRead RdStat
fstat f = do
  h <- readReadRef f
  Inode{metaData=InodeMetadata{mode=m
                              ,num_bytes=sz}} <- FH.fhInode h
  case m of
   File -> return $ RdFile (TimeT 0) sz
   Dir  -> return $ RdDirectory (TimeT 0)
   SymLink -> unimplemented "fstat{SymLink}"

-- |Does this filepath refer to a directory?
isDirectory :: FilePath -> FSRead Bool
isDirectory f = do
  h' <- openRead f
  h <- readReadRef h'
  inode <- FH.fhInode h
  let ret = case mode $ metaData inode of
            File -> False
            Dir  -> True
            SymLink -> unimplemented "isDirectory{SymLink}"
  closeRead h'
  return ret


-- |Open this file for reading. FIX: test.
openRead :: FilePath
         -> FSRead FileHandle
openRead path = openFileAtPath path ReadMode >>= newReadRef

-- |Read from this file handle into this buffer.
read :: FileHandle
     -> Buffer -- ^Buffer to read into
     -> INInt  -- ^Offset into above buffer
     -> INInt  -- ^How many to read
     -> FSRead INInt
read fref b off sz = do
  f <- readReadRef fref
  (f', i) <- fhRead f (buffGetHandle b) off sz
  writeReadRef fref f'
  return i

-- |Close a filehandle that's open for reading.
closeRead :: FileHandle -> FSRead ()
closeRead h = do readReadRef h >>= fhCloseRead
--		 fsckRead

-- |Get the contents of a directory.
getDirectoryContents :: FilePath -> FSRead [FilePath]
getDirectoryContents path
    = getDirectoryAtPath path >>= return . getChildrenNames

-- |Caller may want to filter out "." and ".."
getDirectoryDetails :: FilePath -> FSRead [(String, Inode)]
getDirectoryDetails path = do
  namesNums <- getDirectoryAtPath path >>= return . Map.toList . dirContents
  mapM (\(n,iNum) -> do i <- getInodeRead iNum Nothing
                        return (n, i)) namesNums

-- ------------------------------------------------------------
-- * Mounting and Control Interface
-- ------------------------------------------------------------

-- |Mount the given file system for writing and perform these
-- operations. FIX: Maybe add MVar () for blocking on.
withFSWrite :: DeviceLocation              -- ^Location of device
            -> FSWrite a -- ^Operations to perform
            -> IO a
withFSWrite path f = do
  fsroot <- mountFS Nothing path False 500
  blockOn <- newMVar fsroot
  evalStateT (runFSWrite f) (StateHandle blockOn Nothing)

-- |Mount the given file system for reading and perform these
-- operations.
withFSRead :: DeviceLocation              -- ^Location of device
           -> FSRead a -- ^Operations to perform
           -> IO a
withFSRead path f = do
  fsroot <- mountFS Nothing path True 500 -- Nothing == No read-down.
  rootVar  <- newMVar fsroot
  evalStateT (runFSRead f) (StateHandle rootVar Nothing)

-- |Create a new file system and perform the given operations.  Unmounting
-- is up to the caller.  See 'newFS' for parameter details.
withNewFSWrite :: String
               -> INInt
               -> FSWrite a -- ^Operations to perform
               -> IO a
withNewFSWrite path len f = do
  mRemoveFile path
  newFS path len
  withFSWrite path f

-- ------------------------------------------------------------
-- * Mounting and Control Helpers
-- ------------------------------------------------------------

-- |Creates a new filesystem with a real-life root inode! Out of thin
-- air, create a buffer block for this device, 0, and write root inode
-- to our new cache.
newFS :: DeviceLocation
      -> INInt  -- ^desired length of the new filesystem in blocks
      -> IO ()
newFS path fileLen = do
  -- this block map marks 0 and 1 as used:

  dev <- newDevice Nothing path fileLen

--  realBlocks <- blocksInDevice dev
--  when (realBlocks < (fromIntegral fileLen))
--        (error $ "requested FS size greater than physical disk.  blocks: " ++ (show fileLen) ++ " size: " ++ (show realBlocks))

  theCache <- createCache 500
  let blockMap' = BM.newFS fileLen

  let d = newDirectory rootDirInodeNum
  let fsroot'    = FSRoot dev theCache blockMap' emptyInodeCache
                         (emptyInodeMap firstFreeInodeNum)
                         emptyDirectoryCache FsReadWrite

  -- add various distinguished inodes to the inode cache
  let fsroot = foldl fsRootUpdateInodeCache fsroot' [newFSRootInode
                                                    ,newFSBlockMapInode
                                                    ,newFSInodeMapInode
                                                    ,newFSRootDirInode]
  -- Write out the root directory. FIX: Remove when we have diredctory cache?
  (_, fsroot1) <- runFSWriteIO (syncDirectoryToFile d) fsroot

  -- sync the FS and close the device
  unmountFS fsroot1
	-- You cant return the cache, because we lose it when we unmount
	--   return theCache
  return ()
  -- todo: new inode map
  -- todo: flush cache

-- |Periodically sync the filesystem.  Usually forked off in its own
-- thread.  For READS: Flush caches on read-only filesystem (so
-- they'll be re-populated). For WRITES: write out the filesystem
-- data. FIX: remove readOnly; that's in the fsroot.  FIX: add
-- exception handler (since it does a take)
syncPeriodicallyWrite :: MVar () -- ^High-level blocker.  This function blocks on this mvar.
                      -> Bool
                      -> FSWrite ()
syncPeriodicallyWrite blockOn readOnly = do
  FSRoot{fsStatus=status} <- unsafeWriteGet -- safe
  putStrLnWriteRead $ "Periodically syncing: " ++ (show status)
  case status of
    FsUnmounted -> putStrLnWriteRead "exiting periodic thread." -- done with this thread.
    _ -> do
      modifyMVarRW_' blockOn (\_ -> do
           putStrLnWriteRead "taken."
           case status of
              FsReadOnly -> do r <- get
                               fsroot <- unsafeLiftIOWrite $ fsRootClearCaches r
                               put (assert (readOnly == True) fsroot)

              FsReadWrite -> do FSRoot{device=_d} <- unsafeWriteGet
                                assert (readOnly == False) shortSyncFSRoot
              FsUnmounted -> assert False (return ())
         )
      putStrLnWriteRead "sync completed."
      unsafeLiftIOWrite $ threadDelay $ secondToMicroSecond 60
      syncPeriodicallyWrite blockOn readOnly

secondToMicroSecond :: Int -> Int
secondToMicroSecond n = n * 1000000

fsRootClearCaches :: FSRoot -> IO FSRoot
fsRootClearCaches fsroot = do
  clearBBCache (assert ((fsStatus fsroot) == FsReadOnly) (bbCache fsroot))
  newInodeCache <- getDistinguishedInodes (device fsroot)
  -- might need to move this up if getDistinguishedInodes needs it.
  return (fsroot {inodeCache=newInodeCache
                 ,directoryCache=emptyDirectoryCache
                 })

getDistinguishedInodes :: RawDevice -> IO InodeCache
getDistinguishedInodes rawDev = do
  -- todo get inode numbers of block map, inodemap and root directory
  -- from root inode. hard-coded in Utils for now.

  -- re-read the fundamental inodes from disk.
  rootInodeBuffer <- getMemoryBlock
  rootInodeBufferBlock <- mkBufferBlock rootInodeBuffer rawDev rootInodeDiskAddr
  devBufferRead rawDev rootInodeDiskAddr rootInodeBuffer
  Binary.resetBin rootInodeBuffer
--   sequence $ map (\_ -> do (w::Word8) <- Binary.get rootInodeBuffer
--                            putStr (show w)
--                            putStr ",") (replicate 200 ())
  Binary.resetBin rootInodeBuffer
  (readRootInode:_) <- getInodesBin rootInodeBufferBlock
  -- get inode of blockMap using blockMapInodeNum
  (_newBlockMapInode, newInodeCache')
       <- readInodeBootStrap (fst $ addToInodeCache InodeCacheOverwrite
                                       (emptyInodeCache, rootInodeNum)
                                       (assert (goodInodeMagic readRootInode) readRootInode))
                             rawDev readRootInode blockMapInodeNum
  (_inodeMapInode, newInodeCache'')
       <- readInodeBootStrap newInodeCache' rawDev readRootInode inodeMapInodeNum
  (_newRootDirInode, newInodeCache)
       <- readInodeBootStrap newInodeCache'' rawDev readRootInode rootDirInodeNum
  return newInodeCache

-- |See 'mountFS' for most documentation.
mountFSMV :: Maybe StateHandle
          -> DeviceLocation
          -> Maybe (MVar () ) -- ^the outermost-blocker, if desirable.  causes a synchronization thread to be spawned
          -> Bool
	  -> Int -- ^cache size
          -> IO StateHandle
{-
mountFSMV mSH path (Just mCache) blockOn readOnly cacheSize = do
  fsr <- mountFS mSH path mCache readOnly
  mv <- newMVar fsr
  let sh = StateHandle mv blockOn
  case blockOn of
    Nothing -> return ()
    Just b -> evalFSWriteIOMV (forkFSWrite (syncPeriodicallyWrite b readOnly)>> return ()) sh
  return sh
-}
mountFSMV mSH path blockOn readOnly cacheSize = do
   -- Q: what's the purpose of this next action?
  _c <- createCache cacheSize
  mv <- mountFS mSH path readOnly cacheSize >>= newMVar
  let sh = StateHandle mv blockOn
  case blockOn of
    Nothing -> return ()
    Just b -> evalFSWriteIOMV (forkFSWrite (syncPeriodicallyWrite b readOnly)>>return ()) sh
  return sh

-- |Basic low-level @mount@ operation.  Usually used via wrappers such as 'withFSWrite' and 'withFSRead'.  See also 'newFS'.
mountFS :: Maybe StateHandle -- ^if Just, use the raw device inside
        -> DeviceLocation    -- ^Location of device
        -> Bool              -- ^Read only?
	-> Int               -- ^buffer block cache size
        -> IO FSRoot
mountFS mSH path readOnly cacheSize = do
  (mRD,cache)
      <- case mSH of
          Nothing -> do cache <- createCache cacheSize
		        return (Nothing,cache)
          Just (StateHandle shM _) -> do FSRoot{device=r, bbCache=c} <- readMVar shM
                                         return $ (Just r,c)
  rawDev <- makeRawDevice mRD path
  -- read root inode
  inodeCache1 <- getDistinguishedInodes rawDev

  -- using fromJustErr here because the above call populates the inode
  -- cache, and we can't call getInode (which is safer) yet because we
  -- don't have a fully-formed fsroot
  let newBlockMapInode = fromJustErr "block map inode not in inode cache during mount"
                           (getFromInodeCache inodeCache1 blockMapInodeNum)
  let inodeMapInode    = fromJustErr "inode map inode not in inode cache during mount"
                           (getFromInodeCache inodeCache1 inodeMapInodeNum)

  -- read block map
  -- have to fake up an fsroot for bootstrapping here.
  let partFsroot = FSRoot rawDev cache
                       (error "undefined") inodeCache1
                       (emptyInodeMap firstFreeInodeNum)
                       emptyDirectoryCache
                       (if readOnly then FsReadOnly else FsReadWrite)
  -- warning! fsroot not fully formed:
  (_, fsroot) <- runFSWriteIO -- makes its own mvar :(
    (do bm <- readToWrite $ readBlockMapFile newBlockMapInode
        modify (\fsroot -> fsroot{blockMap=bm})
        im <- readToWrite $ readInodeMapFile inodeMapInode

        modify (\fsroot -> fsroot{inodeMap=im})
    ) partFsroot
  return fsroot

-- |Syncs the device and closes its handle.  You should stop using it
-- after that.  Must represent an open device!
unmountFS :: FSRoot -> IO ()
unmountFS fsroot@FSRoot{device=d, fsStatus=status} = do
  when (status==FsReadWrite) (evalFSWriteIO syncFSRoot fsroot)
  finalizeDevice d
--   evalFSWriteIO get fsroot -- couln't work; should take the mvar or something.
  return ()

-- |Just like 'unmountFS' but in the 'FSWrite' monad.
unmountWriteFS :: FSWrite ()
unmountWriteFS = do
  modifyFSWrite $ \fsr@FSRoot{fsStatus=status} -> do
    unsafeLiftIOWrite $ unmountFS (assert (status==FsReadWrite) fsr)
    return (fsr{fsStatus=FsUnmounted}, ())
  return ()

-- |Check the filesystem for errors.  Exits with an error code and
-- message if any are found.  Outputs lots of low-level data to the
-- terminal.

fsck :: DeviceLocation -> IO ()
fsck devPath = do
  fsroot <- mountFS Nothing devPath True 500
  fsck' fsroot

fsck' :: FSRoot -> IO ()
fsck' fsroot@FSRoot{inodeMap=theInMap
                   ,directoryCache=dirCache
                   ,bbCache=bbC
                   ,blockMap=theBlockMap} = catchAll $ do
  let totalBlocks = bmTotalSize theBlockMap
  tid <- myThreadId
  putStrLn $ "############################ F S C K ##############################" ++ show tid
  putStrLn $ "root inode: " ++ (show $ fsRootInode fsroot)
  putStrLn $ "blockMap inode: " ++ (show $ fsRootBmInode fsroot)
  bbCacheInfo <- checkBBCache bbC
  putStrLn $ "(bbCacheSize, bbCacheNumDirty,hits,misses): " ++ (show bbCacheInfo)
  let maxInode = (imMaxNum theInMap) - 1
  let allPossibleBlocks = Set.fromList $ [0 .. (totalBlocks - 1)]
  let allInodeNums = fsRootAllInodeNums fsroot
  putStrLn $ "Max inode num: " ++ (show maxInode)
  putStr $ "There are a total of: " ++ (show $ Set.size allInodeNums) ++ " inodes"
  putStrLn $ " and " ++ (show $ length $ freeInodes theInMap) ++ " free inodes."
  putStrLn $ "Free Inodes: " ++ (show $ freeInodes theInMap)

{-  unless ((cardinality allInodeNums) + (length $ freeInodes theInMap) == maxInode)
         (error "all inode nums doesn't add up (see above)")
-}

  let dirInodeNums = show [FH.fhInodeNum (dirFile d)
                               | d <- directoryCacheToList dirCache]
  putStrLn $ "inode nums in directory cache: " ++ dirInodeNums
  (_, _fsroot) <- runFSWriteIO (do
    let mapabs = Set.map abs
    let freeList= queueToList (freeBlocks $ blockMap fsroot)
    let freeSet = mapabs $ Set.fromList $ freeList

    when (Set.size freeSet /= length freeList) (
       error $ "freeList contains duplicates, should never happen: " ++
		   show [ head vs
			| vs <- group (sort freeList)
		        , length vs > 1
		        ])

    theMapping <- buildBlockToInodeMapping (Set.toList allInodeNums) allPossibleBlocks Map.empty
    putStrLnWriteRead $ "The block map [(blockNum, inodeNum)]: " ++ (show $ Map.toList theMapping)
    let usedBlocks = mapabs $ Set.fromList $ Map.keys theMapping
    let usedBlocksMarkedFree = freeSet `Set.intersection` usedBlocks

    unless (Set.null usedBlocksMarkedFree)
           (do let theBadPairs = getPairsFor (Set.toList usedBlocksMarkedFree) theMapping
               badInodes <- mapM (\(_,x) -> getInodeWrite x Nothing) theBadPairs
               error $ "used blocks in inodes marked as free. [(blockNum, inodeNum)]: "
                  ++ (show $ theBadPairs) ++ "\n" ++ (show badInodes)
           )

    let leakedBlocks = allPossibleBlocks `Set.difference` (freeSet `Set.union` usedBlocks)
    unless (Set.null leakedBlocks) (error $ "Leaked blocks: "
                                                ++ (show $ Set.toList leakedBlocks))
      ) fsroot

  putStrLn $ "(END)####################### F S C K ###########################(END)" ++ show tid
  return ()
      where getPairsFor :: (Show a,Ord a) => [a] -> Map a b -> [(a,b)]

            -- this fromJustErr should never break;
            -- list is taken from the map itself:
            getPairsFor theElems mapping
                = [(x, fromJustErr
                         ("attempt to look up element not in mapping: " ++ show x)
                         (Map.lookup x mapping))
                   | x <- theElems]

	    catchAll body = Control.Exception.catch body
						(\ e -> do putStrLn "fsck' failure"
							   print e
							   exitFailure)


-- |See 'fsck'.
fsckWrite :: FSWrite ()
fsckWrite = unsafeWriteGet >>= unsafeLiftIOWrite . fsck'

{- UNUSED:
fsckRead :: FSRead ()
fsckRead = unsafeReadGet >>= unsafeLiftIORead . fsck'
-}

-- |Lookup all the inodes, get their block pointers, and verify that
-- no two inodes have the same block pointer, in which case, crashes
-- with an error for now.
buildBlockToInodeMapping :: [INInt] -- ^All inode nums
			-> Set DiskAddress		-- ^ all possible disk addresses
                         -> Map DiskAddress INInt -- initial mapping
                         -> FSWrite (Map DiskAddress INInt)
buildBlockToInodeMapping [] _allAddr inMap = return inMap
buildBlockToInodeMapping (inodeNum:t) allAddr inMap = do
  inode <- getInodeWrite inodeNum Nothing
  -- FIX: need to check level-two blocks too :(
  allBlocks <- allBlocksInInode (assert (goodInodeMagic inode) inodeNum)
  let numBlocksInInode = length allBlocks
  when (numBlocksForSize inode > fromIntegral' numBlocksInInode)
      (error $ "The inode does not have enough blocks to match its size.  Number it should have, based on size: " ++ (show (numBlocksForSize inode)) ++ " number it actually has: " ++ (show numBlocksInInode) ++ "\n" ++ show inodeNum ++ "\n" ++ show inode)
--  when (inodeNum == 107) (
--	unsafeLiftIOWrite $ print ("inside 107 : ",allBlocks,inode)
--   )


  let newMap = checkInodeBlocks allBlocks
                                (inode_num $ metaData inode) allAddr inode inMap
  buildBlockToInodeMapping t allAddr newMap

-- |Called by 'fsck'.  Checks consistency of the blocks in the given
-- inode.  Checks for inodes with invalid block numbers, two inodes
-- with the same block.
checkInodeBlocks :: [DiskAddress]
                 -> INInt -- inode number
		 -> Set DiskAddress
		 -> Inode
                 -> Map DiskAddress INInt
                 -> Map DiskAddress INInt
checkInodeBlocks [] _ _allAddr _ inMap = inMap
checkInodeBlocks (blk:t) inodeNum allAddr inode inMap
    | blk == 0 && (not (inodeNum == 0)) -- first block of root inode
            = assert False inMap -- should already be filtered.
    | not (abs blk `Set.member` allAddr)
		= error $ "inode with invalid block number: inode=" ++
				show inodeNum ++ " addr = " ++ show blk ++ "\n" ++
				show inode
    | otherwise =
        case Map.lookup blk inMap of
           Nothing -> keepGoing
           -- FIX: probably want to do better sort of error checking
           Just a  -> if (a /= inodeNum)
                      then error $ "two inodes with same block: "
                               ++ (show a) ++ " & " ++ (show inodeNum)
                               ++ " block number: " ++ (show blk)
                      else keepGoing
    where keepGoing = checkInodeBlocks t inodeNum allAddr inode (Map.insert blk inodeNum inMap)

-- ------------------------------------------------------------
-- * Misc
-- ------------------------------------------------------------

-- |This seems to be the kind of Stat information needed by the TSE
-- front end.
data RdStat
  = RdDirectory{ modTime :: TimeT }
  | RdFile{ modTime :: TimeT, size :: SizeT }
  deriving (Eq, Show)

{- UNUSED:
notDone :: a
notDone = error "Undefine"
-}

newtype TimeT = TimeT CLong deriving (Show, Read, Eq, Storable, Ord)


type SizeT = INLong
-- type Buffer = BinHandle

-- |Updates this directory's entry in the cache
updateDirectory :: Directory -> FSWrite ()
updateDirectory dir =
  modify (fsRootUpdateDirectoryCache dir)

-- ------------------------------------------------------------
-- * Testing
-- ------------------------------------------------------------

testFSLoc :: FilePath
testFSLoc = "halfs-client1"

unitTests :: Bool -> UnitTests
unitTests fast = hunitToUnitTest (hunitTests fast)

theContents :: [FilePath]
theContents =  ["bin", "dev", "etc", "lib", "tmp"]

dirFS :: FilePath
dirFS = "halfs-client1"

assertEqualWrite :: (Eq a, Show a) => String -> a -> a -> FSWrite ()
assertEqualWrite s a b = unsafeLiftIOWrite $ assertEqual s a b

-- |for testing. Create some files in the given directory
makeFiles :: Int -- ^Number of files
          -> FilePath -- ^Where to put them
          -> String -- empty if you don't want to write anything to it
          -> FSWrite ()
makeFiles n p s | n <= 0 = return ()
                | otherwise = do
  h <- openWrite $ p ++"/" ++ "smallFile" ++ (show n)
  when (s /= "")
    (writeString h s>>return())
  closeWrite h
  makeFiles (n - 1) p s

makeManyFiles :: Int        -- ^Number of files
              -> FilePath   -- ^where to put them
	      -> FSWrite ()
makeManyFiles numFiles dirLoc = do
  putStrLnWriteRead $ "creating " ++ (show numFiles)
                          ++ " files in " ++ (show dirLoc)
  -- num blocks = numFiles * (inodesPerBlock / bytesPerInode)
  makeFiles numFiles dirLoc ""
  dirs <- readToWrite $ getDirectoryContents dirLoc
  assertEqualWrite "correct size after creating a few files"
                    (numFiles + 1) (length dirs)
  assertEqualWrite "dot in dir" "." (head dirs)
  fsckWrite

slowTests :: [Test]
slowTests =
  [
   TestLabel "large fs" $ TestCase $ do
      newFS dirFS 40000 -- a big filesystem
      fsroot <- mountFS Nothing dirFS True 500
      fsck' fsroot
      unmountFS fsroot
   ,TestLabel "MANY files" $ TestCase $ withFSWrite dirFS $ do
    -- depends on previous large filesystem case
      makeManyFiles 10000 "/"
      unmountWriteFS
   ,TestLabel "re-mounting after writing MANY files" $ TestCase $ do
      fsroot <- mountFS Nothing dirFS False 500
      unmountFS fsroot

   , TestLabel "some appends" $ TestCase $ do
    withNewFSWrite dirFS 10 (unmountWriteFS)
    withFSWrite dirFS $ do
      h <- openWrite "/log"
      closeWrite h
      sequence [ do fd <- openAppend "/log"
	    	    writeString fd (show i)
		    closeWrite fd
               | i <- [(1::Int)..100]
	       ]
      fsckWrite
      unmountWriteFS
   ,TestLabel "many appends" $ TestCase $ do
    let count = 50
    withNewFSWrite dirFS 20 (unmountWriteFS)
    withFSWrite dirFS $ do
      fsckWrite
      let input = [ init (take (n `mod` 1003) (cycle (show i ++ ","))) ++ "#"
		  | (i,n) <- zip [(1::Int)..] (take count $ iterate (* 234587) 1)
	 	  ]
      mkdir "/test"
      h <- openWrite "/test/log"
      closeWrite h
      sequence [ do fd <- openAppend "/test/log"
		    writeString fd str
--                  unsafeLiftIOWrite $ print $ "writing : " ++ show str
		    closeWrite fd
		    let str_ref = concat (take i input)
		    readToWrite $ do
  		      fd2 <- openRead "/test/log"
		      buff <- unsafeLiftIORead $ newBuff (length str_ref)
		      n <- Halfs.read fd2 buff 0 (fromIntegral $ length str_ref)
		      if (fromIntegral n == length str_ref)
			then return ()
			else error $ "read incorrect number of bytes"
	              closeRead fd2
		      str_read <- unsafeLiftIORead $ buffToStr buff
--                      unsafeLiftIORead $ print $ "compareing : " ++ show (str_ref,str_read)
		      if str_ref == str_read
		        then return ()
			else error ("append failed to write then read at byte: " ++
				    show (head [ j | (j,a,b) <- zip3 [(0::Int)..] str_ref str_read, a /= b ],n,i))

		| (i,str) <- zip [1..] input ]
      fsckWrite
      unmountWriteFS

   , TestLabel "large, large file" $ TestCase $ do
      newFS dirFS 40000 -- a big filesystem
      fsroot <- mountFS Nothing dirFS True 500
      unmountFS fsroot
      withFSWrite dirFS $ do
        h <- openWrite "/large"
        closeWrite h
        sequence [ do fd <- openAppend "/large"
                      writeString fd ((show i) ++ take 1031 (cycle "#"))
                      closeWrite fd
                      when ((i `mod` 1000) == 0) $
                                fsckWrite
                 | i <- [(1::Int)..10000]
               ]
        fsckWrite
        unmountWriteFS

   , TestLabel "smaller fs" $ TestCase $ do
      withNewFSWrite dirFS 500 (unmountWriteFS)
  ]

hunitTests :: Bool -> [Test]
hunitTests fast =
  [TestLabel "isaacfs and read root inode" $ TestCase $ do
--     mRemoveFile testFSLoc
     newFS testFSLoc 10 -- creates the file system
     -- verify that the root inode has the right magic number:
     dev <- makeRawDevice Nothing testFSLoc
     buffer <- getMemoryBlock
     bb <- mkBufferBlock buffer dev 0
     devBufferRead dev 0 buffer
     (rootInode':_) <- getInodesBin bb
     assertEqual "root inode magic number incorrect"
                 rootInodeMagicNum
                 (magic1 $ metaData rootInode')
     finalizeDevice dev

  ,TestLabel "mounting fs" $ TestCase $ do
     fsr <- mountFS Nothing testFSLoc False 500
     fsck' fsr
     assertEqual "root inode magic number incorrect"
                 rootInodeMagicNum
                 (magic1 $ metaData $ fsRootInode fsr)
     assertEqual "block map magic number incorrect"
                 otherInodeMagicNum
                 (magic1 $ metaData $ fsRootBmInode fsr)
     unmountFS fsr
  ,TestLabel "mounting and unmount a lot" $ TestCase $ do
     mountFS Nothing testFSLoc True 500 >>= unmountFS
     mountFS Nothing testFSLoc True 500 >>= unmountFS
     mountFS Nothing testFSLoc True 500 >>= unmountFS
     fsroot <- mountFS Nothing testFSLoc True 500
     fsck' fsroot
     unmountFS fsroot
  ,TestLabel "getInode" $ TestCase $ withNewFSWrite
                 "halfs-client1" 500 (do
     theNewInode <- getInodeWrite 16 Nothing
     unless ((magic1 $ metaData theNewInode) == otherInodeMagicNum)
            (error "bad magic in getInode case")
--     let addr = getPointerAt theNewInode 0
     unmountWriteFS)
  ,TestLabel "making directories in memory" $ TestCase $
   withNewFSWrite dirFS 500  (do
     let ls = readToWrite . getDirectoryContents
         mkdirs = mapM_ mkdir
     mkdirs (map ('/':) theContents)
     mkdirs ["/lib/modules"
            ,"/lib/w00t"
            ,"/lib/w00t/foo"
            ,"/lib/init" -- will get overwritten
            ,"/lib/modules/foo"
            ,"/lib/modules/bar"
            ,"/lib/modules/bar/bang"]
     wootInode <- readToWrite $ getInodeAtPath "/lib/w00t"
     assertEqualWrite "hardLinks after mkdir" 1 (hard_links $ metaData wootInode)
     syncFSRoot
     wootInode1 <- readToWrite $ getInodeAtPath "/lib/w00t"
     assertEqualWrite "hardLinks after sync" 1 (hard_links $ metaData wootInode1)
     fsckWrite

     rename "/lib/w00t" "/lib/init"

     syncFSRoot
     fsckWrite

     ls "/lib/init" >>= assertEqualWrite "move directory worked" [".","foo"]

     ls "/" >>= assertEqualWrite "slash equal contents" (".":theContents)

     ls "/etc" >>= assertEqualWrite "etc dir empty pre-unmount" ["."]

     ls "/lib" >>= assertEqualWrite "lib dir has modules pre-unmount"
                        [".", "init", "modules"]

     ls "/lib/modules" >>= assertEqualWrite "lib dir has modules pre-unmount"
                        [".", "bar", "foo"]

     ls "/lib/modules/bar" >>= assertEqualWrite "lib dir has modules pre-unmount"
                        [".", "bang"]

     syncFSRoot
     fsckWrite
     syncFSRoot
     fsckWrite
     unmountWriteFS)
  ,TestLabel "remounting and seeing directories" $ TestCase $ do
    putStrLn "mounting for 'remount'"
    withFSWrite dirFS (do
     fsckWrite
     let ls = readToWrite . getDirectoryContents
         rm = unlink
     ls "/"    >>= assertEqualWrite "/ has theContents" (".":theContents)
     ls "/etc" >>= assertEqualWrite "etc dir empty post-unmount" ["."]

     ls "/lib" >>= assertEqualWrite "lib dir has modules post-unmount"
                        [".", "init", "modules"]
     ls "/lib/modules" >>= assertEqualWrite "lib dir has modules post-unmount"
                               [".", "bar", "foo"]
     ls "/lib/modules/bar" >>= assertEqualWrite "lib dir has modules post-unmount"
                               [".", "bang"]
     p <- readToWrite $ doesPathExist "/lib/modules/bar/bang"
     assertEqualWrite "path that does exist" p True

     p1 <- readToWrite $ doesPathExist "/no/way"
     assertEqualWrite "path that does not exist" p1 False

     rm "/lib/modules/bar/bang"
     ls "/lib/modules/bar" >>= assertEqualWrite "removing a dir non-root"
                               ["."]
{-     unsafeMkFSWrite $ copyFromHostT "tests/smallFile" "/etc/smallFile"
     ls "/etc" >>= assertEqualWrite "etc has smallFile" [".", "smallFile"]
     rm "/etc/smallFile"-}
     ls "/etc" >>= assertEqualWrite "etc delete smallFile" ["."]
     rm "/etc"
     ls "/" >>= assertEqualWrite "remove a dir in root" (filter (/= "etc") (".":theContents))

     -- Overflow a block boundry with a write:
     fh <- openWrite "/tempFile"
     myBuf <- unsafeLiftIOWrite $ strToNewBuff "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
     readToWrite $ seek fh 4093
     write fh myBuf 0 50

     fsroot <- unsafeWriteGet
     getInodeWrite blockMapInodeNum Nothing >>=
           assertEqualWrite "read blockmap inode equals one in root"
                (fsRootBmInode fsroot)
     unmountWriteFS)
   ,TestLabel "mount and unmount after serveral syncs" $ TestCase $
     withFSWrite dirFS unmountWriteFS
   ,TestLabel "a few files" $ TestCase $ withNewFSWrite dirFS 50000 $ do
      makeManyFiles 50 "/"
      unmountWriteFS
   ,TestLabel "re-mounting after writing a few files" $ TestCase $ do
      fsroot <- mountFS Nothing dirFS False 500
      fsck' fsroot
      unmountFS fsroot
   ,TestLabel "a few files, in a non-root directory" $ TestCase $
    withFSWrite dirFS $ do
      fsckWrite
      mkdir "/test"
      makeManyFiles 200 "/test"
      unmountWriteFS
   ,TestLabel "large fs" $ TestCase $ do
      newFS dirFS 40000 -- a big filesystem
      fsroot <- mountFS Nothing dirFS True 500
      fsck' fsroot
      unmountFS fsroot
   ,TestLabel "quite a few files" $ TestCase $ withFSWrite dirFS $ do
    -- depends on previous large filesystem case
      makeManyFiles 1000 "/"
      unmountWriteFS
   ,TestLabel "re-mounting after writing quite a few files" $ TestCase $ do
      fsroot <- mountFS Nothing dirFS False 500
      unmountFS fsroot
   ,TestLabel "smaller fs" $ TestCase $ do
      withNewFSWrite dirFS 500 (unmountWriteFS)

  ] ++ (if fast then [] else slowTests)