diff --git a/Storage/Hashed.hs b/Storage/Hashed.hs --- a/Storage/Hashed.hs +++ b/Storage/Hashed.hs @@ -30,8 +30,7 @@ import Storage.Hashed.Tree( Tree( listImmediate ), TreeItem(..), ItemType(..) , Blob(..), emptyTree, makeTree, makeTreeWithHash , list, read, find ) -import System.FilePath( (), splitDirectories, normalise - , dropTrailingPathSeparator ) +import System.FilePath( () ) import System.Directory( getDirectoryContents, doesFileExist , doesDirectoryExist, createDirectoryIfMissing ) import Codec.Compression.GZip( decompress ) @@ -42,14 +41,6 @@ -- For explorers -- --- | Take a relative FilePath and turn it into an AnchoredPath. The operation --- is unsafe and if you break it, you keep both pieces. More useful for --- exploratory purposes (ghci) than for serious programming. -floatPath :: FilePath -> AnchoredPath -floatPath = AnchoredPath . map (Name . BS.pack) - . splitDirectories - . normalise . dropTrailingPathSeparator - -- | Take a relative FilePath within a Tree and print the contents of the -- object there. Useful for exploration, less so for serious programming. printPath :: Tree -> FilePath -> IO () @@ -100,20 +91,9 @@ readDarcsHashedDir dir h = do compressed <- readSegment (dir BS.unpack (darcsFormatHash h), Nothing) let content = decompress compressed - lines = BL.split '\n' content return $ if BL.null compressed then [] - else parse lines - where - parse (t:n:h':r) = (parse' t, - Name $ BS.pack $ darcsDecodeWhite (BL.unpack n), - makeHash hash) : parse r - where hash = BS.concat $ BL.toChunks h' - parse _ = [] - parse' x - | x == BL.pack "file:" = BlobType - | x == BL.pack "directory:" = TreeType - | otherwise = error $ "Error parsing darcs hashed dir: " ++ BL.unpack x + else darcsParseDir content -- | Read in a darcs-style hashed tree. This is mainly useful for reading -- \"pristine.hashed\". You need to provide the root hash you are interested in @@ -152,7 +132,12 @@ (pris_line:_) -> let hash = makeHash $ BS.drop 9 pris_line in readDarcsHashed (darcs "pristine.hashed") hash - else readPlainTree $ darcs "pristine" + else do have_pristine <- doesDirectoryExist $ darcs "pristine" + have_current <- doesDirectoryExist $ darcs "current" + case (have_pristine, have_current) of + (True, _) -> readPlainTree $ darcs "pristine" + (False, True) -> readPlainTree $ darcs "current" + (_, _) -> fail "No pristine tree is available!" -- | Write out *full* tree to a plain directory structure. If you instead want -- to make incremental updates, refer to "Monad.plainTreeIO". diff --git a/Storage/Hashed/AnchoredPath.hs b/Storage/Hashed/AnchoredPath.hs --- a/Storage/Hashed/AnchoredPath.hs +++ b/Storage/Hashed/AnchoredPath.hs @@ -5,11 +5,11 @@ ( Name(..), AnchoredPath(..), appendPath, anchorPath , isPrefix, parent, parents, catPaths, flatten, makeName -- * Unsafe functions. - , nameToFilePath, nameFromFilePath, floatBS ) where + , nameToFilePath, nameFromFilePath, floatBS, floatPath ) where import qualified Data.ByteString.Char8 as BS import Data.List( isPrefixOf, inits ) -import System.FilePath( () ) +import System.FilePath( (), splitDirectories, normalise, dropTrailingPathSeparator ) ------------------------------- -- AnchoredPath utilities @@ -68,4 +68,11 @@ makeName :: String -> Name makeName = Name . BS.pack + +-- | Take a relative FilePath and turn it into an AnchoredPath. The operation +-- is unsafe and if you break it, you keep both pieces. More useful for +-- exploratory purposes (ghci) than for serious programming. +floatPath :: FilePath -> AnchoredPath +floatPath = AnchoredPath . map (Name . BS.pack) . splitDirectories + . normalise . dropTrailingPathSeparator diff --git a/Storage/Hashed/Darcs.hs b/Storage/Hashed/Darcs.hs --- a/Storage/Hashed/Darcs.hs +++ b/Storage/Hashed/Darcs.hs @@ -10,7 +10,7 @@ import qualified Data.ByteString.Lazy.Char8 as BL import Data.List( sortBy ) -import Data.Char( chr ) +import Data.Char( chr, ord, isSpace ) darcsFormatSize :: (Num a) => a -> BS.ByteString darcsFormatSize s = BS.pack $ replicate (10 - length n) '0' ++ n @@ -23,6 +23,12 @@ , h ] darcsFormatHash (Hash (Nothing, h)) = h +-- | 'decode_white' interprets the Darcs-specific \"encoded\" filenames +-- produced by 'darcsEncodeWhite' +-- +-- > darcsDecodeWhite "hello\32\there" == "hello there" +-- > darcsDecodeWhite "hello\92\there" == "hello\there" +-- > darcsDecodeWhite "hello\there" == error "malformed filename" darcsDecodeWhite :: String -> FilePath darcsDecodeWhite ('\\':cs) = case break (=='\\') cs of @@ -32,6 +38,20 @@ darcsDecodeWhite (c:cs) = c: darcsDecodeWhite cs darcsDecodeWhite "" = "" +-- | 'encode_white' translates whitespace in filenames to a darcs-specific +-- format (backslash followed by numerical representation according to 'ord'). +-- Note that backslashes are also escaped since they are used in the encoding. +-- +-- > darcsEncodeWhite "hello there" == "hello\32\there" +-- > darcsEncodeWhite "hello\there" == "hello\92\there" +darcsEncodeWhite :: FilePath -> String +darcsEncodeWhite (c:cs) | isSpace c || c == '\\' = + '\\' : (show $ ord c) ++ "\\" ++ darcsEncodeWhite cs +darcsEncodeWhite (c:cs) = c : darcsEncodeWhite cs +darcsEncodeWhite [] = [] + +darcsEncodeWhiteBS = BS.pack . darcsEncodeWhite . BS.unpack + darcsFormatDir :: Tree -> BL.ByteString darcsFormatDir t = BL.fromChunks $ concatMap string (sortBy cmp $ listImmediate t) @@ -42,14 +62,30 @@ SubTree _ -> BS.pack "directory:\n" Stub _ _ -> error "Trees with stubs not supported in darcsFormatDir.", - name, BS.singleton '\n', + darcsEncodeWhiteBS name, BS.singleton '\n', case itemHash item of Nothing -> error $ "darcsFormatDir: missing hash on " ++ show name Just h -> darcsFormatHash h, BS.singleton '\n' ] +darcsParseDir :: BL.ByteString -> [(ItemType, Name, Hash)] +darcsParseDir content = parse (BL.split '\n' content) + where + parse (t:n:h':r) = (header t, + Name $ BS.pack $ darcsDecodeWhite (BL.unpack n), + makeHash hash) : parse r + where hash = BS.concat $ BL.toChunks h' + parse _ = [] + header x + | x == BL.pack "file:" = BlobType + | x == BL.pack "directory:" = TreeType + | otherwise = error $ "Error parsing darcs hashed dir: " ++ BL.unpack x + -- | Compute a darcs-compatible hash value for a tree-like structure. darcsTreeHash :: Tree -> Hash darcsTreeHash d = hashSetSize (sha256 bl) $ BL.length bl where bl = darcsFormatDir d + +darcsUpdateHashes tree = + flip updateTreePostorder tree $ \ t -> t { treeHash = Just $ darcsTreeHash t } 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 ScopedTypeVariables, NoMonomorphismRestriction #-} +{-# LANGUAGE CPP, ScopedTypeVariables, NoMonomorphismRestriction #-} -- | This module contains plain tree indexing code. The index itself is a -- CACHE: you should only ever use it as an optimisation and never as a primary @@ -9,7 +9,7 @@ -- your validity tracking code, you also check for format validity (see -- "indexFormatValid") and scrap and re-create index when needed. -- --- The index is a binary file, that overlays a hashed tree over the working +-- The index is a binary file that overlays a hashed tree over the working -- copy. This means that every working file and directory has an entry in the -- index, that contains its path and hash and validity data. The validity data -- is a "last seen" timestamp plus the file size. The file hashes are sha256's @@ -53,7 +53,8 @@ getFileStatus, fileSize, fileExists, EpochTime ) import System.IO.MMap( mmapFileForeignPtr, Mode(..) ) import System.IO( openBinaryFile, hGetChar, hClose, IOMode(..) ) -import System.Directory( removeFile, doesFileExist ) +import System.Directory( removeFile, doesFileExist, renameFile ) +import System.FilePath( (<.>) ) import Control.Monad( when ) import qualified Data.ByteString.Char8 as BS @@ -289,7 +290,11 @@ len = 87 + sum [ typeLen typ + 84 + 1 + length (anchorPath "" p) | (p, typ) <- paths ] exist <- doesFileExist indexpath +#if mingw32_HOST_OS + when exist $ renameFile indexpath (indexpath <.> "old") +#else when exist $ removeFile indexpath -- to avoid clobbering oldidx +#endif (mmap, _) <- mmapIndex indexpath len let magic = fromForeignPtr (castForeignPtr mmap) 0 4 create (File _) path off = diff --git a/Storage/Hashed/Monad.hs b/Storage/Hashed/Monad.hs --- a/Storage/Hashed/Monad.hs +++ b/Storage/Hashed/Monad.hs @@ -92,9 +92,12 @@ (cwd st `catPaths` path) item } expandTo :: AnchoredPath -> TreeIO () -expandTo p = do t <- gets tree - t' <- liftIO $ expandPath t p `catch` \(_::SomeException) -> return t - modify $ \st -> st { tree = t' } +expandTo p = + do t <- gets tree + case find t p of + Nothing -> do t' <- liftIO $ expandPath t p `catch` \(_::SomeException) -> return t + modify $ \st -> st { tree = t' } + _ -> return () -- | Run a 'TreeIO' @action@ in a hashed setting. The @initial@ tree is assumed -- to be fully available from the @directory@, and any changes will be written @@ -109,14 +112,15 @@ do runTreeIO action $ initialState t syncHashed where syncHashed = do ch <- gets changed - modify $ \st -> st { changed = S.empty } + modify $ \st -> st { changed = S.empty, changesize = 0 } + modify $ \st -> st { tree = darcsUpdateHashes $ tree st } forM_ (reverse $ S.toList ch) $ \c -> do let path = anchorPath "" c current <- gets tree case find current c of Just (File b) -> updateFile c b Just (SubTree s) -> updateSub c s - _ -> fail $ "Bar at " ++ path + _ -> return () -- the file could have disappeared in the meantime updateFile path b@(Blob _ (Just !h)) = do let fn = dir BS.unpack (darcsFormatHash h) nblob = File $ Blob (decompress `fmap` BL.readFile fn) (Just h) @@ -148,7 +152,7 @@ plainTreeIO action t dir = runTreeIO action $ initialState t syncPlain where syncPlain = do ch <- gets changed - modify $ \st -> st { changed = S.empty } + modify $ \st -> st { changed = S.empty, changesize = 0 } current <- gets tree forM_ (S.toList ch) $ \c -> do let path = anchorPath dir c @@ -222,6 +226,9 @@ rename from to = do expandTo from tr <- gets tree let item = find tr from + found_to = find tr to + unless (isNothing found_to) $ + fail $ "Error renaming: destination " ++ show to ++ " exists." unless (isNothing item) $ do replaceItem to item replaceItem from Nothing diff --git a/Storage/Hashed/Packed.hs b/Storage/Hashed/Packed.hs new file mode 100644 --- /dev/null +++ b/Storage/Hashed/Packed.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE ParallelListComp #-} +module Storage.Hashed.Packed where + +import Prelude hiding ( lookup, read ) +import Storage.Hashed.AnchoredPath +import Storage.Hashed.Tree hiding ( lookup ) +import Storage.Hashed.Utils +import Storage.Hashed.Darcs + +import Control.Monad( forM, forM_, unless ) +import Control.Applicative( (<$>) ) +import System.FilePath( (), (<.>) ) +import System.Directory( createDirectoryIfMissing, removeFile + , getDirectoryContents ) + +import Bundled.Posix( fileExists, isDirectory, getFileStatus ) + +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BS +import Data.Maybe( listToMaybe, catMaybes, fromJust, isNothing ) + +import qualified Data.Set as S +import qualified Data.Map as M +import Data.List( sort ) + +-- | On-disk format for object storage: we implement a completely loose format +-- (one file per object), a compact format stored in a single append-only file +-- and an immutable "pack" format. +data Format = Loose | Compact | Pack deriving (Show, Eq) + +is_loose os = format (hatchery os) == Loose +is_compact os = format (hatchery os) == Compact + +loose_dirs = let chars = ['0'..'9'] ++ ['a'..'f'] + in [ [a,b] | a <- chars, b <- chars ] + +loosePath :: OS -> Hash -> FilePath +loosePath os (Hash (_,hash)) = + let hash' = BS.unpack hash + in rootdir os "hatchery" take 2 hash' drop 2 hash' + +looseLookup :: OS -> Hash -> IO (Maybe FileSegment) +looseLookup os hash = do + let path = loosePath os hash + exist <- fileExists <$> getFileStatus path + return $ if exist then Just (path, Nothing) + else Nothing + +-- | Object storage block. When used as a hatchery, the loose or compact format +-- are preferable, while for mature space, the pack format is more useful. +data Block = Block { blockLookup :: Hash -> IO (Maybe FileSegment) + , size :: Int + , format :: Format } + +-- | Object storage. Contains a single "hatchery" and possibly a number of +-- mature space blocks, usually in form of packs. It also keeps a list of root +-- pointers and has a way to extract pointers from objects (externally +-- supplied). These last two things are used to implement a simple GC. +data OS = OS { hatchery :: Block + , mature :: [Block] + , roots :: [Hash] + , references :: FileSegment -> IO [Hash] + , rootdir :: FilePath } + +-- | Reduce number of packs in the object storage. This may both recombine +-- packs to eliminate dead objects and join some packs to form bigger +-- packs. The set of hashes given is used as roots for GC marking. +repack :: OS -> S.Set Hash -> IO OS +repack os roots = error "repack undefined" + +-- | Add new objects to the object storage (i.e. put them into hatchery). It is +-- safe to call this even on objects that are already present in the storage: +-- such objects will be skipped. +hatch :: OS -> [BL.ByteString] -> IO OS +hatch os blobs = + do processed <- mapM sieve blobs + write [ (h, b) | (True, h, b) <- processed ] + where write bits + | is_loose os = + do forM bits $ \(hash, blob) -> do + BL.writeFile (loosePath os hash) blob + return os + | is_compact os = error "hatch/compact undefined" + | otherwise = fail "Hatchery must be either Loose or Compact." + sieve blob = do let hash = sha256 blob + absent <- isNothing <$> lookup os hash + return (absent, hash, blob) + +-- | Reduce hatchery size by moving things into packs. +compact :: OS -> IO OS +compact os = do objects <- live os [hatchery os] + block <- createPack os (M.toList objects) + cleanup + return $ os { mature = block:mature os } + where cleanup | is_loose os = + forM_ loose_dirs $ nuke . ((rootdir os "hatchery") ) + | is_compact os = + removeFile (rootdir os "hatchery") >> return () + nuke dir = mapM (removeFile . (dir )) =<< + (Prelude.filter (`notElem` [".", ".."]) `fmap` + getDirectoryContents dir) + +blocksLookup :: [Block] -> Hash -> IO (Maybe (Hash, FileSegment)) +blocksLookup blocks hash = + do segment <- cat `fmap` mapM (flip blockLookup hash) blocks + return $ case segment of + Nothing -> Nothing + Just seg -> Just (hash, seg) + where cat = listToMaybe . catMaybes + +lookup :: OS -> Hash -> IO (Maybe FileSegment) +lookup os hash = + do res <- blocksLookup (hatchery os : mature os) hash + return $ case res of + Nothing -> Nothing + Just (_, seg) -> Just seg + +-- | Create an empty object storage in given directory, with a hatchery of +-- given format. The directory is created if needed, but is assumed to be +-- empty. +create :: FilePath -> Format -> IO OS +create path fmt = do createDirectoryIfMissing True path + initHatchery + readOS path + where initHatchery | fmt == Loose = + do mkdir hatchpath + forM loose_dirs $ mkdir . (hatchpath ) + | fmt == Compact = + error "create/mkHatchery Compact undefined" + mkdir = createDirectoryIfMissing False + hatchpath = path "hatchery" + +readOS :: FilePath -> IO OS +readOS path = + do hatch_stat <- getFileStatus $ path "hatchery" + let is_os = fileExists hatch_stat + is_loose = isDirectory hatch_stat + unless is_os $ fail $ path ++ " is not an object storage!" + let _hatchery = Block { blockLookup = look os + , format = if is_loose then Loose else Compact } + os = OS { hatchery = _hatchery + , rootdir = path + , mature = packs + , roots = _roots } + look | format _hatchery == Loose = looseLookup + | otherwise = undefined + packs = [] -- FIXME read packs + _roots = [] -- FIXME read packs + return os + +readPack = undefined + +createPack :: OS -> [(Hash, FileSegment)] -> IO Block +createPack os bits = + do contents <- mapM readSegment (map snd bits) + let offsets = scanl (+) 0 $ map BL.length contents + headerbits = [ BL.fromChunks [ hash + , BS.pack ": (" + , BS.pack (show $ offset) + , BS.pack ", " + , BS.pack (show $ BL.length string) + , BS.pack ")\n" ] + | (Hash (_, hash), _) <- bits | string <- contents | offset <- offsets ] + header = BL.concat $ sort headerbits + blob = BL.concat $ header:contents + hash@(Hash (_, hashhash)) = sha256 blob + path = rootdir os BS.unpack hashhash <.> "bin" + BL.writeFile path blob + return $ readPack path + +-- | Build a map of live objects (i.e. those reachable from the given roots) in +-- a given list of Blocks. +live :: OS -> [Block] -> IO (M.Map Hash FileSegment) +live os blocks = + reachable (references os) + (blocksLookup blocks) + (S.fromList $ roots os) + +-------------------------------------------------------------- +-- Reading and writing darcs-style pristine +---- + +-- | Read a Tree in the darcs hashed format from an object storage. This is +-- basically the same as readDarcsHashed from Storage.Hashed, but uses an +-- object storage instead of traditional darcs filesystem layout. Requires the +-- tree root hash as a starting point. +readPackedDarcsPristine :: OS -> Hash -> IO Tree +readPackedDarcsPristine os root = + do seg <- fromJust <$> lookup os root + items <- darcsParseDir <$> readSegment seg + subs <- sequence [ + case tp of + BlobType -> return (d, File $ file h) + TreeType -> let t = readPackedDarcsPristine os h + in return (d, Stub t $ Just h) + | (tp, d, h) <- items ] + return $ makeTreeWithHash subs root + where file h = Blob ((fromJust <$> lookup os h) >>= readSegment) (Just h) + +-- | Write a Tree into an object storage, using the darcs-style directory +-- formatting (and therefore darcs-style hashes). Gives back the object storage +-- and the root hash of the stored Tree. NB. The function expects that the Tree +-- comes equipped with darcs-style hashes already! +writePackedDarcsPristine :: Tree -> OS -> IO (OS, Hash) +writePackedDarcsPristine tree os = + do t <- expand tree + files <- sequence [ read b | (_, File b) <- list t ] + let dirs = darcsFormatDir t : [ darcsFormatDir d | (_, SubTree d) <- list t ] + os' <- hatch os $ files ++ dirs + return (os', darcsTreeHash t) + +storePackedDarcsPristine :: Tree -> OS -> IO (OS, Hash) +storePackedDarcsPristine tree os = + do (os', root) <- writePackedDarcsPristine tree os + return $ (os' { roots = root : roots os' + -- FIXME we probably don't want to override the references + -- thing completely here... + , references = darcsPristineRefs }, root) + +darcsPristineRefs :: FileSegment -> IO [Hash] +darcsPristineRefs fs = do + con <- (darcsParseDir <$> readSegment fs) `catch` \_ -> return [] + return $! [ hash | (_, _, hash) <- con, valid hash ] + where valid (Hash (_, hash)) = + BS.length hash == 64 && all (`elem` "0123456789abcdef") (BS.unpack hash) diff --git a/Storage/Hashed/Test.hs b/Storage/Hashed/Test.hs --- a/Storage/Hashed/Test.hs +++ b/Storage/Hashed/Test.hs @@ -1,26 +1,34 @@ +{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-} module Storage.Hashed.Test( tests ) where import Prelude hiding ( read, filter ) import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.ByteString.Char8 as BS +import Control.Exception( finally ) import System.Process import System.Directory( doesFileExist, removeFile ) import Control.Monad( forM_, when ) +import Control.Monad.Identity import Data.Maybe import Data.Word import Data.Bits -import Data.List( (\\), sort ) +import Data.List( (\\), sort, intercalate, nub ) import Storage.Hashed import Storage.Hashed.AnchoredPath import Storage.Hashed.Tree import Storage.Hashed.Index import Storage.Hashed.Utils import Storage.Hashed.Darcs +import Storage.Hashed.Packed import System.IO.Unsafe( unsafePerformIO ) import System.Mem( performGC ) -import Bundled.Posix( getFileStatus, getSymbolicLinkStatus, fileSize, fileExists ) +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Bundled.Posix as Posix + ( getFileStatus, getSymbolicLinkStatus, fileSize, fileExists ) + import Test.HUnit import Test.Framework( testGroup ) import Test.QuickCheck @@ -35,12 +43,16 @@ blobs = [ (floatPath "foo_a", BL.pack "a\n") , (floatPath "foo_dir/foo_a", BL.pack "a\n") , (floatPath "foo_dir/foo_b", BL.pack "b\n") - , (floatPath "foo_dir/foo_subdir/foo_a", BL.pack "a\n") ] + , (floatPath "foo_dir/foo_subdir/foo_a", BL.pack "a\n") + , (floatPath "foo space/foo\nnewline", BL.pack "newline\n") + , (floatPath "foo space/foo\\backslash", BL.pack "backslash\n") + , (floatPath "foo space/foo_a", BL.pack "a\n") ] files = map fst blobs dirs = [ floatPath "foo_dir" - , floatPath "foo_dir/foo_subdir" ] + , floatPath "foo_dir/foo_subdir" + , floatPath "foo space" ] emptyStub = Stub (return emptyTree) Nothing @@ -54,15 +66,22 @@ getsub = return sub getsub2 = return $ makeTree [ (makeName "file", File emptyBlob) ] +equals_testdata t = sequence_ [ + do ours <- read b + let Just stored = Prelude.lookup p blobs + assertEqual "contents match" ours stored + | (p, File b) <- list t ] + --------------------------- -- Test list -- tests = [ testGroup "Bundled.Posix" posix - , testGroup "Storage.Hashed" hashed - , testGroup "Storage.Hashed.Index" index + , testGroup "Storage.Hashed.Utils" utils , testGroup "Storage.Hashed.Tree" tree - , testGroup "Storage.Hashed.Utils" utils ] + , testGroup "Storage.Hashed.Index" index + , testGroup "Storage.Hashed.Packed" packed + , testGroup "Storage.Hashed" hashed ] -------------------------- -- Tests @@ -71,12 +90,15 @@ hashed = [ testCase "plain has all files" have_files , testCase "pristine has all files" have_pristine_files , testCase "pristine has no extras" pristine_no_extra - , testCase "pristine file contents match" pristine_contents ] + , testCase "pristine file contents match" pristine_contents + , testCase "plain file contents match" plain_contents + , testCase "writePlainTree works" write_plain ] where check_file t f = assertBool ("path " ++ show f ++ " is missing in tree") (isJust $ find t f) check_files = forM_ files . check_file + pristine_no_extra = do t <- readDarcsPristine "." >>= expand forM_ (list t) $ \(path,_) -> assertBool (show path ++ " is extraneous in tree") @@ -87,12 +109,18 @@ pristine_contents = do t <- readDarcsPristine "." >>= expand - sequence_ [ - do ours <- read b - let Just stored = Prelude.lookup p blobs - assertEqual "contents match" ours stored - | (p, File b) <- list t ] + equals_testdata t + plain_contents = do + t <- expand =<< filter nondarcs `fmap` readPlainTree "." + equals_testdata t + + write_plain = do + orig <- readDarcsPristine "." >>= expand + writePlainTree orig "_darcs/plain" + t <- readPlainTree "_darcs/plain" + equals_testdata t + index = [ testCase "index listing" check_index , testCase "index content" check_index_content , testCase "index versioning" check_index_versions ] @@ -126,12 +154,17 @@ tree = [ testCase "modifyTree" check_modify , testCase "complex modifyTree" check_modify_complex + , testCase "modifyTree removal" check_modify_remove , testCase "expand" check_expand , testCase "expandPath" check_expand_path - , testProperty "treeEq" check_tree_eq - , testProperty "expand is identity" check_expand_id - , testProperty "filter True is identity" check_filter_id - , testProperty "filter False is empty" check_filter_empty ] + , testCase "diffTrees" check_diffTrees + , testCase "diffTrees identical" check_diffTrees_ident + , testProperty "treeEq" prop_tree_eq + , testProperty "expand is identity" prop_expand_id + , testProperty "filter True is identity" prop_filter_id + , testProperty "filter False is empty" prop_filter_empty + , testProperty "restrict both ways keeps shape" prop_restrict_shape_commutative + , testProperty "restrict is a subtree of both" prop_restrict_subtree ] where blob x = File $ Blob (return (BL.pack x)) (Just $ sha256 $ BL.pack x) name = Name . BS.pack check_modify = @@ -141,6 +174,9 @@ y <- read $ fromJust $ findFile modify (floatPath "foo") assertEqual "old version" x (BL.pack "bar") assertEqual "new version" y (BL.pack "bla") + assertBool "list has foo" $ + isJust (Prelude.lookup (floatPath "foo") $ list modify) + length (list modify) @?= 1 check_modify_complex = let t = makeTree [ (name "foo", blob "bar") , (name "bar", SubTree t1) ] @@ -156,6 +192,22 @@ assertEqual "old bar/foo" bar_foo (BL.pack "bar") assertEqual "new foo" foo' (BL.pack "bar") assertEqual "new bar/foo" bar_foo' (BL.pack "bla") + assertBool "list has bar/foo" $ + isJust (Prelude.lookup (floatPath "bar/foo") $ list modify) + assertBool "list has foo" $ + isJust (Prelude.lookup (floatPath "foo") $ list modify) + length (list modify) @?= length (list t) + check_modify_remove = + let t1 = makeTree [(name "foo", blob "bar")] + t2 = makeTree [ (name "foo", blob "bar") + , (name "bar", SubTree t1) ] + modify1 = modifyTree t1 (floatPath "foo") Nothing + modify2 = modifyTree t2 (floatPath "bar") Nothing + file = findFile modify1 (floatPath "foo") + subtree = findTree modify2 (floatPath "bar") + in do assertBool "file is gone" (isNothing file) + assertBool "subtree is gone" (isNothing subtree) + no_stubs t = null [ () | (_, Stub _ _) <- list t ] path = floatPath "substub/substub/file" badpath = floatPath "substub/substub/foo" @@ -167,33 +219,170 @@ assertBool "badpath not reachable" $ badpath `notElem` (map fst $ list x) check_expand_path = do + test_exp <- expand testTree t <- expandPath testTree path - assertBool "path reachable" $ path `elem` (map fst $ list t) - assertBool "badpath not reachable" $ + t' <- expandPath test_exp path + t'' <- expandPath testTree $ floatPath "substub/x" + assertBool "path not reachable in testTree" $ path `notElem` (map fst $ list testTree) + assertBool "path reachable in t" $ path `elem` (map fst $ list t) + assertBool "path reachable in t'" $ path `elem` (map fst $ list t') + assertBool "path reachable in t (with findFile)" $ + isJust $ findFile t path + assertBool "path reachable in t' (with findFile)" $ + isJust $ findFile t' path + assertBool "path not reachable in t''" $ path `notElem` (map fst $ list t'') + assertBool "badpath not reachable in t" $ badpath `notElem` (map fst $ list t) - check_tree_eq x = x `treeEq` x - check_expand_id x = unsafePerformIO (expand x) `treeEq` x - check_filter_id x = filter (\_ _ -> True) x `treeEq` x - check_filter_empty x = filter (\_ _ -> False) x `treeEq` emptyTree + assertBool "badpath not reachable in t'" $ + badpath `notElem` (map fst $ list t') + check_diffTrees = + flip finally (writeFile "foo_dir/foo_a" "a\n") $ + do writeFile "foo_dir/foo_a" "b\n" + working_plain <- filter nondarcs `fmap` readPlainTree "." + working <- expand =<< updateIndexFrom "_darcs/index" darcsTreeHash working_plain + pristine <- readDarcsPristine "." + (working', pristine') <- diffTrees working pristine + let foo_work = findFile working' (floatPath "foo_dir/foo_a") + foo_pris = findFile pristine' (floatPath "foo_dir/foo_a") + assertBool "trees have equal shapes" (working' `treeEq` pristine') + assertBool "foo_dir/foo_a is in working'" $ isJust foo_work + assertBool "foo_dir/foo_a is in pristine'" $ isJust foo_pris + foo_work_c <- read (fromJust foo_work) + foo_pris_c <- read (fromJust foo_pris) + BL.unpack foo_work_c @?= "b\n" + BL.unpack foo_pris_c @?= "a\n" + assertEqual "working' tree is minimal" 2 (length $ list working') + assertEqual "pristine' tree is minimal" 2 (length $ list pristine') + + check_diffTrees_ident = do + pristine <- readDarcsPristine "." + (t1, t2) <- diffTrees pristine pristine + assertBool "t1 is empty" $ null (list t1) + assertBool "t2 is empty" $ null (list t2) + + prop_tree_eq x = x `treeEq` x + prop_expand_id x = unsafePerformIO (expand x) `treeEq` x + prop_filter_id x = filter (\_ _ -> True) x `treeEq` x + prop_filter_empty x = filter (\_ _ -> False) x `treeEq` emptyTree + prop_restrict_shape_commutative (t1, t2) = + not (restrict t1 t2 `treeEq` emptyTree) ==> + restrict t1 t2 `treeEq` restrict t2 t1 + prop_restrict_subtree (t1, t2) = + not (restrict t1 t2 `treeEq` emptyTree) ==> + let restricted = S.fromList (map fst $ list $ restrict t1 t2) + orig1 = S.fromList (map fst $ list t1) + orig2 = S.fromList (map fst $ list t2) + in and [restricted `S.isSubsetOf` orig1, restricted `S.isSubsetOf` orig2] + +packed = [ testCase "loose pristine tree" check_loose + , testCase "readOS" check_readOS + , testCase "live" check_live + , testCase "compact" check_compact ] + where check_loose = do x <- readDarcsPristine "." + os <- create "_darcs/loose" Loose + (os', root) <- writePackedDarcsPristine x os + y <- readPackedDarcsPristine os' root + equals_testdata y + check_readOS = do os <- readOS "_darcs/loose" + format (hatchery os) @?= Loose + x <- readDarcsPristine "." + y <- readPackedDarcsPristine os (fromJust $ treeHash x) + equals_testdata y + check_live = do os <- readOS "_darcs/loose" + x <- readDarcsPristine "." + alive <- live (os { roots = [ fromJust $ treeHash x ] + , references = darcsPristineRefs } ) [hatchery os] + sequence_ [ assertBool "" $ (fromJust hash) `S.member` M.keysSet alive + | hash <- map (itemHash . snd) $ list x ] + length (M.toList alive) @?= 1 + length (nub $ map snd blobs) + length dirs + check_compact = do os <- readOS "_darcs/loose" + x <- darcsUpdateHashes `fmap` (expand =<< readDarcsPristine ".") + (os', root) <- storePackedDarcsPristine x os + hatch_root_old <- blockLookup (hatchery os') root + assertBool "bits in the old hatchery" $ isJust hatch_root_old + + os'' <- compact os' + length (mature os'') @?= 1 + hatch_root <- blockLookup (hatchery os'') root + assertBool "bits no longer in hatchery" $ isNothing hatch_root + + -- TODO: + -- y <- readPackedDarcsPristine os'' (fromJust $ treeHash x) + -- equals_testdata y + utils = [ testProperty "xlate32" prop_xlate32 - , testProperty "xlate64" prop_xlate64 ] + , testProperty "xlate64" prop_xlate64 + , testProperty "reachable is a subset" prop_reach_subset + , testProperty "roots are reachable" prop_reach_roots + , testProperty "nonexistent roots are not reachable" prop_reach_nonroots + , testCase "an example for reachable" check_reachable + , testCase "fixFrom" check_fixFrom + , testCase "mmap empty file" check_mmapEmpty ] where prop_xlate32 x = (xlate32 . xlate32) x == x where types = x :: Word32 prop_xlate64 x = (xlate64 . xlate64) x == x where types = x :: Word64 -posix = [ testCase "getFileStatus" $ check_stat getFileStatus - , testCase "getSymbolicLinkStatus" $ check_stat getSymbolicLinkStatus ] - where check_stat fun = do - x <- fileSize `fmap` fun "foo_a" - writeFile "test_empty" "" - y <- fileSize `fmap` fun "test_empty" - exist_nonexistent <- fileExists `fmap` fun "test_does_not_exist" - exist_existent <- fileExists `fmap` fun "test_empty" + check_fixFrom = let f 0 = 0 + f n = f (n - 1) in fixFrom f 5 @?= 0 + + check_mmapEmpty = flip finally (removeFile "test_empty") $ do + Prelude.writeFile "test_empty" "" + x <- readSegment ("test_empty", Nothing) + x @?= BL.empty + + reachable' ref look roots = runIdentity $ reachable ref look roots + + check_reachable = let refs 0 = [1, 2] + refs 1 = [2] + refs 2 = [0, 4] + refs 3 = [4, 6, 7] + refs 4 = [0, 1] + set = S.fromList [1, 2] + map = M.fromList [ (n, refs n) | n <- [0..10] ] + reach = reachable' return (lookup map) set + in do M.keysSet reach @?= S.fromList [0, 1, 2, 4] + + prop_reach_subset (set :: S.Set Int, map :: M.Map Int [Int]) = + M.keysSet (reachable' return (lookup map) set) + `S.isSubsetOf` M.keysSet map + prop_reach_roots (set :: S.Set Int, map :: M.Map Int [Int]) = + set `S.isSubsetOf` M.keysSet map + ==> set `S.isSubsetOf` + M.keysSet (reachable' return (lookup map) set) + + prop_reach_nonroots (set :: S.Set Int, map :: M.Map Int [Int]) = + set `S.intersection` M.keysSet map + == M.keysSet (reachable' (return . const []) + (lookup map) set) + + lookup :: (Ord a) => M.Map a [a] -> a -> Identity (Maybe (a, [a])) + lookup m k = return $ case M.lookupIndex k m of + Nothing -> Nothing + Just i -> Just $ M.elemAt i m + +posix = [ testCase "getFileStatus" $ check_stat Posix.getFileStatus + , testCase "getSymbolicLinkStatus" $ check_stat Posix.getSymbolicLinkStatus ] + where check_stat fun = flip finally (removeFile "test_empty") $ do + x <- Posix.fileSize `fmap` fun "foo_a" + Prelude.writeFile "test_empty" "" + y <- Posix.fileSize `fmap` fun "test_empty" + exist_nonexistent <- Posix.fileExists `fmap` fun "test_does_not_exist" + exist_existent <- Posix.fileExists `fmap` fun "test_empty" assertEqual "file size" x 2 assertEqual "file size" y 0 assertBool "existence check" $ not exist_nonexistent assertBool "existence check" exist_existent +---------------------------------- +-- Arbitrary instances +-- + +instance (Arbitrary a, Ord a) => Arbitrary (S.Set a) + where arbitrary = S.fromList `fmap` arbitrary + +instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v) + where arbitrary = M.fromList `fmap` arbitrary + instance Arbitrary Word32 where arbitrary = do x <- arbitrary :: Gen Int return $ fromIntegral x @@ -221,6 +410,18 @@ File _ -> arbitrary SubTree t -> return t +--------------------------- +-- Other instances +-- + +instance Show (Int -> Int) where + show f = "[" ++ intercalate ", " (map val [1..20]) ++ " ...]" + where val x = show x ++ " -> " ++ show (f x) + +----------------------- +-- Test utilities +-- + treeItemEq (File _) (File _) = True treeItemEq (SubTree s) (SubTree p) = s `treeEq` p treeItemEq _ _ = False @@ -228,3 +429,6 @@ treeEq t r = and $ zipTrees cmp t r where cmp _ (Just a) (Just b) = a `treeItemEq` b cmp _ _ _ = False + +nondarcs (AnchoredPath (Name x:_)) _ | x == BS.pack "_darcs" = False + | otherwise = True diff --git a/Storage/Hashed/Tree.hs b/Storage/Hashed/Tree.hs --- a/Storage/Hashed/Tree.hs +++ b/Storage/Hashed/Tree.hs @@ -20,7 +20,7 @@ , read -- * Manipulating trees. - , finish, filter, restrict, modifyTree ) where + , finish, filter, restrict, modifyTree, updateTreePostorder ) where import Prelude hiding( lookup, filter, read, all ) import Storage.Hashed.AnchoredPath @@ -218,17 +218,17 @@ let subs = (catMaybes [ (,) name `fmap` wibble path name item | (name,item) <- listImmediate t ]) in t { items = M.mapMaybeWithKey (wibble path) $ items t - , listImmediate = subs - , treeHash = Nothing } + , listImmediate = subs } + -- , treeHash = Nothing } wibble path name item = let npath = path `appendPath` name in if predicate npath item then Just $ filterSub npath item else Nothing filterSub npath (SubTree t) = SubTree $ filter' t npath - filterSub npath (Stub stub _) = + filterSub npath (Stub stub h) = Stub (do x <- stub - return $ filter' x npath) Nothing + return $ filter' x npath) h -- Nothing filterSub _ x = x -- | Read a Blob into a Lazy ByteString. Might be backed by an mmap, use with @@ -265,7 +265,7 @@ -- high up the Tree branches as possible. The result is a pair of trees that do -- not share any identical subtrees. They are derived from the first and second -- parameters respectively and they are always fully expanded. It might be --- advantageous to feed the result into 'zipFiles'. +-- advantageous to feed the result into 'zipFiles' or 'zipTrees'. diffTrees :: Tree -> Tree -> IO (Tree, Tree) diffTrees left right = if treeHash left `match` treeHash right @@ -347,3 +347,12 @@ error "Bug in descent in modifyTree." modifyTree _ (AnchoredPath []) Nothing = error "Bug in descent in modifyTree." + +updateTreePostorder :: (Tree -> Tree) -> Tree -> Tree +updateTreePostorder fun t = + t { items = M.mapWithKey (curry $ snd . update) $ items t + , listImmediate = map update $ listImmediate t + , treeHash = Nothing } + where update (k, SubTree s) = (k, SubTree $ fun $ updateTreePostorder fun s) + update (k, File f) = (k, File f) + update (k, Stub _ _) = error "Stubs not supported in updateTreePostorder" diff --git a/Storage/Hashed/Utils.hs b/Storage/Hashed/Utils.hs --- a/Storage/Hashed/Utils.hs +++ b/Storage/Hashed/Utils.hs @@ -12,25 +12,34 @@ import System.Directory( getCurrentDirectory, setCurrentDirectory ) import System.FilePath( (), isAbsolute ) import Data.Int( Int64 ) +import Data.Maybe( catMaybes ) import Control.Exception.Extensible( catch, bracket, SomeException(..) ) import Control.Monad( when ) +import Control.Monad.Identity( runIdentity ) +import Control.Applicative( (<$>) ) import Foreign.ForeignPtr( withForeignPtr ) import Foreign.Ptr( plusPtr ) import Data.ByteString.Internal( toForeignPtr, memcpy ) -import Data.Bits( (.&.), (.|.), shift, shiftL, shiftR, Bits ) +import Data.Bits( Bits ) +#ifdef BIGENDIAN +import Data.Bits( (.&.), (.|.), shift, shiftL, shiftR ) +#endif import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.ByteString.Char8 as BS -newtype Hash = Hash (Maybe Int64, BS.ByteString) deriving (Show, Eq, Read) +import qualified Data.Set as S +import qualified Data.Map as M +newtype Hash = Hash (Maybe Int64, BS.ByteString) deriving (Show, Eq, Ord, Read) + makeHash :: BS.ByteString -> Hash makeHash str = case BS.split '-' str of [h] -> Hash (Nothing, h) [s, h] -> Hash (Just $ read $ BS.unpack s, h) - _ -> error $ "Bad hash string " ++ show str + _ -> Hash (Nothing, str) -- ... hashSetSize :: Hash -> Int64 -> Hash hashSetSize (Hash (_,h)) s = Hash (Just s, h) @@ -115,3 +124,32 @@ ((a .&. (bytemask `shift` 48) `shiftR` 40)) .|. ((a .&. (bytemask `shift` 56) `shiftR` 56)) #endif + +-- | Find a monadic fixed point of @f@ that is the least above @i@. (Will +-- happily diverge if there is none.) +mfixFrom :: (Eq a, Functor m, Monad m) => (a -> m a) -> a -> m a +mfixFrom f i = do x <- f i + if x == i then return i + else mfixFrom f x + +-- | Find a fixed point of @f@ that is the least above @i@. (Will happily +-- diverge if there is none.) +fixFrom :: (Eq a) => (a -> a) -> a -> a +fixFrom f i = runIdentity $ mfixFrom (return . f) i + +-- | For a @refs@ function, a @map@ (@key@ -> @value@) and a @rootSet@, find a +-- submap of @map@ such that all items in @map@ are reachable, through @refs@ +-- from @rootSet@. +reachable :: forall monad key value. (Functor monad, Monad monad, Ord key, Eq value) => + (value -> monad [key]) + -> (key -> monad (Maybe (key, value))) + -> S.Set key -> monad (M.Map key value) +reachable refs lookup rootSet = + do lookupSet rootSet >>= mfixFrom expand + where lookupSet :: S.Set key -> monad (M.Map key value) + expand :: M.Map key value -> monad (M.Map key value) + + lookupSet s = do list <- mapM lookup (S.toAscList s) + return $ M.fromAscList (catMaybes list) + expand from = do refd <- concat <$> mapM refs (M.elems from) + M.union from <$> lookupSet (S.fromList refd) 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.6 +version: 0.3.7 synopsis: Hashed file storage support code. description: Support code for reading and manipulating hashed file storage @@ -46,6 +46,7 @@ Storage.Hashed.Index Storage.Hashed.Monad Storage.Hashed.Tree + Storage.Hashed.Packed Storage.Hashed.Darcs if flag(diff)