module Storage.Hashed
( -- * Obtaining Trees.
--
-- | Please note that Trees obtained this way will contain Stub
-- items. These need to be executed (they are IO actions) in order to be
-- accessed. Use 'expand' to do this. However, many operations are
-- perfectly fine to be used on a stubbed Tree (and it is often more
-- efficient to do everything that can be done before expanding a Tree).
readPlainTree, readDarcsHashed, readDarcsPristine
-- * Blob access.
, read, readSegment
-- * Writing trees.
, writePlainTree
-- * Unsafe functions for the curious explorer.
--
-- | These are more useful for playing within ghci than for real, serious
-- programs. They generally trade safety for conciseness. Please use
-- responsibly. Don't kill innocent kittens.
, floatPath, printPath ) where
import Prelude hiding ( catch, read, lines )
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BL
import Storage.Hashed.AnchoredPath
import Storage.Hashed.Utils
import Storage.Hashed.Darcs
import Storage.Hashed.Tree( Tree( listImmediate ), TreeItem(..), ItemType(..)
, Blob(..), emptyTree, makeTree, makeTreeWithHash
, list, read, find )
import System.FilePath( (</>), splitDirectories, normalise
, dropTrailingPathSeparator )
import System.Directory( getDirectoryContents, doesFileExist
, doesDirectoryExist, createDirectoryIfMissing )
import Codec.Compression.GZip( decompress )
import Control.Monad( forM_, unless )
import Bundled.Posix( getFileStatus, isDirectory, FileStatus )
------------------------
-- For explorers
--
-- | Take a relative FilePath and turn it into an AnchoredPath. The operation
-- is unsafe and if you break it, you keep both pieces. More useful for
-- exploratory purposes (ghci) than for serious programming.
floatPath :: FilePath -> AnchoredPath
floatPath = AnchoredPath . map (Name . BS.pack)
. splitDirectories
. normalise . dropTrailingPathSeparator
-- | Take a relative FilePath within a Tree and print the contents of the
-- object there. Useful for exploration, less so for serious programming.
printPath :: Tree -> FilePath -> IO ()
printPath t p = print' $ find t (floatPath p)
where print' Nothing = putStrLn $ "ERROR: No object at " ++ p
print' (Just (File b)) = do
putStrLn $ "== Contents of file " ++ p ++ ":"
BL.unpack `fmap` read b >>= putStr
print' (Just (SubTree t')) = do
putStrLn $ "== Listing Tree " ++ p ++ " (immediates only):"
putStr $ unlines $ map BS.unpack $ listNames t'
print' (Just (Stub _ _)) =
putStrLn $ "== (not listing stub at " ++ p ++ ")"
listNames t' = [ n | (Name n, _) <- listImmediate t' ]
readPlainDir :: FilePath -> IO [(FilePath, FileStatus)]
readPlainDir dir =
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
-- changes. Since we use mmap in 'read', this will break referential
-- transparency and produce unexpected results. Please always make sure that
-- all parallel access to the underlying filesystem tree never mutates
-- files. Unlink + recreate is fine though (in other words, the sync/write
-- operations below are safe).
readPlainTree :: FilePath -> IO Tree
readPlainTree dir = do
items <- readPlainDir dir
let subs = [
let name = nameFromFilePath name'
in if isDirectory status
then (name,
Stub (readPlainTree (dir </> name')) Nothing)
else (name, File $
Blob (readBlob name) Nothing)
| (name', status) <- items ]
return $ makeTree subs
where readBlob (Name name) = readSegment (dir </> BS.unpack name, Nothing)
-- | Read and parse a darcs-style hashed directory listing from a given @dir@
-- and with a given @hash@.
readDarcsHashedDir :: FilePath -> Hash -> IO [(ItemType, Name, Hash)]
readDarcsHashedDir dir h = do
compressed <- readSegment (dir </> BS.unpack (darcsFormatHash h), Nothing)
let content = decompress compressed
lines = BL.split '\n' content
return $ if BL.null compressed
then []
else parse lines
where
parse (t:n:h':r) = (parse' t,
Name $ BS.pack $ darcsDecodeWhite (BL.unpack n),
makeHash hash) : parse r
where hash = BS.concat $ BL.toChunks h'
parse _ = []
parse' x
| x == BL.pack "file:" = BlobType
| x == BL.pack "directory:" = TreeType
| otherwise = error $ "Error parsing darcs hashed dir: " ++ BL.unpack x
-- | Read in a darcs-style hashed tree. This is mainly useful for reading
-- \"pristine.hashed\". You need to provide the root hash you are interested in
-- (found in _darcs/hashed_inventory).
readDarcsHashed :: FilePath -> Hash -> IO Tree
readDarcsHashed dir root = do
items <- readDarcsHashedDir dir root
subs <- sequence [
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 = 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
-- requires replaying patches. Cf. 'readDarcsHashed' and 'readPlainTree' that
-- are used to do the actual 'Tree' construction.
readDarcsPristine :: FilePath -> IO Tree
readDarcsPristine dir = do
let darcs = dir </> "_darcs"
h_inventory = darcs </> "hashed_inventory"
repo <- doesDirectoryExist darcs
unless repo $ fail $ "Not a darcs repository: " ++ dir
hashed <- doesFileExist h_inventory
if hashed
then do inv <- BS.readFile h_inventory
let lines = BS.split '\n' inv
case lines of
[] -> return emptyTree
(pris_line:_) ->
let hash = makeHash $ BS.drop 9 pris_line
in readDarcsHashed (darcs </> "pristine.hashed") hash
else readPlainTree $ darcs </> "pristine"
-- | Write out *full* tree to a plain directory structure. If you instead want
-- to make incremental updates, refer to "Monad.plainTreeIO".
writePlainTree :: Tree -> FilePath -> IO ()
writePlainTree t dir = do
createDirectoryIfMissing True dir
forM_ (list t) write
where write (p, File b) = write' p b
write (p, SubTree _) =
createDirectoryIfMissing True (anchorPath dir p)
write _ = return ()
write' p b = read b >>= BL.writeFile (anchorPath dir p)