diff --git a/Bundled/SHA256.hs b/Bundled/SHA256.hs --- a/Bundled/SHA256.hs +++ b/Bundled/SHA256.hs @@ -16,13 +16,10 @@ import Foreign import Foreign.C.Types -import Numeric (showHex) -import Foreign.C.String ( withCString ) import Data.ByteString.Unsafe (unsafeUseAsCStringLen) -import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BSI -sha256 :: BS.ByteString -> BS.ByteString +sha256 :: BSI.ByteString -> BSI.ByteString sha256 p = unsafePerformIO $ do digest <- BSI.create 32 $ \digest -> unsafeUseAsCStringLen p $ \(ptr,n) -> diff --git a/Storage/Hashed/AnchoredPath.hs b/Storage/Hashed/AnchoredPath.hs --- a/Storage/Hashed/AnchoredPath.hs +++ b/Storage/Hashed/AnchoredPath.hs @@ -16,6 +16,13 @@ -- newtype Name = Name BS.ByteString deriving (Eq, Show, Ord) + +-- | This is a type of "sane" file paths. These are always canonic in the sense +-- that there are no stray slashes, no ".." components and similar. They are +-- usually used to refer to a location within a Tree, but a relative filesystem +-- path works just as well. These are either constructed from individual name +-- components (using "appendPath", "catPaths" and "makeName"), or converted +-- from a FilePath ("floatPath" -- but take care when doing that) or . newtype AnchoredPath = AnchoredPath [Name] deriving (Eq, Show, Ord) -- | Check whether a path is a prefix of another path. @@ -51,6 +58,8 @@ anchorPath dir p = dir BS.unpack (flatten p) {-# INLINE anchorPath #-} +-- | Unsafe. Only ever use on bytestrings that came from flatten on a +-- pre-existing AnchoredPath. floatBS :: BS.ByteString -> AnchoredPath floatBS = AnchoredPath . map Name . takeWhile (not . BS.null) . BS.split '/' @@ -60,11 +69,18 @@ [ n | (Name n) <- p ] makeName :: String -> Name -makeName = Name . BS.pack +makeName ".." = error ".. is not a valid AnchoredPath component name" +makeName n | '/' `elem` n = error "/ may not occur in a valid AnchoredPath component name" + | otherwise = Name $ BS.pack n -- | 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. +-- is (relatively) unsafe. Basically, by using floatPath, you are testifying +-- that the argument is a path relative to some common root -- i.e. the root of +-- the associated "Tree" object. Also, there are certain invariants about +-- AnchoredPath that this function tries hard to preserve, but probably cannot +-- guarantee (i.e. this is a best-effort thing). You should sanitize any +-- FilePaths before you declare them "good" by converting into AnchoredPath +-- (using this function). 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 @@ -7,16 +7,18 @@ import Prelude hiding ( lookup ) import System.FilePath ( () ) -import System.Directory( createDirectoryIfMissing, doesFileExist, doesDirectoryExist ) +import System.Directory( doesFileExist ) import Codec.Compression.GZip( decompress, compress ) import Control.Applicative( (<$>) ) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy.Char8 as BL8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString as BS import Data.List( sortBy ) import Data.Char( chr, ord, isSpace ) -import Data.Maybe( fromJust, isNothing ) +import Data.Maybe( fromJust ) import qualified Data.Set as S import Control.Monad.State.Strict @@ -27,7 +29,6 @@ import Storage.Hashed.Hash import Storage.Hashed.Packed import Storage.Hashed.Monad -import Storage.Hashed.Plain --------------------------------------------------------------------- -- Utilities for coping with the darcs directory format. @@ -60,60 +61,62 @@ darcsEncodeWhite (c:cs) = c : darcsEncodeWhite cs darcsEncodeWhite [] = [] -darcsEncodeWhiteBS = BS.pack . darcsEncodeWhite . BS.unpack +darcsEncodeWhiteBS :: BS8.ByteString -> BS8.ByteString +darcsEncodeWhiteBS = BS8.pack . darcsEncodeWhite . BS8.unpack -decodeDarcsHash bs = case BS.split '-' bs of - [s, h] | BS.length s == 10 -> decodeBase16 h +decodeDarcsHash :: BS8.ByteString -> Hash +decodeDarcsHash bs = case BS8.split '-' bs of + [s, h] | BS8.length s == 10 -> decodeBase16 h _ -> decodeBase16 bs -decodeDarcsSize :: BS.ByteString -> Maybe Int -decodeDarcsSize bs = case BS.split '-' bs of - [s, _] | BS.length s == 10 -> - case reads (BS.unpack s) of +decodeDarcsSize :: BS8.ByteString -> Maybe Int +decodeDarcsSize bs = case BS8.split '-' bs of + [s, _] | BS8.length s == 10 -> + case reads (BS8.unpack s) of [(x, _)] -> Just x _ -> Nothing _ -> Nothing darcsLocation :: FilePath -> (Maybe Int, Hash) -> FileSegment -darcsLocation dir (s,h) = (dir (prefix s ++ BS.unpack (encodeBase16 h)), Nothing) +darcsLocation dir (s,h) = (dir (prefix s ++ BS8.unpack (encodeBase16 h)), Nothing) where prefix Nothing = "" - prefix (Just s) = formatSize s ++ "-" - formatSize s = let n = show s in replicate (10 - length n) '0' ++ n + prefix (Just s') = formatSize s' ++ "-" + formatSize s' = let n = show s' in replicate (10 - length n) '0' ++ n ---------------------------------------------- -- Darcs directory format. -- -darcsFormatDir :: Tree m -> Maybe BL.ByteString -darcsFormatDir t = BL.fromChunks <$> concat <$> +darcsFormatDir :: Tree m -> Maybe BL8.ByteString +darcsFormatDir t = BL8.fromChunks <$> concat <$> mapM string (sortBy cmp $ listImmediate t) where cmp (Name a, _) (Name b, _) = compare a b string (Name name, item) = do header <- case item of - File _ -> Just $ BS.pack "file:\n" - SubTree _ -> Just $ BS.pack "directory:\n" + File _ -> Just $ BS8.pack "file:\n" + SubTree _ -> Just $ BS8.pack "directory:\n" Stub _ _ -> Nothing hash <- case itemHash item of NoHash -> Nothing x -> Just $ encodeBase16 x return $ [ header , darcsEncodeWhiteBS name - , BS.singleton '\n' - , hash, BS.singleton '\n' ] + , BS8.singleton '\n' + , hash, BS8.singleton '\n' ] -darcsParseDir :: BL.ByteString -> [(ItemType, Name, Maybe Int, Hash)] -darcsParseDir content = parse (BL.split '\n' content) +darcsParseDir :: BL8.ByteString -> [(ItemType, Name, Maybe Int, Hash)] +darcsParseDir content = parse (BL8.split '\n' content) where parse (t:n:h':r) = (header t, - Name $ BS.pack $ darcsDecodeWhite (BL.unpack n), + Name $ BS8.pack $ darcsDecodeWhite (BL8.unpack n), decodeDarcsSize hash, decodeDarcsHash hash) : parse r - where hash = BS.concat $ BL.toChunks h' + where hash = BS8.concat $ BL8.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 + | x == BL8.pack "file:" = BlobType + | x == BL8.pack "directory:" = TreeType + | otherwise = error $ "Error parsing darcs hashed dir: " ++ BL8.unpack x ---------------------------------------- -- Utilities. @@ -127,10 +130,12 @@ -- The following two are mostly for experimental use in Packed. -darcsUpdateDirHashes tree = updateSubtrees update tree +darcsUpdateDirHashes :: Tree m -> Tree m +darcsUpdateDirHashes = updateSubtrees update where update t = t { treeHash = darcsTreeHash t } -darcsUpdateHashes tree = updateTree update tree +darcsUpdateHashes :: (Monad m, Functor m) => Tree m -> m (Tree m) +darcsUpdateHashes = updateTree update where update (SubTree t) = return . SubTree $ t { treeHash = darcsTreeHash t } update (File blob@(Blob con _)) = do hash <- sha256 <$> readBlob blob @@ -148,7 +153,7 @@ unless exist $ fail $ "error opening " ++ fst (darcsLocation dir h) compressed <- readSegment $ darcsLocation dir h let content = decompress compressed - return $ if BL.null compressed + return $ if BL8.null compressed then [] else darcsParseDir content @@ -156,19 +161,19 @@ -- \"pristine.hashed\". You need to provide the root hash you are interested in -- (found in _darcs/hashed_inventory). readDarcsHashed :: FilePath -> (Maybe Int, Hash) -> IO (Tree IO) -readDarcsHashed dir (_, NoHash) = fail "Cannot readDarcsHashed NoHash" +readDarcsHashed _ (_, NoHash) = fail "Cannot readDarcsHashed NoHash" readDarcsHashed dir root@(_, hash) = do - items <- readDarcsHashedDir dir root + items' <- readDarcsHashedDir dir root subs <- sequence [ case tp of BlobType -> return (d, File $ - Blob (readBlob (s, h)) h) + Blob (readBlob' (s, h)) h) TreeType -> do let t = readDarcsHashed dir (s, h) return (d, Stub t h) - | (tp, d, s, h) <- items ] + | (tp, d, s, h) <- items' ] return $ makeTreeWithHash subs hash - where readBlob = fmap decompress . readSegment . darcsLocation dir + where readBlob' = fmap decompress . readSegment . darcsLocation dir ---------------------------------------------------- -- Writing darcs-style hashed trees. @@ -176,14 +181,14 @@ -- | Write a Tree into a darcs-style hashed directory. writeDarcsHashed :: Tree IO -> FilePath -> IO Hash -writeDarcsHashed tree dir = - do t <- darcsUpdateDirHashes <$> expand tree +writeDarcsHashed tree' dir = + do t <- darcsUpdateDirHashes <$> expand tree' sequence_ [ dump =<< readBlob b | (_, File b) <- list t ] let dirs = darcsFormatDir t : [ darcsFormatDir d | (_, SubTree d) <- list t ] os' <- mapM dump $ map fromJust dirs return $ darcsTreeHash t where dump bits = - do let name = dir BS.unpack (encodeBase16 $ sha256 bits) + do let name = dir BS8.unpack (encodeBase16 $ sha256 bits) exist <- doesFileExist name unless exist $ BL.writeFile name (compress bits) @@ -191,7 +196,7 @@ -- it is kept untouched and is assumed to have the right content. XXX Corrupt -- files should be probably renamed out of the way automatically or something -- (probably when they are being read though). -fsCreateHashedFile :: FilePath -> BL.ByteString -> TreeIO () +fsCreateHashedFile :: FilePath -> BL8.ByteString -> TreeIO () fsCreateHashedFile fn content = liftIO $ do exist <- doesFileExist fn @@ -212,7 +217,6 @@ where syncHashed ch = do modify $ \st -> st { tree = darcsUpdateDirHashes $ tree st } forM_ (reverse $ S.toList ch) $ \c -> do - let path = anchorPath "" c current <- gets tree case find current c of Just (File b) -> updateFile c b @@ -220,18 +224,16 @@ _ -> return () -- the file could have disappeared in the meantime updateFile path b@(Blob _ !h) = do content <- liftIO $ readBlob b - let h' = case h of - NoHash -> sha256 content - _ -> h - fn = dir BS.unpack (encodeBase16 h) - nblob = File $ Blob (decompress `fmap` BL.readFile fn) h + let fn = dir BS8.unpack (encodeBase16 h) + nblob = File $ Blob (decompress <$> rblob) h + rblob = BL.fromChunks <$> return <$> BS.readFile fn newcontent = compress content fsCreateHashedFile fn newcontent replaceItem path (Just nblob) updateSub path s = do let !hash = darcsTreeHash s Just dirdata = darcsFormatDir s - fn = dir BS.unpack (encodeBase16 hash) + fn = dir BS8.unpack (encodeBase16 hash) ns = SubTree (s { treeHash = hash }) fsCreateHashedFile fn (compress dirdata) replaceItem path (Just ns) @@ -246,18 +248,18 @@ -- tree root hash as a starting point. readPackedDarcsPristine :: OS -> Hash -> IO (Tree IO) readPackedDarcsPristine os root = - do items <- darcsParseDir <$> grab root + do items' <- darcsParseDir <$> grab root subs <- sequence [ case tp of BlobType -> return (d, File $ file h) TreeType -> let t = readPackedDarcsPristine os h in return (d, Stub t h) - | (tp, d, _, h) <- items ] + | (tp, d, _, h) <- items' ] return $ makeTreeWithHash subs root where file h = Blob (grab h) h grab hash = do maybeseg <- lookup os hash case maybeseg of - Nothing -> fail $ "hash " ++ BS.unpack (encodeBase16 hash) ++ " not available" + Nothing -> fail $ "hash " ++ BS8.unpack (encodeBase16 hash) ++ " not available" Just seg -> readSegment seg -- | Write a Tree into an object storage, using the darcs-style directory @@ -265,16 +267,16 @@ -- and the root hash of the stored Tree. NB. The function expects that the Tree -- comes equipped with darcs-style hashes already! writePackedDarcsPristine :: Tree IO -> OS -> IO (OS, Hash) -writePackedDarcsPristine tree os = - do t <- darcsUpdateDirHashes <$> expand tree +writePackedDarcsPristine tree' os = + do t <- darcsUpdateDirHashes <$> expand tree' files <- sequence [ readBlob b | (_, File b) <- list t ] let dirs = darcsFormatDir t : [ darcsFormatDir d | (_, SubTree d) <- list t ] os' <- hatch os $ files ++ (map fromJust dirs) return (os', darcsTreeHash t) storePackedDarcsPristine :: Tree IO -> OS -> IO (OS, Hash) -storePackedDarcsPristine tree os = - do (os', root) <- writePackedDarcsPristine tree os +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... diff --git a/Storage/Hashed/Hash.hs b/Storage/Hashed/Hash.hs --- a/Storage/Hashed/Hash.hs +++ b/Storage/Hashed/Hash.hs @@ -2,7 +2,6 @@ , encodeBase16, decodeBase16, sha256, rawHash , match ) where -import Data.Int( Int64 ) import qualified Bundled.SHA256 as SHA import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BSI @@ -34,12 +33,9 @@ Nothing -> Nothing encodeBase64u :: Hash -> BS.ByteString -encodeBase64u (SHA256 bs) = BS.pack $ map BSI.c2w $ B64U.encode $ BS.unpack bs -encodeBase64u (SHA1 bs) = BS.pack $ map BSI.c2w $ B64U.encode $ BS.unpack bs +encodeBase64u (SHA256 bs) = base64u bs +encodeBase64u (SHA1 bs) = base64u bs encodeBase64u NoHash = BS.empty - -formatSize :: (Num a) => a -> BS.ByteString -formatSize s = BS.pack $ replicate (10 - length n) (BSI.c2w '0') ++ n where n = map BSI.c2w $ show s -- | Produce a base16 (ascii-hex) encoded string from a hash. This can be -- turned back into a Hash (see "decodeBase16". This is a loss-less process. diff --git a/Storage/Hashed/Index.hs b/Storage/Hashed/Index.hs --- a/Storage/Hashed/Index.hs +++ b/Storage/Hashed/Index.hs @@ -46,25 +46,29 @@ import Storage.Hashed.AnchoredPath import Data.Int( Int64, Int32 ) -import qualified Data.Set as S -import qualified Data.Map as M - 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, renameFile ) -import System.FilePath( (<.>) ) + getFileStatus, fileSize, fileExists ) +import System.IO.MMap( mmapFileForeignPtr, mmapFileByteString, Mode(..) ) +import System.IO( ) +import System.Directory( doesFileExist ) +#if mingw32_HOST_OS +import System.Directory( renameFile ) +#else +import System.Directory( removeFile ) +#endif + +import System.FilePath( ) import Control.Monad( when ) +import Control.Exception.Extensible import Control.Applicative( (<$>) ) import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Char8 as BSC import Data.ByteString.Unsafe( unsafeHead, unsafeDrop ) import Data.ByteString.Internal( toForeignPtr, fromForeignPtr, memcpy , nullForeignPtr, c2w ) -import Data.IORef( newIORef, readIORef, modifyIORef, IORef ) +import Data.IORef( ) import Data.Maybe( fromJust, isJust ) import Data.Bits( Bits ) @@ -100,7 +104,7 @@ size_dsclen = 4 -- this many bytes store the length of the path size_hash = 32 -- hash representation -off_size, off_aux, off_hash, off_dsc :: Int +off_size, off_aux, off_hash, off_dsc, off_dsclen :: Int off_size = 0 off_aux = off_size + size_size off_dsclen = off_aux + size_aux @@ -108,8 +112,8 @@ off_dsc = off_hash + size_hash itemAllocSize :: AnchoredPath -> Int -itemAllocSize path = - align 4 $ size_hash + size_size + size_aux + size_dsclen + 2 + BS.length (flatten path) +itemAllocSize apath = + align 4 $ size_hash + size_size + size_aux + size_dsclen + 2 + BS.length (flatten apath) itemSize, itemNext :: Item -> Int itemSize i = size_size + size_aux + size_dsclen + (BS.length $ iHashAndDescriptor i) @@ -140,9 +144,9 @@ -- written out, and a corresponding Item is given back. The remaining bits of -- the item can be filled out using 'update'. createItem :: ItemType -> AnchoredPath -> ForeignPtr () -> Int -> IO Item -createItem typ path fp off = - do let dsc = BS.concat [ BS8.singleton $ (typ == TreeType) ? ('D', 'F') - , flatten path +createItem typ apath fp off = + do let dsc = BS.concat [ BSC.singleton $ (typ == TreeType) ? ('D', 'F') + , flatten apath , BS.singleton 0 ] (dsc_fp, dsc_start, dsc_len) = toForeignPtr dsc withForeignPtr fp $ \p -> @@ -183,12 +187,14 @@ -- when updating directory entries). updateItem :: Item -> Int64 -> Hash -> IO () updateItem item _ NoHash = - fail $ "Index.update NoHash: " ++ BS8.unpack (iPath item) + fail $ "Index.update NoHash: " ++ BSC.unpack (iPath item) updateItem item size hash = do xlatePoke64 (iSize item) size unsafePokeBS (iHash item) (rawHash hash) +updateAux :: Item -> Int64 -> IO () updateAux item aux = xlatePoke64 (iAux item) $ aux +updateTime :: forall a.(Enum a) => Item -> a -> IO () updateTime item mtime = updateAux item (fromIntegral $ fromEnum mtime) iHash' :: Item -> Hash @@ -243,7 +249,7 @@ myname = name item (dirlength state) substate = state { start = start state + itemNext item , path = path state `appendPath` myname - , dirlength = if myname == Name (BS8.singleton '.') + , dirlength = if myname == Name (BSC.singleton '.') then dirlength state else dirlength state + namelength } @@ -255,12 +261,11 @@ rest <- subs $ next result case treeitem result of Nothing -> return $! rest - Just ti -> return $! (name (resitem result) $ dirlength substate, result) : rest + Just _ -> return $! (name (resitem result) $ dirlength substate, result) : rest subs coff | coff == following = return [] | otherwise = fail $ "Offset mismatch at " ++ show coff ++ " (ends at " ++ show following ++ ")" - oldsize <- xlatePeek64 $ iSize item inferiors <- if want then subs $ start substate else return [] @@ -283,7 +288,7 @@ size <- xlatePeek64 $ iSize item let mtime' = modificationTime st size' = fromIntegral $ fileSize st - readblob = readSegment (BS8.unpack $ iPath item, Nothing) + readblob = readSegment (BSC.unpack $ iPath item, Nothing) exists = fileExists st we_changed = mtime /= mtime' || size /= size' hash = iHash' item @@ -320,21 +325,21 @@ -- The resulting tree will be fully expanded. readIndex :: FilePath -> (Tree IO -> Hash) -> IO Index readIndex indexpath ht = do - (mmap, mmap_size) <- mmapIndex indexpath 0 + (mmap_ptr, mmap_size) <- mmapIndex indexpath 0 return $ if mmap_size == 0 then EmptyIndex - else Index { mmap = mmap + else Index { mmap = mmap_ptr , hashtree = ht , predicate = \_ _ -> True } formatIndex :: ForeignPtr () -> Tree IO -> Tree IO -> IO () -formatIndex mmap old reference = +formatIndex mmap_ptr old reference = do create (SubTree reference) (AnchoredPath []) size_magic - unsafePokeBS magic (BS8.pack "HSI4") - where magic = fromForeignPtr (castForeignPtr mmap) 0 4 - create (File _) path off = - do i <- createItem BlobType path mmap off - let flatpath = BS8.unpack $ flatten path - case find old path of + unsafePokeBS magic (BSC.pack "HSI4") + where magic = fromForeignPtr (castForeignPtr mmap_ptr) 0 4 + create (File _) path' off = + do i <- createItem BlobType path' mmap_ptr off + let flatpath = BSC.unpack $ flatten path' + case find old path' of Nothing -> return () -- TODO calling getFileStatus here is both slightly -- inefficient and slightly race-prone @@ -345,29 +350,29 @@ updateItem i (fromIntegral size) hash updateTime i mtime return $ off + itemNext i - create (SubTree s) path off = - do i <- createItem TreeType path mmap off - case find old path of + create (SubTree s) path' off = + do i <- createItem TreeType path' mmap_ptr off + case find old path' of Nothing -> return () Just ti | itemHash ti == NoHash -> return () | otherwise -> updateItem i 0 $ itemHash ti let subs [] = return $ off + itemNext i subs ((name,x):xs) = do - let path' = path `appendPath` name + let path'' = path' `appendPath` name noff <- subs xs - create x path' noff + create x path'' noff lastOff <- subs (listImmediate s) xlatePoke64 (iAux i) (fromIntegral lastOff) return lastOff - create (Stub _ _) path _ = - fail $ "Cannot create index from stubbed Tree at " ++ show path + create (Stub _ _) path' _ = + fail $ "Cannot create index from stubbed Tree at " ++ show path' -- | Will add and remove files in index to make it match the 'Tree' object -- given (it is an error for the 'Tree' to contain a file or directory that -- does not exist in a plain form in current working directory). updateIndexFrom :: FilePath -> (Tree IO -> Hash) -> Tree IO -> IO Index -updateIndexFrom indexpath hashtree ref = - do old_idx <- updateIndex =<< readIndex indexpath hashtree +updateIndexFrom indexpath hashtree' ref = + do old_idx <- updateIndex =<< readIndex indexpath hashtree' reference <- expand ref let len_root = itemAllocSize anchoredRoot len = len_root + sum [ itemAllocSize p | (p, _) <- list reference ] @@ -377,21 +382,20 @@ #else when exist $ removeFile indexpath -- to avoid clobbering oldidx #endif - (mmap, _) <- mmapIndex indexpath len - formatIndex mmap old_idx reference - readIndex indexpath hashtree + (mmap_ptr, _) <- mmapIndex indexpath len + formatIndex mmap_ptr old_idx reference + readIndex indexpath hashtree' -- | Check that a given file is an index file with a format we can handle. You -- should remove and re-create the index whenever this is not true. indexFormatValid :: FilePath -> IO Bool -indexFormatValid path = do - fd <- openBinaryFile path ReadMode - magic <- sequence [ hGetChar fd | _ <- [1..size_magic] :: [Int] ] - hClose fd - return $ case magic of - "HSI4" -> True - _ -> False +indexFormatValid path' = + do magic <- mmapFileByteString path' (Just (0, size_magic)) + return $ case BSC.unpack magic of + "HSI4" -> True + _ -> False + `catch` \(_::SomeException) -> return False instance FilterTree IndexM IO where filter _ EmptyIndex = EmptyIndex - filter pred index = index { predicate = \a b -> predicate index a b && pred a b } + filter p index = index { predicate = \a b -> predicate index a b && p a b } diff --git a/Storage/Hashed/Monad.hs b/Storage/Hashed/Monad.hs --- a/Storage/Hashed/Monad.hs +++ b/Storage/Hashed/Monad.hs @@ -24,18 +24,14 @@ import Storage.Hashed.Tree import Storage.Hashed.Hash -import Control.Monad.Error( catchError, throwError, MonadError ) +import Control.Monad.Error( catchError, MonadError ) -import System.Directory( createDirectoryIfMissing, doesFileExist ) -import System.FilePath( () ) import Data.List( inits ) import Data.Int( Int64 ) import Data.Maybe( isNothing, isJust ) -import Codec.Compression.GZip( decompress, compress ) - import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Char8( ) import Control.Monad.RWS.Strict import qualified Data.Set as S diff --git a/Storage/Hashed/Packed.hs b/Storage/Hashed/Packed.hs --- a/Storage/Hashed/Packed.hs +++ b/Storage/Hashed/Packed.hs @@ -17,8 +17,8 @@ ) where import Prelude hiding ( lookup, read ) -import Storage.Hashed.AnchoredPath -import Storage.Hashed.Tree hiding ( lookup ) +import Storage.Hashed.AnchoredPath( ) +import Storage.Hashed.Tree ( ) import Storage.Hashed.Utils import Storage.Hashed.Hash @@ -32,7 +32,7 @@ import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.ByteString.Char8 as BS -import Data.Maybe( listToMaybe, catMaybes, fromJust, isNothing ) +import Data.Maybe( listToMaybe, catMaybes, isNothing ) import Data.Binary( encode, decode ) import qualified Data.Set as S @@ -45,9 +45,7 @@ -- 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 :: [[Char]] loose_dirs = let chars = ['0'..'9'] ++ ['a'..'f'] in [ [a,b] | a <- chars, b <- chars ] @@ -84,7 +82,7 @@ -- | 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. repack :: OS -> IO OS -repack os = error "repack undefined" +repack _ = 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: @@ -93,13 +91,14 @@ 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." + where write bits = + case format (hatchery os) of + Loose -> + do forM bits $ \(hash, blob) -> do + BL.writeFile (loosePath os hash) blob + return os + Compact -> error "hatch/compact undefined" + _ -> fail "Hatchery must be either Loose or Compact." sieve blob = do let hash = sha256 blob absent <- isNothing <$> lookup os hash return (absent, hash, blob) @@ -110,10 +109,11 @@ 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 () + where cleanup = + case format (hatchery os) of + Loose -> forM_ loose_dirs $ nuke . ((rootdir os "hatchery") ) + Compact -> removeFile (rootdir os "hatchery") >> return () + _ -> fail "Hatchery must be either Loose or Compact." nuke dir = mapM (removeFile . (dir )) =<< (Prelude.filter (`notElem` [".", ".."]) `fmap` getDirectoryContents dir) @@ -152,14 +152,16 @@ load path = do hatch_stat <- getFileStatus $ path "hatchery" let is_os = fileExists hatch_stat - is_loose = isDirectory hatch_stat + is_dir = 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 } + , format = if is_dir then Loose else Compact + , size = undefined } os = OS { hatchery = _hatchery , rootdir = path , mature = packs - , roots = _roots } + , roots = _roots + , references = undefined } look | format _hatchery == Loose = looseLookup | otherwise = undefined packs = [] -- FIXME read packs @@ -170,25 +172,25 @@ readPack file = do bits <- readSegment (file, Nothing) let count = decode (BL.take 8 $ bits) _lookup NoHash _ _ = return Nothing - _lookup hash@(SHA256 rawhash) first last = do - let middle = first + ((last - first) `div` 2) + _lookup hash@(SHA256 rawhash) first final = do + let middle = first + ((final - first) `div` 2) res <- case ( compare rawhash (hashof first) , compare rawhash (hashof middle) - , compare rawhash (hashof last) ) of + , compare rawhash (hashof final) ) of (LT, _, _) -> return Nothing ( _, _, GT) -> return Nothing (EQ, _, _) -> return $ Just (segof first) - ( _, _, EQ) -> return $ Just (segof last) + ( _, _, EQ) -> return $ Just (segof final) (GT, EQ, LT) -> return $ Just (segof middle) - (GT, GT, LT) | middle /= last -> _lookup hash middle last + (GT, GT, LT) | middle /= final -> _lookup hash middle final (GT, LT, LT) | first /= middle -> _lookup hash first middle ( _, _, _) -> return Nothing return res headerof i = BL.take 51 $ BL.drop (8 + i * 51) bits hashof i = BS.concat $ BL.toChunks $ BL.take 32 $ headerof i - segof i = (file, Just (count * 51 + 8 + from, size)) + segof i = (file, Just (count * 51 + 8 + from, sz)) where from = decode (BL.take 8 $ BL.drop 33 $ headerof i) - size = decode (BL.take 8 $ BL.drop 42 $ headerof i) + sz = decode (BL.take 8 $ BL.drop 42 $ headerof i) return $ Block { size = BL.length bits , format = Pack , blockLookup = \h -> _lookup h 0 (count - 1) } diff --git a/Storage/Hashed/Plain.hs b/Storage/Hashed/Plain.hs --- a/Storage/Hashed/Plain.hs +++ b/Storage/Hashed/Plain.hs @@ -9,21 +9,24 @@ -- mutates files. Unlink + recreate is fine though (in other words, the -- 'writePlainTree' and 'plainTreeIO' implemented in this module are safe in -- this respect). -module Storage.Hashed.Plain( readPlainTree, writePlainTree ) where +module Storage.Hashed.Plain( readPlainTree, writePlainTree, + plainTreeIO -- (obsolete? if so remove implementation!) + ) where -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BL import System.FilePath( () ) -import System.Directory( getDirectoryContents, doesFileExist - , doesDirectoryExist, createDirectoryIfMissing ) +import System.Directory( getDirectoryContents + , createDirectoryIfMissing ) import Bundled.Posix( getFileStatus, isDirectory, FileStatus ) -import Control.Monad( forM_, unless, when ) +import Control.Monad( forM_ ) import Storage.Hashed.AnchoredPath import Storage.Hashed.Utils import Storage.Hashed.Hash( Hash( NoHash) ) -import Storage.Hashed.Tree( Tree( listImmediate ), TreeItem(..), ItemType(..) - , Blob(..), emptyTree, makeTree, makeTreeWithHash +import Storage.Hashed.Tree( Tree(), TreeItem(..) + , Blob(..), makeTree , list, readBlob, find, modifyTree ) import Storage.Hashed.Monad( TreeIO, runTreeMonad, initialState, tree ) import qualified Data.Set as S @@ -35,21 +38,21 @@ items <- getDirectoryContents "." sequence [ do st <- getFileStatus s return (s, st) - | s <- items, not $ s `elem` [ ".", ".." ] ] + | s <- items, s `notElem` [ ".", ".." ] ] readPlainTree :: FilePath -> IO (Tree IO) readPlainTree dir = do items <- readPlainDir dir let subs = [ - let name = Name (BS.pack name') + let name = Name (BS8.pack name') in if isDirectory status then (name, Stub (readPlainTree (dir name')) NoHash) else (name, File $ - Blob (readBlob name) NoHash) + Blob (readBlob' name) NoHash) | (name', status) <- items ] return $ makeTree subs - where readBlob (Name name) = readSegment (dir BS.unpack name, Nothing) + where readBlob' (Name name) = readSegment (dir BS8.unpack name, Nothing) -- | Write out /full/ tree to a plain directory structure. If you instead want -- to make incremental updates, refer to "Storage.Hashed.Monad". diff --git a/Storage/Hashed/Tree.hs b/Storage/Hashed/Tree.hs --- a/Storage/Hashed/Tree.hs +++ b/Storage/Hashed/Tree.hs @@ -22,7 +22,7 @@ , readBlob -- * Filtering trees. - , FilterTree(..), filter, restrict + , FilterTree(..), restrict -- * Manipulating trees. , modifyTree, updateTree, updateSubtrees, overlay ) where @@ -367,16 +367,16 @@ , treeHash = NoHash } where update (k, SubTree s) = (k, SubTree $ updateSubtrees fun s) update (k, File f) = (k, File f) - update (k, Stub _ _) = error "Stubs not supported in updateTreePostorder" + update (_, Stub _ _) = error "Stubs not supported in updateTreePostorder" -- | Does /not/ expand the tree. updateTree :: (Functor m, Monad m) => (TreeItem m -> m (TreeItem m)) -> Tree m -> m (Tree m) updateTree fun t = do immediate <- mapM update $ listImmediate t - SubTree t <- fun . SubTree $ t { items = M.fromList immediate - , listImmediate = immediate - , treeHash = NoHash } - return t + SubTree t' <- fun . SubTree $ t { items = M.fromList immediate + , listImmediate = immediate + , treeHash = NoHash } + return t' where update (k, SubTree tree) = (\new -> (k, SubTree new)) <$> updateTree fun tree update (k, item) = (\new -> (k, new)) <$> fun item diff --git a/Storage/Hashed/Utils.hs b/Storage/Hashed/Utils.hs --- a/Storage/Hashed/Utils.hs +++ b/Storage/Hashed/Utils.hs @@ -20,14 +20,15 @@ import Foreign.ForeignPtr( withForeignPtr ) import Foreign.Ptr( plusPtr ) import Data.ByteString.Internal( toForeignPtr, memcpy ) - +import System.IO (withFile, IOMode(ReadMode), hSeek, SeekMode(AbsoluteSeek)) 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 +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString as BS import qualified Data.Set as S import qualified Data.Map as M @@ -39,13 +40,20 @@ -- | Read in a FileSegment into a Lazy ByteString. Implemented using mmap. readSegment :: FileSegment -> IO BL.ByteString readSegment (f,range) = do - x <- mmapFileByteString f range - `catch` (\(_::SomeException) -> do + bs <- tryToRead + `catch` (\(_::SomeException) -> do size <- fileSize `fmap` getFileStatus f if size == 0 - then return BS.empty - else performGC >> mmapFileByteString f range) - return $ BL.fromChunks [x] + then return BS8.empty + else performGC >> tryToRead) + return $ BL.fromChunks [bs] + where + tryToRead = do + case range of + Nothing -> BS.readFile f + Just (off, size) -> withFile f ReadMode $ \h -> do + hSeek h AbsoluteSeek $ fromIntegral off + BS.hGet h size {-# INLINE readSegment #-} -- | Run an IO action with @path@ as a working directory. Does neccessary @@ -71,7 +79,7 @@ return $! isAbsolute p ? (p, cwd p) -- Wow, unsafe. -unsafePokeBS :: BS.ByteString -> BS.ByteString -> IO () +unsafePokeBS :: BS8.ByteString -> BS8.ByteString -> IO () unsafePokeBS to from = do let (fp_to, off_to, len_to) = toForeignPtr to (fp_from, off_from, len_from) = toForeignPtr from 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.4.1 +version: 0.4.2 synopsis: Hashed file storage support code. description: Support code for reading and manipulating hashed file storage @@ -77,7 +77,7 @@ c-sources: Bundled/sha2.c - extensions: PatternSignatures, NoMonomorphismRestriction + extensions: ScopedTypeVariables, NoMonomorphismRestriction executable hashed-storage-test if impl(ghc >= 6.8)