hashed-storage 0.3.9 → 0.4.0

raw patch · 16 files changed

+1271/−868 lines, 16 filesdep +binarydep +dataencPVP ok

version bump matches the API change (PVP)

Dependencies added: binary, dataenc

API changes (from Hackage documentation)

Files

• Bundled/Posix.hsc +11/−12
• Bundled/SHA256.hs +8/−20
• NEWS +13/−0
• Storage/Hashed.hs +11/−112
• Storage/Hashed/AnchoredPath.hs +6/−10
• Storage/Hashed/Darcs.hs +231/−35
• Storage/Hashed/Diff.hs +3/−3
• Storage/Hashed/Hash.hs +80/−0
• Storage/Hashed/Index.hs +248/−200
• Storage/Hashed/Monad.hs +135/−181
• Storage/Hashed/Packed.hs +74/−77
• Storage/Hashed/Plain.hs +86/−0
• Storage/Hashed/Test.hs +192/−71
• Storage/Hashed/Tree.hs +147/−124
• Storage/Hashed/Utils.hs +9/−19
• hashed-storage.cabal +17/−4

@@ -31,10 +31,10 @@ ##endif  data FileStatus = FileStatus {-    fst_exists :: Bool,-    fst_mode :: CMode,-    fst_mtime :: CTime,-    fst_size :: FileOffset+    fst_exists :: !Bool,+    fst_mode :: !CMode,+    fst_mtime :: !CTime,+    fst_size :: !FileOffset  }  getFdStatus :: Fd -> IO FileStatus@@ -43,17 +43,16 @@  do_stat :: (Ptr CStat -> IO CInt) -> IO FileStatus do_stat stat_func = do-  allocaBytes sizeof_stat $ \p -> do+  allocaBytes sizeof_stat $! \p -> do      ret <- stat_func p-     err <- getErrno-     case (ret == -1 && err == eNOENT, ret == 0) of-        (True, _) -> return (FileStatus False 0 0 0)-        (False, True) -> do mode <- st_mode p+     if (ret == -1) then do err <- getErrno+                            if (err == eNOENT)+                               then return $! (FileStatus False 0 0 0)+                               else throwErrno "do_stat"+                    else do mode <- st_mode p                             mtime <- st_mtime p                             size <- st_size p-                            return (FileStatus True mode mtime-                                               (fromIntegral size))-        _ -> throwErrno "do_stat"+                            return $! FileStatus True mode mtime size {-# INLINE  do_stat #-}  isDirectory :: FileStatus -> Bool

@@ -18,28 +18,16 @@ import Foreign.C.Types import Numeric (showHex) import Foreign.C.String ( withCString )-#if __GLASGOW_HASKELL__ > 606 import Data.ByteString.Unsafe (unsafeUseAsCStringLen)-#else-import Data.ByteString.Base (unsafeUseAsCStringLen)-#endif-import qualified Data.ByteString as B+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BSI -sha256 :: B.ByteString -> String-sha256 p = unsafePerformIO $-              withCString (replicate 64 'x') $ \digestCString ->-              unsafeUseAsCStringLen p $ \(ptr,n) ->-              do let digest = castPtr digestCString :: Ptr Word8-                 c_sha256 ptr (fromIntegral n) digest-                 go digest 0 []-  where -- print it in 0-padded hex format-        go :: Ptr Word8 -> Int -> [String] -> IO String-        go q n acc | seq q n >= 32 = return $ concat (reverse acc)-                   | otherwise = do w <- peekElemOff q n-                                    go q (n+1) (draw w : acc)-        draw w = case showHex w [] of-                 [x] -> ['0', x]-                 x   -> x+sha256 :: BS.ByteString -> BS.ByteString+sha256 p = unsafePerformIO $ do+             digest <- BSI.create 32 $ \digest ->+                       unsafeUseAsCStringLen p $ \(ptr,n) ->+                           c_sha256 ptr (fromIntegral n) digest+             return $! digest  -- void sha256sum(const unsigned char *d, size_t n, unsigned char *md); --

@@ -0,0 +1,13 @@+hashed-storage 0.4.0+====================++- Index now uses a 32-byte representation for sha256 hashes, instead of a+  64-byte ascii-hex (base16) encoding.+- New module Storage.Hashed.Hash that exports a new incarnation of Hash data+  type and a number of utilities.+- The Tree type is overloaded over a monad type and is not bound to IO monad+  anymore.+- Index has been streamlined, the API has improved safety and the code has been+  extensively optimised.+- Support for creating new hashed trees with the <size>-<hash> format used in+  darcs 2.0.2 and newer has been dropped.

@@ -6,13 +6,13 @@     -- accessed. Use 'expand' to do this. However, many operations are     -- perfectly fine to be used on a stubbed Tree (and it is often more     -- efficient to do everything that can be done before expanding a Tree).-    readPlainTree, readDarcsHashed, readDarcsPristine+    readPlainTree, readDarcsHashed      -- * Blob access.-    , read, readSegment+    , readBlob      -- * Writing trees.-    , writePlainTree+    , writePlainTree, writeDarcsHashed      -- * Unsafe functions for the curious explorer.     --@@ -21,34 +21,27 @@     -- responsibly. Don't kill innocent kittens.     , floatPath, printPath ) where -import Prelude hiding ( catch, read, lines )+import Storage.Hashed.AnchoredPath import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BL-import Storage.Hashed.AnchoredPath-import Storage.Hashed.Utils-import Storage.Hashed.Darcs-import Storage.Hashed.Tree( Tree( listImmediate ), TreeItem(..), ItemType(..)-                          , Blob(..), emptyTree, makeTree, makeTreeWithHash-                          , list, read, find )-import System.FilePath( (</>) )-import System.Directory( getDirectoryContents, doesFileExist-                       , doesDirectoryExist, createDirectoryIfMissing )-import Codec.Compression.GZip( decompress )-import Control.Monad( forM_, unless )-import Bundled.Posix( getFileStatus, isDirectory, FileStatus )+import Storage.Hashed.Tree ( Tree, TreeItem(..), listImmediate, find, readBlob ) +-- For re-exports.+import Storage.Hashed.Darcs( readDarcsHashed, writeDarcsHashed )+import Storage.Hashed.Plain( readPlainTree, writePlainTree )+ ------------------------ -- For explorers --  -- | 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 ()+printPath :: Tree IO -> FilePath -> IO () printPath t p = print' $ find t (floatPath p)     where print' Nothing = putStrLn $ "ERROR: No object at " ++ p           print' (Just (File b)) = do             putStrLn $ "== Contents of file " ++ p ++ ":"-            BL.unpack `fmap` read b >>= putStr+            BL.unpack `fmap` readBlob b >>= putStr           print' (Just (SubTree t')) = do             putStrLn $ "== Listing Tree " ++ p ++ " (immediates only):"             putStr $ unlines $ map BS.unpack $ listNames t'@@ -56,97 +49,3 @@             putStrLn $ "== (not listing stub at " ++ p ++ ")"           listNames t' = [ n | (Name n, _) <- listImmediate t' ] -readPlainDir :: FilePath -> IO [(FilePath, FileStatus)]-readPlainDir dir =-    withCurrentDirectory dir $ do-      items <- getDirectoryContents "."-      sequence [ do st <- getFileStatus s-                    return (s, st)-                 | s <- items, not $ s `elem` [ ".", ".." ] ]---- | Read in a plain directory hierarchy from a filesystem. NB. The 'read'--- function on Blobs with such a Tree is susceptible to file content--- changes. Since we use mmap in 'read', this will break referential--- transparency and produce unexpected results. Please always make sure that--- all parallel access to the underlying filesystem tree never mutates--- files. Unlink + recreate is fine though (in other words, the sync/write--- operations below are safe).-readPlainTree :: FilePath -> IO Tree-readPlainTree dir = do-  items <- readPlainDir dir-  let subs = [-       let name = nameFromFilePath name'-        in if isDirectory status-              then (name,-                    Stub (readPlainTree (dir </> name')) Nothing)-              else (name, File $-                    Blob (readBlob name) Nothing)-            | (name', status) <- items ]-  return $ makeTree subs-    where readBlob (Name name) = readSegment (dir </> BS.unpack name, Nothing)---- | Read and parse a darcs-style hashed directory listing from a given @dir@--- and with a given @hash@.-readDarcsHashedDir :: FilePath -> Hash -> IO [(ItemType, Name, Hash)]-readDarcsHashedDir dir h = do-  compressed <- readSegment (dir </> BS.unpack (darcsFormatHash h), Nothing)-  let content = decompress compressed-  return $ if BL.null compressed-              then []-              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--- (found in _darcs/hashed_inventory).-readDarcsHashed :: FilePath -> Hash -> IO Tree-readDarcsHashed dir root = do-  items <- readDarcsHashedDir dir root-  subs <- sequence [-           case tp of-             BlobType -> return (d, File $-                                      Blob (readBlob h) (Just h))-             TreeType ->-                 do let t = readDarcsHashed dir h-                    return (d, Stub t (Just h))-           | (tp, d, h) <- items ]-  return $ makeTreeWithHash subs root-    where location h = (dir </> BS.unpack (darcsFormatHash h), Nothing)-          readBlob = fmap decompress . readSegment . location---- | Read in a darcs pristine tree. Handles the plain and hashed pristine--- cases. Does not (and will not) handle the no-pristine case, since that--- requires replaying patches. Cf. 'readDarcsHashed' and 'readPlainTree' that--- are used to do the actual 'Tree' construction.-readDarcsPristine :: FilePath -> IO Tree-readDarcsPristine dir = do-  let darcs = dir </> "_darcs"-      h_inventory = darcs </> "hashed_inventory"-  repo <- doesDirectoryExist darcs-  unless repo $ fail $ "Not a darcs repository: " ++ dir-  hashed <- doesFileExist h_inventory-  if hashed-     then do inv <- BS.readFile h_inventory-             let lines = BS.split '\n' inv-             case lines of-               [] -> return emptyTree-               (pris_line:_) ->-                   let hash = makeHash $ BS.drop 9 pris_line-                    in readDarcsHashed (darcs </> "pristine.hashed") hash-     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".-writePlainTree :: Tree -> FilePath -> IO ()-writePlainTree t dir = do-  createDirectoryIfMissing True dir-  forM_ (list t) write-    where write (p, File b) = write' p b-          write (p, SubTree _) =-              createDirectoryIfMissing True (anchorPath dir p)-          write _ = return ()-          write' p b = read b >>= BL.writeFile (anchorPath dir p)

@@ -2,10 +2,10 @@ -- anchored at a certain root (this is usually the Tree root). They are -- represented by a list of Names (these are just strict bytestrings). module Storage.Hashed.AnchoredPath-    ( Name(..), AnchoredPath(..), appendPath, anchorPath+    ( Name(..), AnchoredPath(..), anchoredRoot, appendPath, anchorPath     , isPrefix, parent, parents, catPaths, flatten, makeName     -- * Unsafe functions.-    , nameToFilePath, nameFromFilePath, floatBS, floatPath ) where+    , floatBS, floatPath ) where  import qualified Data.ByteString.Char8 as BS import Data.List( isPrefixOf, inits )@@ -18,14 +18,6 @@ newtype Name = Name BS.ByteString  deriving (Eq, Show, Ord) newtype AnchoredPath = AnchoredPath [Name] deriving (Eq, Show, Ord) --- | Unsafe.-nameToFilePath :: Name -> FilePath-nameToFilePath (Name p) = BS.unpack p---- | Unsafe.-nameFromFilePath :: FilePath -> Name-nameFromFilePath = Name . BS.pack- -- | Check whether a path is a prefix of another path. isPrefix :: AnchoredPath -> AnchoredPath -> Bool (AnchoredPath a) `isPrefix` (AnchoredPath b) = a `isPrefixOf` b@@ -35,6 +27,7 @@ appendPath (AnchoredPath p) n =     case n of       (Name s) | s == BS.empty -> AnchoredPath p+               | s == BS.pack "." -> AnchoredPath p                | otherwise -> AnchoredPath $ p ++ [n]  -- | Catenate two paths together. Not very safe, but sometimes useful@@ -76,3 +69,6 @@ floatPath = AnchoredPath . map (Name . BS.pack) . splitDirectories             . normalise . dropTrailingPathSeparator ++anchoredRoot :: AnchoredPath+anchoredRoot = AnchoredPath []

@@ -1,29 +1,39 @@+{-# LANGUAGE BangPatterns #-}+ -- | A few darcs-specific utility functions. These are used for reading and -- writing darcs and darcs-compatible hashed trees. module Storage.Hashed.Darcs where -import Storage.Hashed.Tree hiding ( read )-import Storage.Hashed.AnchoredPath-import Storage.Hashed.Utils+import Prelude hiding ( lookup )+import System.FilePath ( (</>) ) +import System.Directory( createDirectoryIfMissing, doesFileExist, doesDirectoryExist )+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 Data.List( sortBy ) import Data.Char( chr, ord, isSpace )+import Data.Maybe( fromJust, isNothing )+import qualified Data.Set as S+import Control.Monad.State.Strict -darcsFormatSize :: (Num a) => a -> BS.ByteString-darcsFormatSize s = BS.pack $ replicate (10 - length n) '0' ++ n-    where n = show s+import Storage.Hashed.Tree hiding ( lookup )+import qualified Storage.Hashed.Tree as Tree+import Storage.Hashed.AnchoredPath+import Storage.Hashed.Utils+import Storage.Hashed.Hash+import Storage.Hashed.Packed+import Storage.Hashed.Monad+import Storage.Hashed.Plain -darcsFormatHash :: Hash -> BS.ByteString-darcsFormatHash (Hash (Just s, h)) =-    BS.concat [ darcsFormatSize s-              , BS.singleton '-'-              , h ]-darcsFormatHash (Hash (Nothing, h)) = h+---------------------------------------------------------------------+-- Utilities for coping with the darcs directory format.+-- --- | 'decode_white' interprets the Darcs-specific \"encoded\" filenames+-- | 'darcsDecodeWhite' interprets the Darcs-specific \"encoded\" filenames --   produced by 'darcsEncodeWhite' -- --   > darcsDecodeWhite "hello\32\there" == "hello there"@@ -38,7 +48,7 @@ darcsDecodeWhite (c:cs) = c: darcsDecodeWhite cs darcsDecodeWhite "" = "" --- | 'encode_white' translates whitespace in filenames to a darcs-specific+-- | 'darcsEncodeWhite' 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. --@@ -52,29 +62,52 @@  darcsEncodeWhiteBS = BS.pack . darcsEncodeWhite . BS.unpack -darcsFormatDir :: Tree -> BL.ByteString-darcsFormatDir t = BL.fromChunks $ concatMap string-                     (sortBy cmp $ listImmediate t)+decodeDarcsHash bs = case BS.split '-' bs of+                       [s, h] | BS.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+                                    [(x, _)] -> Just x+                                    _ -> Nothing+                       _ -> Nothing++darcsLocation :: FilePath -> (Maybe Int, Hash) -> FileSegment+darcsLocation dir (s,h) = (dir </> (prefix s ++ BS.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++----------------------------------------------+-- Darcs directory format.+--++darcsFormatDir :: Tree m -> Maybe BL.ByteString+darcsFormatDir t = BL.fromChunks <$> concat <$>+                       mapM string (sortBy cmp $ listImmediate t)     where cmp (Name a, _) (Name b, _) = compare a b           string (Name name, item) =-              [ case item of-                  File _ -> BS.pack "file:\n"-                  SubTree _ -> BS.pack "directory:\n"-                  Stub _ _ ->-                      error "Trees with stubs not supported in darcsFormatDir.",-                darcsEncodeWhiteBS name, BS.singleton '\n',-                case itemHash item of-                  Nothing -> error $ "darcsFormatDir: missing hash on "-                                 ++ show name-                  Just h -> darcsFormatHash h,-                BS.singleton '\n' ]+              do header <- case item of+                             File _ -> Just $ BS.pack "file:\n"+                             SubTree _ -> Just $ BS.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' ] -darcsParseDir :: BL.ByteString -> [(ItemType, Name, Hash)]+darcsParseDir :: BL.ByteString -> [(ItemType, Name, Maybe Int, 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+                          decodeDarcsSize hash,+                          decodeDarcsHash hash) : parse r           where hash = BS.concat $ BL.toChunks h'       parse _ = []       header x@@ -82,10 +115,173 @@           | x == BL.pack "directory:" = TreeType           | otherwise = error $ "Error parsing darcs hashed dir: " ++ BL.unpack x +----------------------------------------+-- Utilities.+--+ -- | 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+darcsTreeHash :: Tree m -> Hash+darcsTreeHash t = case darcsFormatDir t of+                    Nothing -> NoHash+                    Just x -> sha256 x -darcsUpdateHashes tree =-    flip updateTreePostorder tree $ \ t -> t { treeHash = Just $ darcsTreeHash t }+-- The following two are mostly for experimental use in Packed.++darcsUpdateDirHashes tree = updateSubtrees update tree+    where update t = t { treeHash = darcsTreeHash t }++darcsUpdateHashes tree = updateTree update tree+    where update (SubTree t) = return . SubTree $ t { treeHash = darcsTreeHash t }+          update (File blob@(Blob con _)) =+              do hash <- sha256 <$> readBlob blob+                 return $ File (Blob con hash)++-------------------------------------------+-- Reading darcs pristine data+--++-- | Read and parse a darcs-style hashed directory listing from a given @dir@+-- and with a given @hash@.+readDarcsHashedDir :: FilePath -> (Maybe Int, Hash) -> IO [(ItemType, Name, Maybe Int, Hash)]+readDarcsHashedDir dir h = do+  exist <- doesFileExist $ fst (darcsLocation dir h)+  unless exist $ fail $ "error opening " ++ fst (darcsLocation dir h)+  compressed <- readSegment $ darcsLocation dir h+  let content = decompress compressed+  return $ if BL.null compressed+              then []+              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+-- (found in _darcs/hashed_inventory).+readDarcsHashed :: FilePath -> (Maybe Int, Hash) -> IO (Tree IO)+readDarcsHashed dir (_, NoHash) = fail "Cannot readDarcsHashed NoHash"+readDarcsHashed 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)+           | (tp, d, s, h) <- items ]+  return $ makeTreeWithHash subs hash+    where readBlob = fmap decompress . readSegment . darcsLocation dir++----------------------------------------------------+-- Writing darcs-style hashed trees.+--++-- | Write a Tree into a darcs-style hashed directory.+writeDarcsHashed :: Tree IO -> FilePath -> IO Hash+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 = BL.writeFile (dir </> BS.unpack (encodeBase16 $ sha256 bits)) (compress bits)+++-- | Create a hashed file from a 'FilePath' and content. In case the file exists+-- 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 fn content =+    liftIO $ do+      exist <- doesFileExist fn+      unless exist $ BL.writeFile fn content++-- | 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+-- out to same. Please note that actual filesystem files are never removed.+--+-- XXX This somehow manages to leak memory, in some usege scenarios (apparently+-- not even all). The only reproducer known so far is \"gorsvet pull\".+hashedTreeIO :: TreeIO a -- ^ action+             -> Tree IO -- ^ initial+             -> FilePath -- ^ directory+             -> IO (a, Tree IO)+hashedTreeIO action t dir =+    do runTreeMonad action $ initialState t syncHashed+    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+                  Just (SubTree s) -> updateSub c s+                  _ -> 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+                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)+                ns = SubTree (s { treeHash = hash })+            fsCreateHashedFile fn (compress dirdata)+            replaceItem path (Just ns)++--------------------------------------------------------------+-- Reading and writing packed pristine. EXPERIMENTAL.+----++-- | 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 IO)+readPackedDarcsPristine os 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 ]+       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"+                           Just seg -> readSegment seg++-- | 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 IO -> OS -> IO (OS, Hash)+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+       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 NoHash = False+          valid _ = True+

@@ -1,6 +1,6 @@ module Storage.Hashed.Diff where -import Prelude hiding ( read, lookup, filter )+import Prelude hiding ( lookup, filter ) import qualified Data.ByteString.Lazy.Char8 as BL import Storage.Hashed.Tree import Storage.Hashed.AnchoredPath@@ -12,8 +12,8 @@     do (from, to) <- diffTrees l r        diffs <- sequence $ zipCommonFiles diff from to        return $ BL.concat diffs-    where diff p a b = do x <- read a-                          y <- read b+    where diff p a b = do x <- readBlob a+                          y <- readBlob b                           return $ diff' p x y           diff' p x y =               case unifiedDiff x y of

@@ -0,0 +1,80 @@+module Storage.Hashed.Hash( Hash(..), encodeBase64u, decodeBase64u+                          , 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+import qualified Data.ByteString.Lazy as BL++import qualified Codec.Binary.Base64Url as B64U+import qualified Codec.Binary.Base16 as B16++import Data.Maybe( isJust, fromJust )+import Data.Char( toLower, toUpper )++data Hash = SHA256 !BS.ByteString+          | SHA1 !BS.ByteString+          | NoHash+            deriving (Show, Eq, Ord, Read)++base16 :: BS.ByteString -> BS.ByteString+debase16 :: BS.ByteString -> Maybe BS.ByteString+base64u :: BS.ByteString -> BS.ByteString+debase64u :: BS.ByteString -> Maybe BS.ByteString++base16 = BS.pack . map (BSI.c2w . toLower) . B16.encode . BS.unpack+base64u = BS.pack . map BSI.c2w . B64U.encode . BS.unpack+debase64u bs = case B64U.decode $ map BSI.w2c $ BS.unpack bs of+                 Just s -> Just $ BS.pack s+                 Nothing -> Nothing+debase16 bs = case B16.decode $ map (toUpper . BSI.w2c) $ BS.unpack bs of+                Just s -> Just $ BS.pack s+                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 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.+encodeBase16 :: Hash -> BS.ByteString+encodeBase16 (SHA256 bs) = base16 bs+encodeBase16 (SHA1 bs) = base16 bs+encodeBase16 NoHash = BS.empty++-- | Take a base64/url-encoded string and decode it as a "Hash". If the string+-- is malformed, yields NoHash.+decodeBase64u :: BS.ByteString -> Hash+decodeBase64u bs+    | BS.length bs == 44 && isJust (debase64u bs) = SHA256 (fromJust $ debase64u bs)+    | BS.length bs == 28 && isJust (debase64u bs) = SHA1 (fromJust $ debase64u bs)+    | otherwise = NoHash++-- | Take a base16-encoded string and decode it as a "Hash". If the string is+-- malformed, yields NoHash.+decodeBase16 :: BS.ByteString -> Hash+decodeBase16 bs | BS.length bs == 64 && isJust (debase16 bs) = SHA256 (fromJust $ debase16 bs)+                | BS.length bs == 40 && isJust (debase16 bs) = SHA1 (fromJust $ debase16 bs)+                | otherwise = NoHash++-- | Compute a sha256 of a (lazy) ByteString. However, although this works+-- correctly for any bytestring, it is only efficient if the bytestring only+-- has a sigle chunk.+sha256 :: BL.ByteString -> Hash+sha256 bits = SHA256 (SHA.sha256 $ BS.concat $ BL.toChunks bits)++rawHash :: Hash -> BS.ByteString+rawHash NoHash = error "Cannot obtain raw hash from NoHash."+rawHash (SHA1 s) = s+rawHash (SHA256 s) = s++match :: Hash -> Hash -> Bool+NoHash `match` _ = False+_ `match` NoHash = False+x `match` y = x == y

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, ScopedTypeVariables, NoMonomorphismRestriction #-}+{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses #-}  -- | 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@@ -12,35 +12,35 @@ -- 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--- of the file's content.+-- is a timestamp plus the file size. The file hashes are sha256's of the+-- file's content. -- -- There are two entry types, a file entry and a directory entry. Both have a -- common binary format (see 'Item'). The on-disk format is best described by -- 'peekItem'. ----- For each file, the index has a copy of the timestamp taken at the instant--- when the hash has been computed. This means that when file size and--- timestamp of a file in working copy matches those in the index, we assume--- that the hash stored in the index for given file is valid. These hashes are--- then exposed in the resulting 'Tree' object, and can be leveraged by eg.--- 'diffTrees' to compare many files quickly.+-- For each file, the index has a copy of the file's last modification+-- timestamp taken at the instant when the hash has been computed. This means+-- that when file size and timestamp of a file in working copy matches those in+-- the index, we assume that the hash stored in the index for given file is+-- valid. These hashes are then exposed in the resulting 'Tree' object, and can+-- be leveraged by eg.  'diffTrees' to compare many files quickly. -- -- You may have noticed that we also keep hashes of directories. These are--- assumed to be valid whenever the complete subtree has had valid--- timestamps. At any point, as soon as a size or timestamp mismatch is found,--- the working file in question is opened, its hash (and timestamp and size) is--- recomputed and updated in-place in the index file (everything lives at a--- fixed offset and is fixed size, so this isn't an issue). This is also true--- of directories: when a file in a directory changes hash, this triggers--- recomputation of all of its parent directory hashes; moreover this is done--- efficiently -- each directory is updated at most once during a run.+-- assumed to be valid whenever the complete subtree has been valid. At any+-- point, as soon as a size or timestamp mismatch is found, the working file in+-- question is opened, its hash (and timestamp and size) is recomputed and+-- updated in-place in the index file (everything lives at a fixed offset and+-- is fixed size, so this isn't an issue). This is also true of directories:+-- when a file in a directory changes hash, this triggers recomputation of all+-- of its parent directory hashes; moreover this is done efficiently -- each+-- directory is updated at most once during an update run. -module Storage.Hashed.Index( readIndex, updateIndexFrom, readOrUpgradeIndex-                           , indexFormatValid )+module Storage.Hashed.Index( readIndex, updateIndexFrom, indexFormatValid+                           , updateIndex , Index, filter )     where -import Prelude hiding ( lookup, readFile, writeFile, catch )+import Prelude hiding ( lookup, readFile, writeFile, catch, filter ) import Storage.Hashed.Utils import Storage.Hashed.Tree import Storage.Hashed.AnchoredPath@@ -56,10 +56,13 @@ import System.Directory( removeFile, doesFileExist, renameFile ) import System.FilePath( (<.>) ) import Control.Monad( when )+import Control.Applicative( (<$>) ) -import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import Data.ByteString.Unsafe( unsafeHead, unsafeDrop ) import Data.ByteString.Internal( toForeignPtr, fromForeignPtr, memcpy-                               , nullForeignPtr )+                               , nullForeignPtr, c2w )  import Data.IORef( newIORef, readIORef, modifyIORef, IORef ) import Data.Maybe( fromJust, isJust )@@ -69,6 +72,8 @@ import Foreign.ForeignPtr import Foreign.Ptr +import Storage.Hashed.Hash( sha256, rawHash )+ -------------------------- -- Indexed trees --@@ -82,25 +87,46 @@ -- with our internal data structures -- we need to turn the flat index into a -- recursive Tree object, which is rather expensive... As a bonus, we can also -- efficiently implement subtree queries this way (cf. 'readIndex').-data Item = Item { iPath :: BS.ByteString-                 , iName :: BS.ByteString-                 , iHash :: BS.ByteString-                 , iSize :: Ptr Int64-                 , iAux :: Ptr Int64 -- end-offset for dirs, mtime for files+data Item = Item { iBase :: !(Ptr ())+                 , iHashAndDescriptor :: !BS.ByteString                  } deriving Show -itemSize :: Item -> Int-itemSize i = 4 + (BS.length $ iPath i) + 1 + 64 + 16+size_magic :: Int+size_magic = 4 -- the magic word, first 4 bytes of the index -itemSizeI :: (Num a) => Item -> a-itemSizeI = fromIntegral . itemSize+size_dsclen, size_hash, size_size, size_aux :: Int+size_size = 8 -- file/directory size (Int64)+size_aux = 8 -- aux (Int64)+size_dsclen = 4 -- this many bytes store the length of the path+size_hash = 32 -- hash representation -itemIsDir :: Item -> Bool-itemIsDir i = BS.last (iPath i) == '/'+off_size, off_aux, off_hash, off_dsc :: Int+off_size = 0+off_aux = off_size + size_size+off_dsclen = off_aux + size_aux+off_hash = off_dsclen + size_dsclen+off_dsc = off_hash + size_hash -noslashpath :: Item -> FilePath-noslashpath i = BS.unpack $ itemIsDir i ? (BS.init $ iPath i, iPath i)+itemAllocSize :: AnchoredPath -> Int+itemAllocSize path =+    align 4 $ size_hash + size_size + size_aux + size_dsclen + 2 + BS.length (flatten path) +itemSize, itemNext :: Item -> Int+itemSize i = size_size + size_aux + size_dsclen + (BS.length $ iHashAndDescriptor i)+itemNext i = align 4 (itemSize i + 1)++iPath, iHash, iDescriptor :: Item -> BS.ByteString+iDescriptor = unsafeDrop size_hash . iHashAndDescriptor+iPath = unsafeDrop 1 . iDescriptor+iHash = BS.take size_hash . iHashAndDescriptor++iSize, iAux :: Item -> Ptr Int64+iSize i = plusPtr (iBase i) off_size+iAux i = plusPtr (iBase i) off_aux++itemIsDir :: Item -> Bool+itemIsDir i = unsafeHead (iDescriptor i) == c2w 'D'+ -- xlatePeek32 = fmap xlate32 . peek xlatePeek64 :: (Storable a, Bits a) => Ptr a -> IO a xlatePeek64 = fmap xlate64 . peek@@ -115,17 +141,17 @@ -- the item can be filled out using 'update'. createItem :: ItemType -> AnchoredPath -> ForeignPtr () -> Int -> IO Item createItem typ path fp off =- do let name = BS.concat [ flatten path,-                           (typ == TreeType) ? (BS.singleton '/', BS.empty),-                           BS.singleton '\0' ]-        (namefp, nameoff, namel) = toForeignPtr name+ do let dsc = BS.concat [ BS8.singleton $ (typ == TreeType) ? ('D', 'F')+                        , flatten path+                        , BS.singleton 0 ]+        (dsc_fp, dsc_start, dsc_len) = toForeignPtr dsc     withForeignPtr fp $ \p ->-        withForeignPtr namefp $ \namep ->-            do pokeByteOff p off (xlate32 $ fromIntegral namel :: Int32)-               memcpy (plusPtr p $ off + 4)-                      (plusPtr namep nameoff)-                      (fromIntegral namel)-               peekItem fp off Nothing+        withForeignPtr dsc_fp $ \dsc_p ->+            do pokeByteOff p (off + off_dsclen) dsc_len+               memcpy (plusPtr p $ off + off_dsc)+                      (plusPtr dsc_p dsc_start)+                      (fromIntegral dsc_len)+               peekItem fp off  -- | Read the on-disk representation into internal data structure. The Index is -- organised into "lines" where each line describes a single indexed@@ -143,38 +169,31 @@ -- and after it come all its items. Cf. 'readIndex''. -- -- For files, the aux field holds a timestamp.-peekItem :: ForeignPtr () -> Int -> Maybe Int -> IO Item-peekItem fp off dirlen =+peekItem :: ForeignPtr () -> Int -> IO Item+peekItem fp off =     withForeignPtr fp $ \p -> do-      nl' :: Int32 <- xlate32 `fmap` peekByteOff p off+      nl' :: Int32 <- xlate32 `fmap` peekByteOff p (off + off_dsclen)+      when (nl' <= 2) $ fail "Descriptor too short in peekItem!"       let nl = fromIntegral nl'-          path = fromForeignPtr (castForeignPtr fp) (off + 4) (nl - 1)-          path_noslash = (BS.last path == '/') ? (BS.init path, path)-          hash = fromForeignPtr (castForeignPtr fp) (off + 4 + nl) 64-          name = snd $ case dirlen of-                         Just split -> BS.splitAt split path_noslash-                         Nothing -> BS.spanEnd (/= '/') path_noslash-      return $! Item { iName = name-                     , iPath = path-                     , iHash = hash-                     , iSize = plusPtr p (off + 4 + nl + 64)-                     , iAux = plusPtr p (off + 4 + nl + 64 + 8)-                     }+          dsc = fromForeignPtr (castForeignPtr fp) (off + off_hash) (size_hash + nl - 1)+      return $! Item { iBase = plusPtr p off+                     , iHashAndDescriptor = dsc }  -- | Update an existing item with new hash and optionally mtime (give Nothing -- when updating directory entries).-update :: Item -> Maybe EpochTime -> Hash -> IO ()-update item mtime (Hash (Just size, hash)) =+updateItem :: Item -> Int64 -> Hash -> IO ()+updateItem item _ NoHash =+    fail $ "Index.update NoHash: " ++ BS8.unpack (iPath item)+updateItem item size hash =     do xlatePoke64 (iSize item) size-       pokeBS (iHash item) hash-       when (isJust mtime) $ xlatePoke64 (iAux item)-                                  (fromIntegral $ fromEnum $ fromJust mtime)-update _ _ _ = fail "Index.update requires a hash with size included."+       unsafePokeBS (iHash item) (rawHash hash) -iHash' :: Item -> IO Hash-iHash' i = do size <- xlatePeek64 $ iSize i-              return $ hashSetSize (Hash (undefined, iHash i)) size+updateAux item aux = xlatePoke64 (iAux item) $ aux+updateTime item mtime = updateAux item (fromIntegral $ fromEnum mtime) +iHash' :: Item -> Hash+iHash' i = SHA256 (iHash i)+ -- | Gives a ForeignPtr to mmapped index, which can be used for reading and -- updates. mmapIndex :: forall a. FilePath -> Int -> IO (ForeignPtr a, Int)@@ -188,129 +207,151 @@   case size of     0 -> return (castForeignPtr nullForeignPtr, size)     _ -> do (x, _) <- mmapFileForeignPtr indexpath-                                         ReadWrite (Just (0, size + 4))+                                         ReadWrite (Just (0, size + size_magic))             return (x, size) --- | See 'readIndex'. This version also gives a map from paths to items, so the--- extra per-item data can be used (hash and mtime) directly. The map is in a--- form of 'IORef', since the data is not available until the tree is expanded.-readIndex' :: FilePath -> (Tree -> Hash)-           -> IO (Tree, IORef (M.Map AnchoredPath Item))-readIndex' indexpath hashtree = do-  (mmap, mmap_size) <- mmapIndex indexpath 0-  dirs_changed <- newIORef S.empty-  item_map <- newIORef M.empty-  let readItem :: AnchoredPath -> Int -> Int -> IO (Item, Maybe TreeItem)-      readItem parent_path off dl =-          do item <- peekItem mmap off (Just dl)-             x <- if itemIsDir item then readDir parent_path item off dl-                                    else readFile parent_path item-             when (isJust x) $ modifyIORef item_map $ \m ->-                 M.insert (parent_path `appendPath` (Name $ iName item)) item m-             return (item, x)-      readDir :: AnchoredPath -> Item -> Int -> Int -> IO (Maybe TreeItem)-      readDir parent_path item off dl =-          do dirend <- xlatePeek64 $ iAux item-             st <- getFileStatus (noslashpath item)-             let this_path = parent_path `appendPath` (Name $ iName item)-                 nl = BS.length (iName item)-                 dl' = dl + (nl == 0) ? (0, 1 + nl)-                 subs coff | coff < dirend = do-                   (idx_item, tree_item) <- readItem this_path-                                                     (fromIntegral coff) dl'-                   next <- if itemIsDir idx_item-                              then xlatePeek64 $ iAux idx_item-                              else return $ coff + itemSizeI idx_item-                   rest <- subs next-                   case tree_item of-                     Nothing -> return $! rest-                     Just ti -> return $! (Name $ iName idx_item, ti) : rest-                 subs coff | coff == dirend = return []-                           | otherwise = fail "Offset mismatch."-                 updateHash path tree =-                     do changed <- S.member path `fmap` readIORef dirs_changed-                        let hash = hashtree tree-                            tree' = tree { treeHash = Just hash }-                        if changed-                           then do update item Nothing hash-                                   return tree'-                           else return tree-             treehash <- iHash' item-             let rt = Stub (do s <- subs $ fromIntegral (off + itemSize item)-                               return $ (makeTree s)-                                        { finish = updateHash this_path-                                        , treeHash = Just treehash })-                           (Just treehash)-             return $ if fileExists st then Just rt else Nothing-      readFile parent_path item =-          do st <- getFileStatusBS (iPath item)-             mtime <- fromIntegral `fmap` (xlatePeek64 $ iAux item)-             size <- xlatePeek64 $ iSize item-             let mtime' = modificationTime st-                 size' = fileSize st-                 readblob = readSegment (BS.unpack $ iPath item, Nothing)-             when ( mtime /= mtime' || size /= fromIntegral size' ) $-                  do hash_' <- sha256 `fmap` readblob-                     let hash' = hashSetSize hash_' (fromIntegral size')-                     update item (Just mtime') hash'-                     modifyIORef dirs_changed $ \s ->-                         S.union (S.fromList $ parent_path : parents parent_path) s-             hash <- iHash' item-             if fileExists st-                then return $ Just $ File (Blob readblob $ Just hash)-                else return Nothing-  if mmap_size > 0 then-      do (_, Just (Stub root h)) <- readItem (AnchoredPath []) 4 (-2)-         tree <- root-         return (tree { treeHash = h }, item_map)-    else return (emptyTree, item_map)+data IndexM m = Index { mmap :: (ForeignPtr ())+                      , hashtree :: Tree m -> Hash+                      , predicate :: AnchoredPath -> TreeItem m -> Bool }+              | EmptyIndex +type Index = IndexM IO++data State = State { dirlength :: !Int+                   , path :: !AnchoredPath+                   , start :: !Int }++data Result = Result { changed :: !Bool+                     , next :: !Int+                     , treeitem :: !(Maybe (TreeItem IO))+                     , resitem :: !Item }++readItem :: Index -> State -> IO Result+readItem index state = do+  item <- peekItem (mmap index) (start state)+  res' <- if itemIsDir item+              then readDir  index state item+              else readFile index state item+  return res'++readDir :: Index -> State -> Item -> IO Result+readDir index state item =+    do following <- fromIntegral <$> xlatePeek64 (iAux item)+       exists <- fileExists <$> getFileStatusBS (iPath item)+       let name it dirlen = Name $ (BS.drop (dirlen + 1) $ iDescriptor it) -- FIXME MAGIC+           namelength = (BS.length $ iDescriptor item) - (dirlength state) -- FIXME MAGIC+           myname = name item (dirlength state)+           substate = state { start = start state + itemNext item+                            , path = path state `appendPath` myname+                            , dirlength = if myname == Name (BS8.singleton '.')+                                             then dirlength state+                                             else dirlength state + namelength }++           want = exists && (predicate index) (path substate) (Stub undefined NoHash)+           oldhash = iHash' item++           subs off | off < following = do+             result <- readItem index $ substate { start = off }+             rest <- subs $ next result+             case treeitem result of+               Nothing -> return $! rest+               Just ti -> 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 []++       let we_changed = or [ changed x | (_, x) <- inferiors ]+           tree' = makeTree [ (n, fromJust $ treeitem s) | (n, s) <- inferiors, isJust $ treeitem s ]+           treehash = we_changed ? (hashtree index tree', oldhash)+           tree = tree' { treeHash = treehash }++       when we_changed $ updateItem item 0 treehash+       return $ Result { changed = not exists || we_changed+                       , next = following+                       , treeitem = if want then Just $ SubTree tree+                                            else Nothing+                       , resitem = item }++readFile :: Index -> State -> Item -> IO Result+readFile index state item =+    do st <- getFileStatusBS (iPath item)+       mtime <- fromIntegral <$> (xlatePeek64 $ iAux item)+       size <- xlatePeek64 $ iSize item+       let mtime' = modificationTime st+           size' = fromIntegral $ fileSize st+           readblob = readSegment (BS8.unpack $ iPath item, Nothing)+           exists = fileExists st+           we_changed = mtime /= mtime' || size /= size'+           hash = iHash' item+       when we_changed $+            do hash' <- sha256 `fmap` readblob+               updateItem item size' hash'+               updateTime item mtime'+       return $ Result { changed = not exists || we_changed+                       , next = start state + itemNext item+                       , treeitem = exists ? (Just $ File $ Blob readblob hash, Nothing)+                       , resitem = item }++updateIndex :: Index -> IO (Tree IO)+updateIndex EmptyIndex = return emptyTree+updateIndex index =+    do let initial = State { start = size_magic+                           , dirlength = 0+                           , path = AnchoredPath [] }+       res <- readItem index initial+       case treeitem res of+         Just (SubTree tree) -> return $ filter (predicate index) tree+         _ -> fail "Unexpected failure in updateIndex!"+ -- | Read an index and build up a 'Tree' object from it, referring to current--- working directory. Any parts of the index that are out of date are updated--- in-place. The result is always an up-to-date index. Also, the 'Tree' is--- stubby and only the pieces of the index that are expanded will be actually--- updated!  To implement a subtree query, you can use 'Tree.filter' and then--- expand the result. Otherwise just expand the whole tree to avoid unexpected--- problems.-readIndex :: FilePath -> (Tree -> Hash) -> IO Tree-readIndex x y = fst `fmap` readIndex' x y -- pointfree is uglier+-- working directory. The initial Index object returned by readIndex is not+-- directly useful. However, you can use 'Tree.filter' on it. Either way, to+-- obtain the actual Tree object, call update.+--+-- The usual use pattern is this:+--+-- > do (idx, update) <- readIndex+-- >    tree <- update =<< filter predicate idx+--+-- The resulting tree will be fully expanded.+readIndex :: FilePath -> (Tree IO -> Hash) -> IO Index+readIndex indexpath ht = do+  (mmap, mmap_size) <- mmapIndex indexpath 0+  return $ if mmap_size == 0 then EmptyIndex+                             else Index { mmap = mmap+                                        , hashtree = ht+                                        , predicate = \_ _ -> True } --- | 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 -> Hash) -> Tree -> IO Tree-updateIndexFrom indexpath hashtree ref =-    do (oldidx', item_map') <- readIndex' indexpath hashtree-       expand oldidx'-       item_map <- readIORef item_map'-       reference <- expand ref-       let typeLen TreeType = 1-           typeLen BlobType = 0-           paths = [ (p, itemType i) | (p, i) <- list reference ]-           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 =+formatIndex :: ForeignPtr () -> Tree IO -> Tree IO -> IO ()+formatIndex mmap 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-                  case M.lookup path item_map of+                  let flatpath = BS8.unpack $ flatten path+                  case find old path of                     Nothing -> return ()-                    Just item -> do mtime <- xlatePeek64 $ iAux item-                                    hash <- iHash' item-                                    update i (Just $ fromIntegral mtime) hash-                  return $ off + itemSize i-           create (SubTree s) path off =+                    -- TODO calling getFileStatus here is both slightly+                    -- inefficient and slightly race-prone+                    Just ti -> do st <- getFileStatus flatpath+                                  let hash = itemHash ti+                                      mtime = modificationTime st+                                      size = fileSize st+                                  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 M.lookup path item_map of+                  case find old path of                     Nothing -> return ()-                    Just item -> iHash' item >>= update i Nothing-                  let subs [] = return $ off + itemSize i+                    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                         noff <- subs xs@@ -318,10 +359,26 @@                   lastOff <- subs (listImmediate s)                   xlatePoke64 (iAux i) (fromIntegral lastOff)                   return lastOff-           create (Stub _ _) path _ =+          create (Stub _ _) path _ =                fail $ "Cannot create index from stubbed Tree at " ++ show path-       pokeBS magic (BS.pack "HSI1")-       create (SubTree reference) (AnchoredPath []) 4++-- | 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+       reference <- expand ref+       let len_root = itemAllocSize anchoredRoot+           len = len_root + sum [ itemAllocSize p | (p, _) <- list reference ]+       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+       formatIndex mmap old_idx reference        readIndex indexpath hashtree  -- | Check that a given file is an index file with a format we can handle. You@@ -329,21 +386,12 @@ indexFormatValid :: FilePath -> IO Bool indexFormatValid path = do   fd <- openBinaryFile path ReadMode-  magic <- sequence [ hGetChar fd | _ <- [1..4] :: [Int] ]+  magic <- sequence [ hGetChar fd | _ <- [1..size_magic] :: [Int] ]   hClose fd   return $ case magic of-             "HSI1" -> True+             "HSI4" -> True              _ -> False --- | DEPRECATED! Read index (just like readIndex). However, also check that the--- index version matches our expectations and if not, rebuild it from the--- reference (which is provided in form of un-executed action; we will only--- execute it when needed).-readOrUpgradeIndex :: FilePath -> (Tree -> Hash) -> IO Tree -> IO Tree-readOrUpgradeIndex path hashtree getref = do-  valid <- indexFormatValid path-  if valid then readIndex path hashtree-           else do ref <- getref >>= expand-                   removeFile path-                   updateIndexFrom path hashtree ref-+instance FilterTree IndexM IO where+    filter _ EmptyIndex = EmptyIndex+    filter pred index = index { predicate = \a b -> predicate index a b && pred a b }

@@ -1,26 +1,30 @@-{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables, BangPatterns, TypeSynonymInstances, UndecidableInstances #-}  -- | An experimental monadic interface to Tree mutation. The main idea is to -- simulate IO-ish manipulation of real filesystem (that's the state part of -- the monad), and to keep memory usage down by reasonably often dumping the--- intermediate data to disk and forgetting it. XXX This currently does not--- work as advertised and the monads leak memory. So far, I'm at a loss why--- this happens.+-- intermediate data to disk and forgetting it. The monad interface itself is+-- generic, and a number of actual implementations can be used. This module+-- provides just 'virtualTreeIO' that never writes any changes, but may trigger+-- filesystem reads as appropriate.+--+-- XXX This currently does not work as advertised and the monads leak+-- memory. So far, I'm at a loss why this happens. module Storage.Hashed.Monad-    ( hashedTreeIO, plainTreeIO, virtualTreeIO+    ( virtualTreeIO, virtualTreeMonad     , readFile, writeFile, createDirectory, rename, unlink-    , fileExists, directoryExists, exists-    , tree, cwd, TreeState, TreeIO+    , fileExists, directoryExists, exists, withDirectory+    , tree, TreeState, TreeMonad, TreeIO, runTreeMonad+    , PathSet, initialState, replaceItem     ) where -import Prelude hiding ( read, catch, readFile, writeFile )+import Prelude hiding ( readFile, writeFile )  import Storage.Hashed.AnchoredPath import Storage.Hashed.Tree-import Storage.Hashed.Utils-import Storage.Hashed.Darcs+import Storage.Hashed.Hash -import Control.Exception.Extensible( catch, SomeException(..) )+import Control.Monad.Error( catchError, throwError, MonadError )  import System.Directory( createDirectoryIfMissing, doesFileExist ) import System.FilePath( (</>) )@@ -32,16 +36,17 @@  import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.ByteString.Char8 as BS-import Control.Monad.State.Strict+import Control.Monad.RWS.Strict import qualified Data.Set as S +type PathSet = S.Set AnchoredPath+ -- | Internal state of the 'TreeIO' monad. Keeps track of the current Tree -- content, unsync'd changes and a current working directory (of the monad).-data TreeState = TreeState { cwd :: AnchoredPath-                           , tree :: Tree-                           , changed :: S.Set AnchoredPath-                           , changesize :: Int64-                           , sync :: TreeIO () }+data TreeState m = TreeState { tree :: Tree m+                             , changed :: PathSet+                             , changesize :: Int64+                             , sync :: PathSet -> TreeMonad m () }  -- | A 'TreeIO' monad. A sort of like IO but it keeps a 'TreeState' around as well, -- which is a sort of virtual filesystem. Depending on how you obtained your@@ -50,190 +55,139 @@ -- filesystem, however with 'plainTreeIO', the plain tree will be updated every -- now and then, and with 'hashedTreeIO' a darcs-style hashed tree will get -- updated.-type TreeIO = StateT TreeState IO+type TreeMonad m = RWST AnchoredPath () (TreeState m) m+type TreeIO = TreeMonad IO -initialState :: Tree -> TreeIO () -> TreeState-initialState t s = TreeState { cwd = AnchoredPath []-                             , tree = t+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 ()+    -- | 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).+    exists :: (MonadError e m) => AnchoredPath -> m Bool+    -- | Check for existence of a directory.+    directoryExists :: (MonadError e m) => AnchoredPath -> m Bool+    -- | Check for existence of a file.+    fileExists :: (MonadError e m) => AnchoredPath -> m Bool++class TreeRO m => TreeRW m where+    -- | Change content of a file at a given path. The change will be+    -- eventually flushed to disk, but might be buffered for some time.+    writeFile :: (MonadError e m) => AnchoredPath -> BL.ByteString -> m ()+    createDirectory :: (MonadError e m) => AnchoredPath -> m ()+    unlink :: (MonadError e m) => AnchoredPath -> m ()+    rename :: (MonadError e m) => AnchoredPath -> AnchoredPath -> m ()++initialState :: Tree m -> (PathSet -> TreeMonad m ()) -> TreeState m+initialState t s = TreeState { tree = t                              , changed = S.empty                              , changesize = 0                              , sync = s } -runTreeIO :: TreeIO a -> TreeState -> IO (a, Tree)-runTreeIO action initial = do-  (out, final) <- runStateT (do x <- action-                                get >>= sync-                                return x) initial-  return (out, tree final)---- | Run a TreeIO action without dumping anything to disk. Useful for running--- tree mutations just for the purpose of getting the resulting Tree and--- throwing it away.-virtualTreeIO :: TreeIO a -> Tree -> IO (a, Tree)-virtualTreeIO action t = runTreeIO action $ initialState t (return ())---- | Create a hashed file from a 'FilePath' and content. In case the file exists--- 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 fn content =-    liftIO $ do-      exist <- doesFileExist fn-      unless exist $ BL.writeFile fn content--replaceItemAbs :: AnchoredPath -> Maybe TreeItem -> TreeIO ()-replaceItemAbs path item =-    modify $ \st -> st { tree = modifyTree (tree st) path item }--replaceItem :: AnchoredPath -> Maybe TreeItem -> TreeIO ()-replaceItem path item =-    modify $ \st -> st { tree = modifyTree (tree st)-                                           (cwd st `catPaths` path) item }--expandTo :: AnchoredPath -> TreeIO ()-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--- out to same. Please note that actual filesystem files are never removed.------ XXX This somehow manages to leak memory, somewhere.-hashedTreeIO :: TreeIO a -- ^ action-             -> Tree -- ^ initial-             -> FilePath -- ^ directory-             -> IO (a, Tree)-hashedTreeIO action t dir =-    do runTreeIO action $ initialState t syncHashed-    where syncHashed = do-            ch <- gets changed-            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-                  _ -> 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)-            newcontent <- liftIO $ compress `fmap` read b-            fsCreateHashedFile fn newcontent-            replaceItemAbs path (Just nblob)-          updateFile path b@(Blob _ Nothing) = do-            content <- liftIO $ read b-            let h = hashSetSize (sha256 content) (BL.length content)-                fn = dir </> BS.unpack (darcsFormatHash h)-                nblob = File $ Blob (decompress `fmap` BL.readFile fn) (Just h)-                newcontent = compress content-            fsCreateHashedFile fn newcontent-            replaceItemAbs path (Just nblob)-          updateSub path s = do-            let !hash = darcsTreeHash s-                dirdata = darcsFormatDir s-                fn = dir </> BS.unpack (darcsFormatHash $ hash)-                ns = SubTree (s { treeHash = Just hash })-            fsCreateHashedFile fn (compress dirdata)-            replaceItemAbs path (Just ns)---- | Run a 'TreeIO' action in a plain tree setting. Writes out changes to the--- plain tree every now and then (after the action is finished, the last tree--- state is always flushed to disk). XXX Modify the tree with filesystem--- reading and put it back into st (ie. replace the in-memory Blobs with normal--- ones, so the memory can be GCd).-plainTreeIO :: TreeIO a -> Tree -> FilePath -> IO (a, Tree)-plainTreeIO action t dir = runTreeIO action $ initialState t syncPlain-    where syncPlain = do-            ch <- gets changed-            modify $ \st -> st { changed = S.empty, changesize = 0 }-            current  <- gets tree-            forM_ (S.toList ch) $ \c -> do-                let path = anchorPath dir c-                case find current c of-                  Just (File b) -> do-                    liftIO $ read b >>= BL.writeFile path-                    let nblob = File $ Blob (BL.readFile path) Nothing-                    modify $ \st -> st { tree = modifyTree (tree st) c-                                                           (Just nblob) }-                  Just (SubTree _) ->-                      liftIO $ createDirectoryIfMissing False path-                  _ -> fail $ "Foo at " ++ path+flush :: (Monad m) => TreeMonad m ()+flush = do+  current <- get+  modify $ \st -> st { changed = S.empty, changesize = 0 }+  sync current (changed current) --- | Check for existence of a file.-fileExists :: AnchoredPath -> TreeIO Bool-fileExists p = do expandTo p-                  (isJust . (flip findFile p)) `fmap` gets tree+runTreeMonad :: (Monad m) => TreeMonad m a -> TreeState m -> m (a, Tree m)+runTreeMonad action initial = do+  let action' = do x <- action+                   flush+                   return x+  (out, final, _) <- runRWST action' (AnchoredPath []) initial+  return (out, tree final) --- | Check for existence of a directory.-directoryExists :: AnchoredPath -> TreeIO Bool-directoryExists p = do expandTo p-                       (isJust . (flip findTree p)) `fmap` gets tree+-- | Run a TreeIO action without storing any changes. This is useful for+-- running monadic tree mutations for obtaining the resulting Tree (as opposed+-- to their effect of writing a modified tree to disk). The actions can do both+-- read and write -- reads are passed through to the actual filesystem, but the+-- writes are held in memory in a form of modified Tree.+virtualTreeMonad :: (Monad m) => TreeMonad m a -> Tree m -> m (a, Tree m)+virtualTreeMonad action t = runTreeMonad action $ initialState t (\_ -> return ()) --- | Check for existence of a node (file or directory, doesn't matter).-exists :: AnchoredPath -> TreeIO Bool-exists p = do expandTo p-              (isJust . (flip find p)) `fmap` gets tree+virtualTreeIO :: TreeIO a -> Tree IO -> IO (a, Tree IO)+virtualTreeIO = virtualTreeMonad --- | Grab content of a file in the current Tree at the given path.-readFile :: AnchoredPath -> TreeIO BL.ByteString-readFile p = do expandTo p-                t <- gets tree-                let f = findFile t p-                case f of-                  Nothing -> fail $ "No such file " ++ show p-                  Just x -> liftIO (read x)+replaceItem :: (MonadError e m, Monad m) => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()+replaceItem path item = do+  path' <- (`catPaths` path) `fmap` currentDirectory+  modify $ \st -> st { tree = modifyTree (tree st) path' item }  -- | Internal. Mark a given path as changed, so the next sync will flush the -- modified object to disk.-markChanged :: AnchoredPath -> TreeIO ()+markChanged :: (Functor m, Monad m) => AnchoredPath -> TreeMonad m () markChanged p = do   x <- get-  size <- liftIO $ case findFile (tree x) p of-                     Just b -> BL.length `fmap` read b-                     Nothing -> return 0+  size <- lift $ case findFile (tree x) p of+                   Just b -> BL.length `fmap` readBlob b+                   Nothing -> return 0   put $ x { changed = S.union paths (changed x)           , changesize = changesize x + size }     where paths = let (AnchoredPath x) = p                    in S.fromList $ map AnchoredPath $ inits x --- | Change content of a file at a given path. The change will be eventually--- flushed to disk, but might be buffered for some time.-writeFile :: AnchoredPath -> BL.ByteString -> TreeIO ()-writeFile p con =-    do expandTo p-       replaceItem p (Just blob)-       markChanged p-       maybeSync-    where blob = File $ Blob (return con) hash-          hash = Just $ hashSetSize (sha256 con) (BL.length con)+-- | If buffers are becoming large, sync, otherwise do nothing.+maybeFlush :: (Monad m) => TreeMonad m ()+maybeFlush = do x <- gets changesize+                when (x > 100 * 1024 * 1024) $ flush -createDirectory :: AnchoredPath -> TreeIO ()-createDirectory p = do expandTo p-                       replaceItem p $ Just $ SubTree emptyTree+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' }+             _ -> return () -unlink :: AnchoredPath -> TreeIO ()-unlink p = do expandTo p-              replaceItem p Nothing+    fileExists p =+        do expandTo p+           (isJust . (flip findFile p)) `fmap` gets tree -rename :: AnchoredPath -> AnchoredPath -> TreeIO ()-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+    directoryExists p =+        do expandTo p+           (isJust . (flip findTree p)) `fmap` gets tree --- | If buffers are becoming large, sync, otherwise do nothing.-maybeSync :: TreeIO ()-maybeSync = do x <- gets changesize-               when (x > 16 * 1024 * 1024) $ get >>= sync+    exists p =+        do expandTo p+           (isJust . (flip find p)) `fmap` gets tree++    readFile p =+        do expandTo p+           t <- gets tree+           let f = findFile t p+           case f of+             Nothing -> fail $ "No such file " ++ show p+             Just x -> lift (readBlob x)++    currentDirectory = ask+    withDirectory dir = local (\old -> old `catPaths` dir)++instance (Functor m, Monad m, MonadError e m) => TreeRW (TreeMonad m) where+    writeFile p con =+        do expandTo p+           replaceItem p (Just blob)+           markChanged p+           maybeFlush+        where blob = File $ Blob (return con) hash+              hash = sha256 con++    createDirectory p =+        do expandTo p+           replaceItem p $ Just $ SubTree emptyTree++    unlink p =+        do expandTo p+           replaceItem p Nothing++    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

@@ -1,11 +1,26 @@ {-# LANGUAGE ParallelListComp #-}-module Storage.Hashed.Packed where+-- | This module implements an "object storage". This is a directory on disk+-- containing a content-addressed storage. This is useful for storing all kinds+-- of things, particularly filesystem trees, or darcs pristine caches and patch+-- objects. However, this is an abstract, flat storage: no tree semantics are+-- provided. You just need to provide a reference-collecting functionality,+-- computing a list of references for any given object. The system provides+-- transparent garbage collection and packing.+module Storage.Hashed.Packed+    ( Format(..), Block, OS+    -- * Basic operations.+    , hatch, compact, repack, lookup+    -- * Creating and loading.+    , create, load+    -- * Low-level.+    , format, blockLookup, live, hatchery, mature, roots, references, rootdir+    ) 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 Storage.Hashed.Hash  import Control.Monad( forM, forM_, unless ) import Control.Applicative( (<$>) )@@ -15,17 +30,19 @@  import Bundled.Posix( fileExists, isDirectory, getFileStatus ) -import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.ByteString.Char8 as BS import Data.Maybe( listToMaybe, catMaybes, fromJust, isNothing )+import Data.Binary( encode, decode )  import qualified Data.Set as S import qualified Data.Map as M import Data.List( sort )+import Data.Int( Int64 )  -- | 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.+-- and an immutable \"pack\" format. data Format = Loose | Compact | Pack deriving (Show, Eq)  is_loose os = format (hatchery os) == Loose@@ -35,11 +52,13 @@               in [ [a,b] | a <- chars, b <- chars ]  loosePath :: OS -> Hash -> FilePath-loosePath os (Hash (_,hash)) =-    let hash' = BS.unpack hash+loosePath _ NoHash = error "No path for NoHash!"+loosePath os hash =+    let hash' = BS.unpack (encodeBase16 hash)      in rootdir os </> "hatchery" </> take 2 hash' </> drop 2 hash'  looseLookup :: OS -> Hash -> IO (Maybe FileSegment)+looseLookup _ NoHash = return Nothing looseLookup os hash = do   let path = loosePath os hash   exist <- fileExists <$> getFileStatus path@@ -49,10 +68,10 @@ -- | 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+                   , size :: Int64                    , format :: Format } --- | Object storage. Contains a single "hatchery" and possibly a number of+-- | 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.@@ -63,10 +82,9 @@              , 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"+-- packs to eliminate dead objects and join some packs to form bigger packs.+repack :: OS -> IO OS+repack os = 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:@@ -86,7 +104,7 @@                           absent <- isNothing <$> lookup os hash                           return (absent, hash, blob) --- | Reduce hatchery size by moving things into packs.+-- | Move things from hatchery into a (new) pack. compact :: OS -> IO OS compact os = do objects <- live os [hatchery os]                 block <- createPack os (M.toList objects)@@ -121,7 +139,7 @@ create :: FilePath -> Format -> IO OS create path fmt = do createDirectoryIfMissing True path                      initHatchery-                     readOS path+                     load path     where initHatchery | fmt == Loose =                            do mkdir hatchpath                               forM loose_dirs $ mkdir . (hatchpath </>)@@ -130,8 +148,8 @@           mkdir = createDirectoryIfMissing False           hatchpath = path </> "hatchery" -readOS :: FilePath -> IO OS-readOS path =+load :: FilePath -> IO OS+load path =     do hatch_stat <- getFileStatus $ path </> "hatchery"        let is_os = fileExists hatch_stat            is_loose = isDirectory hatch_stat@@ -145,28 +163,55 @@            look | format _hatchery == Loose = looseLookup                 | otherwise = undefined            packs = [] -- FIXME read packs-           _roots = [] -- FIXME read packs+           _roots = [] -- FIXME read root pointers        return os -readPack = undefined+readPack :: FilePath -> IO Block+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)+                         res <- case ( compare rawhash (hashof first)+                              , compare rawhash (hashof middle)+                              , compare rawhash (hashof last) ) of+                           (LT,  _,  _) -> return Nothing+                           ( _,  _, GT) -> return Nothing+                           (EQ,  _,  _) -> return $ Just (segof first)+                           ( _,  _, EQ) -> return $ Just (segof last)+                           (GT, EQ, LT) -> return $ Just (segof middle)+                           (GT, GT, LT) | middle /= last -> _lookup hash middle last+                           (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))+                           where from = decode (BL.take 8 $ BL.drop 33 $ headerof i)+                                 size = decode (BL.take 8 $ BL.drop 42 $ headerof i)+                   return $ Block { size = BL.length bits+                                  , format = Pack+                                  , blockLookup = \h -> _lookup h 0 (count - 1) }  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+           headerbits = [ BL.concat [ BL.fromChunks [rawhash]+                                    , BL.pack "@"+                                    , encode offset+                                    , BL.pack "!"+                                    , encode $ BL.length string+                                    , BL.pack "\n" ]+                          | (SHA256 rawhash, _) <- bits+                          | string <- contents+                          | offset <- offsets ]+           header = BL.concat $ (encode $ length bits) : sort headerbits            blob = BL.concat $ header:contents-           hash@(Hash (_, hashhash)) = sha256 blob-           path = rootdir os </> BS.unpack hashhash <.> "bin"+           hash = sha256 blob+           path = rootdir os </> BS.unpack (encodeBase16 hash) <.> "bin"        BL.writeFile path blob-       return $ readPack path+       readPack path  -- | Build a map of live objects (i.e. those reachable from the given roots) in -- a given list of Blocks.@@ -175,51 +220,3 @@     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)

@@ -0,0 +1,86 @@+-- | The plain format implementation resides in this module. The plain format+-- does not use any hashing and basically just wraps a normal filesystem tree+-- in the hashed-storage API.+--+-- NB. The 'read' function on Blobs coming from a plain tree is susceptible to+-- file content changes. Since we use mmap in 'read', this will break+-- referential transparency and produce unexpected results. Please always make+-- sure that all parallel access to the underlying filesystem tree never+-- 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++import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as BL+import System.FilePath( (</>) )+import System.Directory( getDirectoryContents, doesFileExist+                       , doesDirectoryExist, createDirectoryIfMissing )+import Bundled.Posix( getFileStatus, isDirectory, FileStatus )+import Control.Monad( forM_, unless, when )++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+                          , list, readBlob, find, modifyTree )+import Storage.Hashed.Monad( TreeIO, runTreeMonad, initialState, tree )+import qualified Data.Set as S+import Control.Monad.State( liftIO, gets, modify )++readPlainDir :: FilePath -> IO [(FilePath, FileStatus)]+readPlainDir dir =+    withCurrentDirectory dir $ do+      items <- getDirectoryContents "."+      sequence [ do st <- getFileStatus s+                    return (s, st)+                 | s <- items, not $ s `elem` [ ".", ".." ] ]++readPlainTree :: FilePath -> IO (Tree IO)+readPlainTree dir = do+  items <- readPlainDir dir+  let subs = [+       let name = Name (BS.pack name')+        in if isDirectory status+              then (name,+                    Stub (readPlainTree (dir </> name')) NoHash)+              else (name, File $+                    Blob (readBlob name) NoHash)+            | (name', status) <- items ]+  return $ makeTree subs+    where readBlob (Name name) = readSegment (dir </> BS.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".+writePlainTree :: Tree IO -> FilePath -> IO ()+writePlainTree t dir = do+  createDirectoryIfMissing True dir+  forM_ (list t) write+    where write (p, File b) = write' p b+          write (p, SubTree _) =+              createDirectoryIfMissing True (anchorPath dir p)+          write _ = return ()+          write' p b = readBlob b >>= BL.writeFile (anchorPath dir p)++-- | Run a 'TreeIO' action in a plain tree setting. Writes out changes to the+-- plain tree every now and then (after the action is finished, the last tree+-- state is always flushed to disk). XXX Modify the tree with filesystem+-- reading and put it back into st (ie. replace the in-memory Blobs with normal+-- ones, so the memory can be GCd).+plainTreeIO :: TreeIO a -> Tree IO -> FilePath -> IO (a, Tree IO)+plainTreeIO action t dir = runTreeMonad action $ initialState t syncPlain+    where syncPlain ch = do+            current  <- gets tree+            forM_ (S.toList ch) $ \c -> do+                let path = anchorPath dir c+                case find current c of+                  Just (File b) -> do+                    liftIO $ readBlob b >>= BL.writeFile path+                    let nblob = File $ Blob (BL.readFile path) NoHash+                    modify $ \st -> st { tree = modifyTree (tree st) c+                                                           (Just nblob) }+                  Just (SubTree _) ->+                      liftIO $ createDirectoryIfMissing False path+                  _ -> fail $ "Foo at " ++ path+

@@ -1,18 +1,25 @@ {-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-} module Storage.Hashed.Test( tests ) where -import Prelude hiding ( read, filter )+import Prelude hiding ( filter, readFile, writeFile )+import qualified Prelude 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 System.Directory( doesFileExist, removeFile, doesDirectoryExist )+import System.FilePath( (</>) ) import Control.Monad( forM_, when ) import Control.Monad.Identity+import Control.Monad.Trans( lift )+import Control.Applicative( (<$>) )+ import Data.Maybe import Data.Word+import Data.Int import Data.Bits-import Data.List( (\\), sort, intercalate, nub )+import Data.List( (\\), sort, intercalate, nub, intersperse )+ import Storage.Hashed import Storage.Hashed.AnchoredPath import Storage.Hashed.Tree@@ -20,6 +27,9 @@ import Storage.Hashed.Utils import Storage.Hashed.Darcs import Storage.Hashed.Packed+import Storage.Hashed.Hash+import Storage.Hashed.Monad hiding ( tree )+ import System.IO.Unsafe( unsafePerformIO ) import System.Mem( performGC ) @@ -54,23 +64,27 @@        , floatPath "foo_dir/foo_subdir"        , floatPath "foo space" ] -emptyStub = Stub (return emptyTree) Nothing+emptyStub = Stub (return emptyTree) NoHash  testTree =     makeTree [ (makeName "foo", emptyStub)              , (makeName "subtree", SubTree sub)-             , (makeName "substub", Stub getsub Nothing) ]+             , (makeName "substub", Stub getsub NoHash) ]     where sub = makeTree [ (makeName "stub", emptyStub)-                         , (makeName "substub", Stub getsub2 Nothing)+                         , (makeName "substub", Stub getsub2 NoHash)                          , (makeName "x", SubTree emptyTree) ]           getsub = return sub-          getsub2 = return $ makeTree [ (makeName "file", File emptyBlob) ]+          getsub2 = return $ makeTree [ (makeName "file", File emptyBlob)+                                      , (makeName "file2",+                                         File $ Blob (return $ BL.pack "foo") NoHash) ]  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 ]+                     do isJust (findFile t p) @? show p ++ " in tree"+                        ours <- readBlob (fromJust $ findFile t p)+                        ours @?= stored+                     | (p, stored) <- blobs ] >>+                    sequence_ [ isJust (Prelude.lookup p blobs) @? show p ++ " extra in tree"+                                | (p, File _) <- list t ]  --------------------------- -- Test list@@ -78,9 +92,11 @@  tests = [ testGroup "Bundled.Posix" posix         , testGroup "Storage.Hashed.Utils" utils+        , testGroup "Storage.Hashed.Hash" hash         , testGroup "Storage.Hashed.Tree" tree         , testGroup "Storage.Hashed.Index" index         , testGroup "Storage.Hashed.Packed" packed+        , testGroup "Storage.Hashed.Monad" monad         , testGroup "Storage.Hashed" hashed ]  --------------------------@@ -95,7 +111,7 @@          , testCase "writePlainTree works" write_plain ]     where       check_file t f = assertBool-                       ("path " ++ show f ++ " is missing in tree")+                       ("path " ++ show f ++ " is missing in tree " ++ show t)                        (isJust $ find t f)       check_files = forM_ files . check_file @@ -118,26 +134,26 @@       write_plain = do         orig <- readDarcsPristine "." >>= expand         writePlainTree orig "_darcs/plain"-        t <- readPlainTree "_darcs/plain"+        t <- expand =<< readPlainTree "_darcs/plain"         equals_testdata t -index = [ testCase "index listing" check_index-        , testCase "index content" check_index_content-        , testCase "index versioning" check_index_versions ]+index = [ testCase "index versioning" check_index_versions+        , testCase "index listing" check_index+        , testCase "index content" check_index_content ]     where pristine = readDarcsPristine "." >>= expand           build_index =             do x <- pristine                exist <- doesFileExist "_darcs/index"                performGC -- required in win32 to trigger file close                when exist $ removeFile "_darcs/index"-               idx <- updateIndexFrom "_darcs/index" darcsTreeHash x >>= expand+               idx <- updateIndex =<< updateIndexFrom "_darcs/index" darcsTreeHash x                return (x, idx)           check_index =             do (pris, idx) <- build_index                (sort $ map fst $ list idx) @?= (sort $ map fst $ list pris)           check_blob_pair p x y =-              do a <- read x-                 b <- read y+              do a <- readBlob x+                 b <- readBlob y                  assertEqual ("content match on " ++ show p) a b           check_index_content =             do (_, idx) <- build_index@@ -146,11 +162,9 @@                assertBool "files match" (length x > 0)           check_index_versions =             do performGC -- required in win32 to trigger file close-               writeFile "_darcs/index" "nonsense index... do not crash!"-               pris <- pristine-               idx <- expand =<<-                        readOrUpgradeIndex "_darcs/index" darcsTreeHash pristine-               (sort $ map fst $ list idx) @?= (sort $ map fst $ list pris)+               Prelude.writeFile "_darcs/index" "nonsense index... do not crash!"+               valid <- indexFormatValid "_darcs/index"+               assertBool "index format invalid" $ not valid  tree = [ testCase "modifyTree" check_modify        , testCase "complex modifyTree" check_modify_complex@@ -160,18 +174,19 @@        , testCase "diffTrees" check_diffTrees        , testCase "diffTrees identical" check_diffTrees_ident        , testProperty "treeEq" prop_tree_eq+       , testProperty "deepTreeEq" prop_deep_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)+    where blob x = File $ Blob (return (BL.pack x)) (sha256 $ BL.pack x)           name = Name . BS.pack           check_modify =               let t = makeTree [(name "foo", blob "bar")]                   modify = modifyTree t (floatPath "foo") (Just $ blob "bla")-               in do x <- read $ fromJust $ findFile t (floatPath "foo")-                     y <- read $ fromJust $ findFile modify (floatPath "foo")+               in do x <- readBlob $ fromJust $ findFile t (floatPath "foo")+                     y <- readBlob $ fromJust $ findFile modify (floatPath "foo")                      assertEqual "old version" x (BL.pack "bar")                      assertEqual "new version" y (BL.pack "bla")                      assertBool "list has foo" $@@ -182,11 +197,11 @@                                , (name "bar", SubTree t1) ]                   t1 = makeTree [ (name "foo", blob "bar") ]                   modify = modifyTree t (floatPath "bar/foo") (Just $ blob "bla")-               in do foo <- read $ fromJust $ findFile t (floatPath "foo")-                     foo' <- read $ fromJust $ findFile modify (floatPath "foo")-                     bar_foo <- read $ fromJust $+               in do foo <- readBlob $ fromJust $ findFile t (floatPath "foo")+                     foo' <- readBlob $ fromJust $ findFile modify (floatPath "foo")+                     bar_foo <- readBlob $ fromJust $                                 findFile t (floatPath "bar/foo")-                     bar_foo' <- read $ fromJust $+                     bar_foo' <- readBlob $ fromJust $                                  findFile modify (floatPath "bar/foo")                      assertEqual "old foo" foo (BL.pack "bar")                      assertEqual "old bar/foo" bar_foo (BL.pack "bar")@@ -199,8 +214,8 @@                      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) ]+                  t2 :: Tree Identity = 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")@@ -237,19 +252,21 @@                        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"+            flip finally (Prelude.writeFile "foo_dir/foo_a" "a\n") $+                 do Prelude.writeFile "foo_dir/foo_a" "b\n"                     working_plain <- filter nondarcs `fmap` readPlainTree "."-                    working <- expand =<< updateIndexFrom "_darcs/index" darcsTreeHash working_plain+                    working <- updateIndex =<<+                                 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')+                    working' `treeEq` pristine'+                             @? show working' ++ " `treeEq` " ++ show 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)+                    foo_work_c <- readBlob (fromJust foo_work)+                    foo_pris_c <- readBlob (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')@@ -261,43 +278,55 @@             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_tree_eq x = no_stubs x ==> x `treeEq` x+              where types = x :: Tree Identity+          prop_deep_tree_eq x = runIdentity $ deepTreeEq x x+              where types = x :: Tree Identity+          prop_expand_id x = no_stubs x ==> runIdentity (expand x) `treeEq` x+              where types = x :: Tree Identity+          prop_filter_id x = runIdentity $ deepTreeEq x $ filter (\_ _ -> True) x+              where types = x :: Tree Identity+          prop_filter_empty x = runIdentity $ deepTreeEq emptyTree $ filter (\_ _ -> False) x+              where types = x :: Tree Identity           prop_restrict_shape_commutative (t1, t2) =-              not (restrict t1 t2 `treeEq` emptyTree) ==>+              no_stubs t1 && no_stubs t2 && not (restrict t1 t2 `treeEq` emptyTree) ==>                   restrict t1 t2 `treeEq` restrict t2 t1+              where types = (t1 :: Tree Identity, t2 :: Tree Identity)           prop_restrict_subtree (t1, t2) =-              not (restrict t1 t2 `treeEq` emptyTree) ==>+              no_stubs t1 && 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]+              where types = (t1 :: Tree Identity, t2 :: Tree Identity)  packed = [ testCase "loose pristine tree" check_loose-         , testCase "readOS" check_readOS+         , testCase "load" check_load          , testCase "live" check_live          , testCase "compact" check_compact ]-    where check_loose = do x <- readDarcsPristine "."+    where root_hash = treeHash <$> get_pristine+          get_pristine = darcsUpdateDirHashes <$> (expand =<< readDarcsPristine ".")+          check_loose = do x <- readDarcsPristine "."                            os <- create "_darcs/loose" Loose                            (os', root) <- writePackedDarcsPristine x os-                           y <- readPackedDarcsPristine os' root+                           y <- expand =<< 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+          check_load = do os <- load "_darcs/loose"+                          format (hatchery os) @?= Loose+                          root <- root_hash+                          y <- expand =<< readPackedDarcsPristine os root+                          equals_testdata y+          check_live = do os <- load "_darcs/loose"+                          x <- get_pristine+                          root <- root_hash+                          alive <- live (os { roots = [ root ]+                                            , references = darcsPristineRefs }) [hatchery os]+                          sequence_ [ assertBool (show hash ++ " is alive") $+                                                 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 ".")+          check_compact = do os <- load "_darcs/loose"+                             x <- darcsUpdateDirHashes `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@@ -305,14 +334,19 @@                              os'' <- compact os'                              length (mature os'') @?= 1                              hatch_root <- blockLookup (hatchery os'') root+                             mature_root <- blockLookup (head $ mature os'') root                              assertBool "bits no longer in hatchery" $ isNothing hatch_root+                             assertBool "bits now in the mature space" $ isJust mature_root+                             mature_root_con <- readSegment (fromJust mature_root)+                             Just mature_root_con @?= darcsFormatDir x -                             -- TODO:-                             -- y <- readPackedDarcsPristine os'' (fromJust $ treeHash x)-                             -- equals_testdata y+                             y <- expand =<< readPackedDarcsPristine os'' root+                             equals_testdata y  utils = [ testProperty "xlate32" prop_xlate32         , testProperty "xlate64" prop_xlate64+        , testProperty "align bounded" prop_align_bounded+        , testProperty "align aligned" prop_align_aligned         , testProperty "reachable is a subset" prop_reach_subset         , testProperty "roots are reachable" prop_reach_roots         , testProperty "nonexistent roots are not reachable" prop_reach_nonroots@@ -321,6 +355,14 @@         , 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+          prop_align_bounded (bound, x) =+              bound > 0 && bound < 1024 && x >= 0 ==>+                    align bound x >= x && align bound x < x + bound+              where types = (bound, x) :: (Int, Int)+          prop_align_aligned (bound, x) =+              bound > 0 && bound < 1024 && x >= 0 ==>+                    align bound x `rem` bound == 0+              where types = (bound, x) :: (Int, Int)            check_fixFrom = let f 0 = 0                               f n = f (n - 1) in fixFrom f 5 @?= 0@@ -360,6 +402,18 @@                                   Nothing -> Nothing                                   Just i -> Just $ M.elemAt i m +hash = [ testProperty "decodeBase16 . encodeBase16 == id" prop_base16+       , testProperty "decodeBase64u . encodeBase64u == id" prop_base64u ]+    where prop_base16 x = (decodeBase16 . encodeBase16) x == x+          prop_base64u x = (decodeBase64u . encodeBase64u) x == x++monad = [ testCase "path expansion" check_virtual ]+    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"+ posix = [ testCase "getFileStatus" $ check_stat Posix.getFileStatus         , testCase "getSymbolicLinkStatus" $ check_stat Posix.getSymbolicLinkStatus ]     where check_stat fun = flip finally (removeFile "test_empty") $ do@@ -383,10 +437,26 @@ instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v)     where arbitrary = M.fromList `fmap` arbitrary +instance Arbitrary BL.ByteString where+    arbitrary = BL.pack `fmap` arbitrary+ instance Arbitrary Word32 where     arbitrary = do x <- arbitrary :: Gen Int                    return $ fromIntegral x +instance Arbitrary Word8 where+    arbitrary = do x <- arbitrary :: Gen Int+                   return $ fromIntegral x++instance Arbitrary Hash where+    arbitrary = sized hash'+        where hash' 0 = return NoHash+              hash' _ = do+                tag <- oneof [return 0, return 1]+                case tag of+                  0 -> SHA256 . BS.pack <$> sequence [ arbitrary | _ <- [1..32] ]+                  1 -> SHA1 . BS.pack <$> sequence [ arbitrary | _ <- [1..20] ]+ instance Arbitrary Word64 where     arbitrary = do x <- arbitrary :: Gen Int                    y <- arbitrary :: Gen Int@@ -394,26 +464,48 @@                        y' = fromIntegral y                    return $ x' .|. (y' `shift` 32) -instance Arbitrary TreeItem where+instance Arbitrary Int64 where+    arbitrary = fromIntegral `fmap` (arbitrary :: Gen Word64)++instance (Monad m) => Arbitrary (TreeItem m) where   arbitrary = sized tree'     where tree' 0 = oneof [ return (File emptyBlob), return (SubTree emptyTree) ]-          tree' n = do branches <- choose (1, n)-                       let subtree name = do t <- tree' ((n - 1) `div` branches)-                                             return (makeName $ show name, t)-                       sublist <- mapM subtree [0..branches]-                       oneof [ tree' 0-                             , return (SubTree $ makeTree sublist) ]+          tree' n = oneof [ file n, subtree n ]+          file 0 = return (File emptyBlob)+          file _ = do content <- arbitrary+                      return (File $ Blob (return content) NoHash)+          subtree n = do branches <- choose (1, n)+                         let sub name = do t <- tree' ((n - 1) `div` branches)+                                           return (makeName $ show name, t)+                         sublist <- mapM sub [0..branches]+                         oneof [ tree' 0+                               , return (SubTree $ makeTree sublist)+                               , return $ (Stub $ return (makeTree sublist)) NoHash ] -instance Arbitrary Tree where+instance (Monad m) => Arbitrary (Tree m) where   arbitrary = do item <- arbitrary                  case item of                    File _ -> arbitrary+                   Stub _ _ -> arbitrary                    SubTree t -> return t  --------------------------- -- Other instances -- +instance Show (Blob m) where+    show (Blob _ h) = "Blob " ++ show h++instance Show (TreeItem m) where+    show (File f) = "File (" ++ show f ++ ")"+    show (Stub _ h) = "Stub _ " ++ show h+    show (SubTree s) = "SubTree (" ++ show s ++ ")"++instance Show (Tree m) where+    show t = "Tree " ++ show (treeHash t) ++ " { " +++             (concat . intersperse ", " $ itemstrs) ++ " }"+        where itemstrs = map show $ listImmediate t+ instance Show (Int -> Int) where     show f = "[" ++ intercalate ", " (map val [1..20]) ++ " ...]"         where val x = show x ++ " -> " ++ show (f x)@@ -430,5 +522,34 @@     where cmp _ (Just a) (Just b) = a `treeItemEq` b           cmp _ _ _ = False +deepTreeEq :: (Monad m) => Tree m -> Tree m -> m Bool+deepTreeEq a b = do x <- expand a+                    y <- expand b+                    return $ x `treeEq` y+ nondarcs (AnchoredPath (Name x:_)) _ | x == BS.pack "_darcs" = False                                      | otherwise = True++readDarcsPristine :: FilePath -> IO (Tree IO)+readDarcsPristine dir = do+  let darcs = dir </> "_darcs"+      h_inventory = darcs </> "hashed_inventory"+  repo <- doesDirectoryExist darcs+  unless repo $ fail $ "Not a darcs repository: " ++ dir+  hashed <- doesFileExist h_inventory+  if hashed+     then do inv <- BS.readFile h_inventory+             let lines = BS.split '\n' inv+             case lines of+               [] -> return emptyTree+               (pris_line:_) -> do+                          let hash = decodeDarcsHash $ BS.drop 9 pris_line+                              size = decodeDarcsSize $ BS.drop 9 pris_line+                          when (hash == NoHash) $ fail $ "Bad pristine root: " ++ show pris_line+                          readDarcsHashed (darcs </> "pristine.hashed") (size, hash)+     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!"

@@ -1,15 +1,17 @@+{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances #-}+ -- | The abstract representation of a Tree and useful abstract utilities to -- handle those. module Storage.Hashed.Tree     ( Tree, Blob(..), TreeItem(..), ItemType(..), Hash(..)-    , makeTree, makeTreeWithHash, emptyTree, emptyBlob+    , makeTree, makeTreeWithHash, emptyTree, emptyBlob, makeBlob, makeBlobBS      -- * Unfolding stubbed (lazy) Trees.     --     -- | 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.-    , expand, expandPath+    , expandUpdate, expand, expandPath      -- * Tree access and lookup.     , items, list, listImmediate, treeHash@@ -17,29 +19,34 @@     , zipCommonFiles, zipFiles, zipTrees, diffTrees      -- * Files (Blobs).-    , read+    , readBlob +    -- * Filtering trees.+    , FilterTree(..), filter, restrict+     -- * Manipulating trees.-    , finish, filter, restrict, modifyTree, updateTreePostorder ) where+    , modifyTree, updateTree, updateSubtrees ) where -import Prelude hiding( lookup, filter, read, all )+import Prelude hiding( lookup, filter, all ) import Storage.Hashed.AnchoredPath-import Storage.Hashed.Utils( Hash(..) )+import Storage.Hashed.Hash  import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.ByteString.Char8 as BS import qualified Data.Map as M  import Data.Maybe( catMaybes )-import Data.List( union, sort, intersperse )+import Data.List( union, sort )+import Control.Applicative( (<$>) )  -------------------------------- -- Tree, Blob and friends -- -data Blob = Blob !(IO BL.ByteString) !(Maybe Hash)-data TreeItem = File !Blob-              | SubTree !Tree-              | Stub !(IO Tree) !(Maybe Hash)+data Blob m = Blob !(m BL.ByteString) !Hash+data TreeItem m = File !(Blob m)+                | SubTree !(Tree m)+                | Stub !(m (Tree m)) !Hash  data ItemType = BlobType | TreeType deriving (Show, Eq) @@ -50,80 +57,64 @@ -- -- > tree <- readDarcsPristine "." >>= expand ----- When a Tree is expanded, it becomes "final". All stubs are forced and the+-- When a Tree is expanded, it becomes \"final\". All stubs are forced and the -- Tree can be traversed purely. Access to actual file contents stays in IO -- though. -- -- A Tree may have a Hash associated with it. A pair of Tree's is identical -- whenever their hashes are (the reverse need not hold, since not all Trees -- come equipped with a hash).-data Tree = Tree { items :: (M.Map Name TreeItem)-                 , listImmediate :: [(Name, TreeItem)]-                 -- | Get hash of a Tree. This is guaranteed to uniquely-                 -- identify the Tree (including any blob content), as far as-                 -- cryptographic hashes are concerned. Sha256 is recommended.-                 , treeHash :: !(Maybe Hash)-                 -- | When implementing a Tree that has complex expanding-                 -- semantics, the "finish" IO action lets you do arbitrary IO-                 -- transform on the Tree after it is expanded but before it is-                 -- given to the user by expand. (Used to implement Index-                 -- updates, eg.)-                 , finish :: Tree -> IO Tree }--instance Show Blob where-    show (Blob _ h) = "Blob " ++ show h--instance Show TreeItem where-    show (File f) = "File (" ++ show f ++ ")"-    show (Stub _ h) = "Stub _ " ++ show h-    show (SubTree s) = "SubTree (" ++ show s ++ ")"--instance Show Tree where-    show t = "Tree " ++ show (treeHash t) ++ " { " ++-             (concat . intersperse ", " $ itemstrs) ++ " }"-        where itemstrs = map show $ listImmediate t+data Tree m = Tree { items :: M.Map Name (TreeItem m)+                   , listImmediate :: [(Name, TreeItem m)]+                   -- | Get hash of a Tree. This is guaranteed to uniquely+                   -- identify the Tree (including any blob content), as far as+                   -- cryptographic hashes are concerned. Sha256 is recommended.+                   , treeHash :: !Hash }  -- | Get a hash of a TreeItem. May be Nothing.-itemHash :: TreeItem -> Maybe Hash+itemHash :: TreeItem m -> Hash itemHash (File (Blob _ h)) = h itemHash (SubTree t) = treeHash t itemHash (Stub _ h) = h -itemType :: TreeItem -> ItemType+itemType :: TreeItem m -> ItemType itemType (File _) = BlobType itemType (SubTree _) = TreeType itemType (Stub _ _) = TreeType -emptyTree :: Tree+emptyTree :: (Monad m) => Tree m emptyTree = Tree { items = M.empty                  , listImmediate = []-                 , treeHash = Nothing-                 , finish = return }+                 , treeHash = NoHash } -emptyBlob :: Blob-emptyBlob = Blob (return BL.empty) Nothing+emptyBlob :: (Monad m) => Blob m+emptyBlob = Blob (return BL.empty) NoHash -makeTree :: [(Name,TreeItem)] -> Tree+makeBlob :: (Monad m) => BL.ByteString -> Blob m+makeBlob str = Blob (return str) (sha256 str)++makeBlobBS :: (Monad m) => BS.ByteString -> Blob m+makeBlobBS s' = let s = BL.fromChunks [s'] in Blob (return s) (sha256 s)++makeTree :: (Monad m) => [(Name,TreeItem m)] -> Tree m makeTree l = Tree { items = M.fromList l                   , listImmediate = l-                  , treeHash = Nothing-                  , finish = return }+                  , treeHash = NoHash } -makeTreeWithHash :: [(Name,TreeItem)] -> Hash -> Tree+makeTreeWithHash :: (Monad m) => [(Name,TreeItem m)] -> Hash -> Tree m makeTreeWithHash l h = Tree { items = M.fromList l                             , listImmediate = l-                            , treeHash = Just h-                            , finish = return }+                            , treeHash = h }  ----------------------------------- -- Tree access and lookup --  -- | Look up a 'Tree' item (an immediate subtree or blob).-lookup :: Tree -> Name -> Maybe TreeItem+lookup :: Tree m -> Name -> Maybe (TreeItem m) lookup t n = M.lookup n (items t) -find' :: TreeItem -> AnchoredPath -> Maybe TreeItem+find' :: TreeItem m -> AnchoredPath -> Maybe (TreeItem m) find' t (AnchoredPath []) = Just t find' (SubTree t) (AnchoredPath (d : rest)) =     case lookup t d of@@ -132,52 +123,58 @@ find' _ _ = Nothing  -- | Find a 'TreeItem' by its path. Gives 'Nothing' if the path is invalid.-find :: Tree -> AnchoredPath -> Maybe TreeItem+find :: Tree m -> AnchoredPath -> Maybe (TreeItem m) find = find' . SubTree  -- | Find a 'Blob' by its path. Gives 'Nothing' if the path is invalid, or does -- not point to a Blob.-findFile :: Tree -> AnchoredPath -> Maybe Blob+findFile :: Tree m -> AnchoredPath -> Maybe (Blob m) findFile t p = case find t p of                  Just (File x) -> Just x                  _ -> Nothing  -- | Find a 'Tree' by its path. Gives 'Nothing' if the path is invalid, or does -- not point to a Tree.-findTree :: Tree -> AnchoredPath -> Maybe Tree+findTree :: Tree m -> AnchoredPath -> Maybe (Tree m) findTree t p = case find t p of                  Just (SubTree x) -> Just x                  _ -> Nothing  -- | List all contents of a 'Tree'.-list :: Tree -> [(AnchoredPath, TreeItem)]+list :: Tree m -> [(AnchoredPath, TreeItem m)] list t_ = paths t_ (AnchoredPath [])     where paths t p = [ (appendPath p n, i)                           | (n,i) <- listImmediate t ] ++                     concat [ paths subt (appendPath p subn)                              | (subn, SubTree subt) <- listImmediate t ] --- | Unfold a stubbed Tree into a one with no stubs in it. You might want to--- filter the tree before expanding to save IO.-expand :: Tree -> IO Tree-expand t = do-  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)-      expanded_map = M.fromList expanded-      tree = t { items = M.union orig_map expanded_map-               , listImmediate = orig ++ expanded }-  finish tree tree-    where subtree (name, sub) = do tree <- expand =<< unstub sub-                                   return (name, SubTree tree)+expandUpdate :: (Monad m) => (AnchoredPath -> Tree m -> m (Tree m)) -> Tree m -> m (Tree m)+expandUpdate update t_ = go (AnchoredPath []) t_+    where go path t = do+            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)+                expanded_map = M.fromList expanded+                tree = t { items = M.union orig_map expanded_map+                         , listImmediate = orig ++ expanded }+            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+-- implementation, which may be overriden by some Tree instances (this is+-- especially true of the Index case).+expand :: (Monad m) => Tree m -> m (Tree m)+expand = expandUpdate $ \_ -> return+ -- | Unfold a path in a (stubbed) Tree, such that the leaf node of the path is -- reachable without crossing any stubs.-expandPath :: Tree -> AnchoredPath -> IO Tree+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@@ -194,10 +191,35 @@                          , listImmediate = (name, SubTree sub') : orig_l }             return tree +class (Monad m) => FilterTree a m where+    -- | Given @pred tree@, produce a 'Tree' that only has items for which+    -- @pred@ returns @True@.+    -- The tree might contain stubs. When expanded, these will be subject to+    -- filtering as well.+    filter :: (AnchoredPath -> TreeItem m -> Bool) -> a m -> a m++instance (Monad m) => FilterTree Tree m where+    filter predicate t_ = filter' t_ (AnchoredPath [])+        where filter' t path =+                  let subs = (catMaybes [ (,) name `fmap` wibble path name item+                                              | (name,item) <- listImmediate t ])+                  in t { items = M.mapMaybeWithKey (wibble path) $ items t+                       , listImmediate = subs }+              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 h) =+                  Stub (do x <- stub+                           return $ filter' x npath) h+              filterSub _ x = x+ -- | Given two Trees, a @guide@ and a @tree@, produces a new Tree that is a -- identical to @tree@, but only has those items that are present in both -- @tree@ and @guide@. The @guide@ Tree may not contain any stubs.-restrict :: Tree -> Tree -> Tree+restrict :: (FilterTree t m, Monad n) => Tree n -> t m -> t m restrict guide tree = filter accept tree     where accept path item =               case (find guide path, item) of@@ -208,39 +230,16 @@                     error "*sulk* Go away, you, you precondition violator!"                 (_, _) -> False --- | Given a predicate of the form AnchoredPath -> TreeItem -> Bool, and a--- Tree, produce a Tree that only has items for which the predicate returned--- True. The tree might contain stubs. When expanded, these will be subject to--- filtering as well.-filter :: (AnchoredPath -> TreeItem -> Bool) -> Tree -> Tree-filter predicate t_ = filter' t_ (AnchoredPath [])-    where filter' t path =-              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 }-          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 h) =-              Stub (do x <- stub-                       return $ filter' x npath) h -- Nothing-          filterSub _ x = x- -- | Read a Blob into a Lazy ByteString. Might be backed by an mmap, use with -- care.-read :: Blob -> IO BL.ByteString-read (Blob r _) = r+readBlob :: Blob m -> m BL.ByteString+readBlob (Blob r _) = r  -- | For every pair of corresponding blobs from the two supplied trees, -- evaluate the supplied function and accumulate the results in a list. Hint: -- to get IO actions through, just use sequence on the resulting list. -- NB. This won't expand any stubs.-zipCommonFiles :: (AnchoredPath -> Blob -> Blob -> a) -> Tree -> Tree -> [a]+zipCommonFiles :: (AnchoredPath -> Blob m -> Blob m -> a) -> Tree m -> Tree m -> [a] zipCommonFiles f a b = catMaybes [ flip (f p) x `fmap` findFile a p                                    | (p, File x) <- list b ] @@ -248,35 +247,45 @@ -- function (supplying the corresponding file from the other tree, or Nothing) -- and accumulate the results in a list. Hint: to get IO actions through, just -- use sequence on the resulting list.  NB. This won't expand any stubs.-zipFiles :: (AnchoredPath -> Maybe Blob -> Maybe Blob -> a)-         -> Tree -> Tree -> [a]+zipFiles :: (AnchoredPath -> Maybe (Blob m) -> Maybe (Blob m) -> a)+         -> Tree m -> Tree m -> [a] zipFiles f a b = [ f p (findFile a p) (findFile b p)-                   | p <- paths a `union` paths b ]+                   | p <- paths a `sortedUnion` paths b ]     where paths t = sort [ p | (p, File _) <- list t ] -zipTrees :: (AnchoredPath -> Maybe TreeItem -> Maybe TreeItem -> a)-         -> Tree -> Tree -> [a]+zipTrees :: (AnchoredPath -> Maybe (TreeItem m) -> Maybe (TreeItem m) -> a)+         -> Tree m -> Tree m -> [a] zipTrees f a b = [ f p (find a p) (find b p)-                   | p <- reverse (paths a `union` paths b) ]+                   | p <- reverse (paths a `sortedUnion` paths b) ]     where paths t = sort [ p | (p, _) <- list t ] +-- | Helper function for taking the union of AnchoredPath lists that+-- are already sorted.  This function does not check the precondition+-- so use it carefully.+sortedUnion :: [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]+sortedUnion [] ys = ys+sortedUnion xs [] = xs+sortedUnion a@(x:xs) b@(y:ys) = case compare x y of+                                LT -> x : sortedUnion xs b+                                EQ -> x : sortedUnion xs ys+                                GT -> y : sortedUnion a ys+ -- | Cautiously extracts differing subtrees from a pair of Trees. It will never -- do any unneccessary expanding. Tree hashes are used to cut the comparison as -- 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' or 'zipTrees'.-diffTrees :: Tree -> Tree -> IO (Tree, Tree)+diffTrees :: forall m. (Functor m, Monad m) => Tree m -> Tree m -> m (Tree m, Tree m) diffTrees left right =             if treeHash left `match` treeHash right                then return (emptyTree, emptyTree)                else diff left right-  where match (Just (Hash (_, h))) (Just (Hash (_, j))) | h == j = True-        match _ _ = False-        isFile (File _) = True+  where isFile (File _) = True         isFile _ = False         notFile = not . isFile-        subtree :: TreeItem -> IO Tree+        isEmpty = null . listImmediate+        subtree :: TreeItem m -> m (Tree m)         subtree (Stub x _) = x         subtree (SubTree x) = return x         subtree (File _) = error "diffTrees tried to descend a File as a subtree"@@ -300,44 +309,47 @@                              do x <- subtree l                                 y <- subtree r                                 (x', y') <- diffTrees x y-                                return (n, Just $ SubTree x', Just $ SubTree y')+                                if isEmpty x' && isEmpty y'+                                   then return (n, Nothing, Nothing)+                                   else return (n, Just $ SubTree x', Just $ SubTree y')                          | isFile l && isFile r ->                              return (n, Just l, Just r)-                         | otherwise -> do l' <- maybeUnfold l-                                           r' <- maybeUnfold r-                                           return (n, Just l', Just r')+                         | otherwise ->+                             do l' <- maybeUnfold l+                                r' <- maybeUnfold r+                                return (n, Just l', Just r')                      _ -> error "n lookups failed"                    | n <- immediateN left' `union` immediateN right' ]-          let is_l = [ (n, l) | (n, Just l ,_) <- is ]+          let is_l = [ (n, l) | (n, Just l, _) <- is ]               is_r = [ (n, r) | (n, _, Just r) <- is ]           return (makeTree is_l, makeTree is_r) -modifyTree :: Tree -> AnchoredPath -> Maybe TreeItem -> Tree+modifyTree :: (Monad m) => Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m  modifyTree _ (AnchoredPath []) (Just (SubTree sub)) = sub  modifyTree t (AnchoredPath [n]) (Just item) =     t { items = M.insert n item (items t)       , listImmediate = (n,item) : subs-      , treeHash = Nothing }+      , treeHash = NoHash }   where subs = [ x | x@(n', _) <- listImmediate t, n /= n' ]  modifyTree t (AnchoredPath [n]) Nothing =     t { items = M.delete n (items t)       , listImmediate = subs-      , treeHash = Nothing }+      , treeHash = NoHash }   where subs = [ x | x@(n', _) <- listImmediate t, n /= n' ]  modifyTree t path@(AnchoredPath (n:r)) item =     t { items = M.insert n sub (items t)       , listImmediate = (n,sub) : subs-      , treeHash = Nothing }+      , treeHash = NoHash }   where subs = [ x | x@(n', _) <- listImmediate t, n /= n' ]         modSubtree s = modifyTree s (AnchoredPath r) item         sub = case lookup t n of                 Just (SubTree s) -> SubTree $ modSubtree s                 Just (Stub s _) -> Stub (do x <- s-                                            return $ modSubtree x) Nothing+                                            return $ modSubtree x) NoHash                 Nothing -> SubTree $ modSubtree emptyTree                 _ -> error $ "Modify tree at " ++ show path @@ -348,11 +360,22 @@ 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)+updateSubtrees :: (Tree m -> Tree m) -> Tree m -> Tree m+updateSubtrees fun t =+    fun $ t { items = M.mapWithKey (curry $ snd . update) $ items t+            , listImmediate = map update $ listImmediate t+            , 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"++-- | 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+  where update (k, SubTree tree) = (\new -> (k, SubTree new)) <$> updateTree fun tree+        update (k, item) = (\new -> (k, new)) <$> fun item

@@ -5,7 +5,6 @@ module Storage.Hashed.Utils where  import Prelude hiding ( lookup, catch )-import qualified Bundled.SHA256 as SHA import System.Mem( performGC ) import System.IO.MMap( mmapFileByteString ) import Bundled.Posix( getFileStatus, fileSize )@@ -33,25 +32,10 @@ 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)-                 _ -> Hash (Nothing, str) -- ...--hashSetSize :: Hash -> Int64 -> Hash-hashSetSize (Hash (_,h)) s = Hash (Just s, h)- -- | Pointer to a filesystem, possibly with start/end offsets. Supposed to be -- fed to (uncurry mmapFileByteString) or similar. type FileSegment = (FilePath, Maybe (Int64, Int)) --- | Bad and ugly. Only works well with single-chunk BL's.-sha256 :: BL.ByteString -> Hash-sha256 = makeHash . BS.pack . SHA.sha256 . BS.concat . BL.toChunks- -- | Read in a FileSegment into a Lazy ByteString. Implemented using mmap. readSegment :: FileSegment -> IO BL.ByteString readSegment (f,range) = do@@ -87,17 +71,23 @@   return $! isAbsolute p ? (p, cwd </> p)  -- Wow, unsafe.-pokeBS :: BS.ByteString -> BS.ByteString -> IO ()-pokeBS to from =+unsafePokeBS :: BS.ByteString -> BS.ByteString -> IO ()+unsafePokeBS to from =     do let (fp_to, off_to, len_to) = toForeignPtr to            (fp_from, off_from, len_from) = toForeignPtr from-       when (len_to /= len_from) $ fail $ "Length mismatch in pokeBS: from = "+       when (len_to /= len_from) $ fail $ "Length mismatch in unsafePokeBS: from = "             ++ show len_from ++ " /= to = " ++ show len_to        withForeignPtr fp_from $ \p_from ->          withForeignPtr fp_to $ \p_to ->            memcpy (plusPtr p_to off_to)                   (plusPtr p_from off_from)                   (fromIntegral len_to)++align :: Integral a => a -> a -> a+align boundary i = case i `rem` boundary of+                     0 -> i+                     x -> i + boundary - x+{-# INLINE align #-}  xlate32 :: (Bits a) => a -> a xlate64 :: (Bits a) => a -> a

@@ -1,5 +1,5 @@ name:          hashed-storage-version:       0.3.9+version:       0.4.0 synopsis:      Hashed file storage support code.  description:   Support code for reading and manipulating hashed file storage@@ -19,8 +19,9 @@ category:      System build-type:    Custom cabal-version: >= 1.6-extra-source-files: Bundled/sha2.h, testdata.zip +extra-source-files: Bundled/sha2.h, NEWS, testdata.zip+ flag test     default: False @@ -46,7 +47,10 @@         Storage.Hashed.Index         Storage.Hashed.Monad         Storage.Hashed.Tree+        Storage.Hashed.Hash         Storage.Hashed.Packed++        Storage.Hashed.Plain         Storage.Hashed.Darcs      if flag(diff)@@ -59,8 +63,17 @@         Bundled.SHA256         Storage.Hashed.Utils -    build-depends: base >= 3 && < 5, directory, filepath, bytestring, zlib,-                   containers, mtl, extensible-exceptions, mmap >= 0.4 && < 0.5+    build-depends: base >= 3 && < 5,+                   containers,+                   mtl,+                   directory,+                   filepath,+                   bytestring,+                   extensible-exceptions,+                   dataenc,+                   binary,+                   zlib,+                   mmap >= 0.4 && < 0.5      c-sources: Bundled/sha2.c