packages feed

halfs 0.2 → 2.0

raw patch · 63 files changed

+5746/−8057 lines, 63 filesdep +HFusedep +bytestringdep +cerealdep −HUnitdep −networkdep −processdep ~basesetup-changednew-component:exe:halfsnew-component:exe:halfs-testsnew-uploader

Dependencies added: HFuse, bytestring, cereal, filepath, fingertree, halfs, time

Dependencies removed: HUnit, network, process

Dependency ranges changed: base

Files

− BinArray.hs 
@@ -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, () #) }--
− Binary.hs 
@@ -1,843 +0,0 @@-{-# OPTIONS -cpp -fglasgow-exts #-}-{-# OPTIONS -#include <strings.h> #-}-{-# 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"---
− Data/Array/SysArray.hs 
@@ -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)))------
− Data/Integral.hs 
@@ -1,67 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Integral--- --- Maintainer  :  Isaac Jones <ijones@galois.com>--- 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-
− Data/Queue.hs 
@@ -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
− FastMutInt.hs 
@@ -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, () #) }-
− Fsck.hs 
@@ -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"
− Halfs.hs 
@@ -1,1101 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--------------------------------------------------------------------------------- |--- Module      :  Halfs------ Maintainer  :  Isaac Jones <ijones@galois.com>--- Stability   :  alpha--- Portability :  GHC------ High-level interface to Halfs, the Haskell Filesystem.--module Halfs (-              -- * Write-related functions-              unlink, rmdir, rename, mkdir, addChildWrite, openWrite-              ,openAppend, write, writeString, closeWrite-              ,openFileAtPathWrite--              -- * Read-related functions-              ,stat, fstat, openRead ,Halfs.read, closeRead-              ,seek, openFileAtPathRead--              -- * Meta-data functions-              ,fsStats, getDirectoryContents, isDirectory, getDirectoryDetails--              -- * Creating new filesystems-              ,newFS, withNewFSWrite--              -- * Mounting filesystems-              ,mountFS ,unmountFS, unmountWriteFS, mountFSMV-              ,withFSRead, withFSWrite--              -- * Evaluating the 'FSRead' and 'FSWrite' moands-              ,evalFSWriteIOMV, evalFSReadIOMV--              -- * fsck-              ,fsck, fsckWrite-              ,syncPeriodicallyWrite, readReadRef--              -- * Types (most are re-exported from elsewhere)-              ,FSWrite, FSRead, TimeT(..), SizeT-              ,FileHandle, FileMode(..), Halfs.Buffer.Buffer-              ,DeviceLocation, InodeMetadata(..), Inode(..)--              -- * Types to make abstract (FIX)-              ,StateHandle(..), RdStat(..), FileSystemStats(..), FSStatus(..)--              -- * testing-              ,makeFiles, unitTests-              ) where--import Halfs.BasicIO (getMemoryBlock,-                      getInodesBin, readInodeBootStrap,-                      getInodeWrite, getInodeRead, allBlocksInInode)-import Halfs.Blocks(numBlocksForSize)-import Halfs.Buffer(Buffer, buffGetHandle, strToNewBuff, newBuff, buffToStr)-import Halfs.BufferBlockCache(clearBBCache, createCache, checkBBCache)-import qualified Halfs.TheBlockMap as BM (newFS)-import qualified Binary(resetBin)-import Halfs.TheBlockMap (bmTotalSize, freeBlocks)-import Halfs.BuiltInFiles (readInodeMapFile, readBlockMapFile)-import Halfs.CompatFilePath (splitFileName)-import Halfs.Directory (Directory(..), addChild, hasChild,-                        getChildrenNames, emptyDirectoryCache, directoryCacheToList)-import qualified Halfs.FSState (get, put)-import Halfs.FSState(StateHandle(..)-                     -- writing-                     ,FSWrite, readToWrite, modify, runFSWrite-                     ,evalFSWriteIO, runFSWriteIO, unsafeWriteGet---UNUSED:	     ,unsafeReadGet-		     ,get, put-                     ,updateInodeCacheWrite, evalFSWriteIOMV-                     ,modifyFSWrite-                     -- reading-                     ,FSRead-                     ,runFSRead-                     ,newReadRef, readReadRef, modifyReadRef, writeReadRef---                     ,readMVarRW-                     ,modifyMVarRW_'-                     ,evalFSReadIOMV-                     -- misc-                     ,evalStateT-                     ,forkFSWrite-                     -- exceptions-                     ,throwError-                     ,alreadyExistsEx-                     -- unsafe FIX: REMOVE-                     ,unsafeLiftIOWrite-                     ,unsafeLiftIORead-                     ,putStrLnWriteRead-                    )--import Halfs.FSRoot(FSRoot(..), FileSystemStats(..),-                    fsRootInode, fsStats, FSStatus(..),-                    fsRootUpdateInodeCache, addToInodeCache, InodeCacheAddStyle(..),-                    getFromInodeCache, fsRootBmInode, emptyInodeCache,-                    InodeCache, fsRootUpdateDirectoryCache,-                    fsRootAllInodeNums)-import Halfs.FileHandle(FileMode(..), fhSeek, allocateInodeWrite-                       ,getDirectoryAtPath, newDirectory-                       ,getInodeAtPath, openFileAtPath, getSomethingAtPath-                       ,fhRead, fhWrite, fhCloseRead-                       ,fhOpenWrite, fhCloseWrite-                       ,fhOpenTruncate, doesPathExist)-import Halfs.TheInodeMap (TheInodeMap(..), emptyInodeMap)-import qualified Halfs.FileHandle as FH (FileHandle(..), unlink, fhInode, fileHandle')-import Halfs.Inode (Inode(..), InodeMetadata(..),-                    newInode, goodInodeMagic,-                    newFSRootDirInode, newFSRootInode, newFSBlockMapInode,-                    newFSInodeMapInode,-                    rootInodeDiskAddr)-import Halfs.SyncStructures (syncFSRoot, syncDirectoryToFile, shortSyncFSRoot)-import Halfs.TestFramework (Test(..), UnitTests, hunitToUnitTest,-                            assertEqual)-import System.RawDevice( RawDevice, makeRawDevice, devBufferRead-                      , newDevice, finalizeDevice)-import Data.Integral(INInt, INLong, fromIntegral' )-import Halfs.Utils(FileType(..), firstFreeInodeNum-                   ,rootInodeMagicNum, otherInodeMagicNum-                   ,mRemoveFile, DiskAddress-                   ,unimplemented, fromJustErr-                   -- inode numbers-                   ,blockMapInodeNum, inodeMapInodeNum, rootDirInodeNum,-                   rootInodeNum-                  )-import Halfs.BufferBlock(mkBufferBlock)--- base-import Control.Exception -- (assert,catch,throwIO)-import Control.Concurrent(newMVar, MVar, threadDelay, readMVar,myThreadId)-import Control.Monad(unless, when)-import Control.Monad.Error (throwError)-import Data.Map (Map)-import qualified Data.Map as Map-import Data.IORef (IORef)-import Data.Set(Set)-import qualified Data.Set as Set-import Data.Queue (queueToList)-import Foreign.Storable (Storable)-import Foreign.C.Types (CLong)-import Data.List(group,sort)-import System.Exit(exitFailure)----import System.IO (hPutStrLn,stderr,hFlush)--type FileHandle = IORef FH.FileHandle---- |The location of a device might be a path to the device on a Linux--- filesystem.-type DeviceLocation = String---- |Move this filehandle to given position.-seek :: FileHandle-     -> INLong -- ^What byte offset to move the filehandle to.  Must be > 0 and < the number of bytes in the file.-     -> FSRead ()-seek fh pos = modifyReadRef fh (\fh' -> fhSeek fh' pos)---- --------------------------------------------------------------- * Writing--- ---------------------------------------------------------------- |Delete this file.  Currently can be used to delete a directory,--- but that should probably be FIXED.--unlink :: FilePath -> FSWrite ()-unlink path = do-  let (pathTo, theName) = splitFileName path-  dir@Directory{dirFile=FH.FileHandle{FH.fhInodeNum=_fi, FH.fhSeekPos=_fs}}-      <- readToWrite $ getDirectoryAtPath pathTo-  FH.unlink dir theName-  --ignore the returned directory; FH.unlink updates it in cache-  return ()---  updateDirectory newDir{dirFile=FH.FileHandle fi fs WriteMode}---- Remove this empty directory---                        case mode $ metaData inode of---                          File -> return () -- no problem---                          Dir -> do d <- readToWrite $ readDirectory inode---                                    when (length (filePathsNoDots(getChildrenNames d))---                                          > 0)---                                         (throwError (userError ("directory not empty")))---                          SymLink -> unimplemented "Symlinks"----- |Unlink this directory.  Should only be called on empty--- directories.  Does /not/ descent into sub-directories. Should fail--- if given a file or if the directory is non-empty (but currently--- doesn't: FIX).-rmdir  :: FilePath -> FSWrite ()-rmdir = unlink -- FIX: fail if it's a file, fail if it's non-empty---- |Rename this file.  Rename the file named as /From/ to the file--- named as /To/.  Can throw an exception if /From/ doesn't exist.-rename :: FilePath -- ^From-       -> FilePath -- ^To-       -> FSWrite ()-rename fromPath toPath = do-  let (toParentPath, toName)     = splitFileName toPath-   -- Q: what's the purpose of this next action? Its side-effect?-  _fromInode <- readToWrite $ getInodeAtPath fromPath-  toDirTemp <- readToWrite $ getDirectoryAtPath toParentPath-  toDir <- if toDirTemp `hasChild` toName-               then FH.unlink toDirTemp toName-               else return toDirTemp-  fromInode <- readToWrite $ getInodeAtPath fromPath-  addChildWrite toDir fromInode toName-  unlink fromPath---- |Create an empty directory at this path.  Throws an error if--- something already exists at this path.-mkdir :: FilePath -> FSWrite ()-mkdir dirPath = do-  theNewInode <- newChildInode dirPath Dir -- throws error if exists. that's good.-  let dir@Directory{dirFile=FH.FileHandle{FH.fhInodeNum=fi, FH.fhSeekPos=fs}}-          = newDirectory (inode_num $ metaData theNewInode)-  updateDirectory dir{dirFile=FH.fileHandle' fi fs WriteMode}---- |Like Direcotry.addChild, but in the FSWrite monad, and syncs this--- directory.-addChildWrite :: Directory   -- ^to add to /directory/-              -> Inode       -- ^new child's /inode/-              -> String      -- ^Name of child to create inside /directory/.-              -> FSWrite Inode-addChildWrite d i f =-  let mRet = addChild d i f-  in case mRet of-      Nothing -> throwError (alreadyExistsEx ("addChildWrite:" ++ f))-      Just (d', i') -> do updateDirectory d'-                          updateInodeCacheWrite i'-                          return i'---- |Creates child inode based on the path-newChildInode :: FilePath -- ^path components, last component is name, previous components are parent directories. all parents must exist, child must not exist.-              -> FileType-              -> FSWrite Inode-newChildInode dirs filetype = do-  let (pathTo, childFileName) = splitFileName dirs-  parentDirTemp <- readToWrite $ getDirectoryAtPath pathTo-  parentDir <- if parentDirTemp `hasChild` childFileName-               then FH.unlink parentDirTemp childFileName-               else return parentDirTemp-  inodeNum <- allocateInodeWrite-  let inode = newInode inodeNum filetype-  addChildWrite parentDir inode (assert (goodInodeMagic inode) childFileName)--{---- |Open the given file for writing. FIX: Test-openTrunc :: FilePath-          -> FSWrite FileHandle-openTrunc path =-  (openFileAtPathWrite WriteMode path File True >>= readToWrite . newReadRef)--}---- |Open the given file for writing.  If a file exists at this--- location, it gets overwritten. FIX: Test-openWrite :: FilePath-          -> FSWrite FileHandle-openWrite = openHelper WriteMode---- |Open the given file for appending. If a file already exists at--- this location, it gets opened for writing, and the file pointer is--- pointing to the end.  FIX: Test, what does it do if no such file exists.-openAppend :: FilePath-           -> FSWrite FileHandle-openAppend = openHelper AppendMode---- |Abstraction over 'openWrite' and 'openAppend'.-openHelper :: FileMode-           -> FilePath-           -> FSWrite FileHandle-openHelper mode path-    = openFileAtPathWrite mode path File False >>= readToWrite . newReadRef---- |Much like getDirectoryAtPath, builds a handle out of this--- filepath.  May throw IO Error! FIX: annotate w\/ errors--- thrown. FIX: throw errors for incorrect mode.--openFileAtPathWrite :: FileMode-                    -> FilePath-                    -> FileType -- for WriteMode only-                    -> Bool     -- truncate?-                    -> FSWrite FH.FileHandle-openFileAtPathWrite WriteMode path _theMode True = do-  inode <- readToWrite $ getSomethingAtPath (\i -> return i) path-  fhOpenTruncate $ inode_num $ metaData inode-openFileAtPathWrite WriteMode path theMode False = do-  inode <- newChildInode path theMode-  fhOpenWrite $ inode_num $ metaData inode-openFileAtPathWrite AppendMode path _ _ = do-  Inode{metaData=InodeMetadata{mode=m-                              ,inode_num=i-                              ,num_bytes=loc}}-      <- readToWrite (getSomethingAtPath (\i -> return i) path)-  case m of-    File -> do fh <- fhOpenWrite i-               return fh{FH.fhMode=AppendMode-                        ,FH.fhSeekPos=loc}-    Dir -> throwError (userError (dirFileError path))-    SymLink -> unimplemented "Symlinks"-openFileAtPathWrite md path _ _ =-  throwError (userError ("openFileAtPathWrite: unsupported file mode " ++ show (md,path)))--openFileAtPathRead :: FilePath-                   -> FSRead FH.FileHandle-openFileAtPathRead path =-  getSomethingAtPath (\Inode{metaData=InodeMetadata{mode=m-                                                  ,inode_num=i}}-                          -> case m of-                              File -> do-                                         return $ FH.fileHandle' i 0 ReadMode-                              Dir -> throwError (userError (dirFileError path))-                              SymLink -> unimplemented "Symlinks")-                      path--dirFileError :: FilePath -> String-dirFileError path = "directory encountered where file expected: " ++ path---- |Write from the given buffer into the file.-write :: FileHandle-      -> Buffer -- ^Buffer to write from-      -> INInt  -- ^Offset into above buffer FIX: should we allow current loc-      -> INInt  -- ^How many to write-      -> FSWrite INInt-write fRef b off num = do-  f <- readToWrite $ readReadRef fRef-  (outF, i) <- fhWrite f (buffGetHandle b) off num-  readToWrite $ writeReadRef fRef outF-  return i---- |Helpfer function for writing a string to a file.-writeString :: FileHandle-            -> String-            -> FSWrite INInt-writeString h s = do-  b <- unsafeLiftIOWrite $ strToNewBuff s-  write h b 0 (fromIntegral $ length s)---- |Close a file that's open for writing.-closeWrite :: FileHandle -> FSWrite ()-closeWrite f = do (readToWrite $ readReadRef f) >>= fhCloseWrite---		  fsckWrite---- --------------------------------------------------------------- * Reading--- ---------------------------------------------------------------- |Get basic information about the file at this path.-stat :: FilePath -> FSRead RdStat-stat f = do-  h <- openRead f-  s <- fstat h-  closeRead h-  return s---- |Get basic information about this file handle.-fstat :: FileHandle -> FSRead RdStat-fstat f = do-  h <- readReadRef f-  Inode{metaData=InodeMetadata{mode=m-                              ,num_bytes=sz}} <- FH.fhInode h-  case m of-   File -> return $ RdFile (TimeT 0) sz-   Dir  -> return $ RdDirectory (TimeT 0)-   SymLink -> unimplemented "fstat{SymLink}"---- |Does this filepath refer to a directory?-isDirectory :: FilePath -> FSRead Bool-isDirectory f = do-  h' <- openRead f-  h <- readReadRef h'-  inode <- FH.fhInode h-  let ret = case mode $ metaData inode of-            File -> False-            Dir  -> True-            SymLink -> unimplemented "isDirectory{SymLink}"-  closeRead h'-  return ret----- |Open this file for reading. FIX: test.-openRead :: FilePath-         -> FSRead FileHandle-openRead path = openFileAtPath path ReadMode >>= newReadRef---- |Read from this file handle into this buffer.-read :: FileHandle-     -> Buffer -- ^Buffer to read into-     -> INInt  -- ^Offset into above buffer-     -> INInt  -- ^How many to read-     -> FSRead INInt-read fref b off sz = do-  f <- readReadRef fref-  (f', i) <- fhRead f (buffGetHandle b) off sz-  writeReadRef fref f'-  return i---- |Close a filehandle that's open for reading.-closeRead :: FileHandle -> FSRead ()-closeRead h = do readReadRef h >>= fhCloseRead---		 fsckRead---- |Get the contents of a directory.-getDirectoryContents :: FilePath -> FSRead [FilePath]-getDirectoryContents path-    = getDirectoryAtPath path >>= return . getChildrenNames---- |Caller may want to filter out "." and ".."-getDirectoryDetails :: FilePath -> FSRead [(String, Inode)]-getDirectoryDetails path = do-  namesNums <- getDirectoryAtPath path >>= return . Map.toList . dirContents-  mapM (\(n,iNum) -> do i <- getInodeRead iNum Nothing-                        return (n, i)) namesNums---- --------------------------------------------------------------- * Mounting and Control Interface--- ---------------------------------------------------------------- |Mount the given file system for writing and perform these--- operations. FIX: Maybe add MVar () for blocking on.-withFSWrite :: DeviceLocation              -- ^Location of device-            -> FSWrite a -- ^Operations to perform-            -> IO a-withFSWrite path f = do-  fsroot <- mountFS Nothing path False 500-  blockOn <- newMVar fsroot-  evalStateT (runFSWrite f) (StateHandle blockOn Nothing)---- |Mount the given file system for reading and perform these--- operations.-withFSRead :: DeviceLocation              -- ^Location of device-           -> FSRead a -- ^Operations to perform-           -> IO a-withFSRead path f = do-  fsroot <- mountFS Nothing path True 500 -- Nothing == No read-down.-  rootVar  <- newMVar fsroot-  evalStateT (runFSRead f) (StateHandle rootVar Nothing)---- |Create a new file system and perform the given operations.  Unmounting--- is up to the caller.  See 'newFS' for parameter details.-withNewFSWrite :: String-               -> INInt-               -> FSWrite a -- ^Operations to perform-               -> IO a-withNewFSWrite path len f = do-  mRemoveFile path-  newFS path len-  withFSWrite path f---- --------------------------------------------------------------- * Mounting and Control Helpers--- ---------------------------------------------------------------- |Creates a new filesystem with a real-life root inode! Out of thin--- air, create a buffer block for this device, 0, and write root inode--- to our new cache.-newFS :: DeviceLocation-      -> INInt  -- ^desired length of the new filesystem in blocks-      -> IO ()-newFS path fileLen = do-  -- this block map marks 0 and 1 as used:--  dev <- newDevice Nothing path fileLen----  realBlocks <- blocksInDevice dev---  when (realBlocks < (fromIntegral fileLen))---        (error $ "requested FS size greater than physical disk.  blocks: " ++ (show fileLen) ++ " size: " ++ (show realBlocks))--  theCache <- createCache 500-  let blockMap' = BM.newFS fileLen--  let d = newDirectory rootDirInodeNum-  let fsroot'    = FSRoot dev theCache blockMap' emptyInodeCache-                         (emptyInodeMap firstFreeInodeNum)-                         emptyDirectoryCache FsReadWrite--  -- add various distinguished inodes to the inode cache-  let fsroot = foldl fsRootUpdateInodeCache fsroot' [newFSRootInode-                                                    ,newFSBlockMapInode-                                                    ,newFSInodeMapInode-                                                    ,newFSRootDirInode]-  -- Write out the root directory. FIX: Remove when we have diredctory cache?-  (_, fsroot1) <- runFSWriteIO (syncDirectoryToFile d) fsroot--  -- sync the FS and close the device-  unmountFS fsroot1-	-- You cant return the cache, because we lose it when we unmount-	--   return theCache-  return ()-  -- todo: new inode map-  -- todo: flush cache---- |Periodically sync the filesystem.  Usually forked off in its own--- thread.  For READS: Flush caches on read-only filesystem (so--- they'll be re-populated). For WRITES: write out the filesystem--- data. FIX: remove readOnly; that's in the fsroot.  FIX: add--- exception handler (since it does a take)-syncPeriodicallyWrite :: MVar () -- ^High-level blocker.  This function blocks on this mvar.-                      -> Bool-                      -> FSWrite ()-syncPeriodicallyWrite blockOn readOnly = do-  FSRoot{fsStatus=status} <- unsafeWriteGet -- safe-  putStrLnWriteRead $ "Periodically syncing: " ++ (show status)-  case status of-    FsUnmounted -> putStrLnWriteRead "exiting periodic thread." -- done with this thread.-    _ -> do-      modifyMVarRW_' blockOn (\_ -> do-           putStrLnWriteRead "taken."-           case status of-              FsReadOnly -> do r <- get-                               fsroot <- unsafeLiftIOWrite $ fsRootClearCaches r-                               put (assert (readOnly == True) fsroot)--              FsReadWrite -> do FSRoot{device=_d} <- unsafeWriteGet-                                assert (readOnly == False) shortSyncFSRoot-              FsUnmounted -> assert False (return ())-         )-      putStrLnWriteRead "sync completed."-      unsafeLiftIOWrite $ threadDelay $ secondToMicroSecond 60-      syncPeriodicallyWrite blockOn readOnly--secondToMicroSecond :: Int -> Int-secondToMicroSecond n = n * 1000000--fsRootClearCaches :: FSRoot -> IO FSRoot-fsRootClearCaches fsroot = do-  clearBBCache (assert ((fsStatus fsroot) == FsReadOnly) (bbCache fsroot))-  newInodeCache <- getDistinguishedInodes (device fsroot)-  -- might need to move this up if getDistinguishedInodes needs it.-  return (fsroot {inodeCache=newInodeCache-                 ,directoryCache=emptyDirectoryCache-                 })--getDistinguishedInodes :: RawDevice -> IO InodeCache-getDistinguishedInodes rawDev = do-  -- todo get inode numbers of block map, inodemap and root directory-  -- from root inode. hard-coded in Utils for now.--  -- re-read the fundamental inodes from disk.-  rootInodeBuffer <- getMemoryBlock-  rootInodeBufferBlock <- mkBufferBlock rootInodeBuffer rawDev rootInodeDiskAddr-  devBufferRead rawDev rootInodeDiskAddr rootInodeBuffer-  Binary.resetBin rootInodeBuffer---   sequence $ map (\_ -> do (w::Word8) <- Binary.get rootInodeBuffer---                            putStr (show w)---                            putStr ",") (replicate 200 ())-  Binary.resetBin rootInodeBuffer-  (readRootInode:_) <- getInodesBin rootInodeBufferBlock-  -- get inode of blockMap using blockMapInodeNum-  (_newBlockMapInode, newInodeCache')-       <- readInodeBootStrap (fst $ addToInodeCache InodeCacheOverwrite-                                       (emptyInodeCache, rootInodeNum)-                                       (assert (goodInodeMagic readRootInode) readRootInode))-                             rawDev readRootInode blockMapInodeNum-  (_inodeMapInode, newInodeCache'')-       <- readInodeBootStrap newInodeCache' rawDev readRootInode inodeMapInodeNum-  (_newRootDirInode, newInodeCache)-       <- readInodeBootStrap newInodeCache'' rawDev readRootInode rootDirInodeNum-  return newInodeCache---- |See 'mountFS' for most documentation.-mountFSMV :: Maybe StateHandle-          -> DeviceLocation-          -> Maybe (MVar () ) -- ^the outermost-blocker, if desirable.  causes a synchronization thread to be spawned-          -> Bool-	  -> Int -- ^cache size-          -> IO StateHandle-{--mountFSMV mSH path (Just mCache) blockOn readOnly cacheSize = do-  fsr <- mountFS mSH path mCache readOnly-  mv <- newMVar fsr-  let sh = StateHandle mv blockOn-  case blockOn of-    Nothing -> return ()-    Just b -> evalFSWriteIOMV (forkFSWrite (syncPeriodicallyWrite b readOnly)>> return ()) sh-  return sh--}-mountFSMV mSH path blockOn readOnly cacheSize = do-   -- Q: what's the purpose of this next action?-  _c <- createCache cacheSize-  mv <- mountFS mSH path readOnly cacheSize >>= newMVar-  let sh = StateHandle mv blockOn-  case blockOn of-    Nothing -> return ()-    Just b -> evalFSWriteIOMV (forkFSWrite (syncPeriodicallyWrite b readOnly)>>return ()) sh-  return sh---- |Basic low-level @mount@ operation.  Usually used via wrappers such as 'withFSWrite' and 'withFSRead'.  See also 'newFS'.-mountFS :: Maybe StateHandle -- ^if Just, use the raw device inside-        -> DeviceLocation    -- ^Location of device-        -> Bool              -- ^Read only?-	-> Int               -- ^buffer block cache size-        -> IO FSRoot-mountFS mSH path readOnly cacheSize = do-  (mRD,cache)-      <- case mSH of-          Nothing -> do cache <- createCache cacheSize-		        return (Nothing,cache)-          Just (StateHandle shM _) -> do FSRoot{device=r, bbCache=c} <- readMVar shM-                                         return $ (Just r,c)-  rawDev <- makeRawDevice mRD path-  -- read root inode-  inodeCache1 <- getDistinguishedInodes rawDev--  -- using fromJustErr here because the above call populates the inode-  -- cache, and we can't call getInode (which is safer) yet because we-  -- don't have a fully-formed fsroot-  let newBlockMapInode = fromJustErr "block map inode not in inode cache during mount"-                           (getFromInodeCache inodeCache1 blockMapInodeNum)-  let inodeMapInode    = fromJustErr "inode map inode not in inode cache during mount"-                           (getFromInodeCache inodeCache1 inodeMapInodeNum)--  -- read block map-  -- have to fake up an fsroot for bootstrapping here.-  let partFsroot = FSRoot rawDev cache-                       (error "undefined") inodeCache1-                       (emptyInodeMap firstFreeInodeNum)-                       emptyDirectoryCache-                       (if readOnly then FsReadOnly else FsReadWrite)-  -- warning! fsroot not fully formed:-  (_, fsroot) <- runFSWriteIO -- makes its own mvar :(-    (do bm <- readToWrite $ readBlockMapFile newBlockMapInode-        modify (\fsroot -> fsroot{blockMap=bm})-        im <- readToWrite $ readInodeMapFile inodeMapInode--        modify (\fsroot -> fsroot{inodeMap=im})-    ) partFsroot-  return fsroot---- |Syncs the device and closes its handle.  You should stop using it--- after that.  Must represent an open device!-unmountFS :: FSRoot -> IO ()-unmountFS fsroot@FSRoot{device=d, fsStatus=status} = do-  when (status==FsReadWrite) (evalFSWriteIO syncFSRoot fsroot)-  finalizeDevice d---   evalFSWriteIO get fsroot -- couln't work; should take the mvar or something.-  return ()---- |Just like 'unmountFS' but in the 'FSWrite' monad.-unmountWriteFS :: FSWrite ()-unmountWriteFS = do-  modifyFSWrite $ \fsr@FSRoot{fsStatus=status} -> do-    unsafeLiftIOWrite $ unmountFS (assert (status==FsReadWrite) fsr)-    return (fsr{fsStatus=FsUnmounted}, ())-  return ()---- |Check the filesystem for errors.  Exits with an error code and--- message if any are found.  Outputs lots of low-level data to the--- terminal.--fsck :: DeviceLocation -> IO ()-fsck devPath = do-  fsroot <- mountFS Nothing devPath True 500-  fsck' fsroot--fsck' :: FSRoot -> IO ()-fsck' fsroot@FSRoot{inodeMap=theInMap-                   ,directoryCache=dirCache-                   ,bbCache=bbC-                   ,blockMap=theBlockMap} = catchAll $ do-  let totalBlocks = bmTotalSize theBlockMap-  tid <- myThreadId-  putStrLn $ "############################ F S C K ##############################" ++ show tid-  putStrLn $ "root inode: " ++ (show $ fsRootInode fsroot)-  putStrLn $ "blockMap inode: " ++ (show $ fsRootBmInode fsroot)-  bbCacheInfo <- checkBBCache bbC-  putStrLn $ "(bbCacheSize, bbCacheNumDirty,hits,misses): " ++ (show bbCacheInfo)-  let maxInode = (imMaxNum theInMap) - 1-  let allPossibleBlocks = Set.fromList $ [0 .. (totalBlocks - 1)]-  let allInodeNums = fsRootAllInodeNums fsroot-  putStrLn $ "Max inode num: " ++ (show maxInode)-  putStr $ "There are a total of: " ++ (show $ Set.size allInodeNums) ++ " inodes"-  putStrLn $ " and " ++ (show $ length $ freeInodes theInMap) ++ " free inodes."-  putStrLn $ "Free Inodes: " ++ (show $ freeInodes theInMap)--{-  unless ((cardinality allInodeNums) + (length $ freeInodes theInMap) == maxInode)-         (error "all inode nums doesn't add up (see above)")--}--  let dirInodeNums = show [FH.fhInodeNum (dirFile d)-                               | d <- directoryCacheToList dirCache]-  putStrLn $ "inode nums in directory cache: " ++ dirInodeNums-  (_, _fsroot) <- runFSWriteIO (do-    let mapabs = Set.map abs-    let freeList= queueToList (freeBlocks $ blockMap fsroot)-    let freeSet = mapabs $ Set.fromList $ freeList--    when (Set.size freeSet /= length freeList) (-       error $ "freeList contains duplicates, should never happen: " ++-		   show [ head vs-			| vs <- group (sort freeList)-		        , length vs > 1-		        ])--    theMapping <- buildBlockToInodeMapping (Set.toList allInodeNums) allPossibleBlocks Map.empty-    putStrLnWriteRead $ "The block map [(blockNum, inodeNum)]: " ++ (show $ Map.toList theMapping)-    let usedBlocks = mapabs $ Set.fromList $ Map.keys theMapping-    let usedBlocksMarkedFree = freeSet `Set.intersection` usedBlocks--    unless (Set.null usedBlocksMarkedFree)-           (do let theBadPairs = getPairsFor (Set.toList usedBlocksMarkedFree) theMapping-               badInodes <- mapM (\(_,x) -> getInodeWrite x Nothing) theBadPairs-               error $ "used blocks in inodes marked as free. [(blockNum, inodeNum)]: "-                  ++ (show $ theBadPairs) ++ "\n" ++ (show badInodes)-           )--    let leakedBlocks = allPossibleBlocks `Set.difference` (freeSet `Set.union` usedBlocks)-    unless (Set.null leakedBlocks) (error $ "Leaked blocks: "-                                                ++ (show $ Set.toList leakedBlocks))-      ) fsroot--  putStrLn $ "(END)####################### F S C K ###########################(END)" ++ show tid-  return ()-      where getPairsFor :: (Show a,Ord a) => [a] -> Map a b -> [(a,b)]--            -- this fromJustErr should never break;-            -- list is taken from the map itself:-            getPairsFor theElems mapping-                = [(x, fromJustErr-                         ("attempt to look up element not in mapping: " ++ show x)-                         (Map.lookup x mapping))-                   | x <- theElems]--	    catchAll body = Control.Exception.catch body-						(\ e -> do putStrLn "fsck' failure"-							   print e-							   exitFailure)----- |See 'fsck'.-fsckWrite :: FSWrite ()-fsckWrite = unsafeWriteGet >>= unsafeLiftIOWrite . fsck'--{- UNUSED:-fsckRead :: FSRead ()-fsckRead = unsafeReadGet >>= unsafeLiftIORead . fsck'--}---- |Lookup all the inodes, get their block pointers, and verify that--- no two inodes have the same block pointer, in which case, crashes--- with an error for now.-buildBlockToInodeMapping :: [INInt] -- ^All inode nums-			-> Set DiskAddress		-- ^ all possible disk addresses-                         -> Map DiskAddress INInt -- initial mapping-                         -> FSWrite (Map DiskAddress INInt)-buildBlockToInodeMapping [] _allAddr inMap = return inMap-buildBlockToInodeMapping (inodeNum:t) allAddr inMap = do-  inode <- getInodeWrite inodeNum Nothing-  -- FIX: need to check level-two blocks too :(-  allBlocks <- allBlocksInInode (assert (goodInodeMagic inode) inodeNum)-  let numBlocksInInode = length allBlocks-  when (numBlocksForSize inode > fromIntegral' numBlocksInInode)-      (error $ "The inode does not have enough blocks to match its size.  Number it should have, based on size: " ++ (show (numBlocksForSize inode)) ++ " number it actually has: " ++ (show numBlocksInInode) ++ "\n" ++ show inodeNum ++ "\n" ++ show inode)---  when (inodeNum == 107) (---	unsafeLiftIOWrite $ print ("inside 107 : ",allBlocks,inode)---   )---  let newMap = checkInodeBlocks allBlocks-                                (inode_num $ metaData inode) allAddr inode inMap-  buildBlockToInodeMapping t allAddr newMap---- |Called by 'fsck'.  Checks consistency of the blocks in the given--- inode.  Checks for inodes with invalid block numbers, two inodes--- with the same block.-checkInodeBlocks :: [DiskAddress]-                 -> INInt -- inode number-		 -> Set DiskAddress-		 -> Inode-                 -> Map DiskAddress INInt-                 -> Map DiskAddress INInt-checkInodeBlocks [] _ _allAddr _ inMap = inMap-checkInodeBlocks (blk:t) inodeNum allAddr inode inMap-    | blk == 0 && (not (inodeNum == 0)) -- first block of root inode-            = assert False inMap -- should already be filtered.-    | not (abs blk `Set.member` allAddr)-		= error $ "inode with invalid block number: inode=" ++-				show inodeNum ++ " addr = " ++ show blk ++ "\n" ++-				show inode-    | otherwise =-        case Map.lookup blk inMap of-           Nothing -> keepGoing-           -- FIX: probably want to do better sort of error checking-           Just a  -> if (a /= inodeNum)-                      then error $ "two inodes with same block: "-                               ++ (show a) ++ " & " ++ (show inodeNum)-                               ++ " block number: " ++ (show blk)-                      else keepGoing-    where keepGoing = checkInodeBlocks t inodeNum allAddr inode (Map.insert blk inodeNum inMap)---- --------------------------------------------------------------- * Misc--- ---------------------------------------------------------------- |This seems to be the kind of Stat information needed by the TSE--- front end.-data RdStat-  = RdDirectory{ modTime :: TimeT }-  | RdFile{ modTime :: TimeT, size :: SizeT }-  deriving (Eq, Show)--{- UNUSED:-notDone :: a-notDone = error "Undefine"--}--newtype TimeT = TimeT CLong deriving (Show, Read, Eq, Storable, Ord)---type SizeT = INLong--- type Buffer = BinHandle---- |Updates this directory's entry in the cache-updateDirectory :: Directory -> FSWrite ()-updateDirectory dir =-  modify (fsRootUpdateDirectoryCache dir)---- --------------------------------------------------------------- * Testing--- --------------------------------------------------------------testFSLoc :: FilePath-testFSLoc = "halfs-client1"--unitTests :: Bool -> UnitTests-unitTests fast = hunitToUnitTest (hunitTests fast)--theContents :: [FilePath]-theContents =  ["bin", "dev", "etc", "lib", "tmp"]--dirFS :: FilePath-dirFS = "halfs-client1"--assertEqualWrite :: (Eq a, Show a) => String -> a -> a -> FSWrite ()-assertEqualWrite s a b = unsafeLiftIOWrite $ assertEqual s a b---- |for testing. Create some files in the given directory-makeFiles :: Int -- ^Number of files-          -> FilePath -- ^Where to put them-          -> String -- empty if you don't want to write anything to it-          -> FSWrite ()-makeFiles n p s | n <= 0 = return ()-                | otherwise = do-  h <- openWrite $ p ++"/" ++ "smallFile" ++ (show n)-  when (s /= "")-    (writeString h s>>return())-  closeWrite h-  makeFiles (n - 1) p s--makeManyFiles :: Int        -- ^Number of files-              -> FilePath   -- ^where to put them-	      -> FSWrite ()-makeManyFiles numFiles dirLoc = do-  putStrLnWriteRead $ "creating " ++ (show numFiles)-                          ++ " files in " ++ (show dirLoc)-  -- num blocks = numFiles * (inodesPerBlock / bytesPerInode)-  makeFiles numFiles dirLoc ""-  dirs <- readToWrite $ getDirectoryContents dirLoc-  assertEqualWrite "correct size after creating a few files"-                    (numFiles + 1) (length dirs)-  assertEqualWrite "dot in dir" "." (head dirs)-  fsckWrite--slowTests :: [Test]-slowTests =-  [-   TestLabel "large fs" $ TestCase $ do-      newFS dirFS 40000 -- a big filesystem-      fsroot <- mountFS Nothing dirFS True 500-      fsck' fsroot-      unmountFS fsroot-   ,TestLabel "MANY files" $ TestCase $ withFSWrite dirFS $ do-    -- depends on previous large filesystem case-      makeManyFiles 10000 "/"-      unmountWriteFS-   ,TestLabel "re-mounting after writing MANY files" $ TestCase $ do-      fsroot <- mountFS Nothing dirFS False 500-      unmountFS fsroot--   , TestLabel "some appends" $ TestCase $ do-    withNewFSWrite dirFS 10 (unmountWriteFS)-    withFSWrite dirFS $ do-      h <- openWrite "/log"-      closeWrite h-      sequence [ do fd <- openAppend "/log"-	    	    writeString fd (show i)-		    closeWrite fd-               | i <- [(1::Int)..100]-	       ]-      fsckWrite-      unmountWriteFS-   ,TestLabel "many appends" $ TestCase $ do-    let count = 50-    withNewFSWrite dirFS 20 (unmountWriteFS)-    withFSWrite dirFS $ do-      fsckWrite-      let input = [ init (take (n `mod` 1003) (cycle (show i ++ ","))) ++ "#"-		  | (i,n) <- zip [(1::Int)..] (take count $ iterate (* 234587) 1)-	 	  ]-      mkdir "/test"-      h <- openWrite "/test/log"-      closeWrite h-      sequence [ do fd <- openAppend "/test/log"-		    writeString fd str---                  unsafeLiftIOWrite $ print $ "writing : " ++ show str-		    closeWrite fd-		    let str_ref = concat (take i input)-		    readToWrite $ do-  		      fd2 <- openRead "/test/log"-		      buff <- unsafeLiftIORead $ newBuff (length str_ref)-		      n <- Halfs.read fd2 buff 0 (fromIntegral $ length str_ref)-		      if (fromIntegral n == length str_ref)-			then return ()-			else error $ "read incorrect number of bytes"-	              closeRead fd2-		      str_read <- unsafeLiftIORead $ buffToStr buff---                      unsafeLiftIORead $ print $ "compareing : " ++ show (str_ref,str_read)-		      if str_ref == str_read-		        then return ()-			else error ("append failed to write then read at byte: " ++-				    show (head [ j | (j,a,b) <- zip3 [(0::Int)..] str_ref str_read, a /= b ],n,i))--		| (i,str) <- zip [1..] input ]-      fsckWrite-      unmountWriteFS--   , TestLabel "large, large file" $ TestCase $ do-      newFS dirFS 40000 -- a big filesystem-      fsroot <- mountFS Nothing dirFS True 500-      unmountFS fsroot-      withFSWrite dirFS $ do-        h <- openWrite "/large"-        closeWrite h-        sequence [ do fd <- openAppend "/large"-                      writeString fd ((show i) ++ take 1031 (cycle "#"))-                      closeWrite fd-                      when ((i `mod` 1000) == 0) $-                                fsckWrite-                 | i <- [(1::Int)..10000]-               ]-        fsckWrite-        unmountWriteFS--   , TestLabel "smaller fs" $ TestCase $ do-      withNewFSWrite dirFS 500 (unmountWriteFS)-  ]--hunitTests :: Bool -> [Test]-hunitTests fast =-  [TestLabel "isaacfs and read root inode" $ TestCase $ do---     mRemoveFile testFSLoc-     newFS testFSLoc 10 -- creates the file system-     -- verify that the root inode has the right magic number:-     dev <- makeRawDevice Nothing testFSLoc-     buffer <- getMemoryBlock-     bb <- mkBufferBlock buffer dev 0-     devBufferRead dev 0 buffer-     (rootInode':_) <- getInodesBin bb-     assertEqual "root inode magic number incorrect"-                 rootInodeMagicNum-                 (magic1 $ metaData rootInode')-     finalizeDevice dev--  ,TestLabel "mounting fs" $ TestCase $ do-     fsr <- mountFS Nothing testFSLoc False 500-     fsck' fsr-     assertEqual "root inode magic number incorrect"-                 rootInodeMagicNum-                 (magic1 $ metaData $ fsRootInode fsr)-     assertEqual "block map magic number incorrect"-                 otherInodeMagicNum-                 (magic1 $ metaData $ fsRootBmInode fsr)-     unmountFS fsr-  ,TestLabel "mounting and unmount a lot" $ TestCase $ do-     mountFS Nothing testFSLoc True 500 >>= unmountFS-     mountFS Nothing testFSLoc True 500 >>= unmountFS-     mountFS Nothing testFSLoc True 500 >>= unmountFS-     fsroot <- mountFS Nothing testFSLoc True 500-     fsck' fsroot-     unmountFS fsroot-  ,TestLabel "getInode" $ TestCase $ withNewFSWrite-                 "halfs-client1" 500 (do-     theNewInode <- getInodeWrite 16 Nothing-     unless ((magic1 $ metaData theNewInode) == otherInodeMagicNum)-            (error "bad magic in getInode case")---     let addr = getPointerAt theNewInode 0-     unmountWriteFS)-  ,TestLabel "making directories in memory" $ TestCase $-   withNewFSWrite dirFS 500  (do-     let ls = readToWrite . getDirectoryContents-         mkdirs = mapM_ mkdir-     mkdirs (map ('/':) theContents)-     mkdirs ["/lib/modules"-            ,"/lib/w00t"-            ,"/lib/w00t/foo"-            ,"/lib/init" -- will get overwritten-            ,"/lib/modules/foo"-            ,"/lib/modules/bar"-            ,"/lib/modules/bar/bang"]-     wootInode <- readToWrite $ getInodeAtPath "/lib/w00t"-     assertEqualWrite "hardLinks after mkdir" 1 (hard_links $ metaData wootInode)-     syncFSRoot-     wootInode1 <- readToWrite $ getInodeAtPath "/lib/w00t"-     assertEqualWrite "hardLinks after sync" 1 (hard_links $ metaData wootInode1)-     fsckWrite--     rename "/lib/w00t" "/lib/init"--     syncFSRoot-     fsckWrite--     ls "/lib/init" >>= assertEqualWrite "move directory worked" [".","foo"]--     ls "/" >>= assertEqualWrite "slash equal contents" (".":theContents)--     ls "/etc" >>= assertEqualWrite "etc dir empty pre-unmount" ["."]--     ls "/lib" >>= assertEqualWrite "lib dir has modules pre-unmount"-                        [".", "init", "modules"]--     ls "/lib/modules" >>= assertEqualWrite "lib dir has modules pre-unmount"-                        [".", "bar", "foo"]--     ls "/lib/modules/bar" >>= assertEqualWrite "lib dir has modules pre-unmount"-                        [".", "bang"]--     syncFSRoot-     fsckWrite-     syncFSRoot-     fsckWrite-     unmountWriteFS)-  ,TestLabel "remounting and seeing directories" $ TestCase $ do-    putStrLn "mounting for 'remount'"-    withFSWrite dirFS (do-     fsckWrite-     let ls = readToWrite . getDirectoryContents-         rm = unlink-     ls "/"    >>= assertEqualWrite "/ has theContents" (".":theContents)-     ls "/etc" >>= assertEqualWrite "etc dir empty post-unmount" ["."]--     ls "/lib" >>= assertEqualWrite "lib dir has modules post-unmount"-                        [".", "init", "modules"]-     ls "/lib/modules" >>= assertEqualWrite "lib dir has modules post-unmount"-                               [".", "bar", "foo"]-     ls "/lib/modules/bar" >>= assertEqualWrite "lib dir has modules post-unmount"-                               [".", "bang"]-     p <- readToWrite $ doesPathExist "/lib/modules/bar/bang"-     assertEqualWrite "path that does exist" p True--     p1 <- readToWrite $ doesPathExist "/no/way"-     assertEqualWrite "path that does not exist" p1 False--     rm "/lib/modules/bar/bang"-     ls "/lib/modules/bar" >>= assertEqualWrite "removing a dir non-root"-                               ["."]-{-     unsafeMkFSWrite $ copyFromHostT "tests/smallFile" "/etc/smallFile"-     ls "/etc" >>= assertEqualWrite "etc has smallFile" [".", "smallFile"]-     rm "/etc/smallFile"-}-     ls "/etc" >>= assertEqualWrite "etc delete smallFile" ["."]-     rm "/etc"-     ls "/" >>= assertEqualWrite "remove a dir in root" (filter (/= "etc") (".":theContents))--     -- Overflow a block boundry with a write:-     fh <- openWrite "/tempFile"-     myBuf <- unsafeLiftIOWrite $ strToNewBuff "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"-     readToWrite $ seek fh 4093-     write fh myBuf 0 50--     fsroot <- unsafeWriteGet-     getInodeWrite blockMapInodeNum Nothing >>=-           assertEqualWrite "read blockmap inode equals one in root"-                (fsRootBmInode fsroot)-     unmountWriteFS)-   ,TestLabel "mount and unmount after serveral syncs" $ TestCase $-     withFSWrite dirFS unmountWriteFS-   ,TestLabel "a few files" $ TestCase $ withNewFSWrite dirFS 50000 $ do-      makeManyFiles 50 "/"-      unmountWriteFS-   ,TestLabel "re-mounting after writing a few files" $ TestCase $ do-      fsroot <- mountFS Nothing dirFS False 500-      fsck' fsroot-      unmountFS fsroot-   ,TestLabel "a few files, in a non-root directory" $ TestCase $-    withFSWrite dirFS $ do-      fsckWrite-      mkdir "/test"-      makeManyFiles 200 "/test"-      unmountWriteFS-   ,TestLabel "large fs" $ TestCase $ do-      newFS dirFS 40000 -- a big filesystem-      fsroot <- mountFS Nothing dirFS True 500-      fsck' fsroot-      unmountFS fsroot-   ,TestLabel "quite a few files" $ TestCase $ withFSWrite dirFS $ do-    -- depends on previous large filesystem case-      makeManyFiles 1000 "/"-      unmountWriteFS-   ,TestLabel "re-mounting after writing quite a few files" $ TestCase $ do-      fsroot <- mountFS Nothing dirFS False 500-      unmountFS fsroot-   ,TestLabel "smaller fs" $ TestCase $ do-      withNewFSWrite dirFS 500 (unmountWriteFS)--  ] ++ (if fast then [] else slowTests)
− Halfs/BasicIO.hs 
@@ -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
− Halfs/BasicIO.hs-boot 
@@ -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 ()
− Halfs/BinaryMonad.hs 
@@ -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
+ Halfs/BlockMap.hs view
@@ -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+
− Halfs/Blocks.hs 
@@ -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)
− Halfs/Blocks.hs-boot 
@@ -1,9 +0,0 @@-module Halfs.Blocks where--import Halfs.Utils-import Halfs.Inode-import Halfs.FSState--getDiskAddrOfBlockRead :: Inode-                       -> BlockNumber-                       -> FSRead DiskAddress
− Halfs/Buffer.hs 
@@ -1,143 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Halfs.Buffer--- --- Maintainer  :  Isaac Jones <ijones@galois.com>--- 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
− Halfs/BufferBlock.hs 
@@ -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
− Halfs/BufferBlockCache.hs 
@@ -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---
− Halfs/BuiltInFiles.hs 
@@ -1,43 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Halfs.BuiltInFiles--- --- Maintainer  :  Isaac Jones <ijones@galois.com>--- 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---}
+ Halfs/Classes.hs view
@@ -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
− Halfs/CompatFilePath.hs 
@@ -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
+ Halfs/CoreAPI.hs view
@@ -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
Halfs/Directory.hs view
@@ -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
− Halfs/Directory.hs-boot 
@@ -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
+ Halfs/Errors.hs view
@@ -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             = "<unknown errno>"
− Halfs/FSRW.hs 
@@ -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-
− Halfs/FSRoot.hs 
@@ -1,201 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  FSRoot--- --- Maintainer  :  Isaac Jones <ijones@galois.com>--- 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-                        }
− Halfs/FSState.hs 
@@ -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
+ Halfs/File.hs view
@@ -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
− Halfs/FileHandle.hs 
@@ -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
− Halfs/FileHandle.hs-boot 
@@ -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-                 }
+ Halfs/HalfsState.hs view
@@ -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.+  }
Halfs/Inode.hs view
@@ -1,245 +1,1339 @@--------------------------------------------------------------------------------- |--- Module      :  Halfs.Inode--- --- Maintainer  :  Isaac Jones <ijones@galois.com>--- 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 <EOS>+            else 8 + fromIntegral cPadSize+                 -- cmagic4, padding, <EOS>+      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 ()
+ Halfs/Monad.hs view
@@ -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)
+ Halfs/MonadUtils.hs view
@@ -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
+ Halfs/Protection.hs view
@@ -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
+ Halfs/SuperBlock.hs view
@@ -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
− Halfs/SyncStructures.hs 
@@ -1,200 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Halfs.SyncStructures--- --- Maintainer  :  Isaac Jones <ijones@galois.com>--- 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
− Halfs/TestFramework.hs 
@@ -1,130 +0,0 @@-{-# LANGUAGE Rank2Types, GADTs #-}--------------------------------------------------------------------------------- |--- Module      :  TestFramework--- Copyright   :  Copyright 2004 by  by Aetion Technologies LLC------ Maintainer  :  Isaac Jones <isaac.jones@aetion.com>--- 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 ()
− Halfs/TheBlockMap.hs 
@@ -1,201 +0,0 @@-{-# LANGUAGE PatternSignatures #-}--------------------------------------------------------------------------------- |--- Module      :  TheBlockMap------ Maintainer  :  Isaac Jones <ijones@galois.com>--- 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-            ]
− Halfs/TheInodeMap.hs 
@@ -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}
+ Halfs/Types.hs view
@@ -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)
Halfs/Utils.hs view
@@ -1,155 +1,52 @@-{-# LANGUAGE FlexibleContexts #-}--------------------------------------------------------------------------------- |--- Module      :  Halfs.Utils------ Maintainer  :  Isaac Jones <ijones@galois.com>--- 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
− HighLevelTests.hs 
@@ -1,348 +0,0 @@-{-# LANGUAGE PatternSignatures #-}--------------------------------------------------------------------------------- |--- Module      :  HighLevelTests------ Maintainer  :  Isaac Jones <ijones@galois.com>--- 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-    )-  ]
− LGPL 
@@ -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.---    <one line to give the library's name and a brief idea of what it does.>-    Copyright (C) <year>  <name of author>--    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.--  <signature of Ty Coon>, 1 April 1990-  Ty Coon, President of Vice--That's all there is to it!--
+ LICENSE view
@@ -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.
− ModuleTest.hs 
@@ -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
− NewFS.hs 
@@ -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 ()
Setup.hs view
@@ -1,5 +1,7 @@-#!/usr/bin/runhaskell+module Main (main) where  import Distribution.Simple -main = defaultMainWithHooks defaultUserHooks+main :: IO ()+main = defaultMain+
+ System/Device/BlockDevice.hs view
@@ -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
+ System/Device/File.hs view
@@ -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
+ System/Device/Memory.hs view
@@ -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
+ System/Device/ST.hs view
@@ -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
− System/RawDevice.hs 
@@ -1,41 +0,0 @@-{-# OPTIONS -cpp #-}--------------------------------------------------------------------------------- |--- Module      :  System.RawDevice--- --- Maintainer  :  Isaac Jones <ijones@galois.com>--- 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)
− System/RawDevice/Base.hs 
@@ -1,60 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module      :  System.RawDevice.Base--- --- Maintainer  :  Isaac Jones <ijones@galois.com>--- 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
− System/RawDevice/File.hs 
@@ -1,146 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  System.RawDevice.File------ Maintainer  :  Isaac Jones <ijones@galois.com>--- 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 = "<file descriptor: " ++ show fd' ++ ">"---   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
− binutils.c 
@@ -1,32 +0,0 @@-#include <string.h>-#include <stdio.h>-#include <unistd.h>-#include <HsFFI.h>-#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);-}-
− binutils.h 
@@ -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);
+ fuse/src/Halfs.hs view
@@ -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...] <FUSE CMDLINE>"++  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
halfs.cabal view
@@ -1,165 +1,119 @@-Name: halfs-Version: 0.2-copyright: Copyright (c) 2005 Galois Connections, Inc.-author:    Isaac Jones, Galois Inc.-maintainer: Iaaac Jones <ijones@syntaxpolice.org>-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 <intractable@gmail.com>,+               Adam Wick <awick@galois.com>,+               Isaac Jones <ijones@galois.com>+maintainer:    Joel Stanley <intractable@gmail.com>+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+
+ test/src/Driver.hs view
@@ -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
+ test/src/Tests/Instances.hs view
@@ -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')
+ test/src/Tests/Types.hs view
@@ -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+
+ test/src/Tests/Utils.hs view
@@ -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)