module Darcs.Repository.Clone
( cloneRepository
, replacePristine
, writePatchSet
) where
import Prelude ()
import Darcs.Prelude
import Control.Exception ( catch, SomeException )
import Control.Monad ( when )
import qualified Data.ByteString.Char8 as BC
import Data.List( intercalate )
import Data.Maybe( catMaybes )
import System.FilePath( (</>) )
import System.Directory
( removeFile
, getDirectoryContents
)
import System.IO ( stderr )
import Darcs.Repository.Create
( EmptyRepository(..)
, createRepository
, writePristine
)
import Darcs.Repository.State ( invalidateIndex )
import Darcs.Repository.Pending ( tentativelyAddToPending )
import Darcs.Repository.Identify
( IdentifyRepo(..)
, identifyRepositoryFor
, maybeIdentifyRepository )
import Darcs.Repository.Hashed
( readRepo
, tentativelyRemovePatches
, finalizeRepositoryChanges
, createPristineDirectoryTree
, revertRepositoryChanges
)
import Darcs.Repository.Working
( setScriptsExecutable
, setScriptsExecutablePatches )
import Darcs.Repository.InternalTypes
( Repository
, repoLocation
, repoFormat
, repoCache
, modifyCache
, repoPatchType )
import Darcs.Repository.Job ( withUMaskFlag )
import Darcs.Repository.Cache
( unionRemoteCaches
, unionCaches
, fetchFileUsingCache
, speculateFileUsingCache
, HashedDir(..)
, Cache(..)
, CacheLoc(..)
, repo2cache
)
import qualified Darcs.Repository.Cache as DarcsCache
import qualified Darcs.Repository.Hashed as HashedRepo
import Darcs.Repository.ApplyPatches ( runDefault )
import Darcs.Repository.Hashed
( applyToTentativePristineCwd
, peekPristineHash
)
import Darcs.Repository.Format
( RepoProperty ( HashedInventory, Darcs2 )
, 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.Util.Lock ( appendTextFile, withNewDirectory )
import Darcs.Repository.Flags
( UpdateWorking(..)
, UseCache(..)
, RemoteDarcs (..)
, remoteDarcs
, Compression (..)
, CloneKind (..)
, Verbosity (..)
, DryRun (..)
, UMask (..)
, SetScriptsExecutable (..)
, RemoteRepos (..)
, SetDefault (..)
, WithWorkingDir (..)
, ForgetParent (..)
, WithPatchIndex (..)
, PatchFormat (..)
)
import Darcs.Patch ( RepoPatch, IsRepoType, apply, invert, effect )
import Darcs.Patch.Depends ( findCommonWithThem, countUsThem )
import Darcs.Patch.Set ( Origin
, PatchSet
, patchSet2RL
, patchSet2FL
, progressPatchSet
)
import Darcs.Patch.Match ( MatchFlag(..), havePatchsetMatch )
import Darcs.Patch.Progress ( progressRLShowTags, progressFL )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )
import Darcs.Patch.Witnesses.Ordered
( (:>)(..)
, lengthFL
, mapFL_FL
, RL(..)
, bunchFL
, mapFL
, mapRL
, lengthRL
)
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, extractHash, hopefully )
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 )
import Darcs.Util.Printer ( Doc, text, hPutDocLn, putDocLn, errorDoc )
import Darcs.Util.Progress
( debugMessage
, tediousSize
, beginTedious
, endTedious
)
joinUrl :: [String] -> String
joinUrl :: [String] -> String
joinUrl = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "/"
cloneRepository ::
String
-> String
-> Verbosity -> UseCache
-> CloneKind
-> UMask -> RemoteDarcs
-> SetScriptsExecutable
-> RemoteRepos -> SetDefault
-> [MatchFlag]
-> RepoFormat
-> WithWorkingDir
-> WithPatchIndex
-> Bool
-> ForgetParent
-> IO ()
cloneRepository :: String
-> String
-> Verbosity
-> UseCache
-> CloneKind
-> UMask
-> RemoteDarcs
-> SetScriptsExecutable
-> RemoteRepos
-> SetDefault
-> [MatchFlag]
-> RepoFormat
-> WithWorkingDir
-> WithPatchIndex
-> Bool
-> ForgetParent
-> IO ()
cloneRepository repodir :: String
repodir mysimplename :: String
mysimplename v :: Verbosity
v useCache :: UseCache
useCache cloneKind :: CloneKind
cloneKind um :: UMask
um rdarcs :: RemoteDarcs
rdarcs sse :: SetScriptsExecutable
sse remoteRepos :: RemoteRepos
remoteRepos
setDefault :: SetDefault
setDefault matchFlags :: [MatchFlag]
matchFlags rfsource :: RepoFormat
rfsource withWorkingDir :: WithWorkingDir
withWorkingDir usePatchIndex :: WithPatchIndex
usePatchIndex usePacks :: Bool
usePacks
forget :: 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 = if RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
Darcs2 RepoFormat
rfsource then PatchFormat
PatchFormat2 else PatchFormat
PatchFormat1
EmptyRepository toRepo' :: 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 "Finished initializing new repository."
String -> DryRun -> RemoteRepos -> SetDefault -> IO ()
addRepoSource String
repodir DryRun
NoDryRun RemoteRepos
remoteRepos SetDefault
setDefault
String -> IO ()
debugMessage "Identifying and copying repository..."
Repository ('RepoType 'NoRebase) p Origin Origin Origin
fromRepo <- 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.
Repository rt p wR wU wT
-> UseCache -> String -> IO (Repository rt p vR vU vT)
identifyRepositoryFor Repository ('RepoType 'NoRebase) p Origin Origin Origin
toRepo' UseCache
useCache String
repodir
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 e :: String
e -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Incompatibility with repository " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fromLoc String -> String -> String
forall a. [a] -> [a] -> [a]
++ ":\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
String -> IO ()
debugMessage "Copying prefs..."
String -> String -> String -> Cachable -> IO ()
copyFileOrUrl (RemoteDarcs -> String
remoteDarcs RemoteDarcs
rdarcs)
([String] -> String
joinUrl [String
fromLoc, String
darcsdir, "prefs", "prefs"])
(String
darcsdir String -> String -> String
</> "prefs/prefs") (CInt -> Cachable
MaxAge 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 "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
</> "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 "Done copying and filtering sources."
let toRepo :: Repository ('RepoType 'NoRebase) p Origin Origin Origin
toRepo = Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> (Cache -> Cache)
-> Repository ('RepoType 'NoRebase) p Origin Origin Origin
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT
-> (Cache -> Cache) -> Repository rt p wR wU wT
modifyCache Repository ('RepoType 'NoRebase) p Origin Origin Origin
toRepo' (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)
if RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory RepoFormat
rffrom then do
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 "Copying patches, to get lazy repository hit ctrl-C..."
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
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
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PatchType ('RepoType 'NoRebase) p -> [MatchFlag] -> Bool
forall (rt :: RepoType) (p :: * -> * -> *).
(IsRepoType rt, Matchable p) =>
PatchType rt p -> [MatchFlag] -> Bool
havePatchsetMatch (Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> PatchType ('RepoType 'NoRebase) p
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> PatchType rt p
repoPatchType Repository ('RepoType 'NoRebase) p Origin Origin Origin
toRepo) [MatchFlag]
matchFlags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity -> Doc -> IO ()
putInfo Verbosity
v (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "Going to specified version..."
Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> UpdateWorking -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> UpdateWorking -> IO ()
revertRepositoryChanges Repository ('RepoType 'NoRebase) p Origin Origin Origin
toRepo UpdateWorking
YesUpdateWorking
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 context :: PatchSet ('RepoType 'NoRebase) p Origin wX
context <- Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> [MatchFlag]
-> IO (Sealed (PatchSet ('RepoType 'NoRebase) p Origin))
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT
-> [MatchFlag] -> IO (SealedPatchSet rt p Origin)
getOnePatchset Repository ('RepoType 'NoRebase) p Origin Origin Origin
toRepo [MatchFlag]
matchFlags
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Int, Int) -> Int
forall a b. (a, b) -> b
snd (PatchSet ('RepoType 'NoRebase) p Origin Origin
-> PatchSet ('RepoType 'NoRebase) p Origin wX -> (Int, Int)
forall (p :: * -> * -> *) (rt :: RepoType) wStart wX wY.
Commute p =>
PatchSet rt p wStart wX -> PatchSet rt p wStart wY -> (Int, Int)
countUsThem PatchSet ('RepoType 'NoRebase) p Origin Origin
patches PatchSet ('RepoType 'NoRebase) p Origin wX
context) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Doc -> IO ()
forall a. Doc -> a
errorDoc (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "Missing patches from context!"
_ :> us' :: FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ Origin
us' <- (:>)
(PatchSet ('RepoType 'NoRebase) p)
(FL (PatchInfoAnd ('RepoType 'NoRebase) p))
Origin
Origin
-> IO
((:>)
(PatchSet ('RepoType 'NoRebase) p)
(FL (PatchInfoAnd ('RepoType 'NoRebase) p))
Origin
Origin)
forall (m :: * -> *) a. Monad m => a -> m a
return ((:>)
(PatchSet ('RepoType 'NoRebase) p)
(FL (PatchInfoAnd ('RepoType 'NoRebase) p))
Origin
Origin
-> IO
((:>)
(PatchSet ('RepoType 'NoRebase) p)
(FL (PatchInfoAnd ('RepoType 'NoRebase) p))
Origin
Origin))
-> (:>)
(PatchSet ('RepoType 'NoRebase) p)
(FL (PatchInfoAnd ('RepoType 'NoRebase) p))
Origin
Origin
-> IO
((:>)
(PatchSet ('RepoType 'NoRebase) p)
(FL (PatchInfoAnd ('RepoType 'NoRebase) p))
Origin
Origin)
forall a b. (a -> b) -> a -> b
$ PatchSet ('RepoType 'NoRebase) p Origin Origin
-> PatchSet ('RepoType 'NoRebase) p Origin wX
-> (:>)
(PatchSet ('RepoType 'NoRebase) p)
(FL (PatchInfoAnd ('RepoType 'NoRebase) p))
Origin
Origin
forall (p :: * -> * -> *) (rt :: RepoType) wStart wX wY.
Commute p =>
PatchSet rt p wStart wX
-> PatchSet rt p wStart wY
-> (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) wStart wX
findCommonWithThem PatchSet ('RepoType 'NoRebase) p Origin Origin
patches PatchSet ('RepoType 'NoRebase) p Origin wX
context
let ps :: FL (WrappedNamed ('RepoType 'NoRebase) p) wZ Origin
ps = (forall wW wY.
PatchInfoAnd ('RepoType 'NoRebase) p wW wY
-> WrappedNamed ('RepoType 'NoRebase) p wW wY)
-> FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ Origin
-> FL (WrappedNamed ('RepoType 'NoRebase) p) wZ Origin
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL forall wW wY.
PatchInfoAnd ('RepoType 'NoRebase) p wW wY
-> WrappedNamed ('RepoType 'NoRebase) p wW wY
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> WrappedNamed rt p wA wB
hopefully FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ Origin
us'
Verbosity -> Doc -> IO ()
putInfo Verbosity
v (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ "Unapplying " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (FL (WrappedNamed ('RepoType 'NoRebase) p) wZ Origin -> Int
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL FL (WrappedNamed ('RepoType 'NoRebase) p) wZ Origin
ps) String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> Noun -> String -> String
forall n. Countable n => Int -> n -> String -> String
englishNum (FL (WrappedNamed ('RepoType 'NoRebase) p) wZ Origin -> Int
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL FL (WrappedNamed ('RepoType 'NoRebase) p) wZ Origin
ps) (String -> Noun
Noun "patch") ""
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
_ <- Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> Compression
-> UpdateWorking
-> 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
-> UpdateWorking
-> FL (PatchInfoAnd rt p) wX wT
-> IO (Repository rt p wR wU wX)
tentativelyRemovePatches Repository ('RepoType 'NoRebase) p Origin Origin Origin
toRepo Compression
GzipCompression UpdateWorking
YesUpdateWorking FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ Origin
us'
Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> UpdateWorking -> FL (PrimOf p) Origin wZ -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wX wY.
RepoPatch p =>
Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wX wY -> IO ()
tentativelyAddToPending Repository ('RepoType 'NoRebase) p Origin Origin Origin
toRepo UpdateWorking
YesUpdateWorking (FL (PrimOf p) Origin wZ -> IO ())
-> FL (PrimOf p) Origin wZ -> IO ()
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wZ Origin -> FL (PrimOf p) Origin wZ
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert (FL (PrimOf p) wZ Origin -> FL (PrimOf p) Origin wZ)
-> FL (PrimOf p) wZ Origin -> FL (PrimOf p) Origin wZ
forall a b. (a -> b) -> a -> b
$ FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ Origin
-> FL
(PrimOf (FL (PatchInfoAnd ('RepoType 'NoRebase) p))) wZ Origin
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL (PatchInfoAnd ('RepoType 'NoRebase) p) wZ Origin
us'
Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> UpdateWorking -> Compression -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> UpdateWorking -> Compression -> IO ()
finalizeRepositoryChanges Repository ('RepoType 'NoRebase) p Origin Origin Origin
toRepo UpdateWorking
YesUpdateWorking Compression
GzipCompression
DefaultIO () -> IO ()
forall a. DefaultIO a -> IO a
runDefault (FL (PrimOf p) Origin wZ -> DefaultIO ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply (FL (PrimOf p) wZ Origin -> FL (PrimOf p) Origin wZ
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert (FL (PrimOf p) wZ Origin -> FL (PrimOf p) Origin wZ)
-> FL (PrimOf p) wZ Origin -> FL (PrimOf p) Origin wZ
forall a b. (a -> b) -> a -> b
$ FL (WrappedNamed ('RepoType 'NoRebase) p) wZ Origin
-> FL
(PrimOf (FL (WrappedNamed ('RepoType 'NoRebase) p))) wZ Origin
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL (WrappedNamed ('RepoType 'NoRebase) p) wZ Origin
ps)) 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 ("Couldn't undo patch in working dir.\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 (PrimOf p) Origin wZ -> IO ()
forall (p :: * -> * -> *) wX wY. PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches (FL (PrimOf p) wZ Origin -> FL (PrimOf p) Origin wZ
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert (FL (PrimOf p) wZ Origin -> FL (PrimOf p) Origin wZ)
-> FL (PrimOf p) wZ Origin -> FL (PrimOf p) Origin wZ
forall a b. (a -> b) -> a -> b
$ FL (WrappedNamed ('RepoType 'NoRebase) p) wZ Origin
-> FL
(PrimOf (FL (WrappedNamed ('RepoType 'NoRebase) p))) wZ Origin
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL (WrappedNamed ('RepoType 'NoRebase) p) wZ Origin
ps)
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
dropNonRepos :: Cache -> Cache
dropNonRepos :: Cache -> Cache
dropNonRepos (Ca cache :: [CacheLoc]
cache) = [CacheLoc] -> Cache
Ca ([CacheLoc] -> Cache) -> [CacheLoc] -> Cache
forall a b. (a -> b) -> a -> b
$ (CacheLoc -> Bool) -> [CacheLoc] -> [CacheLoc]
forall a. (a -> Bool) -> [a] -> [a]
filter CacheLoc -> Bool
notRepo [CacheLoc]
cache where
notRepo :: CacheLoc -> Bool
notRepo xs :: CacheLoc
xs = case CacheLoc
xs of
Cache DarcsCache.Directory _ _ -> Bool
False
Cache DarcsCache.Repo DarcsCache.Writable _ -> Bool
False
_ -> Bool
True
putInfo :: Verbosity -> Doc -> IO ()
putInfo :: Verbosity -> Doc -> IO ()
putInfo Quiet _ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
putInfo _ d :: Doc
d = Handle -> Doc -> IO ()
hPutDocLn Handle
stderr Doc
d
putVerbose :: Verbosity -> Doc -> IO ()
putVerbose :: Verbosity -> Doc -> IO ()
putVerbose Verbose d :: Doc
d = Doc -> IO ()
putDocLn Doc
d
putVerbose _ _ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
copyBasicRepoNotPacked :: forall rt 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
-> Repository rt p wR wU wT
-> Verbosity
-> RemoteDarcs
-> WithWorkingDir
-> IO ()
copyBasicRepoNotPacked fromRepo :: Repository rt p wR wU wT
fromRepo toRepo :: Repository rt p wR wU wT
toRepo verb :: Verbosity
verb rdarcs :: RemoteDarcs
rdarcs withWorkingDir :: WithWorkingDir
withWorkingDir = do
Verbosity -> Doc -> IO ()
putVerbose Verbosity
verb (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "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 ()
HashedRepo.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 "Writing pristine and working directory 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 "." WithWorkingDir
withWorkingDir
copyCompleteRepoNotPacked :: 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 ()
copyCompleteRepoNotPacked :: Repository rt p wR wU wT
-> Repository rt p wR wU wT -> Verbosity -> CloneKind -> IO ()
copyCompleteRepoNotPacked _ toRepo :: Repository rt p wR wU wT
toRepo verb :: Verbosity
verb cloneKind :: 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 "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
-> Repository rt p wR wU wT
-> Verbosity
-> RemoteDarcs
-> WithWorkingDir
-> IO ()
copyBasicRepoPacked :: Repository rt p wR wU wT
-> Repository rt p wR wU wT
-> Verbosity
-> RemoteDarcs
-> WithWorkingDir
-> IO ()
copyBasicRepoPacked fromRepo :: Repository rt p wR wU wT
fromRepo toRepo :: Repository rt p wR wU wT
toRepo verb :: Verbosity
verb rdarcs :: RemoteDarcs
rdarcs withWorkingDir :: 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, "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, "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
$ ByteString -> String
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 packHash :: ByteString
packHash | ByteString
packHash ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
currentHash
-> ( 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
IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) ->
do String -> IO ()
putStrLn ("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)
_ -> do Verbosity -> Doc -> IO ()
putVerbose Verbosity
verb (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "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
-> Repository rt p wR wU wT
-> Verbosity
-> WithWorkingDir
-> IO ()
copyBasicRepoPacked2 :: Repository rt p wR wU wT
-> Repository rt p wR wU wT -> Verbosity -> WithWorkingDir -> IO ()
copyBasicRepoPacked2 fromRepo :: Repository rt p wR wU wT
fromRepo toRepo :: Repository rt p wR wU wT
toRepo verb :: Verbosity
verb withWorkingDir :: WithWorkingDir
withWorkingDir = do
Verbosity -> Doc -> IO ()
putVerbose Verbosity
verb (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "Cloning packed basic repository."
String -> IO ()
cleanDir (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
darcsdir String -> String -> String
</> "pristine.hashed"
String -> IO ()
removeFile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
darcsdir 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 "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 "." WithWorkingDir
withWorkingDir
copyCompleteRepoPacked ::
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 ()
copyCompleteRepoPacked :: Repository rt p wR wU wT
-> Repository rt p wR wU wT -> Verbosity -> CloneKind -> IO ()
copyCompleteRepoPacked from :: Repository rt p wR wU wT
from to :: Repository rt p wR wU wT
to verb :: Verbosity
verb cloneKind :: 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 ("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 "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 fromRepo :: Repository rt p wR wU wT
fromRepo toRepo :: Repository rt p wR wU wT
toRepo verb :: Verbosity
verb cloneKind :: 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
let cleanup :: IO ()
cleanup = Verbosity -> Doc -> IO ()
putInfo Verbosity
verb (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "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 "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
cleanDir :: FilePath -> IO ()
cleanDir :: String -> IO ()
cleanDir d :: String
d = (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\x :: 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 ()) -> ([String] -> [String]) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\x :: String
x -> String -> Char
forall a. [a] -> a
head String
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '.') ([String] -> IO ()) -> IO [String] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO [String]
getDirectoryContents String
d
copyRepoOldFashioned :: 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
-> WithWorkingDir
-> IO ()
copyRepoOldFashioned :: Repository rt p wR wU wT
-> Repository rt p wR wU wT -> Verbosity -> WithWorkingDir -> IO ()
copyRepoOldFashioned fromrepository :: Repository rt p wR wU wT
fromrepository toRepo :: Repository rt p wR wU wT
toRepo verb :: Verbosity
verb withWorkingDir :: WithWorkingDir
withWorkingDir = do
IO ()
HashedRepo.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 = "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 ()
HashedRepo.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 ()
HashedRepo.finalizeTentativeChanges Repository rt p wR wU wT
toRepo Compression
GzipCompression
IO ()
HashedRepo.revertTentativeChanges
PatchSet rt p Origin wR
local_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
toRepo
Repository rt p wR wU wT -> 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 wT
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 "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 forall wW wZ. FL (PatchInfoAnd rt p) wW wZ -> IO ()
forall (p :: * -> * -> *) wX wY.
(ApplyState p ~ Tree, Apply p) =>
p wX wY -> IO ()
applyToTentativePristineCwd (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 100 FL (PatchInfoAnd rt p) Origin wR
patchesToApply
Repository rt p wR wU wT -> UpdateWorking -> Compression -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> UpdateWorking -> Compression -> IO ()
finalizeRepositoryChanges Repository rt p wR wU wT
toRepo UpdateWorking
YesUpdateWorking Compression
GzipCompression
Verbosity -> Doc -> IO ()
putVerbose Verbosity
verb (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "Writing pristine and working directory 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 "." WithWorkingDir
withWorkingDir
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 toRepo :: 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 "Copying patches" RL (PatchInfoAnd rt p) Origin wR
patches
(first :: [String]
first, other :: [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
- 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
> 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 ((WrappedNamed rt p wW wZ -> Maybe String)
-> (String -> Maybe String)
-> Either (WrappedNamed rt p wW wZ) String
-> Maybe String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe String -> WrappedNamed rt 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 (WrappedNamed rt p wW wZ) String -> Maybe String)
-> (PatchInfoAnd rt p wW wZ
-> Either (WrappedNamed rt p wW wZ) String)
-> PatchInfoAnd rt p wW wZ
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd rt p wW wZ -> Either (WrappedNamed rt p wW wZ) String
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> Either (WrappedNamed rt p wA wB) String
extractHash)
fetchAndSpeculate :: (String, [String]) -> IO ()
fetchAndSpeculate :: (String, [String]) -> IO ()
fetchAndSpeculate (f :: String
f, ss :: [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
writePatchSet :: (IsRepoType rt, RepoPatch p)
=> PatchSet rt p Origin wX
-> UseCache
-> IO (Repository rt p wR wU wT)
writePatchSet :: PatchSet rt p Origin wX
-> UseCache -> IO (Repository rt p wR wU wT)
writePatchSet patchset :: PatchSet rt p Origin wX
patchset useCache :: UseCache
useCache = do
IdentifyRepo rt p wR wU wT
maybeRepo <- UseCache -> String -> IO (IdentifyRepo rt p wR wU wT)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
UseCache -> String -> IO (IdentifyRepo rt p wR wU wT)
maybeIdentifyRepository UseCache
useCache "."
let repo :: Repository rt p wR wU wT
repo =
case IdentifyRepo rt p wR wU wT
maybeRepo of
GoodRepository r :: Repository rt p wR wU wT
r -> Repository rt p wR wU wT
r
BadRepository e :: String
e -> String -> Repository rt p wR wU wT
forall a. String -> a
bug ("Current directory is a bad repository in writePatchSet: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e)
NonRepository e :: String
e -> String -> Repository rt p wR wU wT
forall a. String -> a
bug ("Current directory not a repository in writePatchSet: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e)
String -> IO ()
debugMessage "Writing inventory"
Cache -> Compression -> PatchSet rt p Origin wX -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wX.
RepoPatch p =>
Cache -> Compression -> PatchSet rt p Origin wX -> IO ()
HashedRepo.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
repo) Compression
GzipCompression PatchSet rt p Origin wX
patchset
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 ()
HashedRepo.finalizeTentativeChanges Repository rt p wR wU wT
repo Compression
GzipCompression
Repository rt p wR wU wT -> IO (Repository rt p wR wU wT)
forall (m :: * -> *) a. Monad m => a -> m a
return Repository rt p wR wU wT
repo
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 CompleteClone _ action :: IO ()
action = IO ()
action
allowCtrlC _ cleanup :: IO ()
cleanup action :: 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 x :: PatchInfoAnd rt p wA wB
x = case PatchInfoAnd rt p wA wB -> Either (WrappedNamed rt p wA wB) String
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> Either (WrappedNamed rt p wA wB) String
extractHash PatchInfoAnd rt p wA wB
x of
Left _ -> String -> String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "unexpected unhashed patch"
Right h :: String
h -> String
h