hashed-storage 0.4.1 → 0.4.2
raw patch · 11 files changed
+203/−179 lines, 11 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Storage.Hashed.Darcs: darcsEncodeWhiteBS :: ByteString -> ByteString
+ Storage.Hashed.Darcs: darcsUpdateDirHashes :: Tree m -> Tree m
+ Storage.Hashed.Darcs: darcsUpdateHashes :: (Monad m, Functor m) => Tree m -> m (Tree m)
+ Storage.Hashed.Darcs: decodeDarcsHash :: ByteString -> Hash
+ Storage.Hashed.Plain: plainTreeIO :: TreeIO a -> Tree IO -> FilePath -> IO (a, Tree IO)
Files
- Bundled/SHA256.hs +1/−4
- Storage/Hashed/AnchoredPath.hs +19/−3
- Storage/Hashed/Darcs.hs +56/−54
- Storage/Hashed/Hash.hs +2/−6
- Storage/Hashed/Index.hs +54/−50
- Storage/Hashed/Monad.hs +2/−6
- Storage/Hashed/Packed.hs +30/−28
- Storage/Hashed/Plain.hs +15/−12
- Storage/Hashed/Tree.hs +6/−6
- Storage/Hashed/Utils.hs +16/−8
- hashed-storage.cabal +2/−2
Bundled/SHA256.hs view
@@ -16,13 +16,10 @@ import Foreign import Foreign.C.Types-import Numeric (showHex)-import Foreign.C.String ( withCString ) import Data.ByteString.Unsafe (unsafeUseAsCStringLen)-import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BSI -sha256 :: BS.ByteString -> BS.ByteString+sha256 :: BSI.ByteString -> BSI.ByteString sha256 p = unsafePerformIO $ do digest <- BSI.create 32 $ \digest -> unsafeUseAsCStringLen p $ \(ptr,n) ->
Storage/Hashed/AnchoredPath.hs view
@@ -16,6 +16,13 @@ -- newtype Name = Name BS.ByteString deriving (Eq, Show, Ord)++-- | This is a type of "sane" file paths. These are always canonic in the sense+-- that there are no stray slashes, no ".." components and similar. They are+-- usually used to refer to a location within a Tree, but a relative filesystem+-- path works just as well. These are either constructed from individual name+-- components (using "appendPath", "catPaths" and "makeName"), or converted+-- from a FilePath ("floatPath" -- but take care when doing that) or . newtype AnchoredPath = AnchoredPath [Name] deriving (Eq, Show, Ord) -- | Check whether a path is a prefix of another path.@@ -51,6 +58,8 @@ anchorPath dir p = dir </> BS.unpack (flatten p) {-# INLINE anchorPath #-} +-- | Unsafe. Only ever use on bytestrings that came from flatten on a+-- pre-existing AnchoredPath. floatBS :: BS.ByteString -> AnchoredPath floatBS = AnchoredPath . map Name . takeWhile (not . BS.null) . BS.split '/' @@ -60,11 +69,18 @@ [ n | (Name n) <- p ] makeName :: String -> Name-makeName = Name . BS.pack+makeName ".." = error ".. is not a valid AnchoredPath component name"+makeName n | '/' `elem` n = error "/ may not occur in a valid AnchoredPath component name"+ | otherwise = Name $ BS.pack n -- | Take a relative FilePath and turn it into an AnchoredPath. The operation--- is unsafe and if you break it, you keep both pieces. More useful for--- exploratory purposes (ghci) than for serious programming.+-- is (relatively) unsafe. Basically, by using floatPath, you are testifying+-- that the argument is a path relative to some common root -- i.e. the root of+-- the associated "Tree" object. Also, there are certain invariants about+-- AnchoredPath that this function tries hard to preserve, but probably cannot+-- guarantee (i.e. this is a best-effort thing). You should sanitize any+-- FilePaths before you declare them "good" by converting into AnchoredPath+-- (using this function). floatPath :: FilePath -> AnchoredPath floatPath = AnchoredPath . map (Name . BS.pack) . splitDirectories . normalise . dropTrailingPathSeparator
Storage/Hashed/Darcs.hs view
@@ -7,16 +7,18 @@ import Prelude hiding ( lookup ) import System.FilePath ( (</>) ) -import System.Directory( createDirectoryIfMissing, doesFileExist, doesDirectoryExist )+import System.Directory( doesFileExist ) import Codec.Compression.GZip( decompress, compress ) import Control.Applicative( (<$>) ) -import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy.Char8 as BL8+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as BS import Data.List( sortBy ) import Data.Char( chr, ord, isSpace )-import Data.Maybe( fromJust, isNothing )+import Data.Maybe( fromJust ) import qualified Data.Set as S import Control.Monad.State.Strict @@ -27,7 +29,6 @@ import Storage.Hashed.Hash import Storage.Hashed.Packed import Storage.Hashed.Monad-import Storage.Hashed.Plain --------------------------------------------------------------------- -- Utilities for coping with the darcs directory format.@@ -60,60 +61,62 @@ darcsEncodeWhite (c:cs) = c : darcsEncodeWhite cs darcsEncodeWhite [] = [] -darcsEncodeWhiteBS = BS.pack . darcsEncodeWhite . BS.unpack+darcsEncodeWhiteBS :: BS8.ByteString -> BS8.ByteString+darcsEncodeWhiteBS = BS8.pack . darcsEncodeWhite . BS8.unpack -decodeDarcsHash bs = case BS.split '-' bs of- [s, h] | BS.length s == 10 -> decodeBase16 h+decodeDarcsHash :: BS8.ByteString -> Hash+decodeDarcsHash bs = case BS8.split '-' bs of+ [s, h] | BS8.length s == 10 -> decodeBase16 h _ -> decodeBase16 bs -decodeDarcsSize :: BS.ByteString -> Maybe Int-decodeDarcsSize bs = case BS.split '-' bs of- [s, _] | BS.length s == 10 ->- case reads (BS.unpack s) of+decodeDarcsSize :: BS8.ByteString -> Maybe Int+decodeDarcsSize bs = case BS8.split '-' bs of+ [s, _] | BS8.length s == 10 ->+ case reads (BS8.unpack s) of [(x, _)] -> Just x _ -> Nothing _ -> Nothing darcsLocation :: FilePath -> (Maybe Int, Hash) -> FileSegment-darcsLocation dir (s,h) = (dir </> (prefix s ++ BS.unpack (encodeBase16 h)), Nothing)+darcsLocation dir (s,h) = (dir </> (prefix s ++ BS8.unpack (encodeBase16 h)), Nothing) where prefix Nothing = ""- prefix (Just s) = formatSize s ++ "-"- formatSize s = let n = show s in replicate (10 - length n) '0' ++ n+ prefix (Just s') = formatSize s' ++ "-"+ formatSize s' = let n = show s' in replicate (10 - length n) '0' ++ n ---------------------------------------------- -- Darcs directory format. -- -darcsFormatDir :: Tree m -> Maybe BL.ByteString-darcsFormatDir t = BL.fromChunks <$> concat <$>+darcsFormatDir :: Tree m -> Maybe BL8.ByteString+darcsFormatDir t = BL8.fromChunks <$> concat <$> mapM string (sortBy cmp $ listImmediate t) where cmp (Name a, _) (Name b, _) = compare a b string (Name name, item) = do header <- case item of- File _ -> Just $ BS.pack "file:\n"- SubTree _ -> Just $ BS.pack "directory:\n"+ File _ -> Just $ BS8.pack "file:\n"+ SubTree _ -> Just $ BS8.pack "directory:\n" Stub _ _ -> Nothing hash <- case itemHash item of NoHash -> Nothing x -> Just $ encodeBase16 x return $ [ header , darcsEncodeWhiteBS name- , BS.singleton '\n'- , hash, BS.singleton '\n' ]+ , BS8.singleton '\n'+ , hash, BS8.singleton '\n' ] -darcsParseDir :: BL.ByteString -> [(ItemType, Name, Maybe Int, Hash)]-darcsParseDir content = parse (BL.split '\n' content)+darcsParseDir :: BL8.ByteString -> [(ItemType, Name, Maybe Int, Hash)]+darcsParseDir content = parse (BL8.split '\n' content) where parse (t:n:h':r) = (header t,- Name $ BS.pack $ darcsDecodeWhite (BL.unpack n),+ Name $ BS8.pack $ darcsDecodeWhite (BL8.unpack n), decodeDarcsSize hash, decodeDarcsHash hash) : parse r- where hash = BS.concat $ BL.toChunks h'+ where hash = BS8.concat $ BL8.toChunks h' parse _ = [] header x- | x == BL.pack "file:" = BlobType- | x == BL.pack "directory:" = TreeType- | otherwise = error $ "Error parsing darcs hashed dir: " ++ BL.unpack x+ | x == BL8.pack "file:" = BlobType+ | x == BL8.pack "directory:" = TreeType+ | otherwise = error $ "Error parsing darcs hashed dir: " ++ BL8.unpack x ---------------------------------------- -- Utilities.@@ -127,10 +130,12 @@ -- The following two are mostly for experimental use in Packed. -darcsUpdateDirHashes tree = updateSubtrees update tree+darcsUpdateDirHashes :: Tree m -> Tree m+darcsUpdateDirHashes = updateSubtrees update where update t = t { treeHash = darcsTreeHash t } -darcsUpdateHashes tree = updateTree update tree+darcsUpdateHashes :: (Monad m, Functor m) => Tree m -> m (Tree m)+darcsUpdateHashes = updateTree update where update (SubTree t) = return . SubTree $ t { treeHash = darcsTreeHash t } update (File blob@(Blob con _)) = do hash <- sha256 <$> readBlob blob@@ -148,7 +153,7 @@ unless exist $ fail $ "error opening " ++ fst (darcsLocation dir h) compressed <- readSegment $ darcsLocation dir h let content = decompress compressed- return $ if BL.null compressed+ return $ if BL8.null compressed then [] else darcsParseDir content @@ -156,19 +161,19 @@ -- \"pristine.hashed\". You need to provide the root hash you are interested in -- (found in _darcs/hashed_inventory). readDarcsHashed :: FilePath -> (Maybe Int, Hash) -> IO (Tree IO)-readDarcsHashed dir (_, NoHash) = fail "Cannot readDarcsHashed NoHash"+readDarcsHashed _ (_, NoHash) = fail "Cannot readDarcsHashed NoHash" readDarcsHashed dir root@(_, hash) = do- items <- readDarcsHashedDir dir root+ items' <- readDarcsHashedDir dir root subs <- sequence [ case tp of BlobType -> return (d, File $- Blob (readBlob (s, h)) h)+ Blob (readBlob' (s, h)) h) TreeType -> do let t = readDarcsHashed dir (s, h) return (d, Stub t h)- | (tp, d, s, h) <- items ]+ | (tp, d, s, h) <- items' ] return $ makeTreeWithHash subs hash- where readBlob = fmap decompress . readSegment . darcsLocation dir+ where readBlob' = fmap decompress . readSegment . darcsLocation dir ---------------------------------------------------- -- Writing darcs-style hashed trees.@@ -176,14 +181,14 @@ -- | Write a Tree into a darcs-style hashed directory. writeDarcsHashed :: Tree IO -> FilePath -> IO Hash-writeDarcsHashed tree dir =- do t <- darcsUpdateDirHashes <$> expand tree+writeDarcsHashed tree' dir =+ do t <- darcsUpdateDirHashes <$> expand tree' sequence_ [ dump =<< readBlob b | (_, File b) <- list t ] let dirs = darcsFormatDir t : [ darcsFormatDir d | (_, SubTree d) <- list t ] os' <- mapM dump $ map fromJust dirs return $ darcsTreeHash t where dump bits =- do let name = dir </> BS.unpack (encodeBase16 $ sha256 bits)+ do let name = dir </> BS8.unpack (encodeBase16 $ sha256 bits) exist <- doesFileExist name unless exist $ BL.writeFile name (compress bits) @@ -191,7 +196,7 @@ -- it is kept untouched and is assumed to have the right content. XXX Corrupt -- files should be probably renamed out of the way automatically or something -- (probably when they are being read though).-fsCreateHashedFile :: FilePath -> BL.ByteString -> TreeIO ()+fsCreateHashedFile :: FilePath -> BL8.ByteString -> TreeIO () fsCreateHashedFile fn content = liftIO $ do exist <- doesFileExist fn@@ -212,7 +217,6 @@ where syncHashed ch = do modify $ \st -> st { tree = darcsUpdateDirHashes $ tree st } forM_ (reverse $ S.toList ch) $ \c -> do- let path = anchorPath "" c current <- gets tree case find current c of Just (File b) -> updateFile c b@@ -220,18 +224,16 @@ _ -> return () -- the file could have disappeared in the meantime updateFile path b@(Blob _ !h) = do content <- liftIO $ readBlob b- let h' = case h of- NoHash -> sha256 content- _ -> h- fn = dir </> BS.unpack (encodeBase16 h)- nblob = File $ Blob (decompress `fmap` BL.readFile fn) h+ let fn = dir </> BS8.unpack (encodeBase16 h)+ nblob = File $ Blob (decompress <$> rblob) h+ rblob = BL.fromChunks <$> return <$> BS.readFile fn newcontent = compress content fsCreateHashedFile fn newcontent replaceItem path (Just nblob) updateSub path s = do let !hash = darcsTreeHash s Just dirdata = darcsFormatDir s- fn = dir </> BS.unpack (encodeBase16 hash)+ fn = dir </> BS8.unpack (encodeBase16 hash) ns = SubTree (s { treeHash = hash }) fsCreateHashedFile fn (compress dirdata) replaceItem path (Just ns)@@ -246,18 +248,18 @@ -- tree root hash as a starting point. readPackedDarcsPristine :: OS -> Hash -> IO (Tree IO) readPackedDarcsPristine os root =- do items <- darcsParseDir <$> grab root+ do items' <- darcsParseDir <$> grab root subs <- sequence [ case tp of BlobType -> return (d, File $ file h) TreeType -> let t = readPackedDarcsPristine os h in return (d, Stub t h)- | (tp, d, _, h) <- items ]+ | (tp, d, _, h) <- items' ] return $ makeTreeWithHash subs root where file h = Blob (grab h) h grab hash = do maybeseg <- lookup os hash case maybeseg of- Nothing -> fail $ "hash " ++ BS.unpack (encodeBase16 hash) ++ " not available"+ Nothing -> fail $ "hash " ++ BS8.unpack (encodeBase16 hash) ++ " not available" Just seg -> readSegment seg -- | Write a Tree into an object storage, using the darcs-style directory@@ -265,16 +267,16 @@ -- and the root hash of the stored Tree. NB. The function expects that the Tree -- comes equipped with darcs-style hashes already! writePackedDarcsPristine :: Tree IO -> OS -> IO (OS, Hash)-writePackedDarcsPristine tree os =- do t <- darcsUpdateDirHashes <$> expand tree+writePackedDarcsPristine tree' os =+ do t <- darcsUpdateDirHashes <$> expand tree' files <- sequence [ readBlob b | (_, File b) <- list t ] let dirs = darcsFormatDir t : [ darcsFormatDir d | (_, SubTree d) <- list t ] os' <- hatch os $ files ++ (map fromJust dirs) return (os', darcsTreeHash t) storePackedDarcsPristine :: Tree IO -> OS -> IO (OS, Hash)-storePackedDarcsPristine tree os =- do (os', root) <- writePackedDarcsPristine tree os+storePackedDarcsPristine tree' os =+ do (os', root) <- writePackedDarcsPristine tree' os return $ (os' { roots = root : roots os' -- FIXME we probably don't want to override the references -- thing completely here...
Storage/Hashed/Hash.hs view
@@ -2,7 +2,6 @@ , encodeBase16, decodeBase16, sha256, rawHash , match ) where -import Data.Int( Int64 ) import qualified Bundled.SHA256 as SHA import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BSI@@ -34,12 +33,9 @@ Nothing -> Nothing encodeBase64u :: Hash -> BS.ByteString-encodeBase64u (SHA256 bs) = BS.pack $ map BSI.c2w $ B64U.encode $ BS.unpack bs-encodeBase64u (SHA1 bs) = BS.pack $ map BSI.c2w $ B64U.encode $ BS.unpack bs+encodeBase64u (SHA256 bs) = base64u bs+encodeBase64u (SHA1 bs) = base64u bs encodeBase64u NoHash = BS.empty--formatSize :: (Num a) => a -> BS.ByteString-formatSize s = BS.pack $ replicate (10 - length n) (BSI.c2w '0') ++ n where n = map BSI.c2w $ show s -- | Produce a base16 (ascii-hex) encoded string from a hash. This can be -- turned back into a Hash (see "decodeBase16". This is a loss-less process.
Storage/Hashed/Index.hs view
@@ -46,25 +46,29 @@ import Storage.Hashed.AnchoredPath import Data.Int( Int64, Int32 ) -import qualified Data.Set as S-import qualified Data.Map as M- import Bundled.Posix( getFileStatusBS, modificationTime,- getFileStatus, fileSize, fileExists, EpochTime )-import System.IO.MMap( mmapFileForeignPtr, Mode(..) )-import System.IO( openBinaryFile, hGetChar, hClose, IOMode(..) )-import System.Directory( removeFile, doesFileExist, renameFile )-import System.FilePath( (<.>) )+ getFileStatus, fileSize, fileExists )+import System.IO.MMap( mmapFileForeignPtr, mmapFileByteString, Mode(..) )+import System.IO( )+import System.Directory( doesFileExist )+#if mingw32_HOST_OS+import System.Directory( renameFile )+#else+import System.Directory( removeFile )+#endif++import System.FilePath( ) import Control.Monad( when )+import Control.Exception.Extensible import Control.Applicative( (<$>) ) import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Char8 as BSC import Data.ByteString.Unsafe( unsafeHead, unsafeDrop ) import Data.ByteString.Internal( toForeignPtr, fromForeignPtr, memcpy , nullForeignPtr, c2w ) -import Data.IORef( newIORef, readIORef, modifyIORef, IORef )+import Data.IORef( ) import Data.Maybe( fromJust, isJust ) import Data.Bits( Bits ) @@ -100,7 +104,7 @@ size_dsclen = 4 -- this many bytes store the length of the path size_hash = 32 -- hash representation -off_size, off_aux, off_hash, off_dsc :: Int+off_size, off_aux, off_hash, off_dsc, off_dsclen :: Int off_size = 0 off_aux = off_size + size_size off_dsclen = off_aux + size_aux@@ -108,8 +112,8 @@ off_dsc = off_hash + size_hash itemAllocSize :: AnchoredPath -> Int-itemAllocSize path =- align 4 $ size_hash + size_size + size_aux + size_dsclen + 2 + BS.length (flatten path)+itemAllocSize apath =+ align 4 $ size_hash + size_size + size_aux + size_dsclen + 2 + BS.length (flatten apath) itemSize, itemNext :: Item -> Int itemSize i = size_size + size_aux + size_dsclen + (BS.length $ iHashAndDescriptor i)@@ -140,9 +144,9 @@ -- written out, and a corresponding Item is given back. The remaining bits of -- the item can be filled out using 'update'. createItem :: ItemType -> AnchoredPath -> ForeignPtr () -> Int -> IO Item-createItem typ path fp off =- do let dsc = BS.concat [ BS8.singleton $ (typ == TreeType) ? ('D', 'F')- , flatten path+createItem typ apath fp off =+ do let dsc = BS.concat [ BSC.singleton $ (typ == TreeType) ? ('D', 'F')+ , flatten apath , BS.singleton 0 ] (dsc_fp, dsc_start, dsc_len) = toForeignPtr dsc withForeignPtr fp $ \p ->@@ -183,12 +187,14 @@ -- when updating directory entries). updateItem :: Item -> Int64 -> Hash -> IO () updateItem item _ NoHash =- fail $ "Index.update NoHash: " ++ BS8.unpack (iPath item)+ fail $ "Index.update NoHash: " ++ BSC.unpack (iPath item) updateItem item size hash = do xlatePoke64 (iSize item) size unsafePokeBS (iHash item) (rawHash hash) +updateAux :: Item -> Int64 -> IO () updateAux item aux = xlatePoke64 (iAux item) $ aux+updateTime :: forall a.(Enum a) => Item -> a -> IO () updateTime item mtime = updateAux item (fromIntegral $ fromEnum mtime) iHash' :: Item -> Hash@@ -243,7 +249,7 @@ myname = name item (dirlength state) substate = state { start = start state + itemNext item , path = path state `appendPath` myname- , dirlength = if myname == Name (BS8.singleton '.')+ , dirlength = if myname == Name (BSC.singleton '.') then dirlength state else dirlength state + namelength } @@ -255,12 +261,11 @@ rest <- subs $ next result case treeitem result of Nothing -> return $! rest- Just ti -> return $! (name (resitem result) $ dirlength substate, result) : rest+ Just _ -> return $! (name (resitem result) $ dirlength substate, result) : rest subs coff | coff == following = return [] | otherwise = fail $ "Offset mismatch at " ++ show coff ++ " (ends at " ++ show following ++ ")" - oldsize <- xlatePeek64 $ iSize item inferiors <- if want then subs $ start substate else return [] @@ -283,7 +288,7 @@ size <- xlatePeek64 $ iSize item let mtime' = modificationTime st size' = fromIntegral $ fileSize st- readblob = readSegment (BS8.unpack $ iPath item, Nothing)+ readblob = readSegment (BSC.unpack $ iPath item, Nothing) exists = fileExists st we_changed = mtime /= mtime' || size /= size' hash = iHash' item@@ -320,21 +325,21 @@ -- The resulting tree will be fully expanded. readIndex :: FilePath -> (Tree IO -> Hash) -> IO Index readIndex indexpath ht = do- (mmap, mmap_size) <- mmapIndex indexpath 0+ (mmap_ptr, mmap_size) <- mmapIndex indexpath 0 return $ if mmap_size == 0 then EmptyIndex- else Index { mmap = mmap+ else Index { mmap = mmap_ptr , hashtree = ht , predicate = \_ _ -> True } formatIndex :: ForeignPtr () -> Tree IO -> Tree IO -> IO ()-formatIndex mmap old reference =+formatIndex mmap_ptr old reference = do create (SubTree reference) (AnchoredPath []) size_magic- unsafePokeBS magic (BS8.pack "HSI4")- where magic = fromForeignPtr (castForeignPtr mmap) 0 4- create (File _) path off =- do i <- createItem BlobType path mmap off- let flatpath = BS8.unpack $ flatten path- case find old path of+ unsafePokeBS magic (BSC.pack "HSI4")+ where magic = fromForeignPtr (castForeignPtr mmap_ptr) 0 4+ create (File _) path' off =+ do i <- createItem BlobType path' mmap_ptr off+ let flatpath = BSC.unpack $ flatten path'+ case find old path' of Nothing -> return () -- TODO calling getFileStatus here is both slightly -- inefficient and slightly race-prone@@ -345,29 +350,29 @@ updateItem i (fromIntegral size) hash updateTime i mtime return $ off + itemNext i- create (SubTree s) path off =- do i <- createItem TreeType path mmap off- case find old path of+ create (SubTree s) path' off =+ do i <- createItem TreeType path' mmap_ptr off+ case find old path' of Nothing -> return () Just ti | itemHash ti == NoHash -> return () | otherwise -> updateItem i 0 $ itemHash ti let subs [] = return $ off + itemNext i subs ((name,x):xs) = do- let path' = path `appendPath` name+ let path'' = path' `appendPath` name noff <- subs xs- create x path' noff+ create x path'' noff lastOff <- subs (listImmediate s) xlatePoke64 (iAux i) (fromIntegral lastOff) return lastOff- create (Stub _ _) path _ =- fail $ "Cannot create index from stubbed Tree at " ++ show path+ create (Stub _ _) path' _ =+ fail $ "Cannot create index from stubbed Tree at " ++ show path' -- | Will add and remove files in index to make it match the 'Tree' object -- given (it is an error for the 'Tree' to contain a file or directory that -- does not exist in a plain form in current working directory). updateIndexFrom :: FilePath -> (Tree IO -> Hash) -> Tree IO -> IO Index-updateIndexFrom indexpath hashtree ref =- do old_idx <- updateIndex =<< readIndex indexpath hashtree+updateIndexFrom indexpath hashtree' ref =+ do old_idx <- updateIndex =<< readIndex indexpath hashtree' reference <- expand ref let len_root = itemAllocSize anchoredRoot len = len_root + sum [ itemAllocSize p | (p, _) <- list reference ]@@ -377,21 +382,20 @@ #else when exist $ removeFile indexpath -- to avoid clobbering oldidx #endif- (mmap, _) <- mmapIndex indexpath len- formatIndex mmap old_idx reference- readIndex indexpath hashtree+ (mmap_ptr, _) <- mmapIndex indexpath len+ formatIndex mmap_ptr old_idx reference+ readIndex indexpath hashtree' -- | Check that a given file is an index file with a format we can handle. You -- should remove and re-create the index whenever this is not true. indexFormatValid :: FilePath -> IO Bool-indexFormatValid path = do- fd <- openBinaryFile path ReadMode- magic <- sequence [ hGetChar fd | _ <- [1..size_magic] :: [Int] ]- hClose fd- return $ case magic of- "HSI4" -> True- _ -> False+indexFormatValid path' =+ do magic <- mmapFileByteString path' (Just (0, size_magic))+ return $ case BSC.unpack magic of+ "HSI4" -> True+ _ -> False+ `catch` \(_::SomeException) -> return False instance FilterTree IndexM IO where filter _ EmptyIndex = EmptyIndex- filter pred index = index { predicate = \a b -> predicate index a b && pred a b }+ filter p index = index { predicate = \a b -> predicate index a b && p a b }
Storage/Hashed/Monad.hs view
@@ -24,18 +24,14 @@ import Storage.Hashed.Tree import Storage.Hashed.Hash -import Control.Monad.Error( catchError, throwError, MonadError )+import Control.Monad.Error( catchError, MonadError ) -import System.Directory( createDirectoryIfMissing, doesFileExist )-import System.FilePath( (</>) ) import Data.List( inits ) import Data.Int( Int64 ) import Data.Maybe( isNothing, isJust ) -import Codec.Compression.GZip( decompress, compress )- import qualified Data.ByteString.Lazy.Char8 as BL-import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Char8( ) import Control.Monad.RWS.Strict import qualified Data.Set as S
Storage/Hashed/Packed.hs view
@@ -17,8 +17,8 @@ ) where import Prelude hiding ( lookup, read )-import Storage.Hashed.AnchoredPath-import Storage.Hashed.Tree hiding ( lookup )+import Storage.Hashed.AnchoredPath( )+import Storage.Hashed.Tree ( ) import Storage.Hashed.Utils import Storage.Hashed.Hash @@ -32,7 +32,7 @@ import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.ByteString.Char8 as BS-import Data.Maybe( listToMaybe, catMaybes, fromJust, isNothing )+import Data.Maybe( listToMaybe, catMaybes, isNothing ) import Data.Binary( encode, decode ) import qualified Data.Set as S@@ -45,9 +45,7 @@ -- and an immutable \"pack\" format. data Format = Loose | Compact | Pack deriving (Show, Eq) -is_loose os = format (hatchery os) == Loose-is_compact os = format (hatchery os) == Compact-+loose_dirs :: [[Char]] loose_dirs = let chars = ['0'..'9'] ++ ['a'..'f'] in [ [a,b] | a <- chars, b <- chars ] @@ -84,7 +82,7 @@ -- | Reduce number of packs in the object storage. This may both recombine -- packs to eliminate dead objects and join some packs to form bigger packs. repack :: OS -> IO OS-repack os = error "repack undefined"+repack _ = error "repack undefined" -- | Add new objects to the object storage (i.e. put them into hatchery). It is -- safe to call this even on objects that are already present in the storage:@@ -93,13 +91,14 @@ hatch os blobs = do processed <- mapM sieve blobs write [ (h, b) | (True, h, b) <- processed ]- where write bits- | is_loose os =- do forM bits $ \(hash, blob) -> do- BL.writeFile (loosePath os hash) blob- return os- | is_compact os = error "hatch/compact undefined"- | otherwise = fail "Hatchery must be either Loose or Compact."+ where write bits =+ case format (hatchery os) of+ Loose ->+ do forM bits $ \(hash, blob) -> do+ BL.writeFile (loosePath os hash) blob+ return os+ Compact -> error "hatch/compact undefined"+ _ -> fail "Hatchery must be either Loose or Compact." sieve blob = do let hash = sha256 blob absent <- isNothing <$> lookup os hash return (absent, hash, blob)@@ -110,10 +109,11 @@ block <- createPack os (M.toList objects) cleanup return $ os { mature = block:mature os }- where cleanup | is_loose os =- forM_ loose_dirs $ nuke . ((rootdir os </> "hatchery") </>)- | is_compact os =- removeFile (rootdir os </> "hatchery") >> return ()+ where cleanup =+ case format (hatchery os) of+ Loose -> forM_ loose_dirs $ nuke . ((rootdir os </> "hatchery") </>)+ Compact -> removeFile (rootdir os </> "hatchery") >> return ()+ _ -> fail "Hatchery must be either Loose or Compact." nuke dir = mapM (removeFile . (dir </>)) =<< (Prelude.filter (`notElem` [".", ".."]) `fmap` getDirectoryContents dir)@@ -152,14 +152,16 @@ load path = do hatch_stat <- getFileStatus $ path </> "hatchery" let is_os = fileExists hatch_stat- is_loose = isDirectory hatch_stat+ is_dir = isDirectory hatch_stat unless is_os $ fail $ path ++ " is not an object storage!" let _hatchery = Block { blockLookup = look os- , format = if is_loose then Loose else Compact }+ , format = if is_dir then Loose else Compact+ , size = undefined } os = OS { hatchery = _hatchery , rootdir = path , mature = packs- , roots = _roots }+ , roots = _roots+ , references = undefined } look | format _hatchery == Loose = looseLookup | otherwise = undefined packs = [] -- FIXME read packs@@ -170,25 +172,25 @@ readPack file = do bits <- readSegment (file, Nothing) let count = decode (BL.take 8 $ bits) _lookup NoHash _ _ = return Nothing- _lookup hash@(SHA256 rawhash) first last = do- let middle = first + ((last - first) `div` 2)+ _lookup hash@(SHA256 rawhash) first final = do+ let middle = first + ((final - first) `div` 2) res <- case ( compare rawhash (hashof first) , compare rawhash (hashof middle)- , compare rawhash (hashof last) ) of+ , compare rawhash (hashof final) ) of (LT, _, _) -> return Nothing ( _, _, GT) -> return Nothing (EQ, _, _) -> return $ Just (segof first)- ( _, _, EQ) -> return $ Just (segof last)+ ( _, _, EQ) -> return $ Just (segof final) (GT, EQ, LT) -> return $ Just (segof middle)- (GT, GT, LT) | middle /= last -> _lookup hash middle last+ (GT, GT, LT) | middle /= final -> _lookup hash middle final (GT, LT, LT) | first /= middle -> _lookup hash first middle ( _, _, _) -> return Nothing return res headerof i = BL.take 51 $ BL.drop (8 + i * 51) bits hashof i = BS.concat $ BL.toChunks $ BL.take 32 $ headerof i- segof i = (file, Just (count * 51 + 8 + from, size))+ segof i = (file, Just (count * 51 + 8 + from, sz)) where from = decode (BL.take 8 $ BL.drop 33 $ headerof i)- size = decode (BL.take 8 $ BL.drop 42 $ headerof i)+ sz = decode (BL.take 8 $ BL.drop 42 $ headerof i) return $ Block { size = BL.length bits , format = Pack , blockLookup = \h -> _lookup h 0 (count - 1) }
Storage/Hashed/Plain.hs view
@@ -9,21 +9,24 @@ -- mutates files. Unlink + recreate is fine though (in other words, the -- 'writePlainTree' and 'plainTreeIO' implemented in this module are safe in -- this respect).-module Storage.Hashed.Plain( readPlainTree, writePlainTree ) where+module Storage.Hashed.Plain( readPlainTree, writePlainTree,+ plainTreeIO -- (obsolete? if so remove implementation!)+ ) where -import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as BL import System.FilePath( (</>) )-import System.Directory( getDirectoryContents, doesFileExist- , doesDirectoryExist, createDirectoryIfMissing )+import System.Directory( getDirectoryContents+ , createDirectoryIfMissing ) import Bundled.Posix( getFileStatus, isDirectory, FileStatus )-import Control.Monad( forM_, unless, when )+import Control.Monad( forM_ ) import Storage.Hashed.AnchoredPath import Storage.Hashed.Utils import Storage.Hashed.Hash( Hash( NoHash) )-import Storage.Hashed.Tree( Tree( listImmediate ), TreeItem(..), ItemType(..)- , Blob(..), emptyTree, makeTree, makeTreeWithHash+import Storage.Hashed.Tree( Tree(), TreeItem(..)+ , Blob(..), makeTree , list, readBlob, find, modifyTree ) import Storage.Hashed.Monad( TreeIO, runTreeMonad, initialState, tree ) import qualified Data.Set as S@@ -35,21 +38,21 @@ items <- getDirectoryContents "." sequence [ do st <- getFileStatus s return (s, st)- | s <- items, not $ s `elem` [ ".", ".." ] ]+ | s <- items, s `notElem` [ ".", ".." ] ] readPlainTree :: FilePath -> IO (Tree IO) readPlainTree dir = do items <- readPlainDir dir let subs = [- let name = Name (BS.pack name')+ let name = Name (BS8.pack name') in if isDirectory status then (name, Stub (readPlainTree (dir </> name')) NoHash) else (name, File $- Blob (readBlob name) NoHash)+ Blob (readBlob' name) NoHash) | (name', status) <- items ] return $ makeTree subs- where readBlob (Name name) = readSegment (dir </> BS.unpack name, Nothing)+ where readBlob' (Name name) = readSegment (dir </> BS8.unpack name, Nothing) -- | Write out /full/ tree to a plain directory structure. If you instead want -- to make incremental updates, refer to "Storage.Hashed.Monad".
Storage/Hashed/Tree.hs view
@@ -22,7 +22,7 @@ , readBlob -- * Filtering trees.- , FilterTree(..), filter, restrict+ , FilterTree(..), restrict -- * Manipulating trees. , modifyTree, updateTree, updateSubtrees, overlay ) where@@ -367,16 +367,16 @@ , treeHash = NoHash } where update (k, SubTree s) = (k, SubTree $ updateSubtrees fun s) update (k, File f) = (k, File f)- update (k, Stub _ _) = error "Stubs not supported in updateTreePostorder"+ update (_, Stub _ _) = error "Stubs not supported in updateTreePostorder" -- | Does /not/ expand the tree. updateTree :: (Functor m, Monad m) => (TreeItem m -> m (TreeItem m)) -> Tree m -> m (Tree m) updateTree fun t = do immediate <- mapM update $ listImmediate t- SubTree t <- fun . SubTree $ t { items = M.fromList immediate- , listImmediate = immediate- , treeHash = NoHash }- return t+ SubTree t' <- fun . SubTree $ t { items = M.fromList immediate+ , listImmediate = immediate+ , treeHash = NoHash }+ return t' where update (k, SubTree tree) = (\new -> (k, SubTree new)) <$> updateTree fun tree update (k, item) = (\new -> (k, new)) <$> fun item
Storage/Hashed/Utils.hs view
@@ -20,14 +20,15 @@ import Foreign.ForeignPtr( withForeignPtr ) import Foreign.Ptr( plusPtr ) import Data.ByteString.Internal( toForeignPtr, memcpy )-+import System.IO (withFile, IOMode(ReadMode), hSeek, SeekMode(AbsoluteSeek)) import Data.Bits( Bits ) #ifdef BIGENDIAN import Data.Bits( (.&.), (.|.), shift, shiftL, shiftR ) #endif import qualified Data.ByteString.Lazy.Char8 as BL-import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString as BS import qualified Data.Set as S import qualified Data.Map as M@@ -39,13 +40,20 @@ -- | Read in a FileSegment into a Lazy ByteString. Implemented using mmap. readSegment :: FileSegment -> IO BL.ByteString readSegment (f,range) = do- x <- mmapFileByteString f range- `catch` (\(_::SomeException) -> do+ bs <- tryToRead+ `catch` (\(_::SomeException) -> do size <- fileSize `fmap` getFileStatus f if size == 0- then return BS.empty- else performGC >> mmapFileByteString f range)- return $ BL.fromChunks [x]+ then return BS8.empty+ else performGC >> tryToRead)+ return $ BL.fromChunks [bs]+ where+ tryToRead = do + case range of+ Nothing -> BS.readFile f+ Just (off, size) -> withFile f ReadMode $ \h -> do+ hSeek h AbsoluteSeek $ fromIntegral off+ BS.hGet h size {-# INLINE readSegment #-} -- | Run an IO action with @path@ as a working directory. Does neccessary@@ -71,7 +79,7 @@ return $! isAbsolute p ? (p, cwd </> p) -- Wow, unsafe.-unsafePokeBS :: BS.ByteString -> BS.ByteString -> IO ()+unsafePokeBS :: BS8.ByteString -> BS8.ByteString -> IO () unsafePokeBS to from = do let (fp_to, off_to, len_to) = toForeignPtr to (fp_from, off_from, len_from) = toForeignPtr from
hashed-storage.cabal view
@@ -1,5 +1,5 @@ name: hashed-storage-version: 0.4.1+version: 0.4.2 synopsis: Hashed file storage support code. description: Support code for reading and manipulating hashed file storage@@ -77,7 +77,7 @@ c-sources: Bundled/sha2.c - extensions: PatternSignatures, NoMonomorphismRestriction+ extensions: ScopedTypeVariables, NoMonomorphismRestriction executable hashed-storage-test if impl(ghc >= 6.8)