module Storage.Hashed
(
readPlainTree, readDarcsHashed, readDarcsPristine
, read, readSegment
, writePlainTree
, 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 )
floatPath :: FilePath -> AnchoredPath
floatPath = AnchoredPath . map (Name . BS.pack)
. splitDirectories
. normalise . dropTrailingPathSeparator
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` [ ".", ".." ] ]
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)
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
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
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"
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)