Darcs.hs

-- | A few darcs-specific utility functions. These are used for reading and
-- writing darcs and darcs-compatible hashed trees.
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

-- | 'decode_white' interprets the Darcs-specific \"encoded\" filenames
--   produced by 'darcsEncodeWhite'
--
--   > darcsDecodeWhite "hello\32\there" == "hello there"
--   > darcsDecodeWhite "hello\92\there" == "hello\there"
--   > darcsDecodeWhite "hello\there"    == error "malformed filename"
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 "" = ""

-- | 'encode_white' translates whitespace in filenames to a darcs-specific
--   format (backslash followed by numerical representation according to 'ord').
--   Note that backslashes are also escaped since they are used in the encoding.
--
--   > darcsEncodeWhite "hello there" == "hello\32\there"
--   > darcsEncodeWhite "hello\there" == "hello\92\there"
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

-- | Compute a darcs-compatible hash value for a tree-like structure.
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 }