hashed-storage 0.3.3.2 → 0.3.4
raw patch · 7 files changed
+236/−84 lines, 7 filesdep +QuickCheckdep +test-frameworkdep +test-framework-hunitsetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: QuickCheck, test-framework, test-framework-hunit, test-framework-quickcheck
API changes (from Hackage documentation)
+ Storage.Hashed.Index: readOrUpgradeIndex :: FilePath -> (Tree -> Hash) -> IO Tree -> IO Tree
Files
- Setup.hs +45/−4
- Storage/Hashed/Index.hs +46/−17
- Storage/Hashed/Test.hs +104/−49
- Storage/Hashed/Tree.hs +3/−3
- Storage/Hashed/Utils.hs +29/−1
- hashed-storage.cabal +6/−3
- test.hs +3/−7
Setup.hs view
@@ -1,13 +1,54 @@ import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) import Distribution.Simple.LocalBuildInfo( LocalBuildInfo(..) )-import System( system )+import Distribution.PackageDescription+ ( PackageDescription(executables), Executable(buildInfo, exeName)+ , BuildInfo(customFieldsBI), emptyBuildInfo+ , updatePackageDescription, cppOptions, ccOptions )+import Distribution.Simple.Setup+ (buildVerbosity, copyDest, copyVerbosity, fromFlag,+ haddockVerbosity, installVerbosity, sDistVerbosity)+import Distribution.Verbosity+ ( Verbosity )+import System( system, exitWith ) import System.FilePath( (</>) ) +-- for endianness check+import Foreign.Marshal.Utils ( with )+import Data.Word ( Word8, Word32 )+import Foreign.Storable ( peek )+import Foreign.Ptr ( castPtr )++hst = "hashed-storage-test"+ main :: IO () main = defaultMainWithHooks simpleUserHooks { runTests = \ _ _ _ lbi -> do- system $ buildDir lbi </> hst </> hst- return ()+ exitWith =<< system (buildDir lbi </> hst </> hst),++ buildHook = \ pkg lbi hooks flags ->+ let verb = fromFlag $ buildVerbosity flags+ in commonBuildHook buildHook pkg lbi hooks verb >>= ($ flags),++ haddockHook = \ pkg lbi hooks flags ->+ let verb = fromFlag $ haddockVerbosity flags+ in commonBuildHook haddockHook pkg lbi hooks verb >>= ($ flags) }- where hst = "hashed-storage-test"++commonBuildHook :: (UserHooks -> PackageDescription -> LocalBuildInfo -> t -> a)+ -> PackageDescription -> LocalBuildInfo -> t -> Verbosity -> IO a+commonBuildHook runHook pkg lbi hooks verbosity = do+ -- Add custom -DFOO[=BAR] flags to the cpp (for .hs) and cc (for .c)+ -- invocations, doing a dance to make the base hook aware of them.+ littleEndian <- testEndianness+ let args = if littleEndian then [ "-DLITTLEENDIAN" ] else [ "-DBIGENDIAN" ]+ bi = emptyBuildInfo { cppOptions = args, ccOptions = args }+ hbi = (Just bi, [(exeName exe, bi) | exe <- executables pkg])+ pkg' = updatePackageDescription hbi pkg+ lbi' = lbi { localPkgDescr = pkg' }+ return $ runHook simpleUserHooks pkg' lbi' hooks++ where+ testEndianness :: IO Bool+ testEndianness = with (1 :: Word32) $ \p -> do o <- peek $ castPtr p+ return $ o == (1 :: Word8)
Storage/Hashed/Index.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables, NoMonomorphismRestriction #-} -- | This module contains plain tree indexing code. --@@ -29,7 +29,8 @@ -- recomputation of all of its parent directory hashes; moreover this is done -- efficiently -- each directory is updated at most once during a run. -module Storage.Hashed.Index( readIndex, updateIndexFrom ) where+module Storage.Hashed.Index( readIndex, updateIndexFrom, readOrUpgradeIndex )+ where import Prelude hiding ( lookup, readFile, writeFile, catch ) import Storage.Hashed.Utils@@ -43,6 +44,7 @@ import Bundled.Posix( getFileStatusBS, modificationTime, getFileStatus, fileSize, fileExists, EpochTime ) import System.IO.MMap( mmapFileForeignPtr, Mode(..) )+import System.IO( openBinaryFile, hGetChar, hClose, IOMode(..) ) import System.Directory( removeFile, doesFileExist ) import Control.Monad( when ) @@ -52,6 +54,7 @@ import Data.IORef( newIORef, readIORef, modifyIORef, IORef ) import Data.Maybe( fromJust, isJust )+import Data.Bits( Bits ) import Foreign.Storable import Foreign.ForeignPtr@@ -86,6 +89,14 @@ itemIsDir :: Item -> Bool itemIsDir i = BS.last (iPath i) == '/' +-- xlatePeek32 = fmap xlate32 . peek+xlatePeek64 :: (Storable a, Bits a) => Ptr a -> IO a+xlatePeek64 = fmap xlate64 . peek++-- xlatePoke32 ptr v = poke ptr (xlate32 v)+xlatePoke64 :: (Storable a, Bits a) => Ptr a -> a -> IO ()+xlatePoke64 ptr v = poke ptr (xlate64 v)+ -- | Lay out the basic index item structure in memory. The memory location is -- given by a ForeignPointer () and an offset. The path and type given are -- written out, and a corresponding Item is given back. The remaining bits of@@ -123,7 +134,7 @@ peekItem :: ForeignPtr () -> Int -> Maybe Int -> IO Item peekItem fp off dirlen = withForeignPtr fp $ \p -> do- nl' :: Int32 <- peekByteOff p off+ nl' :: Int32 <- xlate32 `fmap` peekByteOff p off let nl = fromIntegral nl' path = fromForeignPtr (castForeignPtr fp) (off + 4) (nl - 1) path_noslash = (BS.last path == '/') ? (BS.init path, path)@@ -142,14 +153,14 @@ -- when updating directory entries). update :: Item -> Maybe EpochTime -> Hash -> IO () update item mtime (Hash (Just size, hash)) =- do poke (iSize item) size+ do xlatePoke64 (iSize item) size pokeBS (iHash item) hash- when (isJust mtime) $ poke (iAux item)+ when (isJust mtime) $ xlatePoke64 (iAux item) (fromIntegral $ fromEnum $ fromJust mtime) update _ _ _ = fail "Index.update requires a hash with size included." iHash' :: Item -> IO Hash-iHash' i = do size <- peek $ iSize i+iHash' i = do size <- xlatePeek64 $ iSize i return $ hashSetSize (Hash (undefined, iHash i)) size -- | Gives a ForeignPtr to mmapped index, which can be used for reading and@@ -159,12 +170,13 @@ exist <- doesFileExist indexpath act_size <- if exist then fileSize `fmap` getFileStatus indexpath else return 0- let size = fromIntegral $+ let size :: Int+ size = fromIntegral $ if req_size > 0 then fromIntegral req_size else act_size case size of 0 -> return (castForeignPtr nullForeignPtr, size) _ -> do (x, _) <- mmapFileForeignPtr indexpath- ReadWrite (Just (0, size))+ ReadWrite (Just (0, size + 4)) return (x, size) -- | See 'readIndex'. This version also gives a map from paths to items, so the@@ -186,7 +198,7 @@ return (item, x) readDir :: AnchoredPath -> Item -> Int -> Int -> IO (Maybe TreeItem) readDir parent_path item off dl =- do dirend <- peek $ iAux item+ do dirend <- xlatePeek64 $ iAux item st <- getFileStatusBS (iPath item) let this_path = parent_path `appendPath` (Name $ iName item) nl = BS.length (iName item)@@ -195,7 +207,7 @@ (idx_item, tree_item) <- readItem this_path (fromIntegral coff) dl' next <- if itemIsDir idx_item- then peek $ iAux idx_item+ then xlatePeek64 $ iAux idx_item else return $ coff + itemSizeI idx_item rest <- subs next case tree_item of@@ -220,8 +232,8 @@ return $ if fileExists st then Just rt else Nothing readFile parent_path item = do st <- getFileStatusBS (iPath item)- mtime <- fromIntegral `fmap` (peek $ iAux item)- size <- peek $ iSize 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)@@ -236,7 +248,7 @@ then return $ Just $ File (Blob readblob $ Just hash) else return Nothing if mmap_size > 0 then- do (_, Just (Stub root h)) <- readItem (AnchoredPath []) 0 0+ do (_, Just (Stub root h)) <- readItem (AnchoredPath []) 4 0 tree <- root return (tree { treeHash = h }, item_map) else return (emptyTree, item_map)@@ -268,11 +280,12 @@ exist <- doesFileExist indexpath when exist $ removeFile indexpath -- to avoid clobbering oldidx (mmap, _) <- mmapIndex indexpath len- let create (File _) path off =+ let magic = fromForeignPtr (castForeignPtr mmap) 0 4+ create (File _) path off = do i <- createItem BlobType path mmap off case M.lookup path item_map of Nothing -> return ()- Just item -> do mtime <- peek $ iAux item+ Just item -> do mtime <- xlatePeek64 $ iAux item hash <- iHash' item update i (Just $ fromIntegral mtime) hash return $ off + itemSize i@@ -287,9 +300,25 @@ noff <- subs xs create x path' noff lastOff <- subs (listImmediate s)- poke (iAux i) (fromIntegral lastOff)+ xlatePoke64 (iAux i) (fromIntegral lastOff) return lastOff create (Stub _ _) path _ = fail $ "Cannot create index from stubbed Tree at " ++ show path- create (SubTree reference) (AnchoredPath []) 0+ pokeBS magic (BS.pack "HSI0")+ create (SubTree reference) (AnchoredPath []) 4 readIndex indexpath hashtree++-- | 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+ fd <- openBinaryFile path ReadMode+ magic <- sequence [ hGetChar fd | _ <- [1..4] :: [Int] ]+ hClose fd+ case magic of+ "HSI0" -> readIndex path hashtree+ _ -> do ref <- getref >>= expand+ removeFile path+ updateIndexFrom path hashtree ref
Storage/Hashed/Test.hs view
@@ -1,12 +1,14 @@-module Storage.Hashed.Test where+module Storage.Hashed.Test( tests ) where import Prelude hiding ( read ) import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.ByteString.Char8 as BS-import Test.HUnit import System.Process-import Control.Monad( forM_ )+import System.Directory( doesFileExist, removeFile )+import Control.Monad( forM_, when ) import Data.Maybe+import Data.Word+import Data.Bits import Data.List( (\\), sort ) import Storage.Hashed import Storage.Hashed.AnchoredPath@@ -15,34 +17,69 @@ import Storage.Hashed.Utils import Storage.Hashed.Darcs -testsDarcsBasic :: Test-testsDarcsBasic =- TestList [ TestLabel "have_files" have_files- , TestLabel "have_pristine_files" have_pristine_files- , TestLabel "darcs_manifest" darcs_manifest- , TestLabel "darcs_contents" darcs_contents ]+import Test.HUnit+import Test.Framework( testGroup )+import Test.QuickCheck++import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck++------------------------+-- Test Data+--++files = [ floatPath "hashed-storage.cabal"+ , floatPath "Storage/Hashed.hs"+ , floatPath "Storage/Hashed/Index.hs" ]++emptyStub = Stub (return emptyTree) Nothing++testTree =+ makeTree [ (makeName "foo", emptyStub)+ , (makeName "subtree", SubTree sub)+ , (makeName "substub", Stub getsub Nothing) ]+ where sub = makeTree [ (makeName "stub", emptyStub)+ , (makeName "substub", Stub getsub2 Nothing)+ , (makeName "x", SubTree emptyTree) ]+ getsub = return sub+ getsub2 = return $ makeTree [ (makeName "file", File emptyBlob) ]++---------------------------+-- Test list+--++tests = [ testGroup "darcs" darcs+ , testGroup "Storage.Hashed.Index" index+ , testGroup "Storage.Hashed.Tree" tree+ , testGroup "Storage.Hashed.Utils" utils ]++--------------------------+-- Tests+--++darcs = [ testCase "specific files" have_files+ , testCase "pristine files" have_pristine_files+ , testCase "list == darcs show manifest" darcs_manifest+ , testCase "content == darcs show contents" darcs_contents ] where- files = [ floatPath "hashed-storage.cabal"- , floatPath "Storage/Hashed.hs"- , floatPath "Storage/Hashed/Index.hs" ] check_file t f = assertBool ("path " ++ show f ++ " is in tree") (isJust $ find t f) check_files = forM_ files . check_file- have_files = TestCase $ readPlainTree "." >>= expand >>= check_files- have_pristine_files = TestCase $+ have_files = readPlainTree "." >>= expand >>= check_files+ have_pristine_files = readDarcsPristine "." >>= expand >>= check_files - -- NB. If darcs starts using hashed-storage internally, the following- -- tests become useless, since they check our code against darcs.- darcs_manifest = TestCase $ do+ -- NB. When hashed-storage replace slurpies in darcs, the following 2+ -- tests become useless, since they just check our code against darcs.+ darcs_manifest = do f <- lines `fmap` readProcess "darcs" ["show", "files" ] "" t <- readDarcsPristine "." >>= expand forM_ (f \\ ["."]) (\x -> check_file t (floatPath x)) forM_ (list t) (\x -> assertBool (show (fst x) ++ " is in darcs show files") $ anchorPath "." (fst x) `elem` f)- darcs_contents = TestCase $ do+ darcs_contents = do t <- readDarcsPristine "." >>= expand sequence_ [ do our <- read b@@ -51,47 +88,49 @@ assertEqual "contents match" (BL.unpack our) darcs | (p, File b) <- list t ] -testsTreeIndex :: Test-testsTreeIndex =- TestList [ TestLabel "check_index" check_index- , TestLabel "check_index_content" check_index_content ]+index = [ testCase "index listing" check_index+ , testCase "index content" check_index_content+ , testCase "index versioning" check_index_versions ] where pristine = readDarcsPristine "." >>= expand- {-- working = do- x <- pristine- plain <- readPlainTree "."- expand (restrict x plain)- -} build_index =- do x <- pristine >>= expand+ do x <- pristine+ exist <- doesFileExist "_darcs/index"+ when exist $ removeFile "_darcs/index" idx <- updateIndexFrom "_darcs/index" darcsTreeHash x >>= expand return (x, idx)- check_index = TestCase $+ 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 assertEqual ("content match on " ++ show p) a b- check_index_content = TestCase $+ check_index_content = do (_, idx) <- build_index plain <- readPlainTree "." x <- sequence $ zipCommonFiles check_blob_pair plain idx assertBool "files match" (length x > 0)+ check_index_versions =+ do 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) -testsGeneric :: Test-testsGeneric = TestList [ TestLabel "check_modify" check_modify- , TestLabel "check_modify_complex" check_modify_complex ]+tree = [ testCase "modifyTree" check_modify+ , testCase "complex modifyTree" check_modify_complex+ , testCase "expand" check_expand+ , testCase "expandPath" check_expand_path ] where blob x = File $ Blob (return (BL.pack x)) (Just $ sha256 $ BL.pack x) name = Name . BS.pack- check_modify = TestCase $+ 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") assertEqual "old version" x (BL.pack "bar") assertEqual "new version" y (BL.pack "bla")- check_modify_complex = TestCase $+ check_modify_complex = let t = makeTree [ (name "foo", blob "bar") , (name "bar", SubTree t1) ] t1 = makeTree [ (name "foo", blob "bar") ]@@ -106,18 +145,34 @@ 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")+ no_stubs t = null [ () | (_, Stub _ _) <- list t ]+ path = floatPath "substub/substub/file"+ badpath = floatPath "substub/substub/foo"+ check_expand = do+ x <- expand testTree+ assertBool "no stubs in testTree" $ not (no_stubs testTree)+ assertBool "stubs in expanded tree" $ no_stubs x+ assertBool "path reachable" $ path `elem` (map fst $ list x)+ assertBool "badpath not reachable" $+ badpath `notElem` (map fst $ list x)+ check_expand_path = do+ t <- expandPath testTree path+ assertBool "path reachable" $ path `elem` (map fst $ list t)+ assertBool "badpath not reachable" $+ badpath `notElem` (map fst $ list t) -emptyStub = Stub (return emptyTree) Nothing-testTree = makeTree [ (makeName "foo", emptyStub)- , (makeName "subtree", SubTree sub) ]- where sub = makeTree [ (makeName "stub", emptyStub)- , (makeName "x", SubTree emptyTree)]+utils = [ testProperty "xlate32" prop_xlate32+ , testProperty "xlate64" prop_xlate64 ]+ where prop_xlate32 x = (xlate32 . xlate32) x == x where types = x :: Word32+ prop_xlate64 x = (xlate64 . xlate64) x == x where types = x :: Word64 -testsTree :: Test-testsTree = TestList [ TestLabel "check_expand" check_expand ]- where no_stubs t = null [ () | (_, Stub _ _) <- list t]- check_expand = TestCase $ do- x <- expand testTree- assertBool "no stubs in testTree" $- not (no_stubs testTree)- assertBool "stubs in expanded tree" $ no_stubs x+instance Arbitrary Word32 where+ arbitrary = do x <- arbitrary :: Gen Int+ return $ fromIntegral x++instance Arbitrary Word64 where+ arbitrary = do x <- arbitrary :: Gen Int+ y <- arbitrary :: Gen Int+ let x' = fromIntegral x+ y' = fromIntegral y+ return $ x' .|. (y' `shift` 32)
Storage/Hashed/Tree.hs view
@@ -175,10 +175,10 @@ (Just (SubTree t')) -> amend t n rest t' _ -> fail $ "Descent error in expandPath: " ++ show path_ amend t name rest sub = do- t' <- expand' sub (AnchoredPath rest)+ sub' <- expand' sub (AnchoredPath rest) let orig_l = [ i | i@(n',_) <- listImmediate t, name /= n' ]- tree = t { items = M.insert name (SubTree sub) (items t)- , listImmediate = (name, SubTree sub) : orig_l }+ tree = t { items = M.insert name (SubTree sub') (items t)+ , listImmediate = (name, SubTree sub') : orig_l } return tree -- | Given two Trees, a @guide@ and a @tree@, produces a new Tree that is a
Storage/Hashed/Utils.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP, ScopedTypeVariables #-} -- | Mostly internal utilities for use by the rest of the library. Subject to -- removal without further notice.@@ -19,6 +19,8 @@ import Foreign.Ptr( plusPtr ) import Data.ByteString.Internal( toForeignPtr, memcpy ) +import Data.Bits( (.&.), (.|.), shift, shiftL, shiftR, Bits )+ import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.ByteString.Char8 as BS @@ -87,3 +89,29 @@ memcpy (plusPtr p_to off_to) (plusPtr p_from off_from) (fromIntegral len_to)++xlate32 :: (Bits a) => a -> a+xlate64 :: (Bits a) => a -> a++#ifdef LITTLEENDIAN+xlate32 = id+xlate64 = id+#endif++#ifdef BIGENDIAN+bytemask :: (Bits a) => a+bytemask = 255++xlate32 a = ((a .&. (bytemask `shift` 0) `shiftL` 24)) .|.+ ((a .&. (bytemask `shift` 8) `shiftL` 8)) .|.+ ((a .&. (bytemask `shift` 16) `shiftR` 8)) .|.+ ((a .&. (bytemask `shift` 24) `shiftR` 24))+xlate64 a = ((a .&. (bytemask `shift` 0) `shiftL` 56)) .|.+ ((a .&. (bytemask `shift` 8) `shiftL` 40)) .|.+ ((a .&. (bytemask `shift` 16) `shiftL` 24)) .|.+ ((a .&. (bytemask `shift` 24) `shiftL` 8)) .|.+ ((a .&. (bytemask `shift` 32) `shiftR` 8)) .|.+ ((a .&. (bytemask `shift` 40) `shiftR` 24)) .|.+ ((a .&. (bytemask `shift` 48) `shiftR` 40)) .|.+ ((a .&. (bytemask `shift` 56) `shiftR` 56))+#endif
hashed-storage.cabal view
@@ -1,5 +1,5 @@ name: hashed-storage-version: 0.3.3.2+version: 0.3.4 synopsis: Hashed file storage support code. description: Support code for reading and manipulating hashed file storage@@ -57,7 +57,7 @@ c-sources: Bundled/sha2.c - extensions: PatternSignatures+ extensions: PatternSignatures, NoMonomorphismRestriction executable hashed-storage-test if impl(ghc >= 6.8)@@ -72,7 +72,10 @@ c-sources: Bundled/sha2.c if flag(test)- build-depends: HUnit, process >= 1.0.1+ build-depends: test-framework,+ test-framework-hunit,+ test-framework-quickcheck,+ QuickCheck, HUnit, process >= 1.0.1 else buildable: False
test.hs view
@@ -1,9 +1,5 @@-import Storage.Hashed.Test-import Test.HUnit+import Storage.Hashed.Test( tests )+import Test.Framework( defaultMain ) main :: IO ()-main = do runTestTT testsDarcsBasic- runTestTT testsTreeIndex- runTestTT testsGeneric- runTestTT testsTree- return ()+main = defaultMain tests