diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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) 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 #-} +{-# 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 diff --git a/Storage/Hashed/Test.hs b/Storage/Hashed/Test.hs --- a/Storage/Hashed/Test.hs +++ b/Storage/Hashed/Test.hs @@ -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) diff --git a/Storage/Hashed/Tree.hs b/Storage/Hashed/Tree.hs --- a/Storage/Hashed/Tree.hs +++ b/Storage/Hashed/Tree.hs @@ -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 diff --git a/Storage/Hashed/Utils.hs b/Storage/Hashed/Utils.hs --- a/Storage/Hashed/Utils.hs +++ b/Storage/Hashed/Utils.hs @@ -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 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.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 diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -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