module Storage.Hashed.Darcs where
import Storage.Hashed.Tree hiding ( read )
import Storage.Hashed.AnchoredPath
import Storage.Hashed.Utils
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.List( sortBy )
import Data.Char( chr, ord, isSpace )
darcsFormatSize :: (Num a) => a -> BS.ByteString
darcsFormatSize s = BS.pack $ replicate (10 length n) '0' ++ n
where n = show s
darcsFormatHash :: Hash -> BS.ByteString
darcsFormatHash (Hash (Just s, h)) =
BS.concat [ darcsFormatSize s
, BS.singleton '-'
, h ]
darcsFormatHash (Hash (Nothing, h)) = h
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 = BS.pack . darcsEncodeWhite . BS.unpack
darcsFormatDir :: Tree -> BL.ByteString
darcsFormatDir t = BL.fromChunks $ concatMap string
(sortBy cmp $ listImmediate t)
where cmp (Name a, _) (Name b, _) = compare a b
string (Name name, item) =
[ case item of
File _ -> BS.pack "file:\n"
SubTree _ -> BS.pack "directory:\n"
Stub _ _ ->
error "Trees with stubs not supported in darcsFormatDir.",
darcsEncodeWhiteBS name, BS.singleton '\n',
case itemHash item of
Nothing -> error $ "darcsFormatDir: missing hash on "
++ show name
Just h -> darcsFormatHash h,
BS.singleton '\n' ]
darcsParseDir :: BL.ByteString -> [(ItemType, Name, Hash)]
darcsParseDir content = parse (BL.split '\n' content)
where
parse (t:n:h':r) = (header t,
Name $ BS.pack $ darcsDecodeWhite (BL.unpack n),
makeHash hash) : parse r
where hash = BS.concat $ BL.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
darcsTreeHash :: Tree -> Hash
darcsTreeHash d = hashSetSize (sha256 bl) $ BL.length bl
where bl = darcsFormatDir d
darcsUpdateHashes tree =
flip updateTreePostorder tree $ \ t -> t { treeHash = Just $ darcsTreeHash t }