hashed-storage 0.4.13 → 0.5
raw patch · 7 files changed
+138/−85 lines, 7 filesdep ~mmapPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: mmap
API changes (from Hackage documentation)
- Storage.Hashed.Darcs: readDarcsHashed :: FilePath -> (Maybe Int, Hash) -> IO (Tree IO)
+ Storage.Hashed.Darcs: readDarcsHashed' :: Bool -> FilePath -> (Maybe Int, Hash) -> IO (Tree IO)
Files
- Storage/Hashed/AnchoredPath.hs +3/−2
- Storage/Hashed/Darcs.hs +22/−16
- Storage/Hashed/Index.hs +4/−3
- Storage/Hashed/Monad.hs +25/−18
- Storage/Hashed/Test.hs +32/−2
- Storage/Hashed/Tree.hs +50/−42
- hashed-storage.cabal +2/−2
Storage/Hashed/AnchoredPath.hs view
@@ -82,8 +82,9 @@ -- 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+floatPath = make . splitDirectories . normalise . dropTrailingPathSeparator+ where make ["."] = AnchoredPath []+ make x = AnchoredPath $ map (Name . BS.pack) x anchoredRoot :: AnchoredPath
Storage/Hashed/Darcs.hs view
@@ -18,7 +18,7 @@ import Data.List( sortBy ) import Data.Char( chr, ord, isSpace )-import Data.Maybe( fromJust )+import Data.Maybe( fromJust, isJust ) import qualified Data.Set as S import Control.Monad.State.Strict @@ -78,10 +78,13 @@ _ -> Nothing darcsLocation :: FilePath -> (Maybe Int, Hash) -> FileSegment-darcsLocation dir (s,h) = (dir </> (prefix s ++ BS8.unpack (encodeBase16 h)), Nothing)+darcsLocation dir (s,h) = case hash of+ "" -> error "darcsLocation: invalid hash"+ _ -> (dir </> prefix s ++ hash, Nothing) where prefix Nothing = "" prefix (Just s') = formatSize s' ++ "-" formatSize s' = let n = show s' in replicate (10 - length n) '0' ++ n+ hash = BS8.unpack (encodeBase16 h) ---------------------------------------------- -- Darcs directory format.@@ -94,8 +97,7 @@ string (Name name, item) = do header <- case item of File _ -> Just $ BS8.pack "file:\n"- SubTree _ -> Just $ BS8.pack "directory:\n"- Stub _ _ -> Nothing+ _ -> Just $ BS8.pack "directory:\n" hash <- case itemHash item of NoHash -> Nothing x -> Just $ encodeBase16 x@@ -147,6 +149,7 @@ update (File blob@(Blob con NoHash)) = do hash <- sha256 <$> readBlob blob return $ File (Blob con hash)+ update (Stub _ NoHash) = fail "NoHash Stub encountered in darcsAddMissingHashes" update x = return x -------------------------------------------@@ -168,21 +171,26 @@ -- | Read in a darcs-style hashed tree. This is mainly useful for reading -- \"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 _ (_, NoHash) = fail "Cannot readDarcsHashed NoHash"-readDarcsHashed dir root@(_, hash) = do+readDarcsHashed' :: Bool -> FilePath -> (Maybe Int, Hash) -> IO (Tree IO)+readDarcsHashed' _ _ (_, NoHash) = fail "Cannot readDarcsHashed NoHash"+readDarcsHashed' sizefail dir root@(_, hash) = do items' <- readDarcsHashedDir dir root subs <- sequence [- case tp of- BlobType -> return (d, File $- Blob (readBlob' (s, h)) h)- TreeType ->- do let t = readDarcsHashed dir (s, h)- return (d, Stub t h)+ do when (sizefail && isJust s) $+ fail ("Unexpectedly encountered size-prefixed hash in " ++ dir)+ case tp of+ BlobType -> return (d, File $+ Blob (readBlob' (s, h)) h)+ TreeType ->+ do let t = readDarcsHashed dir (s, h)+ return (d, Stub t h) | (tp, d, s, h) <- items' ] return $ makeTreeWithHash subs hash where readBlob' = fmap decompress . readSegment . darcsLocation dir +readDarcsHashed = readDarcsHashed' False+readDarcsHashedNosize dir hash = readDarcsHashed' True dir (Nothing, hash)+ ---------------------------------------------------- -- Writing darcs-style hashed trees. --@@ -237,12 +245,10 @@ fsCreateHashedFile fn newcontent replaceItem path (Just nblob) updateSub path s = do- let !hash = darcsTreeHash s+ let !hash = treeHash s Just dirdata = darcsFormatDir s fn = dir </> BS8.unpack (encodeBase16 hash)- ns = SubTree (s { treeHash = hash }) fsCreateHashedFile fn (compress dirdata)- replaceItem path (Just ns) -------------------------------------------------------------- -- Reading and writing packed pristine. EXPERIMENTAL.
Storage/Hashed/Index.hs view
@@ -202,7 +202,8 @@ iHash' i = SHA256 (iHash i) -- | Gives a ForeignPtr to mmapped index, which can be used for reading and--- updates.+-- updates. The req_size parameter, if non-0, expresses the requested size of+-- the index file. mmapIndex will grow the index if it is smaller than this. mmapIndex :: forall a. FilePath -> Int -> IO (ForeignPtr a, Int) mmapIndex indexpath req_size = do exist <- doesFileExist indexpath@@ -214,8 +215,8 @@ | otherwise -> 0 case size of 0 -> return (castForeignPtr nullForeignPtr, size)- _ -> do (x, _) <- mmapFileForeignPtr indexpath- ReadWrite (Just (0, size + size_magic))+ _ -> do (x, _, _) <- mmapFileForeignPtr indexpath+ ReadWriteEx (Just (0, size + size_magic)) return (x, size) data IndexM m = Index { mmap :: (ForeignPtr ())
Storage/Hashed/Monad.hs view
@@ -54,7 +54,7 @@ class (Functor m, Monad m) => TreeRO m where currentDirectory :: m AnchoredPath withDirectory :: (MonadError e m) => AnchoredPath -> m a -> m a- expandTo :: (MonadError e m) => AnchoredPath -> m ()+ expandTo :: (MonadError e m) => AnchoredPath -> m AnchoredPath -- | Grab content of a file in the current Tree at the given path. readFile :: (MonadError e m) => AnchoredPath -> m BL.ByteString -- | Check for existence of a node (file or directory, doesn't matter).@@ -147,33 +147,39 @@ instance (Monad m, MonadError e m) => TreeRO (TreeMonad m) where expandTo p = do t <- gets tree- case find t p of- Nothing -> do t' <- lift $ expandPath t p `catchError` \_ -> return t- modify $ \st -> st { tree = t' }+ p' <- (`catPaths` p) `fmap` ask+ let amend = do t' <- lift $ expandPath t p'+ modify $ \st -> st { tree = t' }+ case find t p' of+ Nothing -> amend+ Just (Stub _ _) -> amend _ -> return ()+ return p' fileExists p =- do expandTo p- (isJust . (flip findFile p)) `fmap` gets tree+ do p' <- expandTo p+ (isJust . (flip findFile p')) `fmap` gets tree directoryExists p =- do expandTo p- (isJust . (flip findTree p)) `fmap` gets tree+ do p' <- expandTo p+ (isJust . (flip findTree p')) `fmap` gets tree exists p =- do expandTo p- (isJust . (flip find p)) `fmap` gets tree+ do p' <- expandTo p+ (isJust . (flip find p')) `fmap` gets tree readFile p =- do expandTo p+ do p' <- expandTo p t <- gets tree- let f = findFile t p+ let f = findFile t p' case f of- Nothing -> fail $ "No such file " ++ show p+ Nothing -> fail $ "No such file " ++ show p' Just x -> lift (readBlob x) currentDirectory = ask- withDirectory dir = local (\old -> old `catPaths` dir)+ withDirectory dir act = do+ dir' <- expandTo dir+ local (\old -> dir') act instance (Functor m, Monad m, MonadError e m) => TreeRW (TreeMonad m) where writeFile p con =@@ -196,12 +202,13 @@ modifyItem p Nothing rename from to =- do expandTo from+ do from' <- expandTo from+ to' <- expandTo to tr <- gets tree- let item = find tr from- found_to = find tr to+ let item = find tr from'+ found_to = find tr to' unless (isNothing found_to) $ fail $ "Error renaming: destination " ++ show to ++ " exists." unless (isNothing item) $ do- modifyItem to item modifyItem from Nothing+ modifyItem to item
Storage/Hashed/Test.hs view
@@ -171,8 +171,10 @@ , testCase "modifyTree removal" check_modify_remove , testCase "expand" check_expand , testCase "expandPath" check_expand_path+ , testCase "expandPath of sub" check_expand_path_sub , testCase "diffTrees" check_diffTrees , testCase "diffTrees identical" check_diffTrees_ident+ , testProperty "expandPath" prop_expandPath , testProperty "shapeEq" prop_shape_eq , testProperty "expandedShapeEq" prop_expanded_shape_eq , testProperty "expand is identity" prop_expand_id@@ -253,6 +255,16 @@ assertBool "badpath not reachable in t'" $ badpath `notElem` (map fst $ list t') + check_expand_path_sub = do+ t <- expandPath testTree $ floatPath "substub"+ t' <- expandPath testTree $ floatPath "substub/stub"+ t'' <- expandPath testTree $ floatPath "subtree/stub"+ assertBool "leaf is not a Stub" $+ isNothing (findTree testTree $ floatPath "substub")+ assertBool "leaf is not a Stub" $ isJust (findTree t $ floatPath "substub")+ assertBool "leaf is not a Stub (2)" $ isJust (findTree t' $ floatPath "substub/stub")+ assertBool "leaf is not a Stub (3)" $ isJust (findTree t'' $ floatPath "subtree/stub")+ check_diffTrees = flip finally (Prelude.writeFile "foo_dir/foo_a" "a\n") $ do Prelude.writeFile "foo_dir/foo_a" "b\n"@@ -307,7 +319,11 @@ prop_overlay_super (t1 :: Tree Identity, t2) = (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) ==> Just EQ == (runIdentity $ restrict t2 (t1 `overlay` t2) `cmpTree` t2)-+ prop_expandPath (TreeWithPath t p) =+ notStub $ find (runIdentity $ expandPath t p) p+ where notStub (Just (Stub _ _)) = False+ notStub Nothing = error "Did not exist."+ notStub _ = True packed = [ testCase "loose pristine tree" check_loose , testCase "load" check_load@@ -416,12 +432,18 @@ where prop_base16 x = (decodeBase16 . encodeBase16) x == x prop_base64u x = (decodeBase64u . encodeBase64u) x == x -monad = [ testCase "path expansion" check_virtual ]+monad = [ testCase "path expansion" check_virtual+ , testCase "rename" check_rename ] where check_virtual = virtualTreeMonad run testTree >> return () where run = do file <- readFile (floatPath "substub/substub/file") file2 <- readFile (floatPath "substub/substub/file2") lift $ BL.unpack file @?= "" lift $ BL.unpack file2 @?= "foo"+ check_rename = do (_, t) <- virtualTreeMonad run testTree+ t' <- darcsAddMissingHashes =<< expand t+ forM_ [ (p, i) | (p, i) <- list t' ] $ \(p,i) ->+ assertBool ("have hash: " ++ show p) $ itemHash i /= NoHash+ where run = do rename (floatPath "substub/substub/file") (floatPath "substub/file2") posix = [ testCase "getFileStatus" $ check_stat Posix.getFileStatus , testCase "getSymbolicLinkStatus" $ check_stat Posix.getSymbolicLinkStatus ]@@ -497,6 +519,14 @@ File _ -> arbitrary Stub _ _ -> arbitrary SubTree t -> return t++data TreeWithPath = TreeWithPath (Tree Identity) AnchoredPath deriving (Show)++instance Arbitrary TreeWithPath where+ arbitrary = do t <- arbitrary+ p <- oneof $ return (AnchoredPath []) :+ (map (return . fst) $ list (runIdentity $ expand t))+ return $ TreeWithPath t p --------------------------- -- Other instances
Storage/Hashed/Tree.hs view
@@ -35,7 +35,7 @@ import qualified Data.ByteString.Char8 as BS import qualified Data.Map as M -import Data.Maybe( catMaybes )+import Data.Maybe( catMaybes, isNothing ) import Data.List( union, sort ) import Control.Applicative( (<$>) ) @@ -158,10 +158,6 @@ expanded_map = M.fromList expanded tree = t { items = M.union orig_map expanded_map } update path tree- unstub (Stub s _) = s- unstub (SubTree t) = return t- isSub (File _) = False- isSub _ = True -- | Expand a stubbed Tree into a one with no stubs in it. You might want to -- filter the tree before expanding to save IO. This is the basic@@ -171,21 +167,18 @@ expand = expandUpdate $ \_ -> return -- | Unfold a path in a (stubbed) Tree, such that the leaf node of the path is--- reachable without crossing any stubs.+-- reachable without crossing any stubs. Moreover, the leaf ought not be a Stub+-- in the resulting Tree. A non-existent path is expanded as far as it can be. expandPath :: (Monad m) => Tree m -> AnchoredPath -> m (Tree m)-expandPath t_ path_ = do expand' t_ path_- where expand' t (AnchoredPath [_]) = return t- expand' t (AnchoredPath (n:rest)) = do+expandPath t_ path_ = expand' t_ path_+ where expand' t (AnchoredPath []) = return t+ expand' t (AnchoredPath (n:rest)) = case lookup t n of- (Just (Stub stub _)) ->- do unstubbed <- stub- amend t n rest unstubbed- (Just (SubTree t')) -> amend t n rest t'- _ -> fail $ "Descent error in expandPath: " ++ show path_+ (Just item) | isSub item -> amend t n rest =<< unstub item+ _ -> return t -- fail $ "Descent error in expandPath: " ++ show path_ amend t name rest sub = do sub' <- expand' sub (AnchoredPath rest)- let orig_l = [ i | i@(n',_) <- listImmediate t, name /= n' ]- tree = t { items = M.insert name (SubTree sub') (items t) }+ let tree = t { items = M.insert name (SubTree sub') (items t) } return tree class (Monad m) => FilterTree a m where@@ -322,37 +315,40 @@ -- | Modify a Tree (by replacing, or removing or adding items). modifyTree :: (Monad m) => Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m+modifyTree t_ p_ i_ = snd $ go t_ p_ i_+ where fix t unmod items' = (unmod, t { items = countmap items' `seq` items'+ , treeHash = if unmod then treeHash t else NoHash }) -modifyTree _ (AnchoredPath []) (Just (SubTree sub)) = sub+ go t (AnchoredPath []) (Just (SubTree sub)) = (treeHash t `match` treeHash sub, sub) -modifyTree t (AnchoredPath [n]) (Just item) =- t { items = countmap items' `seq` items'- , treeHash = NoHash }- where !items' = M.insert n item (items t)+ go t (AnchoredPath [n]) (Just item) = fix t unmod items'+ where !items' = M.insert n item (items t)+ !unmod = itemHash item `match` case lookup t n of+ Nothing -> NoHash+ Just i -> itemHash i -modifyTree t (AnchoredPath [n]) Nothing =- t { items = countmap items' `seq` items'- , treeHash = NoHash }- where !items' = M.delete n (items t)+ go t (AnchoredPath [n]) Nothing = fix t unmod items'+ where !items' = M.delete n (items t)+ !unmod = isNothing $ lookup t n -modifyTree t path@(AnchoredPath (n:r)) item =- t { items = countmap items' `seq` items'- , treeHash = NoHash }- where subtree s = modifyTree s (AnchoredPath r) item- !items' = M.insert n sub (items t)- !sub = case lookup t n of- Just (SubTree s) -> SubTree $! subtree s- Just (Stub s _) -> Stub (do x <- s- return $! subtree x) NoHash- Nothing -> SubTree $! subtree emptyTree- _ -> error $ "Modify tree at " ++ show path+ go t path@(AnchoredPath (n:r)) item = fix t unmod items'+ where subtree s = go s (AnchoredPath r) item+ !items' = M.insert n sub (items t)+ !sub = snd sub'+ !unmod = fst sub'+ !sub' = case lookup t n of+ Just (SubTree s) -> let (mod, sub) = subtree s in (mod, SubTree sub)+ Just (Stub s _) -> (False, Stub (do x <- s+ return $! snd $! subtree x) NoHash)+ Nothing -> (False, SubTree $! snd $! subtree emptyTree)+ _ -> error $ "Modify tree at " ++ show path -modifyTree _ (AnchoredPath []) (Just (Stub _ _)) =- error "Bug in descent in modifyTree."-modifyTree _ (AnchoredPath []) (Just (File _)) =- error "Bug in descent in modifyTree."-modifyTree _ (AnchoredPath []) Nothing =- error "Bug in descent in modifyTree."+ go _ (AnchoredPath []) (Just (Stub _ _)) =+ error "Bug in descent in modifyTree."+ go _ (AnchoredPath []) (Just (File _)) =+ error "Bug in descent in modifyTree."+ go _ (AnchoredPath []) Nothing =+ error "Bug in descent in modifyTree." countmap = M.fold (\_ i -> i + 1) 0 @@ -394,3 +390,15 @@ return $ overlay b' o') NoHash (Just x, _) -> x (_, _) -> error $ "Unexpected case in overlay at get " ++ show n ++ "."+++------ Private utilities shared among multiple functions. --------++unstub :: (Monad m) => TreeItem m -> m (Tree m)+unstub (Stub s _) = s+unstub (SubTree s) = return s++isSub :: TreeItem m -> Bool+isSub (File _) = False+isSub _ = True+
hashed-storage.cabal view
@@ -1,5 +1,5 @@ name: hashed-storage-version: 0.4.13+version: 0.5 synopsis: Hashed file storage support code. description: Support code for reading and manipulating hashed file storage@@ -73,7 +73,7 @@ dataenc, binary, zlib,- mmap >= 0.4 && < 0.5+ mmap >= 0.5 && < 0.6 c-sources: Bundled/sha2.c