hashed-storage 0.5.6 → 0.5.7

raw patch · 3 files changed

+54/−4 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Storage/Hashed/Darcs.hs +9/−0
• Storage/Hashed/Tree.hs +44/−3
• hashed-storage.cabal +1/−1

@@ -295,3 +295,12 @@     where valid NoHash = False           valid _ = True +darcsCheckExpand :: Tree IO+            -> IO (Either [(FilePath, Hash, Maybe Hash)] (Tree IO))+darcsCheckExpand t = do+  problemsOrTree <- checkExpand darcsHash t+  case problemsOrTree of+    Left problems -> return . Left $ map render problems+    Right tree -> return . Right $ tree+  where+    render (path, h, h') = (anchorPath "." path, h, h')

@@ -11,7 +11,7 @@     -- | By default, Tree obtained by a read function is stubbed: it will     -- contain Stub items that need to be executed in order to access the     -- respective subtrees. 'expand' will produce an unstubbed Tree.-    , expandUpdate, expand, expandPath+    , expandUpdate, expand, expandPath, checkExpand      -- * Tree access and lookup.     , items, list, listImmediate, treeHash@@ -37,7 +37,9 @@ import qualified Data.Map as M  import Data.Maybe( catMaybes, isNothing )+import Data.Either( lefts, rights ) import Data.List( union, sort )+import Control.Monad( filterM, liftM ) import Control.Applicative( (<$>) )  --------------------------------@@ -154,8 +156,7 @@             let subtree (name, sub) = do tree <- go (path `appendPath` name) =<< unstub sub                                          return (name, SubTree tree)             expanded <- mapM subtree [ x | x@(_, item) <- listImmediate t, isSub item ]-            let orig = [ i | i <- listImmediate t, not $ isSub $ snd i ]-                orig_map = M.filter (not . isSub) (items t)+            let orig_map = M.filter (not . isSub) (items t)                 expanded_map = M.fromList expanded                 tree = t { items = M.union orig_map expanded_map }             update path tree@@ -181,6 +182,46 @@             sub' <- expand' sub (AnchoredPath rest)             let tree = t { items = M.insert name (SubTree sub') (items t) }             return tree++-- | Check the disk version of a Tree: expands it, and checks each+-- hash. Returns either the expanded tree or a list of AnchoredPaths+-- where there are problems. The first argument is the hashing function+-- used to create the tree.+checkExpand :: (TreeItem IO -> IO Hash) -> Tree IO+            -> IO (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO))+checkExpand hashFunc t = go (AnchoredPath []) t+    where+      go path t_ = do+        let+            subtree (name, sub) =+                do let here = path `appendPath` name+                   sub' <- (Just <$> unstub sub) `catch` \_ -> return Nothing+                   case sub' of+                     Nothing -> return $ Left [(here, treeHash t_, Nothing)]+                     Just sub -> do+                       treeOrTrouble <- go (path `appendPath` name) sub+                       return $ case treeOrTrouble of+                              Left problems -> Left problems+                              Right tree -> Right (name, SubTree tree)+            badBlob (_, f@(File (Blob s h))) =+              fmap (/= h) (hashFunc f `catch` (\_ -> return NoHash))+            badBlob _ = return False+            render (name, f@(File (Blob _ h))) = do+              h' <- (Just <$> hashFunc f) `catch` \_ -> return Nothing+              return (path `appendPath` name, h, h')+        subs <- mapM subtree [ x | x@(_, item) <- listImmediate t_, isSub item ]+        badBlobs <- filterM badBlob (listImmediate t) >>= mapM render+        let problems = badBlobs ++ (concat $ lefts subs)+        if null problems+         then do+           let orig_map = M.filter (not . isSub) (items t)+               expanded_map = M.fromList $ rights subs+               tree = t_ {items = orig_map `M.union` expanded_map}+           h' <- hashFunc (SubTree t_)+           if h' `match` treeHash t_+            then return $ Right tree+            else return $ Left [(path, treeHash t_, Just h')]+         else return $ Left problems  class (Monad m) => FilterTree a m where     -- | Given @pred tree@, produce a 'Tree' that only has items for which

@@ -1,5 +1,5 @@ name:          hashed-storage-version:       0.5.6+version:       0.5.7 synopsis:      Hashed file storage support code.  description:   Support code for reading and manipulating hashed file storage