diff --git a/BinArray.hs b/BinArray.hs new file mode 100644 --- /dev/null +++ b/BinArray.hs @@ -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, () #) } + + diff --git a/Binary.hs b/Binary.hs new file mode 100644 --- /dev/null +++ b/Binary.hs @@ -0,0 +1,843 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +{-# OPTIONS -#include #-} +{-# OPTIONS -#include "binutils.h" #-} +-- +-- (c) The University of Glasgow 2002 +-- +-- Binary I/O library, with special tweaks for GHC +-- +-- Based on the nhc98 Binary library, which is copyright +-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. +-- Under the terms of the license for that software, we must tell you +-- where you can obtain the original version of the Binary library, namely +-- http://www.cs.york.ac.uk/fp/nhc98/ + +-- Unit tests by +-- Paul Steckler, NGIT/FNMOC, paul.steckler.ctr@metnet.navy.mil +-- fixme: who did the GHC port? +-- AJG: I believe it was Simon Marlow +-- +-- the Sven Panne port is known to be buggy + +-- The Binary module is *not* thread save. Only one threads should +-- be actively interacting with each Handle at a time. + +module Binary + ( BinHandle, + FixedBinHandle, + FixedSysHandle, + IOBinHandle, + + BinaryHandle, -- abstract class + + Binary(..), + Binary.copyBytes, + Bin(..), + BinArray, + tellBin, + seekBin, + openBinIO, + openBinMem, + openFixedBinMem, + openFixedSysHandle, + sizeBinMem, + sizeFixedBinMem, + sizeFixedSysMem, + zeroFixedBinHandle, + zeroFixedSysHandle, + resetBin, + copyMap, + + invalidateFixedBinMem, + invalidateFixedSysMem, + + ) where + +#include "ghcconfig.h" +#if 0 +#include "haskell_debug.h" +#endif + +import BinArray as BA +import FastMutInt +-- import GHC.IO + +import Data.Array.SysArray + +--import Data.Map(Map) +# if __GLASGOW_HASKELL__>=602 +-- import Data.HashTable as HashTable +# endif +-- import Data.Array.IO +-- import Data.Array.Storable +import Data.Array +-- import Data.Bits +-- import Data.Int +-- import Data.Word +import Data.IORef +import Data.Char ( ord, chr ) +-- import Data.Array.Base ( unsafeRead, unsafeWrite, bounds ) +import Control.Monad ( when ) +import Control.Exception ( assert ) +import System.IO as IO +import System.Posix.IO (fdSeek, fdRead, fdWrite) +import System.Posix.Types (Fd(..)) +-- import System.IO.Unsafe ( unsafeInterleaveIO ) +import System.IO.Error ( mkIOError, eofErrorType ) +--import GHC.Real ( Ratio(..) ) +import GHC.Exts +import GHC.IOBase ( IO(..) ) +-- import GHC.Word ( Word8(..) ) +-- import System.Directory ( removeFile ) +# if __GLASGOW_HASKELL__<602 +-- import GHC.Handle ( hSetBinaryMode ) +# endif + +import Foreign +import Foreign.C + +-- for debug +--import System.CPUTime (getCPUTime) +-- import Numeric (showFFloat) + +--import Testing + +-- FIXME: we should really get SIZEOF_HSINT directly from ghc's config.h +#define SIZEOF_HSINT SIZEOF_VOID_P + +-- This is a hack to prevent the profiling version from +-- being *significantly* slower than the unprofiling version. + +-- + +#ifdef PROFILING +#define IOSCC(label,act) IO $ \ s -> {-# SCC label #-} case act of { IO m -> m s } +#else +#define IOSCC(label,act) act +#endif + +-- type BinArray = StorableArray Int Word8 +-- newtype BinArray = BinArray IOUArray Int Word8 + +--------------------------------------------------------------- +-- BinHandle. etc +--------------------------------------------------------------- + +data IOBinHandle + = IOBinHandle { + + io_off_r :: !FastMutInt, -- the current offset (cached) + hdl :: !Fd -- the file handle (must be seekable) + } + -- cache the file ptr in BinIO; using hTell is too expensive + -- to call repeatedly. If anyone else is modifying this Handle + -- at the same time, we'll be screwed. + +data BinHandle + = BinMem { -- binary data stored in an unboxed array + off_r :: !FastMutInt, -- the current offset + sz_r :: !FastMutInt, -- size of the array (cached) + -- TODO: use the arr_r's size. + arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) + } + +data FixedBinHandle + = FixedBinMem { -- binary data stored in an unboxed array + f_off_r :: !FastMutInt, -- the current offset + f_sz_r :: !FastMutInt, -- size of the array (cached) + -- TODO: use the arr_r's size. + f_arr_r :: !BinArray -- the array (bounds: (0,size-1)) + } + +data FixedSysHandle + = FixedSysMem { -- binary data stored in an unboxed array + fs_off_r :: !FastMutInt, -- the current offset + fs_sz_r :: !FastMutInt, -- size of the array (cached) + -- TODO: use the arr_r's size. + fs_arr_r :: !(SysArray Word8) -- the array (bounds: (0,size-1)) + } + +--------------------------------------------------------------- +-- Bin +--------------------------------------------------------------- + +newtype Bin a = BinPtr Int + deriving (Eq, Ord, Show, Bounded) + +--------------------------------------------------------------- +-- class BinaryHandle +--------------------------------------------------------------- + +class BinaryHandle m where + bhPut :: m -> Word8 -> IO () + bhGet :: m -> IO Word8 + tellBin :: m -> IO (Bin a) + seekBin :: m -> Bin a -> IO () + + getAddrRef :: m -> Int -> IO (Maybe AddrRef) + getAddrRef _ _ = return $ Nothing + +-- |reset the pointer +resetBin :: (BinaryHandle m) => m -> IO () +resetBin bh = seekBin bh (BinPtr 0) + +--------------------------------------------------------------- +-- class Binary +--------------------------------------------------------------- + +class Binary a where + put_ :: (BinaryHandle h) => h -> a -> IO () + put :: (BinaryHandle h) => h -> a -> IO (Bin a) + get :: (BinaryHandle h) => h -> IO a + + -- define one of put_, put. Use of put_ is recommended because it + -- is more likely that tail-calls can kick in, and we rarely need the + -- position return value. + put_ bh a = do put bh a; return () + put bh a = do p <- tellBin bh; put_ bh a; return p + + +--------------------------------------------------------------- +-- BinHandle +--------------------------------------------------------------- + +instance BinaryHandle BinHandle where + bhPut h@(BinMem ix_r sz_r arr_r) w = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + -- double the size of the array if it overflows + if (ix >= sz) + then do expandBin h ix + bhPut h w + else do arr <- readIORef arr_r + BA.writeWord8 arr ix w + writeFastMutInt ix_r (ix+1) + return () + + bhGet (BinMem ix_r sz_r arr_r) = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix >= sz) $ + ioError (mkIOError eofErrorType ("Halfs.Binary.getWord8 array: " ++ (show sz) ++" ") + Nothing Nothing) + arr <- readIORef arr_r + w <- BA.readWord8 arr ix + writeFastMutInt ix_r (ix+1) + return w + + tellBin (BinMem r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) + seekBin h@(BinMem ix_r sz_r a) (BinPtr p) = do + sz <- readFastMutInt sz_r + if (p >= sz) + -- FIX: Below assertion is because we don't want any resizing in this app. + -- FIX: dont use this for fixed sized buffers. + then if (p > sz) then do expandBin h p; writeFastMutInt ix_r p + else -- at end of array, but that is legal, provided we do not read or write. + writeFastMutInt ix_r p + else writeFastMutInt ix_r p + + getAddrRef h@(BinMem off_r sz_r arr_r_ref) count = do + -- move the pointer forward *first* + -- (this does bound checking or increases the size of the array), + ix <- readFastMutInt off_r + seekBin h (BinPtr (ix + count)) + arr_r <- readIORef arr_r_ref + -- then move it back. + seekBin h (BinPtr ix) + return $ Just $ ByteArrAddrRef (getBinArrayRawBuffer arr_r) + ix + (seekBin h (BinPtr (ix + count))) + + + +-- openBinHandle :: BinArray -> IO BinHandle +-- openBinHandle arr = do +-- arr_r <- newIORef arr +-- ix_r <- newFastMutInt +-- writeFastMutInt ix_r 0 +-- sz_r <- newFastMutInt +-- writeFastMutInt sz_r (sizeBinArray arr) +-- return (BinMem ix_r sz_r arr_r) + +openBinMem :: Int -> IO BinHandle +openBinMem size + | size <= 0 = error "Halfs.Binary.openBinMem: size must be > 0" + | otherwise = do + arr <- BA.newBinArray size + arr_r <- newIORef arr + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r size + return (BinMem ix_r sz_r arr_r) + + +sizeBinMem :: BinHandle -> IO Int +sizeBinMem (BinMem _ sz_r _) = readFastMutInt sz_r + +-- getBinArray :: BinHandle -> IO BinArray +-- getBinArray (BinMem _ _ arr_r) = readIORef arr_r + +-- expand the size of the array to include a specified offset +expandBin :: BinHandle -> Int -> IO () +expandBin (BinMem ix_r sz_r arr_r) off = do + sz <- readFastMutInt sz_r + let sz' = head (dropWhile (<= off) (iterate (* 2) sz)) + arr <- readIORef arr_r + arr' <- newBinArray sz' + BA.copy arr arr' + writeFastMutInt sz_r sz' + writeIORef arr_r arr' +#ifdef DEBUG + hPutStrLn stderr ("Binary: expanding to size: " ++ show sz') +#endif + return () +--expandBin (BinIO _ _) _ = return () + -- no need to expand a file, we'll assume they expand by themselves. + + +--------------------------------------------------------------- +-- FixedBinHandle +--------------------------------------------------------------- + +instance BinaryHandle FixedBinHandle where + bhPut h@(FixedBinMem ix_r sz_r arr) w = do + checkFixedBinMem h + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix >= sz) $ + ioError (mkIOError eofErrorType ("Binary.bhPut FixedBinHandle: writing passed end of FixedBinHandle at " ++ (show sz) ++" ") + Nothing Nothing) + BA.writeWord8 arr ix w + writeFastMutInt ix_r (ix+1) + checkFixedBinMem h + return () + + bhGet h@(FixedBinMem ix_r sz_r arr) = do + checkFixedBinMem h + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix >= sz) $ + ioError (mkIOError eofErrorType ("Binary.bhGet FixedBinHandle: reading passed end of FixedBinHandle at " ++ (show sz) ++" ") + Nothing Nothing) + w <- BA.readWord8 arr ix + writeFastMutInt ix_r (ix+1) + checkFixedBinMem h + return w + + tellBin h@(FixedBinMem r _ _) = do checkFixedBinMem h ; ix <- readFastMutInt r; return (BinPtr ix) + seekBin h@(FixedBinMem ix_r sz_r a) (BinPtr p) = do + checkFixedBinMem h + sz <- readFastMutInt sz_r + when (p > sz) $ + ioError (mkIOError eofErrorType ("Binary.seekBin FixedBinHandle: seeking passed end of FixedBinHandle at " ++ (show sz) ++" ") + Nothing Nothing) + when (p < 0) $ + ioError (mkIOError eofErrorType ("Binary.seekBin FixedBinHandle: seeking passed start of FixedBinHandle at " ++ (show sz) ++" ") + Nothing Nothing) + writeFastMutInt ix_r p + checkFixedBinMem h + + getAddrRef h@(FixedBinMem off_r sz_r arr) count = do + checkFixedBinMem h + -- move the pointer forward *first* to check bounds + ix <- readFastMutInt off_r + seekBin h (BinPtr (ix + count)) + -- then move it back. + seekBin h (BinPtr ix) + checkFixedBinMem h + return $ Just $ ByteArrAddrRef (getBinArrayRawBuffer arr) + ix + (seekBin h (BinPtr (ix + count))) + +{- +openFixedBinHandle :: BinArray -> IO FixedBinHandle +openFixedBinHandle arr = do + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r (sizeBinArray arr) + return $ FixedBinMem ix_r sz_r arr +-} + +checkFixedBinMem :: FixedBinHandle -> IO () +checkFixedBinMem (FixedBinMem ix_r _ _) = do + ix <- readFastMutInt ix_r + assert (ix /= -1) $ return () + +-- |make a handle 'dead'. uses to test reclaiming strategies. + +invalidateFixedBinMem :: FixedBinHandle -> IO () +invalidateFixedBinMem (FixedBinMem ix_r _ _) = do + writeFastMutInt ix_r (-1) + return () + +openFixedBinMem :: Int -> IO FixedBinHandle +openFixedBinMem size + | size <= 0 = error "Halfs.Binary.openBinMem: size must be > 0" + | otherwise = do + arr <- BA.newBinArray size + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r size + let h = FixedBinMem ix_r sz_r arr + checkFixedBinMem h + return $ h + +sizeFixedBinMem :: FixedBinHandle -> IO Int +sizeFixedBinMem h@(FixedBinMem _ sz_r _) = do + checkFixedBinMem h + readFastMutInt sz_r + +zeroFixedBinHandle :: FixedBinHandle -> IO () +zeroFixedBinHandle h@(FixedBinMem ix_r _ arr) = do + checkFixedBinMem h + BA.zeroBinArray arr + writeFastMutInt ix_r 0 + checkFixedBinMem h + return () + +--------------------------------------------------------------- +-- FixedSysHandle +--------------------------------------------------------------- + +instance BinaryHandle FixedSysHandle where + bhPut h@(FixedSysMem ix_r sz_r arr) w = do + checkFixedSysMem h + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix >= sz) $ + ioError (mkIOError eofErrorType ("Binary.bhPut FixedSysHandle: writing passed end of FixedSysHandle at " ++ (show sz) ++" ") + Nothing Nothing) + pokeSysArrayElem arr (fromIntegral ix) w + writeFastMutInt ix_r (ix+1) + checkFixedSysMem h + return () + + bhGet h@(FixedSysMem ix_r sz_r arr) = do + checkFixedSysMem h + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix >= sz) $ + ioError (mkIOError eofErrorType ("Binary.bhGet FixedSysHandle: reading passed end of FixedSysHandle at " ++ (show sz) ++" ") + Nothing Nothing) + w <- peekSysArrayElem arr (fromIntegral ix) + writeFastMutInt ix_r (ix+1) + checkFixedSysMem h + return w + + tellBin h@(FixedSysMem r _ _) = do checkFixedSysMem h ; ix <- readFastMutInt r; return (BinPtr ix) + seekBin h@(FixedSysMem ix_r sz_r a) (BinPtr p) = do + checkFixedSysMem h + sz <- readFastMutInt sz_r + when (p > sz) $ + ioError (mkIOError eofErrorType ("Binary.seekBin FixedSysHandle: seeking passed end of FixedSysHandle at " ++ (show sz) ++" ") + Nothing Nothing) + when (p < 0) $ + ioError (mkIOError eofErrorType ("Binary.seekBin FixedSysHandle: seeking passed start of FixedSysHandle at " ++ (show sz) ++" ") + Nothing Nothing) + writeFastMutInt ix_r p + checkFixedSysMem h + + getAddrRef h@(FixedSysMem off_r sz_r arr) count = do + checkFixedSysMem h + -- move the pointer forward *first* to check bounds + ix <- readFastMutInt off_r + seekBin h (BinPtr (ix + count)) + -- then move it back. + seekBin h (BinPtr ix) + checkFixedSysMem h + return $ Just $ SysArrAddrRef (ptrFromSysArray arr) + ix + (seekBin h (BinPtr (ix + count))) + + +openFixedSysHandle :: SysArray Word8 -> IO FixedSysHandle +openFixedSysHandle arr = do + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r (fromIntegral (sysArraySize arr)) + return $ FixedSysMem ix_r sz_r arr + +checkFixedSysMem :: FixedSysHandle -> IO () +checkFixedSysMem (FixedSysMem ix_r _ _) = do + ix <- readFastMutInt ix_r + assert (ix /= -1) $ return () + +-- |make a handle 'dead'. uses to test reclaiming strategies. + +invalidateFixedSysMem :: FixedSysHandle -> IO () +invalidateFixedSysMem (FixedSysMem ix_r _ _) = do + writeFastMutInt ix_r (-1) + return () + +sizeFixedSysMem :: FixedSysHandle -> IO Int +sizeFixedSysMem h@(FixedSysMem _ sz_r _) = do + checkFixedSysMem h + readFastMutInt sz_r + +foreign import ccall unsafe "binzero" binzero + :: Ptr Word8 -> CSize -> IO () + +zeroFixedSysHandle :: FixedSysHandle -> IO () +zeroFixedSysHandle h@(FixedSysMem ix_r sz_r arr) = do + checkFixedSysMem h + sz <- readFastMutInt sz_r + binzero (ptrFromSysArray arr) (fromIntegral sz) + writeFastMutInt ix_r 0 + checkFixedSysMem h + return () + +--------------------------------------------------------------- +-- IOBinHandle +--------------------------------------------------------------- + +instance BinaryHandle IOBinHandle where + bhPut (IOBinHandle ix_r h) w = do + ix <- readFastMutInt ix_r + fdWrite h [(chr (fromIntegral w))] -- XXX not really correct + writeFastMutInt ix_r (ix+1) + return () + bhGet (IOBinHandle ix_r h) = do + ix <- readFastMutInt ix_r + ([c], count) <- fdRead h 1 + writeFastMutInt ix_r (ix+1) + return $! (fromIntegral (ord c)) -- XXX not really correct + tellBin (IOBinHandle r _) = do + ix <- readFastMutInt r + return (BinPtr ix) + seekBin (IOBinHandle ix_r h) (BinPtr p) = do + writeFastMutInt ix_r p +-- print ("fdSeek: " , p) + fdSeek h AbsoluteSeek (fromIntegral p) + return () + + getAddrRef (IOBinHandle ix_r fd) count = do + return $ Just $ FdAddrRef + { ch_fd = fd + , ch_done = do ix <- readFastMutInt ix_r + writeFastMutInt ix_r (ix + count) + } + + +openBinIO :: Fd -> IO IOBinHandle +openBinIO h = do + r <- newFastMutInt + writeFastMutInt r 0 + return $ IOBinHandle r h + +-- ----------------------------------------------------------------------------- +-- Primitve Word writes + +instance Binary Word8 where + put_ bh a = bhPut bh a + get = bhGet + +instance Binary Word16 where + put_ h w = do + bhPut h (fromIntegral (w .&. 0xff)) + bhPut h (fromIntegral (w `shiftR` 8)) + get h = do + w2 <- bhGet h + w1 <- bhGet h + return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2) + + +instance Binary Word32 where + put_ h w = do + bhPut h (fromIntegral (w .&. 0xff)) + bhPut h (fromIntegral ((w `shiftR` 8) .&. 0xff)) + bhPut h (fromIntegral ((w `shiftR` 16) .&. 0xff)) + bhPut h (fromIntegral (w `shiftR` 24)) + get h = do + w4 <- bhGet h + w3 <- bhGet h + w2 <- bhGet h + w1 <- bhGet h + return $! ((fromIntegral w1 `shiftL` 24) .|. + (fromIntegral w2 `shiftL` 16) .|. + (fromIntegral w3 `shiftL` 8) .|. + (fromIntegral w4)) + + +instance Binary Word64 where + put_ h w = do + bhPut h (fromIntegral (w .&. 0xff)) + bhPut h (fromIntegral ((w `shiftR` 8) .&. 0xff)) + bhPut h (fromIntegral ((w `shiftR` 16) .&. 0xff)) + bhPut h (fromIntegral ((w `shiftR` 24) .&. 0xff)) + bhPut h (fromIntegral ((w `shiftR` 32) .&. 0xff)) + bhPut h (fromIntegral ((w `shiftR` 40) .&. 0xff)) + bhPut h (fromIntegral ((w `shiftR` 48) .&. 0xff)) + bhPut h (fromIntegral (w `shiftR` 56)) + get h = do + w8 <- bhGet h + w7 <- bhGet h + w6 <- bhGet h + w5 <- bhGet h + w4 <- bhGet h + w3 <- bhGet h + w2 <- bhGet h + w1 <- bhGet h + return $! ((fromIntegral w1 `shiftL` 56) .|. + (fromIntegral w2 `shiftL` 48) .|. + (fromIntegral w3 `shiftL` 40) .|. + (fromIntegral w4 `shiftL` 32) .|. + (fromIntegral w5 `shiftL` 24) .|. + (fromIntegral w6 `shiftL` 16) .|. + (fromIntegral w7 `shiftL` 8) .|. + (fromIntegral w8)) + +-- ----------------------------------------------------------------------------- +-- Primitve Int writes + +instance Binary Int8 where + put_ h w = put_ h (fromIntegral w :: Word8) + get h = do w <- get h; return $! (fromIntegral (w::Word8)) + +instance Binary Int16 where + put_ h w = put_ h (fromIntegral w :: Word16) + get h = do w <- get h; return $! (fromIntegral (w::Word16)) + +instance Binary Int32 where + put_ h w = put_ h (fromIntegral w :: Word32) + get h = do w <- get h; return $! (fromIntegral (w::Word32)) + +instance Binary Int64 where + put_ h w = put_ h (fromIntegral w :: Word64) + get h = do w <- get h; return $! (fromIntegral (w::Word64)) + +-- ----------------------------------------------------------------------------- +-- Instances for standard types + +instance Binary () where + put_ bh () = return () + get _ = return () +-- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b) + +instance Binary Bool where + put_ bh b = bhPut bh (fromIntegral (fromEnum b)) + get bh = do x <- bhGet bh; return $! (toEnum (fromIntegral x)) +-- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b) + +instance Binary Char where + put_ bh c = put_ bh (fromIntegral (ord c) :: Word8) + get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word8))) +-- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b) + +instance Binary Int where +#if SIZEOF_HSINT == 4 + put_ bh i = put_ bh (fromIntegral i :: Int32) + get bh = do + x <- get bh + return $! (fromIntegral (x :: Int32)) +#elif SIZEOF_HSINT == 8 + put_ bh i = put_ bh (fromIntegral i :: Int64) + get bh = do + x <- get bh + return $! (fromIntegral (x :: Int64)) +#else +#error "unsupported sizeof(HsInt)" +#endif +-- getF bh = getBitsF bh 32 + +instance Binary a => Binary [a] where + put_ bh list = do put_ bh (length list) + mapM_ (put_ bh) list + get bh = do len <- get bh + let getMany :: Int -> IO [a] + getMany 0 = return [] + getMany n = do x <- get bh + xs <- getMany (n-1) + return (x:xs) + getMany len + +instance (Binary a, Binary b) => Binary (a,b) where + put_ bh (a,b) = do put_ bh a; put_ bh b + get bh = do a <- get bh + b <- get bh + return (a,b) + +instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where + put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c + get bh = do a <- get bh + b <- get bh + c <- get bh + return (a,b,c) + +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where + put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (a,b,c,d) + +instance Binary a => Binary (Maybe a) where + put_ bh Nothing = bhPut bh 0 + put_ bh (Just a) = do bhPut bh 1; put_ bh a + get bh = do h <- bhGet bh + case h of + 0 -> return Nothing + _ -> do x <- get bh; return (Just x) + +instance (Binary a, Binary b) => Binary (Either a b) where + put_ bh (Left a) = do bhPut bh 0; put_ bh a + put_ bh (Right b) = do bhPut bh 1; put_ bh b + get bh = do h <- bhGet bh + case h of + 0 -> do a <- get bh ; return (Left a) + _ -> do b <- get bh ; return (Right b) + +instance (Binary a, Binary i, Ix i) => Binary (Array i a) where + put_ bh arr = do put_ bh (Data.Array.bounds arr) + put_ bh (Data.Array.elems arr) + get bh = do bounds <- get bh + elems <- get bh + return $ listArray bounds elems + +instance Binary (Bin a) where + put_ bh (BinPtr i) = put_ bh i + get bh = do i <- get bh; return (BinPtr i) + + +--------------------------------------------------------------- +-- Binary Copying +--------------------------------------------------------------- + +-- |Move from one BinHandle to another, with size. Moves both of +-- their pointers. + +copyBytes :: (BinaryHandle h1,BinaryHandle h2) + => h1 -- ^ src handle + -> h2 -- ^ dest handle + -> Int + -> IO () +copyBytes from_h to_h sz@(I# _) = {-# SCC "copyBytes" #-} do + src <- getAddrRef from_h sz + dst <- getAddrRef to_h sz + case (src,dst) of + (Just (ByteArrAddrRef s_buf s_off s_done), Just (ByteArrAddrRef d_buf d_off d_done)) -> {-# SCC "copyBytesBB" #-} + do binmemmove_BA_BA d_buf (fromIntegral d_off) s_buf (fromIntegral s_off) (fromIntegral sz) + s_done + d_done + return () + (Just (SysArrAddrRef s_buf s_off s_done), Just (SysArrAddrRef d_buf d_off d_done)) -> {-# SCC "copyBytesSS" #-} + do binmemmove_PTR_PTR d_buf (fromIntegral d_off) s_buf (fromIntegral s_off) (fromIntegral sz) + s_done + d_done + return () + (Just (SysArrAddrRef s_buf s_off s_done), Just (ByteArrAddrRef d_buf d_off d_done)) -> {-# SCC "copyBytesSB" #-} + do binmemmove_BA_PTR d_buf (fromIntegral d_off) s_buf (fromIntegral s_off) (fromIntegral sz) + s_done + d_done + return () + (Just (ByteArrAddrRef s_buf s_off s_done), Just (SysArrAddrRef d_buf d_off d_done)) -> {-# SCC "copyBytesBS" #-} + do binmemmove_PTR_BA d_buf (fromIntegral d_off) s_buf (fromIntegral s_off) (fromIntegral sz) + s_done + d_done + return () + + (Just (ByteArrAddrRef s_buf s_off s_done), Just (FdAddrRef (Fd d_fd) d_done)) -> {-# SCC "copyBytesBF" #-} + do r <- binwrite_BA d_fd s_buf (fromIntegral s_off) (fromIntegral sz) + s_done + d_done + return () + (Just (FdAddrRef (Fd s_fd) s_done), Just (ByteArrAddrRef d_buf d_off d_done)) -> {-# SCC "copyBytesFB" #-} + do seekBin to_h (BinPtr (d_off + sz)) + r <- binread_BA d_buf (fromIntegral d_off) s_fd (fromIntegral sz) + s_done + d_done + return () + _ -> {-# SCC "copyBytes1" #-} copyBytes1 from_h to_h sz + +foreign import ccall unsafe "binmemmove" binmemmove_BA_BA + :: MutableByteArray# RealWorld -> CInt -> MutableByteArray# RealWorld -> CInt -> CSize -> IO () +foreign import ccall unsafe "binmemmove" binmemmove_BA_PTR + :: MutableByteArray# RealWorld -> CInt -> Ptr Word8 -> CInt -> CSize -> IO () +foreign import ccall unsafe "binmemmove" binmemmove_PTR_PTR + :: Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> CSize -> IO () +foreign import ccall unsafe "binmemmove" binmemmove_PTR_BA + :: Ptr Word8 -> CInt -> MutableByteArray# RealWorld -> CInt -> CSize -> IO () +foreign import ccall unsafe "binwrite" binwrite_BA + :: CInt -> MutableByteArray# RealWorld -> CInt -> CSize -> IO () +foreign import ccall unsafe "binread" binread_BA + :: MutableByteArray# RealWorld -> CInt -> CInt -> CSize -> IO () + +-- generic worker function. +copyBytes1 from_h to_h (I# sz) + | sz ==# 0# = return () + | otherwise = do { v <- bhGet from_h + ; bhPut to_h v + ; copyBytes1 from_h to_h (I# (sz -# 1#)) + } + + +-- |Just like copy bytes, but takes a function parameter to modify +copyMap :: (BinaryHandle bh1,BinaryHandle bh2,Binary a, Binary b) + => bh1 -- ^input handle + -> bh2 -- ^output handle + -> Int -- ^number of elements to copy + -> (a -> b) -- ^f is for fun + -> IO () +copyMap inHandle outHandle (I# sz) f = do + let loop n + | n ==# sz = return () + | otherwise = do + w <- get inHandle + put outHandle (f w) + loop (n +# 1#) + loop 0# +{- +copyBytesFromPtr :: (BinaryHandle h) + => Ptr a -- ^ src ptr + -> h -- ^ dest handle + -> Int -- ^ number of bytes + -> IO () +copyBytesFromPtr ptr h sz@(I# _) = {-# SCC "copyBytesFromPtr" #-} do + + +copyBytesToPtr :: (BinaryHandle h) => + => h -- ^ src ptr + -> Ptr a -- ^ dest handle + -> Int -- ^ number of bytes + -> IO () +copyBytesToPtr h ptr sz@(I# _) = {-# SCC "copyBytesToPtr" #-} do + copy 0 + where + copy i | i == sz = return () -- done + | otherwise = do + v <- peekByteOff ptr i + put h (v :: Word8) + copy (i + 1) +-} + +------------------------------------------------------------------------------ +-- INTERNAL to this module. + +-- get part of a Handle, for copying. + +data AddrRef = ByteArrAddrRef + { ch_byte_arr :: MutableByteArray# RealWorld + , ch_offset :: Int -- offset where the copy (from/to) will start + , ch_done :: IO () + } + | FdAddrRef + { ch_fd :: Fd -- the file descriptor + , ch_done :: IO () + } + | SysArrAddrRef + { ch_sys_arr :: Ptr Word8 + , ch_offset :: Int + , ch_done :: IO () + } + +instance Show AddrRef where + show (ByteArrAddrRef {}) = "ByteArrAddrRef" + show (FdAddrRef fd _) = "FdAddrRef " ++ show fd + show (SysArrAddrRef {}) = "SysArrAddrRef" + + + diff --git a/Data/Array/SysArray.hs b/Data/Array/SysArray.hs new file mode 100644 --- /dev/null +++ b/Data/Array/SysArray.hs @@ -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))) + + + + + + diff --git a/Data/Integral.hs b/Data/Integral.hs new file mode 100644 --- /dev/null +++ b/Data/Integral.hs @@ -0,0 +1,67 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Integral +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : GHC +-- +-- Cues Integralitis. +module Data.Integral + ( fromIntegral' -- :: (Bounded a, Integral a, Bounded b, Integral b) => a -> b + , fromIntegral'' -- :: (Bounded a, Integral a, Bounded b, Integral b) => a -> b + + , INInt + , INLong + + , inIntToInt -- :: INInt -> Int + , intToINLong -- :: Int -> INLong + , inIntToINLong -- :: INInt -> INLong + , intToINInt -- :: Int -> INInt + + ) where + +import Data.Int ( Int32, Int64 ) +import Control.Exception ( assert ) + +type INInt = Int32 +type INLong = Int64 + +-- This section should only allow _correct_ conversions between types. +-- Raw fromIntegral should be avoided because it can cause overflow +-- and underflow. + +inIntToInt :: INInt -> Int +inIntToInt = fromIntegral' + +intToINLong :: Int -> INLong +intToINLong = fromIntegral' + +inIntToINLong :: INInt -> INLong +inIntToINLong = fromIntegral' + +intToINInt :: Int -> INInt +intToINInt = fromIntegral' + + +-- |Almost like fromIntegral, but checks the bounds to make sure its +-- definitely safe. Uses assert, so without assertions, check won't +-- happen. +fromIntegral' :: (Bounded a, Integral a, Bounded b, Integral b) => a -> b +fromIntegral' x = let i = fromIntegral x + in assert ((toInteger (maxBound `asTypeOf` i) + >= toInteger (maxBound `asTypeOf` x)) + && (toInteger (minBound `asTypeOf` i) + <= toInteger (minBound `asTypeOf` x))) + i + +-- |A bit less safe than fromIntegral'; just runtime checks actual +-- value you're trying to convert. +fromIntegral'' :: (Integral a, Bounded b, Integral b) => a -> b +fromIntegral'' x = let i = fromIntegral x + in assert ((toInteger (maxBound `asTypeOf` i) + >= toInteger x) + && (toInteger (minBound `asTypeOf` i) + <= toInteger x)) + i + diff --git a/Data/Queue.hs b/Data/Queue.hs new file mode 100644 --- /dev/null +++ b/Data/Queue.hs @@ -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 diff --git a/FastMutInt.hs b/FastMutInt.hs new file mode 100644 --- /dev/null +++ b/FastMutInt.hs @@ -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, () #) } + diff --git a/Fsck.hs b/Fsck.hs new file mode 100644 --- /dev/null +++ b/Fsck.hs @@ -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" diff --git a/Halfs.hs b/Halfs.hs new file mode 100644 --- /dev/null +++ b/Halfs.hs @@ -0,0 +1,1101 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- | +-- Module : Halfs +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : GHC +-- +-- High-level interface to Halfs, the Haskell Filesystem. + +module Halfs ( + -- * Write-related functions + unlink, rmdir, rename, mkdir, addChildWrite, openWrite + ,openAppend, write, writeString, closeWrite + ,openFileAtPathWrite + + -- * Read-related functions + ,stat, fstat, openRead ,Halfs.read, closeRead + ,seek, openFileAtPathRead + + -- * Meta-data functions + ,fsStats, getDirectoryContents, isDirectory, getDirectoryDetails + + -- * Creating new filesystems + ,newFS, withNewFSWrite + + -- * Mounting filesystems + ,mountFS ,unmountFS, unmountWriteFS, mountFSMV + ,withFSRead, withFSWrite + + -- * Evaluating the 'FSRead' and 'FSWrite' moands + ,evalFSWriteIOMV, evalFSReadIOMV + + -- * fsck + ,fsck, fsckWrite + ,syncPeriodicallyWrite, readReadRef + + -- * Types (most are re-exported from elsewhere) + ,FSWrite, FSRead, TimeT(..), SizeT + ,FileHandle, FileMode(..), Halfs.Buffer.Buffer + ,DeviceLocation, InodeMetadata(..), Inode(..) + + -- * Types to make abstract (FIX) + ,StateHandle(..), RdStat(..), FileSystemStats(..), FSStatus(..) + + -- * testing + ,makeFiles, unitTests + ) where + +import Halfs.BasicIO (getMemoryBlock, + getInodesBin, readInodeBootStrap, + getInodeWrite, getInodeRead, allBlocksInInode) +import Halfs.Blocks(numBlocksForSize) +import Halfs.Buffer(Buffer, buffGetHandle, strToNewBuff, newBuff, buffToStr) +import Halfs.BufferBlockCache(clearBBCache, createCache, checkBBCache) +import qualified Halfs.TheBlockMap as BM (newFS) +import qualified Binary(resetBin) +import Halfs.TheBlockMap (bmTotalSize, freeBlocks) +import Halfs.BuiltInFiles (readInodeMapFile, readBlockMapFile) +import Halfs.CompatFilePath (splitFileName) +import Halfs.Directory (Directory(..), addChild, hasChild, + getChildrenNames, emptyDirectoryCache, directoryCacheToList) +import qualified Halfs.FSState (get, put) +import Halfs.FSState(StateHandle(..) + -- writing + ,FSWrite, readToWrite, modify, runFSWrite + ,evalFSWriteIO, runFSWriteIO, unsafeWriteGet +--UNUSED: ,unsafeReadGet + ,get, put + ,updateInodeCacheWrite, evalFSWriteIOMV + ,modifyFSWrite + -- reading + ,FSRead + ,runFSRead + ,newReadRef, readReadRef, modifyReadRef, writeReadRef +-- ,readMVarRW + ,modifyMVarRW_' + ,evalFSReadIOMV + -- misc + ,evalStateT + ,forkFSWrite + -- exceptions + ,throwError + ,alreadyExistsEx + -- unsafe FIX: REMOVE + ,unsafeLiftIOWrite + ,unsafeLiftIORead + ,putStrLnWriteRead + ) + +import Halfs.FSRoot(FSRoot(..), FileSystemStats(..), + fsRootInode, fsStats, FSStatus(..), + fsRootUpdateInodeCache, addToInodeCache, InodeCacheAddStyle(..), + getFromInodeCache, fsRootBmInode, emptyInodeCache, + InodeCache, fsRootUpdateDirectoryCache, + fsRootAllInodeNums) +import Halfs.FileHandle(FileMode(..), fhSeek, allocateInodeWrite + ,getDirectoryAtPath, newDirectory + ,getInodeAtPath, openFileAtPath, getSomethingAtPath + ,fhRead, fhWrite, fhCloseRead + ,fhOpenWrite, fhCloseWrite + ,fhOpenTruncate, doesPathExist) +import Halfs.TheInodeMap (TheInodeMap(..), emptyInodeMap) +import qualified Halfs.FileHandle as FH (FileHandle(..), unlink, fhInode, fileHandle') +import Halfs.Inode (Inode(..), InodeMetadata(..), + newInode, goodInodeMagic, + newFSRootDirInode, newFSRootInode, newFSBlockMapInode, + newFSInodeMapInode, + rootInodeDiskAddr) +import Halfs.SyncStructures (syncFSRoot, syncDirectoryToFile, shortSyncFSRoot) +import Halfs.TestFramework (Test(..), UnitTests, hunitToUnitTest, + assertEqual) +import System.RawDevice( RawDevice, makeRawDevice, devBufferRead + , newDevice, finalizeDevice) +import Data.Integral(INInt, INLong, fromIntegral' ) +import Halfs.Utils(FileType(..), firstFreeInodeNum + ,rootInodeMagicNum, otherInodeMagicNum + ,mRemoveFile, DiskAddress + ,unimplemented, fromJustErr + -- inode numbers + ,blockMapInodeNum, inodeMapInodeNum, rootDirInodeNum, + rootInodeNum + ) +import Halfs.BufferBlock(mkBufferBlock) +-- base +import Control.Exception -- (assert,catch,throwIO) +import Control.Concurrent(newMVar, MVar, threadDelay, readMVar,myThreadId) +import Control.Monad(unless, when) +import Control.Monad.Error (throwError) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.IORef (IORef) +import Data.Set(Set) +import qualified Data.Set as Set +import Data.Queue (queueToList) +import Foreign.Storable (Storable) +import Foreign.C.Types (CLong) +import Data.List(group,sort) +import System.Exit(exitFailure) + +--import System.IO (hPutStrLn,stderr,hFlush) + +type FileHandle = IORef FH.FileHandle + +-- |The location of a device might be a path to the device on a Linux +-- filesystem. +type DeviceLocation = String + +-- |Move this filehandle to given position. +seek :: FileHandle + -> INLong -- ^What byte offset to move the filehandle to. Must be > 0 and < the number of bytes in the file. + -> FSRead () +seek fh pos = modifyReadRef fh (\fh' -> fhSeek fh' pos) + +-- ------------------------------------------------------------ +-- * Writing +-- ------------------------------------------------------------ + +-- |Delete this file. Currently can be used to delete a directory, +-- but that should probably be FIXED. + +unlink :: FilePath -> FSWrite () +unlink path = do + let (pathTo, theName) = splitFileName path + dir@Directory{dirFile=FH.FileHandle{FH.fhInodeNum=_fi, FH.fhSeekPos=_fs}} + <- readToWrite $ getDirectoryAtPath pathTo + FH.unlink dir theName + --ignore the returned directory; FH.unlink updates it in cache + return () +-- updateDirectory newDir{dirFile=FH.FileHandle fi fs WriteMode} + +-- Remove this empty directory +-- case mode $ metaData inode of +-- File -> return () -- no problem +-- Dir -> do d <- readToWrite $ readDirectory inode +-- when (length (filePathsNoDots(getChildrenNames d)) +-- > 0) +-- (throwError (userError ("directory not empty"))) +-- SymLink -> unimplemented "Symlinks" + + +-- |Unlink this directory. Should only be called on empty +-- directories. Does /not/ descent into sub-directories. Should fail +-- if given a file or if the directory is non-empty (but currently +-- doesn't: FIX). +rmdir :: FilePath -> FSWrite () +rmdir = unlink -- FIX: fail if it's a file, fail if it's non-empty + +-- |Rename this file. Rename the file named as /From/ to the file +-- named as /To/. Can throw an exception if /From/ doesn't exist. +rename :: FilePath -- ^From + -> FilePath -- ^To + -> FSWrite () +rename fromPath toPath = do + let (toParentPath, toName) = splitFileName toPath + -- Q: what's the purpose of this next action? Its side-effect? + _fromInode <- readToWrite $ getInodeAtPath fromPath + toDirTemp <- readToWrite $ getDirectoryAtPath toParentPath + toDir <- if toDirTemp `hasChild` toName + then FH.unlink toDirTemp toName + else return toDirTemp + fromInode <- readToWrite $ getInodeAtPath fromPath + addChildWrite toDir fromInode toName + unlink fromPath + +-- |Create an empty directory at this path. Throws an error if +-- something already exists at this path. +mkdir :: FilePath -> FSWrite () +mkdir dirPath = do + theNewInode <- newChildInode dirPath Dir -- throws error if exists. that's good. + let dir@Directory{dirFile=FH.FileHandle{FH.fhInodeNum=fi, FH.fhSeekPos=fs}} + = newDirectory (inode_num $ metaData theNewInode) + updateDirectory dir{dirFile=FH.fileHandle' fi fs WriteMode} + +-- |Like Direcotry.addChild, but in the FSWrite monad, and syncs this +-- directory. +addChildWrite :: Directory -- ^to add to /directory/ + -> Inode -- ^new child's /inode/ + -> String -- ^Name of child to create inside /directory/. + -> FSWrite Inode +addChildWrite d i f = + let mRet = addChild d i f + in case mRet of + Nothing -> throwError (alreadyExistsEx ("addChildWrite:" ++ f)) + Just (d', i') -> do updateDirectory d' + updateInodeCacheWrite i' + return i' + +-- |Creates child inode based on the path +newChildInode :: FilePath -- ^path components, last component is name, previous components are parent directories. all parents must exist, child must not exist. + -> FileType + -> FSWrite Inode +newChildInode dirs filetype = do + let (pathTo, childFileName) = splitFileName dirs + parentDirTemp <- readToWrite $ getDirectoryAtPath pathTo + parentDir <- if parentDirTemp `hasChild` childFileName + then FH.unlink parentDirTemp childFileName + else return parentDirTemp + inodeNum <- allocateInodeWrite + let inode = newInode inodeNum filetype + addChildWrite parentDir inode (assert (goodInodeMagic inode) childFileName) + +{- +-- |Open the given file for writing. FIX: Test +openTrunc :: FilePath + -> FSWrite FileHandle +openTrunc path = + (openFileAtPathWrite WriteMode path File True >>= readToWrite . newReadRef) +-} + +-- |Open the given file for writing. If a file exists at this +-- location, it gets overwritten. FIX: Test +openWrite :: FilePath + -> FSWrite FileHandle +openWrite = openHelper WriteMode + +-- |Open the given file for appending. If a file already exists at +-- this location, it gets opened for writing, and the file pointer is +-- pointing to the end. FIX: Test, what does it do if no such file exists. +openAppend :: FilePath + -> FSWrite FileHandle +openAppend = openHelper AppendMode + +-- |Abstraction over 'openWrite' and 'openAppend'. +openHelper :: FileMode + -> FilePath + -> FSWrite FileHandle +openHelper mode path + = openFileAtPathWrite mode path File False >>= readToWrite . newReadRef + +-- |Much like getDirectoryAtPath, builds a handle out of this +-- filepath. May throw IO Error! FIX: annotate w\/ errors +-- thrown. FIX: throw errors for incorrect mode. + +openFileAtPathWrite :: FileMode + -> FilePath + -> FileType -- for WriteMode only + -> Bool -- truncate? + -> FSWrite FH.FileHandle +openFileAtPathWrite WriteMode path _theMode True = do + inode <- readToWrite $ getSomethingAtPath (\i -> return i) path + fhOpenTruncate $ inode_num $ metaData inode +openFileAtPathWrite WriteMode path theMode False = do + inode <- newChildInode path theMode + fhOpenWrite $ inode_num $ metaData inode +openFileAtPathWrite AppendMode path _ _ = do + Inode{metaData=InodeMetadata{mode=m + ,inode_num=i + ,num_bytes=loc}} + <- readToWrite (getSomethingAtPath (\i -> return i) path) + case m of + File -> do fh <- fhOpenWrite i + return fh{FH.fhMode=AppendMode + ,FH.fhSeekPos=loc} + Dir -> throwError (userError (dirFileError path)) + SymLink -> unimplemented "Symlinks" +openFileAtPathWrite md path _ _ = + throwError (userError ("openFileAtPathWrite: unsupported file mode " ++ show (md,path))) + +openFileAtPathRead :: FilePath + -> FSRead FH.FileHandle +openFileAtPathRead path = + getSomethingAtPath (\Inode{metaData=InodeMetadata{mode=m + ,inode_num=i}} + -> case m of + File -> do + return $ FH.fileHandle' i 0 ReadMode + Dir -> throwError (userError (dirFileError path)) + SymLink -> unimplemented "Symlinks") + path + +dirFileError :: FilePath -> String +dirFileError path = "directory encountered where file expected: " ++ path + +-- |Write from the given buffer into the file. +write :: FileHandle + -> Buffer -- ^Buffer to write from + -> INInt -- ^Offset into above buffer FIX: should we allow current loc + -> INInt -- ^How many to write + -> FSWrite INInt +write fRef b off num = do + f <- readToWrite $ readReadRef fRef + (outF, i) <- fhWrite f (buffGetHandle b) off num + readToWrite $ writeReadRef fRef outF + return i + +-- |Helpfer function for writing a string to a file. +writeString :: FileHandle + -> String + -> FSWrite INInt +writeString h s = do + b <- unsafeLiftIOWrite $ strToNewBuff s + write h b 0 (fromIntegral $ length s) + +-- |Close a file that's open for writing. +closeWrite :: FileHandle -> FSWrite () +closeWrite f = do (readToWrite $ readReadRef f) >>= fhCloseWrite +-- fsckWrite + +-- ------------------------------------------------------------ +-- * Reading +-- ------------------------------------------------------------ + +-- |Get basic information about the file at this path. +stat :: FilePath -> FSRead RdStat +stat f = do + h <- openRead f + s <- fstat h + closeRead h + return s + +-- |Get basic information about this file handle. +fstat :: FileHandle -> FSRead RdStat +fstat f = do + h <- readReadRef f + Inode{metaData=InodeMetadata{mode=m + ,num_bytes=sz}} <- FH.fhInode h + case m of + File -> return $ RdFile (TimeT 0) sz + Dir -> return $ RdDirectory (TimeT 0) + SymLink -> unimplemented "fstat{SymLink}" + +-- |Does this filepath refer to a directory? +isDirectory :: FilePath -> FSRead Bool +isDirectory f = do + h' <- openRead f + h <- readReadRef h' + inode <- FH.fhInode h + let ret = case mode $ metaData inode of + File -> False + Dir -> True + SymLink -> unimplemented "isDirectory{SymLink}" + closeRead h' + return ret + + +-- |Open this file for reading. FIX: test. +openRead :: FilePath + -> FSRead FileHandle +openRead path = openFileAtPath path ReadMode >>= newReadRef + +-- |Read from this file handle into this buffer. +read :: FileHandle + -> Buffer -- ^Buffer to read into + -> INInt -- ^Offset into above buffer + -> INInt -- ^How many to read + -> FSRead INInt +read fref b off sz = do + f <- readReadRef fref + (f', i) <- fhRead f (buffGetHandle b) off sz + writeReadRef fref f' + return i + +-- |Close a filehandle that's open for reading. +closeRead :: FileHandle -> FSRead () +closeRead h = do readReadRef h >>= fhCloseRead +-- fsckRead + +-- |Get the contents of a directory. +getDirectoryContents :: FilePath -> FSRead [FilePath] +getDirectoryContents path + = getDirectoryAtPath path >>= return . getChildrenNames + +-- |Caller may want to filter out "." and ".." +getDirectoryDetails :: FilePath -> FSRead [(String, Inode)] +getDirectoryDetails path = do + namesNums <- getDirectoryAtPath path >>= return . Map.toList . dirContents + mapM (\(n,iNum) -> do i <- getInodeRead iNum Nothing + return (n, i)) namesNums + +-- ------------------------------------------------------------ +-- * Mounting and Control Interface +-- ------------------------------------------------------------ + +-- |Mount the given file system for writing and perform these +-- operations. FIX: Maybe add MVar () for blocking on. +withFSWrite :: DeviceLocation -- ^Location of device + -> FSWrite a -- ^Operations to perform + -> IO a +withFSWrite path f = do + fsroot <- mountFS Nothing path False 500 + blockOn <- newMVar fsroot + evalStateT (runFSWrite f) (StateHandle blockOn Nothing) + +-- |Mount the given file system for reading and perform these +-- operations. +withFSRead :: DeviceLocation -- ^Location of device + -> FSRead a -- ^Operations to perform + -> IO a +withFSRead path f = do + fsroot <- mountFS Nothing path True 500 -- Nothing == No read-down. + rootVar <- newMVar fsroot + evalStateT (runFSRead f) (StateHandle rootVar Nothing) + +-- |Create a new file system and perform the given operations. Unmounting +-- is up to the caller. See 'newFS' for parameter details. +withNewFSWrite :: String + -> INInt + -> FSWrite a -- ^Operations to perform + -> IO a +withNewFSWrite path len f = do + mRemoveFile path + newFS path len + withFSWrite path f + +-- ------------------------------------------------------------ +-- * Mounting and Control Helpers +-- ------------------------------------------------------------ + +-- |Creates a new filesystem with a real-life root inode! Out of thin +-- air, create a buffer block for this device, 0, and write root inode +-- to our new cache. +newFS :: DeviceLocation + -> INInt -- ^desired length of the new filesystem in blocks + -> IO () +newFS path fileLen = do + -- this block map marks 0 and 1 as used: + + dev <- newDevice Nothing path fileLen + +-- realBlocks <- blocksInDevice dev +-- when (realBlocks < (fromIntegral fileLen)) +-- (error $ "requested FS size greater than physical disk. blocks: " ++ (show fileLen) ++ " size: " ++ (show realBlocks)) + + theCache <- createCache 500 + let blockMap' = BM.newFS fileLen + + let d = newDirectory rootDirInodeNum + let fsroot' = FSRoot dev theCache blockMap' emptyInodeCache + (emptyInodeMap firstFreeInodeNum) + emptyDirectoryCache FsReadWrite + + -- add various distinguished inodes to the inode cache + let fsroot = foldl fsRootUpdateInodeCache fsroot' [newFSRootInode + ,newFSBlockMapInode + ,newFSInodeMapInode + ,newFSRootDirInode] + -- Write out the root directory. FIX: Remove when we have diredctory cache? + (_, fsroot1) <- runFSWriteIO (syncDirectoryToFile d) fsroot + + -- sync the FS and close the device + unmountFS fsroot1 + -- You cant return the cache, because we lose it when we unmount + -- return theCache + return () + -- todo: new inode map + -- todo: flush cache + +-- |Periodically sync the filesystem. Usually forked off in its own +-- thread. For READS: Flush caches on read-only filesystem (so +-- they'll be re-populated). For WRITES: write out the filesystem +-- data. FIX: remove readOnly; that's in the fsroot. FIX: add +-- exception handler (since it does a take) +syncPeriodicallyWrite :: MVar () -- ^High-level blocker. This function blocks on this mvar. + -> Bool + -> FSWrite () +syncPeriodicallyWrite blockOn readOnly = do + FSRoot{fsStatus=status} <- unsafeWriteGet -- safe + putStrLnWriteRead $ "Periodically syncing: " ++ (show status) + case status of + FsUnmounted -> putStrLnWriteRead "exiting periodic thread." -- done with this thread. + _ -> do + modifyMVarRW_' blockOn (\_ -> do + putStrLnWriteRead "taken." + case status of + FsReadOnly -> do r <- get + fsroot <- unsafeLiftIOWrite $ fsRootClearCaches r + put (assert (readOnly == True) fsroot) + + FsReadWrite -> do FSRoot{device=_d} <- unsafeWriteGet + assert (readOnly == False) shortSyncFSRoot + FsUnmounted -> assert False (return ()) + ) + putStrLnWriteRead "sync completed." + unsafeLiftIOWrite $ threadDelay $ secondToMicroSecond 60 + syncPeriodicallyWrite blockOn readOnly + +secondToMicroSecond :: Int -> Int +secondToMicroSecond n = n * 1000000 + +fsRootClearCaches :: FSRoot -> IO FSRoot +fsRootClearCaches fsroot = do + clearBBCache (assert ((fsStatus fsroot) == FsReadOnly) (bbCache fsroot)) + newInodeCache <- getDistinguishedInodes (device fsroot) + -- might need to move this up if getDistinguishedInodes needs it. + return (fsroot {inodeCache=newInodeCache + ,directoryCache=emptyDirectoryCache + }) + +getDistinguishedInodes :: RawDevice -> IO InodeCache +getDistinguishedInodes rawDev = do + -- todo get inode numbers of block map, inodemap and root directory + -- from root inode. hard-coded in Utils for now. + + -- re-read the fundamental inodes from disk. + rootInodeBuffer <- getMemoryBlock + rootInodeBufferBlock <- mkBufferBlock rootInodeBuffer rawDev rootInodeDiskAddr + devBufferRead rawDev rootInodeDiskAddr rootInodeBuffer + Binary.resetBin rootInodeBuffer +-- sequence $ map (\_ -> do (w::Word8) <- Binary.get rootInodeBuffer +-- putStr (show w) +-- putStr ",") (replicate 200 ()) + Binary.resetBin rootInodeBuffer + (readRootInode:_) <- getInodesBin rootInodeBufferBlock + -- get inode of blockMap using blockMapInodeNum + (_newBlockMapInode, newInodeCache') + <- readInodeBootStrap (fst $ addToInodeCache InodeCacheOverwrite + (emptyInodeCache, rootInodeNum) + (assert (goodInodeMagic readRootInode) readRootInode)) + rawDev readRootInode blockMapInodeNum + (_inodeMapInode, newInodeCache'') + <- readInodeBootStrap newInodeCache' rawDev readRootInode inodeMapInodeNum + (_newRootDirInode, newInodeCache) + <- readInodeBootStrap newInodeCache'' rawDev readRootInode rootDirInodeNum + return newInodeCache + +-- |See 'mountFS' for most documentation. +mountFSMV :: Maybe StateHandle + -> DeviceLocation + -> Maybe (MVar () ) -- ^the outermost-blocker, if desirable. causes a synchronization thread to be spawned + -> Bool + -> Int -- ^cache size + -> IO StateHandle +{- +mountFSMV mSH path (Just mCache) blockOn readOnly cacheSize = do + fsr <- mountFS mSH path mCache readOnly + mv <- newMVar fsr + let sh = StateHandle mv blockOn + case blockOn of + Nothing -> return () + Just b -> evalFSWriteIOMV (forkFSWrite (syncPeriodicallyWrite b readOnly)>> return ()) sh + return sh +-} +mountFSMV mSH path blockOn readOnly cacheSize = do + -- Q: what's the purpose of this next action? + _c <- createCache cacheSize + mv <- mountFS mSH path readOnly cacheSize >>= newMVar + let sh = StateHandle mv blockOn + case blockOn of + Nothing -> return () + Just b -> evalFSWriteIOMV (forkFSWrite (syncPeriodicallyWrite b readOnly)>>return ()) sh + return sh + +-- |Basic low-level @mount@ operation. Usually used via wrappers such as 'withFSWrite' and 'withFSRead'. See also 'newFS'. +mountFS :: Maybe StateHandle -- ^if Just, use the raw device inside + -> DeviceLocation -- ^Location of device + -> Bool -- ^Read only? + -> Int -- ^buffer block cache size + -> IO FSRoot +mountFS mSH path readOnly cacheSize = do + (mRD,cache) + <- case mSH of + Nothing -> do cache <- createCache cacheSize + return (Nothing,cache) + Just (StateHandle shM _) -> do FSRoot{device=r, bbCache=c} <- readMVar shM + return $ (Just r,c) + rawDev <- makeRawDevice mRD path + -- read root inode + inodeCache1 <- getDistinguishedInodes rawDev + + -- using fromJustErr here because the above call populates the inode + -- cache, and we can't call getInode (which is safer) yet because we + -- don't have a fully-formed fsroot + let newBlockMapInode = fromJustErr "block map inode not in inode cache during mount" + (getFromInodeCache inodeCache1 blockMapInodeNum) + let inodeMapInode = fromJustErr "inode map inode not in inode cache during mount" + (getFromInodeCache inodeCache1 inodeMapInodeNum) + + -- read block map + -- have to fake up an fsroot for bootstrapping here. + let partFsroot = FSRoot rawDev cache + (error "undefined") inodeCache1 + (emptyInodeMap firstFreeInodeNum) + emptyDirectoryCache + (if readOnly then FsReadOnly else FsReadWrite) + -- warning! fsroot not fully formed: + (_, fsroot) <- runFSWriteIO -- makes its own mvar :( + (do bm <- readToWrite $ readBlockMapFile newBlockMapInode + modify (\fsroot -> fsroot{blockMap=bm}) + im <- readToWrite $ readInodeMapFile inodeMapInode + + modify (\fsroot -> fsroot{inodeMap=im}) + ) partFsroot + return fsroot + +-- |Syncs the device and closes its handle. You should stop using it +-- after that. Must represent an open device! +unmountFS :: FSRoot -> IO () +unmountFS fsroot@FSRoot{device=d, fsStatus=status} = do + when (status==FsReadWrite) (evalFSWriteIO syncFSRoot fsroot) + finalizeDevice d +-- evalFSWriteIO get fsroot -- couln't work; should take the mvar or something. + return () + +-- |Just like 'unmountFS' but in the 'FSWrite' monad. +unmountWriteFS :: FSWrite () +unmountWriteFS = do + modifyFSWrite $ \fsr@FSRoot{fsStatus=status} -> do + unsafeLiftIOWrite $ unmountFS (assert (status==FsReadWrite) fsr) + return (fsr{fsStatus=FsUnmounted}, ()) + return () + +-- |Check the filesystem for errors. Exits with an error code and +-- message if any are found. Outputs lots of low-level data to the +-- terminal. + +fsck :: DeviceLocation -> IO () +fsck devPath = do + fsroot <- mountFS Nothing devPath True 500 + fsck' fsroot + +fsck' :: FSRoot -> IO () +fsck' fsroot@FSRoot{inodeMap=theInMap + ,directoryCache=dirCache + ,bbCache=bbC + ,blockMap=theBlockMap} = catchAll $ do + let totalBlocks = bmTotalSize theBlockMap + tid <- myThreadId + putStrLn $ "############################ F S C K ##############################" ++ show tid + putStrLn $ "root inode: " ++ (show $ fsRootInode fsroot) + putStrLn $ "blockMap inode: " ++ (show $ fsRootBmInode fsroot) + bbCacheInfo <- checkBBCache bbC + putStrLn $ "(bbCacheSize, bbCacheNumDirty,hits,misses): " ++ (show bbCacheInfo) + let maxInode = (imMaxNum theInMap) - 1 + let allPossibleBlocks = Set.fromList $ [0 .. (totalBlocks - 1)] + let allInodeNums = fsRootAllInodeNums fsroot + putStrLn $ "Max inode num: " ++ (show maxInode) + putStr $ "There are a total of: " ++ (show $ Set.size allInodeNums) ++ " inodes" + putStrLn $ " and " ++ (show $ length $ freeInodes theInMap) ++ " free inodes." + putStrLn $ "Free Inodes: " ++ (show $ freeInodes theInMap) + +{- unless ((cardinality allInodeNums) + (length $ freeInodes theInMap) == maxInode) + (error "all inode nums doesn't add up (see above)") +-} + + let dirInodeNums = show [FH.fhInodeNum (dirFile d) + | d <- directoryCacheToList dirCache] + putStrLn $ "inode nums in directory cache: " ++ dirInodeNums + (_, _fsroot) <- runFSWriteIO (do + let mapabs = Set.map abs + let freeList= queueToList (freeBlocks $ blockMap fsroot) + let freeSet = mapabs $ Set.fromList $ freeList + + when (Set.size freeSet /= length freeList) ( + error $ "freeList contains duplicates, should never happen: " ++ + show [ head vs + | vs <- group (sort freeList) + , length vs > 1 + ]) + + theMapping <- buildBlockToInodeMapping (Set.toList allInodeNums) allPossibleBlocks Map.empty + putStrLnWriteRead $ "The block map [(blockNum, inodeNum)]: " ++ (show $ Map.toList theMapping) + let usedBlocks = mapabs $ Set.fromList $ Map.keys theMapping + let usedBlocksMarkedFree = freeSet `Set.intersection` usedBlocks + + unless (Set.null usedBlocksMarkedFree) + (do let theBadPairs = getPairsFor (Set.toList usedBlocksMarkedFree) theMapping + badInodes <- mapM (\(_,x) -> getInodeWrite x Nothing) theBadPairs + error $ "used blocks in inodes marked as free. [(blockNum, inodeNum)]: " + ++ (show $ theBadPairs) ++ "\n" ++ (show badInodes) + ) + + let leakedBlocks = allPossibleBlocks `Set.difference` (freeSet `Set.union` usedBlocks) + unless (Set.null leakedBlocks) (error $ "Leaked blocks: " + ++ (show $ Set.toList leakedBlocks)) + ) fsroot + + putStrLn $ "(END)####################### F S C K ###########################(END)" ++ show tid + return () + where getPairsFor :: (Show a,Ord a) => [a] -> Map a b -> [(a,b)] + + -- this fromJustErr should never break; + -- list is taken from the map itself: + getPairsFor theElems mapping + = [(x, fromJustErr + ("attempt to look up element not in mapping: " ++ show x) + (Map.lookup x mapping)) + | x <- theElems] + + catchAll body = Control.Exception.catch body + (\ e -> do putStrLn "fsck' failure" + print e + exitFailure) + + +-- |See 'fsck'. +fsckWrite :: FSWrite () +fsckWrite = unsafeWriteGet >>= unsafeLiftIOWrite . fsck' + +{- UNUSED: +fsckRead :: FSRead () +fsckRead = unsafeReadGet >>= unsafeLiftIORead . fsck' +-} + +-- |Lookup all the inodes, get their block pointers, and verify that +-- no two inodes have the same block pointer, in which case, crashes +-- with an error for now. +buildBlockToInodeMapping :: [INInt] -- ^All inode nums + -> Set DiskAddress -- ^ all possible disk addresses + -> Map DiskAddress INInt -- initial mapping + -> FSWrite (Map DiskAddress INInt) +buildBlockToInodeMapping [] _allAddr inMap = return inMap +buildBlockToInodeMapping (inodeNum:t) allAddr inMap = do + inode <- getInodeWrite inodeNum Nothing + -- FIX: need to check level-two blocks too :( + allBlocks <- allBlocksInInode (assert (goodInodeMagic inode) inodeNum) + let numBlocksInInode = length allBlocks + when (numBlocksForSize inode > fromIntegral' numBlocksInInode) + (error $ "The inode does not have enough blocks to match its size. Number it should have, based on size: " ++ (show (numBlocksForSize inode)) ++ " number it actually has: " ++ (show numBlocksInInode) ++ "\n" ++ show inodeNum ++ "\n" ++ show inode) +-- when (inodeNum == 107) ( +-- unsafeLiftIOWrite $ print ("inside 107 : ",allBlocks,inode) +-- ) + + + let newMap = checkInodeBlocks allBlocks + (inode_num $ metaData inode) allAddr inode inMap + buildBlockToInodeMapping t allAddr newMap + +-- |Called by 'fsck'. Checks consistency of the blocks in the given +-- inode. Checks for inodes with invalid block numbers, two inodes +-- with the same block. +checkInodeBlocks :: [DiskAddress] + -> INInt -- inode number + -> Set DiskAddress + -> Inode + -> Map DiskAddress INInt + -> Map DiskAddress INInt +checkInodeBlocks [] _ _allAddr _ inMap = inMap +checkInodeBlocks (blk:t) inodeNum allAddr inode inMap + | blk == 0 && (not (inodeNum == 0)) -- first block of root inode + = assert False inMap -- should already be filtered. + | not (abs blk `Set.member` allAddr) + = error $ "inode with invalid block number: inode=" ++ + show inodeNum ++ " addr = " ++ show blk ++ "\n" ++ + show inode + | otherwise = + case Map.lookup blk inMap of + Nothing -> keepGoing + -- FIX: probably want to do better sort of error checking + Just a -> if (a /= inodeNum) + then error $ "two inodes with same block: " + ++ (show a) ++ " & " ++ (show inodeNum) + ++ " block number: " ++ (show blk) + else keepGoing + where keepGoing = checkInodeBlocks t inodeNum allAddr inode (Map.insert blk inodeNum inMap) + +-- ------------------------------------------------------------ +-- * Misc +-- ------------------------------------------------------------ + +-- |This seems to be the kind of Stat information needed by the TSE +-- front end. +data RdStat + = RdDirectory{ modTime :: TimeT } + | RdFile{ modTime :: TimeT, size :: SizeT } + deriving (Eq, Show) + +{- UNUSED: +notDone :: a +notDone = error "Undefine" +-} + +newtype TimeT = TimeT CLong deriving (Show, Read, Eq, Storable, Ord) + + +type SizeT = INLong +-- type Buffer = BinHandle + +-- |Updates this directory's entry in the cache +updateDirectory :: Directory -> FSWrite () +updateDirectory dir = + modify (fsRootUpdateDirectoryCache dir) + +-- ------------------------------------------------------------ +-- * Testing +-- ------------------------------------------------------------ + +testFSLoc :: FilePath +testFSLoc = "halfs-client1" + +unitTests :: Bool -> UnitTests +unitTests fast = hunitToUnitTest (hunitTests fast) + +theContents :: [FilePath] +theContents = ["bin", "dev", "etc", "lib", "tmp"] + +dirFS :: FilePath +dirFS = "halfs-client1" + +assertEqualWrite :: (Eq a, Show a) => String -> a -> a -> FSWrite () +assertEqualWrite s a b = unsafeLiftIOWrite $ assertEqual s a b + +-- |for testing. Create some files in the given directory +makeFiles :: Int -- ^Number of files + -> FilePath -- ^Where to put them + -> String -- empty if you don't want to write anything to it + -> FSWrite () +makeFiles n p s | n <= 0 = return () + | otherwise = do + h <- openWrite $ p ++"/" ++ "smallFile" ++ (show n) + when (s /= "") + (writeString h s>>return()) + closeWrite h + makeFiles (n - 1) p s + +makeManyFiles :: Int -- ^Number of files + -> FilePath -- ^where to put them + -> FSWrite () +makeManyFiles numFiles dirLoc = do + putStrLnWriteRead $ "creating " ++ (show numFiles) + ++ " files in " ++ (show dirLoc) + -- num blocks = numFiles * (inodesPerBlock / bytesPerInode) + makeFiles numFiles dirLoc "" + dirs <- readToWrite $ getDirectoryContents dirLoc + assertEqualWrite "correct size after creating a few files" + (numFiles + 1) (length dirs) + assertEqualWrite "dot in dir" "." (head dirs) + fsckWrite + +slowTests :: [Test] +slowTests = + [ + TestLabel "large fs" $ TestCase $ do + newFS dirFS 40000 -- a big filesystem + fsroot <- mountFS Nothing dirFS True 500 + fsck' fsroot + unmountFS fsroot + ,TestLabel "MANY files" $ TestCase $ withFSWrite dirFS $ do + -- depends on previous large filesystem case + makeManyFiles 10000 "/" + unmountWriteFS + ,TestLabel "re-mounting after writing MANY files" $ TestCase $ do + fsroot <- mountFS Nothing dirFS False 500 + unmountFS fsroot + + , TestLabel "some appends" $ TestCase $ do + withNewFSWrite dirFS 10 (unmountWriteFS) + withFSWrite dirFS $ do + h <- openWrite "/log" + closeWrite h + sequence [ do fd <- openAppend "/log" + writeString fd (show i) + closeWrite fd + | i <- [(1::Int)..100] + ] + fsckWrite + unmountWriteFS + ,TestLabel "many appends" $ TestCase $ do + let count = 50 + withNewFSWrite dirFS 20 (unmountWriteFS) + withFSWrite dirFS $ do + fsckWrite + let input = [ init (take (n `mod` 1003) (cycle (show i ++ ","))) ++ "#" + | (i,n) <- zip [(1::Int)..] (take count $ iterate (* 234587) 1) + ] + mkdir "/test" + h <- openWrite "/test/log" + closeWrite h + sequence [ do fd <- openAppend "/test/log" + writeString fd str +-- unsafeLiftIOWrite $ print $ "writing : " ++ show str + closeWrite fd + let str_ref = concat (take i input) + readToWrite $ do + fd2 <- openRead "/test/log" + buff <- unsafeLiftIORead $ newBuff (length str_ref) + n <- Halfs.read fd2 buff 0 (fromIntegral $ length str_ref) + if (fromIntegral n == length str_ref) + then return () + else error $ "read incorrect number of bytes" + closeRead fd2 + str_read <- unsafeLiftIORead $ buffToStr buff +-- unsafeLiftIORead $ print $ "compareing : " ++ show (str_ref,str_read) + if str_ref == str_read + then return () + else error ("append failed to write then read at byte: " ++ + show (head [ j | (j,a,b) <- zip3 [(0::Int)..] str_ref str_read, a /= b ],n,i)) + + | (i,str) <- zip [1..] input ] + fsckWrite + unmountWriteFS + + , TestLabel "large, large file" $ TestCase $ do + newFS dirFS 40000 -- a big filesystem + fsroot <- mountFS Nothing dirFS True 500 + unmountFS fsroot + withFSWrite dirFS $ do + h <- openWrite "/large" + closeWrite h + sequence [ do fd <- openAppend "/large" + writeString fd ((show i) ++ take 1031 (cycle "#")) + closeWrite fd + when ((i `mod` 1000) == 0) $ + fsckWrite + | i <- [(1::Int)..10000] + ] + fsckWrite + unmountWriteFS + + , TestLabel "smaller fs" $ TestCase $ do + withNewFSWrite dirFS 500 (unmountWriteFS) + ] + +hunitTests :: Bool -> [Test] +hunitTests fast = + [TestLabel "isaacfs and read root inode" $ TestCase $ do +-- mRemoveFile testFSLoc + newFS testFSLoc 10 -- creates the file system + -- verify that the root inode has the right magic number: + dev <- makeRawDevice Nothing testFSLoc + buffer <- getMemoryBlock + bb <- mkBufferBlock buffer dev 0 + devBufferRead dev 0 buffer + (rootInode':_) <- getInodesBin bb + assertEqual "root inode magic number incorrect" + rootInodeMagicNum + (magic1 $ metaData rootInode') + finalizeDevice dev + + ,TestLabel "mounting fs" $ TestCase $ do + fsr <- mountFS Nothing testFSLoc False 500 + fsck' fsr + assertEqual "root inode magic number incorrect" + rootInodeMagicNum + (magic1 $ metaData $ fsRootInode fsr) + assertEqual "block map magic number incorrect" + otherInodeMagicNum + (magic1 $ metaData $ fsRootBmInode fsr) + unmountFS fsr + ,TestLabel "mounting and unmount a lot" $ TestCase $ do + mountFS Nothing testFSLoc True 500 >>= unmountFS + mountFS Nothing testFSLoc True 500 >>= unmountFS + mountFS Nothing testFSLoc True 500 >>= unmountFS + fsroot <- mountFS Nothing testFSLoc True 500 + fsck' fsroot + unmountFS fsroot + ,TestLabel "getInode" $ TestCase $ withNewFSWrite + "halfs-client1" 500 (do + theNewInode <- getInodeWrite 16 Nothing + unless ((magic1 $ metaData theNewInode) == otherInodeMagicNum) + (error "bad magic in getInode case") +-- let addr = getPointerAt theNewInode 0 + unmountWriteFS) + ,TestLabel "making directories in memory" $ TestCase $ + withNewFSWrite dirFS 500 (do + let ls = readToWrite . getDirectoryContents + mkdirs = mapM_ mkdir + mkdirs (map ('/':) theContents) + mkdirs ["/lib/modules" + ,"/lib/w00t" + ,"/lib/w00t/foo" + ,"/lib/init" -- will get overwritten + ,"/lib/modules/foo" + ,"/lib/modules/bar" + ,"/lib/modules/bar/bang"] + wootInode <- readToWrite $ getInodeAtPath "/lib/w00t" + assertEqualWrite "hardLinks after mkdir" 1 (hard_links $ metaData wootInode) + syncFSRoot + wootInode1 <- readToWrite $ getInodeAtPath "/lib/w00t" + assertEqualWrite "hardLinks after sync" 1 (hard_links $ metaData wootInode1) + fsckWrite + + rename "/lib/w00t" "/lib/init" + + syncFSRoot + fsckWrite + + ls "/lib/init" >>= assertEqualWrite "move directory worked" [".","foo"] + + ls "/" >>= assertEqualWrite "slash equal contents" (".":theContents) + + ls "/etc" >>= assertEqualWrite "etc dir empty pre-unmount" ["."] + + ls "/lib" >>= assertEqualWrite "lib dir has modules pre-unmount" + [".", "init", "modules"] + + ls "/lib/modules" >>= assertEqualWrite "lib dir has modules pre-unmount" + [".", "bar", "foo"] + + ls "/lib/modules/bar" >>= assertEqualWrite "lib dir has modules pre-unmount" + [".", "bang"] + + syncFSRoot + fsckWrite + syncFSRoot + fsckWrite + unmountWriteFS) + ,TestLabel "remounting and seeing directories" $ TestCase $ do + putStrLn "mounting for 'remount'" + withFSWrite dirFS (do + fsckWrite + let ls = readToWrite . getDirectoryContents + rm = unlink + ls "/" >>= assertEqualWrite "/ has theContents" (".":theContents) + ls "/etc" >>= assertEqualWrite "etc dir empty post-unmount" ["."] + + ls "/lib" >>= assertEqualWrite "lib dir has modules post-unmount" + [".", "init", "modules"] + ls "/lib/modules" >>= assertEqualWrite "lib dir has modules post-unmount" + [".", "bar", "foo"] + ls "/lib/modules/bar" >>= assertEqualWrite "lib dir has modules post-unmount" + [".", "bang"] + p <- readToWrite $ doesPathExist "/lib/modules/bar/bang" + assertEqualWrite "path that does exist" p True + + p1 <- readToWrite $ doesPathExist "/no/way" + assertEqualWrite "path that does not exist" p1 False + + rm "/lib/modules/bar/bang" + ls "/lib/modules/bar" >>= assertEqualWrite "removing a dir non-root" + ["."] +{- unsafeMkFSWrite $ copyFromHostT "tests/smallFile" "/etc/smallFile" + ls "/etc" >>= assertEqualWrite "etc has smallFile" [".", "smallFile"] + rm "/etc/smallFile"-} + ls "/etc" >>= assertEqualWrite "etc delete smallFile" ["."] + rm "/etc" + ls "/" >>= assertEqualWrite "remove a dir in root" (filter (/= "etc") (".":theContents)) + + -- Overflow a block boundry with a write: + fh <- openWrite "/tempFile" + myBuf <- unsafeLiftIOWrite $ strToNewBuff "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!" + readToWrite $ seek fh 4093 + write fh myBuf 0 50 + + fsroot <- unsafeWriteGet + getInodeWrite blockMapInodeNum Nothing >>= + assertEqualWrite "read blockmap inode equals one in root" + (fsRootBmInode fsroot) + unmountWriteFS) + ,TestLabel "mount and unmount after serveral syncs" $ TestCase $ + withFSWrite dirFS unmountWriteFS + ,TestLabel "a few files" $ TestCase $ withNewFSWrite dirFS 50000 $ do + makeManyFiles 50 "/" + unmountWriteFS + ,TestLabel "re-mounting after writing a few files" $ TestCase $ do + fsroot <- mountFS Nothing dirFS False 500 + fsck' fsroot + unmountFS fsroot + ,TestLabel "a few files, in a non-root directory" $ TestCase $ + withFSWrite dirFS $ do + fsckWrite + mkdir "/test" + makeManyFiles 200 "/test" + unmountWriteFS + ,TestLabel "large fs" $ TestCase $ do + newFS dirFS 40000 -- a big filesystem + fsroot <- mountFS Nothing dirFS True 500 + fsck' fsroot + unmountFS fsroot + ,TestLabel "quite a few files" $ TestCase $ withFSWrite dirFS $ do + -- depends on previous large filesystem case + makeManyFiles 1000 "/" + unmountWriteFS + ,TestLabel "re-mounting after writing quite a few files" $ TestCase $ do + fsroot <- mountFS Nothing dirFS False 500 + unmountFS fsroot + ,TestLabel "smaller fs" $ TestCase $ do + withNewFSWrite dirFS 500 (unmountWriteFS) + + ] ++ (if fast then [] else slowTests) diff --git a/Halfs/BasicIO.hs b/Halfs/BasicIO.hs new file mode 100644 --- /dev/null +++ b/Halfs/BasicIO.hs @@ -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 diff --git a/Halfs/BasicIO.hs-boot b/Halfs/BasicIO.hs-boot new file mode 100644 --- /dev/null +++ b/Halfs/BasicIO.hs-boot @@ -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 () diff --git a/Halfs/BinaryMonad.hs b/Halfs/BinaryMonad.hs new file mode 100644 --- /dev/null +++ b/Halfs/BinaryMonad.hs @@ -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 diff --git a/Halfs/Blocks.hs b/Halfs/Blocks.hs new file mode 100644 --- /dev/null +++ b/Halfs/Blocks.hs @@ -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) diff --git a/Halfs/Blocks.hs-boot b/Halfs/Blocks.hs-boot new file mode 100644 --- /dev/null +++ b/Halfs/Blocks.hs-boot @@ -0,0 +1,9 @@ +module Halfs.Blocks where + +import Halfs.Utils +import Halfs.Inode +import Halfs.FSState + +getDiskAddrOfBlockRead :: Inode + -> BlockNumber + -> FSRead DiskAddress diff --git a/Halfs/Buffer.hs b/Halfs/Buffer.hs new file mode 100644 --- /dev/null +++ b/Halfs/Buffer.hs @@ -0,0 +1,143 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Halfs.Buffer +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : GHC +-- +-- Explanation: The Buffer represents the filesystem's IO buffer. +-- BinHandle for the FS. All of the conversion to-and-from strings and +-- cstrings assume that each byte interpreted is a Char. The +-- conversion functions which don't take a length assume that the +-- entire buffer is a string. Use 'get' if you have a string whose +-- length is stored at the beginning. There are functions for taking +-- a certain number of characters and interpreting them as strings, +-- however. +-- +-- FIX: Clean up types. + +module Halfs.Buffer (Buffer -- no constructor + ,strToBuff + ,strToNewBuff + ,buffToStrSize + ,buffToStr + ,withBuffSize + ,buffToCBuff + ,cBuffToBuff + ,plusBuff + ,buffSeek + ,buffGetHandle + ,newBuff + ,buffSize + ) where + +import Foreign.C.Types (CSize) +import Foreign.Ptr(Ptr) +import Data.Word(Word8) +import Data.Array.SysArray +import Binary + +newtype Buffer = Buffer (BinHandle) + +newBuff :: Int -> IO Buffer +newBuff i = openBinMem i >>= return . Buffer + +buffSize :: Buffer -> IO Int +buffSize (Buffer b) = sizeBinMem b + +-- |Convert this string into a file buffer. Starts at the beginning +-- of the buffer. +strToBuff :: String -> Buffer -> IO () +strToBuff s (Buffer binHandle) + = resetBin binHandle >> mapM_ (put_ binHandle) s + +-- |Allocate a new buffer to fit this entire string. +strToNewBuff :: String -> IO Buffer +strToNewBuff [] = error "strToNewbuff empty list!" +strToNewBuff s = do + h <- openBinMem (length s) + let b = Buffer h + strToBuff s b + return b + +-- |Extract /sz/ characters from this buffer and interpret them as a +-- string. Starts at beginning of buffer. +buffToStrSize :: Int -> Buffer -> IO String +buffToStrSize sz (Buffer binHandle) = do + resetBin binHandle + s <- getMany binHandle sz + return s + +-- |Evaluate this entire buffer as a string, starting from the beginning. +buffToStr :: Buffer -> IO String +buffToStr buffer@(Buffer binHandle) = do + resetBin binHandle + len <- sizeBinMem binHandle + buffToStrSize len buffer + +-- |Internal helper function to grab the given number of chars from +-- this handle. +getMany :: BinHandle -> Int -> IO String +getMany _ 0 = return [] +getMany bh n = do x <- Binary.get bh + xs <- getMany bh (n-1) + return (x:xs) + +-- |Allocate a new buffer of the given size and perform the given +-- function on that buffer. FIX: Free the buffer when done? +withBuffSize :: Int -> (Buffer -> IO a) -> IO a +withBuffSize sz f + | sz <= 0 = error "withBuffSize 0!" + | otherwise = openBinMem sz >>= f . Buffer + +-- |Convert this Halfs Buffer to a C Buffer, starting at the current +-- pointer. The buffer's pointer will be returned to its location. +buffToCBuff :: Buffer -> Ptr Word8 -> CSize -> IO () +buffToCBuff = forwardTwixt loop + where loop _ _ 0 = return () + loop ptr (Buffer binHandle) i = do + ptr_handle <- openFixedSysHandle + (mkSysArray (fromIntegral i) + ptr + False) + resetBin ptr_handle + copyBytes binHandle ptr_handle (fromIntegral i) + return () + +-- |Convert this C buffer to a Halfs Buffer, starting at the current +-- pointer. The buffer's pointer will be returned to its location. +cBuffToBuff :: Buffer -> Ptr Word8 -> CSize -> IO () +cBuffToBuff = forwardTwixt loop + where loop _ _ 0 = return () + loop ptr (Buffer binHandle) i = do + ptr_handle <- openFixedSysHandle + (mkSysArray (fromIntegral i) + ptr + True) -- Read Only + resetBin ptr_handle + copyBytes ptr_handle binHandle (fromIntegral i) + return () + +forwardTwixt :: (Ptr Word8 -> Buffer -> CSize -> IO ()) -> Buffer -> Ptr Word8 -> CSize -> IO () +forwardTwixt f b@(Buffer binHandle) ptr len + | len < 0 = error "FIX: negative number to cBuffToBuff" + | otherwise = do loc <- tellBin binHandle + f ptr b len + seekBin binHandle loc -- put the pounter back + +-- |Move the buffer's pointer forward. +plusBuff :: Buffer -> Int -> IO () +plusBuff (Buffer binHandle) n = do + BinPtr curr <- tellBin binHandle + seekBin binHandle (BinPtr $ curr + n) + return () + +-- |Seek forward or backward on this buffer. +buffSeek :: Buffer -> Int -> IO () +buffSeek (Buffer binHandle) n + = seekBin binHandle (BinPtr n) + +-- |Get the BinHandle out of this buffer. +buffGetHandle :: Buffer -> BinHandle +buffGetHandle (Buffer b) = b diff --git a/Halfs/BufferBlock.hs b/Halfs/BufferBlock.hs new file mode 100644 --- /dev/null +++ b/Halfs/BufferBlock.hs @@ -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 diff --git a/Halfs/BufferBlockCache.hs b/Halfs/BufferBlockCache.hs new file mode 100644 --- /dev/null +++ b/Halfs/BufferBlockCache.hs @@ -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 + + + diff --git a/Halfs/BuiltInFiles.hs b/Halfs/BuiltInFiles.hs new file mode 100644 --- /dev/null +++ b/Halfs/BuiltInFiles.hs @@ -0,0 +1,43 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Halfs.BuiltInFiles +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : GHC +-- +-- Several files are built-in and this module represents reading them. + +module Halfs.BuiltInFiles (readInodeMapFile + ,readBlockMapFile + ) where +import Halfs.BasicIO (readInodeMapBin, readBlockMapBin) +import Halfs.Inode(Inode) +import Halfs.FSState (FSRead) +import Halfs.TheInodeMap (TheInodeMap(..)) +import Halfs.TheBlockMap(TheBlockMap(..)) +import Halfs.FileHandle (readFileFromInode) + + + +-- |Reads it as a file. +readInodeMapFile :: Inode + -> FSRead TheInodeMap +readInodeMapFile inode + = readFileFromInode readInodeMapBin inode + +-- |Reads it as a file. +readBlockMapFile :: Inode + -> FSRead TheBlockMap +readBlockMapFile bmInode' + = readFileFromInode readBlockMapBin bmInode' + +{- Might be useful sometime: +readFileFromHandle :: (BinHandle -> FSRead a) -> FileHandle -> FSRead a +readFileFromHandle f (FileHandle{fhInode=i}) = readFileFromInode f i + +-- |For assertion checking +justSame :: (Eq a) => a -> (b, a) -> Bool +justSame r (_, numRead) = r == numRead + +-} diff --git a/Halfs/CompatFilePath.hs b/Halfs/CompatFilePath.hs new file mode 100644 --- /dev/null +++ b/Halfs/CompatFilePath.hs @@ -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 diff --git a/Halfs/Directory.hs b/Halfs/Directory.hs new file mode 100644 --- /dev/null +++ b/Halfs/Directory.hs @@ -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) diff --git a/Halfs/Directory.hs-boot b/Halfs/Directory.hs-boot new file mode 100644 --- /dev/null +++ b/Halfs/Directory.hs-boot @@ -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 diff --git a/Halfs/FSRW.hs b/Halfs/FSRW.hs new file mode 100644 --- /dev/null +++ b/Halfs/FSRW.hs @@ -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 + diff --git a/Halfs/FSRoot.hs b/Halfs/FSRoot.hs new file mode 100644 --- /dev/null +++ b/Halfs/FSRoot.hs @@ -0,0 +1,201 @@ +----------------------------------------------------------------------------- +-- | +-- Module : FSRoot +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : GHC +-- +-- Explanation: Represents the root of a filesystem and encapsulates +-- the caches. + +module Halfs.FSRoot (FSRoot(..), FileSystemStats(..), + addToInodeCache, + allocateInode, getFromInodeCache, emptyInodeCache, + fsRootUpdateInodeCache, + fsRootInode, fsRootAllInodeNums, fsStats, + fsRootBmInode, fsRootRootDirInode, fsRootImInode, + fsRootUpdateDirectoryCache, fsRootRmFromDirectoryCache, + Directory, -- from Halfs.Directory + FSStatus(..), InodeCacheAddStyle(..), + BufferBlockCache, InodeNum, InodeCache) +where + +import Halfs.TheBlockMap(TheBlockMap(..)) +import Halfs.BufferBlockCache (BufferBlockCache) +import Data.Integral ( INInt ) +import Halfs.Utils (bytesPerBlock, + rootInodeNum, blockMapInodeNum, rootDirInodeNum, + inodeMapInodeNum, FileType(File)) +import System.RawDevice(RawDevice) +import Halfs.Inode (Inode(..), InodeMetadata (..), newInode, + newFSRootInode, newFSBlockMapInode, + newFSRootDirInode, newFSInodeMapInode) +import Halfs.TheInodeMap(TheInodeMap(..)) +import Halfs.Directory(Directory(..), DirectoryCache, addDirectoryToCache, + rmDirectoryFromCache) + +-- base +import Control.Exception(assert) +import Data.Map(Map) +import qualified Data.Map as Map +import Data.Queue (queueLength) +import Data.Set(Set) +import qualified Data.Set as Set + +type InodeNum = INInt + +-- |Maps the inode number to the inode. +type InodeCache = (Map InodeNum Inode, Bool) + +data FSRoot = FSRoot {device :: RawDevice + -- ^The "raw" interface for reading & writing blocks. + ,bbCache :: BufferBlockCache + -- ^Maps the disk address to a cache of the blocks. + ,blockMap :: TheBlockMap + -- ^A queue of free blocks. + ,inodeCache :: InodeCache + -- ^Maps the inode number to the inode. + ,inodeMap :: TheInodeMap + -- ^Keeps track of freed inodes so we can reuse their space. + ,directoryCache :: DirectoryCache + -- ^Maps from inode numbers to directories. + ,fsStatus :: FSStatus + -- ^mounted or unmounted? + } + +data FSStatus = FsUnmounted | FsReadOnly | FsReadWrite deriving (Eq, Show) + +data FileSystemStats = FileSystemStats + { blockSize :: Integer + -- ^ Optimal transfer block size in bytes. + , blockCount :: Integer + -- ^ Total data blocks in file system. + , blocksFree :: Integer + -- ^ Free blocks in file system. + , blocksAvailable :: Integer + -- ^ Free blocks available to non-superusers. + , fileCount :: Integer + -- ^ Total file nodes in file system. + , filesFree :: Integer + -- ^ Free file nodes in file system. + , maxNameLength :: Integer + -- ^ Maximum length of filenames. FUSE default is 255. + } + +-- |Behavior if it's already in the cache +data InodeCacheAddStyle + = InodeCacheOverwrite -- ^if so, overwrite it. If not, add it. + | InodeCacheKeep -- ^if so, keep the cache version + | InodeCacheError -- ^if so, that's an error! throw assertion. + deriving Eq +-- Compare by disk number +instance Eq FSRoot where + (==) FSRoot{device=one} FSRoot{device=two} + = one == two + +-- Compare by disk number +instance Ord FSRoot where + compare FSRoot{device=one} FSRoot{device=two} + = compare one two + +-- |Type is a little funny because it's useful for a fold! +addToInodeCache :: InodeCacheAddStyle -- ^add it even if it's already there? + -> (InodeCache, InodeNum) -- ^old cache, old biggest inode + -> Inode -- ^inode to add + -> (InodeCache, InodeNum) -- new cache, next inode num +addToInodeCache style p@(c@(iCache, _), num) i = + case style of + InodeCacheOverwrite -> adder p i + _ -> case Map.lookup num iCache of + Nothing -> adder p i + Just _ -> ( c + , assert (style /= InodeCacheError) (num+1)) -- throw it away. + where + adder :: (InodeCache, InodeNum) -> Inode -> (InodeCache, InodeNum) + adder ((inCache, _), inodeNum) inode@Inode{metaData=md} + = ((Map.insert inodeNum inode{metaData=md{inode_num=inodeNum}} inCache, True) + ,inodeNum + 1) + +-- |Not a new element, just update the old entry in the cache, so +-- doesn't increase number of inodes. +fsRootUpdateInodeCache :: FSRoot -> Inode -> FSRoot +fsRootUpdateInodeCache fsroot@FSRoot{inodeCache=(ic, _)} + inode@Inode{metaData=InodeMetadata{inode_num=inodeNum}} + = fsroot{inodeCache=(Map.insert inodeNum inode ic, True)} + +getFromInodeCache :: InodeCache -> InodeNum -> Maybe Inode +getFromInodeCache (cache, _) n = Map.lookup n cache + +emptyInodeCache :: InodeCache +emptyInodeCache = (Map.empty, True) + +fsRootInode :: FSRoot -> Inode +fsRootInode FSRoot{inodeCache=c} + = case getFromInodeCache c rootInodeNum of + Nothing -> assert False newFSRootInode -- shouldn't happen. + Just a -> a + +fsRootBmInode :: FSRoot -> Inode +fsRootBmInode FSRoot{inodeCache=c} + = case getFromInodeCache c blockMapInodeNum of + Nothing -> assert False newFSBlockMapInode -- shouldn't happen. + Just a -> a + +fsRootRootDirInode :: FSRoot -> Inode +fsRootRootDirInode FSRoot{inodeCache=c} + = case getFromInodeCache c rootDirInodeNum of + Nothing -> assert False newFSRootDirInode -- shouldn't happen. + Just a -> a + +fsRootImInode :: FSRoot -> Inode +fsRootImInode FSRoot{inodeCache=c} + = case getFromInodeCache c inodeMapInodeNum of + Nothing -> assert False newFSInodeMapInode -- shouldn't happen. + Just a -> a + +-- |Creates a new inode out of thin air and puts it into the inode +-- cache, and returns its number. +allocateInode :: FSRoot + -> (INInt, FSRoot) +allocateInode fsRoot@FSRoot{inodeMap=inMap@TheInodeMap{freeInodes=[] + ,imMaxNum=numInodes}, + inodeCache=inCache + } = + let (newCache, newNumInodes) + = addToInodeCache InodeCacheOverwrite (inCache, numInodes) (newInode numInodes File) + in (numInodes, fsRoot{inodeCache=newCache + ,inodeMap=inMap{imDirty=True, + imMaxNum=newNumInodes}}) +-- initialize h in case it's right from the disk? +allocateInode fs@FSRoot{inodeMap=im@TheInodeMap{freeInodes=(h:t)}} + = (h, fs{inodeMap=im{freeInodes=t, imDirty=True}}) + +fsRootUpdateDirectoryCache :: Directory -> FSRoot -> FSRoot +fsRootUpdateDirectoryCache dir fsroot@FSRoot{directoryCache=c} + = fsroot{directoryCache=addDirectoryToCache c dir} + +fsRootRmFromDirectoryCache :: INInt -- The inode number of the directory to remove + -> FSRoot + -> FSRoot +fsRootRmFromDirectoryCache dirInodeNum fsroot@FSRoot{directoryCache=c} + = fsroot{directoryCache=rmDirectoryFromCache c dirInodeNum} + +fsRootAllInodeNums :: FSRoot -> Set INInt +fsRootAllInodeNums FSRoot{inodeMap=theInMap} + = let maxInode = (imMaxNum theInMap) - 1 + in (Set.fromList (0:[blockMapInodeNum .. maxInode])) + `Set.difference` (Set.fromList $ freeInodes theInMap) + +fsStats :: FSRoot -> IO FileSystemStats +fsStats fsroot = do + let availBlocks = toInteger $ queueLength $ freeBlocks $ blockMap $ fsroot + return FileSystemStats{blockSize=toInteger bytesPerBlock + ,blockCount=toInteger $ bmTotalSize $ blockMap fsroot + ,blocksFree=availBlocks + ,blocksAvailable=availBlocks + ,fileCount=toInteger + $ Set.size $ fsRootAllInodeNums fsroot + ,filesFree=0 + ,maxNameLength=255 + } diff --git a/Halfs/FSState.hs b/Halfs/FSState.hs new file mode 100644 --- /dev/null +++ b/Halfs/FSState.hs @@ -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 diff --git a/Halfs/FileHandle.hs b/Halfs/FileHandle.hs new file mode 100644 --- /dev/null +++ b/Halfs/FileHandle.hs @@ -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 diff --git a/Halfs/FileHandle.hs-boot b/Halfs/FileHandle.hs-boot new file mode 100644 --- /dev/null +++ b/Halfs/FileHandle.hs-boot @@ -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 + } diff --git a/Halfs/Inode.hs b/Halfs/Inode.hs new file mode 100644 --- /dev/null +++ b/Halfs/Inode.hs @@ -0,0 +1,245 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Halfs.Inode +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : GHC +-- +-- Explanation: Represents inodes in the system. +-- +-- The root inode is a file containing all of the inodes in the +-- system. This file never shrinks. + +module Halfs.Inode (Inode(..), InodeBlock, InodeMetadata(..) + ,newFSRootInode, newFSBlockMapInode, newFSRootDirInode + ,newFSInodeMapInode, dupInode + ,rootInodeDiskAddr, firstFreeInodeDiskAddr + ,getPointerAt, updatePointers, isRootDirInode + ,goodInodeMagic, inodeBumpSize, newInode, inodeAddLink) + where + +import Binary(Binary(..), Bin(..),tellBin,seekBin) +import Halfs.Utils hiding (bytesPerBlock) +import qualified Halfs.Utils (bytesPerBlock) +import Data.Integral +import Data.Array(listArray, (!), (//), elems) +import Control.Exception(assert) + +bytesPerBlock :: INLong +bytesPerBlock = intToINLong Halfs.Utils.bytesPerBlock + +data Inode + = Inode + { + metaData :: InodeMetadata + ,blockPtrs :: INPointers -- 16 pointers @ 32 bits each + } deriving (Show, Eq) + +-- |Must be length 16 +type InodeBlock = [Inode] + +updatePointers :: Inode -> [(Int, INInt)] -> Inode +updatePointers inode@Inode{blockPtrs=ptrs} updatedPtrs + = inode{blockPtrs=ptrs // (assert ((length (filter (\(x,_) -> + x >= blockPointersPerInode) + updatedPtrs)) + == 0) + updatedPtrs)} + +-- |Copy the important bits of this inode, bit not all of them; , +-- leave the inode number alone, but copy everthing else. +dupInode :: Inode -- ^Source inode + -> Inode -- ^Copy to here + -> Inode -- ^Resulting inode +dupInode fromI@Inode{metaData=fromMD} _toI@Inode{metaData=toMD} + = fromI{metaData=fromMD{magic1 =magic1 toMD + ,inode_num=inode_num toMD + } + } + +newFSRootInode :: Inode +newFSRootInode = let tempInode1 = newInode rootInodeNum File + tempInode = tempInode1{metaData=(metaData tempInode1) + {magic1=rootInodeMagicNum}} + in + inodeBumpSize (updatePointers tempInode [(0, rootInodeDiskAddr), + (1, rootInodeDiskAddr + 1)]) + (bytesPerBlock * 2) + +-- See notes about the block map in TheBlockMap.hs. Block map +-- filesize never changes. +newFSBlockMapInode :: Inode +newFSBlockMapInode = inodeBumpSize (updatePointers (newInode blockMapInodeNum File) + [(0,blockMapInodeDiskAddr)]) + bytesPerBlock + +newFSInodeMapInode :: Inode +newFSInodeMapInode = inodeBumpSize (updatePointers (newInode inodeMapInodeNum File) + [(0, inodeMapInodeDiskAddr)]) + bytesPerBlock + +newFSRootDirInode :: Inode +newFSRootDirInode = inodeBumpSize (updatePointers (newInode rootDirInodeNum Dir) + [(0, rootDirInodeDiskAddr)]) + bytesPerBlock + +goodInodeMagic :: Inode -> Bool +goodInodeMagic Inode{metaData=InodeMetadata{magic1=magicNum + ,inode_num=num}} + = if num == rootInodeNum + then magicNum == rootInodeMagicNum + else magicNum == otherInodeMagicNum + +-- |Is this the rootDir inode? +isRootDirInode :: Inode -> Bool +isRootDirInode Inode{metaData=InodeMetadata{inode_num=inodeNum}} + = inodeNum == rootDirInodeNum + +-- |Create a new inode based on this inode number +newInode :: INInt -> FileType -> Inode +newInode num filetype + = let inodeMD = InodeMetadata otherInodeMagicNum 0 0 0 + filetype + num -- inode number + 0 0 0 0 -- so far unused + 1 -- level + in Inode inodeMD (listArray (0, blockPointersPerInode - 1) + (replicate blockPointersPerInode 0)) + +-- |Increase the size of this inode, cannot decrease it! +inodeBumpSize :: Inode + -> INLong -- ^size in bytes + -> Inode +inodeBumpSize inode@(Inode md _) newSize = + inode{metaData=md{num_bytes=max (num_bytes md) newSize}} + +inodeAddLink :: Inode -> Inode +inodeAddLink i@Inode{metaData=md@InodeMetadata{hard_links=hl}} + = i{metaData=md{hard_links=hl+1}} + +-- |Get the block pointer from this inode array. +getPointerAt :: Inode -> BlockNumber -> INInt +getPointerAt inode blockNumber = + (blockPtrs inode) ! + (assert (blockNumber < intToINInt blockPointersPerInode + && blockNumber >= 0) + (inIntToInt blockNumber)) + +rootInodeDiskAddr :: INInt +rootInodeDiskAddr = 0 + +firstFreeInodeDiskAddr :: INInt +firstFreeInodeDiskAddr = rootDirInodeDiskAddr + 1 + +-- For internal use only; they may change after newfs. + +blockMapInodeDiskAddr :: INInt +blockMapInodeDiskAddr = 2 + +inodeMapInodeDiskAddr :: INInt +inodeMapInodeDiskAddr = 3 + +rootDirInodeDiskAddr :: INInt +rootDirInodeDiskAddr = 4 + +-- ------------------------------------------------------------ +-- * INodeMetaData +-- ------------------------------------------------------------ + +data InodeMetadata + = InodeMetadata + { + magic1 :: INInt + ,num_bytes :: INLong + ,uid :: INInt + ,gid :: INInt + ,mode :: FileType -- ^ file or dir + ,inode_num :: INInt + ,flags :: INInt + ,hard_links :: INInt -- ^persistent references + ,create_time :: INLong + ,last_modified_time :: INLong + ,level :: INInt -- sum to here: 56 bytes + } deriving Eq + +instance Show InodeMetadata where + show i + = "\n-----\n" + ++ printField x "magic1" magic1 + ++ printField s' "num_bytes" num_bytes + ++ printField s "uid" uid + ++ printField s "gid" gid + ++ printField show "mode" mode + ++ printField s "inode_num" inode_num + ++ printField s "flags" flags + ++ printField s "hard_links" hard_links + ++ printField s' "create_time" create_time + ++ printField s' "last_modified_time" last_modified_time + ++ printField s "level" level + ++ "-----\n" + where + x = myShowHex + s = show + s' = show + printField :: (Show a) => (a -> String) + -> String -- ^label + -> (InodeMetadata -> a) + -> String + printField shower lab f + = lab ++ ": " ++ (shower $ f i) ++ "\n" + + +-- ------------------------------------------------------------ +-- * Binary representation of the Inodes +-- ------------------------------------------------------------ + +instance Binary Inode where + put_ h inode = do + (BinPtr start) <- tellBin h + put_ h (metaData inode) + sequence_ [ put_ h ptr | ptr <- elems $ blockPtrs inode] + seekBin h (BinPtr (start + bytesPerInode)) + return () + get h = do + (BinPtr start) <- tellBin h + meta <- get h + ptrs <- sequence [ get h | _ <- take 16 [1..blockPointersPerInode] ] + seekBin h (BinPtr (start + bytesPerInode)) + return $ Inode { metaData = meta + , blockPtrs = listArray (0, blockPointersPerInode - 1) $ ptrs + } + +instance Binary InodeMetadata where + put_ h a = do + put_ h (magic1 a) + put_ h (num_bytes a) + put_ h (uid a) + put_ h (gid a) + put_ h (mode a) + put_ h (inode_num a) + put_ h (flags a) + put_ h (hard_links a) + put_ h (create_time a) + put_ h (last_modified_time a) + put_ h (level a) + -- add assert about size + return () + + get h = do magic1' <- get h + num_bytes' <- get h + uid' <- get h + gid' <- get h + mode' <- get h + inode_num' <- get h + flags' <- get h + hard_links' <- get h + create_time' <- get h + last_modified' <- get h + level' <- get h + -- add assert about size + return $ InodeMetadata magic1' num_bytes' uid' + gid' mode' inode_num' flags' + hard_links' create_time' last_modified' level' + + diff --git a/Halfs/SyncStructures.hs b/Halfs/SyncStructures.hs new file mode 100644 --- /dev/null +++ b/Halfs/SyncStructures.hs @@ -0,0 +1,200 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Halfs.SyncStructures +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : GHC +-- +-- Explanation: Write various internal structures to disk. Note that +-- the inode file never shrinks and the block map file never shrinks +-- or grows. Therefore, +-- +-- * When syncing directories, use truncate, since they might shrink a lot. This includes the root directory. +-- +-- * When syncing the inode map, use truncate, Its size might change. +-- +-- * When syncing the inode file, use write. It never shrinks. +-- +-- * When syncing the block map, use write. Its size never changes. + +module Halfs.SyncStructures (shortSyncFSRoot, syncFSRoot, syncDirectoryToFile) where + +import Halfs.Directory(Directory(..), DirectoryCache(..), addDirectoryToCache, + dirCacheDirty, directoryCacheToList) +import Halfs.FSRoot(FSRoot(..), fsRootUpdateInodeCache, fsRootBmInode, FSStatus(..)) +import Halfs.Inode (Inode(..), InodeMetadata(..)) +import Halfs.FileHandle (fhInode, fileHandle, fhOpenTruncate, fhWrite, fileHandle, + FileHandle(..), FileMode(..)) +import Halfs.BasicIO (BinHandle, writeDirectoryBin, syncInode, + writeBlockMapBin, writeInodeMapBin) +import Halfs.BinaryMonad(openBinMemRW, sizeBinMemRW) +import Halfs.TheBlockMap(TheBlockMap,bmDirty) +import Halfs.TheInodeMap(TheInodeMap(..)) +import Data.Integral(INInt, intToINInt, INLong) +import Halfs.Utils(bytesPerBlock, + inodeMapInodeNum, blockMapInodeNum) +import Halfs.BufferBlockCache(syncBBCache) +import Halfs.FSState (FSWrite, modify, unsafeWriteGet, readToWrite, + putStrLnWriteRead) + +-- base +import Control.Exception(assert) +import Control.Monad(mapM_, when) +import qualified Data.Map as Map + +-- |writes it as a file, marks it as clean. block map file never +-- shrinks. see notes in TheBlockMap.hs +syncBlockMapFile :: FSWrite () +syncBlockMapFile = do + fsroot@FSRoot{blockMap=theBlockMap} <- unsafeWriteGet + let oldSize = num_bytes $ metaData $ fsRootBmInode fsroot + + syncObjectToFile theBlockMap + (bmDirty theBlockMap) + blockMapInodeNum + writeBlockMapBin + (updater oldSize) False + where + updater :: INLong -> Inode -> FSRoot -> FSRoot + updater oldSize inode fsroot'@FSRoot{blockMap=bm} + -- if it's grown, then it's still dirty: + = let isDirty = (oldSize /= (num_bytes $ metaData inode)) + in fsroot'{blockMap=bm{bmDirty=isDirty}} + +-- |Inode map file is open truncate, it can be resized. +syncInodeMapFile :: FSWrite () +syncInodeMapFile = do + fsroot <- unsafeWriteGet + let inMap = inodeMap fsroot + syncObjectToFile inMap + (imDirty inMap) + inodeMapInodeNum + writeInodeMapBin updater True + where + updater :: Inode -> FSRoot -> FSRoot + updater _inode fsroot'@FSRoot{inodeMap=im} + = fsroot'{inodeMap=im{imDirty=False}} + +-- |Directories are open truncate, they can be resized. +syncDirectoryToFile :: Directory -> FSWrite () +syncDirectoryToFile d = do + -- the below updater may alter the inode, but don't worry + -- fsrootupdateinodecache will handle that in the case of root + -- directory. + let inodeNum = fhInodeNum $ dirFile d + syncObjectToFile (dirContents (assert (dirHasItsInodeNum d) d)) + (dirDirty d) + inodeNum writeDirectoryBin (updater d) True + -- FIX: If it's the root inode, we should mark it not dirty. + where + updater :: Directory -> Inode -> FSRoot -> FSRoot + updater dir i fsr = let newR@FSRoot{directoryCache=c} + = fsRootUpdateInodeCache fsr i + in newR {directoryCache=addDirectoryToCache c dir{dirDirty=False}} + + dirHasItsInodeNum :: Directory -> Bool + dirHasItsInodeNum (Directory FileHandle{fhInodeNum=i} c _) + = case Map.lookup "." c of + Nothing -> True -- might be root + Just a -> a == i + +syncDirectoryCache :: FSWrite () +syncDirectoryCache = do + FSRoot{directoryCache=c} <- unsafeWriteGet + when (dirCacheDirty c) (mapM_ syncDirectoryToFile (directoryCacheToList c)) + + -- FIX: Possible race condition right here. updater calls modify, so + -- we can't grab it HERE because of deadlock. I think this is fixed + -- by not marking the dcirecotry cache clean :( directories + -- themselves have clean markers, though, so it should be OK. + + modify (\fsroot@FSRoot{directoryCache=_c} -> fsroot) +-- fsroot{directoryCache=markDirectoryCacheClean c}) + +syncObjectToFile :: a -- which object + -> Bool -- is dirty + -> INInt -- inode num + -> (BinHandle -> a -> FSWrite ()) -- writer function + -> (Inode -> FSRoot -> FSRoot) -- updater / dirty marker + -> Bool -- ^Truncate if dirty, otherwise write in-place. FIX: take open flag when that's fixed. + -> FSWrite () +syncObjectToFile _ False _ _ _ _ = return () +syncObjectToFile obj True inodeNum writer updater trunc = do + -- This file will always be less than INInt, not INLong + newFileHandle <- if trunc + then fhOpenTruncate inodeNum + else return $ fileHandle inodeNum WriteMode + + {- FIX: For large filesystems, this may be a bad plan.. that is, we + allocate a single block for the object, then start writing to it. + Binary.hs will resize the array if necessary. fhWrite then performs + the actual write to the filesystem in blocks. What we _should_ do + is perform buffered writes to this array and _not_ resize it, so + that we don't allocate one huge array for these structures. OTOH, + maybe that's not a big deal, as it'll only be an issue for really + big filesystems? -} + + buffer <- openBinMemRW bytesPerBlock -- (num_bytes $ metaData fhInode fileHandle) -- initial size + writer buffer obj -- may resize buffer! + objSize <- sizeBinMemRW buffer + (newFH, writtenNum) + <- fhWrite newFileHandle buffer 0 (intToINInt objSize) + inode <- readToWrite $ fhInode newFH + assert (writtenNum == intToINInt objSize) $ + modify (updater inode) + +-- |Sync the entire inode cache! Woohoo! +syncInodeCache :: FSWrite () +syncInodeCache = do + FSRoot{inodeCache=(inCache,isDirty)} <- unsafeWriteGet + when isDirty (mapM_ syncInode (Map.elems inCache) + >> modify (\fsroot -> fsroot{inodeCache=(fst $ inodeCache fsroot, False)})) + +keepSyncingBlockMap :: FSWrite () +keepSyncingBlockMap = do + return() + FSRoot{blockMap=theBlockMap} <- unsafeWriteGet + when (bmDirty theBlockMap) (do syncBlockMapFile + syncInodeCache + FSRoot{blockMap=theBlockMap1} <- unsafeWriteGet + -- only need to keep syncing if size changed + when (bmDirty theBlockMap1) keepSyncingBlockMap) + +-- |Writes the FSRoot to cache, then to device +syncFSRoot :: FSWrite () +syncFSRoot = do + putS "syncing... " + FSRoot{fsStatus=status, bbCache=cache} <- unsafeWriteGet + let syncBBC = syncBBCache cache + assert (status == FsReadWrite) syncBBC + syncDirectoryCache + syncBBC + syncInodeMapFile + syncBBC + syncBlockMapFile + syncBBC + syncInodeCache + -- Have to do it twice; the first time it might actually change + -- itself. FIX: Should actually do this until we stabalize, and + -- write the inode cache after each one! +-- syncBlockMapFile >> syncInodeCache + keepSyncingBlockMap + syncBBC + + +-- |Writes the FSRoot to cache (sans free list), then to device +shortSyncFSRoot :: FSWrite () +shortSyncFSRoot = do + putS "syncing (sans free list) ... " + FSRoot{fsStatus=status, bbCache=cache} <- unsafeWriteGet + let syncBBC = syncBBCache cache + assert (status == FsReadWrite) $ return () + syncDirectoryCache + syncInodeMapFile + syncInodeCache +-- finally, the buffer blocks them selfs. + syncBBC + +putS :: String -> FSWrite () +putS = putStrLnWriteRead diff --git a/Halfs/TestFramework.hs b/Halfs/TestFramework.hs new file mode 100644 --- /dev/null +++ b/Halfs/TestFramework.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE Rank2Types, GADTs #-} +----------------------------------------------------------------------------- +-- | +-- Module : TestFramework +-- Copyright : Copyright 2004 by by Aetion Technologies LLC +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : Hugs, GHC (Uses existential types) +-- +-- Explanation: Provide basic functions for conviniently running a +-- collection of HUnit and QuickCheck tests. + +{- ============================================================================= +Copyright 2004 by Aetion Technologies LLC. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of the Aetion Technologies LLC nor the names of its + contributors may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +============================================================================= -} + +module Halfs.TestFramework (UnitTests, QC(..), runTest, + combineCounts, runAllTests, + hunitToUnitTest, listsToUnitTests, + qcToUnitTest, testMain, assertCmd, + module Test.QuickCheck, + module Test.HUnit +-- ,(~:), (~=?) + ) where + +-- Base: +import Control.Monad(liftM) +import Data.Maybe(catMaybes) +import Test.QuickCheck (quickCheck, Testable, (==>)) +import System.Cmd(system) +import System.Exit (ExitCode(ExitSuccess)) + +-- Misc: + -- FIX: should eventually be Debug.HUnit or Test.HUnit. +import Test.HUnit (Test(..), Counts(..), Assertion, + (~:), (~=?), assertEqual, assertBool, test, runTestTT) + +-- ------------------------------------------------------------ +-- * Types +-- ------------------------------------------------------------ + +-- |Extra constructor is required. Uses the existential constructor +-- feature so we can have heterogeneous lists. +data QC = forall a. (Testable a) => QC String a + +-- |Either HUnit or QuickCheck +type UnitTests = [Either Test -- HUnit test suite + QC] -- QuickCheck test suite + +hunitToUnitTest :: [Test] -> UnitTests +hunitToUnitTest = map Left + +qcToUnitTest :: [QC] -> UnitTests +qcToUnitTest = map Right + +listsToUnitTests :: [Test] -> [QC] -> UnitTests +listsToUnitTests hu qc + = (map Left hu) ++ (map Right qc) + +-- ------------------------------------------------------------ +-- * Convinient Functions +-- ------------------------------------------------------------ + +-- |Beautify this test label. +prettyLab :: String -> String +prettyLab lab = "---+++ " ++ lab + +-- |Print out the test label before execution. +runTest :: Test -> IO Counts +runTest t@(TestLabel lab _) = (putStrLn $ prettyLab lab) >> runTestTT t +runTest t = runTestTT t + +-- |Given a collection of tests, run them through either quickcheck or +-- HUnit, as appropriate. +runAllTests :: UnitTests -> IO [Counts] +runAllTests t + = do counts <- sequence $ map tester t + return $ catMaybes counts + where tester :: Either Test QC -> IO (Maybe Counts) + tester (Left hUnitTest) = liftM Just (runTest hUnitTest) + tester (Right (QC lab t')) = do putStrLn $ prettyLab lab; quickCheck t'; return Nothing + + +combineCounts :: Counts -> Counts -> Counts +combineCounts (Counts a b c d) (Counts a' b' c' d') + = Counts (a + a') (b + b') (c + c') (d + d') + +-- |Run this command, and assert it returns a successful error code. +assertCmd :: String -- ^Command + -> String -- ^Comment + -> Assertion +assertCmd command comment + = system command >>= assertEqual (command ++ ":" ++ comment) ExitSuccess + +-- ------------------------------------------------------------ +-- * For Testing +-- ------------------------------------------------------------ + +testMain :: IO () +testMain = do runAllTests ([Left $ TestLabel "foo" (TestList ["a" ~: "failed" ~: 3 ~=? (32::Int)]), + Right (QC "first" (True ==> False)), (Right $ QC "snd" True) + ]) + return () diff --git a/Halfs/TheBlockMap.hs b/Halfs/TheBlockMap.hs new file mode 100644 --- /dev/null +++ b/Halfs/TheBlockMap.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE PatternSignatures #-} +----------------------------------------------------------------------------- +-- | +-- Module : TheBlockMap +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : GHC +-- +-- Explanation: Tracks free blocks in the filesystem. Does not track +-- non-free blocks. Exists as a FIFO queue to avoid block reuse. +-- This is also true when syncing to the disk; it syncs in FIFO order, +-- so when its read from the disk, the least-recently-used block is on +-- the end, and won't be used for a while. -- The number of bytes in +-- the block map file does _not_ change, but not all of those bytes +-- will always be used. That is, the block map file is a fixed size, +-- does not shrink after newFS. + +module Halfs.TheBlockMap (TheBlockMap -- abstract + ,mkBlockMap + ,allocateBlock + ,freeBlock + ,freeBlocks + ,bmTotalSize + ,bmDirty + ,newFS + ,findAddress + ,unitTests) + where + +import Halfs.Inode (Inode(metaData), InodeMetadata(level) + ,newInode, firstFreeInodeDiskAddr) +import Halfs.TestFramework (Test(..), UnitTests, (~:), (~=?), + hunitToUnitTest) +import Data.Integral ( INInt, intToINInt ) +import Halfs.Utils (DiskAddress, BlockNumber, + FileType (File), + blockPointersPerIndirectBlock, + blockPointersPerInode) + +-- Base +import Data.Queue (listToQueue, addToQueue, deQueue, Queue, queueToList, queueLength) +import qualified Data.Set as Set +import Control.Exception(assert) + +-- TODO: each block of blockmap should have a dirty bit (inside the +-- inode) +data TheBlockMap = TheBlockMap {freeBlocks :: Queue DiskAddress + ,_freeBlocksSet :: Set.Set DiskAddress + ,bmDirty :: Bool + ,bmTotalSize :: INInt -- total number of blocks + } + +-- |todo: check to see if new epoch, optimize allocation by using a +-- window and passing in a hint of where it "should" go. "Nothing" +-- means that the disk is full. + +allocateBlock :: TheBlockMap -> Maybe (DiskAddress, TheBlockMap) +allocateBlock (TheBlockMap inBlockMap inBlockSet _ s) + = case deQueue inBlockMap of + Nothing -> Nothing -- Nothing free! + Just (addr, newBlockMap) + -> Just ((assert (addr /= 0) addr), TheBlockMap newBlockMap (Set.delete addr inBlockSet) True s) + +freeBlock :: TheBlockMap -> DiskAddress -> TheBlockMap +freeBlock (TheBlockMap inBlockMap inBlockSet _ len) addr + = assert (not (Set.member addr inBlockSet)) $ + assert (addr > 0 && addr < len) $ + TheBlockMap (addToQueue inBlockMap (assert (addr /= 0) addr)) (Set.insert addr inBlockSet) True len +{- + where addToQueue' q addr = listToQueue (take offset xs ++ [addr] ++ drop offset xs) + where xs = queueToList q + offset = 200 +-} +-- |smart constructor for TheBlockMap +newFS :: INInt -- ^Length of the device in blocks + -> TheBlockMap +newFS len -- 0 and 1 are inode file and inodemap file + = mkBlockMap (listToQueue [firstFreeInodeDiskAddr .. (len - 1)]) True len + +mkBlockMap :: Queue DiskAddress -> Bool -> INInt -> TheBlockMap +mkBlockMap free busy size + = assert (queueLength free == Set.size freeSet) $ + TheBlockMap free freeSet busy size + where freeSet = Set.fromList (queueToList free) + +instance Show TheBlockMap where + show (TheBlockMap free _ de tot) = "TheBlockMap [" ++ showBM (queueToList free) ++ "] " ++ show de ++ " " ++ show tot + where + commas [] = "" + commas xs = foldl1 (\ a b -> a ++ "," ++ b) xs + showBM xs = commas + [ if a == b + then + show a + else show a ++ ".." ++ show b + | (a,b) <- combine [ (x,x) | x <- xs ] ] + combine ((a,b):(c,d):r) | b+1 == c = combine ((a,d):r) + combine (v:r) = v: combine r + combine [] = [] + +{- +instance Show TheBlockMap where + show (TheBlockMap fb _ _) + = fmap (\x -> if isFree x then "-" else "X") +-} + +-- ------------------------------------------------------------ +-- * Computing the location on disk of this block +-- ------------------------------------------------------------ + +findAddress :: Inode -- ^Inode that contains the blocks + -> BlockNumber -- ^Address we're looking for, 0 indexed + -> [INInt] -- ^dereference locations at each level, 0 indexed +findAddress inode findMe + = addrList (level $ metaData inode) + 1 + (intToINInt blockPointersPerIndirectBlock) + (intToINInt blockPointersPerInode) + findMe + +-- |Compute the list of locations in a tree with the given branching +-- factor. Counts up to totalLevels, zero indexed. That is, if I'm +-- looking for the 3rd element in a zero indexed binary tree with two +-- levels, it'll be [1,1]. addrList 3 3 2 10 == [1,0,1] + +addrList :: INInt -- Levels + -> INInt -- current level + -> INInt -- branching factor + -> INInt -- base buckets + -> BlockNumber -- address to find + -> [INInt] +addrList totalLevels currLevel branchingFactor baseBuckets findMe + | findMe >= numBuckets totalLevels branchingFactor baseBuckets + = error "block too big, should have resized" + | currLevel > totalLevels = [] + | otherwise = let bucketLoc = absBucket totalLevels currLevel + branchingFactor baseBuckets findMe + prevLevel = currLevel - 1 + prevBucket = absBucket totalLevels prevLevel + branchingFactor baseBuckets findMe + answer = if currLevel == 1 + then bucketLoc + else bucketLoc - (branchingFactor * prevBucket) + in answer : (addrList totalLevels (currLevel + 1) + branchingFactor baseBuckets findMe) + +-- |How many buckets at this level for this branching factor? +numBuckets :: INInt -- current level + -> INInt -- branching factor + -> INInt -- base buckets + -> INInt +numBuckets 0 _ _ = error "zero" +numBuckets 1 _ b = b +numBuckets currLevel branchingFactor baseBuckets + = (numBuckets (currLevel - 1) branchingFactor baseBuckets) * branchingFactor + +-- Get the bucket of this element as if this entire level were one node +absBucket :: INInt -- total levels + -> INInt -- current level + -> INInt -- branching factor + -> INInt -- base buckets + -> BlockNumber -- location to find. + -> INInt +absBucket _ _ _ _ 0 = 0 +absBucket totalLevels currLevel branchingFactor baseBuckets findMe = + let maxElems = numBuckets totalLevels branchingFactor baseBuckets + buckets = numBuckets currLevel branchingFactor baseBuckets + itemsPerBucket = maxElems `div` (assert (buckets /= 0) buckets) + -- Below "1" adjustments are because addresses start at zero. + in (ceiling $ toRational (findMe+1) / toRational itemsPerBucket) - 1 + +-- ------------------------------------------------------------ +-- * Testing +-- ------------------------------------------------------------ + +unitTests :: UnitTests +unitTests = hunitToUnitTest hunitTests + +hunitTests :: [Test] +hunitTests = let inode' = newInode 0 File + inode = inode'{metaData=(metaData inode'){level=2}} + inode2 = inode'{metaData=(metaData inode'){level=3}} + (maxAddr::INInt) = (16 * (1024 ^ (2::Int))) - 1 -- for 3 levels + in + ["simple Address List 1" ~: "failed" ~: [1,0,1] ~=? addrList 3 1 3 2 10 + ,"simple Address List 2" ~: "failed" ~: [1,0,2] ~=? addrList 3 1 3 2 11 + ,"simple Address List 2" ~: "failed" ~: [1,1,1] ~=? addrList 3 1 3 2 13 + ,"disk addr list 1" ~: "failed" ~: [0,0] ~=? findAddress inode 0 + ,"disk addr list 2" ~: "failed" ~: [0,1] ~=? findAddress inode 1 + ,"disk addr list 3" ~: "failed" ~: [0,1023] ~=? findAddress inode 1023 + ,"disk addr list 4" ~: "failed" ~: [1,0] ~=? findAddress inode 1024 + ,"disk addr list 3 lev. 1" ~: "failed" ~: [0,1,0] ~=? findAddress inode2 1024 + ,"disk addr list 3 lev. 2" ~: "failed" + ~: [0,0,1023] ~=? findAddress inode2 1023 + ,"disk addr list 3 lev. 3" ~: "failed" ~: [0,5,0] ~=? findAddress inode2 5120 + ,"max addr" ~: "failed" ~: maxAddr ~=? (numBuckets 3 1024 16) - 1 + ,"max addr loc" ~: "failed" ~: [15, 1023, 1023] + ~=? findAddress inode2 maxAddr + -- FIX: Should test address maxAddr + 1 which should fail + ] diff --git a/Halfs/TheInodeMap.hs b/Halfs/TheInodeMap.hs new file mode 100644 --- /dev/null +++ b/Halfs/TheInodeMap.hs @@ -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} diff --git a/Halfs/Utils.hs b/Halfs/Utils.hs new file mode 100644 --- /dev/null +++ b/Halfs/Utils.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Halfs.Utils +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : GHC +-- +-- Explanation: Implements some useful routines and stores some +-- interesting constants. + +module Halfs.Utils + ( module Halfs.Utils + , module System.RawDevice.Base + ) where + +import Binary (Binary, put_, get) + +-- base +import Numeric(showHex) +import Data.Char (toUpper) +import Control.Monad(when) +import Control.Monad.Error(throwError, MonadError) +import Data.Array (Array) +import Data.Array.MArray +import System.Directory (removeFile, doesFileExist) +import System.IO.Error(userError) +import System.RawDevice.Base +import Data.Integral + +type INPointers = Array Int DiskAddress + + +-- |Like fromJust, but spits out the given error on failure. This is +-- for situations which should not happen +fromJustErr :: String -- ^Error to spew before failing to continue + -> Maybe a + -> a +fromJustErr s Nothing = error s +fromJustErr _ (Just a) = a + +-- |Get a block of memory that's the right size for a block. +-- NOTE: leak + +getMemoryBlock :: IO (BufferBlockHandle s) +getMemoryBlock = newBufferBlockHandle + +myShowHex :: (Integral i) => i -> String +myShowHex n = "0x" ++ map toUpper (Numeric.showHex n []) + +rootInodeNum :: INInt +rootInodeNum = 0 + +-- See notes about the block map in TheBlockMap.hs. Block map +-- filesize never changes. +blockMapInodeNum :: INInt +blockMapInodeNum = 16 + +inodeMapInodeNum :: INInt +inodeMapInodeNum = 17 + +rootDirInodeNum :: INInt +rootDirInodeNum = 18 + +firstFreeInodeNum :: INInt +firstFreeInodeNum = rootDirInodeNum + 1 + +blockPointersPerInode :: Int +blockPointersPerInode = 16 + +blockPointersPerIndirectBlock :: Int +blockPointersPerIndirectBlock = bytesPerBlock `div` bytesPerBlockPointer + +bytesPerBlockPointer :: Int +bytesPerBlockPointer = 4 + +bytesPerInode :: Int +bytesPerInode = 256 + +inodesPerBlock :: Int +inodesPerBlock = bytesPerBlock `div` bytesPerInode + +rootInodeMagicNum :: INInt +rootInodeMagicNum = 0x2395458 + +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) diff --git a/HighLevelTests.hs b/HighLevelTests.hs new file mode 100644 --- /dev/null +++ b/HighLevelTests.hs @@ -0,0 +1,348 @@ +{-# LANGUAGE PatternSignatures #-} +----------------------------------------------------------------------------- +-- | +-- Module : HighLevelTests +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : GHC +-- +-- Explanation: Implements higher-level interfaces like copying whole +-- files. Implements high-level tests that tie together multiple modules. + +module HighLevelTests where + +import Halfs (withFSWrite, unmountFS, unmountWriteFS, withFSRead, mountFSMV, + rename, mkdir, getDirectoryContents, openFileAtPathWrite, + syncPeriodicallyWrite, + openFileAtPathRead, withNewFSWrite, unlink, openAppend, seek, + closeWrite, makeFiles, write, + fsckWrite, closeWrite, closeRead, openRead, readReadRef) +import qualified Halfs as H (read) + +import Halfs.TestFramework (Test(..), UnitTests, hunitToUnitTest, + assertCmd, assertEqual, assertBool) +import Halfs.BasicIO (devBufferReadHost, devBufferWriteHost, + getInodeWrite, getMemoryBlock) +import Binary(openBinMem, resetBin, put, get) +import Halfs.Inode (Inode(..), InodeMetadata(..), getPointerAt) +import Halfs.FSRoot (FSRoot(..)) +import Halfs.FileHandle (FileHandle(..), FileMode(WriteMode), fhCloseWrite, + fhRead, fhWrite, fhSize) +import Halfs.FSState (FSWrite, FSRW, StateHandle(..), readToWrite, unsafeLiftIOWrite, + putStrLnWriteRead, unsafeLiftIORW, evalFSWriteIOMV, + unsafeLiftIOWriteWithRoot, unsafeReadGet, unsafeLiftIORead, + runFSWriteIO, throwError, runFSReadIO, unsafeWriteGet) +import Halfs.Buffer (strToNewBuff, newBuff, buffToStrSize) +import Halfs.Blocks (getBlockFromCacheOrDeviceWrite, getDiskAddrOfBlockWrite) +import Halfs.BufferBlock(mkDiskAddressBlock, getPartBufferBlock) +import Halfs.TheBlockMap(TheBlockMap(..)) +import System.RawDevice(RawDevice, devBufferWrite, devBufferRead, newDevice) +import qualified Binary (get) +import Halfs.Utils (FileType(..), bytesPerBlock, mRemoveFile ) +import Data.Integral ( INInt, inIntToInt, intToINLong, INLong + , fromIntegral', fromIntegral'') +import Data.Word (Word8) + +-- base +import System.IO(openFile, hClose, hFileSize, IOMode(ReadMode)) +import System.IO.Error (isFullError) +import System.Posix.IO (OpenMode(..), openFd, closeFd, defaultFileFlags) +import System.Posix.Files(unionFileModes, ownerReadMode, ownerWriteMode, groupReadMode) +import Control.Monad(when) +import Control.Monad.Error(throwError, catchError) +import Control.Concurrent( MVar, modifyMVar_, newEmptyMVar + , takeMVar, newMVar, putMVar + , forkIO, threadDelay) +import System.Random(randomR, getStdRandom) +import qualified Control.Exception as CE (finally) +--UNUSED:import qualified Control.Exception as CE (catch, throwIO) +import Control.Exception (finally) +import Data.Queue(queueToList) + +-- ------------------------------------------------------------ +-- * Interacting with host filesystem +-- ------------------------------------------------------------ + +-- |FIX: For now only works with file size < bufferSize. overwrites +-- existing file. +copyFromHost :: FSRoot + -> FilePath -- ^From (host) + -> FilePath -- ^To (fs) + -> IO ((FileHandle, INInt), FSRoot) +copyFromHost fsroot fromPath toPath = do + fileSize <- (do h <- openFile fromPath ReadMode + s <- hFileSize h + hClose h + return s) + + hFrom <- openFd fromPath ReadWrite Nothing defaultFileFlags + putStrLn $ "copyFromHost fileSize: " ++ (show fileSize) + buffer <- openBinMem $ fromIntegral'' fileSize + devBufferReadHost hFrom 0 buffer (fromIntegral'' fileSize) + closeFd hFrom + resetBin buffer + (toFsHandle, newRoot) + <- runFSWriteIO (openFileAtPathWrite Halfs.FileHandle.WriteMode toPath File False) fsroot + runFSWriteIO (do r <- fhWrite toFsHandle buffer 0 (fromIntegral'' fileSize) + fhCloseWrite toFsHandle + return r + ) newRoot + +-- |FIX: For now only works with file size < bufferSize. overwrites +-- existing file. +copyToHost :: FSRoot + -> FilePath -- ^From (fs) + -> FilePath -- ^To (host) + -> IO ((FileHandle, INInt), FSRoot) +copyToHost fsroot0 fromPath toPath = do + ((fromFsHandle, bytesToCopy), fsroot1) + <- runFSReadIO (do a <- openFileAtPathRead fromPath + b <- fhSize a + return (a,b) + ) fsroot0 (\e -> throwError e) + -- FIX: do this one block at a time? may run out of memory on big files. + putStrLn $ "copyTo bin mem: " ++ (show bytesToCopy) + -- Put up with fromIntegral'' here because this is just testing code. + buffer <- openBinMem (fromIntegral'' (bytesToCopy::INLong)) + readVal@((_, numRead), _fsroot2) <- + runFSReadIO (fhRead fromFsHandle buffer 0 (fromIntegral'' bytesToCopy)) + fsroot1 (\e -> throwError e) + resetBin buffer + hTo <- openFd toPath ReadWrite (Just (foldl1 unionFileModes [ ownerReadMode + , ownerWriteMode + , groupReadMode])) + defaultFileFlags + devBufferWriteHost hTo 0 buffer (inIntToInt numRead) + closeFd hTo + return readVal + +-- ------------------------------------------------------------ +-- * Testing +-- ------------------------------------------------------------ + +-- Problem: This function doesn't properly use the mvar for +-- threading. maybe I should make it impossible to get the mvar out +-- without blocking... + +copyAndCheckFile :: String -> FilePath -> FilePath -> Test +copyAndCheckFile message path targetFS = + TestLabel message $ TestCase $ do + let targetNative = "tests/fromFS" + mRemoveFile targetNative + withFSWrite dirFS (unsafeLiftIOWriteWithRoot (\fsroot -> do + catchError (do + (_, fsroot1) <- copyFromHost fsroot path targetFS + unmountFS fsroot1 + ) (unmountAndThrow fsroot))) -- clean unmount + withFSWrite dirFS (unsafeLiftIOWriteWithRoot (\fsroot -> do + catchError (do + (_, fsroot1) <- copyToHost fsroot targetFS targetNative + assertCmd ("diff " ++ path ++ " " ++ targetNative) + ("fs file copy failed: " ++ message) + (_, fsroot2) <- runFSWriteIO (unlink targetFS) fsroot1 + unmountFS fsroot2 + ) (unmountAndThrow fsroot))) -- clean unmount + +unmountAndThrow :: FSRoot -> IOError -> IO () +unmountAndThrow fsroot e = unmountFS fsroot >> throwError e + +dirFS :: FilePath +dirFS = "halfs-client1" + +unitTests :: Bool -> UnitTests +unitTests runFast = hunitToUnitTest (hunitTests runFast) + +assertEqualRW :: (Eq a, Show a, FSRW m) => String -> a -> a -> m () +assertEqualRW s a b = unsafeLiftIORW $ assertEqual s a b + +assertBoolRW :: (FSRW m) => String -> Bool -> m () +assertBoolRW s b = unsafeLiftIORW $ assertBool s b + +-- ------------------------------------------------------------ +-- * Multi-Threaded tests +-- ------------------------------------------------------------ + +-- Helpers: + +addResult :: MVar [Maybe String] -> (Maybe String) -> IO () +addResult mv b = + modifyMVar_ mv (\l -> return (b:l)) + +assertMString Nothing = assertBool "" True +assertMString (Just s) = assertBool s False + +waitAll :: [MVar a] -> IO () +waitAll l = mapM_ takeMVar l + +myForkIO :: IO () -> IO (MVar ()) +myForkIO io = do + mvar <- newEmptyMVar + forkIO (io `finally` putMVar mvar ()) + return mvar + +delayRandom :: Int -- ^Max number of seconds to delay + -> IO () +delayRandom s = do + randNum <- getStdRandom (\g -> randomR (0, secondToMicroSecond s) g) + threadDelay randNum + +secondToMicroSecond n = n * 1000000 + +-- TESTS +nSheeps :: Int -> FilePath -> FSWrite [Maybe String] +nSheeps n dirName = do + mkdir dirName + makeFiles n dirName "sheep" + return [Nothing] + +runTest :: MVar [Maybe String] -- ^Results + -> StateHandle + -> FSWrite [Maybe String] + -> IO (MVar ()) +runTest mv h f = + myForkIO $ do delayRandom 10 +-- results <- CE.catch (evalFSWriteIOMV f h) +-- (\e -> addResult mv (Just (show e)) +-- >> CE.throwIO e) + results <- evalFSWriteIOMV f h + mapM_ (addResult mv) results + +-- |Doesn't block on outer blocker. +runTest' :: MVar [Maybe String] -- ^Results + -> MVar FSRoot + -> FSWrite [Maybe String] + -> IO (MVar ()) +runTest' mv h f = + myForkIO $ do delayRandom 10 + results <- evalFSWriteIOMV f (StateHandle h Nothing) + mapM_ (addResult mv) results + +-- Controller: + +multiThreadTests :: Bool -> Test +multiThreadTests runFast = + TestLabel ("multi-thread tests") $ TestCase $ do + blocker <- newMVar () + -- should fork off a sync thread: + stateHandle@(StateHandle smallMv _) + <- mountFSMV Nothing dirFS (Just blocker) False 500 + resultsMV <- newMVar [] + + let rt = runTest resultsMV stateHandle + let rt' = runTest' resultsMV smallMv + let (sheepThreads, extraThreads, syncThreads) + = if runFast + then (50, 50, 1) + else (300, 100, 5) + -- many threads, grab the nSheep mvar many times and make only 4 dirs each. + waitOn2 <- mapM rt [nSheeps 2 ("/sheeps" ++ (show n)) | n <- [1..sheepThreads] ] + + -- 50 fsck threads + waitOn3 <- mapM rt (replicate extraThreads (fsckWrite >> return [Nothing])) + waitOnSync <- mapM rt' (replicate syncThreads (syncPeriodicallyWrite blocker False + >> return [Nothing])) + + waitOn1 <- mapM rt [ fsckWrite >> return [Nothing] + , nSheeps extraThreads "/sheeps" -- grabs mvar only once. + , fsckWrite >> return [Nothing] + ] + + waitAll $ concat [waitOn1, waitOn2, waitOn3] + + evalFSWriteIOMV unmountWriteFS stateHandle + -- the sync thread won't die 'till we unmount. + waitAll waitOnSync + + results <- takeMVar resultsMV + mapM assertMString results + putStrLn "unmounting" + return () + + +-- ------------------------------------------------------------ +-- * Block-level atomicity tests +-- ------------------------------------------------------------ + +toggle :: Word8 -> Word8 +toggle 0 = 1 +toggle 1 = 0 +toggle 3 = 4 +toggle 4 = 3 +toggle n = (n-1) + +writer :: RawDevice -> Word8 -> Int -> IO () +writer lowDev n timeLeft + | timeLeft <= 0 = return () + | otherwise = do + let word8s = replicate bytesPerBlock (n::Word8) + block <- getMemoryBlock + mapM (put block) word8s + resetBin block + devBufferWrite lowDev 1 block + writer lowDev (toggle n) (timeLeft - 1) + +reader lowDev timeLeft + | timeLeft <= 0 = return () + | otherwise = do + block <- getMemoryBlock + devBufferRead lowDev 1 block + resetBin block + ((h::Word8):words) <- sequence $ replicate bytesPerBlock (get block) + let allEq = and [h == w | w <- words] + assertBool ("Failure in test for block-level atomicity at timeLeft = " ++ + show timeLeft ++ ": " ++ + show (h:words)) + allEq + reader lowDev (timeLeft - 1) + +testBuffs :: Test +testBuffs = TestLabel ("block-level atomicity tests") $ TestCase $ do + lowDev <- newDevice Nothing "halfs-client1" 2 + -- highDev <- makeRawDevice "halfs-4EYES" + -- make block uniform before any read operations + writer lowDev 1 1 + let numIterations = 100 + waitWriters <- mapM myForkIO [ writer lowDev 1 numIterations + , writer lowDev 0 numIterations + , writer lowDev 3 numIterations + , writer lowDev 4 numIterations] + + threadDelay (secondToMicroSecond 2) + waitReaders <- mapM myForkIO (replicate 5 (reader lowDev numIterations)) + + waitAll $ concat [waitWriters, waitReaders] + +-- ------------------------------------------------------------ +-- * Collection of tests +-- ------------------------------------------------------------ + +slowTests = [testBuffs] + + +hunitTests :: Bool -- ^run fast? + -> [Test] +hunitTests runFast = (if runFast then [] else slowTests) ++ + [TestLabel "shell.hs: mkdir tmp" $ TestCase $ do + withNewFSWrite dirFS 5000 (mkdir "/tmp" >> unmountWriteFS) + ,(multiThreadTests runFast) + ,copyAndCheckFile "one-block file" "tests/from" "/tmp/toNative" + ,copyAndCheckFile "small file" "tests/smallFile" "/tmp/smallFile" + ,copyAndCheckFile "small file 2" "tests/smallFile" "/tmp/smallFile" + ,copyAndCheckFile "multi-block file" "tests/multiBlockFile" "/tmp/multiBlockFile" + ,copyAndCheckFile "level-2 file" "tests/70KFile" "/70KFile" + ,TestLabel "move" $ TestCase $ do + withFSWrite dirFS (unsafeLiftIOWriteWithRoot (\fsroot -> do + (_, fsroot) <- copyFromHost fsroot "tests/multiBlockFile" "/tmp/multiBlockFile" + unmountFS fsroot)) + + withFSWrite dirFS (do + let ls = readToWrite . getDirectoryContents + ls "/tmp" >>= assertEqualRW "tmp dir has files we created" + [".", "multiBlockFile"] + rename "/tmp/multiBlockFile" "/tmp/multiBlockFile2" + ls "/tmp" >>= assertEqualRW "ls after a move" + [".", "multiBlockFile2"] + unmountWriteFS + ) + ] diff --git a/LGPL b/LGPL new file mode 100644 --- /dev/null +++ b/LGPL @@ -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. + + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or +your school, if any, to sign a "copyright disclaimer" for the library, +if necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James + Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! + + diff --git a/ModuleTest.hs b/ModuleTest.hs new file mode 100644 --- /dev/null +++ b/ModuleTest.hs @@ -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 diff --git a/NewFS.hs b/NewFS.hs new file mode 100644 --- /dev/null +++ b/NewFS.hs @@ -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 () diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#!/usr/bin/runhaskell + +import Distribution.Simple + +main = defaultMainWithHooks defaultUserHooks diff --git a/System/RawDevice.hs b/System/RawDevice.hs new file mode 100644 --- /dev/null +++ b/System/RawDevice.hs @@ -0,0 +1,41 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.RawDevice +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : GHC +-- +-- Imports whatever RawDevice module we actually want. + +module System.RawDevice + ( RawDevice -- no constructor + , makeRawDevice + , blocksInDevice + , finalizeDevice + , newDevice + , devBufferRead + , devBufferWrite + , BufferBlockHandle + , newBufferBlockHandle + , checkBufferBlockHandleSize + , zeroBufferBlockHandle + , invalidateBufferBlockHandle + ) where + +import System.RawDevice.File + ( RawDevice -- no constructor + , makeRawDevice + , blocksInDevice + , finalizeDevice + , newDevice + , devBufferWrite + ) + +import System.RawDevice.File (devBufferRead) +import System.RawDevice.Base (BufferBlockHandle, newBufferBlockHandle, checkBufferBlockHandleSize, + zeroBufferBlockHandle, invalidateBufferBlockHandle) +-- import Control.Concurrent (readMVar) +-- import Control.Monad.Error(throwError) +-- import System.IO.Error (mkIOError, fullErrorType) diff --git a/System/RawDevice/Base.hs b/System/RawDevice/Base.hs new file mode 100644 --- /dev/null +++ b/System/RawDevice/Base.hs @@ -0,0 +1,60 @@ +{-# OPTIONS -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.RawDevice.Base +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : GHC +-- +module System.RawDevice.Base + ( DiskAddress + , BlockNumber + + , bytesPerBlock + , locationOfBlock + , BufferBlockHandle + , newBufferBlockHandle + , checkBufferBlockHandleSize + , zeroBufferBlockHandle + , invalidateBufferBlockHandle + ) where + +import Data.Integral +import Binary +import Control.Exception(assert) +import Data.Array.SysArray +import Foreign.Marshal.Alloc(mallocBytes) + +-- |Represents the number of the physical block on disk. +type DiskAddress = INInt + +-- |nth block within a file +type BlockNumber = INInt + +bytesPerBlock :: Int +bytesPerBlock = 4096 + +locationOfBlock :: DiskAddress -> Bin Int +locationOfBlock blockNum = BinPtr $ (inIntToInt blockNum) * bytesPerBlock + +newtype BufferBlockHandle s = BufferBlockHandle FixedSysHandle + deriving (BinaryHandle) + +newBufferBlockHandle :: IO (BufferBlockHandle s) +newBufferBlockHandle = do + ptr <- mallocBytes bytesPerBlock + let arr = mkSysArray (fromIntegral bytesPerBlock) ptr False + buf <- openFixedSysHandle arr + return $ BufferBlockHandle buf + +checkBufferBlockHandleSize :: BufferBlockHandle s -> IO () +checkBufferBlockHandleSize (BufferBlockHandle fixed) = do + size <- sizeFixedSysMem fixed + assert (size == bytesPerBlock) $ return () + +zeroBufferBlockHandle :: BufferBlockHandle s -> IO () +zeroBufferBlockHandle (BufferBlockHandle fixed) = zeroFixedSysHandle fixed + +invalidateBufferBlockHandle :: BufferBlockHandle s -> IO () +invalidateBufferBlockHandle (BufferBlockHandle fixed) = invalidateFixedSysMem fixed diff --git a/System/RawDevice/File.hs b/System/RawDevice/File.hs new file mode 100644 --- /dev/null +++ b/System/RawDevice/File.hs @@ -0,0 +1,146 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.RawDevice.File +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : GHC +-- +-- Explanation: A raw device which can be opened, read from, and +-- written to. In the basic Halfs filesystem, this is just a file. + +module System.RawDevice.File + ( RawDevice -- no constructor + , makeRawDevice + , blocksInDevice + , finalizeDevice + , newDevice + , devBufferRead + , devBufferWrite + ) where + +import Control.Exception(assert) +-- import Control.Concurrent(MVar, newMVar) +import System.IO(SeekMode(AbsoluteSeek), hFileSize) +import System.Directory(doesFileExist) +import System.Posix.IO(openFd, closeFd, defaultFileFlags, + OpenMode(..), fdWrite, fdSeek) +import Data.Integral ( INInt, intToINInt, fromIntegral'' ) +import System.RawDevice.Base ( DiskAddress, bytesPerBlock, locationOfBlock, BufferBlockHandle,checkBufferBlockHandleSize ) +import Binary(openBinIO, copyBytes, seekBin, resetBin) + +import System.Posix.Internals (fdGetMode, FDType(RegularFile)) +import System.Posix.Files(unionFileModes, ownerReadMode, ownerWriteMode, groupReadMode) +import System.Posix.Types (Fd(Fd)) +import qualified GHC.Handle +import GHC.IOBase + +-- import Network.BSD +-- import Network.Socket + +data RawDevice = RawDevice {rawDevPath :: FilePath + ,rawDevHandle :: Fd + } + +instance Ord RawDevice where + compare (RawDevice{rawDevPath=f1}) (RawDevice{rawDevPath=f2}) + = compare f1 f2 + +instance Eq RawDevice where + (==) (RawDevice{rawDevPath=f1}) (RawDevice{rawDevPath=f2}) + = f1 == f2 + +instance Show RawDevice where + show rd = "dev_" ++ rawDevPath rd + +------------------------------------------------------------ +fdToHandle2 :: Fd -> IO Handle +fdToHandle2 (Fd fd) = do + -- can't avoid fromIntegral'' because of the types returned by these functions + let fd' = fromIntegral'' fd + mode <- fdGetMode fd' + let fd_str = "" +-- h <- GHC.Handle.openFd fd' (Just RegularFile) False fd_str mode True{-bin +-- mode-} + h <- GHC.Handle.fdToHandle' fd' (Just RegularFile) False fd_str mode True{-bin mode-} + + return h + +-- |Smart constructor for a raw device. Opens this file as a device, +-- but does not initialize a filesystem on it or anything like that. +-- FIX: just for testing... +makeRawDevice :: Maybe RawDevice + -> FilePath -- or whatever + -> IO RawDevice +makeRawDevice _ path = do + fd <- openFd path ReadWrite Nothing defaultFileFlags + return $ + RawDevice { rawDevPath = path + , rawDevHandle = fd + } + +-- newDevice _ = newDevice' "/tmp/foo" Always returns Just FIX: just for testing... +newDevice :: Maybe RawDevice + -> FilePath -- ^Or whatever + -> INInt -- ^length in blocks + -> IO RawDevice +newDevice _ path fileLen = do +-- let path = "/tmp/blah/disk.data-1" -- ptg + existsP <- doesFileExist path + fd <- if existsP + then openFd path ReadWrite Nothing defaultFileFlags + else openFd path -- creates it: + ReadWrite + (Just (foldl1 unionFileModes [ ownerReadMode + , ownerWriteMode + , groupReadMode])) + defaultFileFlags + fdSeek fd AbsoluteSeek (fromIntegral'' $ fileLen * (intToINInt bytesPerBlock) - 1) + fdWrite fd "!" + return $ + RawDevice { rawDevPath = path + , rawDevHandle = fd + } + +blocksInDevice :: RawDevice + -> IO DiskAddress +blocksInDevice (RawDevice{rawDevHandle=fd}) = do +-- return (256 * (2 ^ 10) `div` (fromIntegral' bytesPerBlock)) -- FIX: Hard coded... + h <- fdToHandle2 fd + s <- hFileSize h + -- moderately safe due to div. + return $ fromIntegral'' $ s `div` (toInteger bytesPerBlock) + +-- |Closes the device, if necessary. +finalizeDevice :: RawDevice -> IO () +finalizeDevice (RawDevice{rawDevHandle=h }) = closeFd h + +------------------------------------------------------------ + +devBufferRead :: RawDevice -- ^which disk? + -> DiskAddress -- ^Block number + -> BufferBlockHandle s -- ^Buffer! + -> IO () +devBufferRead (RawDevice{rawDevHandle=h}) blockNum buffer = do + () <- assert (blockNum >= 0) $ return () + checkBufferBlockHandleSize buffer + fileHandle <- openBinIO h + seekBin fileHandle (locationOfBlock (abs blockNum)) + resetBin buffer + copyBytes fileHandle + buffer bytesPerBlock + +devBufferWrite :: RawDevice -- ^which disk? + -> DiskAddress -- ^Block number + -> BufferBlockHandle s -- ^Buffer! + -> IO () +devBufferWrite (RawDevice{rawDevHandle=h}) blockNum buffer = do + () <- assert (blockNum >= 0) $ return () + checkBufferBlockHandleSize buffer + -- buffSize <- sizeFixedBinMem buffer + -- TODO: ??? () <- assert (bytesPerBlock <= buffSize) $ return () + fileHandle <- openBinIO h + seekBin fileHandle (locationOfBlock (abs blockNum)) + resetBin buffer + copyBytes buffer + fileHandle bytesPerBlock diff --git a/binutils.c b/binutils.c new file mode 100644 --- /dev/null +++ b/binutils.c @@ -0,0 +1,32 @@ +#include +#include +#include +#include +#include "binutils.h" + +void binmemmove(void *dest,int dest_off,void *src,int src_off,size_t size) { + // printf("memmove: %d + %d <= %d + %d (%d)\n",dest,dest_off,src,src_off,size); + memmove(dest + dest_off,src + src_off,size); + // printf("memmove [done]\n"); +} + +size_t binwrite(int dest_fd,void *src,int src_off,size_t size) { + size_t ret; + // printf("binwrite: %d <= %d + %d (%d)\n",dest_fd,src,src_off,size); + ret = write(dest_fd,src + src_off,size); + // printf("binwrite [done %d]\n",ret); + return ret; +} + +size_t binread(void *dest,int dest_off,int src_fd,size_t size) { + size_t ret; + // printf("binread: %d + %d <= %d (%d)\n",dest,dest_off,src_fd,size); + ret = read(src_fd,dest + dest_off,size); + // printf("binread [done %d]\n",ret); + return ret; +} + +void binzero(void *dest,size_t size) { + bzero(dest,size); +} + diff --git a/binutils.h b/binutils.h new file mode 100644 --- /dev/null +++ b/binutils.h @@ -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); diff --git a/halfs.cabal b/halfs.cabal new file mode 100644 --- /dev/null +++ b/halfs.cabal @@ -0,0 +1,165 @@ +Name: halfs +Version: 0.2 +copyright: Copyright (c) 2005 Galois Connections, Inc. +author: Isaac Jones, Galois Inc. +maintainer: Iaaac Jones +homepage: http://haskell.org/halfs/ +category: System +synopsis: Haskell File System +description: Halfs is a filesystem implemented in the functional programming + language Haskell. Halfs can be mounted and used like any other Linux + filesystem, or used as a library. Halfs is a fork (and a port) of the + filesystem developed by Galois Connections. See also http://haskell.org/pipermail/haskell-cafe/2006-April/015361.html + . + You can get it from here: http://darcs.haskell.org/halfs +License: LGPL +license-file: LGPL + +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