diff --git a/BinArray.hs b/BinArray.hs deleted file mode 100644 --- a/BinArray.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# OPTIONS -cpp -fglasgow-exts #-} - -module BinArray - ( BinArray - , newBinArray - , sizeBinArray - , zeroBinArray - , readWord8 - , writeWord8 - , readWord32 - , writeWord32 - , copy - , getBinArrayRawBuffer -- :: BinArray -> MutableByteArray# RealWorld - ) where - -import GHC.Base -import GHC.IOBase -import GHC.Word ---import GHC.Int - - - --- This is a hack to prevent the profiling version from --- being *significantly* slower than the unprofiling version. - -#ifdef PROFILING -#define IOSCC(label) (\ fn -> IO $ \ s -> {-# SCC label #-} case fn of { IO m -> m s }) -#else -#define IOSCC(label) id -#endif - -data BinArray = BinArray Int# -- size in *bytes* - (MutableByteArray# RealWorld) - -- byte array, padded to 32 bits sized - -getBinArrayRawBuffer :: BinArray -> MutableByteArray# RealWorld -getBinArrayRawBuffer (BinArray _ arr) = arr - -newBinArray :: Int -> IO BinArray -newBinArray (I# sz) = IO $ \ s_in -> - case newByteArray# size s_in of { (# s, arr #) -> - (# s, BinArray sz arr #) } - where (I# size) = ((I# sz + 3) `div` 4) * 4 - - -sizeBinArray :: BinArray -> Int -sizeBinArray (BinArray sz _) = I# sz - -zeroBinArray :: BinArray -> IO () -zeroBinArray arr@(BinArray sz _) = - sequence_ [ writeWord8 arr i 0x0 | i <- take (I# sz) [0..] ] - - --- TODO: this copy needs reworked, to use the FFI. - --- | copy a BinArray onto another BinArray. --- Requires that the target be the same size, or bigger. - -copy :: BinArray -> BinArray -> IO () -copy ba1@(BinArray i1 _) ba2@(BinArray i2 _) - | i1 <=# i2 - && ((I# i1) `mod` 4) == 0 - && ((I# i2) `mod` 4) == 0 = IOSCC("copy") $ - do let loop i t | t == 0 = return () - | otherwise = - do v <- unsafeReadWord32 ba1 (I# i) - unsafeWriteWord32 ba2 (I# i) v - loop (i +# 1#) (t - 1) - loop 0# ((I# i1) `div` (4 :: Int)) - | otherwise = error "BinArray.copy: BinArray's need to be the same size (or bigger) for copy, and power of 4" - - -readWord8 :: BinArray -> Int -> IO Word8 -readWord8 ba@(BinArray i1 _) (I# i) - | i <# i1 = unsafeReadWord8 ba (I# i) - | otherwise = fail "Bad index value in readWord8" - -{-# INLINE unsafeReadWord8 #-} -unsafeReadWord8 :: BinArray -> Int -> IO Word8 -unsafeReadWord8 (BinArray _ arr) (I# i) = - IO $ \ s_in -> case readWord8Array# arr i s_in of { (# s, v #) -> - (# s, W8# v #) } - -writeWord8 :: BinArray -> Int -> Word8 -> IO () -writeWord8 ba@(BinArray i1 _) (I# i) v - | i <# i1 = unsafeWriteWord8 ba (I# i) v - | otherwise = fail "Bad index value in writeWord8" - -{-# INLINE unsafeWriteWord8 #-} -unsafeWriteWord8 :: BinArray -> Int -> Word8 -> IO () -unsafeWriteWord8 (BinArray _ arr) (I# i) (W8# v) = - IO $ \ s_in -> case writeWord8Array# arr i v s_in of { s -> - (# s, () #) } - --- | The addressing is done by Word32 blocks, not the byte address. - -readWord32 :: BinArray -> Int -> IO Word32 -readWord32 ba@(BinArray i1 _) (I# i) - | (i *# 4#) <# i1 = unsafeReadWord32 ba (I# i) - | otherwise = fail "Bad index value in readWord32" - -{-# INLINE unsafeReadWord32 #-} -unsafeReadWord32 :: BinArray -> Int -> IO Word32 -unsafeReadWord32 (BinArray _ arr) (I# i) = - IO $ \ s_in -> case readWord32Array# arr i s_in of { (# s, v #) -> - (# s, W32# v #) } - --- | The addressing is done by Word32 blocks, not the byte address. - -writeWord32 :: BinArray -> Int -> Word32 -> IO () -writeWord32 ba@(BinArray i1 _) (I# i) v - | (i *# 4#) <# i1 = unsafeWriteWord32 ba (I# i) v - | otherwise = fail "Bad index value in writeWord32" - -{-# INLINE unsafeWriteWord32 #-} -unsafeWriteWord32 :: BinArray -> Int -> Word32 -> IO () -unsafeWriteWord32 (BinArray _ arr) (I# i) (W32# v) = - IO $ \ s_in -> case writeWord32Array# arr i v s_in of { s -> - (# s, () #) } - - diff --git a/Binary.hs b/Binary.hs deleted file mode 100644 --- a/Binary.hs +++ /dev/null @@ -1,843 +0,0 @@ -{-# OPTIONS -cpp -fglasgow-exts #-} -{-# OPTIONS -#include #-} -{-# OPTIONS -#include "binutils.h" #-} --- --- (c) The University of Glasgow 2002 --- --- Binary I/O library, with special tweaks for GHC --- --- Based on the nhc98 Binary library, which is copyright --- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. --- Under the terms of the license for that software, we must tell you --- where you can obtain the original version of the Binary library, namely --- http://www.cs.york.ac.uk/fp/nhc98/ - --- Unit tests by --- Paul Steckler, NGIT/FNMOC, paul.steckler.ctr@metnet.navy.mil --- fixme: who did the GHC port? --- AJG: I believe it was Simon Marlow --- --- the Sven Panne port is known to be buggy - --- The Binary module is *not* thread save. Only one threads should --- be actively interacting with each Handle at a time. - -module Binary - ( BinHandle, - FixedBinHandle, - FixedSysHandle, - IOBinHandle, - - BinaryHandle, -- abstract class - - Binary(..), - Binary.copyBytes, - Bin(..), - BinArray, - tellBin, - seekBin, - openBinIO, - openBinMem, - openFixedBinMem, - openFixedSysHandle, - sizeBinMem, - sizeFixedBinMem, - sizeFixedSysMem, - zeroFixedBinHandle, - zeroFixedSysHandle, - resetBin, - copyMap, - - invalidateFixedBinMem, - invalidateFixedSysMem, - - ) where - -#include "ghcconfig.h" -#if 0 -#include "haskell_debug.h" -#endif - -import BinArray as BA -import FastMutInt --- import GHC.IO - -import Data.Array.SysArray - ---import Data.Map(Map) -# if __GLASGOW_HASKELL__>=602 --- import Data.HashTable as HashTable -# endif --- import Data.Array.IO --- import Data.Array.Storable -import Data.Array --- import Data.Bits --- import Data.Int --- import Data.Word -import Data.IORef -import Data.Char ( ord, chr ) --- import Data.Array.Base ( unsafeRead, unsafeWrite, bounds ) -import Control.Monad ( when ) -import Control.Exception ( assert ) -import System.IO as IO -import System.Posix.IO (fdSeek, fdRead, fdWrite) -import System.Posix.Types (Fd(..)) --- import System.IO.Unsafe ( unsafeInterleaveIO ) -import System.IO.Error ( mkIOError, eofErrorType ) ---import GHC.Real ( Ratio(..) ) -import GHC.Exts -import GHC.IOBase ( IO(..) ) --- import GHC.Word ( Word8(..) ) --- import System.Directory ( removeFile ) -# if __GLASGOW_HASKELL__<602 --- import GHC.Handle ( hSetBinaryMode ) -# endif - -import Foreign -import Foreign.C - --- for debug ---import System.CPUTime (getCPUTime) --- import Numeric (showFFloat) - ---import Testing - --- FIXME: we should really get SIZEOF_HSINT directly from ghc's config.h -#define SIZEOF_HSINT SIZEOF_VOID_P - --- This is a hack to prevent the profiling version from --- being *significantly* slower than the unprofiling version. - --- - -#ifdef PROFILING -#define IOSCC(label,act) IO $ \ s -> {-# SCC label #-} case act of { IO m -> m s } -#else -#define IOSCC(label,act) act -#endif - --- type BinArray = StorableArray Int Word8 --- newtype BinArray = BinArray IOUArray Int Word8 - ---------------------------------------------------------------- --- BinHandle. etc ---------------------------------------------------------------- - -data IOBinHandle - = IOBinHandle { - - io_off_r :: !FastMutInt, -- the current offset (cached) - hdl :: !Fd -- the file handle (must be seekable) - } - -- cache the file ptr in BinIO; using hTell is too expensive - -- to call repeatedly. If anyone else is modifying this Handle - -- at the same time, we'll be screwed. - -data BinHandle - = BinMem { -- binary data stored in an unboxed array - off_r :: !FastMutInt, -- the current offset - sz_r :: !FastMutInt, -- size of the array (cached) - -- TODO: use the arr_r's size. - arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) - } - -data FixedBinHandle - = FixedBinMem { -- binary data stored in an unboxed array - f_off_r :: !FastMutInt, -- the current offset - f_sz_r :: !FastMutInt, -- size of the array (cached) - -- TODO: use the arr_r's size. - f_arr_r :: !BinArray -- the array (bounds: (0,size-1)) - } - -data FixedSysHandle - = FixedSysMem { -- binary data stored in an unboxed array - fs_off_r :: !FastMutInt, -- the current offset - fs_sz_r :: !FastMutInt, -- size of the array (cached) - -- TODO: use the arr_r's size. - fs_arr_r :: !(SysArray Word8) -- the array (bounds: (0,size-1)) - } - ---------------------------------------------------------------- --- Bin ---------------------------------------------------------------- - -newtype Bin a = BinPtr Int - deriving (Eq, Ord, Show, Bounded) - ---------------------------------------------------------------- --- class BinaryHandle ---------------------------------------------------------------- - -class BinaryHandle m where - bhPut :: m -> Word8 -> IO () - bhGet :: m -> IO Word8 - tellBin :: m -> IO (Bin a) - seekBin :: m -> Bin a -> IO () - - getAddrRef :: m -> Int -> IO (Maybe AddrRef) - getAddrRef _ _ = return $ Nothing - --- |reset the pointer -resetBin :: (BinaryHandle m) => m -> IO () -resetBin bh = seekBin bh (BinPtr 0) - ---------------------------------------------------------------- --- class Binary ---------------------------------------------------------------- - -class Binary a where - put_ :: (BinaryHandle h) => h -> a -> IO () - put :: (BinaryHandle h) => h -> a -> IO (Bin a) - get :: (BinaryHandle h) => h -> IO a - - -- define one of put_, put. Use of put_ is recommended because it - -- is more likely that tail-calls can kick in, and we rarely need the - -- position return value. - put_ bh a = do put bh a; return () - put bh a = do p <- tellBin bh; put_ bh a; return p - - ---------------------------------------------------------------- --- BinHandle ---------------------------------------------------------------- - -instance BinaryHandle BinHandle where - bhPut h@(BinMem ix_r sz_r arr_r) w = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - -- double the size of the array if it overflows - if (ix >= sz) - then do expandBin h ix - bhPut h w - else do arr <- readIORef arr_r - BA.writeWord8 arr ix w - writeFastMutInt ix_r (ix+1) - return () - - bhGet (BinMem ix_r sz_r arr_r) = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - when (ix >= sz) $ - ioError (mkIOError eofErrorType ("Halfs.Binary.getWord8 array: " ++ (show sz) ++" ") - Nothing Nothing) - arr <- readIORef arr_r - w <- BA.readWord8 arr ix - writeFastMutInt ix_r (ix+1) - return w - - tellBin (BinMem r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) - seekBin h@(BinMem ix_r sz_r a) (BinPtr p) = do - sz <- readFastMutInt sz_r - if (p >= sz) - -- FIX: Below assertion is because we don't want any resizing in this app. - -- FIX: dont use this for fixed sized buffers. - then if (p > sz) then do expandBin h p; writeFastMutInt ix_r p - else -- at end of array, but that is legal, provided we do not read or write. - writeFastMutInt ix_r p - else writeFastMutInt ix_r p - - getAddrRef h@(BinMem off_r sz_r arr_r_ref) count = do - -- move the pointer forward *first* - -- (this does bound checking or increases the size of the array), - ix <- readFastMutInt off_r - seekBin h (BinPtr (ix + count)) - arr_r <- readIORef arr_r_ref - -- then move it back. - seekBin h (BinPtr ix) - return $ Just $ ByteArrAddrRef (getBinArrayRawBuffer arr_r) - ix - (seekBin h (BinPtr (ix + count))) - - - --- openBinHandle :: BinArray -> IO BinHandle --- openBinHandle arr = do --- arr_r <- newIORef arr --- ix_r <- newFastMutInt --- writeFastMutInt ix_r 0 --- sz_r <- newFastMutInt --- writeFastMutInt sz_r (sizeBinArray arr) --- return (BinMem ix_r sz_r arr_r) - -openBinMem :: Int -> IO BinHandle -openBinMem size - | size <= 0 = error "Halfs.Binary.openBinMem: size must be > 0" - | otherwise = do - arr <- BA.newBinArray size - arr_r <- newIORef arr - ix_r <- newFastMutInt - writeFastMutInt ix_r 0 - sz_r <- newFastMutInt - writeFastMutInt sz_r size - return (BinMem ix_r sz_r arr_r) - - -sizeBinMem :: BinHandle -> IO Int -sizeBinMem (BinMem _ sz_r _) = readFastMutInt sz_r - --- getBinArray :: BinHandle -> IO BinArray --- getBinArray (BinMem _ _ arr_r) = readIORef arr_r - --- expand the size of the array to include a specified offset -expandBin :: BinHandle -> Int -> IO () -expandBin (BinMem ix_r sz_r arr_r) off = do - sz <- readFastMutInt sz_r - let sz' = head (dropWhile (<= off) (iterate (* 2) sz)) - arr <- readIORef arr_r - arr' <- newBinArray sz' - BA.copy arr arr' - writeFastMutInt sz_r sz' - writeIORef arr_r arr' -#ifdef DEBUG - hPutStrLn stderr ("Binary: expanding to size: " ++ show sz') -#endif - return () ---expandBin (BinIO _ _) _ = return () - -- no need to expand a file, we'll assume they expand by themselves. - - ---------------------------------------------------------------- --- FixedBinHandle ---------------------------------------------------------------- - -instance BinaryHandle FixedBinHandle where - bhPut h@(FixedBinMem ix_r sz_r arr) w = do - checkFixedBinMem h - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - when (ix >= sz) $ - ioError (mkIOError eofErrorType ("Binary.bhPut FixedBinHandle: writing passed end of FixedBinHandle at " ++ (show sz) ++" ") - Nothing Nothing) - BA.writeWord8 arr ix w - writeFastMutInt ix_r (ix+1) - checkFixedBinMem h - return () - - bhGet h@(FixedBinMem ix_r sz_r arr) = do - checkFixedBinMem h - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - when (ix >= sz) $ - ioError (mkIOError eofErrorType ("Binary.bhGet FixedBinHandle: reading passed end of FixedBinHandle at " ++ (show sz) ++" ") - Nothing Nothing) - w <- BA.readWord8 arr ix - writeFastMutInt ix_r (ix+1) - checkFixedBinMem h - return w - - tellBin h@(FixedBinMem r _ _) = do checkFixedBinMem h ; ix <- readFastMutInt r; return (BinPtr ix) - seekBin h@(FixedBinMem ix_r sz_r a) (BinPtr p) = do - checkFixedBinMem h - sz <- readFastMutInt sz_r - when (p > sz) $ - ioError (mkIOError eofErrorType ("Binary.seekBin FixedBinHandle: seeking passed end of FixedBinHandle at " ++ (show sz) ++" ") - Nothing Nothing) - when (p < 0) $ - ioError (mkIOError eofErrorType ("Binary.seekBin FixedBinHandle: seeking passed start of FixedBinHandle at " ++ (show sz) ++" ") - Nothing Nothing) - writeFastMutInt ix_r p - checkFixedBinMem h - - getAddrRef h@(FixedBinMem off_r sz_r arr) count = do - checkFixedBinMem h - -- move the pointer forward *first* to check bounds - ix <- readFastMutInt off_r - seekBin h (BinPtr (ix + count)) - -- then move it back. - seekBin h (BinPtr ix) - checkFixedBinMem h - return $ Just $ ByteArrAddrRef (getBinArrayRawBuffer arr) - ix - (seekBin h (BinPtr (ix + count))) - -{- -openFixedBinHandle :: BinArray -> IO FixedBinHandle -openFixedBinHandle arr = do - ix_r <- newFastMutInt - writeFastMutInt ix_r 0 - sz_r <- newFastMutInt - writeFastMutInt sz_r (sizeBinArray arr) - return $ FixedBinMem ix_r sz_r arr --} - -checkFixedBinMem :: FixedBinHandle -> IO () -checkFixedBinMem (FixedBinMem ix_r _ _) = do - ix <- readFastMutInt ix_r - assert (ix /= -1) $ return () - --- |make a handle 'dead'. uses to test reclaiming strategies. - -invalidateFixedBinMem :: FixedBinHandle -> IO () -invalidateFixedBinMem (FixedBinMem ix_r _ _) = do - writeFastMutInt ix_r (-1) - return () - -openFixedBinMem :: Int -> IO FixedBinHandle -openFixedBinMem size - | size <= 0 = error "Halfs.Binary.openBinMem: size must be > 0" - | otherwise = do - arr <- BA.newBinArray size - ix_r <- newFastMutInt - writeFastMutInt ix_r 0 - sz_r <- newFastMutInt - writeFastMutInt sz_r size - let h = FixedBinMem ix_r sz_r arr - checkFixedBinMem h - return $ h - -sizeFixedBinMem :: FixedBinHandle -> IO Int -sizeFixedBinMem h@(FixedBinMem _ sz_r _) = do - checkFixedBinMem h - readFastMutInt sz_r - -zeroFixedBinHandle :: FixedBinHandle -> IO () -zeroFixedBinHandle h@(FixedBinMem ix_r _ arr) = do - checkFixedBinMem h - BA.zeroBinArray arr - writeFastMutInt ix_r 0 - checkFixedBinMem h - return () - ---------------------------------------------------------------- --- FixedSysHandle ---------------------------------------------------------------- - -instance BinaryHandle FixedSysHandle where - bhPut h@(FixedSysMem ix_r sz_r arr) w = do - checkFixedSysMem h - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - when (ix >= sz) $ - ioError (mkIOError eofErrorType ("Binary.bhPut FixedSysHandle: writing passed end of FixedSysHandle at " ++ (show sz) ++" ") - Nothing Nothing) - pokeSysArrayElem arr (fromIntegral ix) w - writeFastMutInt ix_r (ix+1) - checkFixedSysMem h - return () - - bhGet h@(FixedSysMem ix_r sz_r arr) = do - checkFixedSysMem h - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - when (ix >= sz) $ - ioError (mkIOError eofErrorType ("Binary.bhGet FixedSysHandle: reading passed end of FixedSysHandle at " ++ (show sz) ++" ") - Nothing Nothing) - w <- peekSysArrayElem arr (fromIntegral ix) - writeFastMutInt ix_r (ix+1) - checkFixedSysMem h - return w - - tellBin h@(FixedSysMem r _ _) = do checkFixedSysMem h ; ix <- readFastMutInt r; return (BinPtr ix) - seekBin h@(FixedSysMem ix_r sz_r a) (BinPtr p) = do - checkFixedSysMem h - sz <- readFastMutInt sz_r - when (p > sz) $ - ioError (mkIOError eofErrorType ("Binary.seekBin FixedSysHandle: seeking passed end of FixedSysHandle at " ++ (show sz) ++" ") - Nothing Nothing) - when (p < 0) $ - ioError (mkIOError eofErrorType ("Binary.seekBin FixedSysHandle: seeking passed start of FixedSysHandle at " ++ (show sz) ++" ") - Nothing Nothing) - writeFastMutInt ix_r p - checkFixedSysMem h - - getAddrRef h@(FixedSysMem off_r sz_r arr) count = do - checkFixedSysMem h - -- move the pointer forward *first* to check bounds - ix <- readFastMutInt off_r - seekBin h (BinPtr (ix + count)) - -- then move it back. - seekBin h (BinPtr ix) - checkFixedSysMem h - return $ Just $ SysArrAddrRef (ptrFromSysArray arr) - ix - (seekBin h (BinPtr (ix + count))) - - -openFixedSysHandle :: SysArray Word8 -> IO FixedSysHandle -openFixedSysHandle arr = do - ix_r <- newFastMutInt - writeFastMutInt ix_r 0 - sz_r <- newFastMutInt - writeFastMutInt sz_r (fromIntegral (sysArraySize arr)) - return $ FixedSysMem ix_r sz_r arr - -checkFixedSysMem :: FixedSysHandle -> IO () -checkFixedSysMem (FixedSysMem ix_r _ _) = do - ix <- readFastMutInt ix_r - assert (ix /= -1) $ return () - --- |make a handle 'dead'. uses to test reclaiming strategies. - -invalidateFixedSysMem :: FixedSysHandle -> IO () -invalidateFixedSysMem (FixedSysMem ix_r _ _) = do - writeFastMutInt ix_r (-1) - return () - -sizeFixedSysMem :: FixedSysHandle -> IO Int -sizeFixedSysMem h@(FixedSysMem _ sz_r _) = do - checkFixedSysMem h - readFastMutInt sz_r - -foreign import ccall unsafe "binzero" binzero - :: Ptr Word8 -> CSize -> IO () - -zeroFixedSysHandle :: FixedSysHandle -> IO () -zeroFixedSysHandle h@(FixedSysMem ix_r sz_r arr) = do - checkFixedSysMem h - sz <- readFastMutInt sz_r - binzero (ptrFromSysArray arr) (fromIntegral sz) - writeFastMutInt ix_r 0 - checkFixedSysMem h - return () - ---------------------------------------------------------------- --- IOBinHandle ---------------------------------------------------------------- - -instance BinaryHandle IOBinHandle where - bhPut (IOBinHandle ix_r h) w = do - ix <- readFastMutInt ix_r - fdWrite h [(chr (fromIntegral w))] -- XXX not really correct - writeFastMutInt ix_r (ix+1) - return () - bhGet (IOBinHandle ix_r h) = do - ix <- readFastMutInt ix_r - ([c], count) <- fdRead h 1 - writeFastMutInt ix_r (ix+1) - return $! (fromIntegral (ord c)) -- XXX not really correct - tellBin (IOBinHandle r _) = do - ix <- readFastMutInt r - return (BinPtr ix) - seekBin (IOBinHandle ix_r h) (BinPtr p) = do - writeFastMutInt ix_r p --- print ("fdSeek: " , p) - fdSeek h AbsoluteSeek (fromIntegral p) - return () - - getAddrRef (IOBinHandle ix_r fd) count = do - return $ Just $ FdAddrRef - { ch_fd = fd - , ch_done = do ix <- readFastMutInt ix_r - writeFastMutInt ix_r (ix + count) - } - - -openBinIO :: Fd -> IO IOBinHandle -openBinIO h = do - r <- newFastMutInt - writeFastMutInt r 0 - return $ IOBinHandle r h - --- ----------------------------------------------------------------------------- --- Primitve Word writes - -instance Binary Word8 where - put_ bh a = bhPut bh a - get = bhGet - -instance Binary Word16 where - put_ h w = do - bhPut h (fromIntegral (w .&. 0xff)) - bhPut h (fromIntegral (w `shiftR` 8)) - get h = do - w2 <- bhGet h - w1 <- bhGet h - return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2) - - -instance Binary Word32 where - put_ h w = do - bhPut h (fromIntegral (w .&. 0xff)) - bhPut h (fromIntegral ((w `shiftR` 8) .&. 0xff)) - bhPut h (fromIntegral ((w `shiftR` 16) .&. 0xff)) - bhPut h (fromIntegral (w `shiftR` 24)) - get h = do - w4 <- bhGet h - w3 <- bhGet h - w2 <- bhGet h - w1 <- bhGet h - return $! ((fromIntegral w1 `shiftL` 24) .|. - (fromIntegral w2 `shiftL` 16) .|. - (fromIntegral w3 `shiftL` 8) .|. - (fromIntegral w4)) - - -instance Binary Word64 where - put_ h w = do - bhPut h (fromIntegral (w .&. 0xff)) - bhPut h (fromIntegral ((w `shiftR` 8) .&. 0xff)) - bhPut h (fromIntegral ((w `shiftR` 16) .&. 0xff)) - bhPut h (fromIntegral ((w `shiftR` 24) .&. 0xff)) - bhPut h (fromIntegral ((w `shiftR` 32) .&. 0xff)) - bhPut h (fromIntegral ((w `shiftR` 40) .&. 0xff)) - bhPut h (fromIntegral ((w `shiftR` 48) .&. 0xff)) - bhPut h (fromIntegral (w `shiftR` 56)) - get h = do - w8 <- bhGet h - w7 <- bhGet h - w6 <- bhGet h - w5 <- bhGet h - w4 <- bhGet h - w3 <- bhGet h - w2 <- bhGet h - w1 <- bhGet h - return $! ((fromIntegral w1 `shiftL` 56) .|. - (fromIntegral w2 `shiftL` 48) .|. - (fromIntegral w3 `shiftL` 40) .|. - (fromIntegral w4 `shiftL` 32) .|. - (fromIntegral w5 `shiftL` 24) .|. - (fromIntegral w6 `shiftL` 16) .|. - (fromIntegral w7 `shiftL` 8) .|. - (fromIntegral w8)) - --- ----------------------------------------------------------------------------- --- Primitve Int writes - -instance Binary Int8 where - put_ h w = put_ h (fromIntegral w :: Word8) - get h = do w <- get h; return $! (fromIntegral (w::Word8)) - -instance Binary Int16 where - put_ h w = put_ h (fromIntegral w :: Word16) - get h = do w <- get h; return $! (fromIntegral (w::Word16)) - -instance Binary Int32 where - put_ h w = put_ h (fromIntegral w :: Word32) - get h = do w <- get h; return $! (fromIntegral (w::Word32)) - -instance Binary Int64 where - put_ h w = put_ h (fromIntegral w :: Word64) - get h = do w <- get h; return $! (fromIntegral (w::Word64)) - --- ----------------------------------------------------------------------------- --- Instances for standard types - -instance Binary () where - put_ bh () = return () - get _ = return () --- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b) - -instance Binary Bool where - put_ bh b = bhPut bh (fromIntegral (fromEnum b)) - get bh = do x <- bhGet bh; return $! (toEnum (fromIntegral x)) --- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b) - -instance Binary Char where - put_ bh c = put_ bh (fromIntegral (ord c) :: Word8) - get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word8))) --- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b) - -instance Binary Int where -#if SIZEOF_HSINT == 4 - put_ bh i = put_ bh (fromIntegral i :: Int32) - get bh = do - x <- get bh - return $! (fromIntegral (x :: Int32)) -#elif SIZEOF_HSINT == 8 - put_ bh i = put_ bh (fromIntegral i :: Int64) - get bh = do - x <- get bh - return $! (fromIntegral (x :: Int64)) -#else -#error "unsupported sizeof(HsInt)" -#endif --- getF bh = getBitsF bh 32 - -instance Binary a => Binary [a] where - put_ bh list = do put_ bh (length list) - mapM_ (put_ bh) list - get bh = do len <- get bh - let getMany :: Int -> IO [a] - getMany 0 = return [] - getMany n = do x <- get bh - xs <- getMany (n-1) - return (x:xs) - getMany len - -instance (Binary a, Binary b) => Binary (a,b) where - put_ bh (a,b) = do put_ bh a; put_ bh b - get bh = do a <- get bh - b <- get bh - return (a,b) - -instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where - put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c - get bh = do a <- get bh - b <- get bh - c <- get bh - return (a,b,c) - -instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where - put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (a,b,c,d) - -instance Binary a => Binary (Maybe a) where - put_ bh Nothing = bhPut bh 0 - put_ bh (Just a) = do bhPut bh 1; put_ bh a - get bh = do h <- bhGet bh - case h of - 0 -> return Nothing - _ -> do x <- get bh; return (Just x) - -instance (Binary a, Binary b) => Binary (Either a b) where - put_ bh (Left a) = do bhPut bh 0; put_ bh a - put_ bh (Right b) = do bhPut bh 1; put_ bh b - get bh = do h <- bhGet bh - case h of - 0 -> do a <- get bh ; return (Left a) - _ -> do b <- get bh ; return (Right b) - -instance (Binary a, Binary i, Ix i) => Binary (Array i a) where - put_ bh arr = do put_ bh (Data.Array.bounds arr) - put_ bh (Data.Array.elems arr) - get bh = do bounds <- get bh - elems <- get bh - return $ listArray bounds elems - -instance Binary (Bin a) where - put_ bh (BinPtr i) = put_ bh i - get bh = do i <- get bh; return (BinPtr i) - - ---------------------------------------------------------------- --- Binary Copying ---------------------------------------------------------------- - --- |Move from one BinHandle to another, with size. Moves both of --- their pointers. - -copyBytes :: (BinaryHandle h1,BinaryHandle h2) - => h1 -- ^ src handle - -> h2 -- ^ dest handle - -> Int - -> IO () -copyBytes from_h to_h sz@(I# _) = {-# SCC "copyBytes" #-} do - src <- getAddrRef from_h sz - dst <- getAddrRef to_h sz - case (src,dst) of - (Just (ByteArrAddrRef s_buf s_off s_done), Just (ByteArrAddrRef d_buf d_off d_done)) -> {-# SCC "copyBytesBB" #-} - do binmemmove_BA_BA d_buf (fromIntegral d_off) s_buf (fromIntegral s_off) (fromIntegral sz) - s_done - d_done - return () - (Just (SysArrAddrRef s_buf s_off s_done), Just (SysArrAddrRef d_buf d_off d_done)) -> {-# SCC "copyBytesSS" #-} - do binmemmove_PTR_PTR d_buf (fromIntegral d_off) s_buf (fromIntegral s_off) (fromIntegral sz) - s_done - d_done - return () - (Just (SysArrAddrRef s_buf s_off s_done), Just (ByteArrAddrRef d_buf d_off d_done)) -> {-# SCC "copyBytesSB" #-} - do binmemmove_BA_PTR d_buf (fromIntegral d_off) s_buf (fromIntegral s_off) (fromIntegral sz) - s_done - d_done - return () - (Just (ByteArrAddrRef s_buf s_off s_done), Just (SysArrAddrRef d_buf d_off d_done)) -> {-# SCC "copyBytesBS" #-} - do binmemmove_PTR_BA d_buf (fromIntegral d_off) s_buf (fromIntegral s_off) (fromIntegral sz) - s_done - d_done - return () - - (Just (ByteArrAddrRef s_buf s_off s_done), Just (FdAddrRef (Fd d_fd) d_done)) -> {-# SCC "copyBytesBF" #-} - do r <- binwrite_BA d_fd s_buf (fromIntegral s_off) (fromIntegral sz) - s_done - d_done - return () - (Just (FdAddrRef (Fd s_fd) s_done), Just (ByteArrAddrRef d_buf d_off d_done)) -> {-# SCC "copyBytesFB" #-} - do seekBin to_h (BinPtr (d_off + sz)) - r <- binread_BA d_buf (fromIntegral d_off) s_fd (fromIntegral sz) - s_done - d_done - return () - _ -> {-# SCC "copyBytes1" #-} copyBytes1 from_h to_h sz - -foreign import ccall unsafe "binmemmove" binmemmove_BA_BA - :: MutableByteArray# RealWorld -> CInt -> MutableByteArray# RealWorld -> CInt -> CSize -> IO () -foreign import ccall unsafe "binmemmove" binmemmove_BA_PTR - :: MutableByteArray# RealWorld -> CInt -> Ptr Word8 -> CInt -> CSize -> IO () -foreign import ccall unsafe "binmemmove" binmemmove_PTR_PTR - :: Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> CSize -> IO () -foreign import ccall unsafe "binmemmove" binmemmove_PTR_BA - :: Ptr Word8 -> CInt -> MutableByteArray# RealWorld -> CInt -> CSize -> IO () -foreign import ccall unsafe "binwrite" binwrite_BA - :: CInt -> MutableByteArray# RealWorld -> CInt -> CSize -> IO () -foreign import ccall unsafe "binread" binread_BA - :: MutableByteArray# RealWorld -> CInt -> CInt -> CSize -> IO () - --- generic worker function. -copyBytes1 from_h to_h (I# sz) - | sz ==# 0# = return () - | otherwise = do { v <- bhGet from_h - ; bhPut to_h v - ; copyBytes1 from_h to_h (I# (sz -# 1#)) - } - - --- |Just like copy bytes, but takes a function parameter to modify -copyMap :: (BinaryHandle bh1,BinaryHandle bh2,Binary a, Binary b) - => bh1 -- ^input handle - -> bh2 -- ^output handle - -> Int -- ^number of elements to copy - -> (a -> b) -- ^f is for fun - -> IO () -copyMap inHandle outHandle (I# sz) f = do - let loop n - | n ==# sz = return () - | otherwise = do - w <- get inHandle - put outHandle (f w) - loop (n +# 1#) - loop 0# -{- -copyBytesFromPtr :: (BinaryHandle h) - => Ptr a -- ^ src ptr - -> h -- ^ dest handle - -> Int -- ^ number of bytes - -> IO () -copyBytesFromPtr ptr h sz@(I# _) = {-# SCC "copyBytesFromPtr" #-} do - - -copyBytesToPtr :: (BinaryHandle h) => - => h -- ^ src ptr - -> Ptr a -- ^ dest handle - -> Int -- ^ number of bytes - -> IO () -copyBytesToPtr h ptr sz@(I# _) = {-# SCC "copyBytesToPtr" #-} do - copy 0 - where - copy i | i == sz = return () -- done - | otherwise = do - v <- peekByteOff ptr i - put h (v :: Word8) - copy (i + 1) --} - ------------------------------------------------------------------------------- --- INTERNAL to this module. - --- get part of a Handle, for copying. - -data AddrRef = ByteArrAddrRef - { ch_byte_arr :: MutableByteArray# RealWorld - , ch_offset :: Int -- offset where the copy (from/to) will start - , ch_done :: IO () - } - | FdAddrRef - { ch_fd :: Fd -- the file descriptor - , ch_done :: IO () - } - | SysArrAddrRef - { ch_sys_arr :: Ptr Word8 - , ch_offset :: Int - , ch_done :: IO () - } - -instance Show AddrRef where - show (ByteArrAddrRef {}) = "ByteArrAddrRef" - show (FdAddrRef fd _) = "FdAddrRef " ++ show fd - show (SysArrAddrRef {}) = "SysArrAddrRef" - - - diff --git a/Data/Array/SysArray.hs b/Data/Array/SysArray.hs deleted file mode 100644 --- a/Data/Array/SysArray.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} -module Data.Array.SysArray - ( SysArray -- abstract. Instances: Eq, Show - , mkSysArray -- :: Word32 -> Ptr e -> Bool -> SysArray e - , peekSysArrayElem -- :: (Storable e) => SysArray e -> Word32 -> IO e - , pokeSysArrayElem -- :: (Storable e) => SysArray e -> Word32 -> e -> IO () - , sysArraySize -- :: SysArray e -> Word32 - , sysArrayIsReadOnly -- :: SysArray e -> Bool - , ptrFromSysArray -- :: (Storable e) => SysArray e -> Ptr e - ) where - -import Foreign -import Foreign.C() - --- something like StorableArray --- lower bound implicitly 0 --- upper bound explicit -data SysArray e = SysArray Word32 !(Ptr e) Bool - deriving (Eq,Show) - -mkSysArray :: Word32 -> Ptr elt -> Bool -> SysArray elt -mkSysArray u p ro = SysArray u p ro - --- but *not* an instance of MArray, which does its own allocation --- via newArray or newArray_ --- also not an instance of IArray, which has more cruft than we --- need - -validSysArrayNdx :: (Storable e) => SysArray e -> Word32 -> Bool -validSysArrayNdx (SysArray u _ _) ndx = 0 <= ndx && ndx < u - -ptrFromSysArray :: (Storable e) => SysArray e -> Ptr e -ptrFromSysArray (SysArray _ ptr _) = ptr - -sysArraySize :: SysArray e -> Word32 -sysArraySize (SysArray s _ _) = s - -sysArrayIsReadOnly :: SysArray e -> Bool -sysArrayIsReadOnly (SysArray _ _ ro) = ro - -pokeSysArrayElem :: (Storable e) => SysArray e -> Word32 -> e -> IO () -pokeSysArrayElem sarr ndx v - -- if we didn't check mode, likely to segfault - | (not isRO && validSysArrayNdx sarr ndx) = - pokeElemOff ptr (fromIntegral ndx) v - | otherwise = - fail ("pokeSysArrayElem: illegal op/index " ++ show (ndx,isRO,(0::Integer,sysArraySize sarr))) - where isRO = sysArrayIsReadOnly sarr - ptr = ptrFromSysArray sarr - -peekSysArrayElem :: (Storable e) => SysArray e -> Word32 -> IO e -peekSysArrayElem sarr ndx - | validSysArrayNdx sarr ndx = peekElemOff (ptrFromSysArray sarr) (fromIntegral ndx) - | otherwise = fail ("peekSysArrayElem: index out of bounds " ++ show (ndx,(0::Integer,sysArraySize sarr))) - - - - - - diff --git a/Data/Integral.hs b/Data/Integral.hs deleted file mode 100644 --- a/Data/Integral.hs +++ /dev/null @@ -1,67 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Integral --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : GHC --- --- Cues Integralitis. -module Data.Integral - ( fromIntegral' -- :: (Bounded a, Integral a, Bounded b, Integral b) => a -> b - , fromIntegral'' -- :: (Bounded a, Integral a, Bounded b, Integral b) => a -> b - - , INInt - , INLong - - , inIntToInt -- :: INInt -> Int - , intToINLong -- :: Int -> INLong - , inIntToINLong -- :: INInt -> INLong - , intToINInt -- :: Int -> INInt - - ) where - -import Data.Int ( Int32, Int64 ) -import Control.Exception ( assert ) - -type INInt = Int32 -type INLong = Int64 - --- This section should only allow _correct_ conversions between types. --- Raw fromIntegral should be avoided because it can cause overflow --- and underflow. - -inIntToInt :: INInt -> Int -inIntToInt = fromIntegral' - -intToINLong :: Int -> INLong -intToINLong = fromIntegral' - -inIntToINLong :: INInt -> INLong -inIntToINLong = fromIntegral' - -intToINInt :: Int -> INInt -intToINInt = fromIntegral' - - --- |Almost like fromIntegral, but checks the bounds to make sure its --- definitely safe. Uses assert, so without assertions, check won't --- happen. -fromIntegral' :: (Bounded a, Integral a, Bounded b, Integral b) => a -> b -fromIntegral' x = let i = fromIntegral x - in assert ((toInteger (maxBound `asTypeOf` i) - >= toInteger (maxBound `asTypeOf` x)) - && (toInteger (minBound `asTypeOf` i) - <= toInteger (minBound `asTypeOf` x))) - i - --- |A bit less safe than fromIntegral'; just runtime checks actual --- value you're trying to convert. -fromIntegral'' :: (Integral a, Bounded b, Integral b) => a -> b -fromIntegral'' x = let i = fromIntegral x - in assert ((toInteger (maxBound `asTypeOf` i) - >= toInteger x) - && (toInteger (minBound `asTypeOf` i) - <= toInteger x)) - i - diff --git a/Data/Queue.hs b/Data/Queue.hs deleted file mode 100644 --- a/Data/Queue.hs +++ /dev/null @@ -1,86 +0,0 @@ ------------------------------------------------------------------------------ --- test --- | --- Module : Data.Queue --- Copyright : (c) The University of Glasgow 2002 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- --- Queues with constant time operations, from --- /Simple and efficient purely functional queues and deques/, --- by Chris Okasaki, /JFP/ 5(4):583-592, October 1995. --- ------------------------------------------------------------------------------ - -module Data.Queue( - Queue, - -- * Primitive operations - -- | Each of these requires /O(1)/ time in the worst case. - emptyQueue, addToQueue, deQueue, - -- * Queues and lists - listToQueue, queueToList, queueLength - ) where - -import Prelude -- necessary to get dependencies right -import Control.Exception(assert) - --- | The type of FIFO queues. -data Queue a = Q [a] [a] [a] !Int - --- Invariants for Q xs ys xs': --- length xs = length ys + length xs' --- xs' = drop (length ys) xs -- in fact, shared (except after fmap) --- The queue then represents the list xs ++ reverse ys - -instance Functor Queue where - fmap f (Q xs ys xs' len) = Q (map f xs) (map f ys) (map f xs') len - -- The new xs' does not share the tail of the new xs, but it does - -- share the tail of the old xs, so it still forces the rotations. - -- Note that elements of xs' are ignored. - --- | The empty queue. -emptyQueue :: Queue a -emptyQueue = Q [] [] [] 0 - --- | Add an element to the back of a queue. -addToQueue :: Queue a -> a -> Queue a -addToQueue (Q xs ys xs' len) y = makeQ xs (y:ys) xs' (len + 1) - --- | Attempt to extract the front element from a queue. --- If the queue is empty, 'Nothing', --- otherwise the first element paired with the remainder of the queue. -deQueue :: Queue a -> Maybe (a, Queue a) -deQueue (Q [] _ _ len) = assert (len == 0) $ Nothing -deQueue (Q (x:xs) ys xs' len) = Just (x, makeQ xs ys xs' (len - 1)) - --- Assuming --- length ys <= length xs + 1 --- xs' = drop (length ys - 1) xs --- construct a queue respecting the invariant. -makeQ :: [a] -> [a] -> [a] -> Int -> Queue a -makeQ xs ys [] len = listToQueue' (rotate xs ys []) len -makeQ xs ys (_:xs') len = Q xs ys xs' len - --- Assuming length ys = length xs + 1, --- rotate xs ys zs = xs ++ reverse ys ++ zs -rotate :: [a] -> [a] -> [a] -> [a] -rotate [] (y:_) zs = y : zs -- the _ here must be [] -rotate (x:xs) (y:ys) zs = x : rotate xs ys (y:zs) -rotate _ _ _ = error "Bad arguments to rotate" - --- | A queue with the same elements as the list. -listToQueue :: [a] -> Queue a -listToQueue xs = listToQueue' xs (length xs) - -listToQueue' :: [a] -> Int -> Queue a -listToQueue' xs len = Q xs [] xs len - --- | The elements of a queue, front first. -queueToList :: Queue a -> [a] -queueToList (Q xs ys _ _) = xs ++ reverse ys - -queueLength :: Queue a -> Int -queueLength (Q _xs _ys _ len) = len diff --git a/FastMutInt.hs b/FastMutInt.hs deleted file mode 100644 --- a/FastMutInt.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# OPTIONS -cpp -fglasgow-exts #-} --- --- (c) The University of Glasgow 2002 --- --- Unboxed mutable Ints - -module FastMutInt( - FastMutInt, newFastMutInt, - readFastMutInt, writeFastMutInt - ) where - -#define SIZEOF_HSINT 4 - -import GHC.Base -import GHC.IOBase - -data FastMutInt = FastMutInt (MutableByteArray# RealWorld) - -newFastMutInt :: IO FastMutInt -newFastMutInt = IO $ \s_in -> - case newByteArray# size s_in of { (# s, arr #) -> - (# s, FastMutInt arr #) } - where I# size = SIZEOF_HSINT - -readFastMutInt :: FastMutInt -> IO Int -readFastMutInt (FastMutInt arr) = IO $ \s_in -> - case readIntArray# arr 0# s_in of { (# s, i #) -> - (# s, I# i #) } - -writeFastMutInt :: FastMutInt -> Int -> IO () -writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s_in -> - case writeIntArray# arr 0# i s_in of { s -> - (# s, () #) } - diff --git a/Fsck.hs b/Fsck.hs deleted file mode 100644 --- a/Fsck.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Main where -import Halfs (fsck) ---import System.Posix.Directory (changeWorkingDirectory) -import System.Environment(getArgs) - -main :: IO () -main = do - a <- getArgs - case a of - [wd] -> do -- changeWorkingDirectory wd - fsck wd - putStrLn "file system checked" - return () - _ -> putStrLn "usage: newHalfsFS path/to/device" diff --git a/Halfs.hs b/Halfs.hs deleted file mode 100644 --- a/Halfs.hs +++ /dev/null @@ -1,1101 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ --- | --- Module : Halfs --- --- Maintainer : Isaac Jones --- 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) diff --git a/Halfs/BasicIO.hs b/Halfs/BasicIO.hs deleted file mode 100644 --- a/Halfs/BasicIO.hs +++ /dev/null @@ -1,633 +0,0 @@ -{-# LANGUAGE PatternSignatures, Rank2Types #-} -module Halfs.BasicIO (devBufferReadHost, - devBufferWriteHost, devBufferWriteSafe, bytesPerBlock, - getMemoryBlock, binSkip, - getInodeRead, getInodeWrite, - getDiskAddrOfBlockWrite, - unitTests, readPartOfBlock, writePartOfBlock, - getInodesBin, putPointersBin, - syncInode, - readInodeBootStrap, - getBlockFromCacheOrDeviceWrite, - readDirectoryBin, writeDirectoryBin, readInodeMapBin, - readBlockMapBin, - fsRootFreeInode, freeInodeData, - allBlocksInInode, - writeBlockMapBin, writeInodeMapBin, - module Binary - ) where - -import Data.Integral -import Halfs.Utils hiding (inodesPerBlock) -import qualified Halfs.Utils(inodesPerBlock) - -import Binary (copyBytes, BinHandle, Bin(BinPtr), BinArray, tellBin, - seekBin, openBinIO, Bin(BinPtr), openBinMem, - put_, sizeBinMem, resetBin, get) -import Halfs.FSRW (unsafeLiftIORW) -import Halfs.BinaryMonad (FSRW, resetBinRW, seekBinRW, tellBinRW, getRW) -import Halfs.TestFramework (Test(..), UnitTests, - assertCmd, assertEqual, hunitToUnitTest) -import Halfs.FSRoot(FSRoot(..), InodeNum, InodeCache, - addToInodeCache, getFromInodeCache, - fsRootInode, fsRootUpdateInodeCache, fsRootRmFromDirectoryCache, - InodeCacheAddStyle(InodeCacheKeep)) -import Halfs.BufferBlockCache (getBlockFromCacheOrDevice,getBlockFromDevice) -import Halfs.Inode (InodeBlock, Inode(..), InodeMetadata(..), inodeBumpSize, - newInode, goodInodeMagic) -import Halfs.BufferBlock (BufferBlock(..), writeToBufferBlock,Alloc(..), - copyFromBufferBlock, copyToBufferBlock, mkBufferBlock, - diskAddressListFromBufferBlock, PartBufferBlock, mkInodeBlock, - putPartBufferBlock, getPartBufferBlock, zeroBufferBlock, startBufferBlockCursor ) -import Halfs.TheBlockMap(TheBlockMap,mkBlockMap) -import Halfs.Directory (DirectoryMap) -import System.RawDevice(RawDevice, devBufferRead, devBufferWrite, - makeRawDevice, finalizeDevice, BufferBlockHandle) -import Halfs.FSState (FSRead, writeToBuffer, - unsafeReadGet, unsafeLiftIOWrite, FSWrite, - unsafeWriteToRead, unsafeModifyFSRead, - readToWrite, readToWriteCont, modifyFSWrite, unsafeWriteGet) -import qualified Halfs.FSState (modify) -import Halfs.TheInodeMap(TheInodeMap(..), freeInode) -import Halfs.TheBlockMap(TheBlockMap(..), freeBlock) -import Halfs.Blocks (getDiskAddrOfBlockRead, getDiskAddrOfBlockRaw, markBlockDirtyWrite, - getDiskAddrOfBlockWrite, getBlockFromCacheOrDeviceWrite) - --- base -import System.IO (openFile, hClose, hFileSize, IOMode(..)) -import System.Posix.Types (Fd) -import System.Posix.Files(unionFileModes, ownerReadMode, ownerWriteMode, groupReadMode) -import System.Posix.IO (OpenMode(..), openFd, closeFd, defaultFileFlags) -import System.Directory(removeFile, doesFileExist) - -import Control.Exception(assert) -import Control.Monad(when, unless) -import Data.Queue(Queue, emptyQueue, addToQueue, queueToList) -import qualified Data.Map as Map -import Data.Array (elems, assocs) - -inodesPerBlock :: INInt -inodesPerBlock = intToINInt Halfs.Utils.inodesPerBlock - -binSkip :: (FSRW m) - => BufferBlockHandle s - -> Int -- bytes - -> m () -binSkip binHandle bytes = do - (BinPtr bufLoc) <- tellBinRW binHandle - seekBinRW binHandle (BinPtr (bufLoc + bytes)) - return () - --- ------------------------------------------------------------ --- * Block IO - reads right from disk rather than cache --- ------------------------------------------------------------ - - --- TODO: should this be here? --- |Reads a bunch of sequential bytes, presumably from the host OS. -devBufferReadHost :: Fd - -> DiskAddress -- ^location to start reading - -> BinHandle - -> Int -- ^Number of bytes to read - -> IO () -devBufferReadHost h diskAddr buffer numBytes = do - fileHandle <- openBinIO h - seekBin fileHandle (locationOfBlock diskAddr) - copyBytes fileHandle buffer numBytes - -devBufferWriteSafe :: RawDevice - -> DiskAddress -- ^Block number - -> BufferBlockHandle s -- ^Buffer! - -> FSWrite () -devBufferWriteSafe r d b = unsafeLiftIOWrite $ devBufferWrite r d b - --- TODO: should this be here? --- |Writes a bunch of sequential bytes, presumably to the host OS. -devBufferWriteHost :: Fd - -> DiskAddress -- ^location to write - -> BinHandle -- ^Buffer! - -> Int -- ^How many bytes? - -> IO () -devBufferWriteHost h diskAddr buffer numBytes = do - fileHandle <- openBinIO h - seekBin fileHandle (locationOfBlock diskAddr) - copyBytes buffer fileHandle numBytes - --- |read from cache -readPartOfBlock :: DiskAddress - -> INInt -- Block offset - -> BinHandle -- Buffer - -> INInt -- buffer offset - -> INInt -- number of bytes to read - -> FSRead INInt -- number of bytes read -readPartOfBlock da blockOffset buffer - bufferOffset numToRead = do - FSRoot{device=dev, bbCache=cache} <- unsafeReadGet --- unsafeLiftIOWrite $ print "readPartOfBlock" - getBlockFromCacheOrDevice cache dev da (\ bb -> do - unsafeLiftIORW $ copyFromBufferBlock bb (inIntToInt blockOffset) buffer (inIntToInt bufferOffset) (inIntToInt numToRead) - return numToRead) - -writePartOfBlock :: DiskAddress - -> INInt -- Block offset - -> BinHandle -- Buffer to read from - -> INInt -- buffer offset - -> INInt -- number of bytes to write - -> FSWrite INInt -- number of bytes written -writePartOfBlock da blockOffset buffer - bufferOffset numToWrite = do - FSRoot{device=dev, bbCache=cache} <- unsafeWriteGet -- FIX: Watch for concurrency issues here. --- unsafeLiftIOWrite $ print "writePartOfBlock" - getBlockFromCacheOrDevice cache dev - -- seek positions should be taking care of this. FIX: should we do so here too? - (assert (blockOffset + numToWrite <= (intToINInt bytesPerBlock)) da) - (\ bb -> do --- unsafeLiftIOWrite $ print $ "writePartOfBlock : " ++ show (bbDiskAddr bb) - unsafeLiftIORW $ copyToBufferBlock buffer (inIntToInt bufferOffset) bb (inIntToInt blockOffset) (inIntToInt numToWrite) - markBlockDirtyWrite bb - return numToWrite) - -{- UNUSED: --- For convenience -inBinPtr :: INInt -> Bin a -inBinPtr i = BinPtr $ inIntToInt i --} - --- ------------------------------------------------------------ --- * Inode Stuff --- ------------------------------------------------------------ - --- |gets all the inodes in a BufferBlock. -getInodesBin :: (FSRW m) => BufferBlock s -> m InodeBlock -getInodesBin bb = do - sequence [ do pbb <- unsafeLiftIORW $ mkInodeBlock bb i - unsafeLiftIORW $ getPartBufferBlock pbb - | i <- [0..(inIntToInt inodesPerBlock - 1) ] - ] - - --- Write the DiskAddress pointers inside an Inode into a block, --- zeroing the rest of the block. - -putPointersBin :: (FSRW m) => BufferBlock s -> Inode -> m () -putPointersBin bb (Inode _ ptrs) = do - -- must zero this block so we know where the _real_ - -- pointers end. - unsafeLiftIORW $ zeroBufferBlock bb - unsafeLiftIORW $ writeToBufferBlock bb startBufferBlockCursor [ Alloc e | e <- elems ptrs ] - --- ------------------------------------------------------------ --- * Inode Stuff --- ------------------------------------------------------------ - --- |Update this inode according to the given function. -fsRootUpdateInode :: INInt -- Inode to look up - -> (Inode -> Inode) -- function to apply - -> FSWrite () -- Nothing if this inode isn't in cache -fsRootUpdateInode inodeNum f = do - inode <- getInodeWrite inodeNum Nothing - modifyFSWrite (\fsroot -> return (fsRootUpdateInodeCache fsroot (f inode), ())) - --- |In preparation for a read or a write, we might want to get a --- binhandle that's positioned at the beginning of the given inode. --- Reads from disk. May increase the size of the root inode if the --- requested inode is outside its current range. The size of the root --- inode is always along block boundries. FIX: Move to FSRead monad. - -unsafeMoveBinHandleForInodeNum :: INInt -- ^The inode number - -> Bool -- ^True if it's safe to call "Write" functions - -> (forall s . PartBufferBlock Inode s -> FSRead a) - -> FSRead a -unsafeMoveBinHandleForInodeNum inodeNum forWrite cont = do - -- FIX: Below 'get' might indeed be thread unsafe. see comments below. - rootInode <- (do fsroot <- unsafeReadGet - return (fsRootInode fsroot)) - if forWrite - then unsafeWriteToRead (do - -- FIX: concurrency: should possibly block on this interval (to update) - getBlockFromInodeWrite rootInode inodeBlock (\ bb -> do - -- getBlockFromInode has ensured that the root inode has the blocks - -- it needs, but it hasn't actually bumped the size of this inode if - -- necessary. Plus 1 since count from zero. - let (minSizeForInode::INLong) - = inIntToINLong $ (inodeBlock + 1) * (intToINInt bytesPerBlock) - -- FIX: Better error in Nothing case. - () <- fsRootUpdateInode rootInodeNum - (\i -> inodeBumpSize i minSizeForInode) - pbb <- unsafeLiftIORW $ mkInodeBlock bb (inIntToInt inodeIndexThisBlock) - readToWrite (cont pbb))) - else -- FIX: concurrency: should we block between 'get' and here? - getBlockFromInodeRead rootInode inodeBlock (\ bb -> do - -- getBlockFromInode has ensured that the root inode has the blocks - -- it needs, but it hasn't actually bumped the size of this inode if - -- necessary. Plus 1 since count from zero. - - --- AJG: because this is the read case, we should not need to get new space for the inode. --- let (minSizeForInode::INLong) --- = inIntToINLong $ (inodeBlock + 1) * (intToINInt bytesPerBlock) --- -- FIX: Better error in Nothing case. --- () <- fsRootUpdateInode rootInodeNum --- (\i -> inodeBumpSize i minSizeForInode) - pbb <- unsafeLiftIORW $ mkInodeBlock bb (inIntToInt inodeIndexThisBlock) - cont pbb) - - - - where - - inodeBlock = (inodeNum `div` inodesPerBlock) :: INInt - inodeBaseThisBlock = (inodeBlock * inodesPerBlock) :: INInt - inodeIndexThisBlock = inodeNum - inodeBaseThisBlock - - -- to be used for _writing_ inodes. Be sure to bump the size - -- yourself when using this function. - getBlockFromInodeWrite :: Inode - -> BlockNumber - -> (forall s . BufferBlock s -> FSWrite a) - -> FSWrite a - getBlockFromInodeWrite inode blockNumber ncont = do - addr <- getDiskAddrOfBlockWrite inode blockNumber - getBlockFromCacheOrDeviceWrite addr ncont - - -- to be used for _reading_ inodes - getBlockFromInodeRead :: Inode - -> BlockNumber - -> (forall s . BufferBlock s -> FSRead a) - -> FSRead a - getBlockFromInodeRead inode blockNumber ncont = do - FSRoot{device=dev, bbCache=cache} <- unsafeReadGet - addr <- getDiskAddrOfBlockRead inode blockNumber - getBlockFromCacheOrDevice cache dev addr ncont - --- |Like getInode, syncs a single inode. -syncInode ::Inode -> FSWrite () -syncInode inode@Inode{metaData=InodeMetadata{inode_num=inodeNum}} = do - readToWriteCont (unsafeMoveBinHandleForInodeNum inodeNum True) (\ inode_pbb -> - -- FIX: we might have "bad" / uninitialized inodes that we've read - -- from disk. How do we really know if we should sync them? This - -- is an issue because we try to interpret some of the fields, like - -- fileMode, into their more concrete types; maybe we just shouldn't - -- do that :( - when (goodInodeMagic inode) - (unsafeLiftIORW $ putPartBufferBlock inode_pbb (assert (goodInodeMagic inode) inode)) - ) - -getInodeWrite :: INInt -> Maybe FileType -> FSWrite Inode -getInodeWrite num mType = readToWrite $ getInodeRead num mType - --- |Gets an inode based on its inode number, performs some math to --- figure out what block it's in and stuff. FIX: Make it read a whole --- block of inodes in one go and adds them to the cache (via --- readInodeUpdateCache) - -getInodeRead :: INInt -- inode number to get - -> Maybe FileType -- Nothing if Read from disk? - -> FSRead Inode -getInodeRead inodeNum mType = do - -- FIX: concurrency: Check for threading issues w/ cache. - FSRoot{inodeCache=cache} <- unsafeReadGet - when (inodeNum < 0) (error $ "illegal inode value: " ++ (show inodeNum)) - case getFromInodeCache cache inodeNum of - Nothing -> case mType of - Nothing -> do - unsafeMoveBinHandleForInodeNum inodeNum False (\ inode_pbb -> do - --- FIX: might want to turn off this optimization if it's not actually faster. -{- - let wholeBlockOptimization = True - newElt' - <- if wholeBlockOptimization - then do (i, c') <- readInodeUpdateCache cache - inodeNum - bb - -- FIX: concurrency: thread issues here w/ cache. - unsafeModifyFSRead (\r -> (r{inodeCache=c'}, ())) - return i - else - .. getPart + unsafeModify below .. - -- AJG: turned off this optimization for now - -- The moveBinHandle should not be used before reading - -- the whole block, because it computes a location/offset. - -- (conceptual issue, not a correctness issue) --} - - newElt' <- unsafeLiftIORW $ getPartBufferBlock inode_pbb - -- update the cache: - unsafeModifyFSRead - (\fsroot@FSRoot{inodeCache=the_cache} - -- FIX: Do something w/ snd? - -> (fsroot{inodeCache=fst $ - addToInodeCache InodeCacheKeep - (the_cache, inodeNum) newElt'} - , ())) - - unless ((inode_num $ metaData newElt') == inodeNum - && (goodInodeMagic newElt')) - (error $ "illegal inode: " ++ (show newElt')) - assert ((inode_num $ metaData newElt') == inodeNum - && (goodInodeMagic newElt')) - (return newElt')) - Just t -> return (newInode inodeNum t) - - Just n -> return n - --- |Possibly modifies the inode cache. "Raw" function for reading an --- inode in. Uses rawDevice instead of fsroot. - --- TODO: Add the BBC as an argumenthere. - -readInodeBootStrap :: InodeCache - -> RawDevice - -> Inode -- ^root inode - -> InodeNum - -> IO (Inode, InodeCache) -readInodeBootStrap cache inDevice rootInode inodeNum = - case getFromInodeCache cache inodeNum of - Just n -> return (n, cache) - Nothing -> do let (blockNum::BlockNumber) - = inodeNum `div` inodesPerBlock - addrM <- getDiskAddrOfBlockRaw rootInode - blockNum inDevice - let addr = fromJustErr - ("FIX: uninitialized read. blockNum:inodeNum " - ++ (show blockNum) ++ ":" ++ (show inodeNum)) - addrM - getBlockFromDevice inDevice addr (\ bb -> do - readInodeUpdateCache cache inodeNum bb) - --- |Reads all of the inodes from this binhandle, returns the new inode --- and cache. -readInodeUpdateCache :: (FSRW m) - => InodeCache - -> InodeNum - -> BufferBlock s - -> m (Inode, InodeCache) -readInodeUpdateCache cache inodeNum bb = do - let blockNum = inodeNum `div` inodesPerBlock - inodeBlock <- getInodesBin bb - -- dylan says we'll never have more than 4 billion inodes. FIX: - -- Where does that number come from? seems like 16 * 1024 to me. - let (firstInodeNum::INInt) = blockNum * inodesPerBlock - - -- we throw away the 'max inode number' since these inodes may or - -- may not be valid. That number has to get set in allocateInode. - let (newCache, _) - = foldl (addToInodeCache InodeCacheKeep) - (cache, firstInodeNum) - inodeBlock - -- fromJustErr should be OK since we just added it above. - let newInode' = fromJustErr "can't find inode which was just added to cache" - (getFromInodeCache newCache inodeNum) - return (newInode', newCache) - --- |We ignore the dirty bit here and write it to this handle no matter --- what; the parent should check the dirty bit! -writeInodeMapBin :: BinHandle - -> TheInodeMap - -> FSWrite () -writeInodeMapBin buffer (TheInodeMap freeN _ numInodes) = do - resetBinRW buffer - writeToBuffer buffer (length freeN) - mapM_ (writeToBuffer buffer) freeN - writeToBuffer buffer numInodes - --- ------------------------------------------------------------ --- * BlockMap --- ------------------------------------------------------------ - --- |Reads the free block list from this handle. Size of the output --- queue is = input size. - -inputFreeBlockList :: (FSRW m) => INInt -- ^Num blocks - -> BinHandle - -> Queue DiskAddress - -> m (Queue DiskAddress) -inputFreeBlockList n buffer q - | n <= 0 = return q - | otherwise = do - da <- getRW buffer - inputFreeBlockList (n-1) buffer $! (addToQueue q da) - --- |Write the block map into the beginning of this buffer. -writeBlockMapBin :: BinHandle - -> TheBlockMap - -> FSWrite () -writeBlockMapBin buffer bm = do - resetBinRW buffer - let listQ = queueToList (freeBlocks bm) - writeToBuffer buffer (length listQ) - writeToBuffer buffer (bmTotalSize bm) - mapM_ (writeToBuffer buffer) listQ - - --- ------------------------------------------------------------ --- * Directory stuff --- ------------------------------------------------------------ - -writeDirectoryBin :: BinHandle -> DirectoryMap -> FSWrite () -writeDirectoryBin buffer theMap = do - resetBinRW buffer - let l = Map.toList theMap - writeToBuffer buffer (length l) - mapM_ (writeToBuffer buffer) l - -readDirectoryBin :: (FSRW m) => BinHandle -> m DirectoryMap -readDirectoryBin buffer = do - resetBinRW buffer - size <- getRW buffer - l <- sequence $ replicate size (do f <- getRW buffer - return f) - return $ Map.fromList l - ------------------------------------------------------------- - -readInodeMapBin :: (FSRW m) => BinHandle -> m TheInodeMap -readInodeMapBin buffer = do - resetBinRW buffer - numInodes <- getRW buffer - inodeNums <- inputInodeMap numInodes buffer - maxInodeNum <- getRW buffer - return $ TheInodeMap inodeNums False maxInodeNum - --- |Reads the block map from the beginning of this buffer. Fix: Clean or dirty! -readBlockMapBin :: (FSRW m) => BinHandle - -> m TheBlockMap -readBlockMapBin buffer = do - resetBinRW buffer - numFree <- getRW buffer - size <- getRW buffer - freeBlks <- inputFreeBlockList numFree buffer emptyQueue - return (mkBlockMap freeBlks False size) - -inputInodeMap :: (FSRW m) => INInt -- Num inodes - -> BinHandle - -> m [INInt] -inputInodeMap num buffer - | num <= 0 = return [] - | otherwise = do - inodeNum <- getRW buffer - tails <- inputInodeMap (num - 1) buffer - return $ inodeNum : tails - --- |Traverses these non-zero pointers removing them from block map -freeInodeData :: Inode - -> FSWrite () -freeInodeData inode = do - allBlocks <- allBlocksInInode' inode - mapM_ freeDA allBlocks - where freeDA :: DiskAddress -> FSWrite () - freeDA bp = Halfs.FSState.modify (\fsroot'@FSRoot{blockMap=bm} - -> fsroot'{blockMap=freeBlock bm bp}) - -allBlocksInInode :: INInt -- Inode number - -> FSWrite [DiskAddress] -allBlocksInInode inodeNum = do - inode <- getInodeWrite inodeNum Nothing - allBlocksInInode' inode - --- |Get all the blocks from this inode, including indirect blocks and --- their children. -allBlocksInInode' :: Inode - -> FSWrite [DiskAddress] -allBlocksInInode' inode@Inode{metaData=InodeMetadata{inode_num=inodeNum}} = do - let lev = level $ metaData inode - -- filter out zeros except 0th block in root. - -- FIX: what happens when root becomes level 2? - ptrs = [block | (index, block) <- assocs $ blockPtrs inode - , (block /= 0) || (block == 0 && inodeNum == 0 && index == 0) - ] - mapM (allBlocksAt inodeNum lev) ptrs >>= return . concat - where - allBlocksAt :: InodeNum -> INInt -> DiskAddress -> FSWrite [DiskAddress] - allBlocksAt _ 1 bp = return [bp] - allBlocksAt inodeNum1 n indirBP = do - allBlocks <- getBlockFromCacheOrDeviceWrite indirBP (\ bb -> - unsafeLiftIORW $ diskAddressListFromBufferBlock bb) - let allBlockElems = [block | (index, block) <- zip [(0::Int)..] allBlocks - , (block /= 0) || (block == 0 && inodeNum1 == 0 && index == 0) - ] - rest <- mapM (allBlocksAt inodeNum1 (n - 1)) allBlockElems - return $ indirBP:(concat rest) - ------------------------------------------------------------- --- |Free the given inode from this fsroot. free the block pointers, --- remove from inode map. TODO: XX mvar to sync. -fsRootFreeInode :: Inode - -> FSWrite () -fsRootFreeInode inode = do - let num = inode_num $ metaData inode - Halfs.FSState.modify (\fsroot@FSRoot{inodeMap=theMap} - -> fsroot{inodeMap=freeInode theMap num}) - -- remove it from the directory cache, in case it's a directory: - Halfs.FSState.modify (fsRootRmFromDirectoryCache num) - freeInodeData inode - --- ------------------------------------------------------------ --- * Testing --- ------------------------------------------------------------ - --- Not used, inclued as example -binaryCopyFile :: FilePath -> FilePath -> IO () -binaryCopyFile f1 f2 = do - size <- (do h <- openFile f1 ReadMode - s <- hFileSize h - hClose h - return s) - h <- openFd f1 ReadOnly Nothing defaultFileFlags - bh <- openBinIO h - h' <- openFd f2 WriteOnly (Just (foldl1 unionFileModes - [ ownerReadMode - , ownerWriteMode - , groupReadMode])) - defaultFileFlags - bh' <- openBinIO h' - copyBytes bh - bh' - (fromIntegral'' size) - closeFd h - closeFd h' - --- How to pretend we're using C... only works with a file size < --- buffer size --- TODO: should this be here? - -binaryCopyFile' :: FilePath -> FilePath -> IO () -binaryCopyFile' from to = do - numBytes <- (do h <- openFile from ReadMode - s <- hFileSize h - hClose h - return s) - buffer <- openBinMem (fromIntegral numBytes) - hFrom <- openFd from ReadWrite Nothing defaultFileFlags - devBufferReadHost hFrom 0 buffer (fromIntegral'' numBytes) - resetBin buffer - -- above call resets the buffer, so this is safe: - hTo <- openFd to ReadWrite (Just (foldl1 unionFileModes [ ownerReadMode - , ownerWriteMode - , groupReadMode])) - defaultFileFlags - devBufferWriteHost hTo 0 buffer (fromIntegral'' numBytes) - closeFd hFrom - closeFd hTo - --- ------------------------------------------------------------ --- * inode testing --- ------------------------------------------------------------ - -inodeHunitTests :: [Test] -inodeHunitTests = [ - TestLabel "root inode tests" $ TestCase $ do --- newFS "halfs-client1" 2000 Nothing - dev <- makeRawDevice Nothing "halfs-client1" - buffer <- getMemoryBlock - bb <- mkBufferBlock buffer dev 0 - devBufferRead dev 0 buffer - (rootInode':_) <- getInodesBin bb - - assertEqual "root inode magic number incorrect" - (magic1 $ metaData rootInode') - rootInodeMagicNum - - -- Only level 1 is implemented - assertEqual "root inode level unimplemented" - (level $ metaData rootInode') 1 - finalizeDevice dev - --- It's no longer the case that the disk address of the block map is --- 0, since when it gets re- written, it may get a new address. --- let diskAddr = getPointerAt rootInode' 0 --- assertEqual "0th disk addr of root inode 0" diskAddr 0 --- let diskAddr' = getPointerAt rootInode' 1 --- assertEqual "0th disk addr of root inode 1" diskAddr' 1 - ] - --- tests: - -unitTests :: UnitTests -unitTests = hunitToUnitTest hunitTests - -hunitTests :: [Test] -hunitTests = - [TestLabel "binary copy file" $ TestCase $ do - doesFileExist "tests/to" >>= \e -> when e (removeFile "tests/to") - - binaryCopyFile "tests/from" "tests/to" - assertCmd "diff tests/from tests/to" "binary file copy failed" - - doesFileExist "tests/to" >>= \e -> when e (removeFile "tests/to") - binaryCopyFile' "tests/from" "tests/to" - assertCmd "diff tests/from tests/to" "binary file copy' failed" - - doesFileExist "tests/bigTo" >>= \e -> when e (removeFile "tests/bigTo") - - binaryCopyFile "tests/multiBlockFile" "tests/bigTo" - assertCmd "diff tests/multiBlockFile tests/bigTo" "binary file copy failed" - - doesFileExist "tests/bigTo" >>= \e -> when e (removeFile "tests/bigTo") - - binaryCopyFile' "tests/multiBlockFile" "tests/bigTo" - assertCmd "diff tests/multiBlockFile tests/bigTo" "binary file copy failed" - - - ] ++ inodeHunitTests diff --git a/Halfs/BasicIO.hs-boot b/Halfs/BasicIO.hs-boot deleted file mode 100644 --- a/Halfs/BasicIO.hs-boot +++ /dev/null @@ -1,12 +0,0 @@ -module Halfs.BasicIO where - -import Data.Integral -import Data.Maybe -import Halfs.Utils -import Halfs.FSState -import Halfs.Inode -import Halfs.FSRW -import Halfs.BufferBlock - -getInodeWrite :: INInt -> Maybe FileType -> FSWrite Inode -putPointersBin :: (FSRW m) => BufferBlock s -> Inode -> m () diff --git a/Halfs/BinaryMonad.hs b/Halfs/BinaryMonad.hs deleted file mode 100644 --- a/Halfs/BinaryMonad.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Halfs.BinaryMonad ( FSRW - , openBinMemRW, getMemoryBlockRW - , resetBinRW, sizeBinMemRW, getRW, copyBytesRW - , putRW, putRW_, seekBinRW, tellBinRW) - where - -import Binary( BinHandle, Binary, Bin - , openBinMem, resetBin, sizeBinMem, get, put, put_ - , seekBin, tellBin, copyBytes, BinaryHandle ) -import System.RawDevice(BufferBlockHandle, newBufferBlockHandle) -import Halfs.FSRW ( FSRW - , unsafeLiftIORW) - --- NOTE: leak -getMemoryBlockRW :: (FSRW m) => m (BufferBlockHandle s) -getMemoryBlockRW = unsafeLiftIORW $ newBufferBlockHandle - -openBinMemRW :: (FSRW m) => Int -> m BinHandle -openBinMemRW = unsafeLiftIORW . openBinMem - -resetBinRW :: (FSRW m,BinaryHandle h) => h -> m () -resetBinRW = unsafeLiftIORW . resetBin - -seekBinRW :: (FSRW m,BinaryHandle h) => h -> Bin a -> m () -seekBinRW h b = unsafeLiftIORW (seekBin h b) - -tellBinRW :: (FSRW m,BinaryHandle h) => h -> m (Bin a) -tellBinRW = unsafeLiftIORW . tellBin - -sizeBinMemRW :: (FSRW m) => BinHandle -> m Int -sizeBinMemRW = unsafeLiftIORW . sizeBinMem - -getRW :: (FSRW m, Binary a,BinaryHandle h) => h -> m a -getRW = unsafeLiftIORW . get - -copyBytesRW :: (FSRW m,BinaryHandle h1,BinaryHandle h2) - => h1 -- ^input handle - -> h2 -- ^output handle - -> Int -- ^number of bytes to copy - -> m () -copyBytesRW a b c = unsafeLiftIORW (copyBytes a b c) - --- |FIX: Consider moving to just write monad. Is this ever legit to use for reading? -putRW :: (FSRW m, Binary a, BinaryHandle h) => h -> a -> m (Bin a) -putRW b a = unsafeLiftIORW $ put b a - -putRW_ :: (FSRW m, Binary a,BinaryHandle h) => h -> a -> m () -putRW_ b a = unsafeLiftIORW $ put_ b a diff --git a/Halfs/BlockMap.hs b/Halfs/BlockMap.hs new file mode 100644 --- /dev/null +++ b/Halfs/BlockMap.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances, BangPatterns #-} +module Halfs.BlockMap + ( + -- * Types + BlockGroup(..) + , BlockMap(..) + , Extent(..) + -- * Block Map creation, de/serialization, and query functions + , newBlockMap + , readBlockMap + , writeBlockMap + , numFreeBlocks + -- * Block Map allocation/unallocation functions + , alloc1 + , allocBlocks + , unalloc1 + , unallocBlocks + -- * Utility functions + , blkGroupExts + , blkGroupSz + , blkRange + , blkRangeExt + , blkRangeBG + -- * Internal use only + , blockMapSizeBlks + , newUsedBitmap + , writeUsedBitmap + ) + where + +import Control.Exception (assert) +import Data.Bits hiding (setBit, clearBit) +import qualified Data.Bits as B +import qualified Data.ByteString as BS +import Data.FingerTree +import qualified Data.Foldable as DF +import Data.Monoid +import Data.Word +import Prelude hiding (null) + +import Halfs.Classes +import Halfs.Monad +import Halfs.Utils +import System.Device.BlockDevice + +-- ---------------------------------------------------------------------------- +-- +-- Important block format diagram for a ficticious block device w/ 36 blocks; +-- note that the superblock always consumes exactly one block, while the +-- blockmap itself may span multiple blocks as needed, depending on device +-- geometry. +-- +-- 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 3 +-- 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 +-- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +-- |S|M| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | +-- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +-- +-- + +{- + +TODO: + +-} + +data BlockGroup = Contig Extent | Discontig [Extent] + deriving (Show, Eq) + +data Extent = Extent { extBase :: Word64, extSz :: Word64 } + deriving (Show, Eq) + +newtype ExtentSize = ES Word64 +type FreeTree = FingerTree ExtentSize Extent + +instance Monoid ExtentSize where + mempty = ES minBound + mappend (ES a) (ES b) = ES (max a b) + +instance Measured ExtentSize Extent where + measure (Extent _ s) = ES s + +splitBlockSz :: Word64 -> FreeTree -> (FreeTree, FreeTree) +splitBlockSz sz = split $ \(ES y) -> y >= sz + +insert :: Extent -> FreeTree -> FreeTree +insert ext tr = treeL >< (ext <| treeR) + where (treeL, treeR) = splitBlockSz (extSz ext) tr + +-- ---------------------------------------------------------------------------- + +data BlockMap b r l = BM { + bmFreeTree :: r FreeTree + , bmUsedMap :: b -- ^ Is the given block free? + , bmNumFree :: r Word64 -- ^ Number of available free blocks; the blockmap + -- never counts blocks required for storing + -- blockmap itself nor the superblock as 'free' + , bmLock :: l + } + +-- | Calculate the number of bytes required to store a block map for the +-- given number of blocks +blockMapSizeBytes :: Word64 -> Word64 +blockMapSizeBytes numBlks = numBlks `divCeil` 8 + +-- | Calculate the number of blocks required to store a block map for +-- the given number of blocks. +blockMapSizeBlks :: Word64 -> Word64 -> Word64 +blockMapSizeBlks numBlks blkSzBytes = bytes `divCeil` blkSzBytes + where bytes = blockMapSizeBytes numBlks + +-- | Create a new block map for the given device geometry +newBlockMap :: (Monad m, Reffable r m, Bitmapped b m, Lockable l m) => + BlockDevice m + -> m (BlockMap b r l) +newBlockMap dev = do + when (numFree == 0) $ fail "Block device is too small for block map creation" + + bArr <- newUsedBitmap dev + treeR <- newRef $ singleton $ Extent baseFreeIdx numFree + numFreeR <- newRef numFree + lk <- newLock + return $ assert (baseFreeIdx + numFree == numBlks) $ + BM treeR bArr numFreeR lk + where + numBlks = bdNumBlocks dev + blockMapSzBlks = blockMapSizeBlks numBlks (bdBlockSize dev) + baseFreeIdx = blockMapSzBlks + 1 + numFree = numBlks - blockMapSzBlks - 1 {- -1 for superblock -} + +newUsedBitmap :: (Monad m, Reffable r m, Bitmapped b m, Lockable l m) => + BlockDevice m + -> m b +newUsedBitmap dev = do + -- We overallocate the bitmap up to the entire size of the block(s) + -- needed for the block map region so that de/serialization in the + -- {read,write}BlockMap functions is straightforward + bArr <- newBitmap totalBits False + let markUsed (l,h) = forM_ [l..h] (setBit bArr) + mapM_ markUsed + [ (0, 0) -- superblock + , (1, blockMapSzBlks) -- blocks for storing the block map + , (numBlks, totalBits - 1) -- overallocated region + ] + return bArr + where + numBlks = bdNumBlocks dev + totalBits = blockMapSzBlks * bdBlockSize dev * 8 + blockMapSzBlks = blockMapSizeBlks numBlks (bdBlockSize dev) + +-- | Read in the block map from the disk +readBlockMap :: (Monad m, Reffable r m, Bitmapped b m, Lockable l m) => + BlockDevice m + -> m (BlockMap b r l) +readBlockMap dev = do + bArr <- newBitmap totalBits False + freeR <- newRef 0 + + -- Unpack the block map's block region into the empty bitmap + forM_ [0..blockMapSzBlks - 1] $ \blkIdx -> do + blockBS <- bdReadBlock dev (blkIdx + 1 {- +1 for superblock -}) + forM_ [0..bdBlockSize dev - 1] $ \byteIdx -> do + let byte = BS.index blockBS (fromIntegral byteIdx) + forM_ [0..7] $ \bitIdx -> do + if (testBit byte bitIdx) + then do let baseByte = blkIdx * bdBlockSize dev + idx = (baseByte + byteIdx) * 8 + fromIntegral bitIdx + setBit bArr idx + else do cur <- readRef freeR + writeRef freeR $ cur + 1 + + baseTreeR <- newRef empty + getFreeBlocks bArr baseTreeR Nothing 0 + lk <- newLock + return $ BM baseTreeR bArr freeR lk + where + numBlks = bdNumBlocks dev + totalBits = blockMapSzBlks * bdBlockSize dev * 8 + blockMapSzBlks = blockMapSizeBlks numBlks (bdBlockSize dev) + -- + writeExtent treeR ext = do + t <- readRef treeR + writeRef treeR $ insert ext t + -- + -- getFreeBlocks recurses over each used bit in the used bitmap and + -- finds runs of free block regions, inserting representative Extents + -- into the "free tree" as it does so. The third parameter tracks the + -- block address of start of the current free region. + getFreeBlocks _bmap treeR mb cur | cur == totalBits = + maybe (return ()) (writeExtent treeR . \b -> Extent b (cur - b)) mb + + getFreeBlocks bmap treeR Nothing cur = do + used <- checkBit bmap cur + getFreeBlocks bmap treeR (if used then Nothing else Just cur) (cur + 1) + + getFreeBlocks bmap treeR b@(Just base) cur = do + used <- checkBit bmap cur + when used $ writeExtent treeR (Extent base $ cur - base) + getFreeBlocks bmap treeR (if used then Nothing else b) (cur + 1) + +-- | Write the block map to the disk +writeBlockMap :: + (Monad m, Reffable r m, Bitmapped b m, Functor m, Lockable l m) => + BlockDevice m + -> BlockMap b r l + -> m () +writeBlockMap dev bmap = do + withLockM (bmLock bmap) $ writeUsedBitmap dev (bmUsedMap bmap) + +writeUsedBitmap :: + (Monad m, Reffable r m, Bitmapped b m, Functor m, Lockable l m) => + BlockDevice m + -> b + -> m () +writeUsedBitmap dev used = do + -- Pack the given bitmap into the block map's block region + forM_ [0..blockMapSzBlks - 1] $ \blkIdx -> do + blockBS <- BS.pack `fmap` forM [0..bdBlockSize dev - 1] (getBytes blkIdx) + bdWriteBlock dev (blkIdx + 1 {- +1 for superblock -}) blockBS + where + numBlks = bdNumBlocks dev + blockMapSzBlks = blockMapSizeBlks numBlks (bdBlockSize dev) + -- + getBytes blkIdx byteIdx = do + bs <- forM [0..7] $ \bitIdx -> do + let base = blkIdx * bdBlockSize dev + idx = (base + byteIdx) * 8 + bitIdx + checkBit used idx + return $ foldr (\(b,i) r -> if b then B.setBit r i else r) + (0::Word8) (bs `zip` [0..7]) + +-- | Allocate a set of blocks from the disk. This routine will attempt +-- to fetch a contiguous set of blocks, but isn't guaranteed to do so. +-- Contiguous blocks are represented via the Contig constructor of the +-- BlockGroup datatype, discontiguous blocks via Discontig. If there +-- aren't enough blocks available, this function yields Nothing. +allocBlocks :: (Monad m, Reffable r m, Bitmapped b m, Lockable l m) => + BlockMap b r l + -- ^ the block map + -> Word64 + -- ^ requested number of blocks to allocate + -> m (Maybe BlockGroup) +allocBlocks bm numBlocks = do + withLockM (bmLock bm) $ do + available <- readRef $ bmNumFree bm + if available < numBlocks + then do + return Nothing + else do + freeTree <- readRef $ bmFreeTree bm + let (blkGroup, freeTree') = findSpace numBlocks freeTree + forM_ (blkRangeBG blkGroup) $ setBit $ bmUsedMap bm + writeRef (bmFreeTree bm) freeTree' + writeRef (bmNumFree bm) (available - numBlocks) + return $ Just blkGroup + +-- | Allocate a single block +alloc1 :: (Bitmapped b m, Reffable r m, Lockable l m) => + BlockMap b r l -> m (Maybe Word64) +alloc1 bm = do + res <- allocBlocks bm 1 + case res of + Just (Contig ext) -> return $ Just $ extBase ext + _ -> return Nothing + +-- | Unallocate a single block +unalloc1 :: (Bitmapped b m, Reffable r m, Lockable l m) => + BlockMap b r l -> Word64 -> m () +unalloc1 bm addr = unallocBlocks bm $ Contig $ Extent addr 1 + +-- | Mark a given block group as unused +unallocBlocks :: (Monad m, Reffable r m, Bitmapped b m, Lockable l m) => + BlockMap b r l -- ^ the block map + -> BlockGroup + -> m () +unallocBlocks bm bg = withLockM (bmLock bm) $ unallocBlocks_lckd bm bg + +unallocBlocks_lckd :: (Monad m, Reffable r m, Bitmapped b m, Lockable l m) => + BlockMap b r l -- ^ the block map + -> BlockGroup + -> m () +unallocBlocks_lckd bm (Discontig exts) = do + -- Precond: (bmLock bm) is currently held (can we assert this? TODO) + mapM_ (unallocBlocks_lckd bm . Contig) exts +unallocBlocks_lckd bm (Contig ext) = do + -- Precond: (bmLock bm) is currently held (can we assert this? TODO) + avail <- numFreeBlocks_lckd bm + freeTree <- readRef $ bmFreeTree bm + forM_ (blkRangeExt ext) $ clearBit $ bmUsedMap bm + writeRef (bmFreeTree bm) $ insert ext freeTree + writeRef (bmNumFree bm) $ avail + extSz ext + +-- | Return the number of blocks currently left +numFreeBlocks :: (Monad m, Reffable r m, Bitmapped b m, Lockable l m) => + BlockMap b r l + -> m Word64 +numFreeBlocks bm = withLockM (bmLock bm) $ numFreeBlocks_lckd bm + +numFreeBlocks_lckd :: (Monad m, Reffable r m, Bitmapped b m, Lockable l m) => + BlockMap b r l + -> m Word64 +numFreeBlocks_lckd bm = + -- Precond: (bmLock bm) is currently held (can we assert this? TODO) + readRef $ bmNumFree bm + +findSpace :: Word64 -> FreeTree -> (BlockGroup, FreeTree) +findSpace goalSz freeTree = + -- Precondition: There is sufficient space in the free tree to accomodate the + -- given goal size, although that space may not be contiguous + assert (goalSz <= DF.foldr ((+) . extSz) 0 freeTree) $ do + let (treeL, treeR) = splitBlockSz goalSz freeTree + case viewl treeR of + Extent b sz :< treeR' -> + -- Found an extent with size >= the goal size + ( Contig $ Extent b goalSz + , -- Split the found extent when it exceeds the goal size + let mid = if sz > goalSz + then singleton $ Extent (b + goalSz) (sz - goalSz) + else empty + in treeL >< mid >< treeR' + ) + + EmptyL -> + -- Cannot find an extent large enough, so gather smaller extents + fmapFst Discontig $ gatherL (viewr treeL) 0 [] + where + gatherL :: ViewR (FingerTree ExtentSize) Extent + -> Word64 + -> [Extent] + -> ([Extent], FreeTree) + gatherL EmptyR _ _ = error "Precondition violated: insufficent space" + gatherL !(treeL' :> ext@(Extent b sz)) !accSz !accExts + | accSz + sz < goalSz = gatherL (viewr treeL') + (accSz + sz) + (ext : accExts) + | accSz + sz == goalSz = (ext : accExts, treeL') + | otherwise = + -- We've exceeded the goal, so split the extent we just encountered + (Extent (b + diff) (sz - diff) : accExts, treeL' >< extra) + where diff = accSz + sz - goalSz + extra = singleton $ Extent b diff + +-------------------------------------------------------------------------------- +-- Utility functions + +blkRange :: Word64 -> Word64 -> [Word64] +blkRange b sz = [b .. b + sz - 1] + +blkRangeExt :: Extent -> [Word64] +blkRangeExt (Extent b sz) = blkRange b sz + +blkRangeBG :: BlockGroup -> [Word64] +blkRangeBG (Contig ext) = blkRangeExt ext +blkRangeBG (Discontig exts) = concatMap blkRangeExt exts + +blkGroupExts :: BlockGroup -> [Extent] +blkGroupExts (Contig ext) = [ext] +blkGroupExts (Discontig exts) = exts + +blkGroupSz :: BlockGroup -> Word64 +blkGroupSz (Contig ext) = extSz ext +blkGroupSz (Discontig exts) = foldr (\e -> (extSz e +)) 0 exts + diff --git a/Halfs/Blocks.hs b/Halfs/Blocks.hs deleted file mode 100644 --- a/Halfs/Blocks.hs +++ /dev/null @@ -1,364 +0,0 @@ -{-# LANGUAGE Rank2Types, RankNTypes #-} -module Halfs.Blocks (getDiskAddrOfBlockRead, getDiskAddrOfBlockRaw, - getDiskAddrOfBlockWrite, getBlockFromCacheOrDeviceWrite, - numBlocksForSize, markBlockDirtyWrite) - where - -import Halfs.Inode(Inode(..), InodeMetadata(..), getPointerAt, updatePointers, - goodInodeMagic) -import Data.Integral(INInt, intToINInt, inIntToInt) -import Halfs.Utils(BlockNumber, DiskAddress, - unimplemented, bytesPerBlock, blockPointersPerInode, - blockPointersPerIndirectBlock) -import Halfs.BufferBlock (BufferBlock(..), getDiskAddr, - bufferBlockCursorIntoPointers, - BufferBlockCursor, - writeToBufferBlock, - readFromBufferBlock, - zeroBufferBlock, ---UNUSED: deadbeefBufferBlock, - Alloc(..)) -import Halfs.FSRW (unsafeLiftIORW) -import Halfs.BinaryMonad(FSRW) -import {-# SOURCE #-} Halfs.BasicIO (getInodeWrite, putPointersBin) -import Halfs.TheBlockMap(findAddress, allocateBlock) -import Halfs.FSRoot (FSRoot(..)) -import Halfs.FSState (FSWrite, FSRead, unsafeLiftIOWrite, - unsafeReadGet, updateInodeCacheWrite, - modifyFSWrite, unsafeWriteGet) -import System.RawDevice(RawDevice) -import Halfs.BufferBlockCache (markBlockDirty, - getBlockFromCacheOrDevice, - getNewBlockFromCacheOrDevice, - getBlockFromDevice) - --- base -import Control.Exception(assert) -import Control.Monad(when) -import Data.Array(listArray) -import Control.Monad.Error(MonadError) - --- |Traverses the tree of DiskAddresses implied by this block number --- and inode. Gets the block at that disk address, and positions the --- pointer in that block according to the last address in the tree, --- then reads the disk address there. This function used only for --- reading. -getDiskAddrFun :: (MonadError e m,FSRW m) - => Inode - -> BlockNumber - -> (forall m1 . forall e1 . (MonadError e1 m1, FSRW m1) => DiskAddress -> (forall s . BufferBlock s -> m1 DiskAddress) -> m1 DiskAddress) - -- ^function for getting the block since might be raw - -- device or fsroot. - -> m DiskAddress -- ^a block of indirect pointers -getDiskAddrFun inode blockNum findBlock = do - -- special case for the first block; it's in the inode itself. - let inLevel = level $ metaData (assert (goodInodeMagic inode) inode) - let addrs = findAddress inode blockNum - let firstSeek = head (assert ((intToINInt $ length addrs) == inLevel) addrs) - let firstAddr = getPointerAt inode firstSeek - findBlock firstAddr (\ nextBlock -> - looper (tail addrs) nextBlock (\ b c -> - unsafeLiftIORW (readFromBufferBlock b c))) - - where -- guts of the block recursion; handles all but first case - - looper :: (MonadError e m,FSRW m) - => [INInt] -- Dereference locations - -> BufferBlock t -- Block to start at - -> (forall s . forall m1 . forall e1 . (MonadError e1 m1,FSRW m1) => BufferBlock s -> BufferBlockCursor s -> m1 DiskAddress) - -> m DiskAddress - looper [] _b _cont = error "never happens" -- cont b -- this shouldn't happen. - looper (h:t) b cont = do - if length t > 0 - then do addr <- unsafeLiftIORW (readFromBufferBlock b (bufferBlockCursorIntoPointers h)) - findBlock addr (\ nextBlock -> - looper t nextBlock cont) - else cont b (bufferBlockCursorIntoPointers h) - --- |Get this inode from the inode cache. It SHOULD be in there, but --- just to be safe, we will look on disk if it's not. -internalGetInodeFromCache :: INInt -> FSWrite Inode -internalGetInodeFromCache inodeNum = getInodeWrite inodeNum Nothing - --- |Returns Nothing iff address is zero but inode number and block --- number aren't zero. FIX: maybe also check for out of range block --- number? -getDiskAddrOfBlockRead :: Inode - -> BlockNumber - -> FSRead DiskAddress -getDiskAddrOfBlockRead inode blockNumber = do - FSRoot{device=dev, bbCache=cache} <- unsafeReadGet - addr <- case (level $ metaData inode) of - 0 -> unimplemented "Zero optimization (getDiskAddrOfBlockRead)" - 1 -> return $ getPointerAt inode blockNumber - _ -> do getDiskAddrFun inode blockNumber - (getBlockFromCacheOrDevice cache dev) - case checkedAddr addr inode blockNumber of - Nothing -> error $ "UNINITIALIZED READ. Address is zero but inode number and block number aren't zero: " - ++ (show blockNumber) ++ (show inode) - Just a -> return a - --- |calls to getBlockFromDevice or getPointerAt, depending on level. -getDiskAddrOfBlockRaw :: (MonadError e m,FSRW m) - => Inode - -> BlockNumber - -> RawDevice - -> m (Maybe DiskAddress) -getDiskAddrOfBlockRaw inode blockNumber rawDevice = do - addr <- case (level $ metaData inode) of - 0 -> unimplemented "Zero optimization (getDiskAddrOfBlockRaw)" - 1 -> return $ getPointerAt inode blockNumber - -- FIX: make sure that the block allocated below gets freed. - _ -> do getDiskAddrFun inode blockNumber - (getBlockFromDevice rawDevice) - return $ checkedAddr addr inode blockNumber - --- |Mark this block dirty. Doesn't modify the fsroot (except the bbcache). -markBlockDirtyWrite :: BufferBlock s -> FSWrite () -markBlockDirtyWrite block = do - addr <- unsafeLiftIOWrite $ getDiskAddr block - FSRoot{device=dev, bbCache=cache} <- unsafeWriteGet -- safe - markBlockDirty cache dev addr - -{- --- |Mark this block dirty. Doesn't modify the fsroot (except the bbcache). -markBlockDirtyRead :: DiskAddress -> FSRead () -markBlockDirtyRead addr = do - addr <- unsafeLiftIOWrite $ getDiskAddr block - FSRoot{device=dev, bbCache=cache} <- unsafeReadGet -- safe - markBlockDirty cache dev addr --} - --- |Might modify inode because it might grow it. Returns Alters inode --- cache. FIX: maybe also check for out of range block number? -getDiskAddrOfBlockWrite :: Inode - -> BlockNumber - -> FSWrite DiskAddress -getDiskAddrOfBlockWrite inodeIn blockNumber = do - inode <- ensureCapacity inodeIn blockNumber - updateInodeCacheWrite inode -- just to make sure its in the cache - addr <- case level $ metaData inode of - 0 -> unimplemented "Zero optimization (getDiskAddrWrite)" - 1 -> do -- unsafeLiftIOWrite $ print "getDiskAddrOfBlockWrite<0>" - getAndPositionBlockWrite inode blockNumber (\ block _ -> unsafeLiftIOWrite $ getDiskAddr block) - _ -> - do -- unsafeLiftIOWrite $ print "getDiskAddrOfBlockWrite<*>" - getAndPositionBlockWrite inode blockNumber (\ bb (Just pos) -> do - addr <- unsafeLiftIORW $ readFromBufferBlock bb pos - return addr) - - -- Have to copy that block if its negative, but it won't be - -- indirect, so no negations: - - case checkedAddr (assert (addr >= 0) addr) inode blockNumber of - Nothing -> error $ "internal: ensureCapacity failed to ensure: " - ++ (show blockNumber) ++ (show inode) - Just a -> return a - -checkedAddr :: DiskAddress - -> Inode - -> BlockNumber - -> Maybe DiskAddress -checkedAddr addr inode blockNumber= - if addr == 0 - && inode_num (metaData inode) == 0 - && blockNumber == 0 - then Just addr - else if addr == 0 - then Nothing - else Just addr - --- |This is for reading a block. -getBlockFromCacheOrDeviceWrite :: DiskAddress - -> (forall s . BufferBlock s -> FSWrite a) - -> FSWrite a -getBlockFromCacheOrDeviceWrite da cont = do - FSRoot{device=dev, bbCache=cache} <- unsafeWriteGet - getBlockFromCacheOrDevice cache dev da cont - --- |Just like allocateBlock, but happens in the FSWrite monad. -allocateBlockWrite :: (forall s. BufferBlock s -> FSWrite a) -> FSWrite a -allocateBlockWrite cont = do - mDa <- modifyFSWrite (\fsr@FSRoot{blockMap=bm} -> do - case allocateBlock bm of - Nothing -> return (fsr, Nothing) - Just (da, bmNew) -> return (fsr{blockMap=bmNew}, Just da)) - case mDa of - Just da -> do FSRoot{device=dev, bbCache=cache} <- unsafeWriteGet - getNewBlockFromCacheOrDevice cache dev da cont - Nothing -> error "Out of disk space." - --- |Like getDiskAddrFun, but for writing. If the --- inode level is 1, then this will return the actual block. --- Otherwise, it'll return an indirect block, from which you must read --- or write the address you're interested in. -getAndPositionBlockWrite :: Inode - -> BlockNumber - -> (forall s . BufferBlock s -> (Maybe (BufferBlockCursor s)) -> FSWrite a) -- ^a block of indirect pointers - -> FSWrite a -getAndPositionBlockWrite inode blockNum cont = do - -- special case for the first block; it's in the inode itself. - let inLevel = level $ metaData inode - let inodeNum = inode_num $ metaData inode - let addrs = findAddress inode blockNum - let firstSeek = head (assert ((intToINInt $ length addrs) == inLevel) addrs) - let firstAddr = getPointerAt inode firstSeek - updateInodeCacheWrite inode -- just to make sure its in the cache, see below - getBlockFromCacheOrDeviceWrite firstAddr (\ mightBeNextBlock -> do - -- update the pointer, as it may now point to a new block. - newAddr <- unsafeLiftIOWrite $ getDiskAddr mightBeNextBlock - -- inode may have changed while copying; get it out of the - -- cache. Must be there because we made sure of that above. - inode1 <- internalGetInodeFromCache inodeNum - let i = updatePointers inode1 [(inIntToInt firstSeek, newAddr)] - updateInodeCacheWrite i - looper (tail addrs) inodeNum mightBeNextBlock cont) - where -- guts of the block recursion; handles all but first case - looper :: [INInt] -- Dereference locations - -> INInt -- InodeNum. - -> BufferBlock s -- Block to start at - -> (forall s1 . BufferBlock s1 -> (Maybe (BufferBlockCursor s1)) -> FSWrite a) - -> FSWrite a - looper [] _ b ncont = ncont b Nothing - looper (h:t) inodeNum b ncont = do - -- seek to the position, but don't actually read: - let cursor = bufferBlockCursorIntoPointers h - if length t > 0 -- b is an indirect block - then do addr <- unsafeLiftIORW $ readFromBufferBlock b cursor - getBlockFromCacheOrDeviceWrite addr - (\ mightBeNextBlock -> do - newAddr <- unsafeLiftIOWrite $ getDiskAddr mightBeNextBlock - -- the block might be at a diff. address now. if so, write it back. - when (newAddr /= addr) $ do - unsafeLiftIORW $ writeToBufferBlock b cursor [Alloc newAddr] - markBlockDirtyWrite b - looper t inodeNum mightBeNextBlock ncont) - else ncont b (Just cursor) - ------------------------------------------------------------- - --- |Conditionally grows the inode. Ensures that the inode now --- containes THIS BLOCK NUMBER, not this size (watch for off-by-one --- errors). NOTE: Be sure to bump the size when you're done! -ensureCapacity :: Inode - -> BlockNumber -- ^new capacity - -> FSWrite Inode -ensureCapacity inode newBlockNum - = ensureCapacity' inode (numBlocksForSize inode) newBlockNum - -ensureCapacity' :: Inode - -> BlockNumber -- ^current largest block number - -> BlockNumber -- ^new largest block number - -> FSWrite Inode -ensureCapacity' inodeIn currBlocksInFile newBlockNum - | (abs newBlockNum) < currBlocksInFile = - updateInodeCacheWrite inodeIn --- >> putStrLnWriteRead ("no need to grow: " ++(show (inode_num (metaData inodeIn))) ++ ":" ++ (show newBlockNum) ++ ":" ++ (show currBlocksInFile) ++ ":" ++ (show (num_bytes $ metaData inodeIn))) - >> return inodeIn - | otherwise = do - -- may change inode's level: --- putStrLnWriteRead $ "growing capacity: " ++ (show newBlockNum) - inode@Inode{metaData=InodeMetadata{inode_num=inodeNum}} - <- ensureLevel inodeIn newBlockNum - allocateBlockWrite (\ bb -> do - da <- unsafeLiftIORW $ getDiskAddr bb --- putStrLnWriteRead ("allocated new address: " ++ (show da)) >> - -- safe to coerce since it's a small file: - case level $ metaData inode of - 0 -> unimplemented "Zero optimization (ensureCapacity')" - 1 -> ensureCapacity' (updatePointers inode - [(inIntToInt currBlocksInFile, da)]) - (currBlocksInFile + 1) - newBlockNum - _ -> do when (abs newBlockNum `mod` intToINInt blockPointersPerIndirectBlock == 0) $ do - allocateBlockWrite (\ new_bb -> do --- FIX: This does not work for 32M+ files (stops with array out of bounds). --- unsafeLiftIORW $ print "allocating extra space ..." - zeroBlock new_bb - new_da <- unsafeLiftIORW $ getDiskAddr new_bb - let ix = inIntToInt $ abs newBlockNum `div` intToINInt blockPointersPerIndirectBlock - let i = updatePointers inode [(ix, new_da)] --- unsafeLiftIORW $ print ("allocated extra space ...",ix,new_da,i) - updateInodeCacheWrite i) - inode1 <- getInodeWrite inodeNum Nothing - writeAddressAt inode1 newBlockNum (assert (da /= 0) da) - -- inode may have changed: - inode2 <- getInodeWrite inodeNum Nothing - ensureCapacity' inode2 (currBlocksInFile + 1) newBlockNum) - -maxBlockNum :: INInt -- ^Level - -> BlockNumber -maxBlockNum 1 = intToINInt blockPointersPerInode - 1 -maxBlockNum n = (intToINInt blockPointersPerIndirectBlock ^ (n - 1) - * intToINInt blockPointersPerInode) - 1 - -- -1, since its counting from zero - - --- |Put a bunch of zeros into this block. -zeroBlock :: BufferBlock s -> FSWrite () -zeroBlock buffer = unsafeLiftIORW $ zeroBufferBlock buffer - - --- |When debugging, pPut a bunch of 0xDEADBEEF's into this block; --- uses just after allocating a block, so we know if we have an uninitalized value. - -{- UNUSED: -deadBeefBlock :: DiskAddress -> FSWrite () -deadBeefBlock addr = - getBlockFromCacheOrDeviceWrite addr (\ bb -> unsafeLiftIORW $ deadbeefBufferBlock bb) --} - --- |Writes this disk address into the indirect block pointed to by --- this list of addresses. Doesn't update the inode, because --- ensureLevel should have already done that. -writeAddressAt :: Inode -> BlockNumber -> DiskAddress -> FSWrite () -writeAddressAt inode blockNum da = do --- unsafeLiftIOWrite $ print $ "writeAddressAt: " ++ show da - getAndPositionBlockWrite inode blockNum (\ bb (Just cursor) -> do --- unsafeLiftIOWrite $ print $ "(1)writeAddressAt" ++ show (bbDiskAddr bb) - unsafeLiftIOWrite $ writeToBufferBlock bb cursor [Alloc da] - markBlockDirtyWrite bb) - --- |Optionally increase the level of this inode to include the given --- block number. This allocates new blocks, so is in the FSWrite --- monad. We grab a new block (which is an indirect block of block --- pointers), dump the inode's block pointers into it, then update the --- inode's block pointers to be empty except for an entry pointing to --- ths new block. Finally, we update the level. - -ensureLevel :: Inode - -> BlockNumber -- ^Block number we want to include - -> FSWrite Inode -ensureLevel inode newBlockNum - | maxBlockNum (level $ metaData inode) >= (abs newBlockNum) - = updateInodeCacheWrite inode - >> return inode - | otherwise = do - allocateBlockWrite (\ newBB -> do - let currLevel = level $ metaData inode - let inodeNum = inode_num $ metaData inode - - -- dump the block pointers from inode into new block - putPointersBin newBB inode - - da <- unsafeLiftIORW $ getDiskAddr newBB - -- inode may have changed after "getBlockFromCacheOrDeviceWrite" - -- that probably doesn't matter, because we're blowing away the pointers - -- here anyway, but just in case: - inode1 <- - (do inode2 <- getInodeWrite inodeNum Nothing - -- update the inode to point to this new block instead; - -- erasing existing list. - return inode2{blockPtrs= - listArray (0, blockPointersPerInode - 1) - (da:(replicate (blockPointersPerInode -1) 0)) - -- bump the actual level and repeat. - ,metaData=(metaData inode){level = currLevel+1} - }) - ensureLevel inode1 newBlockNum) - --- |Performs a VERY complex computation. Don't peak inside. -numBlocksForSize :: Inode -> BlockNumber -numBlocksForSize Inode{metaData=InodeMetadata{num_bytes=numBytes}} - -- Rational is arbitrary precision, so this should be safe: - = ceiling $ (toRational numBytes) / (toRational bytesPerBlock) diff --git a/Halfs/Blocks.hs-boot b/Halfs/Blocks.hs-boot deleted file mode 100644 --- a/Halfs/Blocks.hs-boot +++ /dev/null @@ -1,9 +0,0 @@ -module Halfs.Blocks where - -import Halfs.Utils -import Halfs.Inode -import Halfs.FSState - -getDiskAddrOfBlockRead :: Inode - -> BlockNumber - -> FSRead DiskAddress diff --git a/Halfs/Buffer.hs b/Halfs/Buffer.hs deleted file mode 100644 --- a/Halfs/Buffer.hs +++ /dev/null @@ -1,143 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Halfs.Buffer --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : GHC --- --- Explanation: The Buffer represents the filesystem's IO buffer. --- BinHandle for the FS. All of the conversion to-and-from strings and --- cstrings assume that each byte interpreted is a Char. The --- conversion functions which don't take a length assume that the --- entire buffer is a string. Use 'get' if you have a string whose --- length is stored at the beginning. There are functions for taking --- a certain number of characters and interpreting them as strings, --- however. --- --- FIX: Clean up types. - -module Halfs.Buffer (Buffer -- no constructor - ,strToBuff - ,strToNewBuff - ,buffToStrSize - ,buffToStr - ,withBuffSize - ,buffToCBuff - ,cBuffToBuff - ,plusBuff - ,buffSeek - ,buffGetHandle - ,newBuff - ,buffSize - ) where - -import Foreign.C.Types (CSize) -import Foreign.Ptr(Ptr) -import Data.Word(Word8) -import Data.Array.SysArray -import Binary - -newtype Buffer = Buffer (BinHandle) - -newBuff :: Int -> IO Buffer -newBuff i = openBinMem i >>= return . Buffer - -buffSize :: Buffer -> IO Int -buffSize (Buffer b) = sizeBinMem b - --- |Convert this string into a file buffer. Starts at the beginning --- of the buffer. -strToBuff :: String -> Buffer -> IO () -strToBuff s (Buffer binHandle) - = resetBin binHandle >> mapM_ (put_ binHandle) s - --- |Allocate a new buffer to fit this entire string. -strToNewBuff :: String -> IO Buffer -strToNewBuff [] = error "strToNewbuff empty list!" -strToNewBuff s = do - h <- openBinMem (length s) - let b = Buffer h - strToBuff s b - return b - --- |Extract /sz/ characters from this buffer and interpret them as a --- string. Starts at beginning of buffer. -buffToStrSize :: Int -> Buffer -> IO String -buffToStrSize sz (Buffer binHandle) = do - resetBin binHandle - s <- getMany binHandle sz - return s - --- |Evaluate this entire buffer as a string, starting from the beginning. -buffToStr :: Buffer -> IO String -buffToStr buffer@(Buffer binHandle) = do - resetBin binHandle - len <- sizeBinMem binHandle - buffToStrSize len buffer - --- |Internal helper function to grab the given number of chars from --- this handle. -getMany :: BinHandle -> Int -> IO String -getMany _ 0 = return [] -getMany bh n = do x <- Binary.get bh - xs <- getMany bh (n-1) - return (x:xs) - --- |Allocate a new buffer of the given size and perform the given --- function on that buffer. FIX: Free the buffer when done? -withBuffSize :: Int -> (Buffer -> IO a) -> IO a -withBuffSize sz f - | sz <= 0 = error "withBuffSize 0!" - | otherwise = openBinMem sz >>= f . Buffer - --- |Convert this Halfs Buffer to a C Buffer, starting at the current --- pointer. The buffer's pointer will be returned to its location. -buffToCBuff :: Buffer -> Ptr Word8 -> CSize -> IO () -buffToCBuff = forwardTwixt loop - where loop _ _ 0 = return () - loop ptr (Buffer binHandle) i = do - ptr_handle <- openFixedSysHandle - (mkSysArray (fromIntegral i) - ptr - False) - resetBin ptr_handle - copyBytes binHandle ptr_handle (fromIntegral i) - return () - --- |Convert this C buffer to a Halfs Buffer, starting at the current --- pointer. The buffer's pointer will be returned to its location. -cBuffToBuff :: Buffer -> Ptr Word8 -> CSize -> IO () -cBuffToBuff = forwardTwixt loop - where loop _ _ 0 = return () - loop ptr (Buffer binHandle) i = do - ptr_handle <- openFixedSysHandle - (mkSysArray (fromIntegral i) - ptr - True) -- Read Only - resetBin ptr_handle - copyBytes ptr_handle binHandle (fromIntegral i) - return () - -forwardTwixt :: (Ptr Word8 -> Buffer -> CSize -> IO ()) -> Buffer -> Ptr Word8 -> CSize -> IO () -forwardTwixt f b@(Buffer binHandle) ptr len - | len < 0 = error "FIX: negative number to cBuffToBuff" - | otherwise = do loc <- tellBin binHandle - f ptr b len - seekBin binHandle loc -- put the pounter back - --- |Move the buffer's pointer forward. -plusBuff :: Buffer -> Int -> IO () -plusBuff (Buffer binHandle) n = do - BinPtr curr <- tellBin binHandle - seekBin binHandle (BinPtr $ curr + n) - return () - --- |Seek forward or backward on this buffer. -buffSeek :: Buffer -> Int -> IO () -buffSeek (Buffer binHandle) n - = seekBin binHandle (BinPtr n) - --- |Get the BinHandle out of this buffer. -buffGetHandle :: Buffer -> BinHandle -buffGetHandle (Buffer b) = b diff --git a/Halfs/BufferBlock.hs b/Halfs/BufferBlock.hs deleted file mode 100644 --- a/Halfs/BufferBlock.hs +++ /dev/null @@ -1,357 +0,0 @@ -{-# LANGUAGE Rank2Types, ExistentialQuantification #-} -module Halfs.BufferBlock - ( BufferBlock -- abstract - , bbDirty - , bbLock - , bbDiskAddr - , bbRawDevice - , bbRecent - , mkBufferBlock - , incLock - , decLock - , clearLock - , getLock - , setDirty - , getDirty - , getDiskAddr - , setDiskAddr - , setRawDevice - , getRawDevice - , setRecent - , getRecent - , writeToBufferBlock - , readFromBufferBlock - , bufferBlockCursorIntoPointers - , BufferBlockCursor(..) -- for Cache only - , Alloc(..) - , copyFromBufferBlock - , copyToBufferBlock - , copyBufferBlock - , zeroBufferBlock - , deadbeefBufferBlock - , startBufferBlockCursor - , ReadBuffer -- abstract - , readBuffer - , doReadBuffer - , diskAddressListFromBufferBlock - - , PartBufferBlock - , putPartBufferBlock - , getPartBufferBlock - , mkInodeBlock - , mkDiskAddressBlock - , devBufferRead - , devBufferWrite - - - , bbDebugOn - , bbDebugOff - , bbDebug - - ) where - -import Binary -- (FixedBinHandle,BinaryHandle, openFixedBinMem, sizeFixedBinMem) -import Halfs.Utils (DiskAddress, bytesPerBlock, bytesPerBlockPointer, - bytesPerInode, - blockPointersPerIndirectBlock) -import Control.Exception(assert) -import System.RawDevice (BufferBlockHandle, RawDevice, zeroBufferBlockHandle) -import qualified System.RawDevice (devBufferRead, devBufferWrite) -import Data.IORef -import Data.Integral(INInt, inIntToInt) -import Halfs.Inode (Inode) -import System.IO.Unsafe (unsafePerformIO) -import Control.Monad(when) - -data BufferBlock s = - BufferBlock { bbBuffer :: !(BufferBlockHandle s) -- later will just be a buffer block - , bbDirty :: !(IORef Bool) -- dirty bit - , bbLock :: !(IORef Int) -- number of locks on this buffer - , bbRecent :: !(IORef Bool) -- marked if recently used - , bbRawDevice :: !(IORef RawDevice) - , bbDiskAddr :: !(IORef DiskAddress) - } - --- This should only be used inside BufferBlockCache, or for bootstrapping. - -mkBufferBlock :: BufferBlockHandle s -> RawDevice -> DiskAddress -> IO (BufferBlock s) -mkBufferBlock h dev addr = do - dirtyRef <- newIORef False - lockRef <- newIORef 0 - recentRef <- newIORef True - addrRef <- newIORef addr - devRef <- newIORef dev - let bb = BufferBlock h dirtyRef lockRef recentRef devRef addrRef - bbDebug bb "mkBufferBlock" - return $ bb - -setDirty :: BufferBlock s -> Bool -> IO () -setDirty bb val = bbDebugSetter bb "setDirty" $ writeIORef (bbDirty bb) val - -getDirty :: BufferBlock s -> IO Bool -getDirty bb = bbDebugGetter bb "getDirty" $ readIORef (bbDirty bb) - -incLock :: BufferBlock s -> IO () -incLock bb = bbDebugSetter bb "incLock" $ modifyIORef (bbLock bb) $ succ - -decLock :: BufferBlock s -> IO () -decLock bb = bbDebugSetter bb "decLock" $ modifyIORef (bbLock bb) $ pred - -clearLock :: BufferBlock s -> IO () -clearLock bb = bbDebugSetter bb "clearLock" $ writeIORef (bbLock bb) $ 0 - -getLock :: BufferBlock s -> IO Int -getLock bb = bbDebugGetter bb "getLock" $ readIORef (bbLock bb) - -getDiskAddr :: BufferBlock s -> IO DiskAddress -getDiskAddr bb = bbDebugGetter bb "getDiskAddr" $ readIORef (bbDiskAddr bb) - -setDiskAddr :: BufferBlock s -> DiskAddress -> IO () -setDiskAddr bb da = bbDebugSetter bb "setDiskAddr" $ writeIORef (bbDiskAddr bb) da - -getRawDevice :: BufferBlock s -> IO RawDevice -getRawDevice bb = bbDebugGetter bb "getRawDevice" $ readIORef (bbRawDevice bb) - -setRawDevice :: BufferBlock s -> RawDevice -> IO () -setRawDevice bb da = bbDebugSetter bb "setRawDevice" $ writeIORef (bbRawDevice bb) da - -setRecent :: BufferBlock s -> Bool -> IO () -setRecent bb val = bbDebugSetter bb "setRecent" $ writeIORef (bbRecent bb) val - -getRecent :: BufferBlock s -> IO Bool -getRecent bb = bbDebugGetter bb "getRecent" $ readIORef (bbRecent bb) - -data Alloc = forall a . (Binary a, Show a) => Alloc a - -data BufferBlockCursor s = BufferBlockCursor (Bin ()) - deriving Show - -startBufferBlockCursor :: BufferBlockCursor a -startBufferBlockCursor = BufferBlockCursor $ BinPtr 0 - --- TODO: Add asserts -bufferBlockCursorIntoPointers :: INInt -> BufferBlockCursor s -bufferBlockCursorIntoPointers n = - assert (n >= 0 && inIntToInt n < blockPointersPerIndirectBlock) $ - BufferBlockCursor $ BinPtr $ inIntToInt n * bytesPerBlockPointer - -writeToBufferBlock :: BufferBlock s -> BufferBlockCursor s -> [Alloc] -> IO () -writeToBufferBlock buffer (BufferBlockCursor c) allocs = - bbDebugSetter buffer ("writeToBufferBlock: " ++ show (c,[ show a | Alloc a <- allocs])) $ - do seekBin (bbBuffer buffer) c - write allocs - writeIORef (bbDirty buffer) True - where - write (Alloc v : rest) = do - put_ (bbBuffer buffer) v - write rest - write [] = return () - - -readFromBufferBlock :: (Show a,Binary a) => BufferBlock s -> BufferBlockCursor s -> IO a -readFromBufferBlock buffer (BufferBlockCursor cur) = - bbDebugGetter buffer ("readFromBufferBlock" ++ show cur) $ - do seekBin (bbBuffer buffer) cur - get (bbBuffer buffer) - - -copyFromBufferBlock :: (BinaryHandle h) => BufferBlock s -> Int -> h -> Int -> Int -> IO Int -copyFromBufferBlock bb c buffer offset size = do - bbDebugSetter bb ("copyFromBufferBlock: " ++ show (c,offset,size)) $ do - seekBin (bbBuffer bb) (BinPtr c) - seekBin buffer (BinPtr offset) - copyBytes (bbBuffer bb) buffer size - return size - -copyToBufferBlock :: (BinaryHandle h) => h -> Int -> BufferBlock s -> Int -> Int -> IO Int -copyToBufferBlock buffer offset bb c size = do - bbDebugSetter bb ("copyToBufferBlock: " ++ show (c,offset,size)) $ do - seekBin buffer (BinPtr offset) - seekBin (bbBuffer bb) (BinPtr c) - copyBytes buffer (bbBuffer bb) size - writeIORef (bbDirty bb) True - return size - -{- UNUSED: -printHead :: (String, BinHandle) -> IO () -printHead(str,b) = do - resetBin b - vs <- sequence $ replicate 10 (get $ b) - print (str,vs :: [DiskAddress]) - resetBin b --} - -copyBufferBlock :: BufferBlock s -> BufferBlock t -> IO () -copyBufferBlock b1 b2 = do - bbDebug b1 "(before)src:copyBufferBlock" - bbDebug b2 "(before)dest:copyBufferBlock" - resetBin (bbBuffer b1) - resetBin (bbBuffer b2) - copyBytes (bbBuffer b1) (bbBuffer b2) bytesPerBlock - writeIORef (bbDirty b2) True - bbDebug b1 "(after)src:copyBufferBlock" - bbDebug b2 "(after)dest:copyBufferBlock" - return () - -zeroBufferBlock :: BufferBlock s -> IO () -zeroBufferBlock buffer = - bbDebugSetter buffer ("zeroBufferBlock") $ do - zeroBufferBlockHandle (bbBuffer buffer) - -deadbeefBufferBlock :: BufferBlock s -> IO () -deadbeefBufferBlock buffer = - bbDebugSetter buffer ("deadbeefBufferBlock") $ do - writeToBufferBlock buffer (BufferBlockCursor (BinPtr 0)) - [ Alloc (0xDEADBEEF :: DiskAddress) | _ <- take blockPointersPerIndirectBlock $ [(0::Int)..] ] - - -diskAddressListFromBufferBlock :: BufferBlock s -> IO [DiskAddress] -diskAddressListFromBufferBlock bb = do - bbDebugGetter bb ("diskAddressListFromBufferBlock") $ do - resetBin (bbBuffer bb) - sequence $ replicate blockPointersPerIndirectBlock (get $ bbBuffer bb) - ------------------------------------------------------------------------------- - -data ReadBuffer a = ReadBuffer (forall s . BufferBlockHandle s -> IO a) - -instance Monad ReadBuffer where - return a = ReadBuffer (\ _ -> return a) - m >>= k = ReadBuffer (\ h -> case m of - ReadBuffer m1 -> do r <- m1 h - case k r of - ReadBuffer m2 -> m2 h) - -readBuffer :: (Binary a) => ReadBuffer a -readBuffer = ReadBuffer get - -doReadBuffer :: BufferBlock s -> BufferBlockCursor s -> ReadBuffer a -> IO (a,BufferBlockCursor s) -doReadBuffer bb (BufferBlockCursor c) (ReadBuffer rb) = do - seekBin (bbBuffer bb) c - r <- rb (bbBuffer bb) - c' <- tellBin (bbBuffer bb) - return (r,BufferBlockCursor c') - - ------------------------------------------------------------------------------- - --- A PartBufferBlock is a reference to a specific slice of a BufferBlock. - -data PartBufferBlock a s = PartBufferBlock (BufferBlock s) (BufferBlockCursor s) - -putPartBufferBlock :: (Show a,Binary a) => PartBufferBlock a s -> a -> IO () -putPartBufferBlock (PartBufferBlock bb c) a = - bbDebugSetter bb ("putPartBufferBlock") $ do - writeToBufferBlock bb c [Alloc a] - -getPartBufferBlock :: (Show a,Binary a) => PartBufferBlock a s -> IO a -getPartBufferBlock (PartBufferBlock bb c) = - bbDebugGetter bb ("getPartBufferBlock") $ do - readFromBufferBlock bb c - ------------------------------------------------------------------------------- - -mkInodeBlock :: BufferBlock s -> Int -> IO (PartBufferBlock Inode s) -mkInodeBlock bb i = assert (ix >= 0 && ix < bytesPerBlock) $ - return $ PartBufferBlock bb (BufferBlockCursor $ BinPtr ix) - where - ix = i * bytesPerInode - - -mkDiskAddressBlock :: BufferBlock s -> Int -> IO (PartBufferBlock DiskAddress s) -mkDiskAddressBlock bb i = assert (ix >= 0 && ix < bytesPerBlock) $ - return $ PartBufferBlock bb (BufferBlockCursor $ BinPtr ix) - where - ix = i * bytesPerBlockPointer - ------------------------------------------------------------------------------- - - - -devBufferRead :: RawDevice - -> DiskAddress -- ^Block number - -> BufferBlock s -- ^Buffer - -> IO () -devBufferRead dev addr bb = do - bbDebugSetter bb ("devBufferRead:" ++ show(dev,addr)) $ do - System.RawDevice.devBufferRead dev addr (bbBuffer bb) - --- we use setter here to check that the write does not modify/trash its buffer. - -devBufferWrite :: RawDevice -- ^which disk? - -> DiskAddress -- ^Block number - -> BufferBlock s -- ^Buffer! - -> IO () -devBufferWrite dev addr bb = do - bbDebugSetter bb ("devBufferWrite:" ++ show(dev,addr)) $ do - System.RawDevice.devBufferWrite dev addr (bbBuffer bb) - - -{- UNUSED: -assertEqBufferBlockHandle :: BinHandle -> BinHandle -> IO () -assertEqBufferBlockHandle b1 b2 = do - resetBin b1 - resetBin b2 - sequence_ [ do v1 <- get b1 - v2 <- get b2 - when ((v1 :: Word32) /= v2) $ do - print $ "blocks are different(!) : " ++ show (i,v1,v2) - error "" - return $ () - | i <- take (bytesPerBlock `div` 4) [(0::Int)..] - ] - resetBin b1 - resetBin b2 --} - ------------------------------------------------------------------------------- - -{-# NOINLINE debugRef #-} - -debugRef :: IORef Bool -debugRef = unsafePerformIO $ newIORef False - -noDebug :: Bool -noDebug = True - -bbDebugOn :: IO () -bbDebugOn = do writeIORef debugRef True - putStrLn "bbDebugOn" - -bbDebugOff :: IO () -bbDebugOff = do writeIORef debugRef False - putStrLn "bbDebugOff" - -bbDebug :: BufferBlock s -> String -> IO () -bbDebug _bb _msg | noDebug = return () -bbDebug bb msg = do - debug <- readIORef debugRef - when debug $ do - dirty <- readIORef (bbDirty bb) - lock <- readIORef (bbLock bb) - recent <- readIORef (bbRecent bb) - raw <- readIORef (bbRawDevice bb) - addr <- readIORef (bbDiskAddr bb) - putStrLn $ msg - putStrLn $ "BB { dirty=" ++ show dirty - ++ ", lock=" ++ show lock - ++ ", recent=" ++ show recent - ++ ", raw=" ++ show raw - ++ ", addr=" ++ show addr ++ "}" - -bbDebugSetter :: BufferBlock s -> String -> IO a -> IO a -bbDebugSetter _bb _msg m | noDebug = m -bbDebugSetter bb msg m = do - bbDebug bb ("before " ++ msg) - r <- m - bbDebug bb ("after " ++ msg) - return r - -bbDebugGetter :: (Show a) => BufferBlock s -> String -> IO a -> IO a -bbDebugGetter _bb _msg m | noDebug = m -bbDebugGetter bb msg m = do - bbDebug bb msg - r <- m - debug <- readIORef debugRef - when debug $ putStrLn $ "got " ++ show r - return r diff --git a/Halfs/BufferBlockCache.hs b/Halfs/BufferBlockCache.hs deleted file mode 100644 --- a/Halfs/BufferBlockCache.hs +++ /dev/null @@ -1,318 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} -module Halfs.BufferBlockCache ( BufferBlockCache, getBlockFromCacheOrDevice - , getNewBlockFromCacheOrDevice - , getBlockFromDevice, markBlockDirty, checkBBCache - , createCache, syncBBCache, clearBBCache ) - - where - -import Halfs.FSRW (FSRW, unsafeLiftIORW) -import Halfs.Utils (DiskAddress, fromJustErr) -import Halfs.BufferBlock -import Control.Monad.Error (MonadError) -import Data.Queue -import System.RawDevice(RawDevice, newBufferBlockHandle) - --- base -import Data.Map(Map) -import qualified Data.Map as Map -import Control.Concurrent(MVar, modifyMVar_, modifyMVar, readMVar, newMVar) -import Control.Monad.Error(throwError, catchError) -import Control.Exception(assert) -import Control.Monad(liftM, when) - --- |Maps the disk address to a cache of the blocks. -data BufferBlockCache - = forall s . BufferBlockCache (MVar (BBCacheStore s)) - -data BBCacheStore s = BBCacheStore { bbcache :: !(Map (RawDevice, DiskAddress) (BufferBlock s)) - , _bbhits :: !Int - , _bbmisses :: !Int - , _cachereuse :: !(CacheReuseQueue s) - } - --- |If the cache grows beyond this size, we flush something. -maxBBCacheSize :: Int -maxBBCacheSize = 500 - -checkBBCache :: BufferBlockCache -> IO ( Int -- size - , Int -- Num dirty - , Int -- cache hits - , Int -- cache misses - ) -checkBBCache (BufferBlockCache cache) = do - store@(BBCacheStore fm hit miss _) <- readMVar cache - numDirty <- liftM (length . filter id) $ sequence [ getDirty bb | bb <- Map.elems fm ] - return (Map.size fm, assert (verifyCacheSize store) numDirty,hit,miss) - -verifyCacheSize :: BBCacheStore s -> Bool -verifyCacheSize store = Map.size (bbcache store) <= maxBBCacheSize - --- |Should only be called on a read-only FSRoot. FIX: Verify that --- there aren't any dirty blocks? -clearBBCache :: (FSRW m) => BufferBlockCache -> m () -clearBBCache c - = modifyCache_ c (\_ -> return $ BBCacheStore Map.empty 0 0 emptyCRQ) - --- |Returns a new, empty cache -createCache :: Int -> IO (BufferBlockCache) -createCache _ = liftM BufferBlockCache $ newMVar $ BBCacheStore Map.empty 0 0 emptyCRQ - --- maxAddress = 100000 - --- |This block MUST be in the cache. This function marks it as dirty. -markBlockDirty :: (FSRW m) - => BufferBlockCache - -> RawDevice - -> DiskAddress - -> m () -markBlockDirty c dev addr = --- assert (addr < maxAddress && addr > (0 - maxAddress)) $ do - modifyCache_ c (\ cache@(BBCacheStore fm hits misses crq) -> - let bb = fromJustErr - "internal: attempt to mark a block not in the cache." - (Map.lookup (dev, addr) (assert (verifyCacheSize cache) fm)) - in do setDirty bb True - return $ BBCacheStore fm hits misses crq) - --- |This block MUST be in the cache. This function unmarks the busy block. - --- |Sync the BB cache. Fix; can we do this in one pass? Alters the --- cache itself as a side-effect. Not the FSRoot. -syncBBCache :: (FSRW m) - => BufferBlockCache - -> m () -syncBBCache c = modifyCache_ c (\ store@(BBCacheStore cache hits misses crq) -> do - let l = Map.toList (assert (verifyCacheSize store) cache) - l' <- mapM (\ ((dev, addr), bb) -> do - syncBB dev bb - return ((dev, addr), bb)) l - return $ BBCacheStore (Map.fromList l') hits misses crq) - --- |Attempts to read from the cache; if it fails, will read from the --- raw device. Alters the cache, but that's a reference in the --- fsroot, so happens as a side-effect. - --- Whe need to use the BufferBlockCache pattern match so as we have the same --- 'forall' over all this function, rather than use two calls to modifyCache, --- which would have two distinct forall s. - -getBlockFromCacheOrDevice' :: (MonadError e m,FSRW m) - => BufferBlockCache - -> RawDevice - -> DiskAddress - -> Bool -- True for allocation from free list - -> (forall s . BufferBlock s -> m a) -- scoped use - -> m a -getBlockFromCacheOrDevice' (BufferBlockCache bbc) dev da' free cont = do --- assert (da' < maxAddress && da' > (0 - maxAddress)) $ do --- unsafeLiftIORW $ print ("getBlockFromCacheOrDevice",da') - rr <- unsafeLiftIORW $ modifyMVar bbc (\ (BBCacheStore cache hits misses crq) -> do - let da = abs da' - case Map.lookup (dev, da) cache of - Just bb -> do incLock bb - when free $ do - zeroBufferBlock bb - setRecent bb True - internal_da <- getDiskAddr bb - assert (internal_da == da) $ return () - return (BBCacheStore cache (if free then hits else succ hits) misses crq,bb) - _ | isFull crq -> do - (reclaimed,crq') <- syncOneBB crq - key_dev <- getRawDevice reclaimed - key_da <- getDiskAddr reclaimed - let key = (key_dev,key_da) - -- now we re-initiate the block - clearLock reclaimed - setDirty reclaimed False - setDiskAddr reclaimed da - if free - then zeroBufferBlock reclaimed - else getBlockFromDevice'' dev da reclaimed - incLock reclaimed - let cache2 = Map.delete key cache - let cache3 = Map.insert (dev,da) reclaimed cache2 - return (BBCacheStore cache3 hits (if free then misses else succ misses) crq',reclaimed) - _ -> do - -- cache is not full yet, so keep filling - block <- newBufferBlockHandle - newBB <- mkBufferBlock block dev da - if free - then zeroBufferBlock newBB - else getBlockFromDevice'' dev da newBB - incLock newBB - crq' <- bootstrapCRQ newBB crq - let cache2 = Map.insert (dev,da) newBB cache - return (BBCacheStore cache2 hits (if free then misses else succ misses) crq', newBB) - ) - let unlock = unsafeLiftIORW $ modifyMVar_ bbc (\ (BBCacheStore cache hits misses crq) -> do - when (((hits + misses) `mod` 10000) == 0 && (hits + misses) /= 0) $ do - putStrLn $ "Cache: " ++ show (hits + misses) ++ " lookups, " - ++ show ((hits * 100) `div` (hits + misses)) ++ "% hits" - let da = abs da' - case Map.lookup (dev, da) cache of - Just bb -> do decLock bb --- print $ "getBlockFromCacheOrDevice (from cache) unlocking (" ++ show (bbDiskAddr bb') ++ ")" - return $ BBCacheStore cache hits misses crq - Nothing -> do - print "getBlockFromCacheOrDevice (not in cache, should still be here!)" - error "getBlockFromCacheOrDevice (not in cache, should still be here!)" - ) - r <- catchError (cont rr) - (\ e -> do -- unsafeLiftIORW $ print "exception inside cont inside BBC getBlock" - unlock - throwError e) - unlock - return r - where - - syncOneBB crq = do - (bb,crq') <- rotateCRQ crq - lock <- getLock bb - recent <- getRecent bb --- print ("syncOne: ", lock, recent) - if lock > 0 || recent - then syncOneBB crq' -- keep looking - else do --- print ("syncing(1) ") - devi <- getRawDevice bb - syncBB devi bb - return (bb,crq') - --- maybeReclaimSomeBlock :: BBCacheStore -> IO (BBCacheStore, BufferBlockHandle) - -getBlockFromCacheOrDevice :: (MonadError e m,FSRW m) - => BufferBlockCache - -> RawDevice - -> DiskAddress - -> (forall s . BufferBlock s -> m a) -- scoped use - -> m a -getBlockFromCacheOrDevice bbc dev da cont = - getBlockFromCacheOrDevice' bbc dev da False cont - -getNewBlockFromCacheOrDevice :: (MonadError e m,FSRW m) - => BufferBlockCache - -> RawDevice - -> DiskAddress - -> (forall s . BufferBlock s -> m a) -- scoped use - -> m a -getNewBlockFromCacheOrDevice bbc dev da cont = - getBlockFromCacheOrDevice' bbc dev da True cont - --- |Allocates a new block. Caller is responsible for this block from --- now on; it is unlocked and not in the cache. -getBlockFromDevice :: (FSRW m) - => RawDevice - -> DiskAddress - -> (forall s . BufferBlock s -> m a) -- scoped use - -> m a -getBlockFromDevice rawDevice da cont = do --- assert (d < maxAddress && d > (0 - maxAddress)) $ do - buffer <- unsafeLiftIORW $ newBufferBlockHandle - - -- Here's one of the few cases I don't see getting rid of "unsafe" - -- calls. This call is for reading only, calls straight down to - -- device, and is completely necessary to call ultimately from - -- all FSRead, FSWrite, and IO monads. - - newBB <- unsafeLiftIORW $ mkBufferBlock buffer rawDevice da - unsafeLiftIORW $ devBufferRead rawDevice da newBB - cont newBB - - --- TODO: INLINE, there is nothing left here. - -getBlockFromDevice'' :: (FSRW m) - => RawDevice - -> DiskAddress - -> BufferBlock s -- ^BinHandle to re-use - -> m () -getBlockFromDevice'' rawDevice da' buffer = do --- assert (da' < maxAddress && da' > (0 - maxAddress)) $ do - let da = abs da' - -- Here's one of the few cases I don't see getting rid of "unsafe" - -- calls. This call is for reading only, calls straight down to - -- the device, and is completely necessary to call ultimately from - -- all FSRead, FSWrite, and IO monads. - unsafeLiftIORW $ devBufferRead rawDevice da buffer - return () - --- ------------------------------------------------------------ --- * Internal --- ------------------------------------------------------------ - --- |Syncs this bufferblock to disk; marks it as clean. -syncBB :: RawDevice -> BufferBlock s -> IO () -syncBB dev b = do - lock <- getLock b - if lock > 0 then return () -- Locked; skip it! - else do - dirty <- getDirty b - if dirty then do -- Otherwise; write to disk, mark as clean. - addr <- getDiskAddr b - devBufferWrite dev addr b - setDirty b False - return () - else return () - - -modifyCache_ :: (FSRW m) - => BufferBlockCache - -> (forall s . BBCacheStore s -> IO (BBCacheStore s)) -- ^in the IO monad in case we need to alter the buffer itself - -> m () -modifyCache_ (BufferBlockCache mv) f = unsafeLiftIORW $ modifyMVar_ mv f - -{- UNUSED: -modifyCache :: (FSRW m) - => BufferBlockCache - -> (forall s . BBCacheStore s -> IO (BBCacheStore s, a)) -- ^in the IO monad in case we need to alter the buffer itself - -> m a -modifyCache (BufferBlockCache mv) f = unsafeLiftIORW $ modifyMVar mv f --} - ------------------------------------------------------------------------------- - -data CacheReuseQueue s = CacheReuseQueue - { _crq_large :: !(Queue (BufferBlock s)) - , _crq_secondchance :: !(Queue (BufferBlock s)) - } - -emptyCRQ :: CacheReuseQueue s -emptyCRQ = CacheReuseQueue emptyQueue emptyQueue - -isFull :: CacheReuseQueue s -> Bool -isFull (CacheReuseQueue q q2) = queueLength q + queueLength q2 >= maxBBCacheSize - -bootstrapCRQ :: BufferBlock s -> CacheReuseQueue s -> IO (CacheReuseQueue s) -bootstrapCRQ bb (CacheReuseQueue q q2) - | queueLength q < (maxBBCacheSize - secondChanceBBCacheSize) = do - () <- return $ assert (queueLength q2 == 0) $ () - return $ CacheReuseQueue (addToQueue q bb) q2 - | otherwise = do - () <- return $ assert (queueLength q == (maxBBCacheSize - secondChanceBBCacheSize)) $ () - () <- return $ assert (queueLength q2 < secondChanceBBCacheSize) $ () - case deQueue (addToQueue q bb) of - Nothing -> error "insertCRQ: failure, should not happen" - Just (bb',q') -> do - setRecent bb' False - return $ CacheReuseQueue q' (addToQueue q2 bb') - --- -rotateCRQ :: CacheReuseQueue s -> IO (BufferBlock s,CacheReuseQueue s) -rotateCRQ (CacheReuseQueue q q2) = assert (queueLength q + queueLength q2 == maxBBCacheSize) $ - case deQueue q of - Just (bb,q') -> - case deQueue q2 of - Just (bb2,q2') -> do - setRecent bb False - return ( bb2 - , CacheReuseQueue (addToQueue q' bb2) (addToQueue q2' bb) - ) - Nothing -> error "second chance queue in CRQ is empty!!" - Nothing -> error "main queue in CRQ is empty!!" - -secondChanceBBCacheSize :: Int -secondChanceBBCacheSize = maxBBCacheSize `div` 8 - - - diff --git a/Halfs/BuiltInFiles.hs b/Halfs/BuiltInFiles.hs deleted file mode 100644 --- a/Halfs/BuiltInFiles.hs +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Halfs.BuiltInFiles --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : GHC --- --- Several files are built-in and this module represents reading them. - -module Halfs.BuiltInFiles (readInodeMapFile - ,readBlockMapFile - ) where -import Halfs.BasicIO (readInodeMapBin, readBlockMapBin) -import Halfs.Inode(Inode) -import Halfs.FSState (FSRead) -import Halfs.TheInodeMap (TheInodeMap(..)) -import Halfs.TheBlockMap(TheBlockMap(..)) -import Halfs.FileHandle (readFileFromInode) - - - --- |Reads it as a file. -readInodeMapFile :: Inode - -> FSRead TheInodeMap -readInodeMapFile inode - = readFileFromInode readInodeMapBin inode - --- |Reads it as a file. -readBlockMapFile :: Inode - -> FSRead TheBlockMap -readBlockMapFile bmInode' - = readFileFromInode readBlockMapBin bmInode' - -{- Might be useful sometime: -readFileFromHandle :: (BinHandle -> FSRead a) -> FileHandle -> FSRead a -readFileFromHandle f (FileHandle{fhInode=i}) = readFileFromInode f i - --- |For assertion checking -justSame :: (Eq a) => a -> (b, a) -> Bool -justSame r (_, numRead) = r == numRead - --} diff --git a/Halfs/Classes.hs b/Halfs/Classes.hs new file mode 100644 --- /dev/null +++ b/Halfs/Classes.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, + FunctionalDependencies, FlexibleContexts, + FlexibleInstances, ScopedTypeVariables, BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Halfs.Classes + ( HalfsCapable + , Lockable(..) + , Reffable(..) + , TimedT(..) + , Timed(..) + , Bitmapped(..) + , Threaded(..) + , IOLock + ) + where + +import Control.Applicative +import Control.Concurrent (ThreadId, myThreadId) +import Control.Concurrent.MVar +import Control.Exception +import Control.Monad.ST +import Data.Array.IO +import Data.Array.ST +import Data.IORef +import Data.Ratio (numerator) +import Data.Serialize +import Data.STRef +import Data.Time.Clock +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import Data.Time.LocalTime () -- for Show UTCTime instance +import Data.Word + +import Foreign.C.Types (CTime) +import GHC.Int (Int32) + +-- ---------------------------------------------------------------------------- + +-- Any monad used in Halfs must implement the following interface: +class ( Bitmapped b m + , Timed t m + , Reffable r m + , Lockable l m + , Serialize t + , Threaded m + , Functor m + , Monad m + , Show t -- For debugging + ) => + HalfsCapable b t r l m | m -> b t r l + +instance HalfsCapable (IOUArray Word64 Bool) UTCTime IORef IOLock IO +instance HalfsCapable (STUArray s Word64 Bool) Word64 (STRef s) () (ST s) + +-- ---------------------------------------------------------------------------- + +-- |A monad implementing Timed implements a monotonic clock that can be read +-- from. One obvious implementation is using the system clock. Another might be +-- a step counter. +class (Monad m, Eq t, Ord t) => Timed t m | m -> t where + getTime :: m t + toCTime :: t -> m CTime + fromCTime :: CTime -> m t + +-- |This is a monad transformer for the Timed monad, which will work for 2^64 +-- steps of an arbitrary underlying monad. +newtype TimedT m a = TimedT { runTimerT :: Word64 -> m a } + +ttGetTime :: Monad m => TimedT m Word64 +ttGetTime = TimedT $ \ t -> return t + +instance Monad m => Monad (TimedT m) where + return a = TimedT $ \ _ -> return a + m >>= k = TimedT $ \ t -> do + a <- runTimerT m t + runTimerT (k a) (t + 1) + +instance Serialize UTCTime where + put x = do + putWord64be $ fromIntegral $ fromEnum $ utctDay x + putWord64be $ + -- We have no way to extract the underlying fixed-precision Integer from + -- the DiffTime, but picosecond resolution for DiffTime is documented, so + -- we scale via conversion to Rational (i.e., we reconstruct the + -- underlying fixed-precision Integer). The assert is simply in case the + -- underlying representation changes at some point in the future. + let dt2pico = numerator . (1000000000000*) . toRational + off = fromIntegral $ dt2pico $ utctDayTime x + in assert (off >= (minBound :: Word64) && off <= (maxBound :: Word64)) off + + get = do + UTCTime + <$> (toEnum . fromIntegral) `fmap` getWord64be + <*> (picosecondsToDiffTime . fromIntegral) `fmap` getWord64be + +instance Timed UTCTime IO where + getTime = getCurrentTime >>= toCTime >>= fromCTime + -- Pass the current time through conversion to/fromCTime so that all times + -- that originate here have CTime granularity. We do this so that our + -- internally-acquired times have the same granularity as those coming in + -- from outside via the hFuse binding (e.g., via the setFileTimes function). + toCTime t = + -- We'll be converting UTCTimes to POSIXTimes to CTime values, which have + -- implementation-specific size. I don't think it's safe to truncate based + -- on the size reported by the Storable instance for CTime, as we'd still + -- have to make assumptions about the underlying rep (e.g., it's not a real, + -- etc.). As a keep-it-simple concession, we'll err on the side of caution + -- and assume that we have a 32 bit signed int representation, and clamp + -- values based on that. This should be okay until early 2038 :). + let ub = fromIntegral (maxBound :: Int32) + i :: Integer = truncate $ utcTimeToPOSIXSeconds t + in return ((fromIntegral $ if i >= ub then ub else i) :: CTime) + fromCTime = return . posixSecondsToUTCTime . realToFrac + +instance Timed Word64 (ST s) where + getTime = undefined + toCTime = undefined + fromCTime = undefined + +instance Monad m => Timed Word64 (TimedT m) where + getTime = ttGetTime + toCTime = undefined + fromCTime = undefined + +-- --------------------------------------------------------------------------- + +-- |A monad implementing Reffable implements a reference type that allows for +-- mutable state. +class Monad m => Reffable r m | m -> r where + newRef :: a -> m (r a) + readRef :: r a -> m a + writeRef :: r a -> a -> m () + modifyRef :: r a -> (a -> a) -> m () + modifyRef r f = readRef r >>= writeRef r . f + +instance Reffable (STRef s) (ST s) where + newRef = newSTRef + readRef = ($!) readSTRef + writeRef = ($!) writeSTRef + +instance Reffable IORef IO where + newRef = newIORef + readRef = ($!) readIORef + writeRef !r !v = writeIORef r v + +-- --------------------------------------------------------------------------- + +-- | A monad implementing Threaded can obtain its thread id +class Monad m => Threaded m where + getThreadId :: m ThreadId + +instance Threaded IO where + getThreadId = myThreadId + +instance Threaded (ST s) where + getThreadId = undefined + +-- --------------------------------------------------------------------------- + +-- |A monad implementing locks. +class Monad m => Lockable l m | m -> l where + newLock :: m l + lock :: l -> m () + release :: l -> m () + +instance Lockable () (ST s) where + newLock = return () + lock _ = return () + release _ = return () + +newtype IOLock = IOLock (MVar ()) + +instance Lockable IOLock IO where + newLock = IOLock `fmap` newMVar () + lock (IOLock l) = takeMVar l + release (IOLock l) = putMVar l () + +-- --------------------------------------------------------------------------- + +-- | A monad implementing a bitmap +class Monad m => Bitmapped b m | m -> b where + newBitmap :: Word64 -> Bool -> m b + clearBit :: b -> Word64 -> m () + setBit :: b -> Word64 -> m () + checkBit :: b -> Word64 -> m Bool + toList :: b -> m [Bool] + +instance Bitmapped (IOUArray Word64 Bool) IO where + newBitmap s e = newArray (0, s - 1) e + clearBit b i = writeArray b i False + setBit b i = writeArray b i True + checkBit = readArray + toList = getElems + +instance Bitmapped (STUArray s Word64 Bool) (ST s) where + newBitmap s e = newArray (0, s - 1) e + clearBit b i = writeArray b i False + setBit b i = writeArray b i True + checkBit = readArray + toList = getElems diff --git a/Halfs/CompatFilePath.hs b/Halfs/CompatFilePath.hs deleted file mode 100644 --- a/Halfs/CompatFilePath.hs +++ /dev/null @@ -1,374 +0,0 @@ -{-# OPTIONS -cpp #-} -module Halfs.CompatFilePath - ( -- * File path - FilePath - , splitFileName - , splitFileExt - , splitFilePath - , joinFileName - , joinFileExt - , joinPaths - , changeFileExt - , isRootedPath - , isAbsolutePath - - , pathParents - , commonParent - - -- * Search path - , parseSearchPath - , mkSearchPath - - -- * Separators - , isPathSeparator - , pathSeparator - , searchPathSeparator - ) where - -#if !__GLASGOW_HASKELL__ || __GLASGOW_HASKELL__ >= 623 - -import System.FilePath - -#else /* to end of file... */ - -#include "ghcconfig.h" - -import Data.List(intersperse) - --------------------------------------------------------------- --- * FilePath --------------------------------------------------------------- - --- | Split the path into directory and file name --- --- Examples: --- --- \[Posix\] --- --- > splitFileName "/" == ("/", "") --- > splitFileName "/foo/bar.ext" == ("/foo", "bar.ext") --- > splitFileName "bar.ext" == (".", "bar.ext") --- > splitFileName "/foo/." == ("/foo", ".") --- > splitFileName "/foo/.." == ("/foo", "..") --- --- \[Windows\] --- --- > splitFileName "\\" == ("\\", "") --- > splitFileName "c:\\foo\\bar.ext" == ("c:\\foo", "bar.ext") --- > splitFileName "bar.ext" == (".", "bar.ext") --- > splitFileName "c:\\foo\\." == ("c:\\foo", ".") --- > splitFileName "c:\\foo\\.." == ("c:\\foo", "..") --- --- The first case in the above examples returns an empty file name. --- This is a special case because the \"\/\" (\"\\\\\" on Windows) --- path doesn\'t refer to an object (file or directory) which resides --- within a directory. -splitFileName :: FilePath -> (String, String) -splitFileName p = (reverse (path2++drive), reverse fname) - where -#ifdef mingw32_TARGET_OS - (path,drive) = break (== ':') (reverse p) -#else - (path,drive) = (reverse p,"") -#endif - (fname,path1) = break isPathSeparator path - path2 = case path1 of - [] -> "." - [_] -> path1 -- don't remove the trailing slash if - -- there is only one character - (c:ps) | isPathSeparator c -> ps - _ -> path1 - --- | Split the path into file name and extension. If the file doesn\'t have extension, --- the function will return empty string. The extension doesn\'t include a leading period. --- --- Examples: --- --- > splitFileExt "foo.ext" == ("foo", "ext") --- > splitFileExt "foo" == ("foo", "") --- > splitFileExt "." == (".", "") --- > splitFileExt ".." == ("..", "") -splitFileExt :: FilePath -> (String, String) -splitFileExt p = - case pre of - [] -> (p, []) - (_:ps) -> (reverse (ps++path), reverse suf) - where - (fname,path) = break isPathSeparator (reverse p) - (suf,pre) | fname == "." || fname == ".." = (fname,"") - | otherwise = break (== '.') fname - --- | Split the path into directory, file name and extension. --- The function is an optimized version of the following equation: --- --- > splitFilePath path = (dir,name,ext) --- > where --- > (dir,basename) = splitFileName path --- > (name,ext) = splitFileExt basename -splitFilePath :: FilePath -> (String, String, String) -splitFilePath p = - case pre of - [] -> (reverse real_dir, reverse suf, []) - (_:ps) -> (reverse real_dir, reverse ps, reverse suf) - where -#ifdef mingw32_TARGET_OS - (path,drive) = break (== ':') (reverse p) -#else - (path,drive) = (reverse p,"") -#endif - (file,dir) = break isPathSeparator path - (suf,pre) = case file of - ".." -> ("..", "") - _ -> break (== '.') file - - real_dir = case dir of - [] -> '.':drive - [_] -> pathSeparator:drive - (_:ds) -> ds++drive - --- | The 'joinFileName' function is the opposite of 'splitFileName'. --- It joins directory and file names to form complete file path. --- --- The general rule is: --- --- > dir `joinFileName` basename == path --- > where --- > (dir,basename) = splitFileName path --- --- There might be an exeptions to the rule but in any case the --- reconstructed path will refer to the same object (file or directory). --- An example exception is that on Windows some slashes might be converted --- to backslashes. -joinFileName :: String -> String -> FilePath -joinFileName "" fname = fname -joinFileName "." fname = fname -joinFileName dir "" = dir -joinFileName dir fname - | isPathSeparator (last dir) = dir++fname - | otherwise = dir++pathSeparator:fname - --- | The 'joinFileExt' function is the opposite of 'splitFileExt'. --- It joins file name and extension to form complete file path. --- --- The general rule is: --- --- > filename `joinFileExt` ext == path --- > where --- > (filename,ext) = splitFileExt path -joinFileExt :: String -> String -> FilePath -joinFileExt path "" = path -joinFileExt path ext = path ++ '.':ext - --- | Given a directory path \"dir\" and a file\/directory path \"rel\", --- returns a merged path \"full\" with the property that --- (cd dir; do_something_with rel) is equivalent to --- (do_something_with full). If the \"rel\" path is an absolute path --- then the returned path is equal to \"rel\" -joinPaths :: FilePath -> FilePath -> FilePath -joinPaths path1 path2 - | isRootedPath path2 = path2 - | otherwise = -#ifdef mingw32_TARGET_OS - case path2 of - d:':':path2' | take 2 path1 == [d,':'] -> path1 `joinFileName` path2' - | otherwise -> path2 - _ -> path1 `joinFileName` path2 -#else - path1 `joinFileName` path2 -#endif - --- | Changes the extension of a file path. -changeFileExt :: FilePath -- ^ The path information to modify. - -> String -- ^ The new extension (without a leading period). - -- Specify an empty string to remove an existing - -- extension from path. - -> FilePath -- ^ A string containing the modified path information. -changeFileExt path ext = joinFileExt name ext - where - (name,_) = splitFileExt path - --- | On Unix and Macintosh the 'isRootedPath' function is a synonym to 'isAbsolutePath'. --- The difference is important only on Windows. The rooted path must start from the root --- directory but may not include the drive letter while the absolute path always includes --- the drive letter and the full file path. -isRootedPath :: FilePath -> Bool -isRootedPath (c:_) | isPathSeparator c = True -#ifdef mingw32_TARGET_OS -isRootedPath (_:':':c:_) | isPathSeparator c = True -- path with drive letter -#endif -isRootedPath _ = False - --- | Returns True if this path\'s meaning is independent of any OS --- "working directory", False if it isn\'t. -isAbsolutePath :: FilePath -> Bool -#ifdef mingw32_TARGET_OS -isAbsolutePath (_:':':c:_) | isPathSeparator c = True -#else -isAbsolutePath (c:_) | isPathSeparator c = True -#endif -isAbsolutePath _ = False - --- | Gets this path and all its parents. --- The function is useful in case if you want to create --- some file but you aren\'t sure whether all directories --- in the path exists or if you want to search upward for some file. --- --- Some examples: --- --- \[Posix\] --- --- > pathParents "/" == ["/"] --- > pathParents "/dir1" == ["/", "/dir1"] --- > pathParents "/dir1/dir2" == ["/", "/dir1", "/dir1/dir2"] --- > pathParents "dir1" == [".", "dir1"] --- > pathParents "dir1/dir2" == [".", "dir1", "dir1/dir2"] --- --- In the above examples \"\/\" isn\'t included in the list --- because you can\'t create root directory. --- --- \[Windows\] --- --- > pathParents "c:" == ["c:."] --- > pathParents "c:\\" == ["c:\\"] --- > pathParents "c:\\dir1" == ["c:\\", "c:\\dir1"] --- > pathParents "c:\\dir1\\dir2" == ["c:\\", "c:\\dir1", "c:\\dir1\\dir2"] --- > pathParents "c:dir1" == ["c:.","c:dir1"] --- > pathParents "dir1\\dir2" == [".", "dir1", "dir1\\dir2"] --- --- Note that if the file is relative then the the current directory (\".\") --- will be explicitly listed. -pathParents :: FilePath -> [FilePath] -pathParents p = - root'' : map ((++) root') (dropEmptyPath $ inits path') - where -#ifdef mingw32_TARGET_OS - (root,path) = case break (== ':') p of - (path, "") -> ("",path) - (root,_:path) -> (root++":",path) -#else - (root,path) = ("",p) -#endif - (root',root'',path') = case path of - (c:ps) | isPathSeparator c -> (root++[pathSeparator],root++[pathSeparator],ps) - _ -> (root ,root++"." ,path) - - dropEmptyPath ("":paths) = paths - dropEmptyPath paths = paths - - inits :: String -> [String] - inits [] = [""] - inits cs = - case pre of - "." -> inits suf - ".." -> map (joinFileName pre) (dropEmptyPath $ inits suf) - _ -> "" : map (joinFileName pre) (inits suf) - where - (pre,suf) = case break isPathSeparator cs of - (as,"") -> (as, "") - (as,_:bs) -> (as, bs) - --- | Given a list of file paths, returns the longest common parent. -commonParent :: [FilePath] -> Maybe FilePath -commonParent [] = Nothing -commonParent paths@(p:ps) = - case common Nothing "" p ps of -#ifdef mingw32_TARGET_OS - Nothing | all (not . isAbsolutePath) paths -> - let - getDrive (d:':':_) ds - | not (d `elem` ds) = d:ds - getDrive _ ds = ds - in - case foldr getDrive [] paths of - [] -> Just "." - [d] -> Just [d,':'] - _ -> Nothing -#else - Nothing | all (not . isAbsolutePath) paths -> Just "." -#endif - mb_path -> mb_path - where - common i acc [] rs = checkSep i acc rs - common i acc (c:cs) rs - | isPathSeparator c = removeSep i acc cs [] rs - | otherwise = removeChar i acc c cs [] rs - - checkSep _ acc [] = Just (reverse acc) - checkSep _ acc ([]:_ps) = Just (reverse acc) - checkSep i acc ((c1:_):rs) - | isPathSeparator c1 = checkSep i acc rs - checkSep i _acc _ps = i - - removeSep _ acc cs pacc [] = - common (Just (reverse (pathSeparator:acc))) (pathSeparator:acc) cs pacc - removeSep _ acc _cs _pacc ([] :_ps) = Just (reverse acc) - removeSep i acc cs pacc ((c1:p1):rs) - | isPathSeparator c1 = removeSep i acc cs (p1:pacc) rs - removeSep i _acc _cs _pacc _ps = i - - removeChar i acc c cs pacc [] = common i (c:acc) cs pacc - removeChar i _acc _c _cs _pacc ([]:_) = i - removeChar i acc c cs pacc ((c1:p1):rs) - | c == c1 = removeChar i acc c cs (p1:pacc) rs - removeChar i _acc _c _cs _pacc _ps = i - --------------------------------------------------------------- --- * Search path --------------------------------------------------------------- - --- | The function splits the given string to substrings --- using the 'searchPathSeparator'. -parseSearchPath :: String -> [FilePath] -parseSearchPath path = split searchPathSeparator path - where - split :: Char -> String -> [String] - split c s = - case rest of - [] -> [chunk] - _:rest' -> chunk : split c rest' - where - (chunk, rest) = break (==c) s - --- | The function concatenates the given paths to form a --- single string where the paths are separated with 'searchPathSeparator'. -mkSearchPath :: [FilePath] -> String -mkSearchPath paths = concat (intersperse [searchPathSeparator] paths) - - --------------------------------------------------------------- --- * Separators --------------------------------------------------------------- - --- | Checks whether the character is a valid path separator for the host platform. --- The valid character is a 'pathSeparator' but since the Windows operating system --- also accepts a backslash (\"\\\") the function also checks for \"\/\" on this platform. -isPathSeparator :: Char -> Bool -isPathSeparator ch = -#ifdef mingw32_TARGET_OS - ch == '/' || ch == '\\' -#else - ch == '/' -#endif - --- | Provides a platform-specific character used to separate directory levels in a --- path string that reflects a hierarchical file system organization. --- The separator is a slash (\"\/\") on Unix and Macintosh, and a backslash (\"\\\") on the --- Windows operating system. -pathSeparator :: Char -#ifdef mingw32_TARGET_OS -pathSeparator = '\\' -#else -pathSeparator = '/' -#endif - --- | A platform-specific character used to separate search path strings in --- environment variables. The separator is a colon (\":\") on Unix and Macintosh, --- and a semicolon (\";\") on the Windows operating system. -searchPathSeparator :: Char -#ifdef mingw32_TARGET_OS -searchPathSeparator = ';' -#else -searchPathSeparator = ':' -#endif - -#endif diff --git a/Halfs/CoreAPI.hs b/Halfs/CoreAPI.hs new file mode 100644 --- /dev/null +++ b/Halfs/CoreAPI.hs @@ -0,0 +1,858 @@ + +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, RankNTypes #-} +module Halfs.CoreAPI where + +import Control.Exception (assert) +import Data.ByteString (ByteString) +import Data.Serialize hiding (isEmpty) +import Data.Word +import Foreign.C.Error hiding (throwErrno) +import System.FilePath + +import qualified Data.ByteString as BS +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Traversable as T + +import Halfs.BlockMap +import Halfs.Classes +import Halfs.Directory +import Halfs.Errors +import Halfs.File +import Halfs.HalfsState +import Halfs.Inode +import Halfs.Monad +import Halfs.MonadUtils +import Halfs.Protection +import Halfs.SuperBlock +import Halfs.Types +import Halfs.Utils + +import qualified Halfs.File as F + +import System.Device.BlockDevice + +-- import Debug.Trace + +type HalfsM b r l m a = HalfsT HalfsError (Maybe (HalfsState b r l m)) m a + +data SyncType = Data | Everything + +data FileSystemStats = FSS + { fssBlockSize :: Integer -- ^ fundamental file system block size + , fssBlockCount :: Integer -- ^ #data blocks in filesystem + , fssBlocksFree :: Integer -- ^ #free blocks in filesystem + , fssBlocksAvailable :: Integer -- ^ #free blocks avail to non-root + , fssFileCount :: Integer -- ^ #num inodes in filesystem + , fssFilesFree :: Integer -- ^ #free inodes in filesystem + } + deriving (Show) + + +-------------------------------------------------------------------------------- +-- Filesystem init, teardown, and check functions + +-- | Create a new file system on the given device. The new file system +-- will use the block size reported by bdBlockSize on the device; if you +-- want to increase the file system's block size, you should use +-- 'newRescaledBlockDevice' from System.Device.BlockDevice. +-- +-- Block size has no bearing on the maximum size of a file or directory, but +-- will impact the size of certain internal data structures that keep track of +-- free blocks. Larger block sizes will decrease the cost of these structures +-- per underlying disk megabyte, but may also lead to more wasted space for +-- small files and directories. + +newfs :: (HalfsCapable b t r l m) => + BlockDevice m + -> UserID + -> GroupID + -> FileMode + -> HalfsM b r l m SuperBlock +newfs dev uid gid rdirPerms = do + when (superBlockSize > bdBlockSize dev) $ + fail "The device's block size is insufficiently large!" + + blockMap <- lift $ newBlockMap dev + initFree <- readRef (bmNumFree blockMap) + rdirAddr <- lift (alloc1 blockMap) >>= + maybe (fail "Unable to allocate block for rdir inode") return + + -- Build the root directory inode and persist it; note that we can't use + -- Directory.makeDirectory here because this is a special case where we have + -- no parent directory (and, furthermore, no filesystem state). + let rdirIR = blockAddrToInodeRef rdirAddr + dirInode <- lift $ + buildEmptyInodeEnc + dev + Directory + rdirPerms + rdirIR + nilIR + uid + gid + assert (BS.length dirInode == fromIntegral (bdBlockSize dev)) $ do + lift $ bdWriteBlock dev rdirAddr dirInode + + finalFree <- readRef (bmNumFree blockMap) + -- Persist the remaining data structures + lift $ writeBlockMap dev blockMap + lift $ writeSB dev $ SuperBlock + { version = 1 + , devBlockSize = bdBlockSize dev + , devBlockCount = bdNumBlocks dev + , unmountClean = True + , freeBlocks = finalFree + , usedBlocks = initFree - finalFree + , fileCount = 0 + , rootDir = rdirIR + , blockMapStart = blockAddrToInodeRef 1 + } + +-- | Mounts a filesystem from a given block device. After this operation +-- completes, the superblock will have its unmountClean flag set to False. +mount :: (HalfsCapable b t r l m) => + BlockDevice m + -> UserID + -> GroupID + -> FileMode + -> HalfsM b r l m (HalfsState b r l m) +mount dev usr grp rdirPerms = do + -- fsck needs read access some aspects of the HalfsState (e.g. the dev), even + -- though there isn't yet a valid state from a mount/successful fsck. Being + -- able to log here via logMsg is nice here, too, so we wrap everything in a + -- dummy environment with some bits filled in. We'll raise internal errors if + -- any of the nonexistent bits are pulled on. + + let lgr = Nothing -- Just $ \s -> trace s (return ()) + dummy <- newHalfsState dev usr grp lgr + (error "Internal (mount): dummy state's superblock is invalid!") + (error "Internal (mount): dummy state's blockmap is invalid!") + either throwError return =<< (lift $ runHalfs dummy $ mount') + where + newfs' d u g p = newfs d u g p >> mount d u g p + -- + mount' = do + esb <- decode `fmap` lift (bdReadBlock dev 0) + case esb of + Left _msg -> do + -- Unable to read the superblock: for now, we just give up on the mount + -- and provide a new filesystem. + logMsg "mount: unable to read superblock, creating new filesystem." + newfs' dev usr grp rdirPerms + Right sb -> do + if unmountClean sb + then do + bm <- lift $ readBlockMap dev + sb' <- lift $ writeSB dev sb{ unmountClean = False } + newHalfsState dev usr grp Nothing sb' bm + else do + mfs <- fsck dev sb usr grp rdirPerms + case mfs of + Just fs -> return fs + Nothing -> do + logMsg "mount: fsck failed. Creating new filesystem." + newfs' dev usr grp rdirPerms + +-- | Unmounts the given filesystem. After this operation completes, the +-- superblock will have its unmountClean flag set to True. +unmount :: (HalfsCapable b t r l m) => + HalfsM b r l m () +unmount = do + dhMap <- hasks hsDHMap + lk <- hasks hsLock + dev <- hasks hsBlockDev + sbRef <- hasks hsSuperBlock + + withLock lk $ withLockedRscRef dhMap $ \dhMapRef -> do + -- Grab everything; we do not want to permit other filesystem actions to + -- occur in other threads during or after teardown. Needs testing. TODO + + sb <- readRef sbRef + if (unmountClean sb) + then throwError HE_UnmountFailed + else do + -- TODO: + -- - Persist all dirty data structures (dirents, files w/ buffered IO, etc.) + + -- Sync all directories; clean directory state is a no-op + mapM_ syncDirectory =<< M.elems `fmap` readRef dhMapRef + + lift $ bdFlush dev + + -- Finalize the superblock + let sb' = sb{ unmountClean = True } + writeRef sbRef sb' + _ <- lift $ writeSB dev sb' + return () + +-------------------------------------------------------------------------------- +-- FileSystem ChecK (fsck) + +fsck :: HalfsCapable b t r l m => + BlockDevice m + -> SuperBlock + -> UserID + -> GroupID + -> FileMode + -> HalfsM b r l m (Maybe (HalfsState b r l m)) +fsck dev sb usr grp rdirPerms = do + used <- lift $ newUsedBitmap dev + mbad <- fsck' dev sb used (rootDir sb) (rootDir sb) + case mbad of + Nothing -> return Nothing + Just (bad, fc) -> do + bm <- lift $ writeUsedBitmap dev used >> readBlockMap dev + finalFree <- readRef (bmNumFree bm) + _ <- lift $ writeSB dev $ sb + { unmountClean = True + , freeBlocks = finalFree + , usedBlocks = initFree - finalFree + , fileCount = fc + } + logMsg $ "fsck: OK. Bad inodes found: " ++ show (map unIR bad) + Just `fmap` mount dev usr grp rdirPerms + where + blks = blockMapSizeBlks (bdNumBlocks dev) (bdBlockSize dev) + initFree = bdNumBlocks dev - blks - 1 {- -1 for superblock -} + +fsck' :: HalfsCapable b t r l m => + BlockDevice m + -> SuperBlock + -> b + -> InodeRef + -> InodeRef + -> HalfsM b r l m (Maybe ([InodeRef], Word64)) +fsck' dev sb used pinr inr = do + whenValid (drefInode inr) val + where + -- Failed operations result in this inode being marked invalid + whenValid act onValid = do + eea <- Right `fmap` act `catchError` \e -> Left `fmap` inv e + either return onValid eea + -- + inv err = do + logMsg $ "fsck: corrupt inode " ++ show (unIR inr) ++ ".\n\tReason: " + ++ show err + if pinr /= inr + then do + -- We have a valid parent directory, so remove the dirent for this inr + pdh <- newDirHandle pinr + contents <- readRef (dhContents pdh) + case L.find (\de -> deInode de == inr) (M.elems contents) of + Nothing -> do + logMsg "fsck internal: failed to find expected inode" + error "fsck internal: failed to find expected inode" + Just de -> do + rmDirEnt_lckd pdh (deName de) + syncDirectory_lckd pdh + return $ Just ([inr], 0) + else do + logMsg "fsck: Critical failure: couldn't decode root directory" + return Nothing + -- + val nd@Inode{ inoExt = ext, inoFileType = ftype } = do + assert (inoAddress nd == inr) $ return () + whenValid (drop 1 `fmap` expandExts Nothing ext) $ \exts -> do + let markUsed = mapM_ (setBit used) $ + unIR inr : map (unER . address) exts + case ftype of + Directory -> do + whenValid (newDirHandle inr) $ \thisDH -> do + markUsed + kids <- M.elems `fmap` readRef (dhContents thisDH) + foldM (\(Just (bads, fc)) kid -> do + Just (bs, k) <- fsck' dev sb used inr (deInode kid) + return $ Just (bads ++ bs, fc + k) + ) + (Just ([], 0)) kids + + RegularFile -> do + markUsed + return $ Just ([], 1) + + _ -> error "fsck' internal error: filetype not supported" + + +-------------------------------------------------------------------------------- +-- Directory manipulation + +-- | Makes a directory given an absolute path. +-- +-- * Yields HalfsPathComponentNotFound if any path component on the way down to +-- the directory to create does not exist. +-- +-- * Yields HalfsAbsolutePathExpected if an absolute path is not provided. +-- +mkdir :: (HalfsCapable b t r l m) => + FilePath + -> FileMode + -> HalfsM b r l m () +mkdir fp fm = do + parentIR <- fst `fmap` absPathIR path Directory + usr <- getUser + grp <- getGroup + _ <- makeDirectory parentIR dirName usr grp fm + return () + where + (path, dirName) = splitFileName fp + +rmdir :: (HalfsCapable b t r l m) => + FilePath -> HalfsM b r l m () +rmdir fp = removeDirectory (Just $ takeFileName fp) + =<< fst `fmap` absPathIR fp Directory + +openDir :: (HalfsCapable b t r l m) => + FilePath -> HalfsM b r l m (DirHandle r l) +openDir fp = openDirectory =<< fst `fmap` absPathIR fp Directory + +closeDir :: (HalfsCapable b t r l m) => + DirHandle r l -> HalfsM b r l m () +closeDir dh = closeDirectory dh + +readDir :: (HalfsCapable b t r l m) => + DirHandle r l + -> HalfsM b r l m [(FilePath, FileStat t)] +readDir dh = do + withDHLock dh $ do + inr <- getDHINR_lckd dh + contents <- liftM M.toList $ + T.mapM (fileStat) + =<< fmap deInode `fmap` readRef (dhContents dh) + thisStat <- fileStat inr + parentStat <- fileStat =<< do + withLockedInode inr $ do + p <- inoParent `fmap` drefInode inr + if isNilIR p + then fmap rootDir . readRef =<< hasks hsSuperBlock + else return p + return $ (dotPath, thisStat) : (dotdotPath, parentStat) : contents + +-- | Synchronize the given directory to disk. +syncDir :: (HalfsCapable b t r l m) => + FilePath -> SyncType -> HalfsM b r l m () +syncDir = undefined + +-------------------------------------------------------------------------------- +-- File manipulation + +-- | Creates a file given an absolute path. Raises HE_ObjectExists if the file +-- already exists. +createFile :: (HalfsCapable b t r l m ) => + FilePath + -> FileMode + -> HalfsM b r l m () +createFile fp mode = do + -- TODO: permissions + withDir ppath $ \pdh -> do + findInDir pdh fname RegularFile >>= \rslt -> + case rslt of + DF_Found _ -> throwError $ HE_ObjectExists fp + DF_WrongFileType ft -> throwError $ HE_UnexpectedFileType ft fp + _ -> return () + usr <- getUser + grp <- getGroup + _inr <- F.createFile pdh fname usr grp mode + return () + where + (ppath, fname) = splitFileName fp + +-- | Opens a file given an absolute path. Raises HE_FileNotFound if the named +-- file does not exist. Raises HE_UnexpectedFileType if the given path is not a +-- file. Otherwise, provides a FileHandle to the requested file + +-- TODO: modes and flags for open: append, r/w, ronly, truncate, etc., and +-- enforcement of the same +openFile :: (HalfsCapable b t r l m) => + FilePath -- ^ The absolute path of the file + -> FileOpenFlags -- ^ open flags / open mode (ronly, wonly, wr) + -> HalfsM b r l m (FileHandle r l) +openFile fp oflags = do + -- TODO: check perms + pdh <- openDir ppath + fh <- findInDir pdh fname RegularFile >>= \rslt -> + case rslt of + DF_NotFound -> throwError $ HE_FileNotFound + DF_WrongFileType ft -> throwError $ HE_UnexpectedFileType ft fp + DF_Found (fir, _ft) -> foundFile fir + closeDir pdh + return fh + where + (ppath, fname) = splitFileName fp + foundFile = openFilePrim oflags + +read :: (HalfsCapable b t r l m) => + FileHandle r l -- ^ the handle for the open file to read + -> Word64 -- ^ the byte offset into the file + -> Word64 -- ^ the number of bytes to read + -> HalfsM b r l m ByteString -- ^ the data read +read fh byteOff len = do + -- TODO: Check perms + unless (fhReadable fh) $ HE_BadFileHandleForRead `annErrno` eBADF + withLock (fhLock fh) $ do + inr <- getFHINR_lckd fh + readStream inr byteOff (Just len) + +write :: (HalfsCapable b t r l m) => + FileHandle r l -- ^ the handle for the open file to write + -> Word64 -- ^ the byte offset into the file + -> ByteString -- ^ the data to write + -> HalfsM b r l m () +write fh byteOff bytes = do + -- TODO: Check perms + unless (fhWritable fh) $ HE_BadFileHandleForWrite `annErrno` eBADF + withLock (fhLock fh) $ do + inr <- getFHINR_lckd fh + writeStream inr byteOff False bytes + +flush :: (HalfsCapable b t r l m) => + FileHandle r l -> HalfsM b r l m () +flush _fh = lift . bdFlush =<< hasks hsBlockDev + +syncFile :: (HalfsCapable b t r l m) => + FilePath -> SyncType -> HalfsM b r l m () +syncFile _fp _st = lift . bdFlush =<< hasks hsBlockDev + +closeFile :: (HalfsCapable b t r l m) => + FileHandle r l -- ^ the handle to the open file to close + -> HalfsM b r l m () +closeFile fh = closeFilePrim fh + +setFileSize :: (HalfsCapable b t r l m) => + FilePath -> Word64 -> HalfsM b r l m () +setFileSize fp len = + withFile fp (fofWriteOnly True) $ \fh -> do + withLock (fhLock fh) $ do + inr <- getFHINR_lckd fh + let wr = writeStream_lckd inr + withLockedInode inr $ do + sz <- fsSize `fmap` fileStat_lckd inr + if sz > len + then wr len True BS.empty -- truncate at len + else wr sz False $ bsReplicate (len - sz) 0 -- pad up to len + +setFileTimes :: (HalfsCapable b t r l m) => + FilePath + -> t -- ^ access time + -> t -- ^ modification time + -> HalfsM b r l m () +setFileTimes fp accTm modTm = do + -- TODO: Check permissions + modifyInode fp $ \nd -> nd{ inoModifyTime = modTm, inoAccessTime = accTm } + +rename :: (HalfsCapable b t r l m) => + FilePath -> FilePath -> HalfsM b r l m () +rename oldFP newFP = do + -- TODO: perms checks, more errno wrapping + + {- Currently status of unsupported POSIX error behaviors: + + TODO + ---- + [EACCES] A component of either path prefix denies search permission. + + [EACCES] The requested operation requires writing in a directory (e.g., + new, new/.., or old/..) whose modes disallow this. + + [EIO] An I/O error occurs while making or updating a directory entry. + + [ELOOP] Too many symbolic links are encountered in translating either + pathname. This is taken to be indicative of a looping symbolic + link. + + [EPERM] The directory containing old is marked sticky, and neither the + containing directory nor old are owned by the effective user ID. + + [EPERM] The new file exists, the directory containing new is marked sticky, + and neither the containing directory nor new are owned by the + effective user ID. + + DEFERRED + -------- + + [EXDEV] The link named by new and the file named by old are on different + logical devices (file systems). Note that this error code will not + be returned if the implementation permits cross-device links. + + [EROFS] The requested link requires writing in a directory on a read-only + file system. + + NOT APPLICABLE (but may be reconsidered later) + ---------------------------------------------- + [EFAULT] Path points outside the process's allocated address space. + + [EDQUOT] The directory in which the entry for the new name is being placed + cannot be extended because the user's quota of disk blocks on the + file system containing the directory has been exhausted. + + [ENAMETOOLONG] A component of a pathname exceeds {NAME_MAX} characters, or + an entire path name exceeds {PATH_MAX} characters. + -} + + -- [EINVAL]: An attempt is made to rename `.' or `..'. + when (oldFP `equalFilePath` dotPath || oldFP `equalFilePath` dotdotPath) $ + HE_RenameFailed `annErrno` eINVAL + + withDirResources $ \oldParentDH newParentDH -> do + -- Begin critical section over old and new parent directory handles + + mnewDE <- lookupDE newName newParentDH + oldDE <- lookupDE oldName oldParentDH + >>= (`maybe` return) + (HE_PathComponentNotFound oldName `annErrno` eNOENT) + -- [ENOENT]: A component of the old path DNE + + handleErrors oldDE mnewDE + + let updateContentMaps = do + addDirEnt_lckd' True newParentDH oldDE{ deName = newName } + rmDirEnt_lckd oldParentDH oldName + syncDirectory_lckd newParentDH `catchError` \e -> do + case e of + -- [ENOSPC]: The directory in which the entry for the new name is + -- being placed cannot be extended because there is no space left + -- on the file system containing the directory. + HE_AllocFailed{} -> e `annErrno` eNOSPC + _ -> throwError e + + -- We try to respect rename(2)'s behavior requirement that "an instance of + -- new will always exist, even if the system should crash in the middle of + -- the operation." Although there's still a risk here if the crash occurs + -- in the middle of the syncDirectory_lckd operation below (we're not + -- journaled), the content maps for the parent directories are updated + -- completely before any existing files/directories are removed. + -- + -- The thinking is as follows: if we crash immediately before the newName -> + -- oldDE sync'ing is initiated, 'new' is still valid and refers to the old + -- file/dir. If we crash immediately after the newName -> oldDE sync'ing, + -- 'new' is valid and since the old file/dir won't be a referent of any + -- content maps, fsck should be able to identify its resources as available. + -- + -- Finally, when 'new' is an existing empty directory that we'll replace + -- with 'old', it's important that we hold its dh lock for the duration of + -- the content map updates so that it doesn't become non-empty underneath + -- us. + + case mnewDE of + Nothing -> updateContentMaps + Just newDE -> case deType newDE of + RegularFile -> updateContentMaps >> removeFile Nothing (deInode newDE) + Directory -> do + -- New is a directory: ensure that it's empty before updating the + -- parent's content map + hbracket (openDirectory $ deInode newDE) closeDirectory $ \ndh -> do + withDHLock ndh $ do + -- begin dirhandle critical section + isEmpty <- M.null `fmap` readRef (dhContents ndh) + unless isEmpty $ HE_DirectoryNotEmpty `annErrno` eNOTEMPTY + updateContentMaps + -- end dirhandle critical section + + -- NB: We remove the replaced new directory's inode outside of its + -- locked DH context or we'll deadlock when removeDirectory + -- acquires. The unlocked window should be safe here, and it lets + -- us avoid writing "removeDirectory_dhlckd". + removeDirectory Nothing (deInode newDE) + _ -> throwError $ HE_InternalError "rename target type is unsupported" + -- End critical section over old and new parent directory handles + where + [oldName, newName] = map takeFileName [oldFP, newFP] + [oldPP, newPP] = map takeDirectory [oldFP, newFP] + -- + withDirResources f = + -- bracket & lock the old and new parent directories, being careful not to + -- double-lock when they're the same. + withDir' openDir' oldPP $ \opdh -> + withDir' openDir' newPP $ \npdh -> + (if oldPP == newPP + then withDHLock opdh + else withDHLock opdh . withDHLock npdh + ) $ f opdh npdh + -- + openDir' dp = openDir dp `catchError` \e -> + case e of + -- [ENOTDIR]: A component of path prefix is not a directory + HE_UnexpectedFileType{} -> e `annErrno` eNOTDIR + -- [ENOENT] A component of path does not exist + HE_PathComponentNotFound{} -> e `annErrno` eNOENT + _ -> throwError e + -- + handleErrors oldDE mnewDE = do + -- [EINVAL]: Old is a parent directory of new + when (deType oldDE == Directory && oldFP `isParentOf` newFP) $ + HE_RenameFailed `annErrno` eINVAL + + case mnewDE of + Nothing -> return () + Just newDE -> do + -- [EISDIR]: new is a directory, but old is not a directory. + when (nft == Directory && oft /= Directory) $ + HE_RenameFailed `annErrno` eISDIR + -- [ENOTDIR]: old is a directory, but new is not a directory. + when (oft == Directory && nft /= Directory) $ + HE_RenameFailed `annErrno` eNOTDIR + where + nft = deType newDE + oft = deType oldDE + -- + p1 `isParentOf` p2 = length l1 < length l2 && and (zipWith (==) l1 l2) + where l1 = splitDirectories p1 + l2 = splitDirectories p2 + + +-------------------------------------------------------------------------------- +-- Access control + +chmod :: (HalfsCapable b t r l m) => + FilePath -> FileMode -> HalfsM b r l m () +chmod fp mode = do + -- TODO: Check perms + modifyInode fp $ \nd -> nd{ inoMode = mode } + +chown :: (HalfsCapable b t r l m) => + FilePath + -> Maybe UserID -- ^ Nothing indicates no change to user + -> Maybe GroupID -- ^ Nothing indicates no change to group + -> HalfsM b r l m () +chown fp musr mgrp = do + -- TODO: Check perms + modifyInode fp $ \nd -> + nd{ inoUser = maybe (inoUser nd) id musr + , inoGroup = maybe (inoGroup nd) id mgrp + } + +access :: (HalfsCapable b t r l m) => + FilePath -> [AccessRight] -> HalfsM b r l m () +access = undefined + + +-------------------------------------------------------------------------------- +-- Link manipulation + +-- | A POSIX link(2)-like operation: makes a hard file link. +mklink :: (HalfsCapable b t r l m) => + FilePath -> FilePath -> HalfsM b r l m () +mklink path1 {-src-} path2 {-dst-} = do + {- Currently status of unsupported POSIX error behaviors: + + TODO + ---- + + [EACCES] A component of either path prefix denies search permission. + [EACCES] The requested link requires writing in a directory with a mode + that denies write permission. + [EACCES] The current process cannot access the existing file. + + [EIO] An I/O error occurs while reading from or writing to the file + system to make the directory entry. + + [ELOOP] Too many symbolic links are encountered in translating one of the + pathnames. This is taken to be indicative of a looping symbolic + link. + + DEFERRED + -------- + + [EROFS] The requested link requires writing in a directory on a read-only + file system. + + [EXDEV] The link named by path2 and the file named by path1 are on + different file systems. + + NOT APPLICABLE (but may be reconsidered later) + ---------------------------------------------- + + [EFAULT] One of the pathnames specified is outside the process's + allocated address space. + + [EDQUOT] The directory in which the entry for the new link is being + placed cannot be extended because the user's quota of disk + blocks on the file system containing the directory has been + exhausted. + + [EMLINK] The file already has {LINK_MAX} links. + + [ENAMETOOLONG] A component of a pathname exceeds {NAME_MAX} characters, or + an entire path name exceeded {PATH_MAX} characters. + -} + + hbracket openSrcFile closeFile $ \p1fh -> do + hbracket openDstDir closeDir $ \p2dh -> do + withLock (fhLock p1fh) $ do + srcINR <- getFHINR_lckd p1fh + addLink p2dh srcINR + incLinkCount srcINR + where + addLink p2dh inr = do + let fname = takeFileName path2 + linkPerms = FileMode [Read,Write] [Read] [Read] + -- TODO: Obtain the proper permissions for the link + usr <- getUser + grp <- getGroup + withDHLock p2dh $ do + addDirEnt_lckd p2dh fname inr usr grp linkPerms RegularFile + `catchError` \e -> do + case e of + -- [EEXIST]: The link named by path2 already exists. + HE_ObjectExists{} -> e `annErrno` eEXIST + _ -> throwError e + -- Manual directory sync here in order to catch and wrap errors + syncDirectory_lckd p2dh `catchError` \e -> do + rmDirEnt_lckd p2dh fname + case e of + -- [ENOSPC]: The directory in which the entry for the new link is + -- being placed cannot be extended because there is no space left + -- on the file system containing the directory. + HE_AllocFailed{} -> e `annErrno` eNOSPC + _ -> throwError e + -- + openDstDir = openDir (takeDirectory path2) `catchError` \e -> + case e of + -- [ENOTDIR]: A component of path2's pfx is not a directory + HE_UnexpectedFileType{} -> e `annErrno` eNOTDIR + -- [ENOENT] A component of path2's pfx does not exist + HE_PathComponentNotFound{} -> e `annErrno` eNOENT + _ -> throwError e + -- + openSrcFile = openFile path1 fofReadOnly `catchError` \e -> + case e of + -- [EPERM]: The file named by path1 is a directory + HE_UnexpectedFileType Directory _ -> e `annErrno` ePERM + -- [ENOTDIR]: A component of path1's pfx is not a directory + HE_UnexpectedFileType _ _ -> e `annErrno` eNOTDIR + -- [ENOENT] A component of path1's pfx does not exist + HE_PathComponentNotFound _ -> e `annErrno` eNOENT + -- [ENOENT] The file named by path1 does not exist + HE_FileNotFound -> e `annErrno` eNOENT + _ -> throwError e + +rmlink :: (HalfsCapable b t r l m) => + FilePath -> HalfsM b r l m () +rmlink fp = removeFile (Just $ takeFileName fp) + =<< fst `fmap` absPathIR fp RegularFile + +createSymLink :: (HalfsCapable b t r l m) => + FilePath -> FilePath -> HalfsM b r l m () +createSymLink = undefined + +readSymLink :: (HalfsCapable b t r l m) => + FilePath -> HalfsM b r l m FilePath +readSymLink = undefined + + +-------------------------------------------------------------------------------- +-- Filesystem stats + +fstat :: (HalfsCapable b t r l m) => + FilePath -> HalfsM b r l m (FileStat t) +fstat fp = fileStat =<< fst `fmap` absPathIR fp AnyFileType + +fsstat :: (HalfsCapable b t r l m) => + HalfsM b r l m FileSystemStats +fsstat = do + dev <- hasks hsBlockDev + numNodesRsc <- hasks hsNumFileNodes + bm <- hasks hsBlockMap + fileCnt <- fromIntegral `fmap` withLockedRscRef numNodesRsc readRef + freeCnt <- fromIntegral `fmap` numFreeBlocks bm + return FSS + { fssBlockSize = fromIntegral $ bdBlockSize dev + , fssBlockCount = fromIntegral $ bdNumBlocks dev + , fssBlocksFree = freeCnt + , fssBlocksAvailable = freeCnt -- TODO: blocks avail to non-root + , fssFileCount = fileCnt + , fssFilesFree = 0 -- TODO: need to supply free inode count + } + + +-------------------------------------------------------------------------------- +-- Utility functions & consts + +newHalfsState :: HalfsCapable b t r l m => + BlockDevice m + -> UserID + -> GroupID + -> Maybe (String -> m ()) + -> SuperBlock + -> BlockMap b r l + -> HalfsM b r l m (HalfsState b r l m) +newHalfsState dev usr grp lgr sb bm = + HalfsState dev usr grp lgr + `fmap` computeSizes (bdBlockSize dev) -- memoized since it won't change + `ap` return bm -- blockmap + `ap` newRef sb -- superblock + `ap` newLock -- filesystem lock + `ap` newLockedRscRef 0 -- Locked file node count + `ap` newLockedRscRef M.empty -- Locked map: inr -> DH + `ap` newLockedRscRef M.empty -- Locked map: inr -> (l, refcnt) + `ap` newLockedRscRef M.empty -- Locked map: inr -> (FH, opencnt) + +-- | Atomic inode modification wrapper +modifyInode :: HalfsCapable b t r l m => + FilePath + -> (Inode t -> Inode t) + -> HalfsM b r l m () +modifyInode fp f = + withFile fp (fofReadWrite True) $ \fh -> + withLock (fhLock fh) $ + getFHINR_lckd fh >>= flip atomicModifyInode (return . f) + +-- | Find the InodeRef corresponding to the given path. On error, raises +-- exceptions HE_PathComponentNotFound, HE_AbsolutePathExpected, or +-- HE_UnexpectedFileType. +absPathIR :: HalfsCapable b t r l m => + FilePath + -> FileType + -> HalfsM b r l m (InodeRef, FileType) +absPathIR fp ftype = do + if isAbsolute fp + then do + sbRef <- hasks hsSuperBlock + rdirIR <- rootDir `fmap` readRef sbRef + mir <- find rdirIR ftype (drop 1 $ splitDirectories fp) + case mir of + DF_NotFound -> throwError $ HE_PathComponentNotFound fp + DF_WrongFileType ft -> throwError $ HE_UnexpectedFileType ft fp + DF_Found (ir, ft) -> return (ir, ft) + else + throwError HE_AbsolutePathExpected + +-- | Bracketed directory open +withDir :: HalfsCapable b t r l m => + FilePath + -> (DirHandle r l -> HalfsM b r l m a) + -> HalfsM b r l m a +withDir = withDir' openDir + +-- | Bracketed directory open, parameterized by a function for opening a dir +withDir' :: HalfsCapable b t r l m => + (FilePath -> HalfsM b r l m (DirHandle r l)) + -> FilePath + -> (DirHandle r l -> HalfsM b r l m a) + -> HalfsM b r l m a +withDir' openF = (`hbracket` closeDir) . openF + +withFile :: (HalfsCapable b t r l m) => + FilePath + -> FileOpenFlags + -> (FileHandle r l -> HalfsM b r l m a) + -> HalfsM b r l m a +withFile fp oflags = + hbracket (openFile fp oflags) closeFile + +writeSB :: (HalfsCapable b t r l m) => + BlockDevice m -> SuperBlock -> m SuperBlock +writeSB dev sb = do + let sbdata = encode sb + assert (BS.length sbdata <= fromIntegral (bdBlockSize dev)) $ return () + bdWriteBlock dev 0 sbdata + bdFlush dev + return sb + +getUser :: HalfsCapable b t r l m => + HalfsM b r l m UserID +getUser = hasks hsUserID + +getGroup :: HalfsCapable b t r l m => + HalfsM b r l m GroupID +getGroup = hasks hsGroupID diff --git a/Halfs/Directory.hs b/Halfs/Directory.hs --- a/Halfs/Directory.hs +++ b/Halfs/Directory.hs @@ -1,113 +1,378 @@ -module Halfs.Directory (Directory(..), getChildrenInodeNums, addChild, - removeChild, getChildWithName, getChildrenNames, - filePathsNoDots, hasChild, DirectoryMap, - dirInodeNum, +module Halfs.Directory + ( DirHandle(..) + , FileStat(..) + , FileMode(..) + , AccessRight(..) + , FileType(..) + , addDirEnt + , addDirEnt_lckd + , addDirEnt_lckd' + , closeDirectory + , find + , findInDir + , getDHINR_lckd + , makeDirectory + , newDirHandle + , openDirectory + , removeDirectory + , rmDirEnt + , rmDirEnt_lckd + , syncDirectory + , syncDirectory_lckd + , withDirectory + -- * for testing + , DirectoryEntry(..) + , DirectoryState(..) + ) + where - -- intentionally not exporting DirectoryCache - -- constructor because we don't want anyone - -- messing with its dirty bit. - DirectoryCache(..), emptyDirectoryCache, - addDirectoryToCache, getDirectoryFromCache, - directoryCacheToList, dirCacheDirty, - markDirectoryCacheClean, rmDirectoryFromCache) - where +import Control.Exception (assert) +import qualified Data.ByteString as BS +import qualified Data.Map as M +import Data.Serialize +import Foreign.C.Error -import Halfs.Inode(Inode(..), InodeMetadata(..), inodeAddLink) -import {-# SOURCE #-} Halfs.FileHandle (FileHandle, fhInodeNum) -import Data.Integral (INInt) +import Halfs.BlockMap +import Halfs.Classes +import Halfs.Errors +import Halfs.HalfsState +import Halfs.Monad +import Halfs.MonadUtils +import Halfs.Inode ( Inode(..) + , atomicReadInode + , blockAddrToInodeRef + , buildEmptyInodeEnc + , drefInode + , freeInode + , inodeRefToBlockAddr + , readStream + , withLockedInode + , writeStream + ) +import Halfs.Protection +import Halfs.Types +import Halfs.Utils +import System.Device.BlockDevice ---base -import Data.Map(Map) -import qualified Data.Map as Map -import Control.Exception(assert) +-- import Debug.Trace --- |Maps strings to inode numbers -type DirectoryMap = Map String INInt +type HalfsM b r l m a = HalfsT HalfsError (Maybe (HalfsState b r l m)) m a -data Directory = Directory {dirFile :: FileHandle - ,dirContents :: DirectoryMap - ,dirDirty :: Bool - } + +-------------------------------------------------------------------------------- +-- Directory manipulation and query functions -dirInodeNum :: Directory -> INInt -dirInodeNum d = fhInodeNum $ dirFile d +-- | Given a parent directory's inoderef, its owner, and its group, +-- generate a new, empty directory with the given name. +makeDirectory :: HalfsCapable b t r l m => + InodeRef -- ^ inr to parent directory + -> String -- ^ directory name + -> UserID -- ^ user id for created directory + -> GroupID -- ^ group id for created directory + -> FileMode -- ^ initial perms for new directory + -> HalfsM b r l m InodeRef -- ^ on success, the inode ref to the + -- created directory +makeDirectory parentIR dname user group perms = + withDirectory parentIR $ \pdh -> do + withDHLock pdh $ do + -- Begin critical section over parent's DirHandle + contents <- readRef (dhContents pdh) + if M.member dname contents + then throwError $ HE_ObjectExists dname + else do + bm <- hasks hsBlockMap + mir <- fmap blockAddrToInodeRef `fmap` alloc1 bm + case mir of + Nothing -> throwError HE_AllocFailed + Just thisIR -> do + -- Build the directory inode and persist it + dev <- hasks hsBlockDev + bstr <- lift $ buildEmptyInodeEnc + dev + Directory + perms + thisIR + parentIR + user + group + assert (BS.length bstr == fromIntegral (bdBlockSize dev)) $ do + lift $ bdWriteBlock dev (inodeRefToBlockAddr thisIR) bstr -addChild :: Directory -- ^to add to - -> Inode -- ^new child's inode - -> String -- ^Name - -> Maybe (Directory, Inode) -- ^Nothing if already exists (updated version of parent directory, updated version of child's inode) -addChild (Directory dirFH theContents _) inode name = - case Map.lookup name theContents of - Just _ -> Nothing -- shouldn't be there! - Nothing -> Just ((Directory dirFH (Map.insert name - (assert (inodeNum > 0) inodeNum) - theContents) - True - ,inodeAddLink inode)) - where inodeNum = inode_num $ metaData inode + -- Add 'dname' to parent directory's contents + addDirEnt_lckd pdh dname thisIR user group perms Directory + return thisIR + -- End critical section over parent's DirHandle --- |Does this directory have the given file in it? -hasChild :: Directory -> String -> Bool -hasChild Directory{dirContents=theMap} s - = Map.member s theMap +-- | Given a parent directory's inode ref, remove the directory with the given name. +removeDirectory :: HalfsCapable b t r l m => + Maybe String -- ^ name to remove from parent + -- directory's content map (when Nothing, + -- leaves the the parent directory's + -- content map alone) + -> InodeRef -- ^ inr of directory to remove + -> HalfsM b r l m () +removeDirectory mdname inr = do + -- TODO: Perms check (write perms on parent directory, etc.) + dhMap <- hasks hsDHMap -removeChild :: Directory -> String -> Directory -removeChild (Directory f c _) k - = Directory f (Map.delete k c) True + -- We lock the dirhandle map so (a) there's no contention for + -- dirhandle lookup/creation for the directory we're removing and (b) + -- so we can ensure that the directory is empty. --- |Get the inode numbers from the contents of this directory -getChildrenInodeNums :: Directory -> [INInt] -getChildrenInodeNums = Map.elems . dirContents + withLockedRscRef dhMap $ \dhMapRef -> do + dh <- lookupRM inr dhMapRef >>= maybe (newDirHandle inr) return + withDHLock dh $ do + -- begin dirhandle critical section + contents <- readRef (dhContents dh) + unless (M.null contents) $ HE_DirectoryNotEmpty `annErrno` eNOTEMPTY -getChildrenNames :: Directory -> [String] -getChildrenNames = Map.keys . dirContents + -- When we've been given a directory name, purge this dir's dirent from + -- the parent directory. + case mdname of + Nothing -> return () + Just dname -> + withLockedInode inr $ do + pinr <- inoParent `fmap` drefInode inr + pdh <- lookupRM pinr dhMapRef >>= maybe (newDirHandle pinr) return + rmDirEnt pdh dname -getChildWithName :: Directory -> String -> Maybe INInt -getChildWithName dir str - = let e = Map.lookup str (dirContents dir) - in assert (notLEZ e) e --- Check to make sure that the number is valid; 0 is invalid because --- its not the child of anything. - where notLEZ Nothing = True - notLEZ (Just n) = n > 0 + -- Invalidate dh so that all subsequent DH-mediated access fails + writeRef (dhInode dh) Nothing + deleteRM inr dhMapRef + freeInode inr + -- end dirhandle critical section -filePathsNoDots :: [FilePath] -> [FilePath] -filePathsNoDots = filter (\x -> (x /= ".") && (x /= "..")) +-- | Syncs directory contents to disk +syncDirectory :: HalfsCapable b t r l m => + DirHandle r l + -> HalfsM b r l m () +syncDirectory dh = withDHLock dh $ syncDirectory_lckd dh +syncDirectory_lckd :: HalfsCapable b t r l m => + DirHandle r l + -> HalfsM b r l m () +syncDirectory_lckd dh = do + -- Precond: (dhLock dh) is currently held (can we assert this? TODO) + state <- readRef $ dhState dh --- ------------------------------------------------------------ --- * directory cache --- ------------------------------------------------------------ + -- TODO: Currently, we overwrite the entire DirectoryEntry list, truncating + -- the directory's inode data stream as needed. This is _braindead_, however. + -- For OnlyAdded, we can just append to the stream; for OnlyDeleted, we can + -- write only invalidating entries and employ incremental coalescing, etc. + -- overwriteAll should be reserved for the VeryDirty case only. + case state of + Clean -> return () + OnlyAdded -> overwriteAll + OnlyDeleted -> overwriteAll + VeryDirty -> overwriteAll + where + overwriteAll = do + inr <- getDHINR_lckd dh + writeStream inr 0 True + =<< (encode . M.elems) `fmap` readRef (dhContents dh) + lift . bdFlush =<< hasks hsBlockDev + modifyRef (dhState dh) dirStTransClean --- |Maps from inode numbers to directories. -data DirectoryCache = DirectoryCache { dirCacheDirty :: Bool - , _dirCache :: Map INInt Directory} +-- | Obtains an active directory handle for the directory at the given InodeRef +openDirectory :: HalfsCapable b t r l m => + InodeRef + -> HalfsM b r l m (DirHandle r l) +openDirectory inr = do + -- TODO FIXME permissions checks! + dhMap <- hasks hsDHMap + mdh <- withLockedRscRef dhMap (lookupRM inr) + case mdh of + Just dh -> return dh + Nothing -> do + dh <- newDirHandle inr + withLockedRscRef dhMap $ \ref -> do + -- If there's now a DirHandle in the map for our inode ref, prefer it to + -- the one we just created; this is to safely avoid race conditions + -- without extending the critical section over this entire function, + -- which performs a potentially expensive BlockDevice read. + mdh' <- lookupRM inr ref + case mdh' of + Just dh' -> return dh' + Nothing -> do + insertRM inr dh ref + return dh -emptyDirectoryCache :: DirectoryCache -emptyDirectoryCache = DirectoryCache False Map.empty +closeDirectory :: HalfsCapable b t r l m => + DirHandle r l + -> HalfsM b r l m () +closeDirectory dh = do + syncDirectory dh + return () -directoryCacheToList :: DirectoryCache -> [Directory] -directoryCacheToList (DirectoryCache _ c) = Map.elems c +-- | Add a directory entry for a file, directory, or symlink; expects +-- that the item does not already exist in the directory. Thread-safe. +addDirEnt :: HalfsCapable b t r l m => + DirHandle r l + -> String + -> InodeRef + -> UserID + -> GroupID + -> FileMode + -> FileType + -> HalfsM b r l m () +addDirEnt dh name ir u g mode ftype = + withDHLock dh $ addDirEnt_lckd dh name ir u g mode ftype --- |Also used for updating. If this directory is marked dirty, then --- the cache will also be marked dirty. -addDirectoryToCache :: DirectoryCache -> Directory -> DirectoryCache -addDirectoryToCache (DirectoryCache cacheDirty c) d - = DirectoryCache (if dirDirty d - then True - else cacheDirty) - (Map.insert (dirInodeNum d) d c) +addDirEnt_lckd :: HalfsCapable b t r l m => + DirHandle r l + -> String + -> InodeRef + -> UserID + -> GroupID + -> FileMode + -> FileType + -> HalfsM b r l m () +addDirEnt_lckd dh name inr u g mode ftype = + addDirEnt_lckd' False dh $ DirEnt name inr u g mode ftype -markDirectoryCacheClean :: DirectoryCache -> DirectoryCache -markDirectoryCacheClean (DirectoryCache _ c) - = DirectoryCache False c +addDirEnt_lckd' :: HalfsCapable b t r l m => + Bool + -> DirHandle r l + -> DirectoryEntry + -> HalfsM b r l m () +addDirEnt_lckd' replaceOK dh de = do + -- Precond: (dhLock dh) is currently held (can we assert this? TODO) + when (not replaceOK) $ do + mfound <- lookupDE name dh + maybe (return ()) (const $ throwError $ HE_ObjectExists name) mfound + insertRM name de (dhContents dh) + modifyRef (dhState dh) dirStTransAdd + where + name = deName de -getDirectoryFromCache :: DirectoryCache -> INInt -> Maybe Directory -getDirectoryFromCache (DirectoryCache _ c) i - = Map.lookup i c +-- | Remove a directory entry for a file, directory, or symlink; expects +-- that the item exists in the directory. Thread-safe. +rmDirEnt :: HalfsCapable b t r l m => + DirHandle r l + -> String + -> HalfsM b r l m () +rmDirEnt dh name = + withDHLock dh $ rmDirEnt_lckd dh name --- |Does not complain if the item does not exist. Directory cache --- stays clean. -rmDirectoryFromCache :: DirectoryCache -> INInt -> DirectoryCache -rmDirectoryFromCache (DirectoryCache _ c) i - = DirectoryCache False (Map.delete i c) +rmDirEnt_lckd :: HalfsCapable b t r l m => + DirHandle r l + -> String + -> HalfsM b r l m () +rmDirEnt_lckd dh name = do + -- Precond: (dhLock dh) is currently held (can we assert this? TODO) + -- begin sanity check + mfound <- lookupDE name dh + maybe (throwError $ HE_ObjectDNE name) (const $ return ()) mfound + -- end sanity check + deleteRM name (dhContents dh) + modifyRef (dhState dh) dirStTransRm + +-- | Finds a directory, file, or symlink given a starting inode +-- reference (i.e., the directory inode at which to begin the search) +-- and a list of path components. Success is denoted using the DF_Found +-- constructor of the DirFindRslt type. +find :: HalfsCapable b t r l m => + InodeRef -- ^ The starting inode reference + -> FileType -- ^ A match must be of this filetype + -> [FilePath] -- ^ Path components + -> HalfsM b r l m (DirFindRslt InodeRef) +-- +find startINR ftype [] = do + ft <- atomicReadInode startINR inoFileType + return $ foundRslt startINR ft ftype +-- +find startINR ftype (pathComp:rest) = do + dh <- openDirectory startINR + sr <- findDE dh pathComp (if null rest then ftype else Directory) + case sr of + DF_NotFound -> return $ DF_NotFound + DF_WrongFileType ft -> return $ DF_WrongFileType ft + DF_Found (de, _) -> find (deInode de) ftype rest + +-- | Locate the given directory entry typed file by filename in the +-- DirHandle's content map +findDE :: HalfsCapable b t r l m => + DirHandle r l + -> String + -> FileType + -> HalfsM b r l m (DirFindRslt DirectoryEntry) +findDE dh fname ftype = do + mde <- withDHLock dh $ lookupDE fname dh + case mde of + Nothing -> return DF_NotFound + Just de -> return $ foundRslt de (deType de) ftype + +-- Exportable version of findDE; doesn't expose DirectoryEntry to caller +findInDir :: HalfsCapable b t r l m => + DirHandle r l + -> String + -> FileType + -> HalfsM b r l m (DirFindRslt InodeRef) +findInDir dh fname ftype = fmap deInode `fmap` findDE dh fname ftype + +foundRslt :: a -> FileType -> FileType -> DirFindRslt a +foundRslt inr ft ftype = + if ft `isFileType` ftype + then DF_Found (inr, ft) + else DF_WrongFileType ft + + +-------------------------------------------------------------------------------- +-- Utility functions + +newDirHandle :: HalfsCapable b t r l m => + InodeRef + -> HalfsM b r l m (DirHandle r l) +newDirHandle inr = do + rawDirBytes <- readStream inr 0 Nothing + dirEnts <- if BS.null rawDirBytes + then do return [] + else case decode rawDirBytes of + Left msg -> throwError $ HE_DecodeFail_Directory msg + Right x -> return x + DirHandle + `fmap` newRef (Just inr) + `ap` newRef (M.fromList $ map deName dirEnts `zip` dirEnts) + `ap` newRef Clean + `ap` newLock + +-- Get directory handle's inode reference... +getDHINR_lckd :: HalfsCapable b t r l m => + DirHandle r l + -> HalfsM b r l m InodeRef +getDHINR_lckd dh = do + -- Precond: (dhLock dh) has been acquired (TODO: can we assert this?) + readRef (dhInode dh) >>= maybe (throwError HE_InvalidDirHandle) return + +withDirectory :: HalfsCapable b t r l m => + InodeRef + -> (DirHandle r l -> HalfsM b r l m a) + -> HalfsM b r l m a +withDirectory ir = hbracket (openDirectory ir) closeDirectory + +isFileType :: FileType -> FileType -> Bool +isFileType _ AnyFileType = True +isFileType t1 t2 = t1 == t2 + +_showDH :: HalfsCapable b t r l m => DirHandle r l -> HalfsM b r l m String +_showDH dh = do + withDHLock dh $ do + state <- readRef $ dhState dh + contents <- readRef $ dhContents dh + inr <- getDHINR_lckd dh + return $ "DirHandle { dhInode = " ++ show inr + ++ ", dhContents = " ++ show contents + ++ ", dhState = " ++ show state + +dirStTransAdd :: DirectoryState -> DirectoryState +dirStTransAdd Clean = OnlyAdded +dirStTransAdd OnlyAdded = OnlyAdded +dirStTransAdd _ = VeryDirty + +dirStTransRm :: DirectoryState -> DirectoryState +dirStTransRm Clean = OnlyDeleted +dirStTransRm OnlyDeleted = OnlyDeleted +dirStTransRm _ = VeryDirty + +dirStTransClean :: DirectoryState -> DirectoryState +dirStTransClean = const Clean diff --git a/Halfs/Directory.hs-boot b/Halfs/Directory.hs-boot deleted file mode 100644 --- a/Halfs/Directory.hs-boot +++ /dev/null @@ -1,22 +0,0 @@ -module Halfs.Directory where - -import Data.Integral -import Data.Map(Map) -import GHC.Base --- import Halfs -import {-# SOURCE #-} Halfs.FileHandle - -data Directory - = Directory {dirFile :: FileHandle - ,dirContents :: DirectoryMap - ,dirDirty :: Bool - } - - -type DirectoryMap = Map String INInt -data DirectoryCache = DirectoryCache { dirCacheDirty :: Bool - , _dirCache :: Map INInt Directory} - -removeChild :: Directory -> String -> Directory -getChildWithName :: Directory -> String -> Maybe INInt -getDirectoryFromCache :: DirectoryCache -> INInt -> Maybe Directory diff --git a/Halfs/Errors.hs b/Halfs/Errors.hs new file mode 100644 --- /dev/null +++ b/Halfs/Errors.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Halfs.Errors +where + +import Data.Word +import Foreign.C.Error + +import Halfs.Monad +import Halfs.Types + +data HalfsError = + HE_AbsolutePathExpected + | HE_AllocFailed + | HE_BadFileHandleForRead + | HE_BadFileHandleForWrite + | HE_DecodeFail_BlockCarrier String + | HE_DecodeFail_Ext String + | HE_DecodeFail_Directory String + | HE_DecodeFail_Inode String + | HE_DirectoryHandleNotFound + | HE_DirectoryNotEmpty + | HE_ErrnoAnnotated HalfsError Errno + | HE_FileNotFound + | HE_FsckErr HalfsError + | HE_InternalError String + | HE_InvalidExtIdx + | HE_InvalidStreamIndex Word64 + | HE_InvalidDirHandle + | HE_InvalidFileHandle + | HE_MountFailed RsnHalfsMountFail + | HE_ObjectExists FilePath + | HE_ObjectDNE FilePath + | HE_PathComponentNotFound String + | HE_RenameFailed + | HE_TestFailed String + | HE_UnexpectedFileType FileType FilePath + | HE_UnmountFailed + deriving (Eq, Show) + +data RsnHalfsMountFail = + BadSuperBlock String + | DirtyUnmount + deriving (Eq, Show) + +annErrno :: MonadError HalfsError m => HalfsError -> Errno -> m a +e `annErrno` errno = throwError (e `HE_ErrnoAnnotated` errno) + +throwErrno :: Monad m => Errno -> HalfsError -> HalfsT HalfsError env m a +throwErrno en = throwError . (`HE_ErrnoAnnotated` en) + +-- TODO: template haskell to make this a bit cleaner? +instance Show Errno where + show en | en == eOK = "EOK" + | en == e2BIG = "E2BIG" + | en == eACCES = "EACCES" + | en == eADDRINUSE = "EADDRINUSE" + | en == eADDRNOTAVAIL = "EADDRNOTAVAIL" + | en == eADV = "EADV" + | en == eAFNOSUPPORT = "EAFNOSUPPORT" + | en == eAGAIN = "EAGAIN" + | en == eALREADY = "EALREADY" + | en == eBADF = "EBADF" + | en == eBADMSG = "EBADMSG" + | en == eBADRPC = "EBADRPC" + | en == eBUSY = "EBUSY" + | en == eCHILD = "ECHILD" + | en == eCOMM = "ECOMM" + | en == eCONNABORTED = "ECONNABORTED" + | en == eCONNREFUSED = "ECONNREFUSED" + | en == eCONNRESET = "ECONNRESET" + | en == eDEADLK = "EDEADLK" + | en == eDESTADDRREQ = "EDESTADDRREQ" + | en == eDIRTY = "EDIRTY" + | en == eDOM = "EDOM" + | en == eDQUOT = "EDQUOT" + | en == eEXIST = "EEXIST" + | en == eFAULT = "EFAULT" + | en == eFBIG = "EFBIG" + | en == eFTYPE = "EFTYPE" + | en == eHOSTDOWN = "EHOSTDOWN" + | en == eHOSTUNREACH = "EHOSTUNREACH" + | en == eIDRM = "EIDRM" + | en == eILSEQ = "EILSEQ" + | en == eINPROGRESS = "EINPROGRESS" + | en == eINTR = "EINTR" + | en == eINVAL = "EINVAL" + | en == eIO = "EIO" + | en == eISCONN = "EISCONN" + | en == eISDIR = "EISDIR" + | en == eLOOP = "ELOOP" + | en == eMFILE = "EMFILE" + | en == eMLINK = "EMLINK" + | en == eMSGSIZE = "EMSGSIZE" + | en == eMULTIHOP = "EMULTIHOP" + | en == eNAMETOOLONG = "ENAMETOOLONG" + | en == eNETDOWN = "ENETDOWN" + | en == eNETRESET = "ENETRESET" + | en == eNETUNREACH = "ENETUNREACH" + | en == eNFILE = "ENFILE" + | en == eNOBUFS = "ENOBUFS" + | en == eNODATA = "ENODATA" + | en == eNODEV = "ENODEV" + | en == eNOENT = "ENOENT" + | en == eNOEXEC = "ENOEXEC" + | en == eNOLCK = "ENOLCK" + | en == eNOLINK = "ENOLINK" + | en == eNOMEM = "ENOMEM" + | en == eNOMSG = "ENOMSG" + | en == eNONET = "ENONET" + | en == eNOPROTOOPT = "ENOPROTOOPT" + | en == eNOSPC = "ENOSPC" + | en == eNOSR = "ENOSR" + | en == eNOSTR = "ENOSTR" + | en == eNOSYS = "ENOSYS" + | en == eNOTBLK = "ENOTBLK" + | en == eNOTCONN = "ENOTCONN" + | en == eNOTDIR = "ENOTDIR" + | en == eNOTEMPTY = "ENOTEMPTY" + | en == eNOTSOCK = "ENOTSOCK" + | en == eNOTTY = "ENOTTY" + | en == eNXIO = "ENXIO" + | en == eOPNOTSUPP = "EOPNOTSUPP" + | en == ePERM = "EPERM" + | en == ePFNOSUPPORT = "EPFNOSUPPORT" + | en == ePIPE = "EPIPE" + | en == ePROCLIM = "EPROCLIM" + | en == ePROCUNAVAIL = "EPROCUNAVAIL" + | en == ePROGMISMATCH = "EPROGMISMATCH" + | en == ePROGUNAVAIL = "EPROGUNAVAIL" + | en == ePROTO = "EPROTO" + | en == ePROTONOSUPPORT = "EPROTONOSUPPORT" + | en == ePROTOTYPE = "EPROTOTYPE" + | en == eRANGE = "ERANGE" + | en == eREMCHG = "EREMCHG" + | en == eREMOTE = "EREMOTE" + | en == eROFS = "EROFS" + | en == eRPCMISMATCH = "ERPCMISMATCH" + | en == eRREMOTE = "ERREMOTE" + | en == eSHUTDOWN = "ESHUTDOWN" + | en == eSOCKTNOSUPPORT = "ESOCKTNOSUPPORT" + | en == eSPIPE = "ESPIPE" + | en == eSRCH = "ESRCH" + | en == eSRMNT = "ESRMNT" + | en == eSTALE = "ESTALE" + | en == eTIME = "ETIME" + | en == eTIMEDOUT = "ETIMEDOUT" + | en == eTOOMANYREFS = "ETOOMANYREFS" + | en == eTXTBSY = "ETXTBSY" + | en == eUSERS = "EUSERS" + | en == eWOULDBLOCK = "EWOULDBLOCK" + | en == eXDEV = "EXDEV" + | otherwise = "" diff --git a/Halfs/FSRW.hs b/Halfs/FSRW.hs deleted file mode 100644 --- a/Halfs/FSRW.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Halfs.FSRW where - -class Monad m => FSRW m where - unsafeLiftIORW :: IO a -> m a - --- |FIX: Remove this instance someday. -instance FSRW IO where - unsafeLiftIORW = id - diff --git a/Halfs/FSRoot.hs b/Halfs/FSRoot.hs deleted file mode 100644 --- a/Halfs/FSRoot.hs +++ /dev/null @@ -1,201 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : FSRoot --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : GHC --- --- Explanation: Represents the root of a filesystem and encapsulates --- the caches. - -module Halfs.FSRoot (FSRoot(..), FileSystemStats(..), - addToInodeCache, - allocateInode, getFromInodeCache, emptyInodeCache, - fsRootUpdateInodeCache, - fsRootInode, fsRootAllInodeNums, fsStats, - fsRootBmInode, fsRootRootDirInode, fsRootImInode, - fsRootUpdateDirectoryCache, fsRootRmFromDirectoryCache, - Directory, -- from Halfs.Directory - FSStatus(..), InodeCacheAddStyle(..), - BufferBlockCache, InodeNum, InodeCache) -where - -import Halfs.TheBlockMap(TheBlockMap(..)) -import Halfs.BufferBlockCache (BufferBlockCache) -import Data.Integral ( INInt ) -import Halfs.Utils (bytesPerBlock, - rootInodeNum, blockMapInodeNum, rootDirInodeNum, - inodeMapInodeNum, FileType(File)) -import System.RawDevice(RawDevice) -import Halfs.Inode (Inode(..), InodeMetadata (..), newInode, - newFSRootInode, newFSBlockMapInode, - newFSRootDirInode, newFSInodeMapInode) -import Halfs.TheInodeMap(TheInodeMap(..)) -import Halfs.Directory(Directory(..), DirectoryCache, addDirectoryToCache, - rmDirectoryFromCache) - --- base -import Control.Exception(assert) -import Data.Map(Map) -import qualified Data.Map as Map -import Data.Queue (queueLength) -import Data.Set(Set) -import qualified Data.Set as Set - -type InodeNum = INInt - --- |Maps the inode number to the inode. -type InodeCache = (Map InodeNum Inode, Bool) - -data FSRoot = FSRoot {device :: RawDevice - -- ^The "raw" interface for reading & writing blocks. - ,bbCache :: BufferBlockCache - -- ^Maps the disk address to a cache of the blocks. - ,blockMap :: TheBlockMap - -- ^A queue of free blocks. - ,inodeCache :: InodeCache - -- ^Maps the inode number to the inode. - ,inodeMap :: TheInodeMap - -- ^Keeps track of freed inodes so we can reuse their space. - ,directoryCache :: DirectoryCache - -- ^Maps from inode numbers to directories. - ,fsStatus :: FSStatus - -- ^mounted or unmounted? - } - -data FSStatus = FsUnmounted | FsReadOnly | FsReadWrite deriving (Eq, Show) - -data FileSystemStats = FileSystemStats - { blockSize :: Integer - -- ^ Optimal transfer block size in bytes. - , blockCount :: Integer - -- ^ Total data blocks in file system. - , blocksFree :: Integer - -- ^ Free blocks in file system. - , blocksAvailable :: Integer - -- ^ Free blocks available to non-superusers. - , fileCount :: Integer - -- ^ Total file nodes in file system. - , filesFree :: Integer - -- ^ Free file nodes in file system. - , maxNameLength :: Integer - -- ^ Maximum length of filenames. FUSE default is 255. - } - --- |Behavior if it's already in the cache -data InodeCacheAddStyle - = InodeCacheOverwrite -- ^if so, overwrite it. If not, add it. - | InodeCacheKeep -- ^if so, keep the cache version - | InodeCacheError -- ^if so, that's an error! throw assertion. - deriving Eq --- Compare by disk number -instance Eq FSRoot where - (==) FSRoot{device=one} FSRoot{device=two} - = one == two - --- Compare by disk number -instance Ord FSRoot where - compare FSRoot{device=one} FSRoot{device=two} - = compare one two - --- |Type is a little funny because it's useful for a fold! -addToInodeCache :: InodeCacheAddStyle -- ^add it even if it's already there? - -> (InodeCache, InodeNum) -- ^old cache, old biggest inode - -> Inode -- ^inode to add - -> (InodeCache, InodeNum) -- new cache, next inode num -addToInodeCache style p@(c@(iCache, _), num) i = - case style of - InodeCacheOverwrite -> adder p i - _ -> case Map.lookup num iCache of - Nothing -> adder p i - Just _ -> ( c - , assert (style /= InodeCacheError) (num+1)) -- throw it away. - where - adder :: (InodeCache, InodeNum) -> Inode -> (InodeCache, InodeNum) - adder ((inCache, _), inodeNum) inode@Inode{metaData=md} - = ((Map.insert inodeNum inode{metaData=md{inode_num=inodeNum}} inCache, True) - ,inodeNum + 1) - --- |Not a new element, just update the old entry in the cache, so --- doesn't increase number of inodes. -fsRootUpdateInodeCache :: FSRoot -> Inode -> FSRoot -fsRootUpdateInodeCache fsroot@FSRoot{inodeCache=(ic, _)} - inode@Inode{metaData=InodeMetadata{inode_num=inodeNum}} - = fsroot{inodeCache=(Map.insert inodeNum inode ic, True)} - -getFromInodeCache :: InodeCache -> InodeNum -> Maybe Inode -getFromInodeCache (cache, _) n = Map.lookup n cache - -emptyInodeCache :: InodeCache -emptyInodeCache = (Map.empty, True) - -fsRootInode :: FSRoot -> Inode -fsRootInode FSRoot{inodeCache=c} - = case getFromInodeCache c rootInodeNum of - Nothing -> assert False newFSRootInode -- shouldn't happen. - Just a -> a - -fsRootBmInode :: FSRoot -> Inode -fsRootBmInode FSRoot{inodeCache=c} - = case getFromInodeCache c blockMapInodeNum of - Nothing -> assert False newFSBlockMapInode -- shouldn't happen. - Just a -> a - -fsRootRootDirInode :: FSRoot -> Inode -fsRootRootDirInode FSRoot{inodeCache=c} - = case getFromInodeCache c rootDirInodeNum of - Nothing -> assert False newFSRootDirInode -- shouldn't happen. - Just a -> a - -fsRootImInode :: FSRoot -> Inode -fsRootImInode FSRoot{inodeCache=c} - = case getFromInodeCache c inodeMapInodeNum of - Nothing -> assert False newFSInodeMapInode -- shouldn't happen. - Just a -> a - --- |Creates a new inode out of thin air and puts it into the inode --- cache, and returns its number. -allocateInode :: FSRoot - -> (INInt, FSRoot) -allocateInode fsRoot@FSRoot{inodeMap=inMap@TheInodeMap{freeInodes=[] - ,imMaxNum=numInodes}, - inodeCache=inCache - } = - let (newCache, newNumInodes) - = addToInodeCache InodeCacheOverwrite (inCache, numInodes) (newInode numInodes File) - in (numInodes, fsRoot{inodeCache=newCache - ,inodeMap=inMap{imDirty=True, - imMaxNum=newNumInodes}}) --- initialize h in case it's right from the disk? -allocateInode fs@FSRoot{inodeMap=im@TheInodeMap{freeInodes=(h:t)}} - = (h, fs{inodeMap=im{freeInodes=t, imDirty=True}}) - -fsRootUpdateDirectoryCache :: Directory -> FSRoot -> FSRoot -fsRootUpdateDirectoryCache dir fsroot@FSRoot{directoryCache=c} - = fsroot{directoryCache=addDirectoryToCache c dir} - -fsRootRmFromDirectoryCache :: INInt -- The inode number of the directory to remove - -> FSRoot - -> FSRoot -fsRootRmFromDirectoryCache dirInodeNum fsroot@FSRoot{directoryCache=c} - = fsroot{directoryCache=rmDirectoryFromCache c dirInodeNum} - -fsRootAllInodeNums :: FSRoot -> Set INInt -fsRootAllInodeNums FSRoot{inodeMap=theInMap} - = let maxInode = (imMaxNum theInMap) - 1 - in (Set.fromList (0:[blockMapInodeNum .. maxInode])) - `Set.difference` (Set.fromList $ freeInodes theInMap) - -fsStats :: FSRoot -> IO FileSystemStats -fsStats fsroot = do - let availBlocks = toInteger $ queueLength $ freeBlocks $ blockMap $ fsroot - return FileSystemStats{blockSize=toInteger bytesPerBlock - ,blockCount=toInteger $ bmTotalSize $ blockMap fsroot - ,blocksFree=availBlocks - ,blocksAvailable=availBlocks - ,fileCount=toInteger - $ Set.size $ fsRootAllInodeNums fsroot - ,filesFree=0 - ,maxNameLength=255 - } diff --git a/Halfs/FSState.hs b/Halfs/FSState.hs deleted file mode 100644 --- a/Halfs/FSState.hs +++ /dev/null @@ -1,347 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, RankNTypes, FlexibleContexts #-} - --- | Convenience module for exporting usually useful stuff --- ALL "unsafe*" functions must be deleted and turned into "primitives" --- in this module. - -module Halfs.FSState (StateHandle(..) -- FIX: might get rid of FSState or StateHandle. - -- writing stuff: - ,FSWrite, unsafeLiftIOWrite, runFSWrite - ,evalFSWriteIO, evalFSWriteIOMV - ,runFSWriteIO, readToWrite, readToWriteCont, writeToBuffer - ,unsafeLiftIOWriteWithRoot, unsafeWriteGet, putStrLnWriteRead - ,updateInodeCacheWrite - ,modifyFSWrite - -- reading stuff: - ,FSRead, unsafeLiftIORead, runFSRead - ,runFSReadIO, evalFSReadIOMV, unsafeReadGet - ,unsafeModifyFSRead - ,unsafeWriteToRead - -- general monad capabilities. move elsewhere? - ,newReadRef, readReadRef, modifyReadRef, writeReadRef - ,takeMVarRW, readMVarRW, putMVarRW, modifyMVarRW_ - ,modifyMVarRW_' - -- other stuff: - ,module Control.Monad.Trans - ,module Control.Monad.Error - ,module Control.Monad.State - -- read-write - ,FSRW, unsafeLiftIORW - -- FIX: don't export put & get: - ,Control.Monad.State.put - ,Control.Monad.State.get - ,alreadyExistsEx - ,doesNotExistEx - ,eofEx - ,illegalOpEx - ,decLinksForInode - ,forkWithMVar - ,forkFSWrite - ) where - -import Binary (Binary, BinHandle, put_) -import Halfs.FSRoot (FSRoot(..), FSStatus(..) - ,fsRootUpdateInodeCache) -import Halfs.FSRW -import Halfs.Inode(Inode(..), InodeMetadata(..)) --- import System.RawDevice(RawDevice) - --- FIX: get rid of FSState data type; we only need it because it works --- on the StateT monad. We can rool it ourselves and get rid of --- FSState, probably. - --- base - -import Control.Concurrent(MVar, ThreadId, modifyMVar_, tryPutMVar, modifyMVar, - putMVar, newMVar, readMVar, forkIO, takeMVar, - withMVar) -import Control.Exception(assert) -import Control.Monad.Error(throwError, catchError, MonadError) -import Control.Monad.State(StateT(..), modify, - evalStateT, execStateT, - MonadState) -import qualified Control.Monad.State (get, put) -import Control.Monad.Trans(liftIO) -import Data.IORef (IORef, newIORef, readIORef, modifyIORef, writeIORef) -import System.IO.Error (alreadyExistsErrorType, doesNotExistErrorType, - illegalOperationErrorType, eofErrorType, mkIOError) - --- | Read-write state -data StateHandle - = StateHandle { {- any function needing access to the FSRoot - needs to get this mvar: -} - stateFineMVar :: MVar FSRoot - - {- clients can use this MVar to block by calling - the evalFS{Read,Write}IOMV functions: -} - , stateCoarseMVar :: Maybe (MVar ()) - } deriving Eq -type FSState a = StateT StateHandle IO a - -alreadyExistsEx :: FilePath -> IOError -alreadyExistsEx path - = mkIOError alreadyExistsErrorType "already exists" Nothing (Just path) - -doesNotExistEx :: FilePath -> IOError -doesNotExistEx path - = mkIOError doesNotExistErrorType "does not exist" Nothing (Just path) - -illegalOpEx :: FilePath -> IOError -illegalOpEx path - = mkIOError illegalOperationErrorType "illegal operation" Nothing (Just path) - -eofEx :: FilePath -> IOError -eofEx path = mkIOError eofErrorType "EOF" Nothing (Just path) - --- ------------------------------------------------------------ --- * FSState Read Only --- ------------------------------------------------------------ - -newtype FSRead a = FSR (FSState a) -instance Monad FSRead where - return a = FSR (return a) - (FSR m) >>= k = FSR $ do a <- m - runFSRead $ k a - --- | Make this read-only monad into a read-write monad. -runFSRead :: FSRead a -> FSState a -runFSRead (FSR f) = f - --- | Returns the FSRoot since things like Inode cache may change. -runFSReadIO' :: FSRead a - -> FSRoot - -> IO (a, FSRoot) -runFSReadIO' (FSR f) s = - do mv <- newMVar s - -- same mvar, so ignore it on output: - (r,_) <- runStateT f (StateHandle mv Nothing) - fsroot <- readMVar mv - return (r, fsroot) - -runFSReadIO :: FSRead a - -> FSRoot - -> (IOError -> IO (a, FSRoot)) -- exception handler - -> IO (a, FSRoot) -runFSReadIO f s handler = catch (runFSReadIO' f s) handler - --- | -evalFSReadIOMV :: FSRead a -> StateHandle -> IO a -evalFSReadIOMV (FSR f) mv@(StateHandle _ (Just blockOn)) - = do (r,_) <- withMVar blockOn $ \ _ -> runStateT f mv - return r -evalFSReadIOMV (FSR f) mv@(StateHandle _ Nothing) - = do (r,_) <- runStateT f mv - return r - --- | Unsafe because it uses readMVar. -unsafeReadGet :: FSRead FSRoot -unsafeReadGet = FSR $ do (StateHandle mv _) <- Control.Monad.State.get - liftIO $ readMVar mv - --- | FIX: Unsafe? -unsafeModifyFSRead :: (FSRoot -> (FSRoot, a)) -> FSRead a -unsafeModifyFSRead f = FSR $ do - (StateHandle mv _) <- Control.Monad.State.get - retVal <- liftIO $ modifyMVar mv (\fsroot -> return (f fsroot)) - return retVal - --- | FIX: Delete this function; it's temporary during refactoring. It --- violates safety requirements. -unsafeLiftIORead :: IO a -> FSRead a -unsafeLiftIORead action = FSR $ liftIO action - --- | unsafe since this allows a reader to write. -unsafeWriteToRead :: FSWrite a -> FSRead a -unsafeWriteToRead (FSW a) = FSR a - --- These are mostly for handles. The types aren't what we would like --- since we can't import FileHandle. - --- This synonym is for documentation purposes: -type ReadRef a = IORef a - -newReadRef :: a -> FSRead (ReadRef a) -newReadRef = unsafeLiftIORead . newIORef - -readReadRef :: (ReadRef a) -> FSRead a -readReadRef = unsafeLiftIORead . readIORef - -modifyReadRef :: (ReadRef a) -> (a -> a) -> FSRead () -modifyReadRef f h = unsafeLiftIORead $ modifyIORef f h - -writeReadRef :: (ReadRef a) -> a -> FSRead () -writeReadRef f h = unsafeLiftIORead $ writeIORef f h - -takeMVarRW :: (FSRW m) => MVar a -> m a -takeMVarRW = unsafeLiftIORW . takeMVar - -putMVarRW :: (FSRW m) => MVar a -> a -> m () -putMVarRW m a = unsafeLiftIORW (putMVar m a) - -readMVarRW :: (FSRW m) => MVar a -> m a -readMVarRW = unsafeLiftIORW . readMVar - -modifyMVarRW_ :: (FSRW m) => MVar a -> (a -> IO a) -> m () -modifyMVarRW_ m f = unsafeLiftIORW (modifyMVar_ m f) - -modifyMVarRW_' :: (FSRW m, MonadError IOError m) => MVar a -> (a -> m a) -> m () -modifyMVarRW_' m f = do - s <- takeMVarRW m - catchError (f s >>= putMVarRW m) - (\e -> putMVarRW m s >> unsafeLiftIORW (throwError e)) - -instance MonadError IOError FSRead where - throwError = FSR . throwError - catchError (FSR m) f - = FSR $ catchError m (\e -> runFSRead $ f e) - --- ------------------------------------------------------------ --- * FSState Write Only --- ------------------------------------------------------------ - -newtype FSWrite a = FSW (FSState a) -instance Monad FSWrite where - return a = FSW (return a) - (FSW m) >>= k = FSW $ do a <- m - runFSWrite $ k a - --- | Make this write-only monad into a read-write monad. -runFSWrite :: FSWrite a -> FSState a -runFSWrite (FSW f) = f - --- Forks a new thread which uses the mvar from this state. Whew. Sorta doesn't make sense to be in FSWrite, maybe should just be in IO; we have two versions of the state available here, and that's no good... one is really just for syncronizeation. - -forkWithMVar :: (StateHandle -> FSWrite ()) -> FSWrite ThreadId -forkWithMVar f = do - mv <- FSW Control.Monad.State.get - forkFSWrite (f mv) - -forkFSWrite :: FSWrite () -> FSWrite ThreadId -forkFSWrite (FSW f) = - FSW (do mv <- Control.Monad.State.get - -- safe to ignore output since its held in the mvar - liftIO $ forkIO $ (runStateT f mv >> return ())) - -runFSWriteIO :: FSWrite a -> FSRoot -> IO (a, FSRoot) -runFSWriteIO (FSW f) s = do mv <- newMVar s - -- same mvar, so ignore it on output: - (r,_) <- runStateT f (StateHandle mv Nothing) - fsroot <- readMVar mv - return (r, fsroot) - -evalFSWriteIOMV :: FSWrite a -> StateHandle -> IO a -evalFSWriteIOMV (FSW f) mv@(StateHandle _ (Just blockOn)) - = do (r,_) <- withMVar blockOn $ \ _ -> runStateT f mv - return r -evalFSWriteIOMV (FSW f) mv@(StateHandle _ Nothing) - = do (r,_) <- runStateT f mv - return r - --- | -evalFSWriteIO :: FSWrite a -> FSRoot -> IO a -evalFSWriteIO (FSW f) s = do - mv <- newMVar s - evalStateT f (StateHandle mv Nothing) - -putStrLnWriteRead :: String -> FSWrite () -putStrLnWriteRead = unsafeLiftIOWrite . putStrLn - --- | FIX: Delete this function; it's temporary during refactoring. It --- violates safety requirements. -unsafeLiftIOWrite :: IO a -> FSWrite a -unsafeLiftIOWrite action = FSW $ liftIO action - -unsafeLiftIOWriteWithRoot :: (FSRoot -> IO a) -> FSWrite a -unsafeLiftIOWriteWithRoot action = FSW $ do (StateHandle mv _) <- Control.Monad.State.get - fsroot <- liftIO $ readMVar mv - liftIO (action fsroot) - -{- UNUSED: --- | Blocks on the MVar while performing this action. -unsafeLiftIOWriteModifyRoot :: (FSRoot -> IO FSRoot) -> FSWrite () -unsafeLiftIOWriteModifyRoot action - = FSW $ do (StateHandle mv v) - <- Control.Monad.State.get - _newRoot <- liftIO $ withMVar mv action - -- unnecessary: - Control.Monad.State.put (StateHandle mv v) --} - -writeToBuffer :: (Binary a) => BinHandle -> a -> FSWrite () -writeToBuffer bh a = FSW $ liftIO (Binary.put_ bh a) - -instance MonadError IOError FSWrite where - throwError = FSW . throwError - catchError (FSW m) f - = FSW $ catchError m (\e -> runFSWrite $ f e) - -instance MonadState FSRoot FSWrite where - get = FSW (do (StateHandle mv _) <- Control.Monad.State.get --- liftIO $ readMVar mv) --- liftIO $ putStrLn "monadState get!" - fsroot <- liftIO $ takeMVar mv - return $ assert (fsStatus fsroot /= FsUnmounted) fsroot -{- - maybeRoot <- liftIO $ tryTakeMVar mv - case maybeRoot of - -- FIX: remove below when using multi-threads: - Nothing -> liftIO $ putStrLn "DEADLOCK GET" >> error "deadlock get" - Just a -> return a --} - ) - put s = FSW (do (StateHandle mv _) <- Control.Monad.State.get - maybeFoo <- liftIO $ tryPutMVar mv s - case maybeFoo of - True -> return () - False -> liftIO $ putStrLn "DEADLOCK PUT" >> error "deadlock put" ) - --- | Unsafe since it uses readMVar. For get-only situations, for --- reading and not writing; no mvar block. -unsafeWriteGet :: FSWrite FSRoot -unsafeWriteGet = FSW $ do (StateHandle mv _) <- Control.Monad.State.get - liftIO $ readMVar mv - --- | FIX: This 'f' should probably be in the FSRW monad, since that doesn't have state. -modifyFSWrite :: (FSRoot -> FSWrite (FSRoot, a)) -> FSWrite a -modifyFSWrite f = do - fsroot <- Control.Monad.State.get - (newRoot, retVal) <- f fsroot - Control.Monad.State.put newRoot - return retVal - --- | Safe since writers can be readers. -readToWrite :: FSRead a -> FSWrite a -readToWrite (FSR a) = FSW a - --- | Safe since writers can be readers. -readToWriteCont :: ((forall s . m s -> FSRead a) -> FSRead a) - -> (forall s . m s -> FSWrite a) -> FSWrite a -readToWriteCont f cont = - case f (w2r cont) of - FSR a -> FSW a - where - w2r :: (forall s . m s -> FSWrite a) -> (forall s . m s -> FSRead a) - w2r g s = case g s of - FSW a -> FSR a - - - -updateInodeCacheWrite :: Inode -> FSWrite () -updateInodeCacheWrite inode - = modify (\f -> fsRootUpdateInodeCache f inode) - -decLinksForInode :: Inode -> FSWrite () -decLinksForInode inode@Inode{metaData=md@InodeMetadata{hard_links=hl}} - = updateInodeCacheWrite inode{metaData=md{hard_links=hl-1}} - --- ------------------------------------------------------------ --- * FSReadWrite --- ------------------------------------------------------------ - --- FSRW functions don't carry state unless it's passed explicitly as --- input and output. -instance FSRW FSRead where - unsafeLiftIORW = unsafeLiftIORead - -instance FSRW FSWrite where - unsafeLiftIORW = unsafeLiftIOWrite diff --git a/Halfs/File.hs b/Halfs/File.hs new file mode 100644 --- /dev/null +++ b/Halfs/File.hs @@ -0,0 +1,168 @@ +module Halfs.File + ( FileHandle (..) -- fhInode, fhReadable, fhWritable) + , createFile + , fofReadOnly + , fofWriteOnly + , fofReadWrite + , getFHINR_lckd + , openFilePrim + , closeFilePrim + , removeFile + ) + where + +import Halfs.BlockMap +import Halfs.Classes +import Halfs.Directory +import Halfs.Errors +import Halfs.HalfsState +import Halfs.Inode +import Halfs.Monad +import Halfs.MonadUtils +import Halfs.Protection +import Halfs.Types +import Halfs.Utils + +import System.Device.BlockDevice + +-- import Debug.Trace + +type HalfsM b r l m a = HalfsT HalfsError (Maybe (HalfsState b r l m)) m a + +-------------------------------------------------------------------------------- +-- File creation and manipulation functions + +createFile :: HalfsCapable b t r l m => + DirHandle r l + -> FilePath + -> UserID + -> GroupID + -> FileMode + -> HalfsM b r l m InodeRef +createFile parentDH fname usr grp mode = do + dev <- hasks hsBlockDev + bm <- hasks hsBlockMap + mfileIR <- fmap blockAddrToInodeRef `fmap` lift (alloc1 bm) + case mfileIR of + Nothing -> throwError HE_AllocFailed + Just fileIR -> do + withDHLock parentDH $ do + pIR <- getDHINR_lckd parentDH + n <- lift $ buildEmptyInodeEnc + dev + RegularFile + mode + fileIR + pIR + usr + grp + lift $ bdWriteBlock dev (inodeRefToBlockAddr fileIR) n + addDirEnt_lckd parentDH fname fileIR usr grp mode RegularFile + numNodesRsc <- hasks hsNumFileNodes + atomicModifyLockedRscRef numNodesRsc (+1) + return $ fileIR + +removeFile :: HalfsCapable b t r l m => + Maybe String -- ^ name to remove from parent directory's content + -- map (when Nothing, leaves the parent directory's + -- content map alone) + -> InodeRef -- ^ inr of file to remove + -> HalfsM b r l m () +removeFile mfname inr = do + case mfname of + Nothing -> return () + Just fname -> do + -- Purge the filename from the parent directory + dhMap <- hasks hsDHMap + withLockedRscRef dhMap $ \dhMapRef -> do + pinr <- atomicReadInode inr inoParent + pdh <- lookupRM pinr dhMapRef >>= maybe (newDirHandle pinr) return + rmDirEnt pdh fname + + -- Decrement link count & register deallocation callback + hbracket (openFilePrim fofReadOnly inr) closeFilePrim $ \fh -> do + fhMap <- hasks hsFHMap + withLockedRscRef fhMap $ \fhMapRef -> do + atomicModifyInode inr $ \nd -> do + when (inoNumLinks nd == 1) $ do + -- We're removing the last link, so we inject a callback into the fhmap + -- that will be invoked when all processes have closed the filehandle + -- associated with inr. The callback invalidates the filehandle and + -- releases its inode. NB: The callback must assume that both the fhmap + -- and fh locks are held when it is executed. + mfhData <- lookupRM inr fhMapRef + case mfhData of + Just (_, c, _) -> insertRM inr (fh, c, cb) fhMapRef + where cb = invalidateFH fh >> freeInode inr + Nothing -> error "fh not found for open file, cannot happen" + return nd{ inoNumLinks = inoNumLinks nd - 1 } + +openFilePrim :: HalfsCapable b t r l m => + FileOpenFlags -> InodeRef -> HalfsM b r l m (FileHandle r l) +openFilePrim oflags@FileOpenFlags{ openMode = omode } inr = do + fhMap <- hasks hsFHMap + withLockedRscRef fhMap $ \fhMapRef -> do + mfh <- lookupRM inr fhMapRef + case mfh of + Just (fh, c, onFinalClose) -> do + insertRM inr (fh, c + 1, onFinalClose) fhMapRef + return fh + Nothing -> do + fh <- FH (omode /= WriteOnly) (omode /= ReadOnly) oflags + `fmap` newRef (Just inr) + `ap` newLock + insertRM inr (fh, 1, invalidateFH fh) fhMapRef + return fh + +closeFilePrim :: HalfsCapable b t r l m => + FileHandle r l + -> HalfsM b r l m () +closeFilePrim fh = do + fhMap <- hasks hsFHMap + withLock (fhLock fh) $ do + withLockedRscRef fhMap $ \fhMapRef -> do + inr <- getFHINR_lckd fh + mfh <- lookupRM inr fhMapRef + case mfh of + Nothing -> return () + + -- Remove FH from the map when the current open count is 1, otherwise + -- just decrement it. When FH is removed from the map, execute the + -- 'onFinalClose' callback from the fhmap (which, by default, simply + -- invalidates the FH, but may also, e.g., deallocate resources for the + -- file if a function like rmlink needs to defer resource release). NB: + -- onFinalClose may assume that both fh and fhmap locks are held! + -- + -- TODO: We may want to do this on a per-process basis (e.g., by mapping + -- an inr to a pid -> open count map) to disallow accidental multiple + -- closes across multiple processes resulting in incorrect open counts. + -- At the very least, we should work through the ramifications should + -- this multiple-close scenario occur. This includes dealing with + -- per-process FH invalidation as well. E.g., in the current scheme, if + -- two processes p1 and p2 have the FH and p1 closes it, FH invalidation + -- does not occur (it would occur only after p1 and p2 closed the FH) + -- and so p1 can still use the FH which is not intended. + -- + Just (_, c, onFinalClose) + | c == 1 -> deleteRM inr fhMapRef >> onFinalClose + | otherwise -> insertRM inr (fh, c - 1, onFinalClose) fhMapRef + +-- Get file handle's inode reference +getFHINR_lckd :: HalfsCapable b t r l m => + FileHandle r l + -> HalfsM b r l m InodeRef +getFHINR_lckd fh = + -- Precond: (fhLock fh) has been acquried (TODO: can we assert this?) + readRef (fhInode fh) >>= maybe (throwError HE_InvalidFileHandle) return + +invalidateFH :: HalfsCapable b t r l m => + FileHandle r l + -> HalfsM b r l m () +invalidateFH fh = writeRef (fhInode fh) Nothing + +fofReadOnly :: FileOpenFlags +fofReadOnly = FileOpenFlags False False ReadOnly + +fofWriteOnly, fofReadWrite :: Bool -> FileOpenFlags +fofWriteOnly app = FileOpenFlags app False WriteOnly +fofReadWrite app = FileOpenFlags app False ReadWrite diff --git a/Halfs/FileHandle.hs b/Halfs/FileHandle.hs deleted file mode 100644 --- a/Halfs/FileHandle.hs +++ /dev/null @@ -1,450 +0,0 @@ -{-# LANGUAGE PatternSignatures #-} -module Halfs.FileHandle (fhRead, fhSize, fhRewind, fileHandle, fileHandle', - fhCloseRead, fhCloseWrite, fhSeek, fhInode, fhOpenWrite, - fhOpenTruncate, fhWrite, getDirectoryAtPath, - allocateInodeWrite, - getSomethingAtPath, FileMode(..), FileHandle(..), - unitTests, readFileFromInode, newDirectory, unlink, - getInodeAtPath, openFileAtPath, doesPathExist) - where - -import Halfs.Inode (Inode(..), InodeMetadata(..), inodeBumpSize, - goodInodeMagic, newInode, dupInode, updatePointers) -import Data.Integral ( INLong, INInt, fromIntegral'', - intToINInt, intToINLong, inIntToINLong) -import Halfs.Utils (BlockNumber, bytesPerBlock, FileType(..), - unimplemented, rootInodeMagicNum) -import Halfs.BasicIO (getDiskAddrOfBlockWrite, - readPartOfBlock, writePartOfBlock, - readDirectoryBin, getInodeRead, getInodeWrite, - freeInodeData, fsRootFreeInode) -import Binary (BinHandle) -import Halfs.BinaryMonad (openBinMemRW, sizeBinMemRW, resetBinRW) -import {-# SOURCE #-} Halfs.Blocks(getDiskAddrOfBlockRead) -import Halfs.FSRoot (FSRoot(..), fsRootRootDirInode, fsRootUpdateInodeCache, - fsRootUpdateDirectoryCache, allocateInode) - -import Halfs.TestFramework (Test, test, (~=?), (~:), UnitTests, hunitToUnitTest) -import qualified Halfs.FSState (get, put) -import Halfs.TheInodeMap(freeInode) -import Halfs.FSState (doesNotExistEx, FSWrite, FSRead, - modify, eofEx, decLinksForInode, - readToWrite, unsafeReadGet, unsafeModifyFSRead, - catchError, updateInodeCacheWrite) -import Halfs.TheBlockMap (freeBlock) - -import {-# SOURCE #-} Halfs.Directory(Directory(..), - getDirectoryFromCache, - removeChild, getChildWithName) - --- Base -import qualified Data.Map as Map -import Data.Array(assocs) -import Data.List(sort) -import Control.Exception(assert) -import Control.Monad(foldM, unless, when) -import Control.Monad.Error(throwError) -import Halfs.CompatFilePath (splitFileName) -import System.IO.Error (isDoesNotExistError) --- ------------------------------------------------------------ --- * FileHandle stuff --- ------------------------------------------------------------ - -data FileMode = ReadMode | WriteMode | AppendMode deriving (Eq, Show) - --- |This is _not_ an opaque type. Anyone can change the mode of --- elements, reguardless of whether they're in the FSRead or FSWrite --- monads. The mode here is _not_ enforcing. Maybe eventually will --- be opaque. FIX. - -data FileHandle - = FileHandle {fhInodeNum :: INInt - ,fhSeekPos :: INLong - ,fhMode :: FileMode - } deriving (Show, Eq) -- FIX: eq instance should probably be the inode number? - -fhSize :: FileHandle -> FSRead INLong -fhSize fh = do - inode <- fhInode fh - return $ num_bytes $ metaData inode - -fhInode :: FileHandle -> FSRead Inode -fhInode FileHandle{fhInodeNum=n} - = getInodeRead n Nothing - --- |A "smart" constructor for FileHandle. Does not truncate file in --- write mode or anything like that. -fileHandle :: INInt -> FileMode -> FileHandle -fileHandle iNum f = fileHandle' iNum 0 f - --- |Another smart construcor. -fileHandle' :: INInt -> INLong -> FileMode -> FileHandle -fileHandle' iNum s f = FileHandle iNum s f - --- |open for write. -fhOpenWrite :: INInt -> FSWrite FileHandle -fhOpenWrite inodeNum = do - return $ FileHandle inodeNum 0 WriteMode - --- |Opens the file in write mode and frees all blocks in the file. --- Reuses the inode. -fhOpenTruncate :: INInt -> FSWrite FileHandle -fhOpenTruncate inodeNum0 = do - oldInode@ - Inode{metaData=InodeMetadata{inode_num=inodeNum - ,mode=theMode - ,hard_links=oldHardLinks - ,magic1=theMagic}} <- getInodeWrite inodeNum0 Nothing - let newI' = newInode inodeNum theMode - let newI = newI'{metaData=(metaData newI'){magic1 = theMagic - ,hard_links=oldHardLinks}} - when (theMagic == rootInodeMagicNum) (error "overwriting root inode.") - modify (\fsroot -> fsRootUpdateInodeCache fsroot newI) - freeInodeData oldInode - return $ fileHandle inodeNum WriteMode - --- |Close this handle. Does nothing for now. -fhCloseRead :: FileHandle -> FSRead () -fhCloseRead _ = return () - --- |Close this handle. Does nothing for now. -fhCloseWrite :: FileHandle -> FSWrite () -fhCloseWrite _ = return () - -fhRewind :: FileHandle -> FileHandle -fhRewind fh = fh{fhSeekPos=0} - -fhSeek :: FileHandle -> INLong -> FileHandle -fhSeek fh n = fh{fhSeekPos=n} - --- ------------------------------------------------------------ --- * Read --- ------------------------------------------------------------ - --- |Must not touch the block map in fhRead, since it may not be --- well-formed yet. -fhRead :: FileHandle - -> BinHandle -- ^Buffer to read into - -> INInt -- ^Offset into above buffer - -> INInt -- ^How many to read - -> FSRead (FileHandle, INInt) -- ^Number actually read, nothing if eof -fhRead inFh _buffer _offset _len = do - buffSize <- sizeBinMemRW _buffer - (newLen::INInt) - <- fhSize inFh >>= fhRead' inFh _buffer _offset _len (intToINInt buffSize) - return $ (inFh{fhSeekPos=(fhSeekPos inFh) + inIntToINLong newLen}, newLen) - - where - - fhRead' :: FileHandle - -> BinHandle -- ^Buffer to read into - -> INInt -- ^Offset into above buffer - -> INInt -- ^How many to read - -> INInt -- Buffer size - -> INLong -- Size of file (from fhSize) - -> FSRead INInt -- ^Number actually read, nothing if eof - fhRead' fh@FileHandle{fhSeekPos=filePos} buffer offset len buffSize fileSize - -- First two cases handle bad length requests. - | offset + len > buffSize - = fhRead' fh buffer offset (buffSize - offset) buffSize fileSize - | filePos + (inIntToINLong len) > fileSize - -- safe conversion, since len is INInt - = let (newLen::INInt) = fromIntegral'' $ fileSize - filePos - in if newLen <= 0 - then throwError $ eofEx "" - else fhSize fh >>= fhRead' fh buffer - (assert (newLen < len) offset) - newLen buffSize - | otherwise = do sums <- mapM (\ (startPos::INLong, len', soFar) -> do - inode <- fhInode fh - readBlock inode - -- following fromIntegral'' is kinda safe, due to mod. - (fromIntegral'' (startPos `div` intToINLong bytesPerBlock)) - (fromIntegral'' (startPos `mod` intToINLong bytesPerBlock)) - len' buffer (offset + soFar)) - (seekPositions filePos len) - return (sum sums) -- the amount actually read - - --- |Read a number of bytes from the given file. -readBlock :: Inode -- The file to read from - -> BlockNumber -- Block number of the file to read - -> INInt -- Offset in the above block - -> INInt -- number of bytes to read - -> BinHandle -- Array to read the block into - -> INInt -- buffer offset; where to read this block into - -> FSRead INInt -- Number of bytes read -readBlock inode blockNum blockOffset numBytes buffer buffOffset - = do da <- getDiskAddrOfBlockRead inode blockNum - readPartOfBlock da blockOffset buffer buffOffset numBytes - --- ------------------------------------------------------------ --- * Write --- ------------------------------------------------------------ - -fhWrite :: FileHandle - -> BinHandle -- ^Buffer to write from - -> INInt -- ^Offset into above buffer - -> INInt -- ^How many to write - -> FSWrite (FileHandle, INInt) - -- ^Number actually written, nothing if eof -fhWrite (FileHandle{fhMode=ReadMode}) _ _ _ = throwError $ eofEx "" -fhWrite inFH@(FileHandle inodeNum filePos _) buffer buffOffset len = do - outLen - <- foldM (oneWrite buffer inodeNum buffOffset) - 0 - (seekPositions filePos len) - let fh' = inFH{fhSeekPos=filePos + inIntToINLong outLen} - return (fh', outLen) - --- |Bumps the filesize. -oneWrite :: BinHandle - -> INInt -- Inode number - -> INInt -- buff offset - -> INInt -- bytes so far, inode - -> (INLong, INInt, INInt) - -> FSWrite INInt -- bytes so far -oneWrite buffer inodeNum buffOffset - bytesSoFar (startPos, len', soFar) = do - lastInode <- getInodeWrite inodeNum Nothing - let oldSize = num_bytes $ metaData lastInode - newLen - <- writeBlock - lastInode - -- following are kinda safe due to div & mod - (fromIntegral'' (startPos `div` intToINLong bytesPerBlock)) - (fromIntegral'' (startPos `mod` intToINLong bytesPerBlock)) - len' buffer (buffOffset + soFar) - newInodeB <- getInodeWrite (inode_num $ metaData lastInode) Nothing - let currSize = num_bytes $ metaData newInodeB - -- how much bigger is this file than it was before? - let (biggerBy::INLong) - = startPos + (inIntToINLong newLen) - - (assert (currSize == oldSize) currSize) --- putStrLnWriteRead $ "would bump if > 0: " ++ (show biggerBy) - -- bump the size if we've gone off the end: - updateInodeCacheWrite (if biggerBy > 0 - then inodeBumpSize newInodeB (currSize + biggerBy) - else newInodeB) - return $ bytesSoFar + newLen - --- |Write a number of bytes from the given file. Be sure to bump the --- file size. - -writeBlock :: Inode -- The file to write into - -> BlockNumber -- Block number of the file to write - -> INInt -- Offset in the above block - -> INInt -- number of bytes to write - -> BinHandle -- buffer to read from - -> INInt -- buffer offset; where to write this block into - -> FSWrite INInt -- Number of bytes written -writeBlock inInode blockNum blockOffset numBytes buffer buffOffset - = do da <- getDiskAddrOfBlockWrite inInode blockNum - num <- writePartOfBlock da blockOffset buffer buffOffset numBytes - return num - --- ------------------------------------------------------------ --- * Helpers (Rithmatic) --- ------------------------------------------------------------ - --- |Compute the start positions, lengths, and buffer offset for a read --- call. This takes into account the size of the buffer. -seekPositions :: INLong -- ^Start position - -> INInt -- ^Length to read - -> [(INLong -- positions - ,INInt -- sizes - ,INInt)] -- total amount read at end of read -seekPositions startPos len = seekPositions' startPos len 0 - -seekPositions' :: INLong -- Start position - -> INInt -- Length to read - -> INInt -- amount read so far - -> [(INLong -- positions - ,INInt -- sizes - ,INInt)] -- total amount read at end of read -seekPositions' startPos len soFar = - let bytesPerBlock' = intToINLong bytesPerBlock - (thisBlockSize::Int) = fromIntegral'' $ -- safe due to 'mod' - if startPos < bytesPerBlock' - then bytesPerBlock' - startPos - else bytesPerBlock' - - (startPos `mod` bytesPerBlock') - in if len <= intToINInt thisBlockSize - then [(startPos,len, soFar)] -- base case - else let newPos = startPos + (intToINLong thisBlockSize) - newLen = len - (intToINInt thisBlockSize) - newSoFar = soFar + (intToINInt thisBlockSize) - in (startPos, intToINInt thisBlockSize, soFar) - :seekPositions' newPos newLen newSoFar - -allocateInodeWrite :: FSWrite INInt -allocateInodeWrite = do fsr <- Halfs.FSState.get - let (a,b) = allocateInode fsr - Halfs.FSState.put b - return a --- ------------------------------------------------------------ --- * Directory stuff --- ------------------------------------------------------------ - --- |Builds a brand-new, almost-empty directory. -newDirectory :: INInt -- ^inode number - -> Directory -newDirectory inodeNum = - -- not really open, so mode doesn't matter - let fhDirectory = fileHandle' inodeNum 0 ReadMode - in Directory fhDirectory (Map.fromList [(".", inodeNum)]) True - --- |This file will always be less than INInt, not INLong. FIX: Is this --- true? If not, we'll have to read it in chunks. -readFileFromInode :: (BinHandle -> FSRead a) -> Inode -> FSRead a -readFileFromInode f Inode{metaData=InodeMetadata{num_bytes=theSize - ,inode_num=inodeNum}} = do - let theFileHandle = fileHandle inodeNum ReadMode - buffer <- openBinMemRW $ fromIntegral'' (assert (theSize > 0) theSize) - readOutput <- fhRead theFileHandle buffer 0 (fromIntegral'' theSize) - resetBinRW buffer - assert (justSame (fromIntegral'' theSize) readOutput) (f buffer) - --- | Reads a directory from the given inode. -readDirectory :: Inode - -> FSRead Directory -readDirectory inode@Inode{metaData=InodeMetadata{inode_num=inN}} = do - FSRoot{directoryCache=c} <- unsafeReadGet - case getDirectoryFromCache c inN of - Nothing -> do m <- readFileFromInode readDirectoryBin inode - let d = Directory (fileHandle inN WriteMode) m True - unsafeModifyFSRead (\fsroot - -> ((fsRootUpdateDirectoryCache d fsroot), ())) - return d - Just d -> return d - --- |fetch the inode out of the root directory -readRootDir :: FSRead Directory -readRootDir = do - fsroot <- unsafeReadGet - let inode = fsRootRootDirInode fsroot - readDirectory inode - --- |FIX: are we actually freeing the inode? -unlink :: Directory - -> String -- file to unlink - -> FSWrite Directory -unlink dir@(Directory _ contents _) unlinkMe - = case Map.lookup unlinkMe contents of - Nothing -> throwError $ doesNotExistEx unlinkMe - Just num -> do inode <- getInodeWrite num Nothing - let f = if (hard_links $ metaData inode) <= 1 - then fsRootFreeInode --also takes care of dir cache. - else decLinksForInode - f inode - -- FIX: Should we not return dir? - let dir' = removeChild dir unlinkMe - modify (fsRootUpdateDirectoryCache dir') - return dir' - --- |Build a directory out of this FilePath. -getDirectoryAtPath :: FilePath - -> FSRead Directory -getDirectoryAtPath path = do - getSomethingAtPath (\i@Inode{metaData=InodeMetadata{mode=inM}} - -> case assert (goodInodeMagic i) inM of - Dir -> readDirectory i - File -> throwError (userError - ("file encountered where directory expected")) - SymLink -> unimplemented "Symlinks") - path - --- |Higher level function for turning a path into an object. Uses --- getInodeAtPath (mutually-recursive with getDirectoryAtPath) to get --- this inode, and build something out of it. WARNING: the inode --- returned may be an invalid inode. Caller is responsible for --- initializing it if it's possibly invalid. - -getSomethingAtPath :: (Inode -> FSRead a) - -> FilePath - -> FSRead a -getSomethingAtPath f path = do - inode <- getInodeAtPath path - f (assert (goodInodeMagic inode) inode) - --- |FIX: this is in the read monad, but it'll let you make a write --- handle if you ask for one. The FileHandle type is not opaque so --- that's OK! Should work for files or directories! -openFileAtPath :: FilePath - -> FileMode - -> FSRead FileHandle -openFileAtPath path fMode = do - Inode{metaData=InodeMetadata{inode_num=n}} <- getInodeAtPath path - return $ fileHandle n fMode - --- |Uses getDirectoryAtPath (mutually recursive) to traverse down a --- directory hierarchy to get the contents of the parent of this --- filepath and fetch the inode from there. WARNING: the inode --- returned may be an invalid inode. Caller is responsible for --- initializing it if it's possibly invalid. -getInodeAtPath :: FilePath - -> FSRead Inode -getInodeAtPath "" = error "getDirectoryAt: empty string" -getInodeAtPath "/" = readRootDir >>= fhInode . dirFile -getInodeAtPath ('.':'/':p) = getInodeAtPath ('/':p) -- FIX: this is a horrid hack -getInodeAtPath ('.':p) = getInodeAtPath ('/':p) -- FIX: remove when we have relative paths -getInodeAtPath dirPath = do - unless (head dirPath == '/') - (error $ "FIX: non-absolute path encountered: " ++ (show dirPath)) - let (parentDir, dirName) = splitFileName dirPath - d <- getDirectoryAtPath parentDir - case getChildWithName d dirName of - Nothing -> throwError (doesNotExistEx dirPath) - Just n -> getInodeRead n Nothing - -doesPathExist :: FilePath -> FSRead Bool -doesPathExist path = do - catchError (do _ <- getInodeAtPath path -- FIX: will laziness hurt here? - return True) - (\e -> if isDoesNotExistError e - then return False - else throwError e) - --- ------------------------------------------------------------ --- * Files With Names --- ------------------------------------------------------------ - --- |Might fail if parent doesn't exist. FIX: talk to dylan about --- special cases here handled in the java code. - --- openFileForWrite :: FSRoot -> FilePath -> IO (Maybe FileHandle) --- openFileForWrite fsroot path = do --- mInode <- getInodeAtPath fsroot path --- case mInode of --- Nothing -> --- return $ Just $ FileHandle inode 0 WriteMode - --- ------------------------------------------------------------ --- * Tests --- ------------------------------------------------------------ - -unitTests :: UnitTests -unitTests = hunitToUnitTest hunitTests - -hunitTests :: [Test] -hunitTests - = let bs = (intToINInt bytesPerBlock)::INInt - bs' = (intToINLong bytesPerBlock)::INLong - in [test - ["less than buffSize" ~: [(0,10, 0)] ~=? seekPositions 0 10 - ,"just at buffsize" ~: [(0, bs, 0)] ~=? seekPositions 0 bs - ,"just over buffsize" ~: [(0, bs, 0), (bs', 1, bs)] - ~=? seekPositions 0 (bs+1) - ,"non-zero start point" ~: [(1, 10,0)] ~=? seekPositions 1 10 - ,"slop on both sides" ~: [(10, bs - 10, 0) - ,(bs', bs, bs-10) - ,(bs'*2, 10, 2*bs-10)] - ~=? seekPositions 10 (bs * 2) - ]] - --- a good quickecheck test would be to add up all the sizes and see if --- they equal the length. - --- |For assertion checking -justSame :: (Eq a) => a -> (b, a) -> Bool -justSame r (_, numRead) = r == numRead diff --git a/Halfs/FileHandle.hs-boot b/Halfs/FileHandle.hs-boot deleted file mode 100644 --- a/Halfs/FileHandle.hs-boot +++ /dev/null @@ -1,11 +0,0 @@ -module Halfs.FileHandle where - -import Data.Integral - -data FileMode = ReadMode | WriteMode | AppendMode - -data FileHandle - = FileHandle {fhInodeNum :: INInt - ,fhSeekPos :: INLong - ,fhMode :: FileMode - } diff --git a/Halfs/HalfsState.hs b/Halfs/HalfsState.hs new file mode 100644 --- /dev/null +++ b/Halfs/HalfsState.hs @@ -0,0 +1,50 @@ +-- Contains HalfsState, the "global" data structure for tracking +-- filesystem state. + +module Halfs.HalfsState + ( + HalfsState(..) + ) + where + +import Data.Map as M +import Data.Word + +import Halfs.BlockMap (BlockMap) +import Halfs.Errors (HalfsError) +import Halfs.Monad (HalfsT) +import Halfs.Protection (UserID, GroupID) +import Halfs.SuperBlock (SuperBlock) +import Halfs.Types (DirHandle, FileHandle, InodeRef, LockedRscRef) + +import System.Device.BlockDevice (BlockDevice) + +type HalfsM b r l m a = HalfsT HalfsError (Maybe (HalfsState b r l m)) m a +type FHMapVal b r l m = (FileHandle r l, Word64, HalfsM b r l m ()) + +data HalfsState b r l m = HalfsState { + hsBlockDev :: BlockDevice m + , hsUserID :: UserID + , hsGroupID :: GroupID + , hsLogger :: Maybe (String -> m ()) + , hsSizes :: (Word64, Word64, Word64, Word64) + -- ^ explicitly memoized Inode.computeSizes + , hsBlockMap :: BlockMap b r l + , hsSuperBlock :: r SuperBlock + , hsLock :: l + , hsNumFileNodes :: LockedRscRef l r Word64 + , hsDHMap :: LockedRscRef l r (M.Map InodeRef (DirHandle r l)) + -- ^ Tracks active directory handles; we probably want to add a + -- (refcounting?) expiry mechanism so that the size of the map is + -- bounded. TODO. + , hsFHMap :: LockedRscRef l r (M.Map InodeRef (FHMapVal b r l m)) + -- ^ Tracks active file handles, their open counts, and an + -- on-final-close hook. This last monadic action is executed + -- whenever the open count becomes 0 (we do this because, e.g., + -- unlinking files can cause deferred resource allocation for + -- currently-open files). + + , hsInodeLockMap :: LockedRscRef l r (M.Map InodeRef (l, Word64)) + -- ^ Tracks refcnt'd inode locks. For now, these are single reader/writer + -- locks. + } diff --git a/Halfs/Inode.hs b/Halfs/Inode.hs --- a/Halfs/Inode.hs +++ b/Halfs/Inode.hs @@ -1,245 +1,1339 @@ ------------------------------------------------------------------------------ --- | --- Module : Halfs.Inode --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : GHC --- --- Explanation: Represents inodes in the system. --- --- The root inode is a file containing all of the inodes in the --- system. This file never shrinks. - -module Halfs.Inode (Inode(..), InodeBlock, InodeMetadata(..) - ,newFSRootInode, newFSBlockMapInode, newFSRootDirInode - ,newFSInodeMapInode, dupInode - ,rootInodeDiskAddr, firstFreeInodeDiskAddr - ,getPointerAt, updatePointers, isRootDirInode - ,goodInodeMagic, inodeBumpSize, newInode, inodeAddLink) - where - -import Binary(Binary(..), Bin(..),tellBin,seekBin) -import Halfs.Utils hiding (bytesPerBlock) -import qualified Halfs.Utils (bytesPerBlock) -import Data.Integral -import Data.Array(listArray, (!), (//), elems) -import Control.Exception(assert) - -bytesPerBlock :: INLong -bytesPerBlock = intToINLong Halfs.Utils.bytesPerBlock - -data Inode - = Inode - { - metaData :: InodeMetadata - ,blockPtrs :: INPointers -- 16 pointers @ 32 bits each - } deriving (Show, Eq) - --- |Must be length 16 -type InodeBlock = [Inode] - -updatePointers :: Inode -> [(Int, INInt)] -> Inode -updatePointers inode@Inode{blockPtrs=ptrs} updatedPtrs - = inode{blockPtrs=ptrs // (assert ((length (filter (\(x,_) -> - x >= blockPointersPerInode) - updatedPtrs)) - == 0) - updatedPtrs)} - --- |Copy the important bits of this inode, bit not all of them; , --- leave the inode number alone, but copy everthing else. -dupInode :: Inode -- ^Source inode - -> Inode -- ^Copy to here - -> Inode -- ^Resulting inode -dupInode fromI@Inode{metaData=fromMD} _toI@Inode{metaData=toMD} - = fromI{metaData=fromMD{magic1 =magic1 toMD - ,inode_num=inode_num toMD - } - } - -newFSRootInode :: Inode -newFSRootInode = let tempInode1 = newInode rootInodeNum File - tempInode = tempInode1{metaData=(metaData tempInode1) - {magic1=rootInodeMagicNum}} - in - inodeBumpSize (updatePointers tempInode [(0, rootInodeDiskAddr), - (1, rootInodeDiskAddr + 1)]) - (bytesPerBlock * 2) - --- See notes about the block map in TheBlockMap.hs. Block map --- filesize never changes. -newFSBlockMapInode :: Inode -newFSBlockMapInode = inodeBumpSize (updatePointers (newInode blockMapInodeNum File) - [(0,blockMapInodeDiskAddr)]) - bytesPerBlock - -newFSInodeMapInode :: Inode -newFSInodeMapInode = inodeBumpSize (updatePointers (newInode inodeMapInodeNum File) - [(0, inodeMapInodeDiskAddr)]) - bytesPerBlock - -newFSRootDirInode :: Inode -newFSRootDirInode = inodeBumpSize (updatePointers (newInode rootDirInodeNum Dir) - [(0, rootDirInodeDiskAddr)]) - bytesPerBlock - -goodInodeMagic :: Inode -> Bool -goodInodeMagic Inode{metaData=InodeMetadata{magic1=magicNum - ,inode_num=num}} - = if num == rootInodeNum - then magicNum == rootInodeMagicNum - else magicNum == otherInodeMagicNum - --- |Is this the rootDir inode? -isRootDirInode :: Inode -> Bool -isRootDirInode Inode{metaData=InodeMetadata{inode_num=inodeNum}} - = inodeNum == rootDirInodeNum - --- |Create a new inode based on this inode number -newInode :: INInt -> FileType -> Inode -newInode num filetype - = let inodeMD = InodeMetadata otherInodeMagicNum 0 0 0 - filetype - num -- inode number - 0 0 0 0 -- so far unused - 1 -- level - in Inode inodeMD (listArray (0, blockPointersPerInode - 1) - (replicate blockPointersPerInode 0)) - --- |Increase the size of this inode, cannot decrease it! -inodeBumpSize :: Inode - -> INLong -- ^size in bytes - -> Inode -inodeBumpSize inode@(Inode md _) newSize = - inode{metaData=md{num_bytes=max (num_bytes md) newSize}} - -inodeAddLink :: Inode -> Inode -inodeAddLink i@Inode{metaData=md@InodeMetadata{hard_links=hl}} - = i{metaData=md{hard_links=hl+1}} - --- |Get the block pointer from this inode array. -getPointerAt :: Inode -> BlockNumber -> INInt -getPointerAt inode blockNumber = - (blockPtrs inode) ! - (assert (blockNumber < intToINInt blockPointersPerInode - && blockNumber >= 0) - (inIntToInt blockNumber)) - -rootInodeDiskAddr :: INInt -rootInodeDiskAddr = 0 - -firstFreeInodeDiskAddr :: INInt -firstFreeInodeDiskAddr = rootDirInodeDiskAddr + 1 - --- For internal use only; they may change after newfs. - -blockMapInodeDiskAddr :: INInt -blockMapInodeDiskAddr = 2 - -inodeMapInodeDiskAddr :: INInt -inodeMapInodeDiskAddr = 3 - -rootDirInodeDiskAddr :: INInt -rootDirInodeDiskAddr = 4 - --- ------------------------------------------------------------ --- * INodeMetaData --- ------------------------------------------------------------ - -data InodeMetadata - = InodeMetadata - { - magic1 :: INInt - ,num_bytes :: INLong - ,uid :: INInt - ,gid :: INInt - ,mode :: FileType -- ^ file or dir - ,inode_num :: INInt - ,flags :: INInt - ,hard_links :: INInt -- ^persistent references - ,create_time :: INLong - ,last_modified_time :: INLong - ,level :: INInt -- sum to here: 56 bytes - } deriving Eq - -instance Show InodeMetadata where - show i - = "\n-----\n" - ++ printField x "magic1" magic1 - ++ printField s' "num_bytes" num_bytes - ++ printField s "uid" uid - ++ printField s "gid" gid - ++ printField show "mode" mode - ++ printField s "inode_num" inode_num - ++ printField s "flags" flags - ++ printField s "hard_links" hard_links - ++ printField s' "create_time" create_time - ++ printField s' "last_modified_time" last_modified_time - ++ printField s "level" level - ++ "-----\n" - where - x = myShowHex - s = show - s' = show - printField :: (Show a) => (a -> String) - -> String -- ^label - -> (InodeMetadata -> a) - -> String - printField shower lab f - = lab ++ ": " ++ (shower $ f i) ++ "\n" - - --- ------------------------------------------------------------ --- * Binary representation of the Inodes --- ------------------------------------------------------------ - -instance Binary Inode where - put_ h inode = do - (BinPtr start) <- tellBin h - put_ h (metaData inode) - sequence_ [ put_ h ptr | ptr <- elems $ blockPtrs inode] - seekBin h (BinPtr (start + bytesPerInode)) - return () - get h = do - (BinPtr start) <- tellBin h - meta <- get h - ptrs <- sequence [ get h | _ <- take 16 [1..blockPointersPerInode] ] - seekBin h (BinPtr (start + bytesPerInode)) - return $ Inode { metaData = meta - , blockPtrs = listArray (0, blockPointersPerInode - 1) $ ptrs - } - -instance Binary InodeMetadata where - put_ h a = do - put_ h (magic1 a) - put_ h (num_bytes a) - put_ h (uid a) - put_ h (gid a) - put_ h (mode a) - put_ h (inode_num a) - put_ h (flags a) - put_ h (hard_links a) - put_ h (create_time a) - put_ h (last_modified_time a) - put_ h (level a) - -- add assert about size - return () - - get h = do magic1' <- get h - num_bytes' <- get h - uid' <- get h - gid' <- get h - mode' <- get h - inode_num' <- get h - flags' <- get h - hard_links' <- get h - create_time' <- get h - last_modified' <- get h - level' <- get h - -- add assert about size - return $ InodeMetadata magic1' num_bytes' uid' - gid' mode' inode_num' flags' - hard_links' create_time' last_modified' level' - - +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, BangPatterns #-} +module Halfs.Inode + ( + InodeRef(..) + , blockAddrToInodeRef + , buildEmptyInodeEnc + , decLinkCount + , fileStat + , incLinkCount + , inodeKey + , inodeRefToBlockAddr + , isNilIR + , nilIR + , readStream + , writeStream + -- * for internal use only! + , atomicModifyInode + , atomicReadInode + , bsReplicate + , drefInode + , expandExts -- for use by fsck + , fileStat_lckd + , freeInode + , withLockedInode + , writeStream_lckd + -- * for testing: ought not be used by actual clients of this module! + , Inode(..) + , Ext(..) + , ExtRef(..) + , bsDrop + , bsTake + , computeMinimalInodeSize + , computeNumAddrs + , computeNumInodeAddrsM + , computeNumExtAddrsM + , computeSizes + , decodeExt + , decodeInode + , minimalExtSize + , minInodeBlocks + , minExtBlocks + , nilER + , safeToInt + , truncSentinel + ) + where + +import Control.Exception +import Data.ByteString(ByteString) +import qualified Data.ByteString as BS +import Data.Char +import Data.List (genericDrop, genericLength, genericTake) +import Data.Serialize +import qualified Data.Serialize.Get as G +import Data.Word + +import Halfs.BlockMap (BlockMap) +import qualified Halfs.BlockMap as BM +import Halfs.Classes +import Halfs.Errors +import Halfs.HalfsState +import Halfs.Protection +import Halfs.Monad +import Halfs.MonadUtils +import Halfs.Types +import Halfs.Utils + +import System.Device.BlockDevice + +-- import System.IO.Unsafe (unsafePerformIO) +dbug :: String -> a -> a +-- dbug = seq . unsafePerformIO . putStrLn +dbug _ = id +dbugM :: Monad m => String -> m () +--dbugM s = dbug s $ return () +dbugM _ = return () + +type HalfsM b r l m a = HalfsT HalfsError (Maybe (HalfsState b r l m)) m a + +-------------------------------------------------------------------------------- +-- Inode/Ext constructors, geometry calculation, and helpful constructors + +type StreamIdx = (Word64, Word64, Word64) + +-- | Obtain a 64 bit "key" for an inode; useful for building maps etc. +-- For now, this is the same as inodeRefToBlockAddr, but clients should +-- be using this function rather than inodeRefToBlockAddr in case the +-- underlying inode representation changes. +inodeKey :: InodeRef -> Word64 +inodeKey = inodeRefToBlockAddr + +-- | Convert a disk block address into an Inode reference. +blockAddrToInodeRef :: Word64 -> InodeRef +blockAddrToInodeRef = IR + +-- | Convert an inode reference into a block address +inodeRefToBlockAddr :: InodeRef -> Word64 +inodeRefToBlockAddr = unIR + +-- | The nil Inode reference. With the current Word64 representation and the +-- block layout assumptions, block 0 is the superblock, and thus an invalid +-- Inode reference. +nilIR :: InodeRef +nilIR = IR 0 + +isNilIR :: InodeRef -> Bool +isNilIR = (==) nilIR + +-- | The nil Ext reference. With the current Word64 representation and +-- the block layout assumptions, block 0 is the superblock, and thus an +-- invalid Ext reference. +nilER :: ExtRef +nilER = ER 0 + +isNilER :: ExtRef -> Bool +isNilER = (==) nilER + +-- | The sentinel byte written to partial blocks when doing truncating writes +truncSentinel :: Word8 +truncSentinel = 0xBA + +-- | The sentinel byte written to the padded region at the end of Inodes/Exts +padSentinel :: Word8 +padSentinel = 0xAD + +-- We semi-arbitrarily state that an Inode must be capable of maintaining a +-- minimum of 35 block addresses in its embedded Ext while the Ext must be +-- capable of maintaining 57 block addresses. These values, together with +-- specific padding values for inodes and exts (4 and 0, respectively), give us +-- a minimum inode AND ext size of 512 bytes each (in the IO monad variant, +-- which uses the our Serialize instance for the UTCTime when writing the time +-- fields). +-- +-- These can be adjusted as needed according to inode metadata sizes, but it's +-- very important that (computeMinimalInodeSize =<< getTime) and minimalExtSize yield +-- the same value! + +-- | The size, in bytes, of the padding region at the end of Inodes +iPadSize :: Int +iPadSize = 4 + +-- | The size, in bytes, of the padding region at the end of Exts +cPadSize :: Int +cPadSize = 0 + +minInodeBlocks :: Word64 +minInodeBlocks = 35 + +minExtBlocks :: Word64 +minExtBlocks = 57 + +-- | The structure of an Inode. Pretty standard, except that we use the Ext +-- structure (the first of which is embedded in the inode) to hold block +-- references and use its ext field to allow multiple runs of block +-- addresses. +data Inode t = Inode + { inoParent :: InodeRef -- ^ block addr of parent directory + -- inode: This is nilIR for the + -- root directory inode + + , inoLastExt :: (ExtRef, Word64) -- ^ The last-accessed ER and its ext + -- idx. For the "faster end-of-stream + -- access" hack. + -- begin fstat metadata + , inoAddress :: InodeRef -- ^ block addr of this inode + , inoFileSize :: Word64 -- ^ in bytes + , inoAllocBlocks :: Word64 -- ^ number of blocks allocated to this inode + -- (includes its own allocated block, blocks + -- allocated for Exts, and and all blocks in + -- the ext chain itself) + , inoFileType :: FileType + , inoMode :: FileMode + , inoNumLinks :: Word64 -- ^ number of hardlinks to this inode + , inoCreateTime :: t -- ^ time of creation + , inoModifyTime :: t -- ^ time of last data modification + , inoAccessTime :: t -- ^ time of last data access + , inoChangeTime :: t -- ^ time of last change to inode data + , inoUser :: UserID -- ^ userid of inode's owner + , inoGroup :: GroupID -- ^ groupid of inode's owner + -- end fstat metadata + + , inoExt :: Ext -- The "embedded" inode extension ("ext") + } + deriving (Show, Eq) + +-- An "Inode extension" datatype +data Ext = Ext + { address :: ExtRef -- ^ Address of this Ext (nilER for an + -- inode's embedded Ext) + , nextExt :: ExtRef -- ^ Next Ext in the chain; nilER terminates + , blockCount :: Word64 + , blockAddrs :: [Word64] -- ^ references to blocks governed by this Ext + + -- Fields below here are not persisted, and are populated via decodeExt + + , numAddrs :: Word64 -- ^ Maximum number of blocks addressable by *this* + -- Ext. NB: Does not include blocks further down + -- the chain. + } + deriving (Show, Eq) + +-- | Size of a minimal inode structure when serialized, in bytes. This will +-- vary based on the space required for type t when serialized. Note that +-- minimal inode structure always contains minInodeBlocks InodeRefs in +-- its blocks region. +-- +-- You can check this value interactively in ghci by doing, e.g. +-- computeMinimalInodeSize =<< (getTime :: IO UTCTime) +computeMinimalInodeSize :: (Monad m, Ord t, Serialize t, Show t) => + t -> m Word64 +computeMinimalInodeSize t = do + return $ fromIntegral $ BS.length $ encode $ + let e = emptyInode minInodeBlocks t RegularFile (FileMode [] [] []) + nilIR nilIR rootUser rootGroup + c = inoExt e + in e{ inoExt = c{ blockAddrs = replicate (safeToInt minInodeBlocks) 0 } } + +-- | The size of a minimal Ext structure when serialized, in bytes. +minimalExtSize :: Monad m => m (Word64) +minimalExtSize = return $ fromIntegral $ BS.length $ encode $ + (emptyExt minExtBlocks nilER){ + blockAddrs = replicate (safeToInt minExtBlocks) 0 + } + +-- | Computes the number of block addresses storable by an inode/ext +computeNumAddrs :: Monad m => + Word64 -- ^ block size, in bytes + -> Word64 -- ^ minimum number of blocks for inode/ext + -> Word64 -- ^ minimum inode/ext total size, in bytes + -> m Word64 +computeNumAddrs blkSz minBlocks minSize = do + unless (minSize <= blkSz) $ + fail "computeNumAddrs: Block size too small to accomodate minimal inode" + let + -- # bytes required for the blocks region of the minimal inode + padding = minBlocks * refSize + -- # bytes of the inode excluding the blocks region + notBlocksSize = minSize - padding + -- # bytes available for storing the blocks region + blkSz' = blkSz - notBlocksSize + unless (0 == blkSz' `mod` refSize) $ + fail "computeNumAddrs: Inexplicably bad block size" + return $ blkSz' `div` refSize + +computeNumInodeAddrsM :: (Serialize t, Timed t m, Show t) => + Word64 -> m Word64 +computeNumInodeAddrsM blkSz = + computeNumAddrs blkSz minInodeBlocks =<< computeMinimalInodeSize =<< getTime + +computeNumExtAddrsM :: (Serialize t, Timed t m) => + Word64 -> m Word64 +computeNumExtAddrsM blkSz = do + minSize <- minimalExtSize + computeNumAddrs blkSz minExtBlocks minSize + +computeSizes :: (Serialize t, Timed t m, Show t) => + Word64 + -> m ( Word64 -- #inode bytes + , Word64 -- #ext bytes + , Word64 -- #inode addrs + , Word64 -- #ext addrs + ) +computeSizes blkSz = do + startExtAddrs <- computeNumInodeAddrsM blkSz + extAddrs <- computeNumExtAddrsM blkSz + return (startExtAddrs * blkSz, extAddrs * blkSz, startExtAddrs, extAddrs) + +-- Builds and encodes an empty inode +buildEmptyInodeEnc :: (Serialize t, Timed t m, Show t) => + BlockDevice m -- ^ The block device + -> FileType -- ^ This inode's filetype + -> FileMode -- ^ This inode's access mode + -> InodeRef -- ^ This inode's block address + -> InodeRef -- ^ Parent's block address + -> UserID + -> GroupID + -> m ByteString +buildEmptyInodeEnc bd ftype fmode me mommy usr grp = + liftM encode $ buildEmptyInode bd ftype fmode me mommy usr grp + +buildEmptyInode :: (Serialize t, Timed t m, Show t) => + BlockDevice m + -> FileType -- ^ This inode's filetype + -> FileMode -- ^ This inode's access mode + -> InodeRef -- ^ This inode's block address + -> InodeRef -- ^ Parent block's address + -> UserID -- ^ This inode's owner's userid + -> GroupID -- ^ This inode's owner's groupid + -> m (Inode t) +buildEmptyInode bd ftype fmode me mommy usr grp = do + now <- getTime + minSize <- computeMinimalInodeSize =<< return now + + minimalExtSize >>= (`assert` return ()) . (==) minSize + + nAddrs <- computeNumAddrs (bdBlockSize bd) minInodeBlocks minSize + return $ emptyInode nAddrs now ftype fmode me mommy usr grp + +emptyInode :: (Ord t, Serialize t) => + Word64 -- ^ number of block addresses + -> t -- ^ creation timestamp + -> FileType -- ^ inode's filetype + -> FileMode -- ^ inode's access mode + -> InodeRef -- ^ block addr for this inode + -> InodeRef -- ^ parent block address + -> UserID + -> GroupID + -> Inode t +emptyInode nAddrs now ftype fmode me mommy usr grp = + Inode + { inoParent = mommy + , inoLastExt = (nilER, 0) + , inoAddress = me + , inoFileSize = 0 + , inoAllocBlocks = 1 + , inoFileType = ftype + , inoMode = fmode + , inoNumLinks = 1 + , inoCreateTime = now + , inoModifyTime = now + , inoAccessTime = now + , inoChangeTime = now + , inoUser = usr + , inoGroup = grp + , inoExt = emptyExt nAddrs nilER + } + +buildEmptyExt :: (Serialize t, Timed t m) => + BlockDevice m -- ^ The block device + -> ExtRef -- ^ This ext's block address + -> m Ext +buildEmptyExt bd me = do + minSize <- minimalExtSize + nAddrs <- computeNumAddrs (bdBlockSize bd) minExtBlocks minSize + return $ emptyExt nAddrs me + +emptyExt :: Word64 -- ^ number of block addresses + -> ExtRef -- ^ block addr for this ext + -> Ext +emptyExt nAddrs me = + Ext + { address = me + , nextExt = nilER + , blockCount = 0 + , blockAddrs = [] + , numAddrs = nAddrs + } + + +-------------------------------------------------------------------------------- +-- Inode stream functions + +-- | Provides a stream over the bytes governed by a given Inode and its +-- extensions (exts). This function performs a write to update inode metadata +-- (e.g., access time). +readStream :: HalfsCapable b t r l m => + InodeRef -- ^ Starting inode reference + -> Word64 -- ^ Starting stream (byte) offset + -> Maybe Word64 -- ^ Stream length (Nothing => read + -- until end of stream, including + -- entire last block) + -> HalfsM b r l m ByteString -- ^ Stream contents +readStream startIR start mlen = do + withLockedInode startIR $ do + -- ====================== Begin inode critical section ====================== + dev <- hasks hsBlockDev + startInode <- drefInode startIR + let bs = bdBlockSize dev + readB c b = lift $ readBlock dev c b + fileSz = inoFileSize startInode + gsi = getStreamIdx (bdBlockSize dev) fileSz + + if 0 == blockCount (inoExt startInode) + then return BS.empty + else do + dbug ("==== readStream begin ===") $ do + (sExtI, sBlkOff, sByteOff) <- gsi start + sExt <- findExt startInode sExtI + (eExtI, _, _) <- gsi $ case mlen of + Nothing -> fileSz - 1 + Just len -> start + len - 1 + + dbug ("start = " ++ show start) $ do + dbug ("(sExtI, sBlkOff, sByteOff) = " ++ show (sExtI, sBlkOff, sByteOff)) $ do + dbug ("eExtI = " ++ show eExtI) $ do + + rslt <- case mlen of + Just len | len == 0 -> return BS.empty + _ -> do + assert (maybe True (> 0) mlen) $ return () + + -- 'hdr' is the (possibly partial) first block + hdr <- bsDrop sByteOff `fmap` readB sExt sBlkOff + + -- 'rest' is the list of block-sized bytestrings containing the + -- requested content from blocks in subsequent conts, accounting for + -- the (Maybe) maximum length requested. + rest <- do + let hdrLen = fromIntegral (BS.length hdr) + totalToRead = maybe (fileSz - start) id mlen + -- + howManyBlks ext bsf blkOff = + let bc = blockCount ext - blkOff + in + maybe bc (\len -> min bc ((len - bsf) `divCeil` bs)) mlen + -- + readExt (_, [], _) = error "The impossible happened" + readExt ((cExt, cExtI), blkOff:boffs, bytesSoFar) + | cExtI > eExtI = + assert (bytesSoFar >= totalToRead) $ return Nothing + | bytesSoFar >= totalToRead = + return Nothing + | otherwise = do + let remBlks = howManyBlks cExt bytesSoFar blkOff + range = if remBlks > 0 + then [blkOff .. blkOff + remBlks - 1] + else [] + + theData <- BS.concat `fmap` mapM (readB cExt) range + assert (fromIntegral (BS.length theData) == remBlks * bs) $ return () + + let rslt c = return $ Just $ + ( theData -- accumulated by unfoldr + , ( (c, cExtI+1) + , boffs + , bytesSoFar + remBlks * bs + ) + ) + if isNilER (nextExt cExt) + then rslt (error "Ext DNE and expected termination!") + else rslt =<< drefExt (nextExt cExt) + + -- ==> Bulk reading starts here <== + if (sBlkOff + 1 < blockCount sExt || sExtI < eExtI) + then unfoldrM readExt ((sExt, sExtI), (sBlkOff+1):repeat 0, hdrLen) + else return [] + + return $ bsTake (maybe (fileSz - start) id mlen) $ + hdr `BS.append` BS.concat rest + + now <- getTime + lift $ writeInode dev $ + startInode { inoAccessTime = now, inoChangeTime = now } + dbug ("==== readStream end ===") $ return () + return rslt + -- ======================= End inode critical section ======================= + +-- | Writes to the inode stream at the given starting inode and starting byte +-- offset, overwriting data and allocating new space on disk as needed. If the +-- write is a truncating write, all resources after the end of the written data +-- are freed. Whenever the data to be written exceeds the the end of the +-- stream, the trunc flag is ignored. +writeStream :: HalfsCapable b t r l m => + InodeRef -- ^ Starting inode ref + -> Word64 -- ^ Starting stream (byte) offset + -> Bool -- ^ Truncating write? + -> ByteString -- ^ Data to write + -> HalfsM b r l m () +writeStream _ _ False bytes | 0 == BS.length bytes = return () +writeStream startIR start trunc bytes = do + withLockedInode startIR $ writeStream_lckd startIR start trunc bytes + +writeStream_lckd :: HalfsCapable b t r l m => + InodeRef -- ^ Starting inode ref + -> Word64 -- ^ Starting stream (byte) offset + -> Bool -- ^ Truncating write? + -> ByteString -- ^ Data to write + -> HalfsM b r l m () +writeStream_lckd _ _ False bytes | 0 == BS.length bytes = return () +writeStream_lckd startIR start trunc bytes = do + -- ====================== Begin inode critical section ====================== + + -- NB: This implementation currently 'flattens' Contig/Discontig block groups + -- from the BlockMap allocator (see allocFill and truncUnalloc below), which + -- will force us to treat them as Discontig when we unallocate, which is more + -- expensive. We may want to have the Exts hold onto these block groups + -- directly and split/merge them as needed to reduce the number of + -- unallocation actions required, but we leave this as a TODO for now. + + startInode@Inode{ inoLastExt = lcInfo } <- drefInode startIR + dev <- hasks hsBlockDev + + let bs = bdBlockSize dev + len = fromIntegral $ BS.length bytes + fileSz = inoFileSize startInode + newFileSz = if trunc then start + len else max (start + len) fileSz + fszRndBlk = (fileSz `divCeil` bs) * bs + availBlks c = numAddrs c - blockCount c + bytesToAlloc = if newFileSz > fszRndBlk then newFileSz - fszRndBlk else 0 + blksToAlloc = bytesToAlloc `divCeil` bs + + (_, _, _, apc) <- hasks hsSizes + sIdx@(sExtI, sBlkOff, sByteOff) <- getStreamIdx bs fileSz start + sExt <- findExt startInode sExtI + lastExt <- getLastExt Nothing sExt + -- TODO: Track a ptr to this? Traversing + -- the allocated region is yucky. + let extsToAlloc = (blksToAlloc - availBlks lastExt) `divCeil` apc + + ------------------------------------------------------------------------------ + -- Debugging miscellany + + dbug ("\nwriteStream: " ++ show (sExtI, sBlkOff, sByteOff) + ++ " (start=" ++ show start ++ ")" + ++ " len = " ++ show len ++ ", trunc = " ++ show trunc + ++ ", fileSz/newFileSz = " ++ show fileSz ++ "/" ++ show newFileSz + ++ ", toAlloc(exts/blks/bytes) = " ++ show extsToAlloc ++ "/" + ++ show blksToAlloc ++ "/" ++ show bytesToAlloc) $ do +-- dbug ("inoLastExt startInode = " ++ show (lcInfo) ) $ return () +-- dbug ("inoExt startInode = " ++ show (inoExt startInode)) $ return () +-- dbug ("Exts on entry, from inode ext:") $ return () +-- dumpExts (inoExt startInode) + + ------------------------------------------------------------------------------ + -- Allocation: + + -- Allocate if needed and obtain (1) the post-alloc start ext and (2) + -- possibly a dirty ext to write back into the inode (ie, when its + -- nextExt field is modified as a result of allocation -- all other + -- modified exts are written by allocFill, but the inode write is the last + -- thing we do, so we defer the update). + + (sExt', minodeExt) <- do + if blksToAlloc == 0 + then return (sExt, Nothing) + else do + lastExt' <- allocFill availBlks blksToAlloc extsToAlloc lastExt + let st = if address lastExt' == address sExt then lastExt' else sExt + -- Our starting location remains the same, but in case of an + -- update of the start ext, we can use lastExt' instead of + -- re-reading. + lci = snd lcInfo + st' <- if lci < sExtI + then getLastExt (Just $ sExtI - lci + 1) st + -- NB: We need to start ahead of st, but couldn't adjust + -- until after we allocated. This is to catch a corner case + -- where the "start" ext coming into writeStream_lckd + -- refers to a ext that hasn't been allocated yet. + else return st + return (st', if isEmbedded st then Just st else Nothing) + +-- dbug ("sExt' = " ++ show sExt') $ return () +-- dbug ("minodeExt = " ++ show minodeExt) $ return () +-- dbug ("Exts immediately after alloc, from sExt'") $ return () +-- dumpExts (sExt') + + assert (sBlkOff < blockCount sExt') $ return () + + ------------------------------------------------------------------------------ + -- Truncation + + -- Truncate if needed and obtain (1) the new start ext at which to start + -- writing data and (2) possibly a dirty ext to write back into the inode + + (sExt'', numBlksFreed, minodeExt') <- + if trunc && bytesToAlloc == 0 + then do + (ext, nbf) <- truncUnalloc start len (sExt', sExtI) + return ( ext + , nbf + , if isEmbedded ext + then case minodeExt of + Nothing -> Just ext + Just _ -> -- This "can't happen" ... + error $ "Internal: dirty inode ext from " + ++ "both allocFill & truncUnalloc!?" + else Nothing + ) + else return (sExt', 0, minodeExt) + + assert (blksToAlloc + extsToAlloc == 0 || numBlksFreed == 0) $ return () + + ------------------------------------------------------------------------------ + -- Data streaming + + (eExtI, _, _) <- decomp (bdBlockSize dev) (bytesToEnd start len) + eExt <- getLastExt (Just $ (eExtI - sExtI) + 1) sExt'' + when (len > 0) $ writeInodeData (sIdx, sExt'') eExtI trunc bytes + + -------------------------------------------------------------------------------- + -- Inode metadata adjustments & persist + + now <- getTime + lift $ writeInode dev $ + startInode + { inoLastExt = if eExtI == sExtI + then (address sExt'', sExtI) + else (address eExt, eExtI) + , inoFileSize = newFileSz + , inoAllocBlocks = inoAllocBlocks startInode + + blksToAlloc + + extsToAlloc + - numBlksFreed + , inoAccessTime = now + , inoModifyTime = now + , inoChangeTime = now + , inoExt = maybe (inoExt startInode) id minodeExt' + } +-- ======================= End inode critical section ======================= + + +-------------------------------------------------------------------------------- +-- Inode operations + +incLinkCount :: HalfsCapable b t r l m => + InodeRef -- ^ Source inode ref + -> HalfsM b r l m () +incLinkCount inr = + atomicModifyInode inr $ \nd -> + return $ nd{ inoNumLinks = inoNumLinks nd + 1 } + +decLinkCount :: HalfsCapable b t r l m => + InodeRef -- ^ Source inode ref + -> HalfsM b r l m () +decLinkCount inr = + atomicModifyInode inr $ \nd -> + return $ nd{ inoNumLinks = inoNumLinks nd - 1 } + +-- | Atomically modifies an inode; always updates inoChangeTime, but +-- callers are responsible for other metadata modifications. +atomicModifyInode :: HalfsCapable b t r l m => + InodeRef + -> (Inode t -> HalfsM b r l m (Inode t)) + -> HalfsM b r l m () +atomicModifyInode inr f = + withLockedInode inr $ do + dev <- hasks hsBlockDev + inode <- drefInode inr + now <- getTime + inode' <- setChangeTime now `fmap` f inode + lift $ writeInode dev inode' + +atomicReadInode :: HalfsCapable b t r l m => + InodeRef + -> (Inode t -> a) + -> HalfsM b r l m a +atomicReadInode inr f = + withLockedInode inr $ f `fmap` drefInode inr + +fileStat :: HalfsCapable b t r l m => + InodeRef + -> HalfsM b r l m (FileStat t) +fileStat inr = + withLockedInode inr $ fileStat_lckd inr + +fileStat_lckd :: HalfsCapable b t r l m => + InodeRef + -> HalfsM b r l m (FileStat t) +fileStat_lckd inr = do + inode <- drefInode inr + return $ FileStat + { fsInode = inr + , fsType = inoFileType inode + , fsMode = inoMode inode + , fsNumLinks = inoNumLinks inode + , fsUID = inoUser inode + , fsGID = inoGroup inode + , fsSize = inoFileSize inode + , fsNumBlocks = inoAllocBlocks inode + , fsAccessTime = inoAccessTime inode + , fsModifyTime = inoModifyTime inode + , fsChangeTime = inoChangeTime inode + } + + +-------------------------------------------------------------------------------- +-- Inode/Ext stream helper & utility functions + +isEmbedded :: Ext -> Bool +isEmbedded = isNilER . address + +freeInode :: HalfsCapable b t r l m => + InodeRef -- ^ reference to the inode to remove + -> HalfsM b r l m () +freeInode inr@(IR addr) = + withLockedInode inr $ do + bm <- hasks hsBlockMap + start <- inoExt `fmap` drefInode inr + freeBlocks bm (blockAddrs start) + _numFreed :: Word64 <- freeExts bm start + BM.unalloc1 bm addr + +freeBlocks :: HalfsCapable b t r l m => + BlockMap b r l -> [Word64] -> HalfsM b r l m () +freeBlocks _ [] = return () +freeBlocks bm addrs = + lift $ BM.unallocBlocks bm $ BM.Discontig $ map (`BM.Extent` 1) addrs + -- NB: Freeing all of the blocks this way (as unit extents) is ugly and + -- inefficient, but we need to be tracking BlockGroups (or reconstitute them + -- here by digging for contiguous address subsequences in addrs) before we can + -- do better. + +-- | Frees all exts after the given ext, returning the number of blocks freed. +freeExts :: (HalfsCapable b t r l m, Num a) => + BlockMap b r l -> Ext -> HalfsM b r l m a +freeExts bm Ext{ nextExt = cr } + | isNilER cr = return $ fromInteger 0 + | otherwise = drefExt cr >>= extFoldM freeExt (fromInteger 0) + where + freeExt !acc c = + freeBlocks bm toFree >> return (acc + genericLength toFree) + where toFree = unER (address c) : blockAddrs c + +withLockedInode :: HalfsCapable b t r l m => + InodeRef -- ^ reference to inode to lock + -> HalfsM b r l m a -- ^ action to take while holding lock + -> HalfsM b r l m a +withLockedInode inr act = + -- Inode locking: We currently use a single reader/writer lock tracked by the + -- InodeRef -> (lock, ref count) map in HalfsState. Reference counting is used + -- to determine when it is safe to remove a lock from the map. + -- + -- We use the map to track lock info so that we don't hold locks for lengthy + -- intervals when we have access requests for disparate inode refs. + + hbracket before after (const act {- inode lock doesn't escape! -}) + + where + before = do + -- When the InodeRef is already in the map, atomically increment its + -- reference count and acquire; otherwise, create a new lock and acquire. + inodeLock <- do + lm <- hasks hsInodeLockMap + withLockedRscRef lm $ \mapRef -> do + -- begin inode lock map critical section + lockInfo <- lookupRM inr mapRef + case lockInfo of + Nothing -> do + l <- newLock + insertRM inr (l, 1) mapRef + return l + Just (l, r) -> do + insertRM inr (l, r + 1) mapRef + return l + -- end inode lock map critical section + lock inodeLock + return inodeLock + -- + after inodeLock = do + -- Atomically decrement the reference count for the InodeRef and then + -- release the lock + lm <- hasks hsInodeLockMap + withLockedRscRef lm $ \mapRef -> do + -- begin inode lock map critical section + lockInfo <- lookupRM inr mapRef + case lockInfo of + Nothing -> fail "withLockedInode internal: No InodeRef in lock map" + Just (l, r) | r == 1 -> deleteRM inr mapRef + | otherwise -> insertRM inr (l, r - 1) mapRef + -- end inode lock map critical section + release inodeLock + +-- | A wrapper around Data.Serialize.decode that populates transient fields. We +-- do this to avoid occupying valuable on-disk inode space where possible. Bare +-- applications of 'decode' should not occur when deserializing inodes! +decodeInode :: HalfsCapable b t r l m => + ByteString + -> HalfsM b r l m (Inode t) +decodeInode bs = do + (_, _, numAddrs', _) <- hasks hsSizes + case decode bs of + Left s -> throwError $ HE_DecodeFail_Inode s + Right n -> do + return n{ inoExt = (inoExt n){ numAddrs = numAddrs' } } + +-- | A wrapper around Data.Serialize.decode that populates transient fields. We +-- do this to avoid occupying valuable on-disk Ext space where possible. Bare +-- applications of 'decode' should not occur when deserializing Exts! +decodeExt :: HalfsCapable b t r l m => + Word64 + -> ByteString + -> HalfsM b r l m Ext +decodeExt blkSz bs = do + numAddrs' <- computeNumExtAddrsM blkSz + case decode bs of + Left s -> throwError $ HE_DecodeFail_Ext s + Right c -> return c{ numAddrs = numAddrs' } + +-- | Obtain the ext with the given ext index in the ext chain. +-- Currently traverses Exts from either the inode's embedded ext or +-- from the (saved) ext from the last operation, whichever is +-- closest. +findExt :: HalfsCapable b t r l m => + Inode t -> Word64 -> HalfsM b r l m Ext +findExt Inode{ inoLastExt = (ler, lci), inoExt = defExt } sci + | isNilER ler || lci > sci = getLastExt (Just $ sci + 1) defExt + | otherwise = getLastExt (Just $ sci - lci + 1) =<< drefExt ler + +-- | Allocate the given number of Exts and blocks, and fill blocks into the +-- ext chain starting at the given ext. Persists dirty exts and yields a new +-- start ext to use. +allocFill :: HalfsCapable b t r l m => + (Ext -> Word64) -- ^ Available blocks function + -> Word64 -- ^ Number of blocks to allocate + -> Word64 -- ^ Number of exts to allocate + -> Ext -- ^ Last allocated ext + -> HalfsM b r l m Ext -- ^ Updated last ext +allocFill _ 0 _ eExt = return eExt +allocFill avail blksToAlloc extsToAlloc eExt = do + dev <- hasks hsBlockDev + bm <- hasks hsBlockMap + newExts <- allocExts dev bm + blks <- allocBlocks bm + + -- Fill nextExt fields to form the region that we'll fill with the newly + -- allocated blocks (i.e., starting at the end of the already-allocated region + -- from the start ext, but including the newly allocated exts as well). + + let (_, region) = foldr (\c (er, !acc) -> + ( address c + , c{ nextExt = er } : acc + ) + ) + (nilER, []) + (eExt : newExts) + + -- "Spill" the allocated blocks into the empty region + let (blks', k) = foldl fillBlks (blks, id) region + dirtyExts@(eExt':_) = k [] + fillBlks (remBlks, k') c = + let cnt = min (safeToInt $ avail c) (length remBlks) + c' = c { blockCount = blockCount c + fromIntegral cnt + , blockAddrs = blockAddrs c ++ take cnt remBlks + } + in + (drop cnt remBlks, k' . (c':)) + + assert (null blks') $ return () + + forM_ (dirtyExts) $ \c -> unless (isEmbedded c) $ lift $ writeExt dev c + return eExt' + where + allocBlocks bm = do + -- currently "flattens" BlockGroup; see comment in writeStream + mbg <- lift $ BM.allocBlocks bm blksToAlloc + case mbg of + Nothing -> throwError HE_AllocFailed + Just bg -> return $ BM.blkRangeBG bg + -- + allocExts dev bm = + if 0 == extsToAlloc + then return [] + else do + -- TODO: Unalloc partial allocs on HE_AllocFailed? + mexts <- fmap sequence $ replicateM (safeToInt extsToAlloc) $ do + mcr <- fmap ER `fmap` BM.alloc1 bm + case mcr of + Nothing -> return Nothing + Just cr -> Just `fmap` lift (buildEmptyExt dev cr) + maybe (throwError HE_AllocFailed) (return) mexts + +-- | Truncates the stream at the given a stream index and length offset, and +-- unallocates all resources in the corresponding free region, yielding a new +-- Ext for the truncated chain. +truncUnalloc :: + HalfsCapable b t r l m => + Word64 -- ^ Starting stream byte index + -> Word64 -- ^ Length from start at which to truncate + -> (Ext, Word64) -- ^ Start ext of chain to truncate, start ext idx + -> HalfsM b r l m (Ext, Word64) + -- ^ new start ext, number of blocks freed +truncUnalloc start len (stExt, sExtI) = do + dev <- hasks hsBlockDev + bm <- hasks hsBlockMap + + (eExtI, eBlkOff, _) <- decomp (bdBlockSize dev) (bytesToEnd start len) + assert (eExtI >= sExtI) $ return () + + -- Get the (new) end of the ext chain. Retain all exts in [sExtI, eExtI]. + eExt <- getLastExt (Just $ eExtI - sExtI + 1) stExt + + let keepBlkCnt = if start + len == 0 then 0 else eBlkOff + 1 + endExtRem = genericDrop keepBlkCnt (blockAddrs eExt) + + freeBlocks bm endExtRem + numFreed <- (+ (genericLength endExtRem)) `fmap` freeExts bm eExt + + -- Currently, only eExt is considered dirty; we do *not* do any writes to any + -- of the Exts that are detached from the chain & freed (we just toss them + -- out); this may have implications for fsck. + let dirtyExts@(firstDirty:_) = + [ + -- eExt, adjusted to discard the freed blocks and clear the + -- nextExt field. + eExt { blockCount = keepBlkCnt + , blockAddrs = genericTake keepBlkCnt (blockAddrs eExt) + , nextExt = nilER + } + ] + stExt' = if sExtI == eExtI then firstDirty else stExt + + forM_ (dirtyExts) $ \c -> unless (isEmbedded c) $ lift $ writeExt dev c + return (stExt', numFreed) + +-- | Write the given bytes to the already-allocated/truncated inode data stream +-- starting at the given start indices (ext/blk/byte offsets) and ending when +-- we have traversed up (and including) to the end ext index. Assumes the +-- inode lock is held. +writeInodeData :: HalfsCapable b t r l m => + (StreamIdx, Ext) + -> Word64 + -> Bool + -> ByteString + -> HalfsM b r l m () +writeInodeData ((sExtI, sBlkOff, sByteOff), sExt) eExtI trunc bytes = do + dev <- hasks hsBlockDev + sBlk <- lift $ readBlock dev sExt sBlkOff + let bs = bdBlockSize dev + toWrite = + -- The first block-sized chunk to write is the region in the start block + -- prior to the start byte offset (header), followed by the first bytes + -- of the data. The trailer is nonempty and must be included when + -- BS.length bytes < bs. We adjust the input bytestring by this + -- first-block padding below. + let (sData, bytes') = bsSplitAt (bs - sByteOff) bytes + header = bsTake sByteOff sBlk + trailLen = sByteOff + fromIntegral (BS.length sData) + trailer = if trunc + then bsReplicate (bs - trailLen) truncSentinel + else bsDrop trailLen sBlk + fstBlk = header `BS.append` sData `BS.append` trailer + in assert (fromIntegral (BS.length fstBlk) == bs) $ + fstBlk `BS.append` bytes' + + -- The unfoldr seed is: current ext/idx, a block offset "supply", and the + -- data that remains to be written. + unfoldrM_ (fillExt dev) ((sExt, sExtI), sBlkOff : repeat 0, toWrite) + where + fillExt _ (_, [], _) = error "The impossible happened" + fillExt dev ((cExt, cExtI), blkOff:boffs, toWrite) + | cExtI > eExtI || BS.null toWrite = return Nothing + | otherwise = do + let blkAddrs = genericDrop blkOff (blockAddrs cExt) + split crs = let (cs, rems) = unzip crs in (cs, last rems) + gbc = lift . getBlockContents dev trunc + + (chunks, remBytes) <- split `fmap` unfoldrM gbc (toWrite, blkAddrs) + + assert (let lc = length chunks; lb = length blkAddrs + in lc == lb || (BS.length remBytes == 0 && lc < lb)) $ return () + + mapM_ (lift . uncurry (bdWriteBlock dev)) (blkAddrs `zip` chunks) + + if isNilER (nextExt cExt) + then assert (BS.null remBytes) $ return Nothing + else do + nextExt' <- drefExt (nextExt cExt) + return $ Just $ ((), ((nextExt', cExtI+1), boffs, remBytes)) + + +-- | Splits the input bytestring into block-sized chunks; may read from the +-- block device in order to preserve contents of blocks if needed. +getBlockContents :: + (Monad m, Functor m) => + BlockDevice m + -- ^ The block device + -> Bool + -- ^ Truncating write? (Impacts partial block retention) + -> (ByteString, [Word64]) + -- ^ Input bytestring, block addresses for each chunk (for retention) + -> m (Maybe ((ByteString, ByteString), (ByteString, [Word64]))) + -- ^ When unfolding, the collected result type here of (ByteString, + -- ByteString) is (chunk, remaining data), in case the entire input bytestring + -- is not consumed. The seed value is (bytestring for all data, block + -- addresses for each chunk). +getBlockContents _ _ (s, _) | BS.null s = return Nothing +getBlockContents _ _ (_, []) = return Nothing +getBlockContents dev trunc (s, blkAddr:blkAddrs) = do + let (newBlkData, remBytes) = bsSplitAt bs s + bs = bdBlockSize dev + if BS.null remBytes + then do + -- Last block; retain the relevant portion of its data + trailer <- + if trunc + then return $ bsReplicate bs truncSentinel + else + bsDrop (BS.length newBlkData) `fmap` bdReadBlock dev blkAddr + let rslt = bsTake bs $ newBlkData `BS.append` trailer + return $ Just ((rslt, remBytes), (remBytes, blkAddrs)) + else do + -- Full block; nothing to see here + return $ Just ((newBlkData, remBytes), (remBytes, blkAddrs)) + +-- | Reads the contents of the given exts's ith block +readBlock :: (Monad m) => + BlockDevice m + -> Ext + -> Word64 + -> m ByteString +readBlock dev c i = do + assert (i < blockCount c) $ return () + bdReadBlock dev (blockAddrs c !! safeToInt i) + +writeExt :: Monad m => + BlockDevice m -> Ext -> m () +writeExt dev c = + dbug (" ==> Writing ext: " ++ show c ) $ + bdWriteBlock dev (unER $ address c) (encode c) + +writeInode :: (Monad m, Ord t, Serialize t, Show t) => + BlockDevice m -> Inode t -> m () +writeInode dev n = bdWriteBlock dev (unIR $ inoAddress n) (encode n) + +-- | Expands the given Ext into a Ext list containing itself followed by zero +-- or more Exts; can be bounded by a positive nonzero value to only retrieve +-- (up to) the given number of exts. +expandExts :: HalfsCapable b t r l m => + Maybe Word64 -> Ext -> HalfsM b r l m [Ext] +expandExts (Just bnd) start@Ext{ nextExt = cr } + | bnd == 0 = throwError HE_InvalidExtIdx + | isNilER cr || bnd == 1 = return [start] + | otherwise = do + (start:) `fmap` (drefExt cr >>= expandExts (Just (bnd - 1))) +expandExts Nothing start@Ext{ nextExt = cr } + | isNilER cr = return [start] + | otherwise = do + (start:) `fmap` (drefExt cr >>= expandExts Nothing) + +getLastExt :: HalfsCapable b t r l m => + Maybe Word64 -> Ext -> HalfsM b r l m Ext +getLastExt mbnd c = last `fmap` expandExts mbnd c + +extFoldM :: HalfsCapable b t r l m => + (a -> Ext -> HalfsM b r l m a) -> a -> Ext -> HalfsM b r l m a +extFoldM f a c@Ext{ nextExt = cr } + | isNilER cr = f a c + | otherwise = f a c >>= \fac -> drefExt cr >>= extFoldM f fac + +extMapM :: HalfsCapable b t r l m => + (Ext -> HalfsM b r l m a) -> Ext -> HalfsM b r l m [a] +extMapM f c@Ext{ nextExt = cr } + | isNilER cr = liftM (:[]) (f c) + | otherwise = liftM2 (:) (f c) (drefExt cr >>= extMapM f) + +drefExt :: HalfsCapable b t r l m => + ExtRef -> HalfsM b r l m Ext +drefExt cr@(ER addr) | isNilER cr = throwError HE_InvalidExtIdx + | otherwise = do + dev <- hasks hsBlockDev + lift (bdReadBlock dev addr) >>= decodeExt (bdBlockSize dev) + +drefInode :: HalfsCapable b t r l m => + InodeRef -> HalfsM b r l m (Inode t) +drefInode (IR addr) = do + dev <- hasks hsBlockDev + lift (bdReadBlock dev addr) >>= decodeInode + +setChangeTime :: (Ord t, Serialize t) => t -> Inode t -> Inode t +setChangeTime t nd = nd{ inoChangeTime = t } + +-- | Decompose the given absolute byte offset into an inode's data stream into +-- Ext index (i.e., 0-based index into the ext chain), a block offset within +-- that Ext, and a byte offset within that block. +decomp :: (Serialize t, Timed t m, Monad m, Show t) => + Word64 -- ^ Block size, in bytes + -> Word64 -- ^ Offset into the data stream + -> HalfsM b r l m StreamIdx +decomp blkSz streamOff = do + -- Note that the first Ext in a Ext chain always gets embedded in an Inode, + -- and thus has differing capacity than the rest of the Exts, which are of + -- uniform size. + (stExtBytes, extBytes, _, _) <- hasks hsSizes + let (extIdx, extByteIdx) = + if streamOff >= stExtBytes + then fmapFst (+1) $ (streamOff - stExtBytes) `divMod` extBytes + else (0, streamOff) + (blkOff, byteOff) = extByteIdx `divMod` blkSz + return (extIdx, blkOff, byteOff) + +getStreamIdx :: HalfsCapable b t r l m => + Word64 -- block size in bytse + -> Word64 -- file size in bytes + -> Word64 -- start byte index + -> HalfsM b r l m StreamIdx +getStreamIdx blkSz fileSz start = do + when (start > fileSz) $ throwError $ HE_InvalidStreamIndex start + decomp blkSz start + +bytesToEnd :: Word64 -> Word64 -> Word64 +bytesToEnd start len + | start + len == 0 = 0 + | otherwise = max (start + len - 1) start + +-- "Safe" (i.e., emits runtime assertions on overflow) versions of +-- BS.{take,drop,replicate}. We want the efficiency of these functions without +-- the danger of an unguarded fromIntegral on the Word64 types we use throughout +-- this module, as this could overflow for absurdly large device geometries. We +-- may need to revisit some implementation decisions should this occur (e.g., +-- because many Prelude and Data.ByteString functions yield and take values of +-- type Int). + +safeToInt :: Integral a => a -> Int +safeToInt n = + assert (toInteger n <= toInteger (maxBound :: Int)) $ fromIntegral n + +makeSafeIntF :: Integral a => (Int -> b) -> a -> b +makeSafeIntF f n = f $ safeToInt n + +-- | "Safe" version of Data.ByteString.take +bsTake :: Integral a => a -> ByteString -> ByteString +bsTake = makeSafeIntF BS.take + +-- | "Safe" version of Data.ByteString.drop +bsDrop :: Integral a => a -> ByteString -> ByteString +bsDrop = makeSafeIntF BS.drop + +-- | "Safe" version of Data.ByteString.replicate +bsReplicate :: Integral a => a -> Word8 -> ByteString +bsReplicate = makeSafeIntF BS.replicate + +bsSplitAt :: Integral a => a -> ByteString -> (ByteString, ByteString) +bsSplitAt = makeSafeIntF BS.splitAt + + +-------------------------------------------------------------------------------- +-- Magic numbers + +magicStr :: String +magicStr = "This is a halfs Inode structure!" + +magicBytes :: [Word8] +magicBytes = assert (length magicStr == 32) $ + map (fromIntegral . ord) magicStr + +magic1, magic2, magic3, magic4 :: ByteString +magic1 = BS.pack $ take 8 $ drop 0 magicBytes +magic2 = BS.pack $ take 8 $ drop 8 magicBytes +magic3 = BS.pack $ take 8 $ drop 16 magicBytes +magic4 = BS.pack $ take 8 $ drop 24 magicBytes + +magicExtStr :: String +magicExtStr = "!!erutcurts tnoC sflah a si sihT" + +magicExtBytes :: [Word8] +magicExtBytes = assert (length magicExtStr == 32) $ + map (fromIntegral . ord) magicExtStr + +cmagic1, cmagic2, cmagic3, cmagic4 :: ByteString +cmagic1 = BS.pack $ take 8 $ drop 0 magicExtBytes +cmagic2 = BS.pack $ take 8 $ drop 8 magicExtBytes +cmagic3 = BS.pack $ take 8 $ drop 16 magicExtBytes +cmagic4 = BS.pack $ take 8 $ drop 24 magicExtBytes + +-------------------------------------------------------------------------------- +-- Typeclass instances + +instance (Show t, Eq t, Ord t, Serialize t) => Serialize (Inode t) where + put n = do + putByteString $ magic1 + + put $ inoParent n + put $ inoLastExt n + put $ inoAddress n + putWord64be $ inoFileSize n + putWord64be $ inoAllocBlocks n + put $ inoFileType n + put $ inoMode n + + putByteString $ magic2 + + putWord64be $ inoNumLinks n + put $ inoCreateTime n + put $ inoModifyTime n + put $ inoAccessTime n + put $ inoChangeTime n + put $ inoUser n + put $ inoGroup n + + putByteString $ magic3 + + put $ inoExt n + + -- NB: For Exts that are inside inodes, the Serialize instance for Ext + -- relies on only 8 + iPadSize bytes beyond this point (the inode magic + -- number and some padding). If you change this, you'll need to update the + -- related calculations in Serialize Ext's get function! + putByteString magic4 + replicateM_ iPadSize $ putWord8 padSentinel + + get = do + checkMagic magic1 + + par <- get + lcr <- get + addr <- get + fsz <- getWord64be + blks <- getWord64be + ftype <- get + fmode <- get + + checkMagic magic2 + + nlnks <- getWord64be + ctm <- get + mtm <- get + atm <- get + chtm <- get + unless (ctm <= mtm && ctm <= atm) $ + fail "Inode: Incoherent modified / creation / access times." + usr <- get + grp <- get + + checkMagic magic3 + + c <- get + + checkMagic magic4 + padding <- replicateM iPadSize $ getWord8 + assert (all (== padSentinel) padding) $ return () + + return Inode + { inoParent = par + , inoLastExt = lcr + , inoAddress = addr + , inoFileSize = fsz + , inoAllocBlocks = blks + , inoFileType = ftype + , inoMode = fmode + , inoNumLinks = nlnks + , inoCreateTime = ctm + , inoModifyTime = mtm + , inoAccessTime = atm + , inoChangeTime = chtm + , inoUser = usr + , inoGroup = grp + , inoExt = c + } + where + checkMagic x = do + magic <- getBytes 8 + unless (magic == x) $ fail "Invalid Inode: magic number mismatch" + +instance Serialize Ext where + put c = do + unless (numBlocks <= numAddrs') $ + fail $ "Corrupted Ext structure put: too many blocks" + + -- dbugM $ "Ext.put: numBlocks = " ++ show numBlocks + -- dbugM $ "Ext.put: blocks = " ++ show blocks + -- dbugM $ "Ext.put: fillBlocks = " ++ show fillBlocks + + putByteString $ cmagic1 + put $ address c + put $ nextExt c + putByteString $ cmagic2 + putWord64be $ blockCount c + putByteString $ cmagic3 + forM_ blocks put + replicateM_ fillBlocks $ put nilIR + + putByteString cmagic4 + replicateM_ cPadSize $ putWord8 padSentinel + where + blocks = blockAddrs c + numBlocks = length blocks + numAddrs' = safeToInt $ numAddrs c + fillBlocks = numAddrs' - numBlocks + + get = do + checkMagic cmagic1 + addr <- get + dbugM $ "decodeExt: addr = " ++ show addr + ext <- get + dbugM $ "decodeExt: ext = " ++ show ext + checkMagic cmagic2 + blkCnt <- getWord64be + dbugM $ "decodeExt: blkCnt = " ++ show blkCnt + checkMagic cmagic3 + + -- Some calculations differ slightly based on whether or not this Ext is + -- embedded in an inode; in particular, the Inode writes a terminating magic + -- number after the end of the serialized Ext, so we must account for that + -- when calculating the number of blocks to read below. + + let isEmbeddedExt = addr == nilER + dbugM $ "decodeExt: isEmbeddedExt = " ++ show isEmbeddedExt + numBlockBytes <- do + remb <- fmap fromIntegral G.remaining + dbugM $ "decodeExt: remb = " ++ show remb + dbugM $ "--" + let numTrailingBytes = + if isEmbeddedExt + then 8 + fromIntegral cPadSize + 8 + fromIntegral iPadSize + -- cmagic4, padding, inode's magic4, inode's padding + else 8 + fromIntegral cPadSize + -- cmagic4, padding, + dbugM $ "decodeExt: numTrailingBytes = " ++ show numTrailingBytes + return (remb - numTrailingBytes) + dbugM $ "decodeExt: numBlockBytes = " ++ show numBlockBytes + + let (numBlocks, check) = numBlockBytes `divMod` refSize + dbugM $ "decodeExt: numBlocks = " ++ show numBlocks + -- dbugM $ "decodeExt: numBlockBytes = " ++ show numBlockBytes + -- dbugM $ "decodeExt: refSzie = " ++ show refSize + -- dbugM $ "decodeExt: check = " ++ show check + + unless (check == 0) $ fail "Ext: Bad remaining byte count for block list." + unless (not isEmbeddedExt && numBlocks >= minExtBlocks || + isEmbeddedExt && numBlocks >= minInodeBlocks) $ + fail "Ext: Not enough space left for minimum number of blocks." + + blks <- filter (/= 0) `fmap` replicateM (safeToInt numBlocks) get + + checkMagic cmagic4 + padding <- replicateM cPadSize $ getWord8 + assert (all (== padSentinel) padding) $ return () + + let na = error $ "numAddrs has not been populated via Data.Serialize.get " + ++ "for Ext; did you forget to use the " + ++ "Inode.decodeExt wrapper?" + return Ext + { address = addr + , nextExt = ext + , blockCount = blkCnt + , blockAddrs = blks + , numAddrs = na + } + where + checkMagic x = do + magic <- getBytes 8 + unless (magic == x) $ fail "Invalid Ext: magic number mismatch" + +-------------------------------------------------------------------------------- +-- Debugging cruft + +_dumpExts :: HalfsCapable b t r l m => + Ext -> HalfsM b r l m () +_dumpExts stExt = do + exts <- expandExts Nothing stExt + if null exts + then dbug ("=== No exts ===") $ return () + else do + dbug ("=== Exts ===") $ return () + mapM_ (\c -> dbug (" " ++ show c) $ return ()) exts + +_allowNoUsesOf :: HalfsCapable b t r l m => HalfsM b r l m () +_allowNoUsesOf = do + extMapM undefined undefined >> return () diff --git a/Halfs/Monad.hs b/Halfs/Monad.hs new file mode 100644 --- /dev/null +++ b/Halfs/Monad.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} + +module Halfs.Monad + ( + module Control.Monad.Reader + , MonadError(..) + , HalfsT + , atomicModifyLockedRscRef + , hbracket + , newLockedRscRef + , runHalfs + , runHalfsNoEnv + , withLock + , withLockM + , withLockedRscRef + ) + where + +import Control.Monad.Error +import Control.Monad.Reader + +import Halfs.Classes +import Halfs.Types + +newtype HalfsT err env m a = HalfsT { runHalfsT :: ReaderT env m (Either err a) } + +runHalfs :: env -> HalfsT err (Maybe env) m a -> m (Either err a) +runHalfs = flip (runReaderT . runHalfsT) . Just + +runHalfsNoEnv :: HalfsT err (Maybe env) m a -> m (Either err a) +runHalfsNoEnv = flip (runReaderT . runHalfsT) Nothing + +-------------------------------------------------------------------------------- +-- Instances + +instance (Monad m) => Monad (HalfsT err env m) where + m >>= k = HalfsT $ runHalfsT m >>= either (return . Left) (runHalfsT . k) + return = HalfsT . return . Right + +instance (Monad m) => Functor (HalfsT err env m) where + fmap f fa = + HalfsT $ runHalfsT fa >>= either (return . Left) (return . Right . f) + +instance MonadTrans (HalfsT err env) where + lift = HalfsT . lift . liftM Right + -- HalfsT . (=<<) (return . Right) + +instance (Monad m) => MonadError err (HalfsT err env m) where + throwError e = HalfsT $ return $ Left e + catchError act h = + HalfsT $ do + eea <- runHalfsT act + case eea of + Left e -> runHalfsT (h e) + Right a -> return $ Right a + +instance Monad m => MonadReader r (HalfsT err r m) where + ask = HalfsT $ ReaderT $ return . Right + local f m = HalfsT $ ReaderT $ \r -> runReaderT (runHalfsT m) (f r) + +instance Reffable r m => Reffable r (HalfsT err env m) where + newRef = lift . newRef + readRef = lift . readRef + writeRef r = lift . writeRef r + +instance Bitmapped b m => Bitmapped b (HalfsT err env m) where + newBitmap w = lift . newBitmap w + clearBit b = lift . clearBit b + setBit b = lift . setBit b + checkBit b = lift . checkBit b + toList = lift . toList + +instance Lockable l m => Lockable l (HalfsT err env m) where + newLock = lift newLock + lock = lift . lock + release = lift . release + +instance Timed t m => Timed t (HalfsT err env m) where + getTime = lift getTime + toCTime = lift . toCTime + fromCTime = lift . fromCTime + +instance Threaded m => Threaded (HalfsT err env m) where + getThreadId = lift getThreadId + +-------------------------------------------------------------------------------- +-- Utility functions specific to the Halfs monad + +hbracket :: Monad m => + HalfsT err env m a -- ^ before (\"acquisition\") + -> (a -> HalfsT err env m b) -- ^ after (\"release\") + -> (a -> HalfsT err env m c) -- ^ bracketed computation + -> HalfsT err env m c -- ^ result of bracketed computation +hbracket before after act = do + a <- before + r <- act a `catchError` \e -> after a >> throwError e + _ <- after a + return r + +withLock :: HalfsCapable b t r l m => + l -> HalfsT err env m a -> HalfsT err env m a +withLock l act = hbracket (lock l) (const $ release l) (const act) + +withLockM :: (Monad m, Lockable l m) => + l -> m a -> m a +withLockM l act = do + lock l + res <- act + release l + return res + +-------------------------------------------------------------------------------- +-- Locked resource reference utility functions + +newLockedRscRef :: (Lockable l m, Functor m, Reffable r m) => + rsc + -> m (LockedRscRef l r rsc) +newLockedRscRef initial = LockedRscRef `fmap` newLock `ap` newRef initial + +withLockedRscRef :: HalfsCapable b t r l m => + LockedRscRef l r rsc + -> (r rsc -> HalfsT err env m rslt) + -> HalfsT err env m rslt +withLockedRscRef lr f = withLock (lrLock lr) $ f (lrRsc lr) + +atomicModifyLockedRscRef :: HalfsCapable b t r l m => + LockedRscRef l r rsc + -> (rsc -> rsc) + -> HalfsT err env m () +atomicModifyLockedRscRef lr f = withLockedRscRef lr (`modifyRef` f) diff --git a/Halfs/MonadUtils.hs b/Halfs/MonadUtils.hs new file mode 100644 --- /dev/null +++ b/Halfs/MonadUtils.hs @@ -0,0 +1,30 @@ +module Halfs.MonadUtils + ( + hasks + , hlocal + , logMsg + ) +where + +import Data.Maybe (fromJust) + +import Halfs.Errors +import Halfs.Monad +import Halfs.HalfsState + +-- import Debug.Trace + +type HalfsM b r l m a = HalfsT HalfsError (Maybe (HalfsState b r l m)) m a + +logMsg :: Monad m => String -> HalfsM b r l m () +logMsg msg = hasks hsLogger >>= maybe (return ()) (\lgr -> lift $ lgr msg) + +hasks :: Monad m => (HalfsState b r l m -> a) -> HalfsM b r l m a +hasks f = + ask >>= maybe (fail "hasks: No valid HalfsState exists") (return . f) + +hlocal :: Monad m => + (HalfsState b r l m -> HalfsState b r l m) + -> HalfsM b r l m a + -> HalfsM b r l m a +hlocal f m = local (Just . f . fromJust) m diff --git a/Halfs/Protection.hs b/Halfs/Protection.hs new file mode 100644 --- /dev/null +++ b/Halfs/Protection.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Halfs.Protection( + UserID (..) + , GroupID(..) + , rootUser + , rootGroup + ) + where + +import Data.Serialize +import Data.Word + +newtype UserID = UID Word64 + deriving (Show, Eq, Real, Enum, Integral, Num, Ord) + +instance Serialize UserID where + put (UID x) = putWord64be x + get = UID `fmap` getWord64be + +rootUser :: UserID +rootUser = UID 0 + +-- + +newtype GroupID = GID Word64 + deriving (Show, Eq, Real, Enum, Integral, Num, Ord) + +instance Serialize GroupID where + put (GID x) = putWord64be x + get = GID `fmap` getWord64be + +rootGroup :: GroupID +rootGroup = GID 0 diff --git a/Halfs/SuperBlock.hs b/Halfs/SuperBlock.hs new file mode 100644 --- /dev/null +++ b/Halfs/SuperBlock.hs @@ -0,0 +1,87 @@ +module Halfs.SuperBlock( + SuperBlock(..) + , superBlockSize + ) + where + +import Control.Exception +import Control.Monad +import Data.ByteString(ByteString) +import qualified Data.ByteString as BS +import Data.Char +import Data.Serialize +import Data.Word + +import Halfs.Types + +data SuperBlock = SuperBlock { + version :: !Word64 -- ^ Version of this superblock + , devBlockSize :: !Word64 -- ^ Block size of underlying blkdev + , devBlockCount :: !Word64 -- ^ Number of blocks on underlying blkdev + , unmountClean :: !Bool -- ^ Was this filesystem unmounted cleanly? + , freeBlocks :: !Word64 -- ^ Number of free blocks + , usedBlocks :: !Word64 -- ^ Number of blocks in use + , fileCount :: !Word64 -- ^ Number of files present in the FS; + -- does not count directories + , rootDir :: !InodeRef -- ^ IR to root directory + , blockMapStart :: !InodeRef -- ^ IR to first block map addr + } + deriving (Show, Eq, Ord) + +instance Serialize SuperBlock where + put sb = do putByteString magic1 + putWord64be $ version sb + putWord64be $ devBlockSize sb + putWord64be $ devBlockCount sb + putByteString magic2 + putWord64be $ if unmountClean sb then cleanMark else 0 + putWord64be $ freeBlocks sb + putWord64be $ usedBlocks sb + putByteString magic3 + putWord64be $ fileCount sb + put $ rootDir sb + put $ blockMapStart sb + putByteString magic4 + get = do checkMagic magic1 + v <- getWord64be + unless (v == 1) $ fail "Unsupported HALFS version found." + bs <- getWord64be + bc <- getWord64be + checkMagic magic2 + uc <- wasUnmountedCleanly `fmap` getWord64be + fb <- getWord64be + ub <- getWord64be + checkMagic magic3 + fc <- getWord64be + rd <- get + bm <- get + checkMagic magic4 + return $ SuperBlock v bs bc uc fb ub fc rd bm + where + checkMagic x = do magic <- getBytes 8 + unless (magic == x) $ fail "Invalid superblock." + +superBlockSize :: Word64 +superBlockSize = fromIntegral $ BS.length $ encode blank + where blank = SuperBlock 0 0 0 False 0 0 0 0 0 + +-- ---------------------------------------------------------------------------- + +cleanMark :: Word64 +cleanMark = 0x2357111317192329 + +wasUnmountedCleanly :: Word64 -> Bool +wasUnmountedCleanly x = x == cleanMark + +magicStr :: String +magicStr = "The Haskell File System, Halfs!!" + +magicBytes :: [Word8] +magicBytes = assert (length magicStr == 32) $ + map (fromIntegral . ord) magicStr + +magic1, magic2, magic3, magic4 :: ByteString +magic1 = BS.pack $ take 8 $ drop 0 magicBytes +magic2 = BS.pack $ take 8 $ drop 8 magicBytes +magic3 = BS.pack $ take 8 $ drop 16 magicBytes +magic4 = BS.pack $ take 8 $ drop 24 magicBytes diff --git a/Halfs/SyncStructures.hs b/Halfs/SyncStructures.hs deleted file mode 100644 --- a/Halfs/SyncStructures.hs +++ /dev/null @@ -1,200 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Halfs.SyncStructures --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : GHC --- --- Explanation: Write various internal structures to disk. Note that --- the inode file never shrinks and the block map file never shrinks --- or grows. Therefore, --- --- * When syncing directories, use truncate, since they might shrink a lot. This includes the root directory. --- --- * When syncing the inode map, use truncate, Its size might change. --- --- * When syncing the inode file, use write. It never shrinks. --- --- * When syncing the block map, use write. Its size never changes. - -module Halfs.SyncStructures (shortSyncFSRoot, syncFSRoot, syncDirectoryToFile) where - -import Halfs.Directory(Directory(..), DirectoryCache(..), addDirectoryToCache, - dirCacheDirty, directoryCacheToList) -import Halfs.FSRoot(FSRoot(..), fsRootUpdateInodeCache, fsRootBmInode, FSStatus(..)) -import Halfs.Inode (Inode(..), InodeMetadata(..)) -import Halfs.FileHandle (fhInode, fileHandle, fhOpenTruncate, fhWrite, fileHandle, - FileHandle(..), FileMode(..)) -import Halfs.BasicIO (BinHandle, writeDirectoryBin, syncInode, - writeBlockMapBin, writeInodeMapBin) -import Halfs.BinaryMonad(openBinMemRW, sizeBinMemRW) -import Halfs.TheBlockMap(TheBlockMap,bmDirty) -import Halfs.TheInodeMap(TheInodeMap(..)) -import Data.Integral(INInt, intToINInt, INLong) -import Halfs.Utils(bytesPerBlock, - inodeMapInodeNum, blockMapInodeNum) -import Halfs.BufferBlockCache(syncBBCache) -import Halfs.FSState (FSWrite, modify, unsafeWriteGet, readToWrite, - putStrLnWriteRead) - --- base -import Control.Exception(assert) -import Control.Monad(mapM_, when) -import qualified Data.Map as Map - --- |writes it as a file, marks it as clean. block map file never --- shrinks. see notes in TheBlockMap.hs -syncBlockMapFile :: FSWrite () -syncBlockMapFile = do - fsroot@FSRoot{blockMap=theBlockMap} <- unsafeWriteGet - let oldSize = num_bytes $ metaData $ fsRootBmInode fsroot - - syncObjectToFile theBlockMap - (bmDirty theBlockMap) - blockMapInodeNum - writeBlockMapBin - (updater oldSize) False - where - updater :: INLong -> Inode -> FSRoot -> FSRoot - updater oldSize inode fsroot'@FSRoot{blockMap=bm} - -- if it's grown, then it's still dirty: - = let isDirty = (oldSize /= (num_bytes $ metaData inode)) - in fsroot'{blockMap=bm{bmDirty=isDirty}} - --- |Inode map file is open truncate, it can be resized. -syncInodeMapFile :: FSWrite () -syncInodeMapFile = do - fsroot <- unsafeWriteGet - let inMap = inodeMap fsroot - syncObjectToFile inMap - (imDirty inMap) - inodeMapInodeNum - writeInodeMapBin updater True - where - updater :: Inode -> FSRoot -> FSRoot - updater _inode fsroot'@FSRoot{inodeMap=im} - = fsroot'{inodeMap=im{imDirty=False}} - --- |Directories are open truncate, they can be resized. -syncDirectoryToFile :: Directory -> FSWrite () -syncDirectoryToFile d = do - -- the below updater may alter the inode, but don't worry - -- fsrootupdateinodecache will handle that in the case of root - -- directory. - let inodeNum = fhInodeNum $ dirFile d - syncObjectToFile (dirContents (assert (dirHasItsInodeNum d) d)) - (dirDirty d) - inodeNum writeDirectoryBin (updater d) True - -- FIX: If it's the root inode, we should mark it not dirty. - where - updater :: Directory -> Inode -> FSRoot -> FSRoot - updater dir i fsr = let newR@FSRoot{directoryCache=c} - = fsRootUpdateInodeCache fsr i - in newR {directoryCache=addDirectoryToCache c dir{dirDirty=False}} - - dirHasItsInodeNum :: Directory -> Bool - dirHasItsInodeNum (Directory FileHandle{fhInodeNum=i} c _) - = case Map.lookup "." c of - Nothing -> True -- might be root - Just a -> a == i - -syncDirectoryCache :: FSWrite () -syncDirectoryCache = do - FSRoot{directoryCache=c} <- unsafeWriteGet - when (dirCacheDirty c) (mapM_ syncDirectoryToFile (directoryCacheToList c)) - - -- FIX: Possible race condition right here. updater calls modify, so - -- we can't grab it HERE because of deadlock. I think this is fixed - -- by not marking the dcirecotry cache clean :( directories - -- themselves have clean markers, though, so it should be OK. - - modify (\fsroot@FSRoot{directoryCache=_c} -> fsroot) --- fsroot{directoryCache=markDirectoryCacheClean c}) - -syncObjectToFile :: a -- which object - -> Bool -- is dirty - -> INInt -- inode num - -> (BinHandle -> a -> FSWrite ()) -- writer function - -> (Inode -> FSRoot -> FSRoot) -- updater / dirty marker - -> Bool -- ^Truncate if dirty, otherwise write in-place. FIX: take open flag when that's fixed. - -> FSWrite () -syncObjectToFile _ False _ _ _ _ = return () -syncObjectToFile obj True inodeNum writer updater trunc = do - -- This file will always be less than INInt, not INLong - newFileHandle <- if trunc - then fhOpenTruncate inodeNum - else return $ fileHandle inodeNum WriteMode - - {- FIX: For large filesystems, this may be a bad plan.. that is, we - allocate a single block for the object, then start writing to it. - Binary.hs will resize the array if necessary. fhWrite then performs - the actual write to the filesystem in blocks. What we _should_ do - is perform buffered writes to this array and _not_ resize it, so - that we don't allocate one huge array for these structures. OTOH, - maybe that's not a big deal, as it'll only be an issue for really - big filesystems? -} - - buffer <- openBinMemRW bytesPerBlock -- (num_bytes $ metaData fhInode fileHandle) -- initial size - writer buffer obj -- may resize buffer! - objSize <- sizeBinMemRW buffer - (newFH, writtenNum) - <- fhWrite newFileHandle buffer 0 (intToINInt objSize) - inode <- readToWrite $ fhInode newFH - assert (writtenNum == intToINInt objSize) $ - modify (updater inode) - --- |Sync the entire inode cache! Woohoo! -syncInodeCache :: FSWrite () -syncInodeCache = do - FSRoot{inodeCache=(inCache,isDirty)} <- unsafeWriteGet - when isDirty (mapM_ syncInode (Map.elems inCache) - >> modify (\fsroot -> fsroot{inodeCache=(fst $ inodeCache fsroot, False)})) - -keepSyncingBlockMap :: FSWrite () -keepSyncingBlockMap = do - return() - FSRoot{blockMap=theBlockMap} <- unsafeWriteGet - when (bmDirty theBlockMap) (do syncBlockMapFile - syncInodeCache - FSRoot{blockMap=theBlockMap1} <- unsafeWriteGet - -- only need to keep syncing if size changed - when (bmDirty theBlockMap1) keepSyncingBlockMap) - --- |Writes the FSRoot to cache, then to device -syncFSRoot :: FSWrite () -syncFSRoot = do - putS "syncing... " - FSRoot{fsStatus=status, bbCache=cache} <- unsafeWriteGet - let syncBBC = syncBBCache cache - assert (status == FsReadWrite) syncBBC - syncDirectoryCache - syncBBC - syncInodeMapFile - syncBBC - syncBlockMapFile - syncBBC - syncInodeCache - -- Have to do it twice; the first time it might actually change - -- itself. FIX: Should actually do this until we stabalize, and - -- write the inode cache after each one! --- syncBlockMapFile >> syncInodeCache - keepSyncingBlockMap - syncBBC - - --- |Writes the FSRoot to cache (sans free list), then to device -shortSyncFSRoot :: FSWrite () -shortSyncFSRoot = do - putS "syncing (sans free list) ... " - FSRoot{fsStatus=status, bbCache=cache} <- unsafeWriteGet - let syncBBC = syncBBCache cache - assert (status == FsReadWrite) $ return () - syncDirectoryCache - syncInodeMapFile - syncInodeCache --- finally, the buffer blocks them selfs. - syncBBC - -putS :: String -> FSWrite () -putS = putStrLnWriteRead diff --git a/Halfs/TestFramework.hs b/Halfs/TestFramework.hs deleted file mode 100644 --- a/Halfs/TestFramework.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE Rank2Types, GADTs #-} ------------------------------------------------------------------------------ --- | --- Module : TestFramework --- Copyright : Copyright 2004 by by Aetion Technologies LLC --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : Hugs, GHC (Uses existential types) --- --- Explanation: Provide basic functions for conviniently running a --- collection of HUnit and QuickCheck tests. - -{- ============================================================================= -Copyright 2004 by Aetion Technologies LLC. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -* Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - -* Neither the name of the Aetion Technologies LLC nor the names of its - contributors may be used to endorse or promote products derived from this - software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -============================================================================= -} - -module Halfs.TestFramework (UnitTests, QC(..), runTest, - combineCounts, runAllTests, - hunitToUnitTest, listsToUnitTests, - qcToUnitTest, testMain, assertCmd, - module Test.QuickCheck, - module Test.HUnit --- ,(~:), (~=?) - ) where - --- Base: -import Control.Monad(liftM) -import Data.Maybe(catMaybes) -import Test.QuickCheck (quickCheck, Testable, (==>)) -import System.Cmd(system) -import System.Exit (ExitCode(ExitSuccess)) - --- Misc: - -- FIX: should eventually be Debug.HUnit or Test.HUnit. -import Test.HUnit (Test(..), Counts(..), Assertion, - (~:), (~=?), assertEqual, assertBool, test, runTestTT) - --- ------------------------------------------------------------ --- * Types --- ------------------------------------------------------------ - --- |Extra constructor is required. Uses the existential constructor --- feature so we can have heterogeneous lists. -data QC = forall a. (Testable a) => QC String a - --- |Either HUnit or QuickCheck -type UnitTests = [Either Test -- HUnit test suite - QC] -- QuickCheck test suite - -hunitToUnitTest :: [Test] -> UnitTests -hunitToUnitTest = map Left - -qcToUnitTest :: [QC] -> UnitTests -qcToUnitTest = map Right - -listsToUnitTests :: [Test] -> [QC] -> UnitTests -listsToUnitTests hu qc - = (map Left hu) ++ (map Right qc) - --- ------------------------------------------------------------ --- * Convinient Functions --- ------------------------------------------------------------ - --- |Beautify this test label. -prettyLab :: String -> String -prettyLab lab = "---+++ " ++ lab - --- |Print out the test label before execution. -runTest :: Test -> IO Counts -runTest t@(TestLabel lab _) = (putStrLn $ prettyLab lab) >> runTestTT t -runTest t = runTestTT t - --- |Given a collection of tests, run them through either quickcheck or --- HUnit, as appropriate. -runAllTests :: UnitTests -> IO [Counts] -runAllTests t - = do counts <- sequence $ map tester t - return $ catMaybes counts - where tester :: Either Test QC -> IO (Maybe Counts) - tester (Left hUnitTest) = liftM Just (runTest hUnitTest) - tester (Right (QC lab t')) = do putStrLn $ prettyLab lab; quickCheck t'; return Nothing - - -combineCounts :: Counts -> Counts -> Counts -combineCounts (Counts a b c d) (Counts a' b' c' d') - = Counts (a + a') (b + b') (c + c') (d + d') - --- |Run this command, and assert it returns a successful error code. -assertCmd :: String -- ^Command - -> String -- ^Comment - -> Assertion -assertCmd command comment - = system command >>= assertEqual (command ++ ":" ++ comment) ExitSuccess - --- ------------------------------------------------------------ --- * For Testing --- ------------------------------------------------------------ - -testMain :: IO () -testMain = do runAllTests ([Left $ TestLabel "foo" (TestList ["a" ~: "failed" ~: 3 ~=? (32::Int)]), - Right (QC "first" (True ==> False)), (Right $ QC "snd" True) - ]) - return () diff --git a/Halfs/TheBlockMap.hs b/Halfs/TheBlockMap.hs deleted file mode 100644 --- a/Halfs/TheBlockMap.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# LANGUAGE PatternSignatures #-} ------------------------------------------------------------------------------ --- | --- Module : TheBlockMap --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : GHC --- --- Explanation: Tracks free blocks in the filesystem. Does not track --- non-free blocks. Exists as a FIFO queue to avoid block reuse. --- This is also true when syncing to the disk; it syncs in FIFO order, --- so when its read from the disk, the least-recently-used block is on --- the end, and won't be used for a while. -- The number of bytes in --- the block map file does _not_ change, but not all of those bytes --- will always be used. That is, the block map file is a fixed size, --- does not shrink after newFS. - -module Halfs.TheBlockMap (TheBlockMap -- abstract - ,mkBlockMap - ,allocateBlock - ,freeBlock - ,freeBlocks - ,bmTotalSize - ,bmDirty - ,newFS - ,findAddress - ,unitTests) - where - -import Halfs.Inode (Inode(metaData), InodeMetadata(level) - ,newInode, firstFreeInodeDiskAddr) -import Halfs.TestFramework (Test(..), UnitTests, (~:), (~=?), - hunitToUnitTest) -import Data.Integral ( INInt, intToINInt ) -import Halfs.Utils (DiskAddress, BlockNumber, - FileType (File), - blockPointersPerIndirectBlock, - blockPointersPerInode) - --- Base -import Data.Queue (listToQueue, addToQueue, deQueue, Queue, queueToList, queueLength) -import qualified Data.Set as Set -import Control.Exception(assert) - --- TODO: each block of blockmap should have a dirty bit (inside the --- inode) -data TheBlockMap = TheBlockMap {freeBlocks :: Queue DiskAddress - ,_freeBlocksSet :: Set.Set DiskAddress - ,bmDirty :: Bool - ,bmTotalSize :: INInt -- total number of blocks - } - --- |todo: check to see if new epoch, optimize allocation by using a --- window and passing in a hint of where it "should" go. "Nothing" --- means that the disk is full. - -allocateBlock :: TheBlockMap -> Maybe (DiskAddress, TheBlockMap) -allocateBlock (TheBlockMap inBlockMap inBlockSet _ s) - = case deQueue inBlockMap of - Nothing -> Nothing -- Nothing free! - Just (addr, newBlockMap) - -> Just ((assert (addr /= 0) addr), TheBlockMap newBlockMap (Set.delete addr inBlockSet) True s) - -freeBlock :: TheBlockMap -> DiskAddress -> TheBlockMap -freeBlock (TheBlockMap inBlockMap inBlockSet _ len) addr - = assert (not (Set.member addr inBlockSet)) $ - assert (addr > 0 && addr < len) $ - TheBlockMap (addToQueue inBlockMap (assert (addr /= 0) addr)) (Set.insert addr inBlockSet) True len -{- - where addToQueue' q addr = listToQueue (take offset xs ++ [addr] ++ drop offset xs) - where xs = queueToList q - offset = 200 --} --- |smart constructor for TheBlockMap -newFS :: INInt -- ^Length of the device in blocks - -> TheBlockMap -newFS len -- 0 and 1 are inode file and inodemap file - = mkBlockMap (listToQueue [firstFreeInodeDiskAddr .. (len - 1)]) True len - -mkBlockMap :: Queue DiskAddress -> Bool -> INInt -> TheBlockMap -mkBlockMap free busy size - = assert (queueLength free == Set.size freeSet) $ - TheBlockMap free freeSet busy size - where freeSet = Set.fromList (queueToList free) - -instance Show TheBlockMap where - show (TheBlockMap free _ de tot) = "TheBlockMap [" ++ showBM (queueToList free) ++ "] " ++ show de ++ " " ++ show tot - where - commas [] = "" - commas xs = foldl1 (\ a b -> a ++ "," ++ b) xs - showBM xs = commas - [ if a == b - then - show a - else show a ++ ".." ++ show b - | (a,b) <- combine [ (x,x) | x <- xs ] ] - combine ((a,b):(c,d):r) | b+1 == c = combine ((a,d):r) - combine (v:r) = v: combine r - combine [] = [] - -{- -instance Show TheBlockMap where - show (TheBlockMap fb _ _) - = fmap (\x -> if isFree x then "-" else "X") --} - --- ------------------------------------------------------------ --- * Computing the location on disk of this block --- ------------------------------------------------------------ - -findAddress :: Inode -- ^Inode that contains the blocks - -> BlockNumber -- ^Address we're looking for, 0 indexed - -> [INInt] -- ^dereference locations at each level, 0 indexed -findAddress inode findMe - = addrList (level $ metaData inode) - 1 - (intToINInt blockPointersPerIndirectBlock) - (intToINInt blockPointersPerInode) - findMe - --- |Compute the list of locations in a tree with the given branching --- factor. Counts up to totalLevels, zero indexed. That is, if I'm --- looking for the 3rd element in a zero indexed binary tree with two --- levels, it'll be [1,1]. addrList 3 3 2 10 == [1,0,1] - -addrList :: INInt -- Levels - -> INInt -- current level - -> INInt -- branching factor - -> INInt -- base buckets - -> BlockNumber -- address to find - -> [INInt] -addrList totalLevels currLevel branchingFactor baseBuckets findMe - | findMe >= numBuckets totalLevels branchingFactor baseBuckets - = error "block too big, should have resized" - | currLevel > totalLevels = [] - | otherwise = let bucketLoc = absBucket totalLevels currLevel - branchingFactor baseBuckets findMe - prevLevel = currLevel - 1 - prevBucket = absBucket totalLevels prevLevel - branchingFactor baseBuckets findMe - answer = if currLevel == 1 - then bucketLoc - else bucketLoc - (branchingFactor * prevBucket) - in answer : (addrList totalLevels (currLevel + 1) - branchingFactor baseBuckets findMe) - --- |How many buckets at this level for this branching factor? -numBuckets :: INInt -- current level - -> INInt -- branching factor - -> INInt -- base buckets - -> INInt -numBuckets 0 _ _ = error "zero" -numBuckets 1 _ b = b -numBuckets currLevel branchingFactor baseBuckets - = (numBuckets (currLevel - 1) branchingFactor baseBuckets) * branchingFactor - --- Get the bucket of this element as if this entire level were one node -absBucket :: INInt -- total levels - -> INInt -- current level - -> INInt -- branching factor - -> INInt -- base buckets - -> BlockNumber -- location to find. - -> INInt -absBucket _ _ _ _ 0 = 0 -absBucket totalLevels currLevel branchingFactor baseBuckets findMe = - let maxElems = numBuckets totalLevels branchingFactor baseBuckets - buckets = numBuckets currLevel branchingFactor baseBuckets - itemsPerBucket = maxElems `div` (assert (buckets /= 0) buckets) - -- Below "1" adjustments are because addresses start at zero. - in (ceiling $ toRational (findMe+1) / toRational itemsPerBucket) - 1 - --- ------------------------------------------------------------ --- * Testing --- ------------------------------------------------------------ - -unitTests :: UnitTests -unitTests = hunitToUnitTest hunitTests - -hunitTests :: [Test] -hunitTests = let inode' = newInode 0 File - inode = inode'{metaData=(metaData inode'){level=2}} - inode2 = inode'{metaData=(metaData inode'){level=3}} - (maxAddr::INInt) = (16 * (1024 ^ (2::Int))) - 1 -- for 3 levels - in - ["simple Address List 1" ~: "failed" ~: [1,0,1] ~=? addrList 3 1 3 2 10 - ,"simple Address List 2" ~: "failed" ~: [1,0,2] ~=? addrList 3 1 3 2 11 - ,"simple Address List 2" ~: "failed" ~: [1,1,1] ~=? addrList 3 1 3 2 13 - ,"disk addr list 1" ~: "failed" ~: [0,0] ~=? findAddress inode 0 - ,"disk addr list 2" ~: "failed" ~: [0,1] ~=? findAddress inode 1 - ,"disk addr list 3" ~: "failed" ~: [0,1023] ~=? findAddress inode 1023 - ,"disk addr list 4" ~: "failed" ~: [1,0] ~=? findAddress inode 1024 - ,"disk addr list 3 lev. 1" ~: "failed" ~: [0,1,0] ~=? findAddress inode2 1024 - ,"disk addr list 3 lev. 2" ~: "failed" - ~: [0,0,1023] ~=? findAddress inode2 1023 - ,"disk addr list 3 lev. 3" ~: "failed" ~: [0,5,0] ~=? findAddress inode2 5120 - ,"max addr" ~: "failed" ~: maxAddr ~=? (numBuckets 3 1024 16) - 1 - ,"max addr loc" ~: "failed" ~: [15, 1023, 1023] - ~=? findAddress inode2 maxAddr - -- FIX: Should test address maxAddr + 1 which should fail - ] diff --git a/Halfs/TheInodeMap.hs b/Halfs/TheInodeMap.hs deleted file mode 100644 --- a/Halfs/TheInodeMap.hs +++ /dev/null @@ -1,22 +0,0 @@ --- |Basically hidden under the FSRoot module (also used by SyncStructures) - -module Halfs.TheInodeMap (TheInodeMap(..), emptyInodeMap, - freeInode) where - -import Data.Integral(INInt) - --- |Keeps track of freed inodes so we can reuse their space. -data TheInodeMap = TheInodeMap { - freeInodes :: [INInt] -- Inode Numbers - ,imDirty :: Bool - ,imMaxNum :: INInt - } - -emptyInodeMap :: INInt -- first free inode number - -> TheInodeMap -emptyInodeMap n = TheInodeMap [] True n - --- |Add this inode to the free list. -freeInode :: TheInodeMap -> INInt -> TheInodeMap -freeInode im@TheInodeMap{freeInodes=l} i - = im{freeInodes=i:l, imDirty=True} diff --git a/Halfs/Types.hs b/Halfs/Types.hs new file mode 100644 --- /dev/null +++ b/Halfs/Types.hs @@ -0,0 +1,212 @@ +-- This module contains types and instances common to most of Halfs + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Halfs.Types +where + +import Control.Applicative +import Control.Monad +import Data.Bits +import qualified Data.Map as M +import Data.List (sort) +import Data.Serialize +import Data.Word + +import Halfs.Protection + +-------------------------------------------------------------------------------- +-- Common Inode Types + +newtype Ref a = Ref Word64 + deriving (Eq, Ord, Num, Show, Integral, Enum, Real) + +instance Serialize (Ref a) where + put (Ref x) = putWord64be x + get = Ref `fmap` getWord64be + +-- We store Inode/Ext references as simple Word64s, newtype'd in case +-- we either decide to do something more fancy or just to make the types +-- a bit more clear. +-- +-- At this point, we assume a reference is equal to its block address, +-- and we fix references as Word64s. Note that if you change the +-- underlying field size of an InodeRef/ExtRef, you *really* (!) need +-- to change 'refSize', below. +-- + +newtype InodeRef = IR { unIR :: Word64 } + deriving (Eq, Ord, Num, Show, Integral, Enum, Real) + +newtype ExtRef = ER { unER :: Word64 } + deriving (Eq, Show) + +instance Serialize InodeRef where + put (IR x) = putWord64be x + get = IR `fmap` getWord64be + +instance Serialize ExtRef where + put (ER x) = putWord64be x + get = ER `fmap` getWord64be + +-- | The size of an Inode/Ext reference in bytes +refSize :: Word64 +refSize = 8 + +-- | A simple locked resource reference +data LockedRscRef l r rsc = LockedRscRef + { lrLock :: l + , lrRsc :: r rsc + } + +-------------------------------------------------------------------------------- +-- Common Directory and File Types + +-- File names are arbitrary-length, null-terminated strings. Valid file names +-- are guaranteed to not include null or the System.FilePath.pathSeparator +-- character. + +-- Current directory and parent directory relative path names +dotPath, dotdotPath :: FilePath +dotPath = "." +dotdotPath = ".." + +-- | DF_WrongFileType implies the filesystem element with the search key +-- was found but was not of the correct type. +data DirFindRslt a = DF_NotFound | DF_WrongFileType FileType | DF_Found (a, FileType) + +data DirectoryEntry = DirEnt + { deName :: String + , deInode :: InodeRef + , deUser :: UserID + , deGroup :: GroupID + , deMode :: FileMode + , deType :: FileType + } + deriving (Show, Eq) + +data DirHandle r l = DirHandle + { dhInode :: r (Maybe InodeRef) + , dhContents :: r (M.Map FilePath DirectoryEntry) + , dhState :: r DirectoryState + , dhLock :: l + } + +data FileHandle r l = FH + { fhReadable :: Bool + , fhWritable :: Bool + , _fhFlags :: FileOpenFlags + , fhInode :: r (Maybe InodeRef) -- Maybe to denote FileHandle invalidation + , fhLock :: l -- Ensures sequential access to the INR + } + +data AccessRight = Read | Write | Execute + deriving (Show, Eq, Ord) + +-- Isomorphic to System.Posix.IO.OpenMode, but present here to avoid explicit +-- dependency on the Posix module(s). +data FileOpenMode = ReadOnly | WriteOnly | ReadWrite + deriving (Eq, Show) + +-- Similar to System.Posix.IO.OpenFileFlags, but present here to avoid explicit +-- dependency on the Posix module(s). +data FileOpenFlags = FileOpenFlags + { append :: Bool -- append on each write + , nonBlock :: Bool -- do not block on open or for data to become avail + +{- Always False from HFuse 0.2.2! + , explicit :: Bool -- atomically obtain an exclusive lock + , truncate :: Bool -- truncate size to 0 +-} + +-- Not yet supported by halfs +-- , noctty :: Bool + + , openMode :: FileOpenMode -- isomorphic to System.Posix.IO.OpenMode + } + deriving (Show) + +data DirectoryState = Clean | OnlyAdded | OnlyDeleted | VeryDirty + deriving (Show, Eq) + +data FileMode = FileMode + { fmOwnerPerms :: [AccessRight] + , fmGroupPerms :: [AccessRight] + , fmUserPerms :: [AccessRight] + } + deriving (Show) + +data FileType = RegularFile | Directory | Symlink | AnyFileType + deriving (Show, Eq) + +data FileStat t = FileStat + { fsInode :: InodeRef + , fsType :: FileType + , fsMode :: FileMode + , fsNumLinks :: Word64 -- ^ Number of hardlinks to the file + , fsUID :: UserID + , fsGID :: GroupID + , fsSize :: Word64 -- ^ File size, in bytes + , fsNumBlocks :: Word64 -- ^ Number of blocks allocated + , fsAccessTime :: t -- ^ Time of last access + , fsModifyTime :: t -- ^ Time of last data modification + , fsChangeTime :: t -- ^ Time of last status (inode) change + } + deriving Show + + +-------------------------------------------------------------------------------- +-- Misc Instances + +instance Serialize DirectoryEntry where + put de = do + put $ deName de + put $ deInode de + put $ deUser de + put $ deGroup de + put $ deMode de + put $ deType de + get = DirEnt <$> get <*> get <*> get <*> get <*> get <*> get + +instance Serialize FileType where + put RegularFile = putWord8 0x0 + put Directory = putWord8 0x1 + put Symlink = putWord8 0x2 + put _ = fail "Invalid FileType during serialize" + -- + get = + getWord8 >>= \x -> case x of + 0x0 -> return RegularFile + 0x1 -> return Directory + 0x2 -> return Symlink + _ -> fail "Invalid FileType during deserialize" + +instance Serialize FileMode where + put FileMode{ fmOwnerPerms = op, fmGroupPerms = gp, fmUserPerms = up } = do + when (any (>3) $ map length [op, gp, up]) $ + fail "Fixed-length check failed in FileMode serialization" + putWord8 $ perms op + putWord8 $ perms gp + putWord8 $ perms up + where + perms ps = foldr (.|.) 0x0 $ flip map ps $ \x -> -- toBit + case x of Read -> 4 ; Write -> 2; Execute -> 1 + -- + get = + FileMode <$> gp <*> gp <*> gp + where + gp = fromBits `fmap` getWord8 + fromBits x = let x0 = if testBit x 0 then [Execute] else [] + x1 = if testBit x 1 then Write:x0 else x0 + x2 = if testBit x 2 then Read:x1 else x1 + in x2 + +instance Eq FileMode where + fm1 == fm2 = + sort (fmOwnerPerms fm1) == sort (fmOwnerPerms fm2) && + sort (fmGroupPerms fm1) == sort (fmGroupPerms fm2) && + sort (fmUserPerms fm1) == sort (fmUserPerms fm2) + +instance Functor DirFindRslt where + fmap _ DF_NotFound = DF_NotFound + fmap _ (DF_WrongFileType ft) = DF_WrongFileType ft + fmap f (DF_Found (r, a)) = DF_Found (f r, a) diff --git a/Halfs/Utils.hs b/Halfs/Utils.hs --- a/Halfs/Utils.hs +++ b/Halfs/Utils.hs @@ -1,155 +1,52 @@ -{-# LANGUAGE FlexibleContexts #-} ------------------------------------------------------------------------------ --- | --- Module : Halfs.Utils --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : GHC --- --- Explanation: Implements some useful routines and stores some --- interesting constants. - -module Halfs.Utils - ( module Halfs.Utils - , module System.RawDevice.Base - ) where - -import Binary (Binary, put_, get) - --- base -import Numeric(showHex) -import Data.Char (toUpper) -import Control.Monad(when) -import Control.Monad.Error(throwError, MonadError) -import Data.Array (Array) -import Data.Array.MArray -import System.Directory (removeFile, doesFileExist) -import System.IO.Error(userError) -import System.RawDevice.Base -import Data.Integral - -type INPointers = Array Int DiskAddress - - --- |Like fromJust, but spits out the given error on failure. This is --- for situations which should not happen -fromJustErr :: String -- ^Error to spew before failing to continue - -> Maybe a - -> a -fromJustErr s Nothing = error s -fromJustErr _ (Just a) = a - --- |Get a block of memory that's the right size for a block. --- NOTE: leak - -getMemoryBlock :: IO (BufferBlockHandle s) -getMemoryBlock = newBufferBlockHandle - -myShowHex :: (Integral i) => i -> String -myShowHex n = "0x" ++ map toUpper (Numeric.showHex n []) - -rootInodeNum :: INInt -rootInodeNum = 0 - --- See notes about the block map in TheBlockMap.hs. Block map --- filesize never changes. -blockMapInodeNum :: INInt -blockMapInodeNum = 16 - -inodeMapInodeNum :: INInt -inodeMapInodeNum = 17 - -rootDirInodeNum :: INInt -rootDirInodeNum = 18 - -firstFreeInodeNum :: INInt -firstFreeInodeNum = rootDirInodeNum + 1 - -blockPointersPerInode :: Int -blockPointersPerInode = 16 - -blockPointersPerIndirectBlock :: Int -blockPointersPerIndirectBlock = bytesPerBlock `div` bytesPerBlockPointer - -bytesPerBlockPointer :: Int -bytesPerBlockPointer = 4 - -bytesPerInode :: Int -bytesPerInode = 256 - -inodesPerBlock :: Int -inodesPerBlock = bytesPerBlock `div` bytesPerInode - -rootInodeMagicNum :: INInt -rootInodeMagicNum = 0x2395458 +module Halfs.Utils where -otherInodeMagicNum :: INInt -otherInodeMagicNum = 0x4814819 +import qualified Data.Map as M -inodePadding :: Int -inodePadding = 8 -- FIX: compute this someplace. +import Halfs.Classes +import Halfs.Monad +import Halfs.Types -data FileType = File -- ^1 - | Dir -- ^2 - | SymLink -- ^3 - deriving (Show, Eq) +fmapFst :: (a -> b) -> (a, c) -> (b, c) +fmapFst f (x,y) = (f x, y) -modeFile :: Int -modeFile = 1 +fmapSnd :: (b -> c) -> (a, b) -> (a, c) +fmapSnd f (x,y) = (x, f y) -modeDir :: Int -modeDir = 2 +maybe' :: Maybe a -> b -> (a -> b) -> b +maybe' ma = \x y -> maybe x y ma -modeSymLink :: Int -modeSymLink = 3 +whenJustM :: Monad m => Maybe a -> (a -> m ()) -> m () +whenJustM ma f = maybe (return ()) f ma -mRemoveFile :: FilePath -> IO () -mRemoveFile p = do - b <- doesFileExist p - when b (removeFile p) +divCeil :: Integral a => a -> a -> a +divCeil a b = (a + (b - 1)) `div` b -secondToMicroSecond :: Integer -> Integer -secondToMicroSecond n = n * 1000000 +unfoldrM :: Monad m => (b -> m (Maybe (a, b))) -> b -> m [a] +unfoldrM f x = do + r <- f x + case r of + Nothing -> return [] + Just (a,b) -> liftM (a:) $ unfoldrM f b -instance Enum FileType where - toEnum x | x == modeFile = File - | x == modeDir = Dir - | x == modeSymLink = SymLink - | otherwise - = error $ "internal fromEnum for FileTypes; unknown: " ++ (show x) - fromEnum File = modeFile - fromEnum Dir = modeDir - fromEnum SymLink = modeSymLink +unfoldrM_ :: Monad m => (b -> m (Maybe (a, b))) -> b -> m () +unfoldrM_ f x = unfoldrM f x >> return () -instance Binary FileType where - put_ h f = put_ h (intToINInt (fromEnum f)) - get h = do x <- get h - return $ toEnum (inIntToInt x) +lookupM :: (Ord k, Monad m) => k -> m (M.Map k v) -> m (Maybe v) +lookupM = liftM . M.lookup --- I think this instance is there in GHC 6.4 -{- -instance Error String where - noMsg = "" - strMsg s = s --} -unimplementedM :: (MonadError IOError m) => String -> m a -unimplementedM s = throwError $ userError $ "Unimplemented: " ++ s +lookupRM :: (Ord k, Reffable r m) => k -> r (M.Map k v) -> m (Maybe v) +lookupRM k = lookupM k . readRef -unimplemented :: String -> a -unimplemented s = error $ "Unimplemented: " ++ s +deleteRM :: (Ord k, Reffable r m) => k -> r (M.Map k v) -> m () +deleteRM k mapRef = modifyRef mapRef $ M.delete k --- Mutate an array derived from the original array by applying a --- function to each of the elements. +insertRM :: (Ord k, Reffable r m) => k -> v -> r (M.Map k v) -> m() +insertRM k v mapRef = modifyRef mapRef $ M.insert k v -mutateMapArray :: (MArray a e m, Ix i) => - (e -> e) -- function to new values - -> a i e - -> m () -mutateMapArray fun ar = do - entries <- getAssocs ar - mapM_ updateElem (map (\ (i,_) -> i) entries) +lookupDE :: Reffable r m => + FilePath -> DirHandle r l -> m (Maybe DirectoryEntry) +lookupDE nm = lookupRM nm . dhContents - where updateElem i = do - e <- readArray ar i - writeArray ar i (fun e) +withDHLock :: (HalfsCapable b t r l m) => + DirHandle r1 l -> HalfsT err env m a -> HalfsT err env m a +withDHLock = withLock . dhLock diff --git a/HighLevelTests.hs b/HighLevelTests.hs deleted file mode 100644 --- a/HighLevelTests.hs +++ /dev/null @@ -1,348 +0,0 @@ -{-# LANGUAGE PatternSignatures #-} ------------------------------------------------------------------------------ --- | --- Module : HighLevelTests --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : GHC --- --- Explanation: Implements higher-level interfaces like copying whole --- files. Implements high-level tests that tie together multiple modules. - -module HighLevelTests where - -import Halfs (withFSWrite, unmountFS, unmountWriteFS, withFSRead, mountFSMV, - rename, mkdir, getDirectoryContents, openFileAtPathWrite, - syncPeriodicallyWrite, - openFileAtPathRead, withNewFSWrite, unlink, openAppend, seek, - closeWrite, makeFiles, write, - fsckWrite, closeWrite, closeRead, openRead, readReadRef) -import qualified Halfs as H (read) - -import Halfs.TestFramework (Test(..), UnitTests, hunitToUnitTest, - assertCmd, assertEqual, assertBool) -import Halfs.BasicIO (devBufferReadHost, devBufferWriteHost, - getInodeWrite, getMemoryBlock) -import Binary(openBinMem, resetBin, put, get) -import Halfs.Inode (Inode(..), InodeMetadata(..), getPointerAt) -import Halfs.FSRoot (FSRoot(..)) -import Halfs.FileHandle (FileHandle(..), FileMode(WriteMode), fhCloseWrite, - fhRead, fhWrite, fhSize) -import Halfs.FSState (FSWrite, FSRW, StateHandle(..), readToWrite, unsafeLiftIOWrite, - putStrLnWriteRead, unsafeLiftIORW, evalFSWriteIOMV, - unsafeLiftIOWriteWithRoot, unsafeReadGet, unsafeLiftIORead, - runFSWriteIO, throwError, runFSReadIO, unsafeWriteGet) -import Halfs.Buffer (strToNewBuff, newBuff, buffToStrSize) -import Halfs.Blocks (getBlockFromCacheOrDeviceWrite, getDiskAddrOfBlockWrite) -import Halfs.BufferBlock(mkDiskAddressBlock, getPartBufferBlock) -import Halfs.TheBlockMap(TheBlockMap(..)) -import System.RawDevice(RawDevice, devBufferWrite, devBufferRead, newDevice) -import qualified Binary (get) -import Halfs.Utils (FileType(..), bytesPerBlock, mRemoveFile ) -import Data.Integral ( INInt, inIntToInt, intToINLong, INLong - , fromIntegral', fromIntegral'') -import Data.Word (Word8) - --- base -import System.IO(openFile, hClose, hFileSize, IOMode(ReadMode)) -import System.IO.Error (isFullError) -import System.Posix.IO (OpenMode(..), openFd, closeFd, defaultFileFlags) -import System.Posix.Files(unionFileModes, ownerReadMode, ownerWriteMode, groupReadMode) -import Control.Monad(when) -import Control.Monad.Error(throwError, catchError) -import Control.Concurrent( MVar, modifyMVar_, newEmptyMVar - , takeMVar, newMVar, putMVar - , forkIO, threadDelay) -import System.Random(randomR, getStdRandom) -import qualified Control.Exception as CE (finally) ---UNUSED:import qualified Control.Exception as CE (catch, throwIO) -import Control.Exception (finally) -import Data.Queue(queueToList) - --- ------------------------------------------------------------ --- * Interacting with host filesystem --- ------------------------------------------------------------ - --- |FIX: For now only works with file size < bufferSize. overwrites --- existing file. -copyFromHost :: FSRoot - -> FilePath -- ^From (host) - -> FilePath -- ^To (fs) - -> IO ((FileHandle, INInt), FSRoot) -copyFromHost fsroot fromPath toPath = do - fileSize <- (do h <- openFile fromPath ReadMode - s <- hFileSize h - hClose h - return s) - - hFrom <- openFd fromPath ReadWrite Nothing defaultFileFlags - putStrLn $ "copyFromHost fileSize: " ++ (show fileSize) - buffer <- openBinMem $ fromIntegral'' fileSize - devBufferReadHost hFrom 0 buffer (fromIntegral'' fileSize) - closeFd hFrom - resetBin buffer - (toFsHandle, newRoot) - <- runFSWriteIO (openFileAtPathWrite Halfs.FileHandle.WriteMode toPath File False) fsroot - runFSWriteIO (do r <- fhWrite toFsHandle buffer 0 (fromIntegral'' fileSize) - fhCloseWrite toFsHandle - return r - ) newRoot - --- |FIX: For now only works with file size < bufferSize. overwrites --- existing file. -copyToHost :: FSRoot - -> FilePath -- ^From (fs) - -> FilePath -- ^To (host) - -> IO ((FileHandle, INInt), FSRoot) -copyToHost fsroot0 fromPath toPath = do - ((fromFsHandle, bytesToCopy), fsroot1) - <- runFSReadIO (do a <- openFileAtPathRead fromPath - b <- fhSize a - return (a,b) - ) fsroot0 (\e -> throwError e) - -- FIX: do this one block at a time? may run out of memory on big files. - putStrLn $ "copyTo bin mem: " ++ (show bytesToCopy) - -- Put up with fromIntegral'' here because this is just testing code. - buffer <- openBinMem (fromIntegral'' (bytesToCopy::INLong)) - readVal@((_, numRead), _fsroot2) <- - runFSReadIO (fhRead fromFsHandle buffer 0 (fromIntegral'' bytesToCopy)) - fsroot1 (\e -> throwError e) - resetBin buffer - hTo <- openFd toPath ReadWrite (Just (foldl1 unionFileModes [ ownerReadMode - , ownerWriteMode - , groupReadMode])) - defaultFileFlags - devBufferWriteHost hTo 0 buffer (inIntToInt numRead) - closeFd hTo - return readVal - --- ------------------------------------------------------------ --- * Testing --- ------------------------------------------------------------ - --- Problem: This function doesn't properly use the mvar for --- threading. maybe I should make it impossible to get the mvar out --- without blocking... - -copyAndCheckFile :: String -> FilePath -> FilePath -> Test -copyAndCheckFile message path targetFS = - TestLabel message $ TestCase $ do - let targetNative = "tests/fromFS" - mRemoveFile targetNative - withFSWrite dirFS (unsafeLiftIOWriteWithRoot (\fsroot -> do - catchError (do - (_, fsroot1) <- copyFromHost fsroot path targetFS - unmountFS fsroot1 - ) (unmountAndThrow fsroot))) -- clean unmount - withFSWrite dirFS (unsafeLiftIOWriteWithRoot (\fsroot -> do - catchError (do - (_, fsroot1) <- copyToHost fsroot targetFS targetNative - assertCmd ("diff " ++ path ++ " " ++ targetNative) - ("fs file copy failed: " ++ message) - (_, fsroot2) <- runFSWriteIO (unlink targetFS) fsroot1 - unmountFS fsroot2 - ) (unmountAndThrow fsroot))) -- clean unmount - -unmountAndThrow :: FSRoot -> IOError -> IO () -unmountAndThrow fsroot e = unmountFS fsroot >> throwError e - -dirFS :: FilePath -dirFS = "halfs-client1" - -unitTests :: Bool -> UnitTests -unitTests runFast = hunitToUnitTest (hunitTests runFast) - -assertEqualRW :: (Eq a, Show a, FSRW m) => String -> a -> a -> m () -assertEqualRW s a b = unsafeLiftIORW $ assertEqual s a b - -assertBoolRW :: (FSRW m) => String -> Bool -> m () -assertBoolRW s b = unsafeLiftIORW $ assertBool s b - --- ------------------------------------------------------------ --- * Multi-Threaded tests --- ------------------------------------------------------------ - --- Helpers: - -addResult :: MVar [Maybe String] -> (Maybe String) -> IO () -addResult mv b = - modifyMVar_ mv (\l -> return (b:l)) - -assertMString Nothing = assertBool "" True -assertMString (Just s) = assertBool s False - -waitAll :: [MVar a] -> IO () -waitAll l = mapM_ takeMVar l - -myForkIO :: IO () -> IO (MVar ()) -myForkIO io = do - mvar <- newEmptyMVar - forkIO (io `finally` putMVar mvar ()) - return mvar - -delayRandom :: Int -- ^Max number of seconds to delay - -> IO () -delayRandom s = do - randNum <- getStdRandom (\g -> randomR (0, secondToMicroSecond s) g) - threadDelay randNum - -secondToMicroSecond n = n * 1000000 - --- TESTS -nSheeps :: Int -> FilePath -> FSWrite [Maybe String] -nSheeps n dirName = do - mkdir dirName - makeFiles n dirName "sheep" - return [Nothing] - -runTest :: MVar [Maybe String] -- ^Results - -> StateHandle - -> FSWrite [Maybe String] - -> IO (MVar ()) -runTest mv h f = - myForkIO $ do delayRandom 10 --- results <- CE.catch (evalFSWriteIOMV f h) --- (\e -> addResult mv (Just (show e)) --- >> CE.throwIO e) - results <- evalFSWriteIOMV f h - mapM_ (addResult mv) results - --- |Doesn't block on outer blocker. -runTest' :: MVar [Maybe String] -- ^Results - -> MVar FSRoot - -> FSWrite [Maybe String] - -> IO (MVar ()) -runTest' mv h f = - myForkIO $ do delayRandom 10 - results <- evalFSWriteIOMV f (StateHandle h Nothing) - mapM_ (addResult mv) results - --- Controller: - -multiThreadTests :: Bool -> Test -multiThreadTests runFast = - TestLabel ("multi-thread tests") $ TestCase $ do - blocker <- newMVar () - -- should fork off a sync thread: - stateHandle@(StateHandle smallMv _) - <- mountFSMV Nothing dirFS (Just blocker) False 500 - resultsMV <- newMVar [] - - let rt = runTest resultsMV stateHandle - let rt' = runTest' resultsMV smallMv - let (sheepThreads, extraThreads, syncThreads) - = if runFast - then (50, 50, 1) - else (300, 100, 5) - -- many threads, grab the nSheep mvar many times and make only 4 dirs each. - waitOn2 <- mapM rt [nSheeps 2 ("/sheeps" ++ (show n)) | n <- [1..sheepThreads] ] - - -- 50 fsck threads - waitOn3 <- mapM rt (replicate extraThreads (fsckWrite >> return [Nothing])) - waitOnSync <- mapM rt' (replicate syncThreads (syncPeriodicallyWrite blocker False - >> return [Nothing])) - - waitOn1 <- mapM rt [ fsckWrite >> return [Nothing] - , nSheeps extraThreads "/sheeps" -- grabs mvar only once. - , fsckWrite >> return [Nothing] - ] - - waitAll $ concat [waitOn1, waitOn2, waitOn3] - - evalFSWriteIOMV unmountWriteFS stateHandle - -- the sync thread won't die 'till we unmount. - waitAll waitOnSync - - results <- takeMVar resultsMV - mapM assertMString results - putStrLn "unmounting" - return () - - --- ------------------------------------------------------------ --- * Block-level atomicity tests --- ------------------------------------------------------------ - -toggle :: Word8 -> Word8 -toggle 0 = 1 -toggle 1 = 0 -toggle 3 = 4 -toggle 4 = 3 -toggle n = (n-1) - -writer :: RawDevice -> Word8 -> Int -> IO () -writer lowDev n timeLeft - | timeLeft <= 0 = return () - | otherwise = do - let word8s = replicate bytesPerBlock (n::Word8) - block <- getMemoryBlock - mapM (put block) word8s - resetBin block - devBufferWrite lowDev 1 block - writer lowDev (toggle n) (timeLeft - 1) - -reader lowDev timeLeft - | timeLeft <= 0 = return () - | otherwise = do - block <- getMemoryBlock - devBufferRead lowDev 1 block - resetBin block - ((h::Word8):words) <- sequence $ replicate bytesPerBlock (get block) - let allEq = and [h == w | w <- words] - assertBool ("Failure in test for block-level atomicity at timeLeft = " ++ - show timeLeft ++ ": " ++ - show (h:words)) - allEq - reader lowDev (timeLeft - 1) - -testBuffs :: Test -testBuffs = TestLabel ("block-level atomicity tests") $ TestCase $ do - lowDev <- newDevice Nothing "halfs-client1" 2 - -- highDev <- makeRawDevice "halfs-4EYES" - -- make block uniform before any read operations - writer lowDev 1 1 - let numIterations = 100 - waitWriters <- mapM myForkIO [ writer lowDev 1 numIterations - , writer lowDev 0 numIterations - , writer lowDev 3 numIterations - , writer lowDev 4 numIterations] - - threadDelay (secondToMicroSecond 2) - waitReaders <- mapM myForkIO (replicate 5 (reader lowDev numIterations)) - - waitAll $ concat [waitWriters, waitReaders] - --- ------------------------------------------------------------ --- * Collection of tests --- ------------------------------------------------------------ - -slowTests = [testBuffs] - - -hunitTests :: Bool -- ^run fast? - -> [Test] -hunitTests runFast = (if runFast then [] else slowTests) ++ - [TestLabel "shell.hs: mkdir tmp" $ TestCase $ do - withNewFSWrite dirFS 5000 (mkdir "/tmp" >> unmountWriteFS) - ,(multiThreadTests runFast) - ,copyAndCheckFile "one-block file" "tests/from" "/tmp/toNative" - ,copyAndCheckFile "small file" "tests/smallFile" "/tmp/smallFile" - ,copyAndCheckFile "small file 2" "tests/smallFile" "/tmp/smallFile" - ,copyAndCheckFile "multi-block file" "tests/multiBlockFile" "/tmp/multiBlockFile" - ,copyAndCheckFile "level-2 file" "tests/70KFile" "/70KFile" - ,TestLabel "move" $ TestCase $ do - withFSWrite dirFS (unsafeLiftIOWriteWithRoot (\fsroot -> do - (_, fsroot) <- copyFromHost fsroot "tests/multiBlockFile" "/tmp/multiBlockFile" - unmountFS fsroot)) - - withFSWrite dirFS (do - let ls = readToWrite . getDirectoryContents - ls "/tmp" >>= assertEqualRW "tmp dir has files we created" - [".", "multiBlockFile"] - rename "/tmp/multiBlockFile" "/tmp/multiBlockFile2" - ls "/tmp" >>= assertEqualRW "ls after a move" - [".", "multiBlockFile2"] - unmountWriteFS - ) - ] diff --git a/LGPL b/LGPL deleted file mode 100644 --- a/LGPL +++ /dev/null @@ -1,510 +0,0 @@ - - GNU LESSER GENERAL PUBLIC LICENSE - Version 2.1, February 1999 - - Copyright (C) 1991, 1999 Free Software Foundation, Inc. - 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - -[This is the first released version of the Lesser GPL. It also counts - as the successor of the GNU Library Public License, version 2, hence - the version number 2.1.] - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -Licenses are intended to guarantee your freedom to share and change -free software--to make sure the software is free for all its users. - - This license, the Lesser General Public License, applies to some -specially designated software packages--typically libraries--of the -Free Software Foundation and other authors who decide to use it. You -can use it too, but we suggest you first think carefully about whether -this license or the ordinary General Public License is the better -strategy to use in any particular case, based on the explanations -below. - - When we speak of free software, we are referring to freedom of use, -not price. Our General Public Licenses are designed to make sure that -you have the freedom to distribute copies of free software (and charge -for this service if you wish); that you receive source code or can get -it if you want it; that you can change the software and use pieces of -it in new free programs; and that you are informed that you can do -these things. - - To protect your rights, we need to make restrictions that forbid -distributors to deny you these rights or to ask you to surrender these -rights. These restrictions translate to certain responsibilities for -you if you distribute copies of the library or if you modify it. - - For example, if you distribute copies of the library, whether gratis -or for a fee, you must give the recipients all the rights that we gave -you. You must make sure that they, too, receive or can get the source -code. If you link other code with the library, you must provide -complete object files to the recipients, so that they can relink them -with the library after making changes to the library and recompiling -it. And you must show them these terms so they know their rights. - - We protect your rights with a two-step method: (1) we copyright the -library, and (2) we offer you this license, which gives you legal -permission to copy, distribute and/or modify the library. - - To protect each distributor, we want to make it very clear that -there is no warranty for the free library. Also, if the library is -modified by someone else and passed on, the recipients should know -that what they have is not the original version, so that the original -author's reputation will not be affected by problems that might be -introduced by others. - - Finally, software patents pose a constant threat to the existence of -any free program. We wish to make sure that a company cannot -effectively restrict the users of a free program by obtaining a -restrictive license from a patent holder. Therefore, we insist that -any patent license obtained for a version of the library must be -consistent with the full freedom of use specified in this license. - - Most GNU software, including some libraries, is covered by the -ordinary GNU General Public License. This license, the GNU Lesser -General Public License, applies to certain designated libraries, and -is quite different from the ordinary General Public License. We use -this license for certain libraries in order to permit linking those -libraries into non-free programs. - - When a program is linked with a library, whether statically or using -a shared library, the combination of the two is legally speaking a -combined work, a derivative of the original library. The ordinary -General Public License therefore permits such linking only if the -entire combination fits its criteria of freedom. The Lesser General -Public License permits more lax criteria for linking other code with -the library. - - We call this license the "Lesser" General Public License because it -does Less to protect the user's freedom than the ordinary General -Public License. It also provides other free software developers Less -of an advantage over competing non-free programs. These disadvantages -are the reason we use the ordinary General Public License for many -libraries. However, the Lesser license provides advantages in certain -special circumstances. - - For example, on rare occasions, there may be a special need to -encourage the widest possible use of a certain library, so that it -becomes a de-facto standard. To achieve this, non-free programs must -be allowed to use the library. A more frequent case is that a free -library does the same job as widely used non-free libraries. In this -case, there is little to gain by limiting the free library to free -software only, so we use the Lesser General Public License. - - In other cases, permission to use a particular library in non-free -programs enables a greater number of people to use a large body of -free software. For example, permission to use the GNU C Library in -non-free programs enables many more people to use the whole GNU -operating system, as well as its variant, the GNU/Linux operating -system. - - Although the Lesser General Public License is Less protective of the -users' freedom, it does ensure that the user of a program that is -linked with the Library has the freedom and the wherewithal to run -that program using a modified version of the Library. - - The precise terms and conditions for copying, distribution and -modification follow. Pay close attention to the difference between a -"work based on the library" and a "work that uses the library". The -former contains code derived from the library, whereas the latter must -be combined with the library in order to run. - - GNU LESSER GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License Agreement applies to any software library or other -program which contains a notice placed by the copyright holder or -other authorized party saying it may be distributed under the terms of -this Lesser General Public License (also called "this License"). -Each licensee is addressed as "you". - - A "library" means a collection of software functions and/or data -prepared so as to be conveniently linked with application programs -(which use some of those functions and data) to form executables. - - The "Library", below, refers to any such software library or work -which has been distributed under these terms. A "work based on the -Library" means either the Library or any derivative work under -copyright law: that is to say, a work containing the Library or a -portion of it, either verbatim or with modifications and/or translated -straightforwardly into another language. (Hereinafter, translation is -included without limitation in the term "modification".) - - "Source code" for a work means the preferred form of the work for -making modifications to it. For a library, complete source code means -all the source code for all modules it contains, plus any associated -interface definition files, plus the scripts used to control -compilation and installation of the library. - - Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running a program using the Library is not restricted, and output from -such a program is covered only if its contents constitute a work based -on the Library (independent of the use of the Library in a tool for -writing it). Whether that is true depends on what the Library does -and what the program that uses the Library does. - - 1. You may copy and distribute verbatim copies of the Library's -complete source code as you receive it, in any medium, provided that -you conspicuously and appropriately publish on each copy an -appropriate copyright notice and disclaimer of warranty; keep intact -all the notices that refer to this License and to the absence of any -warranty; and distribute a copy of this License along with the -Library. - - You may charge a fee for the physical act of transferring a copy, -and you may at your option offer warranty protection in exchange for a -fee. - - 2. You may modify your copy or copies of the Library or any portion -of it, thus forming a work based on the Library, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) The modified work must itself be a software library. - - b) You must cause the files modified to carry prominent notices - stating that you changed the files and the date of any change. - - c) You must cause the whole of the work to be licensed at no - charge to all third parties under the terms of this License. - - d) If a facility in the modified Library refers to a function or a - table of data to be supplied by an application program that uses - the facility, other than as an argument passed when the facility - is invoked, then you must make a good faith effort to ensure that, - in the event an application does not supply such function or - table, the facility still operates, and performs whatever part of - its purpose remains meaningful. - - (For example, a function in a library to compute square roots has - a purpose that is entirely well-defined independent of the - application. Therefore, Subsection 2d requires that any - application-supplied function or table used by this function must - be optional: if the application does not supply it, the square - root function must still compute square roots.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Library, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Library, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote -it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Library. - -In addition, mere aggregation of another work not based on the Library -with the Library (or with a work based on the Library) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may opt to apply the terms of the ordinary GNU General Public -License instead of this License to a given copy of the Library. To do -this, you must alter all the notices that refer to this License, so -that they refer to the ordinary GNU General Public License, version 2, -instead of to this License. (If a newer version than version 2 of the -ordinary GNU General Public License has appeared, then you can specify -that version instead if you wish.) Do not make any other change in -these notices. - - Once this change is made in a given copy, it is irreversible for -that copy, so the ordinary GNU General Public License applies to all -subsequent copies and derivative works made from that copy. - - This option is useful when you wish to copy part of the code of -the Library into a program that is not a library. - - 4. You may copy and distribute the Library (or a portion or -derivative of it, under Section 2) in object code or executable form -under the terms of Sections 1 and 2 above provided that you accompany -it with the complete corresponding machine-readable source code, which -must be distributed under the terms of Sections 1 and 2 above on a -medium customarily used for software interchange. - - If distribution of object code is made by offering access to copy -from a designated place, then offering equivalent access to copy the -source code from the same place satisfies the requirement to -distribute the source code, even though third parties are not -compelled to copy the source along with the object code. - - 5. A program that contains no derivative of any portion of the -Library, but is designed to work with the Library by being compiled or -linked with it, is called a "work that uses the Library". Such a -work, in isolation, is not a derivative work of the Library, and -therefore falls outside the scope of this License. - - However, linking a "work that uses the Library" with the Library -creates an executable that is a derivative of the Library (because it -contains portions of the Library), rather than a "work that uses the -library". The executable is therefore covered by this License. -Section 6 states terms for distribution of such executables. - - When a "work that uses the Library" uses material from a header file -that is part of the Library, the object code for the work may be a -derivative work of the Library even though the source code is not. -Whether this is true is especially significant if the work can be -linked without the Library, or if the work is itself a library. The -threshold for this to be true is not precisely defined by law. - - If such an object file uses only numerical parameters, data -structure layouts and accessors, and small macros and small inline -functions (ten lines or less in length), then the use of the object -file is unrestricted, regardless of whether it is legally a derivative -work. (Executables containing this object code plus portions of the -Library will still fall under Section 6.) - - Otherwise, if the work is a derivative of the Library, you may -distribute the object code for the work under the terms of Section 6. -Any executables containing that work also fall under Section 6, -whether or not they are linked directly with the Library itself. - - 6. As an exception to the Sections above, you may also combine or -link a "work that uses the Library" with the Library to produce a -work containing portions of the Library, and distribute that work -under terms of your choice, provided that the terms permit -modification of the work for the customer's own use and reverse -engineering for debugging such modifications. - - You must give prominent notice with each copy of the work that the -Library is used in it and that the Library and its use are covered by -this License. You must supply a copy of this License. If the work -during execution displays copyright notices, you must include the -copyright notice for the Library among them, as well as a reference -directing the user to the copy of this License. Also, you must do one -of these things: - - a) Accompany the work with the complete corresponding - machine-readable source code for the Library including whatever - changes were used in the work (which must be distributed under - Sections 1 and 2 above); and, if the work is an executable linked - with the Library, with the complete machine-readable "work that - uses the Library", as object code and/or source code, so that the - user can modify the Library and then relink to produce a modified - executable containing the modified Library. (It is understood - that the user who changes the contents of definitions files in the - Library will not necessarily be able to recompile the application - to use the modified definitions.) - - b) Use a suitable shared library mechanism for linking with the - Library. A suitable mechanism is one that (1) uses at run time a - copy of the library already present on the user's computer system, - rather than copying library functions into the executable, and (2) - will operate properly with a modified version of the library, if - the user installs one, as long as the modified version is - interface-compatible with the version that the work was made with. - - c) Accompany the work with a written offer, valid for at least - three years, to give the same user the materials specified in - Subsection 6a, above, for a charge no more than the cost of - performing this distribution. - - d) If distribution of the work is made by offering access to copy - from a designated place, offer equivalent access to copy the above - specified materials from the same place. - - e) Verify that the user has already received a copy of these - materials or that you have already sent this user a copy. - - For an executable, the required form of the "work that uses the -Library" must include any data and utility programs needed for -reproducing the executable from it. However, as a special exception, -the materials to be distributed need not include anything that is -normally distributed (in either source or binary form) with the major -components (compiler, kernel, and so on) of the operating system on -which the executable runs, unless that component itself accompanies -the executable. - - It may happen that this requirement contradicts the license -restrictions of other proprietary libraries that do not normally -accompany the operating system. Such a contradiction means you cannot -use both them and the Library together in an executable that you -distribute. - - 7. You may place library facilities that are a work based on the -Library side-by-side in a single library together with other library -facilities not covered by this License, and distribute such a combined -library, provided that the separate distribution of the work based on -the Library and of the other library facilities is otherwise -permitted, and provided that you do these two things: - - a) Accompany the combined library with a copy of the same work - based on the Library, uncombined with any other library - facilities. This must be distributed under the terms of the - Sections above. - - b) Give prominent notice with the combined library of the fact - that part of it is a work based on the Library, and explaining - where to find the accompanying uncombined form of the same work. - - 8. You may not copy, modify, sublicense, link with, or distribute -the Library except as expressly provided under this License. Any -attempt otherwise to copy, modify, sublicense, link with, or -distribute the Library is void, and will automatically terminate your -rights under this License. However, parties who have received copies, -or rights, from you under this License will not have their licenses -terminated so long as such parties remain in full compliance. - - 9. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Library or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Library (or any work based on the -Library), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Library or works based on it. - - 10. Each time you redistribute the Library (or any work based on the -Library), the recipient automatically receives a license from the -original licensor to copy, distribute, link with or modify the Library -subject to these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties with -this License. - - 11. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Library at all. For example, if a patent -license would not permit royalty-free redistribution of the Library by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Library. - -If any portion of this section is held invalid or unenforceable under -any particular circumstance, the balance of the section is intended to -apply, and the section as a whole is intended to apply in other -circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 12. If the distribution and/or use of the Library is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Library under this License -may add an explicit geographical distribution limitation excluding those -countries, so that distribution is permitted only in or among -countries not thus excluded. In such case, this License incorporates -the limitation as if written in the body of this License. - - 13. The Free Software Foundation may publish revised and/or new -versions of the Lesser General Public License from time to time. -Such new versions will be similar in spirit to the present version, -but may differ in detail to address new problems or concerns. - -Each version is given a distinguishing version number. If the Library -specifies a version number of this License which applies to it and -"any later version", you have the option of following the terms and -conditions either of that version or of any later version published by -the Free Software Foundation. If the Library does not specify a -license version number, you may choose any version ever published by -the Free Software Foundation. - - 14. If you wish to incorporate parts of the Library into other free -programs whose distribution conditions are incompatible with these, -write to the author to ask for permission. For software which is -copyrighted by the Free Software Foundation, write to the Free -Software Foundation; we sometimes make exceptions for this. Our -decision will be guided by the two goals of preserving the free status -of all derivatives of our free software and of promoting the sharing -and reuse of software generally. - - NO WARRANTY - - 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO -WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. -EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR -OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY -KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE -LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME -THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN -WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY -AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU -FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR -CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE -LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING -RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A -FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF -SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH -DAMAGES. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Libraries - - If you develop a new library, and you want it to be of the greatest -possible use to the public, we recommend making it free software that -everyone can redistribute and change. You can do so by permitting -redistribution under these terms (or, alternatively, under the terms -of the ordinary General Public License). - - To apply these terms, attach the following notices to the library. -It is safest to attach them to the start of each source file to most -effectively convey the exclusion of warranty; and each file should -have at least the "copyright" line and a pointer to where the full -notice is found. - - - - Copyright (C) - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library 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 - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA - -Also add information on how to contact you by electronic and paper mail. - -You should also get your employer (if you work as a programmer) or -your school, if any, to sign a "copyright disclaimer" for the library, -if necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the - library `Frob' (a library for tweaking knobs) written by James - Random Hacker. - - , 1 April 1990 - Ty Coon, President of Vice - -That's all there is to it! - - diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) Galois, Inc. 2009 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/ModuleTest.hs b/ModuleTest.hs deleted file mode 100644 --- a/ModuleTest.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Main where - -import Test.HUnit (Counts(..), showCounts) -import qualified Halfs (unitTests) -import qualified HighLevelTests (unitTests) -import qualified Halfs.FileHandle (unitTests) -import qualified Halfs.BasicIO (unitTests) -import qualified Halfs.TheBlockMap (unitTests) -import Halfs.TestFramework - --- base -import Control.Monad.Error(catchError) -import System.Environment(getArgs) -import System.Exit(exitWith, ExitCode(..)) - -main' :: IO () -main' = do - args <- getArgs - let runFast = case args of - ("--fast":_) -> True - _ -> False - counts <- catchError - (runAllTests (Halfs.FileHandle.unitTests - ++ (HighLevelTests.unitTests runFast) - ++ Halfs.TheBlockMap.unitTests - ++ (Halfs.unitTests runFast) - ++ Halfs.BasicIO.unitTests)) - (\ e -> error "error") - putStrLn "---------" - putStrLn "Test Summary (may not include QC tests!):" - let allCounts@(Counts _ _ fails errs) = foldl1 combineCounts counts - putStrLn $ showCounts allCounts - if (fails > 0 || errs > 0) - then exitWith (ExitFailure (fails + errs)) - else exitWith ExitSuccess - - -main :: IO () -main = let handler = (\e -> putStrLn "blah3" >> print e >> error "woot") - in catch (catchError main' handler) handler diff --git a/NewFS.hs b/NewFS.hs deleted file mode 100644 --- a/NewFS.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# OPTIONS -cpp #-} -module Main where -import Halfs (newFS) ---import System.Posix.Directory (changeWorkingDirectory) -import System.Environment(getArgs) - -main :: IO () -main = do - a <- getArgs - case a of - [wd, size] -> do newFS wd (read size) - putStrLn $ "Created new filesystem at: " ++ (show wd) - return () - _ -> putStrLn "usage: newHalfsFS path/to/device sizeInBlocks" - --- getWorkingDirectory :: IO FilePath --- changeWorkingDirectory :: FilePath -> IO () diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,5 +1,7 @@ -#!/usr/bin/runhaskell +module Main (main) where import Distribution.Simple -main = defaultMainWithHooks defaultUserHooks +main :: IO () +main = defaultMain + diff --git a/System/Device/BlockDevice.hs b/System/Device/BlockDevice.hs new file mode 100644 --- /dev/null +++ b/System/Device/BlockDevice.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +module System.Device.BlockDevice( + BlockDevice(..) + , BCM + , newCachedBlockDevice + , newRescaledBlockDevice + , runBCM + ) + where + +import Control.Monad.State.Strict +import Data.ByteString(ByteString) +import qualified Data.ByteString as BS +import Data.Map(Map) +import qualified Data.Map as Map +import Data.Word + +-- |The data type that describes the interface to a BlockDevice. If you can +-- fill this out reasonably, you can be a file system backend. +data BlockDevice m = BlockDevice { + -- |The size of the smallest read/write block for the device, in bytes. + bdBlockSize :: Word64 + -- |The number of blocks in the device. + , bdNumBlocks :: Word64 + -- |Read a the given block number for the device, where block numbers run + -- from 0 to (bdNumBlocks - 1). Smart / paranoid block device implementers + -- should probably verify their inputs, just in case ... + , bdReadBlock :: Word64 -> m ByteString + -- |Write a given block to the given block number. See the note for + -- bdReadBlock for indexing and paranoia information. + , bdWriteBlock :: Word64 -> ByteString -> m () + -- |Force any unfinished writes to be written to disk. + , bdFlush :: m () + -- |Shutdown the device cleanly. + , bdShutdown :: m () + } + +-- ---------------------------------------------------------------------------- +-- +-- Wrapper that will rescale blocks to a more appropriate size. Note that +-- doing this will require that the desired block size is a multiple of the +-- underlying block size. +-- +-- ---------------------------------------------------------------------------- + +-- |Create a new block device that rescales the block size of the underlying +-- device. This is helpful if, for example, your underlying device has a block +-- size of 512 bytes but you want to deal with it in terms of blocks of 4k. +-- +-- Note that this returns a Maybe because it requires that the desired block +-- size be a multiple of the underlying block size. Also note that the +-- resulting block device may be smaller than the original block device, if +-- (bdNumBlocks old `mod` (bdBlockSize new `div` bdBlockSize old)) != 0 +newRescaledBlockDevice :: Monad m => + Word64 -> BlockDevice m -> + Maybe (BlockDevice m) +newRescaledBlockDevice bsize dev + | bsize `mod` bdBlockSize dev /= 0 = Nothing + | otherwise = Just res + where + res = dev { + bdBlockSize = bsize + , bdNumBlocks = blocks + , bdReadBlock = readBlock + , bdWriteBlock = writeBlock + } + oldbs = fromIntegral $! bdBlockSize dev + ratio = bsize `div` bdBlockSize dev + blocks = bdNumBlocks dev `div` ratio + readBlock i = liftM BS.concat $ forM [start..end] (bdReadBlock dev) + where start = i * ratio; end = (i+1) * ratio - 1 + writeBlock i b = write (i * ratio) b + -- + write i b | BS.null b = return () + | otherwise = do let (start, rest) = BS.splitAt oldbs b + bdWriteBlock dev i start + write (i + 1) rest + + +-- ---------------------------------------------------------------------------- +-- +-- Wrapper for automatically caching block reads and writes +-- +-- ---------------------------------------------------------------------------- + +type BCM m = StateT CacheState m +type BlockMap = Map Word64 (ByteString, Bool, Word64) + +data CacheState = BCS { + _cache :: BlockMap + , _timestamp :: Word64 + } + +-- |Given an existing block device, creates a new block device that will cache +-- reads and writes. +newCachedBlockDevice :: Monad m => Int -> BlockDevice m -> BlockDevice (BCM m) +newCachedBlockDevice size dev = dev { + bdReadBlock = readBlock + , bdWriteBlock = writeBlock + , bdFlush = flush + , bdShutdown = lift $ bdShutdown dev + } + where + readBlock i = runCacheOp $ \ cache ts -> + case Map.lookup i cache of + Just (res, dirty ,_) -> do + return (Map.insert i (res, dirty, ts) cache, res) + Nothing -> do + cache' <- if cacheFull cache + then evictEntry cache dev + else return cache + b <- lift $ bdReadBlock dev i + return (Map.insert i (b,False,ts) cache', b) + writeBlock i b = runCacheOp $ \ cache ts -> + case Map.lookup i cache of + Just _ -> + return (Map.insert i (b, True, ts) cache, ()) + Nothing -> do + cache' <- if cacheFull cache + then evictEntry cache dev + else return cache + return (Map.insert i (b, True, ts) cache', ()) + flush = do BCS cache _ <- get + forM_ (Map.toList cache) $ \ (i, (block, dirty, _)) -> + when dirty $ do + lift $ bdWriteBlock dev i block + -- + cacheFull m = Map.size m >= size + +-- |Run something in the BlockCache monad. +runBCM :: Monad m => BCM m a -> m a +runBCM m = evalStateT m (BCS Map.empty 0) + +-- Run an operation that does something with the cache. +runCacheOp :: Monad m => + (BlockMap -> Word64 -> BCM m (BlockMap, a)) -> + BCM m a +runCacheOp f = do + BCS mp ts <- get + (mp', res) <- f mp ts + put (BCS mp' (ts + 1)) + return res + +-- Evict the oldest entry from the Cache +evictEntry :: Monad m => BlockMap -> BlockDevice m -> BCM m BlockMap +evictEntry m d + | oldestEntry == maxBound = fail "Your cache state has gone insane!" + | dirty = do lift $ bdWriteBlock d oldestEntry block + return $! Map.delete oldestEntry m + | otherwise = return $! Map.delete oldestEntry m + where + (oldestEntry, (block, dirty, _)) = + Map.foldrWithKey (\ i igrp@(_, _, its) old@(_, (_, _, jts)) -> + if its < jts then (i, igrp) else old) + (maxBound, (undefined, undefined, maxBound)) + m diff --git a/System/Device/File.hs b/System/Device/File.hs new file mode 100644 --- /dev/null +++ b/System/Device/File.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE BangPatterns #-} +module System.Device.File( + newFileBlockDevice + ) + where + +import qualified Data.ByteString as BS +import Data.Word +import System.IO + +import System.Device.BlockDevice + +-- |Use an existing file (specified by the first argument) as a block device. +-- The second argument is the block size for the pseudo-disk. +newFileBlockDevice :: FilePath -> Word64 -> IO (Maybe (BlockDevice IO)) +newFileBlockDevice fname secSize = do + hndl <- openFile fname ReadWriteMode + sizeBytes <- hFileSize hndl + let numBlocks = fromIntegral sizeBytes `div` secSize + return $! Just BlockDevice { + bdBlockSize = secSize + , bdNumBlocks = numBlocks + , bdReadBlock = \ i -> do + hSeek hndl AbsoluteSeek (fromIntegral $ i * secSize) + v <- BS.hGet hndl secSizeInt + let v' = BS.take secSize64 $ v `BS.append` empty + return v' + , bdWriteBlock = \ i !v -> do + let v' = BS.take secSize64 $ v `BS.append` empty + hSeek hndl AbsoluteSeek (fromIntegral $ i * secSize) + BS.hPut hndl v' + , bdFlush = hFlush hndl + , bdShutdown = hClose hndl + } + where + secSizeI = fromIntegral secSize + secSizeInt = fromIntegral secSize + secSize64 = fromIntegral secSize + empty = BS.replicate secSizeI 0 diff --git a/System/Device/Memory.hs b/System/Device/Memory.hs new file mode 100644 --- /dev/null +++ b/System/Device/Memory.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +module System.Device.Memory( + newMemoryBlockDevice + ) + where + +import Data.Array.IO +import Data.ByteString(ByteString) +import qualified Data.ByteString as BS +import Data.Word + +import System.Device.BlockDevice + +-- Create a new in-memory block device, with the given number of +-- sectors and sector size. +newMemoryBlockDevice :: Word64 -> Word64 -> IO (Maybe (BlockDevice IO)) +newMemoryBlockDevice numSectors sectorSize + | mostW <= sectorSize = return Nothing + | otherwise = do + arr :: IOArray Word64 ByteString <- newArray (0, numSectors - 1) empty + return $! Just BlockDevice { + bdBlockSize = sectorSize + , bdNumBlocks = numSectors + , bdReadBlock = \ i -> readArray arr i + , bdWriteBlock = \ i !v -> do + let v' = BS.take secSize64 $ v `BS.append` empty + writeArray arr i v' + , bdFlush = return () + , bdShutdown = return () -- JS: was 'undefined' for a reason? + } + where + mostW = fromIntegral (maxBound :: Int) + secSizeI = fromIntegral sectorSize + secSize64 = fromIntegral sectorSize + empty = BS.replicate secSizeI 0 diff --git a/System/Device/ST.hs b/System/Device/ST.hs new file mode 100644 --- /dev/null +++ b/System/Device/ST.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +module System.Device.ST( + newSTBlockDevice + ) + where + +import Control.Monad.ST +import Data.Array.ST +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Word + +import System.Device.BlockDevice + +-- Create a new in-memory block device in ST, with the given number of +-- sectors and sector size. +newSTBlockDevice :: forall s. Word64 -> Word64 -> ST s (Maybe (BlockDevice (ST s))) +newSTBlockDevice numSectors sectorSize + | mostW <= sectorSize = return Nothing + | otherwise = do + arr <- buildArray + return $! Just BlockDevice { + bdBlockSize = sectorSize + , bdNumBlocks = numSectors + , bdReadBlock = \ i -> readArray arr i + , bdWriteBlock = \ i !v -> do + let v' = BS.take secSize64 $ v `BS.append` empty + writeArray arr i v' + , bdFlush = return () + , bdShutdown = return () -- JS: was 'undefined' for a reason? + } + where + mostW = fromIntegral (maxBound :: Int) + secSizeI = fromIntegral sectorSize + secSize64 = fromIntegral sectorSize + buildArray :: ST s (STArray s Word64 ByteString) + buildArray = newArray (0, numSectors - 1) empty + empty = BS.replicate secSizeI 0 diff --git a/System/RawDevice.hs b/System/RawDevice.hs deleted file mode 100644 --- a/System/RawDevice.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# OPTIONS -cpp #-} ------------------------------------------------------------------------------ --- | --- Module : System.RawDevice --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : GHC --- --- Imports whatever RawDevice module we actually want. - -module System.RawDevice - ( RawDevice -- no constructor - , makeRawDevice - , blocksInDevice - , finalizeDevice - , newDevice - , devBufferRead - , devBufferWrite - , BufferBlockHandle - , newBufferBlockHandle - , checkBufferBlockHandleSize - , zeroBufferBlockHandle - , invalidateBufferBlockHandle - ) where - -import System.RawDevice.File - ( RawDevice -- no constructor - , makeRawDevice - , blocksInDevice - , finalizeDevice - , newDevice - , devBufferWrite - ) - -import System.RawDevice.File (devBufferRead) -import System.RawDevice.Base (BufferBlockHandle, newBufferBlockHandle, checkBufferBlockHandleSize, - zeroBufferBlockHandle, invalidateBufferBlockHandle) --- import Control.Concurrent (readMVar) --- import Control.Monad.Error(throwError) --- import System.IO.Error (mkIOError, fullErrorType) diff --git a/System/RawDevice/Base.hs b/System/RawDevice/Base.hs deleted file mode 100644 --- a/System/RawDevice/Base.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : System.RawDevice.Base --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : GHC --- -module System.RawDevice.Base - ( DiskAddress - , BlockNumber - - , bytesPerBlock - , locationOfBlock - , BufferBlockHandle - , newBufferBlockHandle - , checkBufferBlockHandleSize - , zeroBufferBlockHandle - , invalidateBufferBlockHandle - ) where - -import Data.Integral -import Binary -import Control.Exception(assert) -import Data.Array.SysArray -import Foreign.Marshal.Alloc(mallocBytes) - --- |Represents the number of the physical block on disk. -type DiskAddress = INInt - --- |nth block within a file -type BlockNumber = INInt - -bytesPerBlock :: Int -bytesPerBlock = 4096 - -locationOfBlock :: DiskAddress -> Bin Int -locationOfBlock blockNum = BinPtr $ (inIntToInt blockNum) * bytesPerBlock - -newtype BufferBlockHandle s = BufferBlockHandle FixedSysHandle - deriving (BinaryHandle) - -newBufferBlockHandle :: IO (BufferBlockHandle s) -newBufferBlockHandle = do - ptr <- mallocBytes bytesPerBlock - let arr = mkSysArray (fromIntegral bytesPerBlock) ptr False - buf <- openFixedSysHandle arr - return $ BufferBlockHandle buf - -checkBufferBlockHandleSize :: BufferBlockHandle s -> IO () -checkBufferBlockHandleSize (BufferBlockHandle fixed) = do - size <- sizeFixedSysMem fixed - assert (size == bytesPerBlock) $ return () - -zeroBufferBlockHandle :: BufferBlockHandle s -> IO () -zeroBufferBlockHandle (BufferBlockHandle fixed) = zeroFixedSysHandle fixed - -invalidateBufferBlockHandle :: BufferBlockHandle s -> IO () -invalidateBufferBlockHandle (BufferBlockHandle fixed) = invalidateFixedSysMem fixed diff --git a/System/RawDevice/File.hs b/System/RawDevice/File.hs deleted file mode 100644 --- a/System/RawDevice/File.hs +++ /dev/null @@ -1,146 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : System.RawDevice.File --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : GHC --- --- Explanation: A raw device which can be opened, read from, and --- written to. In the basic Halfs filesystem, this is just a file. - -module System.RawDevice.File - ( RawDevice -- no constructor - , makeRawDevice - , blocksInDevice - , finalizeDevice - , newDevice - , devBufferRead - , devBufferWrite - ) where - -import Control.Exception(assert) --- import Control.Concurrent(MVar, newMVar) -import System.IO(SeekMode(AbsoluteSeek), hFileSize) -import System.Directory(doesFileExist) -import System.Posix.IO(openFd, closeFd, defaultFileFlags, - OpenMode(..), fdWrite, fdSeek) -import Data.Integral ( INInt, intToINInt, fromIntegral'' ) -import System.RawDevice.Base ( DiskAddress, bytesPerBlock, locationOfBlock, BufferBlockHandle,checkBufferBlockHandleSize ) -import Binary(openBinIO, copyBytes, seekBin, resetBin) - -import System.Posix.Internals (fdGetMode, FDType(RegularFile)) -import System.Posix.Files(unionFileModes, ownerReadMode, ownerWriteMode, groupReadMode) -import System.Posix.Types (Fd(Fd)) -import qualified GHC.Handle -import GHC.IOBase - --- import Network.BSD --- import Network.Socket - -data RawDevice = RawDevice {rawDevPath :: FilePath - ,rawDevHandle :: Fd - } - -instance Ord RawDevice where - compare (RawDevice{rawDevPath=f1}) (RawDevice{rawDevPath=f2}) - = compare f1 f2 - -instance Eq RawDevice where - (==) (RawDevice{rawDevPath=f1}) (RawDevice{rawDevPath=f2}) - = f1 == f2 - -instance Show RawDevice where - show rd = "dev_" ++ rawDevPath rd - ------------------------------------------------------------- -fdToHandle2 :: Fd -> IO Handle -fdToHandle2 (Fd fd) = do - -- can't avoid fromIntegral'' because of the types returned by these functions - let fd' = fromIntegral'' fd - mode <- fdGetMode fd' - let fd_str = "" --- h <- GHC.Handle.openFd fd' (Just RegularFile) False fd_str mode True{-bin --- mode-} - h <- GHC.Handle.fdToHandle' fd' (Just RegularFile) False fd_str mode True{-bin mode-} - - return h - --- |Smart constructor for a raw device. Opens this file as a device, --- but does not initialize a filesystem on it or anything like that. --- FIX: just for testing... -makeRawDevice :: Maybe RawDevice - -> FilePath -- or whatever - -> IO RawDevice -makeRawDevice _ path = do - fd <- openFd path ReadWrite Nothing defaultFileFlags - return $ - RawDevice { rawDevPath = path - , rawDevHandle = fd - } - --- newDevice _ = newDevice' "/tmp/foo" Always returns Just FIX: just for testing... -newDevice :: Maybe RawDevice - -> FilePath -- ^Or whatever - -> INInt -- ^length in blocks - -> IO RawDevice -newDevice _ path fileLen = do --- let path = "/tmp/blah/disk.data-1" -- ptg - existsP <- doesFileExist path - fd <- if existsP - then openFd path ReadWrite Nothing defaultFileFlags - else openFd path -- creates it: - ReadWrite - (Just (foldl1 unionFileModes [ ownerReadMode - , ownerWriteMode - , groupReadMode])) - defaultFileFlags - fdSeek fd AbsoluteSeek (fromIntegral'' $ fileLen * (intToINInt bytesPerBlock) - 1) - fdWrite fd "!" - return $ - RawDevice { rawDevPath = path - , rawDevHandle = fd - } - -blocksInDevice :: RawDevice - -> IO DiskAddress -blocksInDevice (RawDevice{rawDevHandle=fd}) = do --- return (256 * (2 ^ 10) `div` (fromIntegral' bytesPerBlock)) -- FIX: Hard coded... - h <- fdToHandle2 fd - s <- hFileSize h - -- moderately safe due to div. - return $ fromIntegral'' $ s `div` (toInteger bytesPerBlock) - --- |Closes the device, if necessary. -finalizeDevice :: RawDevice -> IO () -finalizeDevice (RawDevice{rawDevHandle=h }) = closeFd h - ------------------------------------------------------------- - -devBufferRead :: RawDevice -- ^which disk? - -> DiskAddress -- ^Block number - -> BufferBlockHandle s -- ^Buffer! - -> IO () -devBufferRead (RawDevice{rawDevHandle=h}) blockNum buffer = do - () <- assert (blockNum >= 0) $ return () - checkBufferBlockHandleSize buffer - fileHandle <- openBinIO h - seekBin fileHandle (locationOfBlock (abs blockNum)) - resetBin buffer - copyBytes fileHandle - buffer bytesPerBlock - -devBufferWrite :: RawDevice -- ^which disk? - -> DiskAddress -- ^Block number - -> BufferBlockHandle s -- ^Buffer! - -> IO () -devBufferWrite (RawDevice{rawDevHandle=h}) blockNum buffer = do - () <- assert (blockNum >= 0) $ return () - checkBufferBlockHandleSize buffer - -- buffSize <- sizeFixedBinMem buffer - -- TODO: ??? () <- assert (bytesPerBlock <= buffSize) $ return () - fileHandle <- openBinIO h - seekBin fileHandle (locationOfBlock (abs blockNum)) - resetBin buffer - copyBytes buffer - fileHandle bytesPerBlock diff --git a/binutils.c b/binutils.c deleted file mode 100644 --- a/binutils.c +++ /dev/null @@ -1,32 +0,0 @@ -#include -#include -#include -#include -#include "binutils.h" - -void binmemmove(void *dest,int dest_off,void *src,int src_off,size_t size) { - // printf("memmove: %d + %d <= %d + %d (%d)\n",dest,dest_off,src,src_off,size); - memmove(dest + dest_off,src + src_off,size); - // printf("memmove [done]\n"); -} - -size_t binwrite(int dest_fd,void *src,int src_off,size_t size) { - size_t ret; - // printf("binwrite: %d <= %d + %d (%d)\n",dest_fd,src,src_off,size); - ret = write(dest_fd,src + src_off,size); - // printf("binwrite [done %d]\n",ret); - return ret; -} - -size_t binread(void *dest,int dest_off,int src_fd,size_t size) { - size_t ret; - // printf("binread: %d + %d <= %d (%d)\n",dest,dest_off,src_fd,size); - ret = read(src_fd,dest + dest_off,size); - // printf("binread [done %d]\n",ret); - return ret; -} - -void binzero(void *dest,size_t size) { - bzero(dest,size); -} - diff --git a/binutils.h b/binutils.h deleted file mode 100644 --- a/binutils.h +++ /dev/null @@ -1,5 +0,0 @@ -extern void binmemmove(void *dest,int dest_off,void *src,int src_off,size_t size); -extern size_t binwrite(int dest_fd,void *src,int src_off,size_t size); -extern size_t binread(void *dest,int dest_off,int src_fd,size_t size); -extern void binzero(void *dest,size_t size); -extern void negateblock(HsWord32 *dest,size_t size); diff --git a/fuse/src/Halfs.hs b/fuse/src/Halfs.hs new file mode 100644 --- /dev/null +++ b/fuse/src/Halfs.hs @@ -0,0 +1,630 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Command line tool for mounting a halfs filesystem from userspace via +-- hFUSE/FUSE. + +module Main +where + +import Control.Applicative +import Control.Exception (SomeException(..), assert) +import Data.Array.IO (IOUArray) +import Data.Bits +import Data.IORef (IORef) +import Data.Word +import System.Console.GetOpt +import System.Directory (doesFileExist) +import System.Environment +import System.IO hiding (openFile) +import System.Posix.Types ( ByteCount + , DeviceID + , EpochTime + , FileMode + , FileOffset + , GroupID + , UserID + ) +import System.Posix.User (getRealUserID, getRealGroupID) +import System.Fuse + +import Halfs.Classes +import Halfs.CoreAPI +import Halfs.File (FileHandle, openFilePrim) +import Halfs.Errors +import Halfs.HalfsState +import Halfs.Monad +import Halfs.MonadUtils +import Halfs.Utils +import System.Device.BlockDevice +import System.Device.File +import System.Device.Memory + +import qualified Data.ByteString as BS +import qualified Data.Map as M +import qualified Halfs.Protection as HP +import qualified Halfs.Types as H +import qualified Tests.Utils as TU +import qualified Prelude +import Prelude hiding (catch, log, read) + +-- import Debug.Trace + +-- Halfs-specific stuff we carry around in our FUSE functions; note that the +-- FUSE library does this via opaque ptr to user data, but since hFUSE +-- reimplements fuse_main and doesn't seem to provide a way to hang onto +-- private data, we just carry the data ourselves. + +type Logger m = String -> m () +data HalfsSpecific b r l m = HS { + hspLogger :: Logger m + , hspState :: HalfsState b r l m + -- ^ The filesystem state, as provided by CoreAPI.mount. + , hspFpdhMap :: H.LockedRscRef l r (M.Map FilePath (H.DirHandle r l)) + -- ^ Tracks DirHandles across halfs{Open,Read,Release}Directory invocations; + -- we should be able to do this via HFuse and the fuse_file_info* out + -- parameter for the 'open' fuse operation, but the binding doesn't support + -- this. However, we'd probably still need something persistent here to go + -- from the opaque handle we stored in the fuse_file_info struct to one of + -- our DirHandles. + } + +-- This isn't a halfs limit, but we have to pick something for FUSE. +maxNameLength :: Integer +maxNameLength = 32768 + +main :: IO () +main = do + (opts, argv1) <- do + argv0 <- getArgs + case getOpt RequireOrder options argv0 of + (o, n, []) -> return (foldl (flip ($)) defOpts o, n) + (_, _, errs) -> ioError $ userError $ concat errs ++ usageInfo hdr options + where hdr = "Usage: halfs [OPTION...] " + + let sz = optSecSize opts; n = optNumSecs opts + (exists, dev) <- maybe (fail "Unable to create device") return + =<< + let wb = (liftM . liftM) . (,) in + if optMemDev opts + then wb False $ newMemoryBlockDevice n sz <* putStrLn "Created new memdev." + else case optFileDev opts of + Nothing -> fail "Can't happen" + Just fp -> do + exists <- doesFileExist fp + wb exists $ + if exists + then newFileBlockDevice fp sz + <* putStrLn "Created filedev from existing file." + else TU.withFileStore False fp sz n (`newFileBlockDevice` sz) + <* putStrLn "Created filedev from new file." + + uid <- (HP.UID . fromIntegral) `fmap` getRealUserID + gid <- (HP.GID . fromIntegral) `fmap` getRealGroupID + + let perms = H.FileMode [H.Read, H.Write, H.Execute] + [H.Read, H.Execute] + [ ] + + when (not exists) $ execNoEnv (newfs dev uid gid perms) >> return () + fs <- execNoEnv $ mount dev uid gid perms + + let withLog act = case optLogFile opts of + Nothing -> act $ const $ return () + Just lp -> System.IO.withFile lp WriteMode $ \h -> + act $ \s -> hPutStrLn h s >> hFlush h + withLog $ \log -> do + dhMap <- newLockedRscRef M.empty + withArgs argv1 $ fuseMain (ops (HS log fs dhMap)) $ \(e :: SomeException) -> do + log $ "*** Exception: " ++ show e + return eFAULT + +-------------------------------------------------------------------------------- +-- Halfs-hFUSE filesystem operation implementation + +-- JS: ST monad impls will have to get mapped to hFUSE ops via stToIO? + +ops :: HalfsSpecific (IOUArray Word64 Bool) IORef IOLock IO + -> FuseOperations (FileHandle IORef IOLock) +ops hsp = FuseOperations + { fuseGetFileStat = halfsGetFileStat hsp + , fuseReadSymbolicLink = halfsReadSymbolicLink hsp + , fuseCreateDevice = halfsCreateDevice hsp + , fuseCreateDirectory = halfsCreateDirectory hsp + , fuseRemoveLink = halfsRemoveLink hsp + , fuseRemoveDirectory = halfsRemoveDirectory hsp + , fuseCreateSymbolicLink = halfsCreateSymbolicLink hsp + , fuseRename = halfsRename hsp + , fuseCreateLink = halfsCreateLink hsp + , fuseSetFileMode = halfsSetFileMode hsp + , fuseSetOwnerAndGroup = halfsSetOwnerAndGroup hsp + , fuseSetFileSize = halfsSetFileSize hsp + , fuseSetFileTimes = halfsSetFileTimes hsp + , fuseOpen = halfsOpen hsp + , fuseRead = halfsRead hsp + , fuseWrite = halfsWrite hsp + , fuseGetFileSystemStats = halfsGetFileSystemStats hsp + , fuseFlush = halfsFlush hsp + , fuseRelease = halfsRelease hsp + , fuseSynchronizeFile = halfsSyncFile hsp + , fuseOpenDirectory = halfsOpenDirectory hsp + , fuseReadDirectory = halfsReadDirectory hsp + , fuseReleaseDirectory = halfsReleaseDirectory hsp + , fuseSynchronizeDirectory = halfsSyncDirectory hsp + , fuseAccess = halfsAccess hsp + , fuseInit = halfsInit hsp + , fuseDestroy = halfsDestroy hsp + } + +halfsGetFileStat :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath + -> m (Either Errno FileStat) +halfsGetFileStat hsp@HS{ hspLogger = _log } fp = do + --log $ "halfsGetFileStat: fp = " ++ show fp + eestat <- execOrErrno hsp eINVAL id (fstat fp) + case eestat of + Left en -> do + --log $ " (fstat failed w/ " ++ show en ++ ")" + return $ Left en + Right stat -> + Right `fmap` hfstat2fstat stat + +halfsReadSymbolicLink :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath + -> m (Either Errno FilePath) +halfsReadSymbolicLink HS{ hspLogger = _log, hspState = _fs } _fp = do + _ <- error "halfsReadSymbolicLink: Not Yet Implemented" -- TODO + return (Left eNOSYS) + +halfsCreateDevice :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath -> EntryType -> FileMode -> DeviceID + -> m Errno +halfsCreateDevice hsp@HS{ hspLogger = log } fp etype mode _devID = do + log $ "halfsCreateDevice: fp = " ++ show fp ++ ", etype = " ++ show etype ++ + ", mode = " ++ show mode + case etype of + RegularFile -> do + --log $ "halfsCreateDevice: Regular file w/ " ++ show hmode + execDefault hsp $ hlocal (withLogger log) $ createFile fp hmode + _ -> do + log $ "halfsCreateDevice: Error: Unsupported EntryType encountered." + return eINVAL + where hmode = mode2hmode mode + +halfsCreateDirectory :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath -> FileMode + -> m Errno +halfsCreateDirectory hsp@HS{ hspLogger = log } fp mode = do + log $ "halfsCreateDirectory: fp = " ++ show fp + execDefault hsp $ mkdir fp (mode2hmode mode) + +halfsRemoveLink :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath + -> m Errno +halfsRemoveLink hsp@HS{ hspLogger = log } fp = do + log $ "halfsRemoveLink: fp = " ++ show fp + execDefault hsp $ rmlink fp + +halfsRemoveDirectory :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath + -> m Errno +halfsRemoveDirectory hsp@HS{ hspLogger = log } fp = do + log $ "halfsRemoveDirectory: removing " ++ show fp + execDefault hsp $ rmdir fp + + +halfsCreateSymbolicLink :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath -> FilePath + -> m Errno +halfsCreateSymbolicLink HS{ hspLogger = _log, hspState = _fs } _src _dst = do + _ <- error $ "halfsCreateSymbolicLink: Not Yet Implemented." -- TODO + return eNOSYS + +halfsRename :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath -> FilePath + -> m Errno +halfsRename hsp@HS{ hspLogger = log } old new = do + log $ "halfsRename: old = " ++ show old ++ ", new = " ++ show new + execDefault hsp $ rename old new + +halfsCreateLink :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath -> FilePath + -> m Errno +halfsCreateLink hsp@HS{ hspLogger = log } src dst = do + log $ "halfsCreateLink: creating hard link from '" ++ src + ++ "' to '" ++ dst ++ "'" + execDefault hsp $ mklink src dst + +halfsSetFileMode :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath -> FileMode + -> m Errno +halfsSetFileMode hsp@HS{ hspLogger = log } fp mode = do + log $ "halfsSetFileMode: setting " ++ show fp ++ " to mode " ++ show mode + execDefault hsp $ chmod fp (mode2hmode mode) + +halfsSetOwnerAndGroup :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath -> UserID -> GroupID + -> m Errno +halfsSetOwnerAndGroup hsp@HS{ hspLogger = log } fp uid' gid' = do + -- uid and gid get passed as System.Posix.Types.C[UG]id which are newtype'd + -- Word32s. Unfortunately, this means that a user or group argument of -1 + -- (which means "unchanged" according to the man page for chown(2)) is only + -- visible to us here as maxBound :: Word32. + + let uid = cvt uid' + gid = cvt gid' + cvt x = if fromIntegral x == (maxBound :: Word32) + then Nothing + else Just (fromIntegral x) + + log $ "halfsSetOwnerAndGroup: setting " ++ show fp ++ " to user = " + ++ show uid ++ ", group = " ++ show gid + execDefault hsp $ chown fp uid gid + +halfsSetFileSize :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath -> FileOffset + -> m Errno +halfsSetFileSize hsp@HS{ hspLogger = log } fp offset = do + log $ "halfsSetFileSize: setting " ++ show fp ++ " to size " ++ show offset + execDefault hsp $ setFileSize fp (fromIntegral offset) + +halfsSetFileTimes :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath -> EpochTime -> EpochTime + -> m Errno +halfsSetFileTimes hsp@HS{ hspLogger = log } fp accTm modTm = do + -- TODO: Check perms: caller must be file owner w/ write access or + -- superuser. + accTm' <- fromCTime accTm + modTm' <- fromCTime modTm + log $ "halfsSetFileTimes fp = " ++ show fp ++ ", accTm = " ++ show accTm' ++ + ", modTm = " ++ show modTm' + execDefault hsp $ setFileTimes fp accTm' modTm' + +halfsOpen :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath -> OpenMode -> OpenFileFlags + -> m (Either Errno (FileHandle r l)) +halfsOpen hsp@HS{ hspLogger = log } fp omode flags = do + log $ "halfsOpen: fp = " ++ show fp ++ ", omode = " ++ show omode ++ + ", flags = " ++ show flags + rslt <- execOrErrno hsp eINVAL id $ openFile fp halfsFlags + return rslt + where + -- NB: In HFuse 0.2.2, the explicit and truncate are always false, + -- so we do not pass them down to halfs. Similarly, halfs does not + -- support noctty, so it's ignored here as well. + halfsFlags = H.FileOpenFlags + { H.append = append flags + , H.nonBlock = nonBlock flags + , H.openMode = case omode of + ReadOnly -> H.ReadOnly + WriteOnly -> H.WriteOnly + ReadWrite -> H.ReadWrite + } + +halfsRead :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath -> FileHandle r l -> ByteCount -> FileOffset + -> m (Either Errno BS.ByteString) +halfsRead hsp@HS{ hspLogger = log } fp fh byteCnt offset = do + log $ "halfsRead: Reading " ++ show byteCnt ++ " bytes from " ++ + show fp ++ " at offset " ++ show offset + execOrErrno hsp eINVAL id $ + read fh (fromIntegral offset) (fromIntegral byteCnt) + +halfsWrite :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath -> FileHandle r l -> BS.ByteString -> FileOffset + -> m (Either Errno ByteCount) +halfsWrite hsp@HS{ hspLogger = log } fp fh bytes offset = do + log $ "halfsWrite: Writing " ++ show (BS.length bytes) ++ " bytes to " ++ + show fp ++ " at offset " ++ show offset + execOrErrno hsp eINVAL id $ do + write fh (fromIntegral offset) bytes + return (fromIntegral $ BS.length bytes) + +halfsGetFileSystemStats :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath + -> m (Either Errno System.Fuse.FileSystemStats) +halfsGetFileSystemStats hsp _fp = do + execOrErrno hsp eINVAL fss2fss fsstat + where + fss2fss (FSS bs bc bf ba fc ff) = System.Fuse.FileSystemStats + { fsStatBlockSize = bs + , fsStatBlockCount = bc + , fsStatBlocksFree = bf + , fsStatBlocksAvailable = ba + , fsStatFileCount = fc + , fsStatFilesFree = ff + , fsStatMaxNameLength = maxNameLength + } + +halfsFlush :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath -> FileHandle r l + -> m Errno +halfsFlush hsp@HS{ hspLogger = _log } _fp fh = do + --log $ "halfsFlush: Flushing " ++ show fp + execDefault hsp $ flush fh + +halfsRelease :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath -> FileHandle r l + -> m () +halfsRelease HS{ hspLogger = log, hspState = fs } fp fh = do + log $ "halfsRelease: Releasing " ++ show fp + exec fs $ closeFile fh + +halfsSyncFile :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath -> System.Fuse.SyncType + -> m Errno +halfsSyncFile HS{ hspLogger = _log, hspState = _fs } _fp _syncType = do + _ <- error "halfsSyncFile: Not Yet Implemented." -- TODO + return eNOSYS + +halfsOpenDirectory :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath + -> m Errno +halfsOpenDirectory hsp@HS{ hspLogger = log, hspFpdhMap = fpdhMap } fp = do + log $ "halfsOpenDirectory: fp = " ++ show fp + execDefault hsp $ + withLockedRscRef fpdhMap $ \ref -> do + mdh <- lookupRM fp ref + case mdh of + Nothing -> openDir fp >>= \v -> insertRM fp v ref + _ -> return () + +halfsReadDirectory :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath + -> m (Either Errno [(FilePath, FileStat)]) +halfsReadDirectory hsp@HS{ hspLogger = log, hspFpdhMap = fpdhMap } fp = do + log $ "halfsReadDirectory: fp = " ++ show fp + rslt <- execOrErrno hsp eINVAL id $ + withLockedRscRef fpdhMap $ \ref -> do + mdh <- lookupRM fp ref + case mdh of + Nothing -> throwError HE_DirectoryHandleNotFound + Just dh -> readDir dh + >>= mapM (\(p, s) -> (,) p `fmap` hfstat2fstat s) + -- log $ " rslt = " ++ show rslt + log $ " rslt had " ++ show (length `fmap` rslt) ++ " entries." + return rslt + +halfsReleaseDirectory :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath + -> m Errno +halfsReleaseDirectory hsp@HS{ hspLogger = log, hspFpdhMap = fpdhMap} fp = do + log $ "halfsReleaseDirectory: fp = " ++ show fp + execDefault hsp $ + withLockedRscRef fpdhMap $ \ref -> do + mdh <- lookupRM fp ref + case mdh of + Nothing -> throwError HE_DirectoryHandleNotFound + Just dh -> closeDir dh >> deleteRM fp ref + +halfsSyncDirectory :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath -> System.Fuse.SyncType + -> m Errno +halfsSyncDirectory HS{ hspLogger = _log, hspState = _fs } _fp _syncType = do + _ <- error "halfsSyncDirectory: Not Yet Implemented." -- TODO + return eNOSYS + +halfsAccess :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> FilePath -> Int + -> m Errno +halfsAccess (HS _log _fs _fpdhMap) _fp _n = do + --log $ "halfsAccess: fp = " ++ show fp ++ ", n = " ++ show n + return eOK -- TODO FIXME currently grants all access! + +halfsInit :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> m () +halfsInit (HS log _fs _fpdhMap) = do + log $ "halfsInit: Invoked." + return () + +halfsDestroy :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> m () +halfsDestroy HS{ hspLogger = log, hspState = fs } = do + log $ "halfsDestroy: Unmounting..." + exec fs $ unmount + log "halfsDestroy: Shutting block device down..." + exec fs $ lift $ bdShutdown (hsBlockDev fs) + log $ "halfsDestroy: Done." + return () + +-------------------------------------------------------------------------------- +-- Converters + +hfstat2fstat :: (Show t, Timed t m) => H.FileStat t -> m FileStat +hfstat2fstat stat = do + atm <- toCTime $ H.fsAccessTime stat + mtm <- toCTime $ H.fsModifyTime stat + chtm <- toCTime $ H.fsChangeTime stat + let entryType = case H.fsType stat of + H.RegularFile -> RegularFile + H.Directory -> Directory + H.Symlink -> SymbolicLink + -- TODO: Represent remaining FUSE entry types + H.AnyFileType -> error "Invalid fstat type" + return FileStat + { statEntryType = entryType + , statFileMode = entryTypeToFileMode entryType + .|. emode (H.fsMode stat) + , statLinkCount = chkb16 $ H.fsNumLinks stat + , statFileOwner = chkb32 $ H.fsUID stat + , statFileGroup = chkb32 $ H.fsGID stat + , statSpecialDeviceID = 0 -- XXX/TODO: Do we need to distinguish by + -- blkdev, or is this for something else? + , statFileSize = fromIntegral $ H.fsSize stat + , statBlocks = fromIntegral $ H.fsNumBlocks stat + , statAccessTime = atm + , statModificationTime = mtm + , statStatusChangeTime = chtm + } + where + chkb16 x = assert (x' <= fromIntegral (maxBound :: Word16)) x' + where x' = fromIntegral x + chkb32 x = assert (x' <= fromIntegral (maxBound :: Word32)) x' + where x' = fromIntegral x + emode (H.FileMode o g u) = cvt o * 0o100 + cvt g * 0o10 + cvt u where + cvt = foldr (\p acc -> acc + case p of H.Read -> 0o4 + H.Write -> 0o2 + H.Execute -> 0o1 + ) 0 + +-- NB: Something like this should probably be done by HFuse. TODO: Migrate? +mode2hmode :: FileMode -> H.FileMode +mode2hmode mode = H.FileMode (perms 6) (perms 3) (perms 0) + where + msk b = case b of H.Read -> 4; H.Write -> 2; H.Execute -> 1 + perms k = chk H.Read ++ chk H.Write ++ chk H.Execute + where chk b = if mode .&. msk b `shiftL` k /= 0 then [b] else [] + +-------------------------------------------------------------------------------- +-- Misc + +exec :: HalfsCapable b t r l m => + HalfsState b r l m -> HalfsM b r l m a -> m a +exec fs act = + runHalfs fs act >>= \ea -> case ea of + Left e -> fail $ show e + Right x -> return x + +execNoEnv :: Monad m => HalfsM b r l m a -> m a +execNoEnv act = + runHalfsNoEnv act >>= \ea -> case ea of + Left e -> fail $ show e + Right x -> return x + +-- | Returns the result of the given action on success, otherwise yields an +-- Errno for the failed operation. The Errno comes from either a HalfsM +-- exception signifying it holds an Errno, or the default provided as the first +-- argument. + +execOrErrno :: Monad m => + HalfsSpecific b r l m + -> Errno + -> (a -> rslt) + -> HalfsM b r l m a + -> m (Either Errno rslt) +execOrErrno HS{ hspLogger = log, hspState = fs } defaultEn f act = do + runHalfs fs act >>= \ea -> case ea of + Left (HE_ErrnoAnnotated e en) -> do + log ("execOrErrno: e = " ++ show e) + return $ Left en + Left _e@HE_PathComponentNotFound{} -> do + --log ("execOrErrno: e = " ++ show e) + return $ Left eNOENT + Left e -> do + log ("execOrErrno: e = " ++ show e) + return $ Left defaultEn + Right x -> return $ Right (f x) + +execToErrno :: HalfsCapable b t r l m => + HalfsSpecific b r l m + -> Errno + -> (a -> Errno) + -> HalfsM b r l m a + -> m Errno +execToErrno hsp defaultEn f = liftM (either id id) . execOrErrno hsp defaultEn f + +execDefault :: HalfsCapable b t r l m => + HalfsSpecific b r l m -> HalfsM b r l m a -> m Errno +execDefault hsp = execToErrno hsp eINVAL (const eOK) + +withLogger :: HalfsCapable b t r l m => + Logger m -> HalfsState b r l m -> HalfsState b r l m +withLogger log fs = fs {hsLogger = Just log} + +-------------------------------------------------------------------------------- +-- Command line stuff + +data Options = Options + { optFileDev :: Maybe FilePath + , optMemDev :: Bool + , optNumSecs :: Word64 + , optSecSize :: Word64 + , optLogFile :: Maybe FilePath + } + deriving (Show) + +defOpts :: Options +defOpts = Options + { optFileDev = Nothing + , optMemDev = True + , optNumSecs = 512 + , optSecSize = 512 + , optLogFile = Nothing + } + +options :: [OptDescr (Options -> Options)] +options = + [ Option ['m'] ["memdev"] + (NoArg $ \opts -> opts{ optFileDev = Nothing, optMemDev = True }) + "use memory device" + , Option ['f'] ["filedev"] + (ReqArg (\f opts -> opts{ optFileDev = Just f, optMemDev = False }) + "PATH" + ) + "use file-backed device" + , Option ['n'] ["numsecs"] + (ReqArg (\s0 opts -> let s1 = Prelude.read s0 in opts{ optNumSecs = s1 }) + "SIZE" + ) + "number of sectors (ignored for filedevs; default 512)" + , Option ['s'] ["secsize"] + (ReqArg (\s0 opts -> let s1 = Prelude.read s0 in opts{ optSecSize = s1 }) + "SIZE" + ) + "sector size in bytes (ignored for existing filedevs; default 512)" + , Option ['l'] ["logfile"] + (ReqArg (\s opts -> opts{ optLogFile = Just s }) + "PATH" + ) + "filename for halfs logging (default is no logging done)" + ] + +-------------------------------------------------------------------------------- +-- Instances for debugging + +instance Show OpenMode where + show ReadOnly = "ReadOnly" + show WriteOnly = "WriteOnly" + show ReadWrite = "ReadWrite" + +instance Show OpenFileFlags where + show (OpenFileFlags append' exclusive' noctty' nonBlock' trunc') = + "OpenFileFlags " ++ + "{ append = " ++ show append' ++ + ", exclusive = " ++ show exclusive' ++ + ", noctty = " ++ show noctty' ++ + ", nonBlock = " ++ show nonBlock' ++ + ", trunc = " ++ show trunc' ++ + "}" + +-- Get rid of extraneous Halfs.File not-used warning +_dummy :: HalfsCapable b t r l m => + H.InodeRef -> HalfsM b r l m (FileHandle r l) +_dummy = openFilePrim undefined diff --git a/halfs.cabal b/halfs.cabal --- a/halfs.cabal +++ b/halfs.cabal @@ -1,165 +1,119 @@ -Name: halfs -Version: 0.2 -copyright: Copyright (c) 2005 Galois Connections, Inc. -author: Isaac Jones, Galois Inc. -maintainer: Iaaac Jones -homepage: http://haskell.org/halfs/ -category: System -synopsis: Haskell File System -description: Halfs is a filesystem implemented in the functional programming - language Haskell. Halfs can be mounted and used like any other Linux - filesystem, or used as a library. Halfs is a fork (and a port) of the - filesystem developed by Galois Connections. See also http://haskell.org/pipermail/haskell-cafe/2006-April/015361.html - . - You can get it from here: http://darcs.haskell.org/halfs -License: LGPL -license-file: LGPL +name: halfs +version: 2.0 +license: BSD3 +license-file: LICENSE +author: Joel Stanley , + Adam Wick , + Isaac Jones +maintainer: Joel Stanley +description: A library implementing a file system suitable for use in + HaLVMs. Provides useful abstractions over the underlying + block layer. Implemented atop FUSE. Note: This is a new + implementation of the halfs project, and bears little to + no resemblance to halfs 0.2. +synopsis: The HAskelL File System ("halfs" -- intended for use on the HaLVM) +category: System +stability: experimental +build-type: Simple +cabal-version: >= 1.8 +tested-with: GHC == 7.0.4 -build-type: Simple -build-depends: HUnit, unix, base>3, QuickCheck, network, mtl, - containers, array, directory, process, random -tested-with: GHC==6.8.2 -Extensions: ExistentialQuantification, CPP, ForeignFunctionInterface, FlexibleContexts, - PatternSignatures, Rank2Types, RankNTypes, TypeSynonymInstances, GADTs, - MultiParamTypeClasses -c-sources: binutils.c -includes: binutils.h -extra-source-files: binutils.h - Halfs/Directory.hs-boot - Halfs/Blocks.hs-boot - Halfs/BasicIO.hs-boot - Halfs/FileHandle.hs-boot +source-repository head + type: git + location: git clone https://github.com/GaloisInc/halfs.git -Exposed-Modules: Halfs, Halfs.FSState, Halfs.Buffer, Data.Integral -Other-Modules: Data.Array.SysArray, - Data.Queue, - Halfs.BufferBlockCache, - Halfs.BufferBlock, - Halfs.FSRoot, - Halfs.FSRW, - Halfs.BasicIO, - Halfs.Blocks, - Halfs.SyncStructures, - Halfs.BuiltInFiles, - Halfs.TheBlockMap, - Halfs.FileHandle, - Halfs.TestFramework, - Halfs.TheInodeMap, - Halfs.Inode, - Halfs.CompatFilePath, - Halfs.Utils, - Halfs.Directory, - Halfs.BinaryMonad, - BinArray, - Binary, - FastMutInt, - System.RawDevice.Base, - System.RawDevice.File, - System.RawDevice -ghc-prof-options: -auto-all -GHC-Options: -Wall -fno-ignore-asserts -O2 +flag build-tests + description: Build the test executables -Executable: moduleTest -Main-is: ModuleTest.hs -c-sources: binutils.c -Other-Modules: Data.Array.SysArray, - Data.Queue, - Data.Integral, - Halfs.BufferBlockCache, - Halfs.BufferBlock, - Halfs.FSState, - Halfs.FSRoot, - Halfs.FSRW, - Halfs.Buffer, - Halfs.BasicIO, - Halfs.Blocks, - Halfs.SyncStructures, - Halfs.BuiltInFiles, - Halfs.TheBlockMap, - Halfs.FileHandle, - Halfs.TestFramework, - Halfs.TheInodeMap, - Halfs.Inode, - Halfs.CompatFilePath, - Halfs.Utils, - Halfs.Directory, - Halfs.BinaryMonad, - BinArray, - HighLevelTests, - Binary, - FastMutInt, - System.RawDevice.Base, - System.RawDevice.File, - System.RawDevice -ghc-prof-options: -auto-all -GHC-Options: -Wall -fno-ignore-asserts -O2 +library + build-depends: + QuickCheck, + array, + base >= 3 && <= 4, + bytestring, + cereal, + containers, + directory, + filepath, + fingertree, + mtl, + random, + time, + unix -Executable: newfs-halfs -Main-is: NewFS.hs -c-sources: binutils.c -Other-Modules: Data.Array.SysArray, - Data.Queue, - Data.Integral, - Halfs.BufferBlockCache, - Halfs.BufferBlock, - Halfs.FSState, - Halfs.FSRoot, - Halfs.FSRW, - Halfs.Buffer, - Halfs.BasicIO, - Halfs.Blocks, - Halfs.SyncStructures, - Halfs.BuiltInFiles, - Halfs.TheBlockMap, - Halfs.FileHandle, - Halfs.TestFramework, - Halfs.TheInodeMap, - Halfs.Inode, - Halfs.CompatFilePath, - Halfs.Utils, - Halfs.Directory, - Halfs.BinaryMonad, - BinArray, - HighLevelTests, - Binary, - FastMutInt, - System.RawDevice.Base, - System.RawDevice.File, - System.RawDevice -ghc-prof-options: -auto-all -GHC-Options: -Wall -O2 + Exposed-Modules: + Halfs.BlockMap, + Halfs.Classes, + Halfs.CoreAPI, + Halfs.Directory, + Halfs.Errors, + Halfs.File, + Halfs.HalfsState, + Halfs.Inode, + Halfs.Monad, + Halfs.MonadUtils, + Halfs.Protection, + Halfs.SuperBlock, + Halfs.Types, + Halfs.Utils, + System.Device.BlockDevice, + System.Device.File, + System.Device.Memory, + System.Device.ST + Tests.Instances, + Tests.Types, + Tests.Utils -Executable: fsck-halfs -Main-is: Fsck.hs -c-sources: binutils.c -Other-Modules: Data.Array.SysArray, - Data.Queue, - Data.Integral, - Halfs.BufferBlockCache, - Halfs.BufferBlock, - Halfs.FSState, - Halfs.FSRoot, - Halfs.FSRW, - Halfs.Buffer, - Halfs.BasicIO, - Halfs.Blocks, - Halfs.SyncStructures, - Halfs.BuiltInFiles, - Halfs.TheBlockMap, - Halfs.FileHandle, - Halfs.TestFramework, - Halfs.TheInodeMap, - Halfs.Inode, - Halfs.CompatFilePath, - Halfs.Utils, - Halfs.Directory, - Halfs.BinaryMonad, - BinArray, - HighLevelTests, - Binary, - FastMutInt, - System.RawDevice.Base, - System.RawDevice.File, - System.RawDevice -ghc-prof-options: -auto-all -GHC-Options: -Wall -O2 + extensions: + BangPatterns, + FlexibleContexts, + FlexibleInstances, + FunctionalDependencies, + GeneralizedNewtypeDeriving, + MultiParamTypeClasses, + ScopedTypeVariables + + hs-source-dirs : . test/src + GHC-Options : -Wall -fno-ignore-asserts + ghc-prof-options : -prof -auto-all + +executable halfs-tests + if !flag(build-tests) + buildable: False + + build-depends: + QuickCheck, + array, + base >= 3 && < 5, + bytestring, + cereal, + containers, + directory, + filepath, + fingertree, + halfs, + mtl, + random, + time + + hs-source-dirs : test/src . + main-is : Driver.hs + ghc-options : -Wall -fno-ignore-asserts -threaded + ghc-prof-options : -prof -auto-all + +executable halfs + build-depends: + HFuse >= 0.2.4.1, + array, + base >= 3 && < 5, + bytestring, + containers, + directory, + halfs, + unix + + hs-source-dirs : fuse/src + main-is : Halfs.hs + ghc-options : -Wall -fno-ignore-asserts -threaded + ghc-prof-options : -prof -auto-all + diff --git a/test/src/Driver.hs b/test/src/Driver.hs new file mode 100644 --- /dev/null +++ b/test/src/Driver.hs @@ -0,0 +1,34 @@ +module Main where + +import Test.QuickCheck (Args, Property, quickCheckWithResult) +import Test.QuickCheck.Test (isSuccess) +import System.Exit (ExitCode(..), exitFailure, exitWith) + +import qualified Tests.BlockDevice as BD +import qualified Tests.BlockMap as BM +import qualified Tests.CoreAPI as CA +import qualified Tests.Inode as IN +import qualified Tests.Serdes as SD + +qcProps :: [(Args, Property)] +qcProps = + BD.qcProps True -- run in "quick" mode for Block Devices + ++ + BM.qcProps True -- run in "quick" mode for Block Map + ++ + SD.qcProps True -- run in "quick" mode for Serdes + ++ + IN.qcProps True -- run in "quick" mode for Inode + ++ + CA.qcProps True -- run in "quick" mode for CoreAPI + +main :: IO () +main = do + results <- mapM (uncurry quickCheckWithResult) qcProps + if all isSuccess results + then do + putStrLn "All tests successful." + exitWith ExitSuccess + else do + putStrLn "One or more tests failed." + exitFailure diff --git a/test/src/Tests/Instances.hs b/test/src/Tests/Instances.hs new file mode 100644 --- /dev/null +++ b/test/src/Tests/Instances.hs @@ -0,0 +1,307 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} + +module Tests.Instances +where + +import Control.Applicative ((<$>), (<*>)) +import Control.Exception (assert) +import Control.Monad (foldM, replicateM) +import Data.Bits (shiftL) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.List (nub, genericTake) +import Data.Serialize +import Data.Time +import Data.Word +import System.Random +import Test.QuickCheck +import Test.QuickCheck.Monadic hiding (assert) + +import Halfs.BlockMap (Extent(..)) + +import Halfs.Inode ( Ext(..) + , ExtRef(..) + , Inode(..) + , InodeRef(..) + , computeNumAddrs + , minimalExtSize + , computeMinimalInodeSize + , minExtBlocks + , minInodeBlocks + , nilER + ) +import Halfs.Directory +import Halfs.Protection (UserID(..), GroupID(..)) +import Halfs.SuperBlock (SuperBlock(..)) +import Tests.Types + + +-------------------------------------------------------------------------------- +-- Block Device generators and helpers + +-- | Generate an arbitrary geometry (modified by function given by the +-- first parameter) and employ the given geometry-requiring generator to +-- supply data to the given property. +forAllBlocksM :: Monad m => + (BDGeom -> BDGeom) + -- ^ geometry transformer + -> (BDGeom -> Gen [(Word64, ByteString)]) + -- ^ data generator + -> ([(Word64, ByteString)] -> BDGeom -> PropertyM m b) + -- ^ property constructor + -> PropertyM m b +forAllBlocksM f gen prop = + forAllM arbBDGeom $ \g -> let g' = f g in forAllM (gen g') (flip prop g') + +-- | Generate a power of 2 given an exponent range in [0, 63] +powTwo :: Int -> Int -> Gen Word64 +powTwo l h = assert (l >= 0 && h <= 63) $ shiftL 1 <$> choose (l, h) + +arbBDGeom :: Gen BDGeom +arbBDGeom = arbitrary + +-- | Creates arbitrary "filesystem data" : just block addresses and +-- block data, constrained by the given device geometry +arbFSData :: BDGeom -> Gen [(Word64, ByteString)] +arbFSData g = listOf1 $ (,) <$> arbBlockAddr g <*> arbBlockData g + +-- | Creates arbitrary contiguous "filesystem data" : consecutive runs +-- of block addresses and accompanying block data, constrained by the +-- given device geometry +arbContiguousData :: BDGeom -> Gen [(Word64, ByteString)] +arbContiguousData g = do + let numBlks = fromIntegral $ bdgSecCnt g + limit = 64 -- artificial limit on number of contiguous blocks + -- generated; keeps generated data on the small side + numContig <- if numBlks > 1 -- maybe we can't create continguous blocks + then choose (2 :: Integer, max 2 (min limit (numBlks `div` 2))) + else return 1 + baseAddrs <- (\x -> map fromIntegral [x .. x + numContig]) + `fmap` choose (0 :: Integer, numBlks - numContig) + zip baseAddrs `fmap` vectorOf (fromIntegral numContig) (arbBlockData g) + +arbBlockAddr :: BDGeom -> Gen Word64 +arbBlockAddr (BDGeom cnt _sz) = + fromIntegral `fmap` choose (0 :: Integer, ub) + where ub = fromIntegral $ cnt - 1 + +arbBlockData :: BDGeom -> Gen ByteString +arbBlockData (BDGeom _cnt sz) = bytes (fromIntegral sz) + +byte :: Gen Word8 +byte = fromIntegral `fmap` choose (0 :: Int, 255) + +bytes :: Int -> Gen ByteString +bytes n = BS.pack `fmap` replicateM n byte + +printableBytes :: Int -> Gen ByteString +printableBytes n = BS.pack `fmap` replicateM n printableByte + +printableByte :: Gen Word8 +printableByte = fromIntegral `fmap` choose (33 :: Int, 126) + +filename :: Int -> Gen String +filename maxLen = + resize maxLen $ + listOf1 (elements $ ['0' .. '9'] ++ ['A'..'Z'] ++ ['a'..'z'] ++ ['_', '-']) + + + +-------------------------------------------------------------------------------- +-- BlockMap generators and helpers + +newtype UnallocDecision = UnallocDecision Bool deriving Show + +-- | Given an extent, generates subextents that cover it; useful for creating +-- allocation sequences. To keep the number of subextents relatively small, the +-- first two subextents generated cover ~75% of the input extent. The input +-- extent should be of reasonable size (>= 8) in order to avoid degenerate +-- corner cases. +arbExtents :: Extent -> Gen [Extent] +arbExtents ext@(Extent _ ub) + | ub < 8 = fail $ "Tests.Instances.arbExtents: " + ++ "Input extent size is too small (<8)" + | otherwise = arbExtents' ext + +arbExtents' :: Extent -> Gen [Extent] +arbExtents' (Extent b ub) = do + filledQuarter <- fill (Extent (b + soFar) (ub - soFar)) + let r = Extent b halfCnt : (Extent (b + halfCnt) quarterCnt : filledQuarter) + -- monotonically decreasing size over region groups + assert (halfCnt >= quarterCnt && + quarterCnt >= sum (map extSz filledQuarter)) $ do + -- distinct base addrs + assert (let bs = map extBase r in length bs == length (nub bs)) $ do + -- exactly covers input extent and contains and no 0-size extents + assert (ub == foldr (\e -> assert (extSz e > 0) (extSz e +)) 0 r) $ do + return r + where + halfCnt = ub `div` 2 + quarterCnt = ub `div` 4 + 1 + soFar = halfCnt + quarterCnt + -- + fill :: Extent -> Gen [Extent] + fill (Extent _ 0) = return [] + fill (Extent b' ub') = do + sz <- choose (1, ub') + rest <- fill $ Extent (b' + sz) (ub' - sz) + return (Extent b' sz : rest) + +-- | A hacky, inefficient-but-good-enough permuter +permute :: [a] -> Gen [a] +permute xs = do + let len = fromIntegral $ length xs + foldM rswap xs $ replicate len len + where + rswap [] _ = return [] + rswap (x:xs') len = do + i <- choose (0, len - 1) + return $ let (l,r) = splitAt i xs' + in l ++ [x] ++ r + + +-------------------------------------------------------------------------------- +-- Instances and helpers + +instance Arbitrary UnallocDecision where + arbitrary = UnallocDecision `fmap` arbitrary + +-- instance Arbitrary BDGeom where +-- arbitrary = +-- BDGeom +-- <$> powTwo 10 13 -- 1024..8192 sectors +-- <*> powTwo 9 12 -- 512b..4K sector size +-- -- => 512K .. 32M filesystem size + +instance Arbitrary BDGeom where + arbitrary = return $ BDGeom 512 512 + +-- Generate an arbitrary version 1 superblock with coherent free and +-- used block counts. Block size and count are constrained by the +-- Arbitrary instance for BDGeom. +instance Arbitrary SuperBlock where + arbitrary = do + BDGeom cnt sz <- arbitrary + free <- choose (0, cnt) + SuperBlock + <$> return 1 -- version + <*> return sz -- blockSize + <*> return cnt -- blockCount + <*> arbitrary -- unmountClean + <*> return free -- freeBlocks + <*> return (cnt - free) -- usedBlocks + <*> arbitrary -- fileCount + <*> IR `fmap` arbitrary -- rootDir + <*> IR `fmap` return 1 -- blockMapStart + +-- Generate an arbitrary inode with mostly coherent fields (filesize/allocated +-- block relationships are not cogent, however) based on the minimal inode size +-- computation for an arbitrary device geometry. +instance (Arbitrary a, Ord a, Serialize a, Show a) => Arbitrary (Inode a) where + arbitrary = do + BDGeom _ blkSz <- arbitrary + createTm <- arbitrary + addrCnt <- computeNumAddrs blkSz minInodeBlocks + =<< computeMinimalInodeSize createTm + Inode + <$> IR `fmap` arbitrary -- inoParent + <*> return (nilER, 0) -- inoLastER + <*> IR `fmap` arbitrary -- inoAddress + <*> arbitrary -- inoFileSize + <*> arbitrary -- inoAllocBlocks + <*> arbitrary -- inoFileType + <*> arbitrary -- inoMode + <*> arbitrary -- inoNumLinks + <*> return createTm -- inoCreateTime + <*> arbitrary `suchThat` (>= createTm) -- inoModifyTime + <*> arbitrary `suchThat` (>= createTm) -- inoAccessTime + <*> arbitrary `suchThat` (>= createTm) -- inoChangeTime + <*> arbitrary -- inoUser + <*> arbitrary -- inoGroup + <*> (arbitrary >>= \cont -> do -- inoCont + let blockCount' = min (blockCount cont) addrCnt + return + cont{ address = nilER + , blockCount = blockCount' + , blockAddrs = genericTake blockCount' (blockAddrs cont) + , numAddrs = min (numAddrs cont) addrCnt + } + ) + + +-- Generate an arbitrary inode 'extension' (i.e., an Ext) with coherent fields +-- based on the minimal ext size computaton for an arbitrary device geometry +instance Arbitrary Ext where + arbitrary = do + BDGeom _ blkSz <- arbitrary + addrCnt <- computeNumAddrs blkSz minExtBlocks =<< minimalExtSize + numBlocks <- fromIntegral `fmap` choose (0, addrCnt) + Ext + <$> ER `fmap` (arbitrary `suchThat` (>=1)) -- address + <*> ER `fmap` arbitrary -- nextExt + <*> return (fromIntegral numBlocks) -- blockCount + <*> replicateM numBlocks validBlockAddr -- blockAddrs + -- Transient: + <*> return addrCnt -- numAddrs + where + validBlockAddr = let arb = arbitrary :: Gen (Positive Word64) + in (\(Positive v) -> v) <$> arb + +-- Generate an arbitrary directory entry +instance Arbitrary DirectoryEntry where + arbitrary = + DirEnt + <$> (listOf1 arbitrary :: Gen String) -- deName + <*> IR `fmap` arbitrary -- deInode + <*> arbitrary -- deUser + <*> arbitrary -- deGroup + <*> (arbitrary :: Gen FileMode) -- deMode + <*> elements [RegularFile, Directory, Symlink] -- deType + +instance Arbitrary UserID where + arbitrary = UID <$> arbitrary + +instance Arbitrary GroupID where + arbitrary = GID <$> arbitrary + +instance Arbitrary FileMode where + arbitrary = + FileMode <$> gp <*> gp <*> gp + where + gp = validAccess >>= permute + validAccess = elements [ [] + , [Read] + , [Write] + , [Execute] + , [Read,Write] + , [Read,Execute] + , [Write,Execute] + , [Read,Write,Execute] + ] + +instance Arbitrary FileType where + arbitrary = elements [ RegularFile, Directory, Symlink ] + +instance Arbitrary UTCTime where + arbitrary = UTCTime <$> arbitrary <*> arbitrary + +instance Arbitrary Day where + arbitrary = + fromGregorian <$> choose (1900, 2200) <*> choose (1, 12) <*> choose (1, 31) + +instance Arbitrary DiffTime where + arbitrary = do + sec <- choose (0, 86400) + ps <- choose (0, 10000000000000) -- 10^13, intentionally exceeds picosecond + -- resolution + return $ secondsToDiffTime sec + picosecondsToDiffTime ps + +instance Random Word64 where + randomR = integralRandomR + random = randomR (minBound, maxBound) + +integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) +integralRandomR (a,b) g = + case randomR (fromIntegral a :: Integer, fromIntegral b :: Integer) g of + (x, g') -> (fromIntegral x, g') diff --git a/test/src/Tests/Types.hs b/test/src/Tests/Types.hs new file mode 100644 --- /dev/null +++ b/test/src/Tests/Types.hs @@ -0,0 +1,10 @@ +module Tests.Types +where + +import Data.Word + +data BDGeom = BDGeom + { bdgSecCnt :: Word64 -- ^ number of sectors + , bdgSecSz :: Word64 -- ^ sector size, in bytes + } deriving Show + diff --git a/test/src/Tests/Utils.hs b/test/src/Tests/Utils.hs new file mode 100644 --- /dev/null +++ b/test/src/Tests/Utils.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE Rank2Types, FlexibleContexts #-} + +module Tests.Utils +where + +import Data.Word +import Control.Monad.ST +import Foreign.C.Error +import System.Directory +import System.IO +import System.IO.Unsafe (unsafePerformIO) +import System.FilePath +import Test.QuickCheck hiding (numTests) +import Test.QuickCheck.Monadic + +import qualified Data.ByteString as BS +import qualified Data.Map as M + +import Halfs.BlockMap +import Halfs.Classes +import Halfs.CoreAPI (mount, newfs, unmount) +import Halfs.Directory +import Halfs.Errors +import Halfs.HalfsState +import Halfs.Monad +import Halfs.MonadUtils +import Halfs.Protection +import Halfs.SuperBlock +import Halfs.Utils (divCeil, withDHLock) + +import System.Device.BlockDevice +import System.Device.File +import System.Device.Memory +import System.Device.ST + +import Tests.Instances +import Tests.Types + +-- import Debug.Trace + +type DevCtor = BDGeom -> IO (Maybe (BlockDevice IO)) +type HalfsM b r l m a = HalfsT HalfsError (Maybe (HalfsState b r l m)) m a + +-------------------------------------------------------------------------------- +-- Utility functions + +fileDev :: DevCtor +fileDev g = withFileStore + True + ("./pseudo.dsk") + (bdgSecSz g) + (bdgSecCnt g) + (`newFileBlockDevice` (bdgSecSz g)) + +memDev :: DevCtor +memDev g = newMemoryBlockDevice (bdgSecCnt g) (bdgSecSz g) + +-- | Create an STArray-backed block device. This function transforms +-- the ST-based block device to an IO block device for interface +-- consistency within this module. +staDev :: DevCtor +staDev g = + stToIO (newSTBlockDevice (bdgSecCnt g) (bdgSecSz g)) >>= + return . maybe Nothing (\dev -> + Just BlockDevice { + bdBlockSize = bdBlockSize dev + , bdNumBlocks = bdNumBlocks dev + , bdReadBlock = \i -> stToIO $ bdReadBlock dev i + , bdWriteBlock = \i v -> stToIO $ bdWriteBlock dev i v + , bdFlush = stToIO $ bdFlush dev + , bdShutdown = stToIO $ bdShutdown dev + }) + +rescaledDev :: BDGeom -- ^ geometry for underlying device + -> BDGeom -- ^ new device geometry + -> DevCtor -- ^ ctor for underlying device + -> IO (Maybe (BlockDevice IO)) +rescaledDev oldG newG ctor = + maybe (fail "Invalid BlockDevice") (newRescaledBlockDevice (bdgSecSz newG)) + `fmap` ctor oldG + +monadicBCMIOProp :: PropertyM (BCM IO) a -> Property +monadicBCMIOProp = monadic (unsafePerformIO . runBCM) + +withFileStore :: Bool -> FilePath -> Word64 -> Word64 -> (FilePath -> IO a) + -> IO a +withFileStore temp fp secSize secCnt act = do + (fname, h) <- + if temp + then openBinaryTempFile + (let d = takeDirectory "." in if null d then "." else d) + (takeFileName fp) + else (,) fp `fmap` openBinaryFile fp ReadWriteMode + + let chunkSz = 2^(20::Int) + (numChunks, numBytes) = fromIntegral (secSize * secCnt) `divMod` chunkSz + chunk = BS.replicate chunkSz 0 + replicateM_ numChunks (BS.hPut h chunk) + BS.hPut h (BS.replicate numBytes 0) + hClose h + rslt <- act fname + when temp $ removeFile fname + return rslt + +whenDev :: (Monad m) => (a -> m b) -> (a -> m ()) -> Maybe a -> m b +whenDev act cleanup = + maybe (fail "Invalid BlockDevice") $ \x -> do + y <- act x + cleanup x + return y + +mkMemDevExec :: forall m. + Bool + -> String + -> Int + -> String + -> (BDGeom -> BlockDevice IO -> PropertyM IO m) + -> (Args, Property) +mkMemDevExec quick pfx = + let numTests n = (,) $ if quick then stdArgs{maxSuccess = n} else stdArgs + doProp = (`whenDev` run . bdShutdown) + in + \n s pr -> + numTests n $ label (pfx ++ ": " ++ s) $ monadicIO $ + forAllM arbBDGeom $ \g -> + run (memDev g) >>= doProp (pr g) + +mkNewFS :: HalfsCapable b t r l m => + BlockDevice m -> PropertyM m (Either HalfsError SuperBlock) +mkNewFS dev = runHNoEnv $ newfs dev rootUser rootGroup rootDirPerms + +mountOK :: HalfsCapable b t r l m => + BlockDevice m + -> PropertyM m (HalfsState b r l m) +mountOK dev = do + runHNoEnv (defaultMount dev) + >>= either (fail . (++) "Unexpected mount failure: " . show) return + +unmountOK :: HalfsCapable b t r l m => + HalfsState b r l m -> PropertyM m () +unmountOK fs = + runH fs unmount >>= + either (fail . (++) "Unexpected unmount failure: " . show) + (const $ return ()) + +sreadRef :: HalfsCapable b t r l m => r a -> PropertyM m a +sreadRef = ($!) (run . readRef) + +runH :: HalfsCapable b t r l m => + HalfsState b r l m + -> HalfsM b r l m a + -> PropertyM m (Either HalfsError a) +runH fs = run . runHalfs fs + +runHNoEnv :: HalfsCapable b t r l m => + HalfsM b r l m a + -> PropertyM m (Either HalfsError a) +runHNoEnv = run . runHalfsNoEnv + +execE :: (Monad m ,Show a) => + String -> String -> m (Either a b) -> PropertyM m b +execE nm descrip act = + run act >>= \ea -> case ea of + Left e -> + fail $ "Unexpected error in " ++ nm ++ " (" + ++ descrip ++ "): " ++ show e + Right x -> return x + +execH :: Monad m => + String + -> env + -> String + -> HalfsT HalfsError (Maybe env) m b + -> PropertyM m b +execH nm env descrip = execE nm descrip . runHalfs env + +execHNoEnv :: Monad m => + String + -> String + -> HalfsT HalfsError (Maybe env) m b + -> PropertyM m b +execHNoEnv nm descrip = execE nm descrip . runHalfsNoEnv + +expectErr :: HalfsCapable b t r l m => + (HalfsError -> Bool) + -> String + -> HalfsM b r l m a + -> HalfsState b r l m + -> PropertyM m () +expectErr expectedP rsn act fs = + runH fs act >>= \e -> case e of + Left err | expectedP err -> return () + Left err -> unexpectedErr err + Right _ -> fail rsn + +unexpectedErr :: (Monad m, Show a) => a -> PropertyM m () +unexpectedErr = fail . (++) "Expected failure, but not: " . show + +expectErrno :: Monad m => Errno -> Either HalfsError a -> PropertyM m () +expectErrno e (Left (HE_ErrnoAnnotated _ errno)) = assert (errno == e) +expectErrno _ _ = assert False + +checkFileStat :: (HalfsCapable b t r l m, Integral a) => + FileStat t + -> a -- expected filesize + -> FileType -- expected filetype + -> FileMode -- expected filemode + -> UserID -- expected userid + -> GroupID -- expected groupid + -> a -- expected allocated block count + -> (t -> Bool) -- access time predicate + -> (t -> Bool) -- modification time predicate + -> (t -> Bool) -- status change time predicate + -> PropertyM m () +checkFileStat st expFileSz expFileTy expMode + expUsr expGrp expNumBlocks accessp modifyp changep = do + mapM_ assert + [ fsSize st == fromIntegral expFileSz + , fsType st == expFileTy + , fsMode st == expMode + , fsUID st == expUsr + , fsGID st == expGrp + , fsNumBlocks st == fromIntegral expNumBlocks + , accessp (fsAccessTime st) + , modifyp (fsModifyTime st) + , changep (fsChangeTime st) + ] + +assertMsg :: Monad m => String -> String -> Bool -> PropertyM m () +assertMsg _ _ True = return () +assertMsg ctx dtls False = do + fail $ "(" ++ ctx ++ ": " ++ dtls ++ ")" + +-- Using the current allocation scheme and inode/cont distinction, +-- determine how many blocks (of the given size, in bytes) are required +-- to store the given data size, in bytes. +calcExpBlockCount :: Integral a => + Word64 -- block size + -> Word64 -- addresses (#blocks) per inode + -> Word64 -- addresses (#blocks) per cont + -> a -- data size + -> a -- expected number of blocks +calcExpBlockCount bs api apc dataSz = fromIntegral $ + if dsz > bpi + then 1 -- inode block + + api -- number of blocks in full inode + + (dsz - bpi) `divCeil` bpc -- number of blocks required for conts + + (dsz - bpi) `divCeil` bs -- number of blocks rquired for data + else 1 -- inode block + + (dsz `divCeil` bs) -- number of blocks required for data + where + dsz = fromIntegral dataSz + bpi = api * bs + bpc = apc * bs + +defaultUser :: UserID +defaultUser = rootUser + +defaultGroup :: GroupID +defaultGroup = rootGroup + +rootDirPerms, defaultDirPerms, defaultFilePerms :: FileMode +rootDirPerms = FileMode [Read,Write,Execute] [] [] +defaultDirPerms = FileMode [Read,Write,Execute] [Read, Execute] [Read, Execute] +defaultFilePerms = FileMode [Read,Write] [Read] [Read] + +defaultMount :: HalfsCapable b t r l m => + BlockDevice m -> HalfsM b r l m (HalfsState b r l m) +defaultMount dev = mount dev defaultUser defaultGroup defaultDirPerms + +-------------------------------------------------------------------------------- +-- Block utilization checking combinators + +rscUtil :: HalfsCapable b t r l m => + (Word64 -> Word64 -> Bool) -- ^ predicate on after/before block cnts + -> HalfsState b r l m -- ^ the filesystem state + -> PropertyM m a -- ^ the action to check + -> PropertyM m () +rscUtil p fs act = do b <- getFree fs; _ <- act; a <- getFree fs; assert (p a b) + where getFree = sreadRef . bmNumFree . hsBlockMap + +blocksUnallocd :: HalfsCapable b t r l m => + Word64 -- ^ expected #blocks unallocated + -> HalfsState b r l m -- ^ the filesystem state + -> PropertyM m a -- ^ the action to check + -> PropertyM m () +blocksUnallocd x = rscUtil (\a b -> a >= b && a - b == x) + +blocksAllocd :: HalfsCapable b t r l m => + Word64 -- ^ expected #blocks unallocated + -> HalfsState b r l m -- ^ the filesystem state + -> PropertyM m a -- ^ the action to check + -> PropertyM m () +blocksAllocd x = rscUtil (\a b -> b >= a && b - a == x) + +zeroOrMoreBlocksAllocd :: HalfsCapable b t r l m => + HalfsState b r l m -- ^ the filesystem state + -> PropertyM m a -- ^ the action to check + -> PropertyM m () +zeroOrMoreBlocksAllocd = rscUtil (<=) + + +-------------------------------------------------------------------------------- +-- Debugging helpers + +dumpfs :: HalfsCapable b t r l m => + HalfsM b r l m String +dumpfs = do + sbRef <- hasks hsSuperBlock + dump <- dumpfs' 2 "/\n" =<< rootDir `fmap` readRef sbRef + return $ "=== fs dump begin ===\n" + ++ dump + ++ "=== fs dump end ===\n" + where + dumpfs' i ipfx inr = do + contents <- withDirectory inr $ \dh -> do + withDHLock dh $ readRef (dhContents dh) + foldM (\dumpAcc (path, dirEnt) -> do + sub <- if deType dirEnt == Directory + && path /= "." + && path /= ".." + then dumpfs' (i+2) "" (deInode dirEnt) + else return "" + return $ dumpAcc + ++ replicate i ' ' + ++ path + ++ let inr' = deInode dirEnt in + case deType dirEnt of + RegularFile -> " (" ++ show inr' ++ ") (file)\n" + Directory -> " (" ++ show inr' ++ ") (directory)\n" ++ sub + Symlink -> " (" ++ show inr' ++ ") (symlink)\n" + _ -> error "unknown file type" + ) + ipfx (M.toList contents)