module Darcs.Repository.Clone
    ( cloneRepository
    , replacePristine
    ) where

import Darcs.Prelude

import Control.Exception ( catch, SomeException )
import Control.Monad ( unless, void, when )
import qualified Data.ByteString.Char8 as BC
import Data.List( intercalate )
import Data.Maybe( catMaybes )
import System.FilePath( (</>) )
import System.Directory
    ( removeFile
    , listDirectory
    )
import System.IO ( stderr )

import Darcs.Repository.Create
    ( EmptyRepository(..)
    , createRepository
    , writePristine
    )
import Darcs.Repository.State ( invalidateIndex )
import Darcs.Repository.Identify ( identifyRepositoryFor, ReadingOrWriting(..) )
import Darcs.Repository.Pristine
    ( ApplyDir(..)
    , applyToTentativePristineCwd
    , createPristineDirectoryTree
    )
import Darcs.Repository.Hashed
    ( copyHashedInventory
    , finalizeRepositoryChanges
    , finalizeTentativeChanges
    , readRepo
    , revertRepositoryChanges
    , revertTentativeChanges
    , tentativelyRemovePatches
    , writeTentativeInventory
    )
import Darcs.Repository.Working
    ( setScriptsExecutable
    , setScriptsExecutablePatches )
import Darcs.Repository.InternalTypes
    ( Repository
    , repoLocation
    , repoFormat
    , repoCache
    , modifyCache
    )
import Darcs.Repository.Job ( withUMaskFlag )
import Darcs.Repository.Cache
    ( unionRemoteCaches
    , unionCaches
    , fetchFileUsingCache
    , speculateFileUsingCache
    , HashedDir(..)
    , repo2cache
    , dropNonRepos
    )

import Darcs.Repository.ApplyPatches ( runDefault )
import Darcs.Repository.Inventory
    ( peekPristineHash
    , getValidHash
    )
import Darcs.Repository.Format
    ( RepoProperty ( HashedInventory, Darcs2, Darcs3 )
    , RepoFormat
    , formatHas
    , readProblem
    )
import Darcs.Repository.Prefs ( addRepoSource, deleteSources )
import Darcs.Repository.Match ( getOnePatchset )
import Darcs.Util.External
    ( copyFileOrUrl
    , Cachable(..)
    , gzFetchFilePS
    )
import Darcs.Repository.PatchIndex
    ( doesPatchIndexExist
    , createPIWithInterrupt
    )
import Darcs.Repository.Packs
    ( fetchAndUnpackBasic
    , fetchAndUnpackPatches
    , packsDir
    )
import Darcs.Repository.Resolution
    ( StandardResolution(..)
    , patchsetConflictResolutions
    , announceConflicts
    )
import Darcs.Repository.Working ( applyToWorking )
import Darcs.Util.Lock ( appendTextFile, withNewDirectory )
import Darcs.Repository.Flags
    ( UpdatePending(..)
    , UseCache(..)
    , RemoteDarcs (..)
    , remoteDarcs
    , Compression (..)
    , CloneKind (..)
    , Verbosity (..)
    , DryRun (..)
    , UMask (..)
    , SetScriptsExecutable (..)
    , RemoteRepos (..)
    , SetDefault (..)
    , InheritDefault (..)
    , WithWorkingDir (..)
    , ForgetParent (..)
    , WithPatchIndex (..)
    , PatchFormat (..)
    , AllowConflicts(..)
    , ExternalMerge(..)
    )

import Darcs.Patch ( RepoPatch, IsRepoType, description )
import Darcs.Patch.Depends ( findUncommon )
import Darcs.Patch.Set ( patchSet2RL
                       , patchSet2FL
                       , progressPatchSet
                       )
import Darcs.Patch.Match ( MatchFlag(..), patchSetMatch )
import Darcs.Patch.Progress ( progressRLShowTags, progressFL )
import Darcs.Patch.Apply ( Apply(..) )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..)
    , RL(..)
    , (:\/:)(..)
    , lengthFL
    , bunchFL
    , mapFL
    , mapRL
    , lengthRL
    , nullFL
    )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, extractHash )

import Darcs.Util.Tree( Tree, emptyTree )

import Darcs.Util.Download ( maxPipelineLength )
import Darcs.Util.Exception ( catchall )
import Darcs.Util.English ( englishNum, Noun(..) )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.URL ( isValidLocalPath )
import Darcs.Util.SignalHandler ( catchInterrupt, withSignalsBlocked )
import Darcs.Util.Printer ( Doc, ($$), hPutDocLn, hsep, putDocLn, text )
import Darcs.Util.Printer.Color ( unsafeRenderStringColored )
import Darcs.Util.Progress
    ( debugMessage
    , tediousSize
    , beginTedious
    , endTedious
    )

joinUrl :: [String] -> String
joinUrl :: [String] -> String
joinUrl = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/"

cloneRepository ::
    String    -- origin repository path
    -> String -- new repository name (for relative path)
    -> Verbosity -> UseCache
    -> CloneKind
    -> UMask -> RemoteDarcs
    -> SetScriptsExecutable
    -> RemoteRepos
    -> SetDefault
    -> InheritDefault
    -> [MatchFlag]
    -> RepoFormat
    -> WithWorkingDir
    -> WithPatchIndex   -- use patch index
    -> Bool   -- use packs
    -> ForgetParent
    -> IO ()
cloneRepository :: String
-> String
-> Verbosity
-> UseCache
-> CloneKind
-> UMask
-> RemoteDarcs
-> SetScriptsExecutable
-> RemoteRepos
-> SetDefault
-> InheritDefault
-> [MatchFlag]
-> RepoFormat
-> WithWorkingDir
-> WithPatchIndex
-> Bool
-> ForgetParent
-> IO ()
cloneRepository String
repourl String
mysimplename Verbosity
v UseCache
useCache CloneKind
cloneKind UMask
um RemoteDarcs
rdarcs SetScriptsExecutable
sse RemoteRepos
remoteRepos
                SetDefault
setDefault InheritDefault
inheritDefault [MatchFlag]
matchFlags RepoFormat
rfsource WithWorkingDir
withWorkingDir
                WithPatchIndex
usePatchIndex Bool
usePacks ForgetParent
forget =
  UMask -> IO () -> IO ()
forall a. UMask -> IO a -> IO a
withUMaskFlag UMask
um (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO () -> IO ()
withNewDirectory String
mysimplename (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      let patchfmt :: PatchFormat
patchfmt
            | RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
Darcs3 RepoFormat
rfsource = PatchFormat
PatchFormat3
            | RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
Darcs2 RepoFormat
rfsource = PatchFormat
PatchFormat2
            | Bool
otherwise                 = PatchFormat
PatchFormat1
      EmptyRepository Repository ('RepoType 'NoRebase) p Origin Origin Origin
_toRepo <-
        PatchFormat
-> WithWorkingDir
-> WithPatchIndex
-> UseCache
-> IO EmptyRepository
createRepository PatchFormat
patchfmt WithWorkingDir
withWorkingDir
          (if CloneKind
cloneKind CloneKind -> CloneKind -> Bool
forall a. Eq a => a -> a -> Bool
== CloneKind
LazyClone then WithPatchIndex
NoPatchIndex else WithPatchIndex
usePatchIndex) UseCache
useCache
      String -> IO ()
debugMessage String
"Finished initializing new repository."
      String
-> DryRun
-> RemoteRepos
-> SetDefault
-> InheritDefault
-> Bool
-> IO ()
addRepoSource String
repourl DryRun
NoDryRun RemoteRepos
remoteRepos SetDefault
setDefault InheritDefault
inheritDefault Bool
False

      String -> IO ()
debugMessage String
"Identifying and copying repository..."
      Repository ('RepoType 'NoRebase) p Origin Origin Origin
fromRepo <- ReadingOrWriting
-> Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> UseCache
-> String
-> IO (Repository ('RepoType 'NoRebase) p Origin Origin Origin)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT vR vU vT.
ReadingOrWriting
-> Repository rt p wR wU wT
-> UseCache
-> String
-> IO (Repository rt p vR vU vT)
identifyRepositoryFor ReadingOrWriting
Reading Repository ('RepoType 'NoRebase) p Origin Origin Origin
_toRepo UseCache
useCache String
repourl
      let fromLoc :: String
fromLoc = Repository ('RepoType 'NoRebase) p Origin Origin Origin -> String
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String
repoLocation Repository ('RepoType 'NoRebase) p Origin Origin Origin
fromRepo
      let rffrom :: RepoFormat
rffrom = Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> RepoFormat
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> RepoFormat
repoFormat Repository ('RepoType 'NoRebase) p Origin Origin Origin
fromRepo
      case RepoFormat -> Maybe String
readProblem RepoFormat
rffrom of
        Just String
e ->  String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Incompatibility with repository " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fromLoc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e
        Maybe String
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      String -> IO ()
debugMessage String
"Copying prefs..."
      String -> String -> String -> Cachable -> IO ()
copyFileOrUrl (RemoteDarcs -> String
remoteDarcs RemoteDarcs
rdarcs)
        ([String] -> String
joinUrl [String
fromLoc, String
darcsdir, String
"prefs", String
"prefs"])
        (String
darcsdir String -> String -> String
</> String
"prefs/prefs") (CInt -> Cachable
MaxAge CInt
600) IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      String -> IO ()
debugMessage String
"Copying sources..."
      Cache
cache <- Cache -> Cache -> String -> IO Cache
unionRemoteCaches (Repository ('RepoType 'NoRebase) p Origin Origin Origin -> Cache
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository ('RepoType 'NoRebase) p Origin Origin Origin
_toRepo) (Repository ('RepoType 'NoRebase) p Origin Origin Origin -> Cache
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository ('RepoType 'NoRebase) p Origin Origin Origin
fromRepo) String
fromLoc
      String -> String -> IO ()
forall p. FilePathLike p => p -> String -> IO ()
appendTextFile (String
darcsdir String -> String -> String
</> String
"prefs/sources")
                     (Cache -> String
forall a. Show a => a -> String
show (Cache -> String) -> Cache -> String
forall a b. (a -> b) -> a -> b
$ String -> Cache
repo2cache String
fromLoc Cache -> Cache -> Cache
`unionCaches` Cache -> Cache
dropNonRepos Cache
cache)
      String -> IO ()
debugMessage String
"Done copying and filtering sources."
      -- put remote source last
      Repository ('RepoType 'NoRebase) p Origin Origin Origin
_toRepo <- Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> IO (Repository ('RepoType 'NoRebase) p Origin Origin Origin)
forall (m :: * -> *) a. Monad m => a -> m a
return (Repository ('RepoType 'NoRebase) p Origin Origin Origin
 -> IO (Repository ('RepoType 'NoRebase) p Origin Origin Origin))
-> Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> IO (Repository ('RepoType 'NoRebase) p Origin Origin Origin)
forall a b. (a -> b) -> a -> b
$
        (Cache -> Cache)
-> Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> Repository ('RepoType 'NoRebase) p Origin Origin Origin
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(Cache -> Cache)
-> Repository rt p wR wU wT -> Repository rt p wR wU wT
modifyCache (Cache -> Cache -> Cache
forall a b. a -> b -> a
const (Cache -> Cache -> Cache) -> Cache -> Cache -> Cache
forall a b. (a -> b) -> a -> b
$ Cache
cache Cache -> Cache -> Cache
`unionCaches` String -> Cache
repo2cache String
fromLoc) Repository ('RepoType 'NoRebase) p Origin Origin Origin
_toRepo
      if RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory RepoFormat
rffrom then do
       String -> IO ()
debugMessage String
"Copying basic repository (hashed_inventory and pristine)"
       if Bool
usePacks Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isValidLocalPath) String
fromLoc
         then Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> Verbosity
-> RemoteDarcs
-> WithWorkingDir
-> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT
-> Repository rt p wR wU wT
-> Verbosity
-> RemoteDarcs
-> WithWorkingDir
-> IO ()
copyBasicRepoPacked    Repository ('RepoType 'NoRebase) p Origin Origin Origin
fromRepo Repository ('RepoType 'NoRebase) p Origin Origin Origin
_toRepo Verbosity
v RemoteDarcs
rdarcs WithWorkingDir
withWorkingDir
         else Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> Verbosity
-> RemoteDarcs
-> WithWorkingDir
-> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT
-> Repository rt p wR wU wT
-> Verbosity
-> RemoteDarcs
-> WithWorkingDir
-> IO ()
copyBasicRepoNotPacked Repository ('RepoType 'NoRebase) p Origin Origin Origin
fromRepo Repository ('RepoType 'NoRebase) p Origin Origin Origin
_toRepo Verbosity
v RemoteDarcs
rdarcs WithWorkingDir
withWorkingDir
       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CloneKind
cloneKind CloneKind -> CloneKind -> Bool
forall a. Eq a => a -> a -> Bool
/= CloneKind
LazyClone) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CloneKind
cloneKind CloneKind -> CloneKind -> Bool
forall a. Eq a => a -> a -> Bool
/= CloneKind
CompleteClone) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
           Verbosity -> Doc -> IO ()
putInfo Verbosity
v (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Copying patches, to get lazy repository hit ctrl-C..."
         String -> IO ()
debugMessage String
"Copying complete repository (inventories and patches)"
         if Bool
usePacks Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isValidLocalPath) String
fromLoc
           then Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> Verbosity
-> CloneKind
-> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> Repository rt p wR wU wT -> Verbosity -> CloneKind -> IO ()
copyCompleteRepoPacked    Repository ('RepoType 'NoRebase) p Origin Origin Origin
fromRepo Repository ('RepoType 'NoRebase) p Origin Origin Origin
_toRepo Verbosity
v CloneKind
cloneKind
           else Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> Verbosity
-> CloneKind
-> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> Repository rt p wR wU wT -> Verbosity -> CloneKind -> IO ()
copyCompleteRepoNotPacked Repository ('RepoType 'NoRebase) p Origin Origin Origin
fromRepo Repository ('RepoType 'NoRebase) p Origin Origin Origin
_toRepo Verbosity
v CloneKind
cloneKind
      else
       -- old-fashioned repositories are cloned diferently since
       -- we need to copy all patches first and then build pristine
       Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> Verbosity
-> WithWorkingDir
-> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> Repository rt p wR wU wT -> Verbosity -> WithWorkingDir -> IO ()
copyRepoOldFashioned Repository ('RepoType 'NoRebase) p Origin Origin Origin
fromRepo Repository ('RepoType 'NoRebase) p Origin Origin Origin
_toRepo Verbosity
v WithWorkingDir
withWorkingDir
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SetScriptsExecutable
sse SetScriptsExecutable -> SetScriptsExecutable -> Bool
forall a. Eq a => a -> a -> Bool
== SetScriptsExecutable
YesSetScriptsExecutable) IO ()
setScriptsExecutable
      case [MatchFlag] -> Maybe PatchSetMatch
patchSetMatch [MatchFlag]
matchFlags of
       Maybe PatchSetMatch
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       Just PatchSetMatch
psm -> do
        Verbosity -> Doc -> IO ()
putInfo Verbosity
v (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Going to specified version..."
        -- the following is necessary to be able to read _toRepo's patches
        Repository ('RepoType 'NoRebase) p Origin Origin Origin
_toRepo <- Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> UpdatePending
-> IO (Repository ('RepoType 'NoRebase) p Origin Origin Origin)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT
-> UpdatePending -> IO (Repository rt p wR wU wR)
revertRepositoryChanges Repository ('RepoType 'NoRebase) p Origin Origin Origin
_toRepo UpdatePending
NoUpdatePending
        PatchSet ('RepoType 'NoRebase) p Origin Origin
patches <- Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> IO (PatchSet ('RepoType 'NoRebase) p Origin Origin)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository ('RepoType 'NoRebase) p Origin Origin Origin
_toRepo
        Sealed PatchSet ('RepoType 'NoRebase) p Origin wX
context <- Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> PatchSetMatch
-> IO (Sealed (PatchSet ('RepoType 'NoRebase) p Origin))
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wR
-> PatchSetMatch -> IO (SealedPatchSet rt p Origin)
getOnePatchset Repository ('RepoType 'NoRebase) p Origin Origin Origin
_toRepo PatchSetMatch
psm
        FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ Origin
to_remove :\/: FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ wX
only_in_context <- (:\/:)
  (FL (PatchInfoAnd ('RepoType 'NoRebase) p))
  (FL (PatchInfoAnd ('RepoType 'NoRebase) p))
  Origin
  wX
-> IO
     ((:\/:)
        (FL (PatchInfoAnd ('RepoType 'NoRebase) p))
        (FL (PatchInfoAnd ('RepoType 'NoRebase) p))
        Origin
        wX)
forall (m :: * -> *) a. Monad m => a -> m a
return ((:\/:)
   (FL (PatchInfoAnd ('RepoType 'NoRebase) p))
   (FL (PatchInfoAnd ('RepoType 'NoRebase) p))
   Origin
   wX
 -> IO
      ((:\/:)
         (FL (PatchInfoAnd ('RepoType 'NoRebase) p))
         (FL (PatchInfoAnd ('RepoType 'NoRebase) p))
         Origin
         wX))
-> (:\/:)
     (FL (PatchInfoAnd ('RepoType 'NoRebase) p))
     (FL (PatchInfoAnd ('RepoType 'NoRebase) p))
     Origin
     wX
-> IO
     ((:\/:)
        (FL (PatchInfoAnd ('RepoType 'NoRebase) p))
        (FL (PatchInfoAnd ('RepoType 'NoRebase) p))
        Origin
        wX)
forall a b. (a -> b) -> a -> b
$ PatchSet ('RepoType 'NoRebase) p Origin Origin
-> PatchSet ('RepoType 'NoRebase) p Origin wX
-> (:\/:)
     (FL (PatchInfoAnd ('RepoType 'NoRebase) p))
     (FL (PatchInfoAnd ('RepoType 'NoRebase) p))
     Origin
     wX
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
Commute p =>
PatchSet rt p Origin wX
-> PatchSet rt p Origin wY
-> (:\/:) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wX wY
findUncommon PatchSet ('RepoType 'NoRebase) p Origin Origin
patches PatchSet ('RepoType 'NoRebase) p Origin wX
context
        case FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ wX
only_in_context of
          FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ wX
NilFL -> do
            let num_to_remove :: Int
num_to_remove = FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ Origin -> Int
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ Origin
to_remove
            Verbosity -> Doc -> IO ()
putInfo Verbosity
v (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
              [ String
"Unapplying"
              , Int -> String
forall a. Show a => a -> String
show Int
num_to_remove
              , Int -> Noun -> String -> String
forall n. Countable n => Int -> n -> String -> String
englishNum Int
num_to_remove (String -> Noun
Noun String
"patch") String
""
              ]
            Repository ('RepoType 'NoRebase) p Origin Origin Origin -> IO ()
forall t. t -> IO ()
invalidateIndex Repository ('RepoType 'NoRebase) p Origin Origin Origin
_toRepo
            Repository ('RepoType 'NoRebase) p Origin Origin wZ
_toRepo <-
              Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> Compression
-> UpdatePending
-> FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ Origin
-> IO (Repository ('RepoType 'NoRebase) p Origin Origin wZ)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wX.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> Compression
-> UpdatePending
-> FL (PatchInfoAnd rt p) wX wT
-> IO (Repository rt p wR wU wX)
tentativelyRemovePatches Repository ('RepoType 'NoRebase) p Origin Origin Origin
_toRepo Compression
GzipCompression UpdatePending
NoUpdatePending FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ Origin
to_remove
            Repository ('RepoType 'NoRebase) p wZ Origin wZ
_toRepo <-
              Repository ('RepoType 'NoRebase) p Origin Origin wZ
-> UpdatePending
-> Compression
-> IO (Repository ('RepoType 'NoRebase) p wZ Origin wZ)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdatePending -> Compression -> IO (Repository rt p wT wU wT)
finalizeRepositoryChanges Repository ('RepoType 'NoRebase) p Origin Origin wZ
_toRepo UpdatePending
NoUpdatePending Compression
GzipCompression
            DefaultIO () -> IO ()
forall a. DefaultIO a -> IO a
runDefault (FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ Origin -> DefaultIO ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
unapply FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ Origin
to_remove) IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) ->
                String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Couldn't undo patch in working tree.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SetScriptsExecutable
sse SetScriptsExecutable -> SetScriptsExecutable -> Bool
forall a. Eq a => a -> a -> Bool
== SetScriptsExecutable
YesSetScriptsExecutable) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ Origin -> IO ()
forall (p :: * -> * -> *) wX wY. PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ Origin
to_remove
          FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ wX
_ ->
            -- This can only happen if the user supplied a context file that
            -- doesn't specify a subset of the remote repo.
            String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> String
unsafeRenderStringColored
              (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Missing patches from context:"
              Doc -> Doc -> Doc
$$ FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ wX -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
description FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ wX
only_in_context
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ForgetParent
forget ForgetParent -> ForgetParent -> Bool
forall a. Eq a => a -> a -> Bool
== ForgetParent
YesForgetParent) IO ()
deleteSources
      -- check for unresolved conflicts
      PatchSet ('RepoType 'NoRebase) p Origin Origin
patches <- Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> IO (PatchSet ('RepoType 'NoRebase) p Origin Origin)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository ('RepoType 'NoRebase) p Origin Origin Origin
_toRepo
      let conflicts :: StandardResolution (PrimOf p) Origin
conflicts = PatchSet ('RepoType 'NoRebase) p Origin Origin
-> StandardResolution (PrimOf p) Origin
forall (p :: * -> * -> *) (rt :: RepoType) wX.
RepoPatch p =>
PatchSet rt p Origin wX -> StandardResolution (PrimOf p) wX
patchsetConflictResolutions PatchSet ('RepoType 'NoRebase) p Origin Origin
patches
      Bool
_ <- String
-> AllowConflicts
-> ExternalMerge
-> StandardResolution (PrimOf p) Origin
-> IO Bool
forall (prim :: * -> * -> *) wX.
PrimPatch prim =>
String
-> AllowConflicts
-> ExternalMerge
-> StandardResolution prim wX
-> IO Bool
announceConflicts String
"clone" AllowConflicts
YesAllowConflictsAndMark ExternalMerge
NoExternalMerge StandardResolution (PrimOf p) Origin
conflicts
      Sealed FL (PrimOf p) Origin wX
mangled_res <- Sealed (FL (PrimOf p) Origin) -> IO (Sealed (FL (PrimOf p) Origin))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PrimOf p) Origin)
 -> IO (Sealed (FL (PrimOf p) Origin)))
-> Sealed (FL (PrimOf p) Origin)
-> IO (Sealed (FL (PrimOf p) Origin))
forall a b. (a -> b) -> a -> b
$ StandardResolution (PrimOf p) Origin
-> Sealed (FL (PrimOf p) Origin)
forall (prim :: * -> * -> *) wX.
StandardResolution prim wX -> Mangled prim wX
mangled StandardResolution (PrimOf p) Origin
conflicts
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FL (PrimOf p) Origin wX -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PrimOf p) Origin wX
mangled_res) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        IO () -> IO ()
forall a. IO a -> IO a
withSignalsBlocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (Repository ('RepoType 'NoRebase) p Origin wX Origin) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Repository ('RepoType 'NoRebase) p Origin wX Origin) -> IO ())
-> IO (Repository ('RepoType 'NoRebase) p Origin wX Origin)
-> IO ()
forall a b. (a -> b) -> a -> b
$ Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> Verbosity
-> FL (PrimOf p) Origin wX
-> IO (Repository ('RepoType 'NoRebase) p Origin wX Origin)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wR wU wT
-> Verbosity
-> FL (PrimOf p) wU wY
-> IO (Repository rt p wR wY wT)
applyToWorking Repository ('RepoType 'NoRebase) p Origin Origin Origin
_toRepo Verbosity
v FL (PrimOf p) Origin wX
mangled_res

putInfo :: Verbosity -> Doc -> IO ()
putInfo :: Verbosity -> Doc -> IO ()
putInfo Verbosity
Quiet Doc
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
putInfo Verbosity
_ Doc
d = Handle -> Doc -> IO ()
hPutDocLn Handle
stderr Doc
d

putVerbose :: Verbosity -> Doc -> IO ()
putVerbose :: Verbosity -> Doc -> IO ()
putVerbose Verbosity
Verbose Doc
d = Doc -> IO ()
putDocLn Doc
d
putVerbose Verbosity
_ Doc
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

copyBasicRepoNotPacked  :: forall rt p wR wU wT.
                           Repository rt p wR wU wT -- remote
                        -> Repository rt p wR wU wT -- existing empty local
                        -> Verbosity
                        -> RemoteDarcs
                        -> WithWorkingDir
                        -> IO ()
copyBasicRepoNotPacked :: Repository rt p wR wU wT
-> Repository rt p wR wU wT
-> Verbosity
-> RemoteDarcs
-> WithWorkingDir
-> IO ()
copyBasicRepoNotPacked Repository rt p wR wU wT
fromRepo Repository rt p wR wU wT
toRepo Verbosity
verb RemoteDarcs
rdarcs WithWorkingDir
withWorkingDir = do
  Verbosity -> Doc -> IO ()
putVerbose Verbosity
verb (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Copying hashed inventory from remote repo..."
  Repository rt p wR wU wT -> RemoteDarcs -> String -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> RemoteDarcs -> String -> IO ()
copyHashedInventory Repository rt p wR wU wT
toRepo RemoteDarcs
rdarcs (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
fromRepo)
  Verbosity -> Doc -> IO ()
putVerbose Verbosity
verb (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Writing pristine and working tree contents..."
  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
toRepo String
"." WithWorkingDir
withWorkingDir

copyCompleteRepoNotPacked :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                        => Repository rt p wR wU wT -- remote
                        -> Repository rt p wR wU wT -- existing basic local
                        -> Verbosity
                        -> CloneKind
                        -> IO ()
copyCompleteRepoNotPacked :: Repository rt p wR wU wT
-> Repository rt p wR wU wT -> Verbosity -> CloneKind -> IO ()
copyCompleteRepoNotPacked Repository rt p wR wU wT
_ Repository rt p wR wU wT
toRepo Verbosity
verb CloneKind
cloneKind = do
       let cleanup :: IO ()
cleanup = Verbosity -> Doc -> IO ()
putInfo Verbosity
verb (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Using lazy repository."
       CloneKind -> IO () -> IO () -> IO ()
allowCtrlC CloneKind
cloneKind IO ()
cleanup (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
         Repository rt p wR wU wT -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO ()
fetchPatchesIfNecessary Repository rt p wR wU wT
toRepo
         Bool
pi <- String -> IO Bool
doesPatchIndexExist (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
toRepo)
         PatchSet rt p Origin wR
ps <- Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wT
toRepo
         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
pi (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Repository rt p wR wU wT -> PatchSet rt p Origin wR -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> PatchSet rt p Origin wR -> IO ()
createPIWithInterrupt Repository rt p wR wU wT
toRepo PatchSet rt p Origin wR
ps

copyBasicRepoPacked ::
  forall rt p wR wU wT.
     Repository rt p wR wU wT -- remote
  -> Repository rt p wR wU wT -- existing empty local repository
  -> Verbosity
  -> RemoteDarcs
  -> WithWorkingDir
  -> IO ()
copyBasicRepoPacked :: Repository rt p wR wU wT
-> Repository rt p wR wU wT
-> Verbosity
-> RemoteDarcs
-> WithWorkingDir
-> IO ()
copyBasicRepoPacked Repository rt p wR wU wT
fromRepo Repository rt p wR wU wT
toRepo Verbosity
verb RemoteDarcs
rdarcs WithWorkingDir
withWorkingDir =
  do let fromLoc :: String
fromLoc = 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
fromRepo
     let hashURL :: String
hashURL = [String] -> String
joinUrl [String
fromLoc, String
darcsdir, String
packsDir, String
"pristine"]
     Maybe ByteString
mPackHash <- (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 -> Cachable -> IO ByteString
gzFetchFilePS String
hashURL Cachable
Uncachable) IO (Maybe ByteString)
-> IO (Maybe ByteString) -> IO (Maybe ByteString)
forall a. IO a -> IO a -> IO a
`catchall` (Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing)
     let hiURL :: String
hiURL = [String] -> String
joinUrl [String
fromLoc, String
darcsdir, String
"hashed_inventory"]
     ByteString
i <- String -> Cachable -> IO ByteString
gzFetchFilePS String
hiURL Cachable
Uncachable
     let currentHash :: ByteString
currentHash = 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
i
     let copyNormally :: IO ()
copyNormally = Repository rt p wR wU wT
-> Repository rt p wR wU wT
-> Verbosity
-> RemoteDarcs
-> WithWorkingDir
-> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT
-> Repository rt p wR wU wT
-> Verbosity
-> RemoteDarcs
-> WithWorkingDir
-> IO ()
copyBasicRepoNotPacked Repository rt p wR wU wT
fromRepo Repository rt p wR wU wT
toRepo Verbosity
verb RemoteDarcs
rdarcs WithWorkingDir
withWorkingDir
     case Maybe ByteString
mPackHash of
      Just ByteString
packHash | ByteString
packHash ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
currentHash
              -> ( do Repository rt p wR wU wT
-> Repository rt p wR wU wT -> Verbosity -> WithWorkingDir -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT
-> Repository rt p wR wU wT -> Verbosity -> WithWorkingDir -> IO ()
copyBasicRepoPacked2 Repository rt p wR wU wT
fromRepo Repository rt p wR wU wT
toRepo Verbosity
verb WithWorkingDir
withWorkingDir
                      -- need to obtain a fresh copy of hashed_inventory as reference
                      Verbosity -> Doc -> IO ()
putVerbose Verbosity
verb (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Copying hashed inventory from remote repo..."
                      Repository rt p wR wU wT -> RemoteDarcs -> String -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> RemoteDarcs -> String -> IO ()
copyHashedInventory Repository rt p wR wU wT
toRepo RemoteDarcs
rdarcs (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
fromRepo)
                   IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) ->
                               do String -> IO ()
putStrLn (String
"Exception while getting basic pack:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
                                  IO ()
copyNormally)
      Maybe ByteString
_       -> do Verbosity -> Doc -> IO ()
putVerbose Verbosity
verb (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$
                      String -> Doc
text String
"Remote repo has no basic pack or outdated basic pack, copying normally."
                    IO ()
copyNormally

copyBasicRepoPacked2 ::
  forall rt p wR wU wT.
     Repository rt p wR wU wT -- remote
  -> Repository rt p wR wU wT -- existing empty local repository
  -> Verbosity
  -> WithWorkingDir
  -> IO ()
copyBasicRepoPacked2 :: Repository rt p wR wU wT
-> Repository rt p wR wU wT -> Verbosity -> WithWorkingDir -> IO ()
copyBasicRepoPacked2 Repository rt p wR wU wT
fromRepo Repository rt p wR wU wT
toRepo Verbosity
verb WithWorkingDir
withWorkingDir = do
  Verbosity -> Doc -> IO ()
putVerbose Verbosity
verb (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Cloning packed basic repository."
  -- unpack inventory & pristine cache
  String -> IO ()
cleanDir (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
darcsdir String -> String -> String
</> String
"pristine.hashed"
  String -> IO ()
removeFile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
darcsdir String -> String -> String
</> String
"hashed_inventory"
  Cache -> String -> IO ()
fetchAndUnpackBasic (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
toRepo) (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
fromRepo)
  Verbosity -> Doc -> IO ()
putInfo Verbosity
verb (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Done fetching and unpacking basic pack."
  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
toRepo String
"." WithWorkingDir
withWorkingDir

copyCompleteRepoPacked ::
  forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
  => Repository rt p wR wU wT -- remote
  -> Repository rt p wR wU wT -- existing basic local repository
  -> Verbosity
  -> CloneKind
  -> IO ()
copyCompleteRepoPacked :: Repository rt p wR wU wT
-> Repository rt p wR wU wT -> Verbosity -> CloneKind -> IO ()
copyCompleteRepoPacked Repository rt p wR wU wT
from Repository rt p wR wU wT
to Verbosity
verb CloneKind
cloneKind =
    Repository rt p wR wU wT
-> Repository rt p wR wU wT -> Verbosity -> CloneKind -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> Repository rt p wR wU wT -> Verbosity -> CloneKind -> IO ()
copyCompleteRepoPacked2 Repository rt p wR wU wT
from Repository rt p wR wU wT
to Verbosity
verb CloneKind
cloneKind
  IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch`
    \(SomeException
e :: SomeException) -> do
      String -> IO ()
putStrLn (String
"Exception while getting patches pack:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
      Verbosity -> Doc -> IO ()
putVerbose Verbosity
verb (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Problem while copying patches pack, copying normally."
      Repository rt p wR wU wT
-> Repository rt p wR wU wT -> Verbosity -> CloneKind -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> Repository rt p wR wU wT -> Verbosity -> CloneKind -> IO ()
copyCompleteRepoNotPacked Repository rt p wR wU wT
from Repository rt p wR wU wT
to Verbosity
verb CloneKind
cloneKind

copyCompleteRepoPacked2 ::
  forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
  => Repository rt p wR wU wT
  -> Repository rt p wR wU wT
  -> Verbosity
  -> CloneKind
  -> IO ()
copyCompleteRepoPacked2 :: Repository rt p wR wU wT
-> Repository rt p wR wU wT -> Verbosity -> CloneKind -> IO ()
copyCompleteRepoPacked2 Repository rt p wR wU wT
fromRepo Repository rt p wR wU wT
toRepo Verbosity
verb CloneKind
cloneKind = do
  PatchSet rt p Origin wR
us <- Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wT
toRepo
  -- get old patches
  let cleanup :: IO ()
cleanup = Verbosity -> Doc -> IO ()
putInfo Verbosity
verb (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Using lazy repository."
  CloneKind -> IO () -> IO () -> IO ()
allowCtrlC CloneKind
cloneKind IO ()
cleanup (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Verbosity -> Doc -> IO ()
putVerbose Verbosity
verb (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Using patches pack."
    [String] -> Cache -> String -> IO ()
fetchAndUnpackPatches ((forall wW wZ. PatchInfoAnd rt p wW wZ -> String)
-> RL (PatchInfoAnd rt p) Origin wR -> [String]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> RL a wX wY -> [b]
mapRL forall wW wZ. PatchInfoAnd rt p wW wZ -> String
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> String
hashedPatchFileName (RL (PatchInfoAnd rt p) Origin wR -> [String])
-> RL (PatchInfoAnd rt p) Origin wR -> [String]
forall a b. (a -> b) -> a -> b
$ PatchSet rt p Origin wR -> RL (PatchInfoAnd rt p) Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX
patchSet2RL PatchSet rt p Origin wR
us)
      (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
toRepo) (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
fromRepo)
    Bool
pi <- String -> IO Bool
doesPatchIndexExist (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
toRepo)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
pi (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Repository rt p wR wU wT -> PatchSet rt p Origin wR -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> PatchSet rt p Origin wR -> IO ()
createPIWithInterrupt Repository rt p wR wU wT
toRepo PatchSet rt p Origin wR
us -- TODO or do another readRepo?

cleanDir :: FilePath -> IO ()
cleanDir :: String -> IO ()
cleanDir String
d = (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\String
x -> String -> IO ()
removeFile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
d String -> String -> String
</> String
x) ([String] -> IO ()) -> IO [String] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO [String]
listDirectory String
d

copyRepoOldFashioned :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                        => Repository rt p wR wU wT  -- remote repo
                        -> Repository rt p wR wU wT  -- local empty repo
                        -> Verbosity
                        -> WithWorkingDir
                        -> IO ()
copyRepoOldFashioned :: Repository rt p wR wU wT
-> Repository rt p wR wU wT -> Verbosity -> WithWorkingDir -> IO ()
copyRepoOldFashioned Repository rt p wR wU wT
fromrepository Repository rt p wR wU wT
_toRepo Verbosity
verb WithWorkingDir
withWorkingDir = do
  IO ()
revertTentativeChanges
  PatchSet rt p Origin wR
patches <- Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wT
fromrepository
  let k :: String
k = String
"Copying patch"
  String -> IO ()
beginTedious String
k
  String -> Int -> IO ()
tediousSize String
k (RL (PatchInfoAnd rt p) Origin wR -> Int
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL (RL (PatchInfoAnd rt p) Origin wR -> Int)
-> RL (PatchInfoAnd rt p) Origin wR -> Int
forall a b. (a -> b) -> a -> b
$ PatchSet rt p Origin wR -> RL (PatchInfoAnd rt p) Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX
patchSet2RL PatchSet rt p Origin wR
patches)
  let patches' :: PatchSet rt p Origin wR
patches' = String -> PatchSet rt p Origin wR -> PatchSet rt p Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
String -> PatchSet rt p wStart wX -> PatchSet rt p wStart wX
progressPatchSet String
k PatchSet rt p Origin wR
patches
  Cache -> Compression -> PatchSet rt p Origin wR -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wX.
RepoPatch p =>
Cache -> Compression -> PatchSet rt p Origin wX -> IO ()
writeTentativeInventory (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
_toRepo) Compression
GzipCompression PatchSet rt p Origin wR
patches'
  String -> IO ()
endTedious String
k
  Repository rt p wR wU wT -> Compression -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> Compression -> IO ()
finalizeTentativeChanges Repository rt p wR wU wT
_toRepo Compression
GzipCompression
  -- apply all patches into current hashed repository
  Repository rt p wR wU wR
_toRepo <- Repository rt p wR wU wT
-> UpdatePending -> IO (Repository rt p wR wU wR)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT
-> UpdatePending -> IO (Repository rt p wR wU wR)
revertRepositoryChanges Repository rt p wR wU wT
_toRepo UpdatePending
NoUpdatePending
  PatchSet rt p Origin wR
local_patches <- Repository rt p wR wU wR -> IO (PatchSet rt p Origin wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wR
_toRepo
  Repository rt p wR wU wR -> Tree IO -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Tree IO -> IO ()
replacePristine Repository rt p wR wU wR
_toRepo Tree IO
forall (m :: * -> *). Tree m
emptyTree
  let patchesToApply :: FL (PatchInfoAnd rt p) Origin wR
patchesToApply = String
-> FL (PatchInfoAnd rt p) Origin wR
-> FL (PatchInfoAnd rt p) Origin wR
forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL String
"Applying patch" (FL (PatchInfoAnd rt p) Origin wR
 -> FL (PatchInfoAnd rt p) Origin wR)
-> FL (PatchInfoAnd rt p) Origin wR
-> FL (PatchInfoAnd rt p) Origin wR
forall a b. (a -> b) -> a -> b
$ PatchSet rt p Origin wR -> FL (PatchInfoAnd rt p) Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX
patchSet2FL PatchSet rt p Origin wR
local_patches
  [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall wW wZ. FL (PatchInfoAnd rt p) wW wZ -> IO ())
-> FL (FL (PatchInfoAnd rt p)) Origin wR -> [IO ()]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL (ApplyDir -> FL (PatchInfoAnd rt p) wW wZ -> IO ()
forall (p :: * -> * -> *) wX wY.
(ApplyState p ~ Tree, Apply p) =>
ApplyDir -> p wX wY -> IO ()
applyToTentativePristineCwd ApplyDir
ApplyNormal) (FL (FL (PatchInfoAnd rt p)) Origin wR -> [IO ()])
-> FL (FL (PatchInfoAnd rt p)) Origin wR -> [IO ()]
forall a b. (a -> b) -> a -> b
$ Int
-> FL (PatchInfoAnd rt p) Origin wR
-> FL (FL (PatchInfoAnd rt p)) Origin wR
forall (a :: * -> * -> *) wX wY.
Int -> FL a wX wY -> FL (FL a) wX wY
bunchFL Int
100 FL (PatchInfoAnd rt p) Origin wR
patchesToApply
  Repository rt p wR wU wR
_toRepo <- Repository rt p wR wU wR
-> UpdatePending -> Compression -> IO (Repository rt p wR wU wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdatePending -> Compression -> IO (Repository rt p wT wU wT)
finalizeRepositoryChanges Repository rt p wR wU wR
_toRepo UpdatePending
NoUpdatePending Compression
GzipCompression
  Verbosity -> Doc -> IO ()
putVerbose Verbosity
verb (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Writing pristine and working tree contents..."
  Repository rt p wR wU wR -> 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 wR
_toRepo String
"." WithWorkingDir
withWorkingDir

-- | This function fetches all patches that the given repository has
--   with fetchFileUsingCache.
fetchPatchesIfNecessary :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p)
                        => Repository rt p wR wU wT
                        -> IO ()
fetchPatchesIfNecessary :: Repository rt p wR wU wT -> IO ()
fetchPatchesIfNecessary Repository rt p wR wU wT
toRepo =
  do  PatchSet rt p Origin wR
ps <- Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wT
toRepo
      Int
pipelineLength <- IO Int
maxPipelineLength
      let patches :: RL (PatchInfoAnd rt p) Origin wR
patches = PatchSet rt p Origin wR -> RL (PatchInfoAnd rt p) Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX
patchSet2RL PatchSet rt p Origin wR
ps
          ppatches :: RL (PatchInfoAnd rt p) Origin wR
ppatches = String
-> RL (PatchInfoAnd rt p) Origin wR
-> RL (PatchInfoAnd rt p) Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
String
-> RL (PatchInfoAnd rt p) wX wY -> RL (PatchInfoAnd rt p) wX wY
progressRLShowTags String
"Copying patches" RL (PatchInfoAnd rt p) Origin wR
patches
          ([String]
first, [String]
other) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
pipelineLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ([String] -> ([String], [String]))
-> [String] -> ([String], [String])
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
tail ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ RL (PatchInfoAnd rt p) Origin wR -> [String]
forall wX wY. RL (PatchInfoAnd rt p) wX wY -> [String]
hashes RL (PatchInfoAnd rt p) Origin wR
patches
          speculate :: [[String]]
speculate | Int
pipelineLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = [] [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
: [String]
first [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
: (String -> [String]) -> [String] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map (String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[]) [String]
other
                    | Bool
otherwise = []
      ((String, [String]) -> IO ()) -> [(String, [String])] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String, [String]) -> IO ()
fetchAndSpeculate ([(String, [String])] -> IO ()) -> [(String, [String])] -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> [[String]] -> [(String, [String])]
forall a b. [a] -> [b] -> [(a, b)]
zip (RL (PatchInfoAnd rt p) Origin wR -> [String]
forall wX wY. RL (PatchInfoAnd rt p) wX wY -> [String]
hashes RL (PatchInfoAnd rt p) Origin wR
ppatches) ([[String]]
speculate [[String]] -> [[String]] -> [[String]]
forall a. [a] -> [a] -> [a]
++ [String] -> [[String]]
forall a. a -> [a]
repeat [])
  where hashes :: forall wX wY . RL (PatchInfoAnd rt p) wX wY -> [String]
        hashes :: RL (PatchInfoAnd rt p) wX wY -> [String]
hashes = [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe String] -> [String])
-> (RL (PatchInfoAnd rt p) wX wY -> [Maybe String])
-> RL (PatchInfoAnd rt p) wX wY
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall wW wZ. PatchInfoAnd rt p wW wZ -> Maybe String)
-> RL (PatchInfoAnd rt p) wX wY -> [Maybe String]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> RL a wX wY -> [b]
mapRL ((Named p wW wZ -> Maybe String)
-> (String -> Maybe String)
-> Either (Named p wW wZ) String
-> Maybe String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe String -> Named p wW wZ -> Maybe String
forall a b. a -> b -> a
const Maybe String
forall a. Maybe a
Nothing) String -> Maybe String
forall a. a -> Maybe a
Just (Either (Named p wW wZ) String -> Maybe String)
-> (PatchInfoAndG rt (Named p) wW wZ
    -> Either (Named p wW wZ) String)
-> PatchInfoAndG rt (Named p) wW wZ
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAndG rt (Named p) wW wZ -> Either (Named p wW wZ) String
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> Either (p wA wB) String
extractHash)
        fetchAndSpeculate :: (String, [String]) -> IO ()
        fetchAndSpeculate :: (String, [String]) -> IO ()
fetchAndSpeculate (String
f, [String]
ss) = do
          (String, ByteString)
_ <- Cache -> HashedDir -> String -> IO (String, ByteString)
fetchFileUsingCache Cache
c HashedDir
HashedPatchesDir String
f
          (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Cache -> HashedDir -> String -> IO ()
speculateFileUsingCache Cache
c HashedDir
HashedPatchesDir) [String]
ss
        c :: Cache
c = 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
toRepo

-- | Replace the existing pristine with a new one (loaded up in a Tree object).
replacePristine :: Repository rt p wR wU wT -> Tree IO -> IO ()
replacePristine :: Repository rt p wR wU wT -> Tree IO -> IO ()
replacePristine = String -> Tree IO -> IO ()
writePristine (String -> Tree IO -> IO ())
-> (Repository rt p wR wU wT -> String)
-> Repository rt p wR wU wT
-> Tree IO
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Repository rt p wR wU wT -> String
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String
repoLocation

allowCtrlC :: CloneKind -> IO () -> IO () -> IO ()
allowCtrlC :: CloneKind -> IO () -> IO () -> IO ()
allowCtrlC CloneKind
CompleteClone IO ()
_       IO ()
action = IO ()
action
allowCtrlC CloneKind
_             IO ()
cleanup IO ()
action = IO ()
action IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchInterrupt` IO ()
cleanup

hashedPatchFileName :: PatchInfoAnd rt p wA wB -> String
hashedPatchFileName :: PatchInfoAnd rt p wA wB -> String
hashedPatchFileName PatchInfoAnd rt p wA wB
x = case PatchInfoAnd rt p wA wB -> Either (Named p wA wB) String
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> Either (p wA wB) String
extractHash PatchInfoAnd rt p wA wB
x of
  Left Named p wA wB
_ -> String -> String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unexpected unhashed patch"
  Right String
h -> String
h