module Darcs.Repository.Pristine
    ( ApplyDir(..)
    , applyToHashedPristine
    , applyToTentativePristine
    , applyToTentativePristineCwd
    , readHashedPristineRoot
    , pokePristineHash
    , peekPristineHash
    , createPristineDirectoryTree
    , createPartialsPristineDirectoryTree
    , withRecorded
    , withTentative
    ) where

import Darcs.Prelude

import Control.Arrow ( (&&&) )
import Control.Exception ( catch, IOException )
import Control.Monad ( when )

import qualified Data.ByteString.Char8 as BC ( unpack, pack )

import System.Directory ( createDirectoryIfMissing )
import System.FilePath.Posix( (</>) )
import System.IO ( hPutStrLn, stderr )

import Darcs.Patch ( description )
import Darcs.Patch.Apply ( Apply(..) )
import Darcs.Patch.Show ( ShowPatch )

import Darcs.Repository.Cache ( Cache, HashedDir(..), mkCache )
import Darcs.Repository.Flags ( Verbosity(..), WithWorkingDir(..) )
import Darcs.Repository.Format ( RepoProperty(HashedInventory), formatHas )
import Darcs.Repository.HashedIO ( cleanHashdir, copyHashed, copyPartialsHashed )
import Darcs.Repository.Inventory
import Darcs.Repository.InternalTypes
    ( Repository
    , repoCache
    , repoFormat
    , repoLocation
    , withRepoLocation
    )
import Darcs.Repository.Old ( oldRepoFailMsg )
import Darcs.Repository.Paths
    ( hashedInventoryPath
    , pristineDirPath
    , tentativePristinePath
    )

import Darcs.Util.ByteString ( gzReadFilePS )
import Darcs.Util.External ( Cachable(Uncachable), fetchFilePS )
import Darcs.Util.File ( withCurrentDirectory )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Hash ( Hash(..), encodeBase16 )
import Darcs.Util.Lock ( writeDocBinFile )
import Darcs.Util.Path ( AbsolutePath, AnchoredPath, toFilePath )
import Darcs.Util.Printer ( (<+>), putDocLn, text )
import Darcs.Util.Progress ( beginTedious, endTedious, debugMessage )
import Darcs.Util.Tree ( Tree, treeHash )
import Darcs.Util.Tree.Hashed
    ( decodeDarcsHash
    , decodeDarcsSize
    , hashedTreeIO
    , readDarcsHashed
    , readDarcsHashedNosize
    , writeDarcsHashed
    )


data ApplyDir = ApplyNormal | ApplyInverted

-- | 'applyToHashedPristine' takes a root hash, a patch @p@ and attempts to
-- apply the patch to the 'Tree' identified by @h@. If we encounter an old,
-- size-prefixed pristine, we first convert it to the non-size-prefixed format,
-- then apply the patch.
applyToHashedPristine :: (Apply p, ApplyState p ~ Tree)
                      => ApplyDir -> PristineHash -> p wX wY -> IO PristineHash
applyToHashedPristine :: ApplyDir -> PristineHash -> p wX wY -> IO PristineHash
applyToHashedPristine ApplyDir
dir PristineHash
h p wX wY
p = IO PristineHash
applyOrConvertOldPristineAndApply
  where
    applyOrConvertOldPristineAndApply :: IO PristineHash
applyOrConvertOldPristineAndApply =
        Hash -> IO PristineHash
tryApply Hash
hash IO PristineHash
-> (IOException -> IO PristineHash) -> IO PristineHash
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
_ :: IOException) -> IO PristineHash
handleOldPristineAndApply

    hash :: Hash
hash = ByteString -> Hash
decodeDarcsHash (ByteString -> Hash) -> ByteString -> Hash
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BC.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ PristineHash -> String
forall a. ValidHash a => a -> String
getValidHash PristineHash
h

    failOnMalformedRoot :: Hash -> m ()
failOnMalformedRoot (SHA256 ByteString
_) = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    failOnMalformedRoot Hash
root = String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Cannot handle hash: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Hash -> String
forall a. Show a => a -> String
show Hash
root

    hash2root :: Hash -> PristineHash
hash2root = String -> PristineHash
forall a. ValidHash a => String -> a
mkValidHash (String -> PristineHash)
-> (Hash -> String) -> Hash -> PristineHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BC.unpack (ByteString -> String) -> (Hash -> ByteString) -> Hash -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> ByteString
encodeBase16

    tryApply :: Hash -> IO PristineHash
    tryApply :: Hash -> IO PristineHash
tryApply Hash
root = do
        Hash -> IO ()
forall (m :: * -> *). MonadFail m => Hash -> m ()
failOnMalformedRoot Hash
root
        -- Read a non-size-prefixed pristine, failing if we encounter one.
        Tree IO
tree <- String -> Hash -> IO (Tree IO)
readDarcsHashedNosize String
pristineDirPath Hash
root
        (()
_, Tree IO
updatedTree) <- case ApplyDir
dir of
            ApplyDir
ApplyNormal -> TreeIO () -> Tree IO -> String -> IO ((), Tree IO)
forall a. TreeIO a -> Tree IO -> String -> IO (a, Tree IO)
hashedTreeIO (p wX wY -> TreeIO ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply p wX wY
p) Tree IO
tree String
pristineDirPath
            ApplyDir
ApplyInverted -> TreeIO () -> Tree IO -> String -> IO ((), Tree IO)
forall a. TreeIO a -> Tree IO -> String -> IO (a, Tree IO)
hashedTreeIO (p wX wY -> TreeIO ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
unapply p wX wY
p) Tree IO
tree String
pristineDirPath
        PristineHash -> IO PristineHash
forall (m :: * -> *) a. Monad m => a -> m a
return (PristineHash -> IO PristineHash)
-> PristineHash -> IO PristineHash
forall a b. (a -> b) -> a -> b
$ Hash -> PristineHash
hash2root (Hash -> PristineHash) -> Hash -> PristineHash
forall a b. (a -> b) -> a -> b
$ Tree IO -> Hash
forall (m :: * -> *). Tree m -> Hash
treeHash Tree IO
updatedTree

    warn :: String
warn = String
"WARNING: Doing a one-time conversion of pristine format.\n"
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"This may take a while. The new format is backwards-compatible."

    handleOldPristineAndApply :: IO PristineHash
handleOldPristineAndApply = do
        Handle -> String -> IO ()
hPutStrLn Handle
stderr String
warn
        ByteString
inv <- String -> IO ByteString
gzReadFilePS String
hashedInventoryPath
        let oldroot :: ByteString
oldroot = String -> ByteString
BC.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ PristineHash -> String
forall a. ValidHash a => a -> String
getValidHash (PristineHash -> String) -> PristineHash -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> PristineHash
peekPristineHash ByteString
inv
            oldrootSizeandHash :: (Maybe Int, Hash)
oldrootSizeandHash = (ByteString -> Maybe Int
decodeDarcsSize (ByteString -> Maybe Int)
-> (ByteString -> Hash) -> ByteString -> (Maybe Int, Hash)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ByteString -> Hash
decodeDarcsHash) ByteString
oldroot
        -- Read the old size-prefixed pristine tree
        Tree IO
old <- String -> (Maybe Int, Hash) -> IO (Tree IO)
readDarcsHashed String
pristineDirPath (Maybe Int, Hash)
oldrootSizeandHash
        -- Write out the pristine tree as a non-size-prefixed pristine.
        Hash
root <- Tree IO -> String -> IO Hash
writeDarcsHashed Tree IO
old String
pristineDirPath
        let newroot :: PristineHash
newroot = Hash -> PristineHash
hash2root Hash
root
        -- Write out the new inventory.
        String -> Doc -> IO ()
forall p. FilePathLike p => p -> Doc -> IO ()
writeDocBinFile String
hashedInventoryPath (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ PristineHash -> ByteString -> Doc
pokePristineHash PristineHash
newroot ByteString
inv
        Cache -> HashedDir -> [PristineHash] -> IO ()
cleanHashdir ([CacheLoc] -> Cache
mkCache []) HashedDir
HashedPristineDir [PristineHash
newroot]
        Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Pristine conversion done..."
        -- Retry applying the patch, which should now succeed.
        Hash -> IO PristineHash
tryApply Hash
root

-- | copyPristine copies a pristine tree into the current pristine dir,
--   and possibly copies a clean working tree.
--   The target is read from the passed-in dir/inventory name combination.
copyPristine :: Cache -> String -> String -> WithWorkingDir -> IO ()
copyPristine :: Cache -> String -> String -> WithWorkingDir -> IO ()
copyPristine Cache
cache String
dir String
iname WithWorkingDir
wwd = do
    ByteString
i <- String -> Cachable -> IO ByteString
fetchFilePS (String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
iname) Cachable
Uncachable
    String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Copying hashed pristine tree: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PristineHash -> String
forall a. ValidHash a => a -> String
getValidHash (ByteString -> PristineHash
peekPristineHash ByteString
i)
    let tediousName :: String
tediousName = String
"Copying pristine"
    String -> IO ()
beginTedious String
tediousName
    String -> Cache -> WithWorkingDir -> PristineHash -> IO ()
copyHashed String
tediousName Cache
cache WithWorkingDir
wwd (PristineHash -> IO ()) -> PristineHash -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> PristineHash
peekPristineHash ByteString
i
    String -> IO ()
endTedious String
tediousName

-- |applyToTentativePristine applies a patch @p@ to the tentative pristine
-- tree, and updates the tentative pristine hash
applyToTentativePristine :: (ApplyState q ~ Tree, Apply q, ShowPatch q)
                         => Repository rt p wR wU wT
                         -> ApplyDir
                         -> Verbosity
                         -> q wT wY
                         -> IO ()
applyToTentativePristine :: Repository rt p wR wU wT
-> ApplyDir -> Verbosity -> q wT wY -> IO ()
applyToTentativePristine Repository rt p wR wU wT
r ApplyDir
dir Verbosity
verb q wT wY
p =
  Repository rt p wR wU wT -> IO () -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT a.
Repository rt p wR wU wT -> IO a -> IO a
withRepoLocation Repository rt p wR wU wT
r (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verb Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Verbose) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Doc -> IO ()
putDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Applying to pristine..." Doc -> Doc -> Doc
<+> q wT wY -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
description q wT wY
p
    ApplyDir -> q wT wY -> IO ()
forall (p :: * -> * -> *) wX wY.
(ApplyState p ~ Tree, Apply p) =>
ApplyDir -> p wX wY -> IO ()
applyToTentativePristineCwd ApplyDir
dir q wT wY
p

applyToTentativePristineCwd :: (ApplyState p ~ Tree, Apply p)
                            => ApplyDir
                            -> p wX wY
                            -> IO ()
applyToTentativePristineCwd :: ApplyDir -> p wX wY -> IO ()
applyToTentativePristineCwd ApplyDir
dir p wX wY
p = do
    ByteString
tentativePristine <- String -> IO ByteString
gzReadFilePS String
tentativePristinePath
    -- Extract the pristine hash from the tentativePristine file, using
    -- peekPristineHash (this is valid since we normally just extract the hash from the
    -- first line of an inventory file; we can pass in a one-line file that
    -- just contains said hash).
    let tentativePristineHash :: PristineHash
tentativePristineHash = ByteString -> PristineHash
peekPristineHash ByteString
tentativePristine
    PristineHash
newPristineHash <- ApplyDir -> PristineHash -> p wX wY -> IO PristineHash
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
ApplyDir -> PristineHash -> p wX wY -> IO PristineHash
applyToHashedPristine ApplyDir
dir PristineHash
tentativePristineHash p wX wY
p
    String -> Doc -> IO ()
forall p. FilePathLike p => p -> Doc -> IO ()
writeDocBinFile String
tentativePristinePath (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$
        PristineHash -> ByteString -> Doc
pokePristineHash PristineHash
newPristineHash ByteString
tentativePristine

-- | Used by the commands dist and diff
createPartialsPristineDirectoryTree :: Repository rt p wR wU wT
                                    -> [AnchoredPath]
                                    -> FilePath
                                    -> IO ()
createPartialsPristineDirectoryTree :: Repository rt p wR wU wT -> [AnchoredPath] -> String -> IO ()
createPartialsPristineDirectoryTree Repository rt p wR wU wT
r [AnchoredPath]
paths String
target_dir
    | RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory (Repository rt p wR wU wT -> RepoFormat
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> RepoFormat
repoFormat Repository rt p wR wU wT
r) =
        do Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
target_dir
           String -> IO () -> IO ()
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory String
target_dir (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Cache -> String -> String -> IO ()
copyPartialsPristine (Repository rt p wR wU wT -> Cache
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p wR wU wT
r) (Repository rt p wR wU wT -> String
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String
repoLocation Repository rt p wR wU wT
r) String
hashedInventoryPath
    | Bool
otherwise = String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
oldRepoFailMsg
  where
    -- |copyPartialsPristine copies the pristine entries for a given list of
    -- filepaths.
    copyPartialsPristine :: Cache -> String -> String -> IO ()
copyPartialsPristine Cache
cache String
repo_loc String
inv_name = do
        ByteString
raw_inv <- String -> Cachable -> IO ByteString
fetchFilePS (String
repo_loc String -> String -> String
</> String
inv_name) Cachable
Uncachable
        Cache -> PristineHash -> [AnchoredPath] -> IO ()
copyPartialsHashed Cache
cache (ByteString -> PristineHash
peekPristineHash ByteString
raw_inv) [AnchoredPath]
paths

-- |readHashedPristineRoot attempts to read the pristine hash from the current
-- inventory, returning Nothing if it cannot do so.
readHashedPristineRoot :: Repository rt p wR wU wT -> IO (Maybe PristineHash)
readHashedPristineRoot :: Repository rt p wR wU wT -> IO (Maybe PristineHash)
readHashedPristineRoot Repository rt p wR wU wT
r = Repository rt p wR wU wT
-> IO (Maybe PristineHash) -> IO (Maybe PristineHash)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT a.
Repository rt p wR wU wT -> IO a -> IO a
withRepoLocation Repository rt p wR wU wT
r (IO (Maybe PristineHash) -> IO (Maybe PristineHash))
-> IO (Maybe PristineHash) -> IO (Maybe PristineHash)
forall a b. (a -> b) -> a -> b
$ do
    Maybe ByteString
i <- (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
gzReadFilePS String
hashedInventoryPath)
         IO (Maybe ByteString)
-> (IOException -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOException
_ :: IOException) -> Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing)
    Maybe PristineHash -> IO (Maybe PristineHash)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PristineHash -> IO (Maybe PristineHash))
-> Maybe PristineHash -> IO (Maybe PristineHash)
forall a b. (a -> b) -> a -> b
$ ByteString -> PristineHash
peekPristineHash (ByteString -> PristineHash)
-> Maybe ByteString -> Maybe PristineHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
i

-- | grab the pristine hash of _darcs/hash_inventory, and retrieve whole pristine tree,
--   possibly writing a clean working tree in the process.
createPristineDirectoryTree :: Repository rt p wR wU wT -> FilePath -> WithWorkingDir -> IO ()
createPristineDirectoryTree :: Repository rt p wR wU wT -> String -> WithWorkingDir -> IO ()
createPristineDirectoryTree Repository rt p wR wU wT
r String
reldir WithWorkingDir
wwd
    | RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory (Repository rt p wR wU wT -> RepoFormat
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> RepoFormat
repoFormat Repository rt p wR wU wT
r) =
        do Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
reldir
           String -> IO () -> IO ()
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory String
reldir (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              Cache -> String -> String -> WithWorkingDir -> IO ()
copyPristine (Repository rt p wR wU wT -> Cache
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p wR wU wT
r) (Repository rt p wR wU wT -> String
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String
repoLocation Repository rt p wR wU wT
r) String
hashedInventoryPath WithWorkingDir
wwd
    | Bool
otherwise = String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
oldRepoFailMsg

withRecorded :: Repository rt p wR wU wT
             -> ((AbsolutePath -> IO a) -> IO a)
             -> (AbsolutePath -> IO a)
             -> IO a
withRecorded :: Repository rt p wR wU wT
-> ((AbsolutePath -> IO a) -> IO a)
-> (AbsolutePath -> IO a)
-> IO a
withRecorded Repository rt p wR wU wT
repository (AbsolutePath -> IO a) -> IO a
mk_dir AbsolutePath -> IO a
f =
  (AbsolutePath -> IO a) -> IO a
mk_dir ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \AbsolutePath
d -> do
    Repository rt p wR wU wT -> String -> WithWorkingDir -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String -> WithWorkingDir -> IO ()
createPristineDirectoryTree Repository rt p wR wU wT
repository (AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
d) WithWorkingDir
WithWorkingDir
    AbsolutePath -> IO a
f AbsolutePath
d

withTentative :: Repository rt p wR wU wT
              -> ((AbsolutePath -> IO a) -> IO a)
              -> (AbsolutePath -> IO a)
              -> IO a
withTentative :: Repository rt p wR wU wT
-> ((AbsolutePath -> IO a) -> IO a)
-> (AbsolutePath -> IO a)
-> IO a
withTentative Repository rt p wR wU wT
r (AbsolutePath -> IO a) -> IO a
mk_dir AbsolutePath -> IO a
f
    | RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory (Repository rt p wR wU wT -> RepoFormat
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> RepoFormat
repoFormat Repository rt p wR wU wT
r) =
        (AbsolutePath -> IO a) -> IO a
mk_dir ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \AbsolutePath
d -> do Cache -> String -> String -> WithWorkingDir -> IO ()
copyPristine
                              (Repository rt p wR wU wT -> Cache
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p wR wU wT
r)
                              (Repository rt p wR wU wT -> String
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String
repoLocation Repository rt p wR wU wT
r)
                              (String
darcsdirString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"/tentative_pristine")
                              WithWorkingDir
WithWorkingDir
                          AbsolutePath -> IO a
f AbsolutePath
d
    | Bool
otherwise = String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
oldRepoFailMsg