--  Copyright (C) 2009-2011 Petr Rockai
--
--  BSD3

-- | A few darcs-specific utility functions. These are used for reading and
-- writing darcs and darcs-compatible hashed trees.
module Darcs.Util.Tree.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).
      readDarcsHashed
    -- * Writing trees.
    , writeDarcsHashed
    -- * Interact with hashed tree
    , hashedTreeIO
    -- * Other
    , readDarcsHashedDir
    , readDarcsHashedNosize
    , darcsAddMissingHashes
    , darcsLocation
    , darcsTreeHash
    , decodeDarcsHash
    , decodeDarcsSize
    , darcsUpdateHashes
    ) where

import System.FilePath ( (</>) )

import System.Directory( doesFileExist )
import Codec.Compression.GZip( decompress, compress )

import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy.Char8 as BLC
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as B

import Data.List( sortBy )
import Data.Maybe( fromJust, isJust )
import Control.Monad.State.Strict (liftIO,when,unless)

import Darcs.Prelude

import Darcs.Util.ByteString (FileSegment, readSegment)
import Darcs.Util.Hash (Hash(..), decodeBase16, encodeBase16, sha256)
import Darcs.Util.Path (Name, decodeWhiteName, encodeWhiteName)
import Darcs.Util.Progress (debugMessage)
import Darcs.Util.Tree
    ( Blob(..)
    , ItemType(..)
    , Tree(..)
    , TreeItem(..)
    , addMissingHashes
    , expand
    , itemHash
    , list
    , listImmediate
    , makeTreeWithHash
    , readBlob
    , updateSubtrees
    , updateTree
    )
import Darcs.Util.Tree.Monad (TreeIO, runTreeMonad)

---------------------------------------------------------------------
-- Utilities for coping with the darcs directory format.
--

decodeDarcsHash :: BC.ByteString -> Hash
decodeDarcsHash :: ByteString -> Hash
decodeDarcsHash ByteString
bs = case Char -> ByteString -> [ByteString]
BC.split Char
'-' ByteString
bs of
                       [ByteString
s, ByteString
h] | ByteString -> Int
BC.length ByteString
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
10 -> ByteString -> Hash
decodeBase16 ByteString
h
                       [ByteString]
_ -> ByteString -> Hash
decodeBase16 ByteString
bs

decodeDarcsSize :: BC.ByteString -> Maybe Int
decodeDarcsSize :: ByteString -> Maybe Int
decodeDarcsSize ByteString
bs = case Char -> ByteString -> [ByteString]
BC.split Char
'-' ByteString
bs of
                       [ByteString
s, ByteString
_] | ByteString -> Int
BC.length ByteString
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
10 ->
                                  case ReadS Int
forall a. Read a => ReadS a
reads (ByteString -> [Char]
BC.unpack ByteString
s) of
                                    [(Int
x, [Char]
_)] -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
x
                                    [(Int, [Char])]
_ -> Maybe Int
forall a. Maybe a
Nothing
                       [ByteString]
_ -> Maybe Int
forall a. Maybe a
Nothing

darcsLocation :: FilePath -> (Maybe Int, Hash) -> FileSegment
darcsLocation :: [Char] -> (Maybe Int, Hash) -> FileSegment
darcsLocation [Char]
dir (Maybe Int
s,Hash
h) = case [Char]
hash of
                            [Char]
"" -> [Char] -> FileSegment
forall a. HasCallStack => [Char] -> a
error [Char]
"darcsLocation: invalid hash"
                            [Char]
_ -> ([Char]
dir [Char] -> [Char] -> [Char]
</> Maybe Int -> [Char]
forall a. Show a => Maybe a -> [Char]
prefix Maybe Int
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
hash, Maybe (Int64, Int)
forall a. Maybe a
Nothing)
    where prefix :: Maybe a -> [Char]
prefix Maybe a
Nothing = [Char]
""
          prefix (Just a
s') = a -> [Char]
forall a. Show a => a -> [Char]
formatSize a
s' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"-"
          formatSize :: a -> [Char]
formatSize a
s' = let n :: [Char]
n = a -> [Char]
forall a. Show a => a -> [Char]
show a
s' in Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
n) Char
'0' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
n
          hash :: [Char]
hash = Hash -> [Char]
showHash Hash
h

----------------------------------------------
-- Darcs directory format.
--

darcsFormatDir :: Tree m -> Maybe BLC.ByteString
darcsFormatDir :: Tree m -> Maybe ByteString
darcsFormatDir Tree m
t = [ByteString] -> ByteString
BLC.fromChunks ([ByteString] -> ByteString)
-> ([[ByteString]] -> [ByteString]) -> [[ByteString]] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[ByteString]] -> [ByteString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ByteString]] -> ByteString)
-> Maybe [[ByteString]] -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                       ((Name, TreeItem m) -> Maybe [ByteString])
-> [(Name, TreeItem m)] -> Maybe [[ByteString]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name, TreeItem m) -> Maybe [ByteString]
forall (m :: * -> *). (Name, TreeItem m) -> Maybe [ByteString]
string (((Name, TreeItem m) -> (Name, TreeItem m) -> Ordering)
-> [(Name, TreeItem m)] -> [(Name, TreeItem m)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Name, TreeItem m) -> (Name, TreeItem m) -> Ordering
forall a b b. Ord a => (a, b) -> (a, b) -> Ordering
cmp ([(Name, TreeItem m)] -> [(Name, TreeItem m)])
-> [(Name, TreeItem m)] -> [(Name, TreeItem m)]
forall a b. (a -> b) -> a -> b
$ Tree m -> [(Name, TreeItem m)]
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate Tree m
t)
    where cmp :: (a, b) -> (a, b) -> Ordering
cmp (a
a, b
_) (a
b, b
_) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b
          string :: (Name, TreeItem m) -> Maybe [ByteString]
string (Name
name, TreeItem m
item) =
              do ByteString
header <- case TreeItem m
item of
                             File Blob m
_ -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
BC.pack [Char]
"file:\n"
                             TreeItem m
_ -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
BC.pack [Char]
"directory:\n"
                 ByteString
hash <- case TreeItem m -> Hash
forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem m
item of
                           Hash
NoHash -> Maybe ByteString
forall a. Maybe a
Nothing
                           Hash
x -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Hash -> ByteString
encodeBase16 Hash
x
                 [ByteString] -> Maybe [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return   [ ByteString
header
                          , Name -> ByteString
encodeWhiteName Name
name
                          , Char -> ByteString
BC.singleton Char
'\n'
                          , ByteString
hash, Char -> ByteString
BC.singleton Char
'\n' ]

darcsParseDir :: BLC.ByteString -> [(ItemType, Name, Maybe Int, Hash)]
darcsParseDir :: ByteString -> [(ItemType, Name, Maybe Int, Hash)]
darcsParseDir ByteString
content = [ByteString] -> [(ItemType, Name, Maybe Int, Hash)]
parse (Char -> ByteString -> [ByteString]
BLC.split Char
'\n' ByteString
content)
    where
      parse :: [ByteString] -> [(ItemType, Name, Maybe Int, Hash)]
parse (ByteString
t:ByteString
n:ByteString
h':[ByteString]
r) = (ByteString -> ItemType
header ByteString
t,
                          ByteString -> Name
decodeWhiteName (ByteString -> Name) -> ByteString -> Name
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
BL.toChunks ByteString
n,
                          ByteString -> Maybe Int
decodeDarcsSize ByteString
hash,
                          ByteString -> Hash
decodeDarcsHash ByteString
hash) (ItemType, Name, Maybe Int, Hash)
-> [(ItemType, Name, Maybe Int, Hash)]
-> [(ItemType, Name, Maybe Int, Hash)]
forall a. a -> [a] -> [a]
: [ByteString] -> [(ItemType, Name, Maybe Int, Hash)]
parse [ByteString]
r
          where hash :: ByteString
hash = [ByteString] -> ByteString
BC.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
BLC.toChunks ByteString
h'
      parse [ByteString]
_ = []
      header :: ByteString -> ItemType
header ByteString
x
          | ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> ByteString
BLC.pack [Char]
"file:" = ItemType
BlobType
          | ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> ByteString
BLC.pack [Char]
"directory:" = ItemType
TreeType
          | Bool
otherwise = [Char] -> ItemType
forall a. HasCallStack => [Char] -> a
error ([Char] -> ItemType) -> [Char] -> ItemType
forall a b. (a -> b) -> a -> b
$ [Char]
"Error parsing darcs hashed dir: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BLC.unpack ByteString
x

----------------------------------------
-- Utilities.
--

-- | Compute a darcs-compatible hash value for a tree-like structure.
darcsTreeHash :: Tree m -> Hash
darcsTreeHash :: Tree m -> Hash
darcsTreeHash Tree m
t = case Tree m -> Maybe ByteString
forall (m :: * -> *). Tree m -> Maybe ByteString
darcsFormatDir Tree m
t of
                    Maybe ByteString
Nothing -> Hash
NoHash
                    Just ByteString
x -> ByteString -> Hash
sha256 ByteString
x

-- The following two are mostly for experimental use in Packed.

darcsUpdateDirHashes :: Tree m -> Tree m
darcsUpdateDirHashes :: Tree m -> Tree m
darcsUpdateDirHashes = (Tree m -> Tree m) -> Tree m -> Tree m
forall (m :: * -> *). (Tree m -> Tree m) -> Tree m -> Tree m
updateSubtrees Tree m -> Tree m
forall (m :: * -> *). Tree m -> Tree m
update
    where update :: Tree m -> Tree m
update Tree m
t = Tree m
t { treeHash :: Hash
treeHash = Tree m -> Hash
forall (m :: * -> *). Tree m -> Hash
darcsTreeHash Tree m
t }

darcsUpdateHashes :: (Monad m) => Tree m -> m (Tree m)
darcsUpdateHashes :: Tree m -> m (Tree m)
darcsUpdateHashes = (TreeItem m -> m (TreeItem m)) -> Tree m -> m (Tree m)
forall (m :: * -> *).
Monad m =>
(TreeItem m -> m (TreeItem m)) -> Tree m -> m (Tree m)
updateTree TreeItem m -> m (TreeItem m)
forall (m :: * -> *). Monad m => TreeItem m -> m (TreeItem m)
update
    where update :: TreeItem m -> m (TreeItem m)
update (SubTree Tree m
t) = TreeItem m -> m (TreeItem m)
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeItem m -> m (TreeItem m))
-> (Tree m -> TreeItem m) -> Tree m -> m (TreeItem m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
SubTree (Tree m -> m (TreeItem m)) -> Tree m -> m (TreeItem m)
forall a b. (a -> b) -> a -> b
$ Tree m
t { treeHash :: Hash
treeHash = Tree m -> Hash
forall (m :: * -> *). Tree m -> Hash
darcsTreeHash Tree m
t }
          update (File blob :: Blob m
blob@(Blob m ByteString
con Hash
_)) =
              do Hash
hash <- ByteString -> Hash
sha256 (ByteString -> Hash) -> m ByteString -> m Hash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blob m -> m ByteString
forall (m :: * -> *). Blob m -> m ByteString
readBlob Blob m
blob
                 TreeItem m -> m (TreeItem m)
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeItem m -> m (TreeItem m)) -> TreeItem m -> m (TreeItem m)
forall a b. (a -> b) -> a -> b
$ Blob m -> TreeItem m
forall (m :: * -> *). Blob m -> TreeItem m
File (m ByteString -> Hash -> Blob m
forall (m :: * -> *). m ByteString -> Hash -> Blob m
Blob m ByteString
con Hash
hash)
          update TreeItem m
stub = TreeItem m -> m (TreeItem m)
forall (m :: * -> *) a. Monad m => a -> m a
return TreeItem m
stub

darcsHash :: (Monad m) => TreeItem m -> m Hash
darcsHash :: TreeItem m -> m Hash
darcsHash (SubTree Tree m
t) = Hash -> m Hash
forall (m :: * -> *) a. Monad m => a -> m a
return (Hash -> m Hash) -> Hash -> m Hash
forall a b. (a -> b) -> a -> b
$ Tree m -> Hash
forall (m :: * -> *). Tree m -> Hash
darcsTreeHash Tree m
t
darcsHash (File Blob m
blob) = ByteString -> Hash
sha256 (ByteString -> Hash) -> m ByteString -> m Hash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blob m -> m ByteString
forall (m :: * -> *). Blob m -> m ByteString
readBlob Blob m
blob
darcsHash TreeItem m
_ = Hash -> m Hash
forall (m :: * -> *) a. Monad m => a -> m a
return Hash
NoHash

darcsAddMissingHashes :: (Monad m) => Tree m -> m (Tree m)
darcsAddMissingHashes :: Tree m -> m (Tree m)
darcsAddMissingHashes = (TreeItem m -> m Hash) -> Tree m -> m (Tree m)
forall (m :: * -> *).
Monad m =>
(TreeItem m -> m Hash) -> Tree m -> m (Tree m)
addMissingHashes TreeItem m -> m Hash
forall (m :: * -> *). Monad m => TreeItem m -> m Hash
darcsHash

-------------------------------------------
-- Reading darcs pristine data
--

-- | Read and parse a darcs-style hashed directory listing from a given @dir@
-- and with a given @hash@.
readDarcsHashedDir :: FilePath -> (Maybe Int, Hash) -> IO [(ItemType, Name, Maybe Int, Hash)]
readDarcsHashedDir :: [Char]
-> (Maybe Int, Hash) -> IO [(ItemType, Name, Maybe Int, Hash)]
readDarcsHashedDir [Char]
dir (Maybe Int, Hash)
h = do
  [Char] -> IO ()
debugMessage ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"readDarcsHashedDir: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
dir [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Hash -> [Char]
showHash ((Maybe Int, Hash) -> Hash
forall a b. (a, b) -> b
snd (Maybe Int, Hash)
h)
  Bool
exist <- [Char] -> IO Bool
doesFileExist ([Char] -> IO Bool) -> [Char] -> IO Bool
forall a b. (a -> b) -> a -> b
$ FileSegment -> [Char]
forall a b. (a, b) -> a
fst ([Char] -> (Maybe Int, Hash) -> FileSegment
darcsLocation [Char]
dir (Maybe Int, Hash)
h)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exist (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"error opening " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ FileSegment -> [Char]
forall a b. (a, b) -> a
fst ([Char] -> (Maybe Int, Hash) -> FileSegment
darcsLocation [Char]
dir (Maybe Int, Hash)
h)
  ByteString
compressed <- FileSegment -> IO ByteString
readSegment (FileSegment -> IO ByteString) -> FileSegment -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> (Maybe Int, Hash) -> FileSegment
darcsLocation [Char]
dir (Maybe Int, Hash)
h
  let content :: ByteString
content = ByteString -> ByteString
decompress ByteString
compressed
  [(ItemType, Name, Maybe Int, Hash)]
-> IO [(ItemType, Name, Maybe Int, Hash)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(ItemType, Name, Maybe Int, Hash)]
 -> IO [(ItemType, Name, Maybe Int, Hash)])
-> [(ItemType, Name, Maybe Int, Hash)]
-> IO [(ItemType, Name, Maybe Int, Hash)]
forall a b. (a -> b) -> a -> b
$ if ByteString -> Bool
BLC.null ByteString
compressed
              then []
              else ByteString -> [(ItemType, Name, Maybe Int, Hash)]
darcsParseDir ByteString
content

-- | 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' :: Bool -> FilePath -> (Maybe Int, Hash) -> IO (Tree IO)
readDarcsHashed' :: Bool -> [Char] -> (Maybe Int, Hash) -> IO (Tree IO)
readDarcsHashed' Bool
_ [Char]
_ (Maybe Int
_, Hash
NoHash) = [Char] -> IO (Tree IO)
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Cannot readDarcsHashed NoHash"
readDarcsHashed' Bool
sizefail [Char]
dir root :: (Maybe Int, Hash)
root@(Maybe Int
_, Hash
hash) = do
  [(ItemType, Name, Maybe Int, Hash)]
items' <- [Char]
-> (Maybe Int, Hash) -> IO [(ItemType, Name, Maybe Int, Hash)]
readDarcsHashedDir [Char]
dir (Maybe Int, Hash)
root
  [(Name, TreeItem IO)]
subs <- [IO (Name, TreeItem IO)] -> IO [(Name, TreeItem IO)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [
           do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
sizefail Bool -> Bool -> Bool
&& Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust Maybe Int
s) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                [Char] -> IO ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Unexpectedly encountered size-prefixed hash in " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
dir)
              case ItemType
tp of
                ItemType
BlobType -> (Name, TreeItem IO) -> IO (Name, TreeItem IO)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
d, Blob IO -> TreeItem IO
forall (m :: * -> *). Blob m -> TreeItem m
File (Blob IO -> TreeItem IO) -> Blob IO -> TreeItem IO
forall a b. (a -> b) -> a -> b
$
                                       IO ByteString -> Hash -> Blob IO
forall (m :: * -> *). m ByteString -> Hash -> Blob m
Blob ((Maybe Int, Hash) -> IO ByteString
readBlob' (Maybe Int
s, Hash
h)) Hash
h)
                ItemType
TreeType ->
                  do let t :: IO (Tree IO)
t = [Char] -> (Maybe Int, Hash) -> IO (Tree IO)
readDarcsHashed [Char]
dir (Maybe Int
s, Hash
h)
                     (Name, TreeItem IO) -> IO (Name, TreeItem IO)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
d, IO (Tree IO) -> Hash -> TreeItem IO
forall (m :: * -> *). m (Tree m) -> Hash -> TreeItem m
Stub IO (Tree IO)
t Hash
h)
           | (ItemType
tp, Name
d, Maybe Int
s, Hash
h) <- [(ItemType, Name, Maybe Int, Hash)]
items' ]
  Tree IO -> IO (Tree IO)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO -> IO (Tree IO)) -> Tree IO -> IO (Tree IO)
forall a b. (a -> b) -> a -> b
$ [(Name, TreeItem IO)] -> Hash -> Tree IO
forall (m :: * -> *). [(Name, TreeItem m)] -> Hash -> Tree m
makeTreeWithHash [(Name, TreeItem IO)]
subs Hash
hash
    where readBlob' :: (Maybe Int, Hash) -> IO ByteString
readBlob' = (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
decompress (IO ByteString -> IO ByteString)
-> ((Maybe Int, Hash) -> IO ByteString)
-> (Maybe Int, Hash)
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileSegment -> IO ByteString
readSegment (FileSegment -> IO ByteString)
-> ((Maybe Int, Hash) -> FileSegment)
-> (Maybe Int, Hash)
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> (Maybe Int, Hash) -> FileSegment
darcsLocation [Char]
dir

readDarcsHashed :: FilePath -> (Maybe Int, Hash) -> IO (Tree IO)
readDarcsHashed :: [Char] -> (Maybe Int, Hash) -> IO (Tree IO)
readDarcsHashed = Bool -> [Char] -> (Maybe Int, Hash) -> IO (Tree IO)
readDarcsHashed' Bool
False

readDarcsHashedNosize :: FilePath -> Hash -> IO (Tree IO)
readDarcsHashedNosize :: [Char] -> Hash -> IO (Tree IO)
readDarcsHashedNosize [Char]
dir Hash
hash = Bool -> [Char] -> (Maybe Int, Hash) -> IO (Tree IO)
readDarcsHashed' Bool
True [Char]
dir (Maybe Int
forall a. Maybe a
Nothing, Hash
hash)

----------------------------------------------------
-- Writing darcs-style hashed trees.
--

-- | Write a Tree into a darcs-style hashed directory.
writeDarcsHashed :: Tree IO -> FilePath -> IO Hash
writeDarcsHashed :: Tree IO -> [Char] -> IO Hash
writeDarcsHashed Tree IO
tree' [Char]
dir =
    do [Char] -> IO ()
debugMessage ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"writeDarcsHashed " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
dir
       Tree IO
t <- Tree IO -> Tree IO
forall (m :: * -> *). Tree m -> Tree m
darcsUpdateDirHashes (Tree IO -> Tree IO) -> IO (Tree IO) -> IO (Tree IO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand Tree IO
tree'
       [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ ByteString -> IO ()
dump (ByteString -> IO ()) -> IO ByteString -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Blob IO -> IO ByteString
forall (m :: * -> *). Blob m -> m ByteString
readBlob Blob IO
b | (AnchoredPath
_, File Blob IO
b) <- Tree IO -> [(AnchoredPath, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree IO
t ]
       let dirs :: [Maybe ByteString]
dirs = Tree IO -> Maybe ByteString
forall (m :: * -> *). Tree m -> Maybe ByteString
darcsFormatDir Tree IO
t Maybe ByteString -> [Maybe ByteString] -> [Maybe ByteString]
forall a. a -> [a] -> [a]
: [ Tree IO -> Maybe ByteString
forall (m :: * -> *). Tree m -> Maybe ByteString
darcsFormatDir Tree IO
d | (AnchoredPath
_, SubTree Tree IO
d) <- Tree IO -> [(AnchoredPath, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree IO
t ]
       [()]
_ <- (Maybe ByteString -> IO ()) -> [Maybe ByteString] -> IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ByteString -> IO ()
dump (ByteString -> IO ())
-> (Maybe ByteString -> ByteString) -> Maybe ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ByteString -> ByteString
forall a. HasCallStack => Maybe a -> a
fromJust) [Maybe ByteString]
dirs
       Hash -> IO Hash
forall (m :: * -> *) a. Monad m => a -> m a
return (Hash -> IO Hash) -> Hash -> IO Hash
forall a b. (a -> b) -> a -> b
$ Tree IO -> Hash
forall (m :: * -> *). Tree m -> Hash
darcsTreeHash Tree IO
t
    where dump :: ByteString -> IO ()
dump ByteString
bits =
              do let name :: [Char]
name = [Char]
dir [Char] -> [Char] -> [Char]
</> ByteString -> [Char]
BC.unpack (Hash -> ByteString
encodeBase16 (Hash -> ByteString) -> Hash -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Hash
sha256 ByteString
bits)
                 Bool
exist <- [Char] -> IO Bool
doesFileExist [Char]
name
                 Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exist (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> IO ()
BL.writeFile [Char]
name (ByteString -> ByteString
compress ByteString
bits)

-- | Create a hashed file from a 'FilePath' and content. In case the file exists
-- it is kept untouched and is assumed to have the right content. XXX Corrupt
-- files should be probably renamed out of the way automatically or something
-- (probably when they are being read though).
fsCreateHashedFile :: FilePath -> BLC.ByteString -> TreeIO ()
fsCreateHashedFile :: [Char] -> ByteString -> TreeIO ()
fsCreateHashedFile [Char]
fn ByteString
content =
    IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ do
      [Char] -> IO ()
debugMessage ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"fsCreateHashedFile " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
fn
      Bool
exist <- [Char] -> IO Bool
doesFileExist [Char]
fn
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exist (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> IO ()
BL.writeFile [Char]
fn ByteString
content

-- | Run a 'TreeIO' @action@ in a hashed setting. The @initial@ tree is assumed
-- to be fully available from the @directory@, and any changes will be written
-- out to same. Please note that actual filesystem files are never removed.
hashedTreeIO :: TreeIO a -- ^ action
             -> Tree IO -- ^ initial
             -> FilePath -- ^ directory
             -> IO (a, Tree IO)
hashedTreeIO :: TreeIO a -> Tree IO -> [Char] -> IO (a, Tree IO)
hashedTreeIO TreeIO a
action Tree IO
t [Char]
dir =
    TreeIO a
-> Tree IO
-> (TreeItem IO -> IO Hash)
-> (AnchoredPath -> TreeItem IO -> TreeMonad IO (TreeItem IO))
-> IO (a, Tree IO)
forall (m :: * -> *) a.
Monad m =>
TreeMonad m a
-> Tree m
-> (TreeItem m -> m Hash)
-> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
-> m (a, Tree m)
runTreeMonad TreeIO a
action Tree IO
t TreeItem IO -> IO Hash
forall (m :: * -> *). Monad m => TreeItem m -> m Hash
darcsHash AnchoredPath -> TreeItem IO -> TreeMonad IO (TreeItem IO)
forall p. p -> TreeItem IO -> TreeMonad IO (TreeItem IO)
updateItem
    where updateItem :: p -> TreeItem IO -> TreeMonad IO (TreeItem IO)
updateItem p
_ (File Blob IO
b) = Blob IO -> TreeItem IO
forall (m :: * -> *). Blob m -> TreeItem m
File (Blob IO -> TreeItem IO)
-> RWST (TreeEnv IO) () (TreeState IO) IO (Blob IO)
-> TreeMonad IO (TreeItem IO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blob IO -> RWST (TreeEnv IO) () (TreeState IO) IO (Blob IO)
updateFile Blob IO
b
          updateItem p
_ (SubTree Tree IO
s) = Tree IO -> TreeItem IO
forall (m :: * -> *). Tree m -> TreeItem m
SubTree (Tree IO -> TreeItem IO)
-> RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
-> TreeMonad IO (TreeItem IO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tree IO -> RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
forall (m :: * -> *).
Tree m -> RWST (TreeEnv IO) () (TreeState IO) IO (Tree m)
updateSub Tree IO
s
          updateItem p
_ TreeItem IO
x = TreeItem IO -> TreeMonad IO (TreeItem IO)
forall (m :: * -> *) a. Monad m => a -> m a
return TreeItem IO
x

          updateFile :: Blob IO -> RWST (TreeEnv IO) () (TreeState IO) IO (Blob IO)
updateFile b :: Blob IO
b@(Blob IO ByteString
_ !Hash
h) = do
            IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
debugMessage ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"hashedTreeIO.updateFile: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Hash -> [Char]
showHash Hash
h
            ByteString
content <- IO ByteString -> RWST (TreeEnv IO) () (TreeState IO) IO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString
 -> RWST (TreeEnv IO) () (TreeState IO) IO ByteString)
-> IO ByteString
-> RWST (TreeEnv IO) () (TreeState IO) IO ByteString
forall a b. (a -> b) -> a -> b
$ Blob IO -> IO ByteString
forall (m :: * -> *). Blob m -> m ByteString
readBlob Blob IO
b
            let fn :: [Char]
fn = [Char]
dir [Char] -> [Char] -> [Char]
</> Hash -> [Char]
showHash Hash
h
                nblob :: Blob IO
nblob = IO ByteString -> Hash -> Blob IO
forall (m :: * -> *). m ByteString -> Hash -> Blob m
Blob (ByteString -> ByteString
decompress (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString
rblob) Hash
h
                rblob :: IO ByteString
rblob = [ByteString] -> ByteString
BL.fromChunks ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO ByteString
B.readFile [Char]
fn
                newcontent :: ByteString
newcontent = ByteString -> ByteString
compress ByteString
content
            [Char] -> ByteString -> TreeIO ()
fsCreateHashedFile [Char]
fn ByteString
newcontent
            Blob IO -> RWST (TreeEnv IO) () (TreeState IO) IO (Blob IO)
forall (m :: * -> *) a. Monad m => a -> m a
return Blob IO
nblob
          updateSub :: Tree m -> RWST (TreeEnv IO) () (TreeState IO) IO (Tree m)
updateSub Tree m
s = do
            let !hash :: Hash
hash = Tree m -> Hash
forall (m :: * -> *). Tree m -> Hash
treeHash Tree m
s
                Just ByteString
dirdata = Tree m -> Maybe ByteString
forall (m :: * -> *). Tree m -> Maybe ByteString
darcsFormatDir Tree m
s
                fn :: [Char]
fn = [Char]
dir [Char] -> [Char] -> [Char]
</> Hash -> [Char]
showHash Hash
hash
            IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
debugMessage ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"hashedTreeIO.updateSub: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Hash -> [Char]
showHash Hash
hash
            [Char] -> ByteString -> TreeIO ()
fsCreateHashedFile [Char]
fn (ByteString -> ByteString
compress ByteString
dirdata)
            Tree m -> RWST (TreeEnv IO) () (TreeState IO) IO (Tree m)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree m
s

showHash :: Hash -> String
showHash :: Hash -> [Char]
showHash = ByteString -> [Char]
BC.unpack (ByteString -> [Char]) -> (Hash -> ByteString) -> Hash -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> ByteString
encodeBase16