hashed-storage 0.3.6 → 0.3.7

raw patch · 10 files changed

+595/−78 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Storage/Hashed.hs +8/−23
• Storage/Hashed/AnchoredPath.hs +9/−2
• Storage/Hashed/Darcs.hs +38/−2
• Storage/Hashed/Index.hs +8/−3
• Storage/Hashed/Monad.hs +13/−6
• Storage/Hashed/Packed.hs +225/−0
• Storage/Hashed/Test.hs +236/−32
• Storage/Hashed/Tree.hs +15/−6
• Storage/Hashed/Utils.hs +41/−3
• hashed-storage.cabal +2/−1

@@ -30,8 +30,7 @@ import Storage.Hashed.Tree( Tree( listImmediate ), TreeItem(..), ItemType(..)                           , Blob(..), emptyTree, makeTree, makeTreeWithHash                           , list, read, find )-import System.FilePath( (</>), splitDirectories, normalise-                      , dropTrailingPathSeparator )+import System.FilePath( (</>) ) import System.Directory( getDirectoryContents, doesFileExist                        , doesDirectoryExist, createDirectoryIfMissing ) import Codec.Compression.GZip( decompress )@@ -42,14 +41,6 @@ -- For explorers -- --- | 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.-floatPath :: FilePath -> AnchoredPath-floatPath = AnchoredPath . map (Name . BS.pack)-              . splitDirectories-              . normalise . dropTrailingPathSeparator- -- | Take a relative FilePath within a Tree and print the contents of the -- object there. Useful for exploration, less so for serious programming. printPath :: Tree -> FilePath -> IO ()@@ -100,20 +91,9 @@ readDarcsHashedDir dir h = do   compressed <- readSegment (dir </> BS.unpack (darcsFormatHash h), Nothing)   let content = decompress compressed-      lines = BL.split '\n' content   return $ if BL.null compressed               then []-              else parse lines-    where-      parse (t:n:h':r) = (parse' t,-                          Name $ BS.pack $ darcsDecodeWhite (BL.unpack n),-                          makeHash hash) : parse r-          where hash = BS.concat $ BL.toChunks h'-      parse _ = []-      parse' x-          | x == BL.pack "file:" = BlobType-          | x == BL.pack "directory:" = TreeType-          | otherwise = error $ "Error parsing darcs hashed dir: " ++ BL.unpack x+              else darcsParseDir content  -- | 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@@ -152,7 +132,12 @@                (pris_line:_) ->                    let hash = makeHash $ BS.drop 9 pris_line                     in readDarcsHashed (darcs </> "pristine.hashed") hash-     else readPlainTree $ darcs </> "pristine"+     else do have_pristine <- doesDirectoryExist $ darcs </> "pristine"+             have_current <- doesDirectoryExist $ darcs </> "current"+             case (have_pristine, have_current) of+               (True, _) -> readPlainTree $ darcs </> "pristine"+               (False, True) -> readPlainTree $ darcs </> "current"+               (_, _) -> fail "No pristine tree is available!"  -- | Write out *full* tree to a plain directory structure. If you instead want -- to make incremental updates, refer to "Monad.plainTreeIO".

@@ -5,11 +5,11 @@     ( Name(..), AnchoredPath(..), appendPath, anchorPath     , isPrefix, parent, parents, catPaths, flatten, makeName     -- * Unsafe functions.-    , nameToFilePath, nameFromFilePath, floatBS ) where+    , nameToFilePath, nameFromFilePath, floatBS, floatPath ) where  import qualified Data.ByteString.Char8 as BS import Data.List( isPrefixOf, inits )-import System.FilePath( (</>) )+import System.FilePath( (</>), splitDirectories, normalise, dropTrailingPathSeparator )  ------------------------------- -- AnchoredPath utilities@@ -68,4 +68,11 @@  makeName :: String -> Name makeName = Name . BS.pack++-- | 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.+floatPath :: FilePath -> AnchoredPath+floatPath = AnchoredPath . map (Name . BS.pack) . splitDirectories+            . normalise . dropTrailingPathSeparator 

@@ -10,7 +10,7 @@ import qualified Data.ByteString.Lazy.Char8 as BL  import Data.List( sortBy )-import Data.Char( chr )+import Data.Char( chr, ord, isSpace )  darcsFormatSize :: (Num a) => a -> BS.ByteString darcsFormatSize s = BS.pack $ replicate (10 - length n) '0' ++ n@@ -23,6 +23,12 @@               , h ] darcsFormatHash (Hash (Nothing, h)) = h +-- | 'decode_white' interprets the Darcs-specific \"encoded\" filenames+--   produced by 'darcsEncodeWhite'+--+--   > darcsDecodeWhite "hello\32\there" == "hello there"+--   > darcsDecodeWhite "hello\92\there" == "hello\there"+--   > darcsDecodeWhite "hello\there"    == error "malformed filename" darcsDecodeWhite :: String -> FilePath darcsDecodeWhite ('\\':cs) =     case break (=='\\') cs of@@ -32,6 +38,20 @@ darcsDecodeWhite (c:cs) = c: darcsDecodeWhite cs darcsDecodeWhite "" = "" +-- | 'encode_white' translates whitespace in filenames to a darcs-specific+--   format (backslash followed by numerical representation according to 'ord').+--   Note that backslashes are also escaped since they are used in the encoding.+--+--   > darcsEncodeWhite "hello there" == "hello\32\there"+--   > darcsEncodeWhite "hello\there" == "hello\92\there"+darcsEncodeWhite :: FilePath -> String+darcsEncodeWhite (c:cs) | isSpace c || c == '\\' =+    '\\' : (show $ ord c) ++ "\\" ++ darcsEncodeWhite cs+darcsEncodeWhite (c:cs) = c : darcsEncodeWhite cs+darcsEncodeWhite [] = []++darcsEncodeWhiteBS = BS.pack . darcsEncodeWhite . BS.unpack+ darcsFormatDir :: Tree -> BL.ByteString darcsFormatDir t = BL.fromChunks $ concatMap string                      (sortBy cmp $ listImmediate t)@@ -42,14 +62,30 @@                   SubTree _ -> BS.pack "directory:\n"                   Stub _ _ ->                       error "Trees with stubs not supported in darcsFormatDir.",-                name, BS.singleton '\n',+                darcsEncodeWhiteBS name, BS.singleton '\n',                 case itemHash item of                   Nothing -> error $ "darcsFormatDir: missing hash on "                                  ++ show name                   Just h -> darcsFormatHash h,                 BS.singleton '\n' ] +darcsParseDir :: BL.ByteString -> [(ItemType, Name, Hash)]+darcsParseDir content = parse (BL.split '\n' content)+    where+      parse (t:n:h':r) = (header t,+                          Name $ BS.pack $ darcsDecodeWhite (BL.unpack n),+                          makeHash hash) : parse r+          where hash = BS.concat $ BL.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+ -- | Compute a darcs-compatible hash value for a tree-like structure. darcsTreeHash :: Tree -> Hash darcsTreeHash d = hashSetSize (sha256 bl) $ BL.length bl     where bl = darcsFormatDir d++darcsUpdateHashes tree =+    flip updateTreePostorder tree $ \ t -> t { treeHash = Just $ darcsTreeHash t }

@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, NoMonomorphismRestriction #-}+{-# LANGUAGE CPP, ScopedTypeVariables, NoMonomorphismRestriction #-}  -- | This module contains plain tree indexing code. The index itself is a -- CACHE: you should only ever use it as an optimisation and never as a primary@@ -9,7 +9,7 @@ -- your validity tracking code, you also check for format validity (see -- "indexFormatValid") and scrap and re-create index when needed. ----- The index is a binary file, that overlays a hashed tree over the working+-- The index is a binary file that overlays a hashed tree over the working -- copy. This means that every working file and directory has an entry in the -- index, that contains its path and hash and validity data. The validity data -- is a "last seen" timestamp plus the file size. The file hashes are sha256's@@ -53,7 +53,8 @@                       getFileStatus, fileSize, fileExists, EpochTime ) import System.IO.MMap( mmapFileForeignPtr, Mode(..) ) import System.IO( openBinaryFile, hGetChar, hClose, IOMode(..) )-import System.Directory( removeFile, doesFileExist )+import System.Directory( removeFile, doesFileExist, renameFile )+import System.FilePath( (<.>) ) import Control.Monad( when )  import qualified Data.ByteString.Char8 as BS@@ -289,7 +290,11 @@            len = 87 + sum [ typeLen typ + 84 + 1 + length (anchorPath "" p)                                 | (p, typ) <- paths ]        exist <- doesFileExist indexpath+#if mingw32_HOST_OS+       when exist $ renameFile indexpath (indexpath <.> "old")+#else        when exist $ removeFile indexpath -- to avoid clobbering oldidx+#endif        (mmap, _) <- mmapIndex indexpath len        let magic = fromForeignPtr (castForeignPtr mmap) 0 4            create (File _) path off =

@@ -92,9 +92,12 @@                                            (cwd st `catPaths` path) item }  expandTo :: AnchoredPath -> TreeIO ()-expandTo p = do t <- gets tree-                t' <- liftIO $ expandPath t p `catch` \(_::SomeException) -> return t-                modify $ \st -> st { tree = t' }+expandTo p =+    do t <- gets tree+       case find t p of+         Nothing -> do t' <- liftIO $ expandPath t p `catch` \(_::SomeException) -> return t+                       modify $ \st -> st { tree = t' }+         _ -> return ()  -- | Run a 'TreeIO' @action@ in a hashed setting. The @initial@ tree is assumed -- to be fully available from the @directory@, and any changes will be written@@ -109,14 +112,15 @@     do runTreeIO action $ initialState t syncHashed     where syncHashed = do             ch <- gets changed-            modify $ \st -> st { changed = S.empty }+            modify $ \st -> st { changed = S.empty, changesize = 0 }+            modify $ \st -> st { tree = darcsUpdateHashes $ 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                   Just (SubTree s) -> updateSub c s-                  _ -> fail $ "Bar at " ++ path+                  _ -> return () -- the file could have disappeared in the meantime           updateFile path b@(Blob _ (Just !h)) = do             let fn = dir </> BS.unpack (darcsFormatHash h)                 nblob = File $ Blob (decompress `fmap` BL.readFile fn) (Just h)@@ -148,7 +152,7 @@ plainTreeIO action t dir = runTreeIO action $ initialState t syncPlain     where syncPlain = do             ch <- gets changed-            modify $ \st -> st { changed = S.empty }+            modify $ \st -> st { changed = S.empty, changesize = 0 }             current  <- gets tree             forM_ (S.toList ch) $ \c -> do                 let path = anchorPath dir c@@ -222,6 +226,9 @@ rename from to = do expandTo from                     tr <- gets tree                     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                       replaceItem to item                       replaceItem from Nothing

@@ -0,0 +1,225 @@+{-# LANGUAGE ParallelListComp #-}+module Storage.Hashed.Packed where++import Prelude hiding ( lookup, read )+import Storage.Hashed.AnchoredPath+import Storage.Hashed.Tree hiding ( lookup )+import Storage.Hashed.Utils+import Storage.Hashed.Darcs++import Control.Monad( forM, forM_, unless )+import Control.Applicative( (<$>) )+import System.FilePath( (</>), (<.>) )+import System.Directory( createDirectoryIfMissing, removeFile+                       , getDirectoryContents )++import Bundled.Posix( fileExists, isDirectory, getFileStatus )++import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Char8 as BS+import Data.Maybe( listToMaybe, catMaybes, fromJust, isNothing )++import qualified Data.Set as S+import qualified Data.Map as M+import Data.List( sort )++-- | On-disk format for object storage: we implement a completely loose format+-- (one file per object), a compact format stored in a single append-only file+-- 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 = let chars = ['0'..'9'] ++ ['a'..'f']+              in [ [a,b] | a <- chars, b <- chars ]++loosePath :: OS -> Hash -> FilePath+loosePath os (Hash (_,hash)) =+    let hash' = BS.unpack hash+     in rootdir os </> "hatchery" </> take 2 hash' </> drop 2 hash'++looseLookup :: OS -> Hash -> IO (Maybe FileSegment)+looseLookup os hash = do+  let path = loosePath os hash+  exist <- fileExists <$> getFileStatus path+  return $ if exist then Just (path, Nothing)+                    else Nothing++-- | Object storage block. When used as a hatchery, the loose or compact format+-- are preferable, while for mature space, the pack format is more useful.+data Block = Block { blockLookup :: Hash -> IO (Maybe FileSegment)+                   , size :: Int+                   , format :: Format }++-- | Object storage. Contains a single "hatchery" and possibly a number of+-- mature space blocks, usually in form of packs. It also keeps a list of root+-- pointers and has a way to extract pointers from objects (externally+-- supplied). These last two things are used to implement a simple GC.+data OS = OS { hatchery :: Block+             , mature :: [Block]+             , roots :: [Hash]+             , references :: FileSegment -> IO [Hash]+             , rootdir :: FilePath }++-- | 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. The set of hashes given is used as roots for GC marking.+repack :: OS -> S.Set Hash -> IO OS+repack os roots = 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:+-- such objects will be skipped.+hatch :: OS -> [BL.ByteString] -> IO OS+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."+          sieve blob = do let hash = sha256 blob+                          absent <- isNothing <$> lookup os hash+                          return (absent, hash, blob)++-- | Reduce hatchery size by moving things into packs.+compact :: OS -> IO OS+compact os = do objects <- live os [hatchery os]+                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 ()+          nuke dir = mapM (removeFile . (dir </>)) =<<+                       (Prelude.filter (`notElem` [".", ".."]) `fmap`+                               getDirectoryContents dir)++blocksLookup :: [Block] -> Hash -> IO (Maybe (Hash, FileSegment))+blocksLookup blocks hash =+    do segment <- cat `fmap` mapM (flip blockLookup hash) blocks+       return $ case segment of+                  Nothing -> Nothing+                  Just seg -> Just (hash, seg)+    where cat = listToMaybe . catMaybes++lookup :: OS -> Hash -> IO (Maybe FileSegment)+lookup os hash =+    do res <- blocksLookup (hatchery os : mature os) hash+       return $ case res of+                  Nothing -> Nothing+                  Just (_, seg) -> Just seg++-- | Create an empty object storage in given directory, with a hatchery of+-- given format. The directory is created if needed, but is assumed to be+-- empty.+create :: FilePath -> Format -> IO OS+create path fmt = do createDirectoryIfMissing True path+                     initHatchery+                     readOS path+    where initHatchery | fmt == Loose =+                           do mkdir hatchpath+                              forM loose_dirs $ mkdir . (hatchpath </>)+                       | fmt == Compact =+                           error "create/mkHatchery Compact undefined"+          mkdir = createDirectoryIfMissing False+          hatchpath = path </> "hatchery"++readOS :: FilePath -> IO OS+readOS path =+    do hatch_stat <- getFileStatus $ path </> "hatchery"+       let is_os = fileExists hatch_stat+           is_loose = 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 }+           os = OS { hatchery = _hatchery+                   , rootdir = path+                   , mature = packs+                   , roots = _roots }+           look | format _hatchery == Loose = looseLookup+                | otherwise = undefined+           packs = [] -- FIXME read packs+           _roots = [] -- FIXME read packs+       return os++readPack = undefined++createPack :: OS -> [(Hash, FileSegment)] -> IO Block+createPack os bits =+    do contents <- mapM readSegment (map snd bits)+       let offsets = scanl (+) 0 $ map BL.length contents+           headerbits = [ BL.fromChunks [ hash+                                        , BS.pack ": ("+                                        , BS.pack (show $ offset)+                                        , BS.pack ", "+                                        , BS.pack (show $ BL.length string)+                                        , BS.pack ")\n" ]+                          | (Hash (_, hash), _) <- bits | string <- contents | offset <- offsets ]+           header = BL.concat $ sort headerbits+           blob = BL.concat $ header:contents+           hash@(Hash (_, hashhash)) = sha256 blob+           path = rootdir os </> BS.unpack hashhash <.> "bin"+       BL.writeFile path blob+       return $ readPack path++-- | Build a map of live objects (i.e. those reachable from the given roots) in+-- a given list of Blocks.+live :: OS -> [Block] -> IO (M.Map Hash FileSegment)+live os blocks =+    reachable (references os)+              (blocksLookup blocks)+              (S.fromList $ roots os)++--------------------------------------------------------------+-- Reading and writing darcs-style pristine+----++-- | Read a Tree in the darcs hashed format from an object storage. This is+-- basically the same as readDarcsHashed from Storage.Hashed, but uses an+-- object storage instead of traditional darcs filesystem layout. Requires the+-- tree root hash as a starting point.+readPackedDarcsPristine :: OS -> Hash -> IO Tree+readPackedDarcsPristine os root =+    do seg <- fromJust <$> lookup os root+       items <- darcsParseDir <$> readSegment seg+       subs <- sequence [+                case tp of+                  BlobType -> return (d, File $ file h)+                  TreeType -> let t = readPackedDarcsPristine os h+                               in return (d, Stub t $ Just h)+                | (tp, d, h) <- items ]+       return $ makeTreeWithHash subs root+    where file h = Blob ((fromJust <$> lookup os h) >>= readSegment) (Just h)++-- | Write a Tree into an object storage, using the darcs-style directory+-- formatting (and therefore darcs-style hashes). Gives back the object storage+-- and the root hash of the stored Tree. NB. The function expects that the Tree+-- comes equipped with darcs-style hashes already!+writePackedDarcsPristine :: Tree -> OS -> IO (OS, Hash)+writePackedDarcsPristine tree os =+    do t <- expand tree+       files <- sequence [ read b | (_, File b) <- list t ]+       let dirs = darcsFormatDir t : [ darcsFormatDir d | (_, SubTree d) <- list t ]+       os' <- hatch os $ files ++ dirs+       return (os', darcsTreeHash t)++storePackedDarcsPristine :: Tree -> OS -> IO (OS, Hash)+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...+                     , references = darcsPristineRefs }, root)++darcsPristineRefs :: FileSegment -> IO [Hash]+darcsPristineRefs fs = do+  con <- (darcsParseDir <$> readSegment fs) `catch` \_ -> return []+  return $! [ hash | (_, _, hash) <- con, valid hash ]+    where valid (Hash (_, hash)) =+              BS.length hash == 64 && all (`elem` "0123456789abcdef") (BS.unpack hash)

@@ -1,26 +1,34 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-} module Storage.Hashed.Test( tests ) where  import Prelude hiding ( read, filter ) import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.ByteString.Char8 as BS+import Control.Exception( finally ) import System.Process import System.Directory( doesFileExist, removeFile ) import Control.Monad( forM_, when )+import Control.Monad.Identity import Data.Maybe import Data.Word import Data.Bits-import Data.List( (\\), sort )+import Data.List( (\\), sort, intercalate, nub ) import Storage.Hashed import Storage.Hashed.AnchoredPath import Storage.Hashed.Tree import Storage.Hashed.Index import Storage.Hashed.Utils import Storage.Hashed.Darcs+import Storage.Hashed.Packed import System.IO.Unsafe( unsafePerformIO ) import System.Mem( performGC ) -import Bundled.Posix( getFileStatus, getSymbolicLinkStatus, fileSize, fileExists )+import qualified Data.Set as S+import qualified Data.Map as M +import qualified Bundled.Posix as Posix+    ( getFileStatus, getSymbolicLinkStatus, fileSize, fileExists )+ import Test.HUnit import Test.Framework( testGroup ) import Test.QuickCheck@@ -35,12 +43,16 @@ blobs = [ (floatPath "foo_a", BL.pack "a\n")         , (floatPath "foo_dir/foo_a", BL.pack "a\n")         , (floatPath "foo_dir/foo_b", BL.pack "b\n")-        , (floatPath "foo_dir/foo_subdir/foo_a", BL.pack "a\n") ]+        , (floatPath "foo_dir/foo_subdir/foo_a", BL.pack "a\n")+        , (floatPath "foo space/foo\nnewline", BL.pack "newline\n")+        , (floatPath "foo space/foo\\backslash", BL.pack "backslash\n")+        , (floatPath "foo space/foo_a", BL.pack "a\n") ]  files = map fst blobs  dirs = [ floatPath "foo_dir"-       , floatPath "foo_dir/foo_subdir" ]+       , floatPath "foo_dir/foo_subdir"+       , floatPath "foo space" ]  emptyStub = Stub (return emptyTree) Nothing @@ -54,15 +66,22 @@           getsub = return sub           getsub2 = return $ makeTree [ (makeName "file", File emptyBlob) ] +equals_testdata t = sequence_ [+                     do ours <- read b+                        let Just stored = Prelude.lookup p blobs+                        assertEqual "contents match" ours stored+                     | (p, File b) <- list t ]+ --------------------------- -- Test list --  tests = [ testGroup "Bundled.Posix" posix-        , testGroup "Storage.Hashed" hashed-        , testGroup "Storage.Hashed.Index" index+        , testGroup "Storage.Hashed.Utils" utils         , testGroup "Storage.Hashed.Tree" tree-        , testGroup "Storage.Hashed.Utils" utils ]+        , testGroup "Storage.Hashed.Index" index+        , testGroup "Storage.Hashed.Packed" packed+        , testGroup "Storage.Hashed" hashed ]  -------------------------- -- Tests@@ -71,12 +90,15 @@ hashed = [ testCase "plain has all files" have_files          , testCase "pristine has all files" have_pristine_files          , testCase "pristine has no extras" pristine_no_extra-         , testCase "pristine file contents match" pristine_contents ]+         , testCase "pristine file contents match" pristine_contents+         , testCase "plain file contents match" plain_contents+         , testCase "writePlainTree works" write_plain ]     where       check_file t f = assertBool                        ("path " ++ show f ++ " is missing in tree")                        (isJust $ find t f)       check_files = forM_ files . check_file+       pristine_no_extra = do         t <- readDarcsPristine "." >>= expand         forM_ (list t) $ \(path,_) -> assertBool (show path ++ " is extraneous in tree")@@ -87,12 +109,18 @@        pristine_contents = do         t <- readDarcsPristine "." >>= expand-        sequence_ [-          do ours <- read b-             let Just stored = Prelude.lookup p blobs-             assertEqual "contents match" ours stored-         | (p, File b) <- list t ]+        equals_testdata t +      plain_contents = do+        t <- expand =<< filter nondarcs `fmap` readPlainTree "."+        equals_testdata t++      write_plain = do+        orig <- readDarcsPristine "." >>= expand+        writePlainTree orig "_darcs/plain"+        t <- readPlainTree "_darcs/plain"+        equals_testdata t+ index = [ testCase "index listing" check_index         , testCase "index content" check_index_content         , testCase "index versioning" check_index_versions ]@@ -126,12 +154,17 @@  tree = [ testCase "modifyTree" check_modify        , testCase "complex modifyTree" check_modify_complex+       , testCase "modifyTree removal" check_modify_remove        , testCase "expand" check_expand        , testCase "expandPath" check_expand_path-       , testProperty "treeEq" check_tree_eq-       , testProperty "expand is identity" check_expand_id-       , testProperty "filter True is identity" check_filter_id-       , testProperty "filter False is empty" check_filter_empty ]+       , testCase "diffTrees" check_diffTrees+       , testCase "diffTrees identical" check_diffTrees_ident+       , testProperty "treeEq" prop_tree_eq+       , testProperty "expand is identity" prop_expand_id+       , testProperty "filter True is identity" prop_filter_id+       , testProperty "filter False is empty" prop_filter_empty+       , testProperty "restrict both ways keeps shape" prop_restrict_shape_commutative+       , testProperty "restrict is a subtree of both" prop_restrict_subtree ]     where blob x = File $ Blob (return (BL.pack x)) (Just $ sha256 $ BL.pack x)           name = Name . BS.pack           check_modify =@@ -141,6 +174,9 @@                      y <- read $ fromJust $ findFile modify (floatPath "foo")                      assertEqual "old version" x (BL.pack "bar")                      assertEqual "new version" y (BL.pack "bla")+                     assertBool "list has foo" $+                                isJust (Prelude.lookup (floatPath "foo") $ list modify)+                     length (list modify) @?= 1           check_modify_complex =               let t = makeTree [ (name "foo", blob "bar")                                , (name "bar", SubTree t1) ]@@ -156,6 +192,22 @@                      assertEqual "old bar/foo" bar_foo (BL.pack "bar")                      assertEqual "new foo" foo' (BL.pack "bar")                      assertEqual "new bar/foo" bar_foo' (BL.pack "bla")+                     assertBool "list has bar/foo" $+                                isJust (Prelude.lookup (floatPath "bar/foo") $ list modify)+                     assertBool "list has foo" $+                                isJust (Prelude.lookup (floatPath "foo") $ list modify)+                     length (list modify) @?= length (list t)+          check_modify_remove =+              let t1 = makeTree [(name "foo", blob "bar")]+                  t2 = makeTree [ (name "foo", blob "bar")+                                , (name "bar", SubTree t1) ]+                  modify1 = modifyTree t1 (floatPath "foo") Nothing+                  modify2 = modifyTree t2 (floatPath "bar") Nothing+                  file = findFile modify1 (floatPath "foo")+                  subtree = findTree modify2 (floatPath "bar")+               in do assertBool "file is gone" (isNothing file)+                     assertBool "subtree is gone" (isNothing subtree)+           no_stubs t = null [ () | (_, Stub _ _) <- list t ]           path = floatPath "substub/substub/file"           badpath = floatPath "substub/substub/foo"@@ -167,33 +219,170 @@             assertBool "badpath not reachable" $                        badpath `notElem` (map fst $ list x)           check_expand_path = do+            test_exp <- expand testTree             t <- expandPath testTree path-            assertBool "path reachable" $ path `elem` (map fst $ list t)-            assertBool "badpath not reachable" $+            t' <- expandPath test_exp path+            t'' <- expandPath testTree $ floatPath "substub/x"+            assertBool "path not reachable in testTree" $ path `notElem` (map fst $ list testTree)+            assertBool "path reachable in t" $ path `elem` (map fst $ list t)+            assertBool "path reachable in t'" $ path `elem` (map fst $ list t')+            assertBool "path reachable in t (with findFile)" $+                       isJust $ findFile t path+            assertBool "path reachable in t' (with findFile)" $+                       isJust $ findFile t' path+            assertBool "path not reachable in t''" $ path `notElem` (map fst $ list t'')+            assertBool "badpath not reachable in t" $                        badpath `notElem` (map fst $ list t)-          check_tree_eq x = x `treeEq` x-          check_expand_id x = unsafePerformIO (expand x) `treeEq` x-          check_filter_id x = filter (\_ _ -> True) x `treeEq` x-          check_filter_empty x = filter (\_ _ -> False) x `treeEq` emptyTree+            assertBool "badpath not reachable in t'" $+                       badpath `notElem` (map fst $ list t') +          check_diffTrees =+            flip finally (writeFile "foo_dir/foo_a" "a\n") $+                 do writeFile "foo_dir/foo_a" "b\n"+                    working_plain <- filter nondarcs `fmap` readPlainTree "."+                    working <- expand =<< updateIndexFrom "_darcs/index" darcsTreeHash working_plain+                    pristine <- readDarcsPristine "."+                    (working', pristine') <- diffTrees working pristine+                    let foo_work = findFile working' (floatPath "foo_dir/foo_a")+                        foo_pris = findFile pristine' (floatPath "foo_dir/foo_a")+                    assertBool "trees have equal shapes" (working' `treeEq` pristine')+                    assertBool "foo_dir/foo_a is in working'" $ isJust foo_work+                    assertBool "foo_dir/foo_a is in pristine'" $ isJust foo_pris+                    foo_work_c <- read (fromJust foo_work)+                    foo_pris_c <- read (fromJust foo_pris)+                    BL.unpack foo_work_c @?= "b\n"+                    BL.unpack foo_pris_c @?= "a\n"+                    assertEqual "working' tree is minimal" 2 (length $ list working')+                    assertEqual "pristine' tree is minimal" 2 (length $ list pristine')++          check_diffTrees_ident = do+            pristine <- readDarcsPristine "."+            (t1, t2) <- diffTrees pristine pristine+            assertBool "t1 is empty" $ null (list t1)+            assertBool "t2 is empty" $ null (list t2)++          prop_tree_eq x = x `treeEq` x+          prop_expand_id x = unsafePerformIO (expand x) `treeEq` x+          prop_filter_id x = filter (\_ _ -> True) x `treeEq` x+          prop_filter_empty x = filter (\_ _ -> False) x `treeEq` emptyTree+          prop_restrict_shape_commutative (t1, t2) =+              not (restrict t1 t2 `treeEq` emptyTree) ==>+                  restrict t1 t2 `treeEq` restrict t2 t1+          prop_restrict_subtree (t1, t2) =+              not (restrict t1 t2 `treeEq` emptyTree) ==>+                  let restricted = S.fromList (map fst $ list $ restrict t1 t2)+                      orig1 = S.fromList (map fst $ list t1)+                      orig2 = S.fromList (map fst $ list t2)+                   in and [restricted `S.isSubsetOf` orig1, restricted `S.isSubsetOf` orig2]++packed = [ testCase "loose pristine tree" check_loose+         , testCase "readOS" check_readOS+         , testCase "live" check_live+         , testCase "compact" check_compact ]+    where check_loose = do x <- readDarcsPristine "."+                           os <- create "_darcs/loose" Loose+                           (os', root) <- writePackedDarcsPristine x os+                           y <- readPackedDarcsPristine os' root+                           equals_testdata y+          check_readOS = do os <- readOS "_darcs/loose"+                            format (hatchery os) @?= Loose+                            x <- readDarcsPristine "."+                            y <- readPackedDarcsPristine os (fromJust $ treeHash x)+                            equals_testdata y+          check_live = do os <- readOS "_darcs/loose"+                          x <- readDarcsPristine "."+                          alive <- live (os { roots = [ fromJust $ treeHash x ]+                                            , references = darcsPristineRefs } ) [hatchery os]+                          sequence_ [ assertBool "" $ (fromJust hash) `S.member` M.keysSet alive+                                      | hash <- map (itemHash . snd) $ list x ]+                          length (M.toList alive) @?= 1 + length (nub $ map snd blobs) + length dirs+          check_compact = do os <- readOS "_darcs/loose"+                             x <- darcsUpdateHashes `fmap` (expand =<< readDarcsPristine ".")+                             (os', root) <- storePackedDarcsPristine x os+                             hatch_root_old <- blockLookup (hatchery os') root+                             assertBool "bits in the old hatchery" $ isJust hatch_root_old++                             os'' <- compact os'+                             length (mature os'') @?= 1+                             hatch_root <- blockLookup (hatchery os'') root+                             assertBool "bits no longer in hatchery" $ isNothing hatch_root++                             -- TODO:+                             -- y <- readPackedDarcsPristine os'' (fromJust $ treeHash x)+                             -- equals_testdata y+ utils = [ testProperty "xlate32" prop_xlate32-        , testProperty "xlate64" prop_xlate64 ]+        , testProperty "xlate64" prop_xlate64+        , testProperty "reachable is a subset" prop_reach_subset+        , testProperty "roots are reachable" prop_reach_roots+        , testProperty "nonexistent roots are not reachable" prop_reach_nonroots+        , testCase "an example for reachable" check_reachable+        , testCase "fixFrom" check_fixFrom+        , testCase "mmap empty file" check_mmapEmpty ]     where prop_xlate32 x = (xlate32 . xlate32) x == x where types = x :: Word32           prop_xlate64 x = (xlate64 . xlate64) x == x where types = x :: Word64 -posix = [ testCase "getFileStatus" $ check_stat getFileStatus-        , testCase "getSymbolicLinkStatus" $ check_stat getSymbolicLinkStatus ]-    where check_stat fun = do-            x <- fileSize `fmap` fun "foo_a"-            writeFile "test_empty" ""-            y <- fileSize `fmap` fun "test_empty"-            exist_nonexistent <- fileExists `fmap` fun "test_does_not_exist"-            exist_existent <- fileExists `fmap` fun "test_empty"+          check_fixFrom = let f 0 = 0+                              f n = f (n - 1) in fixFrom f 5 @?= 0++          check_mmapEmpty = flip finally (removeFile "test_empty") $ do+                              Prelude.writeFile "test_empty" ""+                              x <- readSegment ("test_empty", Nothing)+                              x @?= BL.empty++          reachable' ref look roots = runIdentity $ reachable ref look roots++          check_reachable = let refs 0 = [1, 2]+                                refs 1 = [2]+                                refs 2 = [0, 4]+                                refs 3 = [4, 6, 7]+                                refs 4 = [0, 1]+                                set = S.fromList [1, 2]+                                map = M.fromList [ (n, refs n) | n <- [0..10] ]+                                reach = reachable' return (lookup map) set+                             in do M.keysSet reach @?= S.fromList [0, 1, 2, 4]++          prop_reach_subset (set :: S.Set Int, map :: M.Map Int [Int]) =+              M.keysSet (reachable' return (lookup map) set)+                   `S.isSubsetOf` M.keysSet map+          prop_reach_roots (set :: S.Set Int, map :: M.Map Int [Int]) =+              set `S.isSubsetOf` M.keysSet map+                      ==> set `S.isSubsetOf`+                            M.keysSet (reachable' return (lookup map) set)++          prop_reach_nonroots (set :: S.Set Int, map :: M.Map Int [Int]) =+              set `S.intersection` M.keysSet map+                      == M.keysSet (reachable' (return . const [])+                                   (lookup map) set)++          lookup :: (Ord a) => M.Map a [a] -> a -> Identity (Maybe (a, [a]))+          lookup m k = return $ case M.lookupIndex k m of+                                  Nothing -> Nothing+                                  Just i -> Just $ M.elemAt i m++posix = [ testCase "getFileStatus" $ check_stat Posix.getFileStatus+        , testCase "getSymbolicLinkStatus" $ check_stat Posix.getSymbolicLinkStatus ]+    where check_stat fun = flip finally (removeFile "test_empty") $ do+            x <- Posix.fileSize `fmap` fun "foo_a"+            Prelude.writeFile "test_empty" ""+            y <- Posix.fileSize `fmap` fun "test_empty"+            exist_nonexistent <- Posix.fileExists `fmap` fun "test_does_not_exist"+            exist_existent <- Posix.fileExists `fmap` fun "test_empty"             assertEqual "file size" x 2             assertEqual "file size" y 0             assertBool "existence check" $ not exist_nonexistent             assertBool "existence check" exist_existent +----------------------------------+-- Arbitrary instances+--++instance (Arbitrary a, Ord a) => Arbitrary (S.Set a)+    where arbitrary = S.fromList `fmap` arbitrary++instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v)+    where arbitrary = M.fromList `fmap` arbitrary+ instance Arbitrary Word32 where     arbitrary = do x <- arbitrary :: Gen Int                    return $ fromIntegral x@@ -221,6 +410,18 @@                    File _ -> arbitrary                    SubTree t -> return t +---------------------------+-- Other instances+--++instance Show (Int -> Int) where+    show f = "[" ++ intercalate ", " (map val [1..20]) ++ " ...]"+        where val x = show x ++ " -> " ++ show (f x)++-----------------------+-- Test utilities+--+ treeItemEq (File _) (File _) = True treeItemEq (SubTree s) (SubTree p) = s `treeEq` p treeItemEq _ _ = False@@ -228,3 +429,6 @@ treeEq t r = and $ zipTrees cmp t r     where cmp _ (Just a) (Just b) = a `treeItemEq` b           cmp _ _ _ = False++nondarcs (AnchoredPath (Name x:_)) _ | x == BS.pack "_darcs" = False+                                     | otherwise = True

@@ -20,7 +20,7 @@     , read      -- * Manipulating trees.-    , finish, filter, restrict, modifyTree ) where+    , finish, filter, restrict, modifyTree, updateTreePostorder ) where  import Prelude hiding( lookup, filter, read, all ) import Storage.Hashed.AnchoredPath@@ -218,17 +218,17 @@               let subs = (catMaybes [ (,) name `fmap` wibble path name item                                       | (name,item) <- listImmediate t ])               in t { items = M.mapMaybeWithKey (wibble path) $ items t-                   , listImmediate = subs-                   , treeHash = Nothing }+                   , listImmediate = subs }+                   -- , treeHash = Nothing }           wibble path name item =               let npath = path `appendPath` name in                   if predicate npath item                      then Just $ filterSub npath item                      else Nothing           filterSub npath (SubTree t) = SubTree $ filter' t npath-          filterSub npath (Stub stub _) =+          filterSub npath (Stub stub h) =               Stub (do x <- stub-                       return $ filter' x npath) Nothing+                       return $ filter' x npath) h -- Nothing           filterSub _ x = x  -- | Read a Blob into a Lazy ByteString. Might be backed by an mmap, use with@@ -265,7 +265,7 @@ -- high up the Tree branches as possible. The result is a pair of trees that do -- not share any identical subtrees. They are derived from the first and second -- parameters respectively and they are always fully expanded. It might be--- advantageous to feed the result into 'zipFiles'.+-- advantageous to feed the result into 'zipFiles' or 'zipTrees'. diffTrees :: Tree -> Tree -> IO (Tree, Tree) diffTrees left right =             if treeHash left `match` treeHash right@@ -347,3 +347,12 @@     error "Bug in descent in modifyTree." modifyTree _ (AnchoredPath []) Nothing =     error "Bug in descent in modifyTree."++updateTreePostorder :: (Tree -> Tree) -> Tree -> Tree+updateTreePostorder fun t =+    t { items = M.mapWithKey (curry $ snd . update) $ items t+      , listImmediate = map update $ listImmediate t+      , treeHash = Nothing }+  where update (k, SubTree s) = (k, SubTree $ fun $ updateTreePostorder fun s)+        update (k, File f) = (k, File f)+        update (k, Stub _ _) = error "Stubs not supported in updateTreePostorder"

@@ -12,25 +12,34 @@ import System.Directory( getCurrentDirectory, setCurrentDirectory ) import System.FilePath( (</>), isAbsolute ) import Data.Int( Int64 )+import Data.Maybe( catMaybes ) import Control.Exception.Extensible( catch, bracket, SomeException(..) ) import Control.Monad( when )+import Control.Monad.Identity( runIdentity )+import Control.Applicative( (<$>) )  import Foreign.ForeignPtr( withForeignPtr ) import Foreign.Ptr( plusPtr ) import Data.ByteString.Internal( toForeignPtr, memcpy ) -import Data.Bits( (.&.), (.|.), shift, shiftL, shiftR, Bits )+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 -newtype Hash = Hash (Maybe Int64, BS.ByteString) deriving (Show, Eq, Read)+import qualified Data.Set as S+import qualified Data.Map as M +newtype Hash = Hash (Maybe Int64, BS.ByteString) deriving (Show, Eq, Ord, Read)+ makeHash :: BS.ByteString -> Hash makeHash str = case BS.split '-' str of                  [h] -> Hash (Nothing, h)                  [s, h] -> Hash (Just $ read $ BS.unpack s, h)-                 _ -> error $ "Bad hash string " ++ show str+                 _ -> Hash (Nothing, str) -- ...  hashSetSize :: Hash -> Int64 -> Hash hashSetSize (Hash (_,h)) s = Hash (Just s, h)@@ -115,3 +124,32 @@             ((a .&. (bytemask `shift` 48) `shiftR` 40)) .|.             ((a .&. (bytemask `shift` 56) `shiftR` 56)) #endif++-- | Find a monadic fixed point of @f@ that is the least above @i@. (Will+-- happily diverge if there is none.)+mfixFrom :: (Eq a, Functor m, Monad m) => (a -> m a) -> a -> m a+mfixFrom f i = do x <- f i+                  if x == i then return i+                            else mfixFrom f x++-- | Find a fixed point of @f@ that is the least above @i@. (Will happily+-- diverge if there is none.)+fixFrom :: (Eq a) => (a -> a) -> a -> a+fixFrom f i = runIdentity $ mfixFrom (return . f) i++-- | For a @refs@ function, a @map@ (@key@ -> @value@) and a @rootSet@, find a+-- submap of @map@ such that all items in @map@ are reachable, through @refs@+-- from @rootSet@.+reachable :: forall monad key value. (Functor monad, Monad monad, Ord key, Eq value) =>+              (value -> monad [key])+           -> (key -> monad (Maybe (key, value)))+           -> S.Set key -> monad (M.Map key value)+reachable refs lookup rootSet =+    do lookupSet rootSet >>= mfixFrom expand+    where lookupSet :: S.Set key -> monad (M.Map key value)+          expand :: M.Map key value -> monad (M.Map key value)++          lookupSet s = do list <- mapM lookup (S.toAscList s)+                           return $ M.fromAscList (catMaybes list)+          expand from = do refd <- concat <$> mapM refs (M.elems from)+                           M.union from <$> lookupSet (S.fromList refd)

@@ -1,5 +1,5 @@ name:          hashed-storage-version:       0.3.6+version:       0.3.7 synopsis:      Hashed file storage support code.  description:   Support code for reading and manipulating hashed file storage@@ -46,6 +46,7 @@         Storage.Hashed.Index         Storage.Hashed.Monad         Storage.Hashed.Tree+        Storage.Hashed.Packed         Storage.Hashed.Darcs      if flag(diff)