diff --git a/Bundled/Posix.hsc b/Bundled/Posix.hsc --- a/Bundled/Posix.hsc +++ b/Bundled/Posix.hsc @@ -1,4 +1,5 @@ -{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + module Bundled.Posix( getFdStatus, getSymbolicLinkStatus, getFileStatus , getFileStatusBS , fileExists @@ -70,7 +71,7 @@ #include getSymbolicLinkStatus :: FilePath -> IO FileStatus -getSymbolicLinkStatus fp = +getSymbolicLinkStatus fp = do_stat (\p -> (fp `withCString` (`lstat` p))) getFileStatus :: FilePath -> IO FileStatus diff --git a/Bundled/SHA256.hs b/Bundled/SHA256.hs --- a/Bundled/SHA256.hs +++ b/Bundled/SHA256.hs @@ -27,7 +27,7 @@ sha256 :: B.ByteString -> String sha256 p = unsafePerformIO $ - withCString (take 64 $ repeat 'x') $ \digestCString -> + withCString (replicate 64 'x') $ \digestCString -> unsafeUseAsCStringLen p $ \(ptr,n) -> do let digest = castPtr digestCString :: Ptr Word8 c_sha256 ptr (fromIntegral n) digest @@ -45,4 +45,3 @@ -- foreign import ccall unsafe "sha2.h sha256" c_sha256 :: Ptr CChar -> CSize -> Ptr Word8 -> IO () - diff --git a/Bundled/sha2.c b/Bundled/sha2.c --- a/Bundled/sha2.c +++ b/Bundled/sha2.c @@ -947,4 +947,3 @@ } #endif /* TEST_VECTORS */ - diff --git a/Bundled/sha2.h b/Bundled/sha2.h --- a/Bundled/sha2.h +++ b/Bundled/sha2.h @@ -105,4 +105,3 @@ #endif #endif /* !SHA2_H */ - diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright Petr Rockai 2009 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -4,8 +4,9 @@ import System( system ) import System.FilePath( () ) +main :: IO () main = defaultMainWithHooks simpleUserHooks { - runTests = \ _ _ pkg lbi -> do + runTests = \ _ _ _ lbi -> do system $ buildDir lbi hst hst return () } diff --git a/Storage/Hashed.hs b/Storage/Hashed.hs --- a/Storage/Hashed.hs +++ b/Storage/Hashed.hs @@ -60,17 +60,17 @@ print' (Just (SubTree t')) = do putStrLn $ "== Listing Tree " ++ p ++ " (immediates only):" putStr $ unlines $ map BS.unpack $ listNames t' - print' (Just (Stub _ _)) = do + print' (Just (Stub _ _)) = putStrLn $ "== (not listing stub at " ++ p ++ ")" listNames t' = [ n | (Name n, _) <- listImmediate t' ] readPlainDir :: FilePath -> IO [(FilePath, FileStatus)] readPlainDir dir = - do withCurrentDirectory dir $ do - items <- getDirectoryContents "." - sequence [ do st <- getFileStatus s - return (s, st) - | s <- items, not $ s `elem` [ ".", ".." ] ] + 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 @@ -107,7 +107,7 @@ 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' + where hash = BS.concat $ BL.toChunks h' parse _ = [] parse' x | x == BL.pack "file:" = BlobType @@ -121,16 +121,16 @@ readDarcsHashed dir root = do items <- readDarcsHashedDir dir root subs <- sequence [ - do 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)) + 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 name = fmap decompress $ readSegment $ location name + 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 @@ -164,4 +164,3 @@ 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 @@ -1,9 +1,11 @@ +-- | This module implements relative paths within a Tree. All paths are +-- 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 - , isPrefix, parent, parents, catPaths + , isPrefix, parent, parents, catPaths, flatten -- * Unsafe functions. - , nameToFilePath, nameFromFilePath - , floatBS, anchorBS ) where + , nameToFilePath, nameFromFilePath, floatBS ) where import qualified Data.ByteString.Char8 as BS import Data.List( isPrefixOf, inits ) @@ -16,14 +18,15 @@ newtype Name = Name BS.ByteString deriving (Eq, Show, Ord) newtype AnchoredPath = AnchoredPath [Name] deriving (Eq, Show, Ord) --- Both unsafe. - +-- | Unsafe. nameToFilePath :: Name -> FilePath nameToFilePath (Name p) = BS.unpack p +-- | Unsafe. nameFromFilePath :: FilePath -> Name -nameFromFilePath p = Name $ BS.pack p +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 @@ -34,12 +37,17 @@ (Name s) | s == BS.empty -> AnchoredPath p | otherwise -> AnchoredPath $ p ++ [n] +-- | Catenate two paths together. Not very safe, but sometimes useful +-- (e.g. when you are representing paths relative to a different point than a +-- Tree root). catPaths :: AnchoredPath -> AnchoredPath -> AnchoredPath catPaths (AnchoredPath p) (AnchoredPath n) = AnchoredPath $ p ++ n +-- | Get parent (path) of a given path. foo/bar/baz -> foo/bar parent :: AnchoredPath -> AnchoredPath parent (AnchoredPath x) = AnchoredPath (init x) +-- | List all parents of a given path. foo/bar/baz -> [foo, foo/bar] parents :: AnchoredPath -> [AnchoredPath] parents (AnchoredPath x) = case x of @@ -47,16 +55,16 @@ [_] -> [AnchoredPath []] _ -> map AnchoredPath $ tail $ inits (init x) --- | Take a "root" directory and an anchored path and produce a full path. +-- | Take a "root" directory and an anchored path and produce a full +-- 'FilePath'. Moreover, you can use anchorPath "" to get a relative +-- 'FilePath'. anchorPath :: FilePath -> AnchoredPath -> FilePath -anchorPath dir (AnchoredPath p) = dir path - where path = BS.unpack (flatten p) - flatten = BS.intercalate (BS.singleton '/') . map (\(Name x) -> x) +anchorPath dir p = dir BS.unpack (flatten p) {-# INLINE anchorPath #-} floatBS :: BS.ByteString -> AnchoredPath floatBS = AnchoredPath . map Name . takeWhile (not . BS.null) . BS.split '/' -anchorBS :: AnchoredPath -> BS.ByteString -anchorBS (AnchoredPath p) = BS.intercalate (BS.singleton '/') +flatten :: AnchoredPath -> BS.ByteString +flatten (AnchoredPath p) = BS.intercalate (BS.singleton '/') [ n | (Name n) <- p ] diff --git a/Storage/Hashed/Diff.hs b/Storage/Hashed/Diff.hs --- a/Storage/Hashed/Diff.hs +++ b/Storage/Hashed/Diff.hs @@ -40,7 +40,7 @@ -- | Produce unified diff (in a string form, ie. formatted) from a pair of -- bytestrings. unifiedDiff :: BL.ByteString -> BL.ByteString -> BL.ByteString -unifiedDiff a b = printUnified $ concat $ unifiedHunks +unifiedDiff a b = printUnified $ concat unifiedHunks where unifiedHunks = reduceContext 3 $ map unifyHunk $ hunks $ weave a b -- | Weave two bytestrings. Intermediate data structure for the actual unidiff @@ -54,18 +54,18 @@ common = lcs left right weave' [] [] [] = [] weave' [] c [] = error $ "oops: Left & Right empty, Common: " ++ show c - weave' [] [] (b:bs) = (Add b):weave' [] [] bs - weave' (a:as) [] [] = (Remove a):weave' as [] [] - weave' (a:as) [] (b:bs) = (Replace a b):weave' as [] bs + weave' [] [] (b:bs) = Add b : weave' [] [] bs + weave' (a:as) [] [] = Remove a : weave' as [] [] + weave' (a:as) [] (b:bs) = Replace a b : weave' as [] bs weave' (a:as) (c:cs) (b:bs) - | a == c && b == c = (Common a):weave' as cs bs - | a == c && b /= c = (Add b):weave' (a:as) (c:cs) bs - | a /= c && b == c = (Remove a):weave' as (c:cs) (b:bs) - | a /= c && b /= c = (Replace a b):weave' as (c:cs) bs + | a == c && b == c = Common a : weave' as cs bs + | a == c && b /= c = Add b : weave' (a:as) (c:cs) bs + | a /= c && b == c = Remove a : weave' as (c:cs) (b:bs) + | a /= c && b /= c = Replace a b : weave' as (c:cs) bs | otherwise = error "oops!" weave' a c b = error $ "oops: \nLeft: " ++ show a ++ "\nCommon: " ++ show c ++ "\nRight: " ++ show b --- | Break up a Weave into hunks. +-- | Break up a 'Weave' into 'Hunk's. hunks :: Weave -> [Hunk] hunks = groupBy grp where grp (Common _) (Common _) = True @@ -73,10 +73,10 @@ grp _ (Common _) = False grp _ _ = True --- | Reformat a Hunk into a format suitable for unified diff. Replaces are +-- | Reformat a 'Hunk' into a format suitable for unified diff. Replaces are -- turned into add/remove pairs, all removals in a hunk go before all --- adds. Hunks of Common lines are left intact. Produces input suitable for --- reduceContext. +-- adds. 'Hunk's of 'Common' lines are left intact. Produces input suitable for +-- 'reduceContext'. unifyHunk :: Hunk -> Hunk unifyHunk h = case h of (Common _:_) -> h @@ -85,16 +85,16 @@ breakup (Replace f t) = [Remove f, Add t] breakup x = [x] --- | Break up a 'Weave' into unified hunks, leaving @n@ lines of context around --- every hunk. Consecutive Common lines not used as context are replaced with --- Skips. +-- | Break up a 'Weave' into unified 'Hunk's, leaving @n@ lines of context around +-- every hunk. Consecutive 'Common' lines not used as context are replaced with +-- 'Skip's. reduceContext :: Int -> [Hunk] -> [Hunk] reduceContext n hs = case hs of [] -> [] [Common _:_] -> [] [x] -> [x] - [h,t] -> reduce 0 n h : reduce n 0 t : [] + [h,t] -> [reduce 0 n h, reduce n 0 t] (h:rest) -> reduce 0 n h : map (reduce n n) (init rest) ++ [reduce n 0 $ last rest] @@ -106,7 +106,7 @@ drop (length h - e) h reduce _ _ h = h --- | Format a Weave for printing. +-- | Format a 'Weave' for printing. deweave :: Weave -> BL.ByteString deweave = BL.unlines . map disp where disp (Common l) = BL.cons ' ' l @@ -115,8 +115,8 @@ disp (Replace _ t) = BL.cons '!' t disp (Skip n) = BL.pack $ "-- skip " ++ show n ++ " lines --" --- | Print a "hunked" weave in form of an unified diff. Hunk boundaries are --- marked up as "Skip" lines. Cf. "reduceContext". +-- | Print a \"hunked\" weave in form of an unified diff. 'Hunk' boundaries are +-- marked up as 'Skip' lines. Cf. 'reduceContext'. printUnified :: Weave -> BL.ByteString printUnified hunked = printHunks 1 1 $ groupBy splits hunked where splits (Skip _) _ = False 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,5 @@ -{-# LANGUAGE PatternSignatures, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Storage.Hashed.Index where import Prelude hiding ( lookup, readFile, writeFile, catch ) @@ -38,7 +39,7 @@ -- used by git... It turns out that it's hard to efficiently read a flat index -- 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). +-- also efficiently implement subtree queries this way (cf. 'readIndex'). data Item = Item { iPath :: BS.ByteString , iName :: BS.ByteString , iHash :: BS.ByteString @@ -57,7 +58,7 @@ createItem :: ItemType -> AnchoredPath -> ForeignPtr () -> Int -> IO Item createItem typ path fp off = - do let name = BS.concat [ anchorBS path, + do let name = BS.concat [ flatten path, (typ == TreeType) ? (BS.singleton '/', BS.empty), BS.singleton '\0' ] (namefp, nameoff, namel) = toForeignPtr name @@ -107,14 +108,14 @@ let size = fromIntegral $ if req_size > 0 then fromIntegral req_size else act_size case size of - 0 -> return (castForeignPtr $ nullForeignPtr, size) + 0 -> return (castForeignPtr nullForeignPtr, size) _ -> do (x, _) <- mmapFileForeignPtr "_darcs/index" ReadWrite (Just (0, size)) return (x, size) --- |See "readIndex". This version also gives a map from paths to items, so the +-- |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 unfolded. +-- form of 'IORef', since the data is not available until the tree is unfolded. readIndex' :: IO (Tree, IORef (M.Map AnchoredPath Item)) readIndex' = do (mmap, mmap_size) <- mmapIndex 0 @@ -179,24 +180,24 @@ if fileExists st then return $ Just $ File (Blob readblob $ Just hash) else return Nothing - if (mmap_size > 0) then + if mmap_size > 0 then do (_, Just (Stub root h)) <- readItem (AnchoredPath []) 0 0 tree <- root return (tree { treeHash = h }, item_map) else return (emptyTree, item_map) --- |Read an index and build up a Tree object from it, referring to current +-- |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 +-- 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 unfolded will be actually updated! -- To implement a subtree query, you can use 'Tree.filter' and then unfold the -- result. Otherwise just unfold the whole tree to avoid unexpected problems. readIndex :: IO Tree readIndex = fst `fmap` readIndex' --- |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 under FilePath). +-- |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 under 'FilePath'). updateIndexFrom :: Tree -> IO Tree updateIndexFrom ref = do (oldidx', item_map') <- readIndex' @@ -223,8 +224,7 @@ do i <- createItem TreeType path mmap off case M.lookup path item_map of Nothing -> return () - Just item -> do hash <- iHash' item - update i Nothing hash + Just item -> iHash' item >>= update i Nothing let subs [] = return $ off + itemSize i subs ((name,x):xs) = do let path' = path `appendPath` name diff --git a/Storage/Hashed/Monad.hs b/Storage/Hashed/Monad.hs --- a/Storage/Hashed/Monad.hs +++ b/Storage/Hashed/Monad.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PatternSignatures, ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} -- | 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 @@ -31,20 +31,22 @@ import Control.Monad.State.Strict import qualified Data.Set as S +-- | 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 () } --- | A TreeIO monad. A sort of like IO but it keeps a TreeState around as well, +-- | 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 --- TreeIO, the actions in your virtual filesystem get somehow reflected in the --- actual real filesystem. For "virtualTreeIO", nothing happens in real --- filesystem, however with "plainTreeIO", the plain tree will be updated every --- now and then, and with "hashedTreeIO" a darcs-style hashed tree will get +-- 'TreeIO', the actions in your virtual filesystem get somehow reflected in the +-- actual real filesystem. For 'virtualTreeIO', nothing happens in real +-- 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 a = StateT TreeState IO a +type TreeIO = StateT TreeState IO initialState :: Tree -> TreeIO () -> TreeState initialState t s = TreeState { cwd = AnchoredPath [] @@ -66,12 +68,12 @@ 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 +-- | 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). -fs_createHashedFile :: FilePath -> BL.ByteString -> TreeIO () -fs_createHashedFile fn content = +fsCreateHashedFile :: FilePath -> BL.ByteString -> TreeIO () +fsCreateHashedFile fn content = liftIO $ do exist <- doesFileExist fn unless exist $ BL.writeFile fn content @@ -90,7 +92,7 @@ t' <- liftIO $ unfoldPath t p modify $ \st -> st { tree = t' } --- | Run a TreeIO @action@ in a hashed setting. The @initial@ tree is assumed +-- | 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. -- @@ -115,7 +117,7 @@ let fn = dir BS.unpack (darcsFormatHash h) nblob = File $ Blob (decompress `fmap` BL.readFile fn) (Just h) newcontent <- liftIO $ compress `fmap` read b - fs_createHashedFile fn newcontent + fsCreateHashedFile fn newcontent replaceItemAbs path (Just nblob) updateFile path b@(Blob _ Nothing) = do content <- liftIO $ read b @@ -123,17 +125,17 @@ fn = dir BS.unpack (darcsFormatHash h) nblob = File $ Blob (decompress `fmap` BL.readFile fn) (Just h) newcontent = compress content - fs_createHashedFile fn newcontent + 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 }) - fs_createHashedFile fn (compress dirdata) + fsCreateHashedFile fn (compress dirdata) replaceItemAbs path (Just ns) --- | Run a TreeIO action in a plain tree setting. Writes out changes to the +-- | 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 diff --git a/Storage/Hashed/Test.hs b/Storage/Hashed/Test.hs --- a/Storage/Hashed/Test.hs +++ b/Storage/Hashed/Test.hs @@ -8,14 +8,14 @@ import Control.Monad( forM_ ) import Data.Maybe import Data.List( (\\), sort ) -import System.Directory import Storage.Hashed import Storage.Hashed.AnchoredPath import Storage.Hashed.Tree import Storage.Hashed.Index import Storage.Hashed.Utils -tests_darcs_basic = +testsDarcsBasic :: Test +testsDarcsBasic = TestList [ TestLabel "have_files" have_files , TestLabel "have_pristine_files" have_pristine_files , TestLabel "darcs_manifest" darcs_manifest @@ -27,7 +27,7 @@ check_file t f = assertBool ("path " ++ show f ++ " is in tree") (isJust $ find t f) - check_files t = forM_ files (check_file t) + check_files = forM_ files . check_file have_files = TestCase $ readPlainTree "." >>= unfold >>= check_files have_pristine_files = TestCase $ readDarcsPristine "." >>= unfold >>= check_files @@ -50,14 +50,17 @@ assertEqual "contents match" (BL.unpack our) darcs | (p, File b) <- list t ] -tests_tree_index = +testsTreeIndex :: Test +testsTreeIndex = TestList [ TestLabel "check_index" check_index , TestLabel "check_index_content" check_index_content ] where pristine = readDarcsPristine "." >>= unfold + {- working = do x <- pristine plain <- readPlainTree "." unfold (restrict x plain) + -} build_index = do x <- pristine >>= unfold idx <- updateIndexFrom x >>= unfold @@ -75,29 +78,30 @@ x <- sequence $ zipCommonFiles check_blob_pair plain idx assertBool "files match" (length x > 0) -tests_generic = TestList [ TestLabel "check_modify" check_modify +testsGeneric :: Test +testsGeneric = TestList [ TestLabel "check_modify" check_modify , TestLabel "check_modify_complex" check_modify_complex ] where blob x = File $ Blob (return (BL.pack x)) (Just $ sha256 $ BL.pack x) name = Name . BS.pack check_modify = TestCase $ let t = makeTree [(name "foo", blob "bar")] - mod = modifyTree t (floatPath "foo") (Just $ blob "bla") + modify = modifyTree t (floatPath "foo") (Just $ blob "bla") in do x <- read $ fromJust $ findFile t (floatPath "foo") - y <- read $ fromJust $ findFile mod (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 $ let t = makeTree [ (name "foo", blob "bar") , (name "bar", SubTree t1) ] t1 = makeTree [ (name "foo", blob "bar") ] - mod = modifyTree t (floatPath "bar/foo") (Just $ blob "bla") + modify = modifyTree t (floatPath "bar/foo") (Just $ blob "bla") in do foo <- read $ fromJust $ findFile t (floatPath "foo") - foo' <- read $ fromJust $ findFile mod (floatPath "foo") + foo' <- read $ fromJust $ findFile modify (floatPath "foo") bar_foo <- read $ fromJust $ findFile t (floatPath "bar/foo") bar_foo' <- read $ fromJust $ - findFile mod (floatPath "bar/foo") + findFile modify (floatPath "bar/foo") assertEqual "old foo" foo (BL.pack "bar") assertEqual "old bar/foo" bar_foo (BL.pack "bar") assertEqual "new foo" foo' (BL.pack "bar") diff --git a/Storage/Hashed/Tree.hs b/Storage/Hashed/Tree.hs --- a/Storage/Hashed/Tree.hs +++ b/Storage/Hashed/Tree.hs @@ -144,7 +144,7 @@ -- | Find a 'TreeItem' by its path. Gives 'Nothing' if the path is invalid. find :: Tree -> AnchoredPath -> Maybe TreeItem -find t p = find' (SubTree t) p +find = find' . SubTree -- | Find a 'Blob' by its path. Gives 'Nothing' if the path is invalid, or does -- not point to a Blob. @@ -188,7 +188,7 @@ tree <- stub sub <- unfold' tree npath return (name, SubTree sub) - item n stub p = subtree n stub p + item = subtree isStub (Stub _ _) = True isStub _ = False @@ -302,7 +302,7 @@ maybeUnfold i = return i immediateN t = [ n | (n, _) <- listImmediate t ] diff left' right' = do - items <- sequence [ + is <- sequence [ case (lookup left' n, lookup right' n) of (Just l, Nothing) -> do l' <- maybeUnfold l @@ -317,18 +317,17 @@ do x <- subtree l y <- subtree r (x', y') <- diffTrees x y - return $ (n, - Just $ SubTree x', - Just $ SubTree y') + 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') + return (n, Just l', Just r') + _ -> error "n lookups failed" | n <- immediateN left' `union` immediateN right' ] - let items_l = [ (n, l) | (n, Just l ,_) <- items ] - items_r = [ (n, r) | (n, _, Just r) <- items ] - return (makeTree items_l, makeTree items_r) + 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 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 PatternSignatures, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Mostly internal utilities for use by the rest of the library. Subject to -- removal without further notice. @@ -36,7 +36,7 @@ darcsFormatSize :: (Num a) => a -> BS.ByteString darcsFormatSize s = BS.pack $ replicate (10 - length n) '0' ++ n - where n = (show s) + where n = show s darcsFormatHash :: Hash -> BS.ByteString darcsFormatHash (Hash (Just s, h)) = @@ -78,14 +78,14 @@ -- | Run an IO action with @path@ as a working directory. Does neccessary -- bracketing. withCurrentDirectory :: FilePath -> IO a -> IO a -withCurrentDirectory name m = +withCurrentDirectory name = bracket (do cwd <- getCurrentDirectory when (name /= "") (setCurrentDirectory name) return cwd) (\oldwd -> setCurrentDirectory oldwd `catch` \(_::SomeException) -> return ()) - (const m) + . const -- Ternary kind of operator. Just a concise way to write if. (?) :: Bool -> (a, a) -> a @@ -103,10 +103,9 @@ 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 = " - ++ (show len_from) ++ " /= to = " ++ (show len_to) - withForeignPtr fp_from $ \p_from -> do - withForeignPtr fp_to $ \p_to -> do + ++ 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) - diff --git a/hashed-storage.cabal b/hashed-storage.cabal --- a/hashed-storage.cabal +++ b/hashed-storage.cabal @@ -1,55 +1,68 @@ -Name: hashed-storage -Version: 0.3 -License: BSD3 -Copyright: 2009 Petr Rockai -Author: Petr Rockai -Maintainer: Petr Rockai -Synopsis: Hashed file storage support code. -Description: - Support code for reading and manipulating hashed file storage (where each - file and directory is associated with a cryptographic hash, for - corruption-resistant storage and fast comparisons). - . - The supported storage formats include darcs hashed pristine, a plain - filesystem tree and an indexed plain tree (where the index maintains hashes - of the plain files and directories). +name: hashed-storage +version: 0.3.1 +synopsis: Hashed file storage support code. -Category: System -Build-Type: Custom -Cabal-Version: >=1.2 +description: Support code for reading and manipulating hashed file storage + (where each file and directory is associated with a + cryptographic hash, for corruption-resistant storage and fast + comparisons). + . + The supported storage formats include darcs hashed pristine, a + plain filesystem tree and an indexed plain tree (where the index + maintains hashes of the plain files and directories). darcs' + pristine.hashed. +license: BSD3 +license-file: LICENSE +copyright: 2009 Petr Rockai +author: Petr Rockai +maintainer: Petr Rockai +category: System +build-type: Custom +cabal-version: >= 1.2 extra-source-files: Bundled/sha2.h -Library - ghc-options: -Wall -O2 +flag test + default: False + +library + if impl(ghc >= 6.8) + ghc-options: -fwarn-tabs + ghc-options: -Wall -O2 ghc-prof-options: -prof -auto-all -O2 - Exposed-Modules: + exposed-modules: Storage.Hashed Storage.Hashed.AnchoredPath - Storage.Hashed.Tree - Storage.Hashed.Index Storage.Hashed.Diff + Storage.Hashed.Index Storage.Hashed.Monad + Storage.Hashed.Tree - Other-Modules: + other-modules: + Bundled.Posix + Bundled.SHA256 Storage.Hashed.Utils Storage.Hashed.Test - Build-Depends: base, directory, filepath, + build-depends: base, directory, filepath, bytestring, bytestring-mmap, zlib, lcs, binary, containers, mtl, extensible-exceptions, mmap - other-modules: Bundled.SHA256 - Bundled.Posix c-sources: Bundled/sha2.c -Executable hashed-storage-test - ghc-options: -O2 +executable hashed-storage-test + if impl(ghc >= 6.8) + ghc-options: -fwarn-tabs + ghc-options: -Wall -O2 + ghc-prof-options: -prof -auto-all -O2 + + main-is: test.hs other-modules: Bundled.Posix c-sources: Bundled/sha2.c - Main-Is: test.hs - Build-Depends: HUnit, process >= 1.0.1 + build-depends: HUnit, process >= 1.0.1 + if !flag(test) + buildable: False diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -1,6 +1,8 @@ import Storage.Hashed.Test import Test.HUnit -main = do runTestTT tests_darcs_basic - runTestTT tests_tree_index - runTestTT tests_generic +main :: IO () +main = do runTestTT testsDarcsBasic + runTestTT testsTreeIndex + runTestTT testsGeneric + return ()