{-# LANGUAGE OverloadedStrings #-}
module Darcs.Repository.Pristine
    ( applyToTentativePristine
    , readHashedPristineRoot
    , pokePristineHash
    , peekPristineHash
    , createPristineDirectoryTree
    , readPristine
    , writePristine
    , convertSizePrefixedPristine
    ) where

import Darcs.Prelude

import Control.Exception ( catch, IOException, throwIO )

import System.Directory ( withCurrentDirectory )
import System.FilePath.Posix ( (</>) )
import System.IO ( hPutStrLn, stderr )
import System.IO.Error ( catchIOError )

import Darcs.Patch ( PatchInfoAnd, RepoPatch, description )
import Darcs.Patch.Apply ( Apply(..) )
import Darcs.Patch.Invertible ( Invertible )
import Darcs.Patch.Show ( ShowPatch )
import Darcs.Patch.Witnesses.Ordered ( FL )

import Darcs.Repository.Flags ( WithWorkingDir(..) )
import Darcs.Repository.Format ( RepoProperty(HashedInventory), formatHas )
import Darcs.Repository.Inventory
import Darcs.Repository.InternalTypes
    ( Repository
    , AccessType(..)
    , SAccessType(..)
    , repoAccessType
    , repoCache
    , repoFormat
    , repoLocation
    , withRepoDir
    )
import Darcs.Repository.Old ( oldRepoFailMsg )
import Darcs.Repository.Paths
    ( hashedInventoryPath
    , tentativePristinePath
    )

import Darcs.Util.ByteString ( gzReadFilePS )
import Darcs.Util.Cache ( Cache )
import Darcs.Util.Lock ( writeDocBinFile )
import Darcs.Util.Printer ( ($$), renderString, text )
import Darcs.Util.Tree ( Tree )
import Darcs.Util.Tree.Hashed
    ( darcsAddMissingHashes
    , darcsTreeHash
    , hashedTreeIO
    , readDarcsHashed
    , readDarcsHashedNosize
    , writeDarcsHashed
    )
import Darcs.Util.Tree.Plain ( writePlainTree )
import Darcs.Util.ValidHash ( fromHash, getSize )


-- | Apply a patch to the 'Tree' identified by the given root 'PristineHash',
-- then return the root hash of the result. The 'ApplyDir' argument says
-- whether to add or remove the changes. The 'Cache' argument specifies the
-- possible locations for hashed files.
applyToHashedPristine :: (Apply p, ApplyState p ~ Tree, ShowPatch p)
                      => Cache
                      -> PristineHash
                      -> p wX wY
                      -> IO PristineHash
applyToHashedPristine :: forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree, ShowPatch p) =>
Cache -> PristineHash -> p wX wY -> IO PristineHash
applyToHashedPristine Cache
cache PristineHash
root p wX wY
patch = IO PristineHash
tryApply IO PristineHash -> (IOError -> IO PristineHash) -> IO PristineHash
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` IOError -> IO PristineHash
forall {a} {a}. Show a => a -> IO a
annotateError
  where
    tryApply :: IO PristineHash
    tryApply :: IO PristineHash
tryApply = do
        -- Read a non-size-prefixed pristine, failing if we encounter one.
        Tree IO
tree <- Cache -> PristineHash -> IO (Tree IO)
readDarcsHashedNosize Cache
cache PristineHash
root
        (()
_, Tree IO
updatedTree) <- TreeIO () -> Tree IO -> Cache -> IO ((), Tree IO)
forall a. TreeIO a -> Tree IO -> Cache -> IO (a, Tree IO)
hashedTreeIO (p wX wY -> TreeIO ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState p) m =>
p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply p wX wY
patch) Tree IO
tree Cache
cache
        PristineHash -> IO PristineHash
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PristineHash -> IO PristineHash)
-> PristineHash -> IO PristineHash
forall a b. (a -> b) -> a -> b
$ Hash -> PristineHash
forall h. ValidHash h => Hash -> h
fromHash (Hash -> PristineHash) -> Hash -> PristineHash
forall a b. (a -> b) -> a -> b
$ Tree IO -> Hash
forall (m :: * -> *). Tree m -> Hash
darcsTreeHash Tree IO
updatedTree

    annotateError :: a -> IO a
annotateError a
e =
      IOError -> IO a
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO a) -> IOError -> IO a
forall a b. (a -> b) -> a -> b
$
      String -> IOError
userError (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$
      Doc -> String
renderString (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$
      Doc
"Cannot apply patch to pristine:" Doc -> Doc -> Doc
$$ (p wX wY -> Doc
forall wX wY. p wX wY -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
description p wX wY
patch) Doc -> Doc -> Doc
$$
      Doc
"You may want to run 'darcs repair' on the repository containing this patch." Doc -> Doc -> Doc
$$
      Doc
"Reason: " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text (a -> String
forall a. Show a => a -> String
show a
e)

convertSizePrefixedPristine :: Cache -> PristineHash -> IO PristineHash
convertSizePrefixedPristine :: Cache -> PristineHash -> IO PristineHash
convertSizePrefixedPristine Cache
cache PristineHash
ph = do
  case PristineHash -> Maybe Int
forall h. ValidHash h => h -> Maybe Int
getSize PristineHash
ph of
    Maybe Int
Nothing -> PristineHash -> IO PristineHash
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PristineHash
ph
    Just Int
_ -> do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Converting pristine..."
      -- Read the old size-prefixed pristine tree
      Tree IO
old <- Cache -> PristineHash -> IO (Tree IO)
readDarcsHashed Cache
cache PristineHash
ph
      -- Write out the pristine tree as a non-size-prefixed pristine
      -- and return the new root hash.
      Tree IO -> Cache -> IO PristineHash
writeDarcsHashed Tree IO
old Cache
cache

-- | Apply an 'FL' of 'Invertible' patches tentative pristine tree, and update
-- the tentative pristine hash. The patches need to be 'Invertible' so that we
-- can use it when removing patches from the repository, too.
applyToTentativePristine :: (ApplyState p ~ Tree, RepoPatch p)
                         => Repository 'RW p wU wR
                         -> Invertible (FL (PatchInfoAnd p)) wR wY
                         -> IO ()
applyToTentativePristine :: forall (p :: * -> * -> *) wU wR wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository 'RW p wU wR
-> Invertible (FL (PatchInfoAnd p)) wR wY -> IO ()
applyToTentativePristine Repository 'RW p wU wR
r Invertible (FL (PatchInfoAnd p)) wR 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 <- Cache
-> PristineHash
-> Invertible (FL (PatchInfoAnd p)) wR wY
-> IO PristineHash
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree, ShowPatch p) =>
Cache -> PristineHash -> p wX wY -> IO PristineHash
applyToHashedPristine (Repository 'RW p wU wR -> Cache
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache Repository 'RW p wU wR
r) PristineHash
tentativePristineHash Invertible (FL (PatchInfoAnd p)) wR 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

readHashedPristineRoot :: Repository rt p wU wR -> IO PristineHash
readHashedPristineRoot :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO PristineHash
readHashedPristineRoot Repository rt p wU wR
r =
  Repository rt p wU wR -> IO PristineHash -> IO PristineHash
forall (rt :: AccessType) (p :: * -> * -> *) wU wR a.
Repository rt p wU wR -> IO a -> IO a
withRepoDir Repository rt p wU wR
r (IO PristineHash -> IO PristineHash)
-> IO PristineHash -> IO PristineHash
forall a b. (a -> b) -> a -> b
$
    case Repository rt p wU wR -> SAccessType rt
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> SAccessType rt
repoAccessType Repository rt p wU wR
r of
      SAccessType rt
SRO -> String -> IO PristineHash
getHash String
hashedInventoryPath
      SAccessType rt
SRW -> String -> IO PristineHash
getHash String
tentativePristinePath -- note the asymmetry!
  where
    getHash :: String -> IO PristineHash
getHash String
path =
      ByteString -> PristineHash
peekPristineHash (ByteString -> PristineHash) -> IO ByteString -> IO PristineHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        String -> IO ByteString
gzReadFilePS String
path IO ByteString -> (IOError -> IO ByteString) -> IO ByteString
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOError
_ :: IOException) -> String -> IO ByteString
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
oldRepoFailMsg)

-- | Write the pristine tree into a plain directory at the given path.
createPristineDirectoryTree ::
     Repository rt p wU wR -> FilePath -> WithWorkingDir -> IO ()
createPristineDirectoryTree :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String -> WithWorkingDir -> IO ()
createPristineDirectoryTree Repository rt p wU wR
r String
_ WithWorkingDir
NoWorkingDir = do
    Tree IO
tree <- Repository rt p wU wR -> IO (Tree IO)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO (Tree IO)
readPristine Repository rt p wU wR
r
    -- evaluate the tree to force copying of pristine files
    Tree IO
_ <- Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
darcsAddMissingHashes Tree IO
tree
    () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
createPristineDirectoryTree Repository rt p wU wR
r String
dir WithWorkingDir
WithWorkingDir = do
    Tree IO
tree <- Repository rt p wU wR -> IO (Tree IO)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO (Tree IO)
readPristine Repository rt p wU wR
r
    Tree IO -> String -> IO ()
writePlainTree Tree IO
tree String
dir

-- | Obtains a Tree corresponding to the "recorded" state of the repository:
-- this is the same as the pristine cache, which is the same as the result of
-- applying all the repository's patches to an empty directory.
readPristine :: Repository rt p wU wR -> IO (Tree IO)
readPristine :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO (Tree IO)
readPristine Repository rt p wU wR
repo
  | RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory (Repository rt p wU wR -> RepoFormat
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> RepoFormat
repoFormat Repository rt p wU wR
repo) =
    case Repository rt p wU wR -> SAccessType rt
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> SAccessType rt
repoAccessType Repository rt p wU wR
repo of
      SAccessType rt
SRO -> do
        ByteString
inv <- String -> IO ByteString
gzReadFilePS (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Repository rt p wU wR -> String
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String
repoLocation Repository rt p wU wR
repo String -> String -> String
</> String
hashedInventoryPath
        let root :: PristineHash
root = ByteString -> PristineHash
peekPristineHash ByteString
inv
        Cache -> PristineHash -> IO (Tree IO)
readDarcsHashed (Repository rt p wU wR -> Cache
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache Repository rt p wU wR
repo) PristineHash
root
      SAccessType rt
SRW -> do
        PristineHash
hash <-
          ByteString -> PristineHash
peekPristineHash (ByteString -> PristineHash) -> IO ByteString -> IO PristineHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            String -> IO ByteString
gzReadFilePS (Repository rt p wU wR -> String
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String
repoLocation Repository rt p wU wR
repo String -> String -> String
</> String
tentativePristinePath)
        Cache -> PristineHash -> IO (Tree IO)
readDarcsHashedNosize (Repository rt p wU wR -> Cache
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache Repository rt p wU wR
repo) PristineHash
hash
  | Bool
otherwise = String -> IO (Tree IO)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
oldRepoFailMsg

-- | Replace the existing pristine with a new one (loaded up in a Tree object).
-- Warning: If @rt ~ 'RO@ this overwrites the recorded state, use only when
-- creating a new repo!
writePristine :: Repository rt p wU wR -> Tree IO -> IO PristineHash
writePristine :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Tree IO -> IO PristineHash
writePristine Repository rt p wU wR
repo Tree IO
tree =
  String -> IO PristineHash -> IO PristineHash
forall a. String -> IO a -> IO a
withCurrentDirectory (Repository rt p wU wR -> String
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String
repoLocation Repository rt p wU wR
repo) (IO PristineHash -> IO PristineHash)
-> IO PristineHash -> IO PristineHash
forall a b. (a -> b) -> a -> b
$ do
    Tree IO
tree' <- Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
darcsAddMissingHashes Tree IO
tree
    PristineHash
root <- Tree IO -> Cache -> IO PristineHash
writeDarcsHashed Tree IO
tree' (Repository rt p wU wR -> Cache
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache Repository rt p wU wR
repo)
    -- now update the current pristine hash
    case Repository rt p wU wR -> SAccessType rt
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> SAccessType rt
repoAccessType Repository rt p wU wR
repo of
      SAccessType rt
SRO -> PristineHash -> String -> IO PristineHash
putHash PristineHash
root String
hashedInventoryPath
      SAccessType rt
SRW -> PristineHash -> String -> IO PristineHash
putHash PristineHash
root String
tentativePristinePath -- note the asymmetry!
  where
    putHash :: PristineHash -> String -> IO PristineHash
putHash PristineHash
root String
path = do
      ByteString
content <- String -> IO ByteString
gzReadFilePS String
path
      String -> Doc -> IO ()
forall p. FilePathLike p => p -> Doc -> IO ()
writeDocBinFile String
path (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ PristineHash -> ByteString -> Doc
pokePristineHash PristineHash
root ByteString
content
      PristineHash -> IO PristineHash
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PristineHash
root