module Storage.Hashed.Darcs where
import Prelude hiding ( lookup )
import System.FilePath ( (</>) )
import System.Directory( doesFileExist )
import Codec.Compression.GZip( decompress, compress )
import Control.Applicative( (<$>) )
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, isJust )
import qualified Data.Set as S
import Control.Monad.State.Strict
import Storage.Hashed.Tree hiding ( lookup )
import qualified Storage.Hashed.Tree as Tree
import Storage.Hashed.AnchoredPath
import Storage.Hashed.Utils
import Storage.Hashed.Hash
import Storage.Hashed.Packed
import Storage.Hashed.Monad
darcsDecodeWhite :: String -> FilePath
darcsDecodeWhite ('\\':cs) =
case break (=='\\') cs of
(theord, '\\':rest) ->
chr (read theord) : darcsDecodeWhite rest
_ -> error "malformed filename"
darcsDecodeWhite (c:cs) = c: darcsDecodeWhite cs
darcsDecodeWhite "" = ""
darcsEncodeWhite :: FilePath -> String
darcsEncodeWhite (c:cs) | isSpace c || c == '\\' =
'\\' : (show $ ord c) ++ "\\" ++ darcsEncodeWhite cs
darcsEncodeWhite (c:cs) = c : darcsEncodeWhite cs
darcsEncodeWhite [] = []
darcsEncodeWhiteBS :: BS8.ByteString -> BS8.ByteString
darcsEncodeWhiteBS = BS8.pack . darcsEncodeWhite . BS8.unpack
decodeDarcsHash :: BS8.ByteString -> Hash
decodeDarcsHash bs = case BS8.split '-' bs of
[s, h] | BS8.length s == 10 -> decodeBase16 h
_ -> decodeBase16 bs
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) = case hash of
"" -> error "darcsLocation: invalid hash"
_ -> (dir </> prefix s ++ hash, Nothing)
where prefix Nothing = ""
prefix (Just s') = formatSize s' ++ "-"
formatSize s' = let n = show s' in replicate (10 length n) '0' ++ n
hash = BS8.unpack (encodeBase16 h)
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 $ BS8.pack "file:\n"
_ -> Just $ BS8.pack "directory:\n"
hash <- case itemHash item of
NoHash -> Nothing
x -> Just $ encodeBase16 x
return $ [ header
, darcsEncodeWhiteBS name
, BS8.singleton '\n'
, hash, BS8.singleton '\n' ]
darcsParseDir :: BL8.ByteString -> [(ItemType, Name, Maybe Int, Hash)]
darcsParseDir content = parse (BL8.split '\n' content)
where
parse (t:n:h':r) = (header t,
Name $ BS8.pack $ darcsDecodeWhite (BL8.unpack n),
decodeDarcsSize hash,
decodeDarcsHash hash) : parse r
where hash = BS8.concat $ BL8.toChunks h'
parse _ = []
header x
| x == BL8.pack "file:" = BlobType
| x == BL8.pack "directory:" = TreeType
| otherwise = error $ "Error parsing darcs hashed dir: " ++ BL8.unpack x
darcsTreeHash :: Tree m -> Hash
darcsTreeHash t = case darcsFormatDir t of
Nothing -> NoHash
Just x -> sha256 x
darcsUpdateDirHashes :: Tree m -> Tree m
darcsUpdateDirHashes = updateSubtrees update
where update t = t { treeHash = darcsTreeHash t }
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
return $ File (Blob con hash)
darcsHash (SubTree t) = return $ darcsTreeHash t
darcsHash (File blob) = sha256 <$> readBlob blob
darcshash _ = return NoHash
darcsAddMissingHashes :: (Monad m, Functor m) => Tree m -> m (Tree m)
darcsAddMissingHashes = addMissingHashes darcsHash
readDarcsHashedDir :: FilePath -> (Maybe Int, Hash) -> IO [(ItemType, Name, Maybe Int, Hash)]
readDarcsHashedDir dir h = do
exist <- doesFileExist $ fst (darcsLocation dir h)
unless exist $ fail $ "error opening " ++ fst (darcsLocation dir h)
compressed <- readSegment $ darcsLocation dir h
let content = decompress compressed
return $ if BL8.null compressed
then []
else darcsParseDir content
readDarcsHashed' :: Bool -> FilePath -> (Maybe Int, Hash) -> IO (Tree IO)
readDarcsHashed' _ _ (_, NoHash) = fail "Cannot readDarcsHashed NoHash"
readDarcsHashed' sizefail dir root@(_, hash) = do
items' <- readDarcsHashedDir dir root
subs <- sequence [
do when (sizefail && isJust s) $
fail ("Unexpectedly encountered size-prefixed hash in " ++ dir)
case tp of
BlobType -> return (d, File $
Blob (readBlob' (s, h)) h)
TreeType ->
do let t = readDarcsHashed dir (s, h)
return (d, Stub t h)
| (tp, d, s, h) <- items' ]
return $ makeTreeWithHash subs hash
where readBlob' = fmap decompress . readSegment . darcsLocation dir
readDarcsHashed = readDarcsHashed' False
readDarcsHashedNosize dir hash = readDarcsHashed' True dir (Nothing, hash)
writeDarcsHashed :: Tree IO -> FilePath -> IO Hash
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 </> BS8.unpack (encodeBase16 $ sha256 bits)
exist <- doesFileExist name
unless exist $ BL.writeFile name (compress bits)
fsCreateHashedFile :: FilePath -> BL8.ByteString -> TreeIO ()
fsCreateHashedFile fn content =
liftIO $ do
exist <- doesFileExist fn
unless exist $ BL.writeFile fn content
hashedTreeIO :: TreeIO a
-> Tree IO
-> FilePath
-> IO (a, Tree IO)
hashedTreeIO action t dir =
do runTreeMonad action $ initialState t darcsHash updateItem
where updateItem path (File b) = File <$> updateFile path b
updateItem path (SubTree s) = SubTree <$> updateSub path s
updateItem _ x = return x
updateFile path b@(Blob _ !h) = do
content <- liftIO $ readBlob b
let fn = dir </> BS8.unpack (encodeBase16 h)
nblob = Blob (decompress <$> rblob) h
rblob = BL.fromChunks <$> return <$> BS.readFile fn
newcontent = compress content
fsCreateHashedFile fn newcontent
return nblob
updateSub path s = do
let !hash = treeHash s
Just dirdata = darcsFormatDir s
fn = dir </> BS8.unpack (encodeBase16 hash)
fsCreateHashedFile fn (compress dirdata)
return s
readPackedDarcsPristine :: OS -> Hash -> IO (Tree IO)
readPackedDarcsPristine os 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' ]
return $ makeTreeWithHash subs root
where file h = Blob (grab h) h
grab hash = do maybeseg <- lookup os hash
case maybeseg of
Nothing -> fail $ "hash " ++ BS8.unpack (encodeBase16 hash) ++ " not available"
Just seg -> readSegment seg
writePackedDarcsPristine :: Tree IO -> OS -> IO (OS, Hash)
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
return $ (os' { roots = root : roots os'
, references = darcsPristineRefs }, root)
darcsPristineRefs :: FileSegment -> IO [Hash]
darcsPristineRefs fs = do
con <- (darcsParseDir <$> readSegment fs) `catch` \_ -> return []
return $! [ hash | (_, _, _, hash) <- con, valid hash ]
where valid NoHash = False
valid _ = True