halfs-0.2: Halfs.hs
{-# 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)