diff --git a/Bundled/Posix.hsc b/Bundled/Posix.hsc --- a/Bundled/Posix.hsc +++ b/Bundled/Posix.hsc @@ -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 diff --git a/Bundled/SHA256.hs b/Bundled/SHA256.hs --- a/Bundled/SHA256.hs +++ b/Bundled/SHA256.hs @@ -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); -- diff --git a/NEWS b/NEWS new file mode 100644 --- /dev/null +++ b/NEWS @@ -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 - format used in + darcs 2.0.2 and newer has been dropped. diff --git a/Storage/Hashed.hs b/Storage/Hashed.hs --- a/Storage/Hashed.hs +++ b/Storage/Hashed.hs @@ -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) diff --git a/Storage/Hashed/AnchoredPath.hs b/Storage/Hashed/AnchoredPath.hs --- a/Storage/Hashed/AnchoredPath.hs +++ b/Storage/Hashed/AnchoredPath.hs @@ -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 [] diff --git a/Storage/Hashed/Darcs.hs b/Storage/Hashed/Darcs.hs --- a/Storage/Hashed/Darcs.hs +++ b/Storage/Hashed/Darcs.hs @@ -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 + diff --git a/Storage/Hashed/Diff.hs b/Storage/Hashed/Diff.hs --- a/Storage/Hashed/Diff.hs +++ b/Storage/Hashed/Diff.hs @@ -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 diff --git a/Storage/Hashed/Hash.hs b/Storage/Hashed/Hash.hs new file mode 100644 --- /dev/null +++ b/Storage/Hashed/Hash.hs @@ -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 diff --git a/Storage/Hashed/Index.hs b/Storage/Hashed/Index.hs --- a/Storage/Hashed/Index.hs +++ b/Storage/Hashed/Index.hs @@ -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 } diff --git a/Storage/Hashed/Monad.hs b/Storage/Hashed/Monad.hs --- a/Storage/Hashed/Monad.hs +++ b/Storage/Hashed/Monad.hs @@ -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 diff --git a/Storage/Hashed/Packed.hs b/Storage/Hashed/Packed.hs --- a/Storage/Hashed/Packed.hs +++ b/Storage/Hashed/Packed.hs @@ -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) diff --git a/Storage/Hashed/Plain.hs b/Storage/Hashed/Plain.hs new file mode 100644 --- /dev/null +++ b/Storage/Hashed/Plain.hs @@ -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 + diff --git a/Storage/Hashed/Test.hs b/Storage/Hashed/Test.hs --- a/Storage/Hashed/Test.hs +++ b/Storage/Hashed/Test.hs @@ -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!" diff --git a/Storage/Hashed/Tree.hs b/Storage/Hashed/Tree.hs --- a/Storage/Hashed/Tree.hs +++ b/Storage/Hashed/Tree.hs @@ -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 diff --git a/Storage/Hashed/Utils.hs b/Storage/Hashed/Utils.hs --- a/Storage/Hashed/Utils.hs +++ b/Storage/Hashed/Utils.hs @@ -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 diff --git a/hashed-storage.cabal b/hashed-storage.cabal --- a/hashed-storage.cabal +++ b/hashed-storage.cabal @@ -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