packages feed

halfs (empty) → 0.2

raw patch · 42 files changed

+8102/−0 lines, 42 filesdep +HUnitdep +QuickCheckdep +arraysetup-changed

Dependencies added: HUnit, QuickCheck, array, base, containers, directory, mtl, network, process, random, unix

Files

+ BinArray.hs view
@@ -0,0 +1,121 @@+{-# 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 view
@@ -0,0 +1,843 @@+{-# 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 view
@@ -0,0 +1,60 @@+{-# 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 view
@@ -0,0 +1,67 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,86 @@+-----------------------------------------------------------------------------+-- 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 view
@@ -0,0 +1,34 @@+{-# 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 view
@@ -0,0 +1,14 @@+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 view
@@ -0,0 +1,1101 @@+{-# 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 view
@@ -0,0 +1,633 @@+{-# 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 view
@@ -0,0 +1,12 @@+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 view
@@ -0,0 +1,48 @@+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/Blocks.hs view
@@ -0,0 +1,364 @@+{-# 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 view
@@ -0,0 +1,9 @@+module Halfs.Blocks where++import Halfs.Utils+import Halfs.Inode+import Halfs.FSState++getDiskAddrOfBlockRead :: Inode+                       -> BlockNumber+                       -> FSRead DiskAddress
+ Halfs/Buffer.hs view
@@ -0,0 +1,143 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,357 @@+{-# 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 view
@@ -0,0 +1,318 @@+{-# 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 view
@@ -0,0 +1,43 @@+-----------------------------------------------------------------------------+-- |+-- 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/CompatFilePath.hs view
@@ -0,0 +1,374 @@+{-# 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/Directory.hs view
@@ -0,0 +1,113 @@+module Halfs.Directory (Directory(..), getChildrenInodeNums, addChild,+                        removeChild, getChildWithName, getChildrenNames,+                        filePathsNoDots, hasChild, DirectoryMap,+                        dirInodeNum,++                        -- 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 Halfs.Inode(Inode(..), InodeMetadata(..), inodeAddLink)+import {-# SOURCE #-} Halfs.FileHandle (FileHandle, fhInodeNum)+import Data.Integral (INInt)++--base+import Data.Map(Map)+import qualified Data.Map as Map+import Control.Exception(assert)++-- |Maps strings to inode numbers+type DirectoryMap = Map String INInt++data Directory = Directory {dirFile     :: FileHandle+                           ,dirContents :: DirectoryMap+                           ,dirDirty    :: Bool+                           }++dirInodeNum :: Directory -> INInt+dirInodeNum d = fhInodeNum $ dirFile d++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++-- |Does this directory have the given file in it?+hasChild :: Directory -> String -> Bool+hasChild Directory{dirContents=theMap} s+  = Map.member s theMap++removeChild :: Directory -> String -> Directory+removeChild (Directory f c _) k+    = Directory f (Map.delete k c) True++-- |Get the inode numbers from the contents of this directory+getChildrenInodeNums :: Directory -> [INInt]+getChildrenInodeNums = Map.elems . dirContents++getChildrenNames :: Directory -> [String]+getChildrenNames = Map.keys . dirContents++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++filePathsNoDots :: [FilePath] -> [FilePath]+filePathsNoDots = filter (\x -> (x /= ".") && (x /= ".."))+++-- ------------------------------------------------------------+-- * directory cache+-- ------------------------------------------------------------++-- |Maps from inode numbers to directories.+data DirectoryCache = DirectoryCache { dirCacheDirty :: Bool+                                     , _dirCache :: Map INInt Directory}++emptyDirectoryCache :: DirectoryCache+emptyDirectoryCache = DirectoryCache False Map.empty++directoryCacheToList :: DirectoryCache -> [Directory]+directoryCacheToList (DirectoryCache _ c) = Map.elems c++-- |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)++markDirectoryCacheClean :: DirectoryCache -> DirectoryCache+markDirectoryCacheClean (DirectoryCache _ c)+    = DirectoryCache False c++getDirectoryFromCache :: DirectoryCache -> INInt -> Maybe Directory+getDirectoryFromCache (DirectoryCache _ c) i+    = Map.lookup i c++-- |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)
+ Halfs/Directory.hs-boot view
@@ -0,0 +1,22 @@+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/FSRW.hs view
@@ -0,0 +1,9 @@+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 view
@@ -0,0 +1,201 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,347 @@+{-# 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/FileHandle.hs view
@@ -0,0 +1,450 @@+{-# 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 view
@@ -0,0 +1,11 @@+module Halfs.FileHandle where++import Data.Integral++data FileMode = ReadMode | WriteMode | AppendMode++data FileHandle+    = FileHandle {fhInodeNum :: INInt+                 ,fhSeekPos  :: INLong+                 ,fhMode     :: FileMode+                 }
+ Halfs/Inode.hs view
@@ -0,0 +1,245 @@+-----------------------------------------------------------------------------+-- |+-- 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'++
+ Halfs/SyncStructures.hs view
@@ -0,0 +1,200 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,130 @@+{-# 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 view
@@ -0,0 +1,201 @@+{-# 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 view
@@ -0,0 +1,22 @@+-- |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/Utils.hs view
@@ -0,0 +1,155 @@+{-# 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++otherInodeMagicNum :: INInt+otherInodeMagicNum = 0x4814819++inodePadding :: Int+inodePadding = 8 -- FIX: compute this someplace.++data FileType = File    -- ^1+              | Dir     -- ^2+              | SymLink -- ^3+      deriving (Show, Eq)++modeFile :: Int+modeFile = 1++modeDir :: Int+modeDir = 2++modeSymLink :: Int+modeSymLink = 3++mRemoveFile :: FilePath -> IO ()+mRemoveFile p = do+  b <- doesFileExist p+  when b (removeFile p)++secondToMicroSecond :: Integer -> Integer+secondToMicroSecond n = n * 1000000++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++instance Binary FileType where+    put_ h f = put_ h (intToINInt (fromEnum f))+    get h   = do x <- get h+                 return $ toEnum (inIntToInt x)++-- 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++unimplemented :: String -> a+unimplemented s = error $ "Unimplemented: " ++ s++-- Mutate an array derived from the original array by applying a+-- function to each of the elements.++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)++ where updateElem i = do+         e <- readArray ar i+         writeArray ar i (fun e)
+ HighLevelTests.hs view
@@ -0,0 +1,348 @@+{-# 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 view
@@ -0,0 +1,510 @@++                  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!++
+ ModuleTest.hs view
@@ -0,0 +1,40 @@+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 view
@@ -0,0 +1,17 @@+{-# 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
@@ -0,0 +1,5 @@+#!/usr/bin/runhaskell++import Distribution.Simple++main = defaultMainWithHooks defaultUserHooks
+ System/RawDevice.hs view
@@ -0,0 +1,41 @@+{-# 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 view
@@ -0,0 +1,60 @@+{-# 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 view
@@ -0,0 +1,146 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,32 @@+#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 view
@@ -0,0 +1,5 @@+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);
+ halfs.cabal view
@@ -0,0 +1,165 @@+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++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++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++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++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++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