--  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
    , readDarcsHashedNosize
    , darcsAddMissingHashes
    , darcsTreeHash
    , darcsUpdateHashes
    , followPristineHashes
    ) where

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

import Data.List ( sortBy )
import Data.Maybe ( fromMaybe )

import Darcs.Prelude

import Darcs.Util.Cache
    ( Cache
    , fetchFileUsingCache
    , writeFileUsingCache
    )
import Darcs.Util.Hash
    ( Hash
    , encodeBase16
    , encodeHash
    , sha256
    , showHash
    )
import Darcs.Util.Parser
import Darcs.Util.Path ( Name, decodeWhiteName, encodeWhiteName )
import Darcs.Util.Progress ( debugMessage, finishedOneIO, withSizedProgress )
import Darcs.Util.Tree
    ( Blob(..)
    , ItemType(..)
    , Tree(..)
    , TreeItem(..)
    , addMissingHashes
    , expand
    , itemHash
    , list
    , listImmediate
    , makeTreeWithHash
    , readBlob
    , updateSubtrees
    , updateTree
    )
import Darcs.Util.Tree.Monad ( TreeIO, runTreeMonad )
import Darcs.Util.ValidHash
    ( PristineHash
    , decodeValidHash
    , encodeValidHash
    , fromHash
    , getHash
    , getSize
    )

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

-- Precondition: all (immediate) items in the tree have hashes
darcsFormatDir :: Tree m -> BL.ByteString
darcsFormatDir :: forall (m :: * -> *). Tree m -> ByteString
darcsFormatDir =
  [ByteString] -> ByteString
BL.fromChunks ([ByteString] -> ByteString)
-> (Tree m -> [ByteString]) -> Tree m -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, TreeItem m) -> ByteString)
-> [(Name, TreeItem m)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (Name, TreeItem m) -> ByteString
forall {m :: * -> *}. (Name, TreeItem m) -> ByteString
formatItem ([(Name, TreeItem m)] -> [ByteString])
-> (Tree m -> [(Name, TreeItem m)]) -> Tree m -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((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)])
-> (Tree m -> [(Name, TreeItem m)])
-> Tree m
-> [(Name, TreeItem m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree m -> [(Name, TreeItem m)]
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate
  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
    formatItem :: (Name, TreeItem m) -> ByteString
formatItem (Name
name, TreeItem m
item) = [ByteString] -> ByteString
BC.unlines
      [ case TreeItem m
item of
          File Blob m
_ -> ByteString
kwFile
          TreeItem m
_      -> ByteString
kwDir
      , Name -> ByteString
encodeWhiteName Name
name
      , case TreeItem m -> Maybe Hash
forall (m :: * -> *). TreeItem m -> Maybe Hash
itemHash TreeItem m
item of
          Maybe Hash
Nothing -> [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"precondition of darcsFormatDir"
          Just Hash
h  -> Hash -> ByteString
encodeBase16 Hash
h
      ]

darcsParseDir
  :: FilePath -> BC.ByteString -> Either String [(ItemType, Name, PristineHash)]
darcsParseDir :: [Char]
-> ByteString -> Either [Char] [(ItemType, Name, PristineHash)]
darcsParseDir [Char]
path = [Char]
-> Either [Char] [(ItemType, Name, PristineHash)]
-> Either [Char] [(ItemType, Name, PristineHash)]
forall a. [Char] -> Either [Char] a -> Either [Char] a
withPath [Char]
path (Either [Char] [(ItemType, Name, PristineHash)]
 -> Either [Char] [(ItemType, Name, PristineHash)])
-> (ByteString -> Either [Char] [(ItemType, Name, PristineHash)])
-> ByteString
-> Either [Char] [(ItemType, Name, PristineHash)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser [(ItemType, Name, PristineHash)]
-> ByteString -> Either [Char] [(ItemType, Name, PristineHash)]
forall a. Parser a -> ByteString -> Either [Char] a
parseAll (Parser ByteString (ItemType, Name, PristineHash)
-> Parser [(ItemType, Name, PristineHash)]
forall a. Parser ByteString a -> Parser ByteString [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ByteString (ItemType, Name, PristineHash)
pDir)
  where
    pDir :: Parser ByteString (ItemType, Name, PristineHash)
pDir = do
      ItemType
t <- Parser ByteString ItemType
pHeader
      Char -> Parser ()
char Char
'\n'
      Name
n <- Parser ByteString Name
pName
      Char -> Parser ()
char Char
'\n'
      PristineHash
h <- Parser ByteString PristineHash
pHash
      Char -> Parser ()
char Char
'\n'
      (ItemType, Name, PristineHash)
-> Parser ByteString (ItemType, Name, PristineHash)
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (ItemType
t, Name
n, PristineHash
h)
    pHeader :: Parser ByteString ItemType
pHeader = (ItemType
BlobType ItemType -> Parser () -> Parser ByteString ItemType
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ()
string ByteString
kwFile) Parser ByteString ItemType
-> Parser ByteString ItemType -> Parser ByteString ItemType
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ItemType
TreeType ItemType -> Parser () -> Parser ByteString ItemType
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ()
string ByteString
kwDir)
    pName :: Parser ByteString Name
pName   = do
      ByteString
name <- Char -> Parser ByteString
takeTillChar Char
'\n'
      ([Char] -> Parser ByteString Name)
-> (Name -> Parser ByteString Name)
-> Either [Char] Name
-> Parser ByteString Name
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Parser ByteString Name
forall a. [Char] -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail Name -> Parser ByteString Name
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Either [Char] Name
decodeWhiteName ByteString
name)
    pHash :: Parser ByteString PristineHash
pHash = do
      ByteString
hash <- Char -> Parser ByteString
takeTillChar Char
'\n'
      Parser ByteString PristineHash
-> (PristineHash -> Parser ByteString PristineHash)
-> Maybe PristineHash
-> Parser ByteString PristineHash
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Parser ByteString PristineHash
forall a. [Char] -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"expected valid hash") PristineHash -> Parser ByteString PristineHash
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Maybe PristineHash
forall h. ValidHash h => [Char] -> Maybe h
decodeValidHash (ByteString -> [Char]
BC.unpack ByteString
hash))

kwFile, kwDir :: BC.ByteString
kwFile :: ByteString
kwFile = [Char] -> ByteString
BC.pack [Char]
"file:"
kwDir :: ByteString
kwDir = [Char] -> ByteString
BC.pack [Char]
"directory:"

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

-- | Compute a darcs-compatible hash value for a tree-like structure.
darcsTreeHash :: Tree m -> Hash
darcsTreeHash :: forall (m :: * -> *). Tree m -> Hash
darcsTreeHash = ByteString -> Hash
sha256 (ByteString -> Hash) -> (Tree m -> ByteString) -> Tree m -> Hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree m -> ByteString
forall (m :: * -> *). Tree m -> ByteString
darcsFormatDir

darcsUpdateDirHashes :: Tree m -> Tree m
darcsUpdateDirHashes :: forall (m :: * -> *). 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 = Just (darcsTreeHash t) }

darcsUpdateHashes :: Monad m => Tree m -> m (Tree m)
darcsUpdateHashes :: forall (m :: * -> *). Monad m => 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) =
              -- why not recursively ensure that hashes exist here?
              TreeItem m -> m (TreeItem m)
forall a. a -> m a
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 = Just (darcsTreeHash t) }
          update (File blob :: Blob m
blob@(Blob m ByteString
con Maybe 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 a. a -> m a
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 -> Maybe Hash -> Blob m
forall (m :: * -> *). m ByteString -> Maybe Hash -> Blob m
Blob m ByteString
con (Hash -> Maybe Hash
forall a. a -> Maybe a
Just Hash
hash))
          update TreeItem m
stub = TreeItem m -> m (TreeItem m)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return TreeItem m
stub

darcsHash :: Monad m => TreeItem m -> m Hash
darcsHash :: forall (m :: * -> *). Monad m => TreeItem m -> m Hash
darcsHash (SubTree Tree m
t) = Hash -> m Hash
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (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 (Stub m (Tree m)
unstub Maybe Hash
_) = Tree m -> Hash
forall (m :: * -> *). Tree m -> Hash
darcsTreeHash (Tree m -> Hash) -> m (Tree m) -> m Hash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Tree m)
unstub

darcsAddMissingHashes :: (Monad m) => Tree m -> m (Tree m)
darcsAddMissingHashes :: forall (m :: * -> *). Monad m => 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 @cache@
-- and with a given @hash@.
readDarcsHashedDir :: Cache
                   -> PristineHash
                   -> IO [(ItemType, Name, PristineHash)]
readDarcsHashedDir :: Cache -> PristineHash -> IO [(ItemType, Name, PristineHash)]
readDarcsHashedDir Cache
cache PristineHash
ph = 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]
++ PristineHash -> [Char]
forall h. ValidHash h => h -> [Char]
encodeValidHash PristineHash
ph
  ([Char]
file, ByteString
content) <- Cache -> PristineHash -> IO ([Char], ByteString)
fsReadHashedFile Cache
cache PristineHash
ph
  ([Char] -> IO [(ItemType, Name, PristineHash)])
-> ([(ItemType, Name, PristineHash)]
    -> IO [(ItemType, Name, PristineHash)])
-> Either [Char] [(ItemType, Name, PristineHash)]
-> IO [(ItemType, Name, PristineHash)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> IO [(ItemType, Name, PristineHash)]
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [(ItemType, Name, PristineHash)]
-> IO [(ItemType, Name, PristineHash)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] [(ItemType, Name, PristineHash)]
 -> IO [(ItemType, Name, PristineHash)])
-> Either [Char] [(ItemType, Name, PristineHash)]
-> IO [(ItemType, Name, PristineHash)]
forall a b. (a -> b) -> a -> b
$ [Char]
-> ByteString -> Either [Char] [(ItemType, Name, PristineHash)]
darcsParseDir [Char]
file ByteString
content

-- | Read a darcs-style hashed tree.
readDarcsHashed' :: Bool -> Cache -> PristineHash -> IO (Tree IO)
readDarcsHashed' :: Bool -> Cache -> PristineHash -> IO (Tree IO)
readDarcsHashed' Bool
sizefail Cache
cache PristineHash
root = do
  [(ItemType, Name, PristineHash)]
items' <- Cache -> PristineHash -> IO [(ItemType, Name, PristineHash)]
readDarcsHashedDir Cache
cache PristineHash
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)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [
           do let h :: Hash
h = PristineHash -> Hash
forall h. ValidHash h => h -> Hash
getHash PristineHash
ph
              case PristineHash -> Maybe Int
forall h. ValidHash h => h -> Maybe Int
getSize PristineHash
ph of
                Just Int
_ | Bool
sizefail ->
                  [Char] -> IO ()
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Unexpectedly encountered size-prefixed hash in " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PristineHash -> [Char]
forall h. ValidHash h => h -> [Char]
encodeValidHash PristineHash
root)
                Maybe Int
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              case ItemType
tp of
                ItemType
BlobType -> (Name, TreeItem IO) -> IO (Name, TreeItem IO)
forall a. a -> IO a
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 -> Maybe Hash -> Blob IO
forall (m :: * -> *). m ByteString -> Maybe Hash -> Blob m
Blob (PristineHash -> IO ByteString
readBlob' PristineHash
ph) (Hash -> Maybe Hash
forall a. a -> Maybe a
Just Hash
h))
                ItemType
TreeType ->
                  do let t :: IO (Tree IO)
t = Cache -> PristineHash -> IO (Tree IO)
readDarcsHashed Cache
cache PristineHash
ph
                     (Name, TreeItem IO) -> IO (Name, TreeItem IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
d, IO (Tree IO) -> Maybe Hash -> TreeItem IO
forall (m :: * -> *). m (Tree m) -> Maybe Hash -> TreeItem m
Stub IO (Tree IO)
t (Hash -> Maybe Hash
forall a. a -> Maybe a
Just Hash
h))
           | (ItemType
tp, Name
d, PristineHash
ph) <- [(ItemType, Name, PristineHash)]
items' ]
  Tree IO -> IO (Tree IO)
forall a. a -> IO a
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 (PristineHash -> Hash
forall h. ValidHash h => h -> Hash
getHash PristineHash
root)
    where readBlob' :: PristineHash -> IO ByteString
readBlob' = (([Char], ByteString) -> ByteString)
-> IO ([Char], ByteString) -> IO ByteString
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString)
-> (([Char], ByteString) -> ByteString)
-> ([Char], ByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], ByteString) -> ByteString
forall a b. (a, b) -> b
snd) (IO ([Char], ByteString) -> IO ByteString)
-> (PristineHash -> IO ([Char], ByteString))
-> PristineHash
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cache -> PristineHash -> IO ([Char], ByteString)
fsReadHashedFile Cache
cache

readDarcsHashed :: Cache -> PristineHash -> IO (Tree IO)
readDarcsHashed :: Cache -> PristineHash -> IO (Tree IO)
readDarcsHashed = Bool -> Cache -> PristineHash -> IO (Tree IO)
readDarcsHashed' Bool
False

readDarcsHashedNosize :: Cache -> PristineHash -> IO (Tree IO)
readDarcsHashedNosize :: Cache -> PristineHash -> IO (Tree IO)
readDarcsHashedNosize = Bool -> Cache -> PristineHash -> IO (Tree IO)
readDarcsHashed' Bool
True

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

-- | Write a Tree into a darcs-style hashed directory.
writeDarcsHashed :: Tree IO -> Cache -> IO PristineHash
writeDarcsHashed :: Tree IO -> Cache -> IO PristineHash
writeDarcsHashed Tree IO
tree' Cache
cache = do
  [Char] -> IO ()
debugMessage [Char]
"writeDarcsHashed"
  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'
  let items :: [(AnchoredPath, TreeItem IO)]
items = Tree IO -> [(AnchoredPath, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree IO
t
  [Char] -> Int -> ([Char] -> IO ()) -> IO ()
forall a. [Char] -> Int -> ([Char] -> IO a) -> IO a
withSizedProgress [Char]
"Getting pristine" ([(AnchoredPath, TreeItem IO)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(AnchoredPath, TreeItem IO)]
items) (([Char] -> IO ()) -> IO ()) -> ([Char] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Char]
k -> do
    [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [[Char] -> Blob IO -> IO ()
readAndWriteBlob [Char]
k Blob IO
b | (AnchoredPath
_, File Blob IO
b) <- [(AnchoredPath, TreeItem IO)]
items]
    let dirs :: [ByteString]
dirs = Tree IO -> ByteString
forall (m :: * -> *). Tree m -> ByteString
darcsFormatDir Tree IO
t ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [Tree IO -> ByteString
forall (m :: * -> *). Tree m -> ByteString
darcsFormatDir Tree IO
d | (AnchoredPath
_, SubTree Tree IO
d) <- [(AnchoredPath, TreeItem IO)]
items]
    (ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char] -> ByteString -> IO ()
dump [Char]
k) [ByteString]
dirs
  PristineHash -> IO PristineHash
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Hash -> PristineHash
forall h. ValidHash h => Hash -> h
fromHash (Tree IO -> Hash
forall (m :: * -> *). Tree m -> Hash
darcsTreeHash Tree IO
t))
  where
    readAndWriteBlob :: [Char] -> Blob IO -> IO ()
readAndWriteBlob [Char]
k Blob IO
b = Blob IO -> IO ByteString
forall (m :: * -> *). Blob m -> m ByteString
readBlob Blob IO
b IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> ByteString -> IO ()
dump [Char]
k
    dump :: [Char] -> ByteString -> IO ()
dump [Char]
k ByteString
x = Cache -> ByteString -> IO PristineHash
fsCreateHashedFile Cache
cache ByteString
x IO PristineHash -> (PristineHash -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> [Char] -> IO ()
finishedOneIO [Char]
k ([Char] -> IO ())
-> (PristineHash -> [Char]) -> PristineHash -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PristineHash -> [Char]
forall h. ValidHash h => h -> [Char]
encodeValidHash

-- | Create a hashed file from a 'Cache' and file content. In case the file
-- exists it is kept untouched and is assumed to have the right content.
fsCreateHashedFile :: Cache -> BL.ByteString -> IO PristineHash
fsCreateHashedFile :: Cache -> ByteString -> IO PristineHash
fsCreateHashedFile Cache
cache ByteString
content =
  Cache -> ByteString -> IO PristineHash
forall h. ValidHash h => Cache -> ByteString -> IO h
writeFileUsingCache Cache
cache (ByteString -> ByteString
BL.toStrict ByteString
content)

fsReadHashedFile :: Cache -> PristineHash -> IO (FilePath, BC.ByteString)
fsReadHashedFile :: Cache -> PristineHash -> IO ([Char], ByteString)
fsReadHashedFile = Cache -> PristineHash -> IO ([Char], ByteString)
forall h. ValidHash h => Cache -> h -> IO ([Char], ByteString)
fetchFileUsingCache

-- | Run a 'TreeIO' @action@ in a hashed setting. Any changes will be written
-- out to the cache. Please note that actual filesystem files are never removed.
hashedTreeIO :: TreeIO a -- ^ action
             -> Tree IO -- ^ initial
             -> Cache
             -> IO (a, Tree IO)
hashedTreeIO :: forall a. TreeIO a -> Tree IO -> Cache -> IO (a, Tree IO)
hashedTreeIO TreeIO a
action Tree IO
tree Cache
cache = TreeIO a -> Tree IO -> DumpItem IO -> IO (a, Tree IO)
forall (m :: * -> *) a.
Monad m =>
TreeMonad m a -> Tree m -> DumpItem m -> m (a, Tree m)
runTreeMonad TreeIO a
action Tree IO
tree ((TreeItem IO -> IO (TreeItem IO)) -> DumpItem IO
forall a b. a -> b -> a
const TreeItem IO -> IO (TreeItem IO)
dumpItem)
  where
    dumpItem :: TreeItem IO -> IO (TreeItem IO)
dumpItem (File Blob IO
b) = Blob IO -> TreeItem IO
forall (m :: * -> *). Blob m -> TreeItem m
File (Blob IO -> TreeItem IO) -> IO (Blob IO) -> IO (TreeItem IO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blob IO -> IO (Blob IO)
dumpFile Blob IO
b
    dumpItem (Stub IO (Tree IO)
unstub Maybe Hash
_) = Tree IO -> TreeItem IO
forall (m :: * -> *). Tree m -> TreeItem m
SubTree (Tree IO -> TreeItem IO) -> IO (Tree IO) -> IO (TreeItem IO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO (Tree IO)
unstub IO (Tree IO) -> (Tree IO -> IO (Tree IO)) -> IO (Tree IO)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tree IO -> IO (Tree IO)
dumpTree)
    dumpItem (SubTree Tree IO
s) = Tree IO -> TreeItem IO
forall (m :: * -> *). Tree m -> TreeItem m
SubTree (Tree IO -> TreeItem IO) -> IO (Tree IO) -> IO (TreeItem IO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tree IO -> IO (Tree IO)
dumpTree Tree IO
s

    -- This code is somewhat tricky. The original Tree may have come from
    -- anywhere e.g. a plain Tree. So when we modify the content of a
    -- file, we not only write a new hashed file, but also modify the
    -- Blob itself, so that the embedded read action read this new hashed
    -- file.
    dumpFile :: Blob IO -> IO (Blob IO)
    dumpFile :: Blob IO -> IO (Blob IO)
dumpFile (Blob IO ByteString
getBlob Maybe Hash
mhash) = do
      ByteString
content <- IO ByteString
getBlob
      let hash :: Hash
hash = Hash -> Maybe Hash -> Hash
forall a. a -> Maybe a -> a
fromMaybe (ByteString -> Hash
sha256 ByteString
content) Maybe Hash
mhash
      [Char] -> IO ()
debugMessage ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"hashedTreeIO.dumpFile: old hash=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Hash -> [Char]
encodeHash Hash
hash
      let getBlob' :: IO ByteString
getBlob' =
            ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString)
-> (([Char], ByteString) -> ByteString)
-> ([Char], ByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], ByteString) -> ByteString
forall a b. (a, b) -> b
snd (([Char], ByteString) -> ByteString)
-> IO ([Char], ByteString) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            Cache -> PristineHash -> IO ([Char], ByteString)
fsReadHashedFile Cache
cache (Hash -> PristineHash
forall h. ValidHash h => Hash -> h
fromHash Hash
hash)
      PristineHash
nhash <- Cache -> ByteString -> IO PristineHash
fsCreateHashedFile Cache
cache ByteString
content
      [Char] -> IO ()
debugMessage ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"hashedTreeIO.dumpFile: new hash=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PristineHash -> [Char]
forall h. ValidHash h => h -> [Char]
encodeValidHash PristineHash
nhash
      Blob IO -> IO (Blob IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blob IO -> IO (Blob IO)) -> Blob IO -> IO (Blob IO)
forall a b. (a -> b) -> a -> b
$ IO ByteString -> Maybe Hash -> Blob IO
forall (m :: * -> *). m ByteString -> Maybe Hash -> Blob m
Blob IO ByteString
getBlob' (Hash -> Maybe Hash
forall a. a -> Maybe a
Just Hash
hash)

    dumpTree :: Tree IO -> IO (Tree IO)
    dumpTree :: Tree IO -> IO (Tree IO)
dumpTree Tree IO
t = do
      [Char] -> IO ()
debugMessage ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"hashedTreeIO.dumpTree: old hash=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe Hash -> [Char]
showHash (Tree IO -> Maybe Hash
forall (m :: * -> *). Tree m -> Maybe Hash
treeHash Tree IO
t)
      Tree IO
t' <- Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
darcsAddMissingHashes Tree IO
t
      PristineHash
nhash <- Cache -> ByteString -> IO PristineHash
fsCreateHashedFile Cache
cache (Tree IO -> ByteString
forall (m :: * -> *). Tree m -> ByteString
darcsFormatDir Tree IO
t')
      [Char] -> IO ()
debugMessage ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"hashedTreeIO.dumpTree: new hash=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PristineHash -> [Char]
forall h. ValidHash h => h -> [Char]
encodeValidHash PristineHash
nhash
      Tree IO -> IO (Tree IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Tree IO
t'

-- | Return all 'PristineHash'es reachable from the given root set, which must
-- consist of directory hashes only.
followPristineHashes :: Cache -> [PristineHash] -> IO [PristineHash]
followPristineHashes :: Cache -> [PristineHash] -> IO [PristineHash]
followPristineHashes Cache
cache = [PristineHash] -> IO [PristineHash]
followAll
  where
    followAll :: [PristineHash] -> IO [PristineHash]
followAll [PristineHash]
roots = [[PristineHash]] -> [PristineHash]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[PristineHash]] -> [PristineHash])
-> IO [[PristineHash]] -> IO [PristineHash]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PristineHash -> IO [PristineHash])
-> [PristineHash] -> IO [[PristineHash]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PristineHash -> IO [PristineHash]
followOne [PristineHash]
roots
    followOne :: PristineHash -> IO [PristineHash]
followOne PristineHash
root = do
      [(ItemType, Name, PristineHash)]
x <- Cache -> PristineHash -> IO [(ItemType, Name, PristineHash)]
readDarcsHashedDir Cache
cache PristineHash
root
      let subs :: [PristineHash]
subs   = [ PristineHash
ph | (ItemType
TreeType, Name
_, PristineHash
ph) <- [(ItemType, Name, PristineHash)]
x ]
          hashes :: [PristineHash]
hashes = PristineHash
root PristineHash -> [PristineHash] -> [PristineHash]
forall a. a -> [a] -> [a]
: [ PristineHash
ph | (ItemType
_, Name
_, PristineHash
ph) <- [(ItemType, Name, PristineHash)]
x ]
      ([PristineHash]
hashes [PristineHash] -> [PristineHash] -> [PristineHash]
forall a. [a] -> [a] -> [a]
++) ([PristineHash] -> [PristineHash])
-> IO [PristineHash] -> IO [PristineHash]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PristineHash] -> IO [PristineHash]
followAll [PristineHash]
subs