module Darcs.Repository.Clone
    ( cloneRepository
    ) where

import Darcs.Prelude

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

import Darcs.Repository.Create
    ( EmptyRepository(..)
    , createRepository
    )
import Darcs.Repository.Identify ( identifyRepositoryFor, ReadingOrWriting(..) )
import Darcs.Repository.Pristine
    ( applyToTentativePristine
    , createPristineDirectoryTree
    , writePristine
    )
import Darcs.Repository.Hashed
    ( copyHashedInventory
    , readPatches
    , tentativelyRemovePatches
    , writeTentativeInventory
    )
import Darcs.Repository.Transaction
    ( finalizeRepositoryChanges
    , revertRepositoryChanges
    )
import Darcs.Repository.Working
    ( setAllScriptsExecutable
    , setScriptsExecutablePatches )
import Darcs.Repository.InternalTypes
    ( Repository
    , AccessType(..)
    , repoLocation
    , repoFormat
    , repoCache
    , modifyCache
    )
import Darcs.Repository.Job ( withUMaskFlag )
import Darcs.Util.Cache
    ( filterRemoteCaches
    , fetchFileUsingCache
    , speculateFileUsingCache
    , dropNonRepos
    )

import Darcs.Repository.ApplyPatches ( runDefault )
import Darcs.Repository.Inventory
    ( PatchHash
    , encodeValidHash
    , peekPristineHash
    )
import Darcs.Repository.Format
    ( RepoProperty ( HashedInventory, Darcs2, Darcs3 )
    , RepoFormat
    , formatHas
    )
import Darcs.Repository.Prefs ( addRepoSource, deleteSources )
import Darcs.Repository.Match ( getOnePatchset )
import Darcs.Util.File
    ( copyFileOrUrl
    , Cachable(..)
    , gzFetchFilePS
    )
import Darcs.Repository.PatchIndex
    ( doesPatchIndexExist
    , createPIWithInterrupt
    )
import Darcs.Repository.Packs
    ( fetchAndUnpackBasic
    , fetchAndUnpackPatches
    , packsDir
    )
import Darcs.Repository.Paths ( hashedInventoryPath, pristineDirPath )
import Darcs.Repository.Resolution
    ( StandardResolution(..)
    , patchsetConflictResolutions
    , announceConflicts
    )
import Darcs.Repository.Working ( applyToWorking )
import Darcs.Util.Lock ( writeTextFile, withNewDirectory )
import Darcs.Repository.Flags
    ( UpdatePending(..)
    , UseCache(..)
    , RemoteDarcs (..)
    , remoteDarcs
    , CloneKind (..)
    , Verbosity (..)
    , DryRun (..)
    , UMask (..)
    , SetScriptsExecutable (..)
    , SetDefault (..)
    , InheritDefault (..)
    , WithWorkingDir (..)
    , ForgetParent (..)
    , WithPatchIndex (..)
    , PatchFormat (..)
    , AllowConflicts(..)
    , ResolveConflicts(..)
    , WithPrefsTemplates(..)
    )

import Darcs.Patch ( RepoPatch, description )
import Darcs.Patch.Depends ( findUncommon )
import Darcs.Patch.Invertible ( mkInvertible )
import Darcs.Patch.Set
    ( Origin
    , patchSet2FL
    , patchSet2RL
    , patchSetInventoryHashes
    , 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
    , mapRL
    , lengthRL
    , nullFL
    )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, extractHash )

import Darcs.Util.Tree( Tree, emptyTree )

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.Ssh ( resetSshConnections )
import Darcs.Util.Printer ( Doc, ($$), 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
    -> SetDefault
    -> InheritDefault
    -> [MatchFlag]
    -> RepoFormat
    -> WithWorkingDir
    -> WithPatchIndex   -- use patch index
    -> Bool   -- use packs
    -> ForgetParent
    -> WithPrefsTemplates
    -> IO ()
cloneRepository :: String
-> String
-> Verbosity
-> UseCache
-> CloneKind
-> UMask
-> RemoteDarcs
-> SetScriptsExecutable
-> SetDefault
-> InheritDefault
-> [MatchFlag]
-> RepoFormat
-> WithWorkingDir
-> WithPatchIndex
-> Bool
-> ForgetParent
-> WithPrefsTemplates
-> IO ()
cloneRepository String
repourl String
mysimplename Verbosity
v UseCache
useCache CloneKind
cloneKind UMask
um RemoteDarcs
rdarcs SetScriptsExecutable
sse
                SetDefault
setDefault InheritDefault
inheritDefault [MatchFlag]
matchFlags RepoFormat
rfsource WithWorkingDir
withWorkingDir
                WithPatchIndex
usePatchIndex Bool
usePacks ForgetParent
forget WithPrefsTemplates
withPrefsTemplates =
  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 _toRepo <-
        PatchFormat
-> WithWorkingDir
-> WithPatchIndex
-> UseCache
-> WithPrefsTemplates
-> 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 WithPrefsTemplates
withPrefsTemplates
      debugMessage "Finished initializing new repository."
      addRepoSource repourl NoDryRun setDefault inheritDefault False

      debugMessage "Identifying remote repository..."
      fromRepo <- identifyRepositoryFor Reading _toRepo useCache repourl
      let fromLoc = Repository 'RO p Origin Origin -> String
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String
repoLocation Repository 'RO p Origin Origin
fromRepo

      debugMessage "Copying prefs..."
      copyFileOrUrl (remoteDarcs rdarcs)
        (joinUrl [fromLoc, darcsdir, "prefs", "prefs"])
        (darcsdir </> "prefs/prefs") (MaxAge 600) `catchall` return ()

      debugMessage "Filtering remote sources..."
      cache <- filterRemoteCaches (repoCache fromRepo)
      _toRepo <- return $ modifyCache (const cache) _toRepo
      writeTextFile
        (darcsdir </> "prefs/sources")
        (unlines [show $ dropNonRepos cache])
      debugMessage $ "Considering sources:\n"++show (repoCache _toRepo)

      if formatHas HashedInventory (repoFormat fromRepo) then do
       debugMessage "Copying basic repository (hashed_inventory and pristine)"
       if usePacks && (not . isValidLocalPath) fromLoc
         then copyBasicRepoPacked    fromRepo _toRepo v rdarcs withWorkingDir
         else copyBasicRepoNotPacked fromRepo _toRepo v rdarcs withWorkingDir
       when (cloneKind /= LazyClone) $ do
         when (cloneKind /= CompleteClone) $
           putInfo v $ text "Copying patches, to get lazy repository hit ctrl-C..."
         debugMessage "Copying complete repository (inventories and patches)"
         if usePacks && (not . isValidLocalPath) fromLoc
           then copyCompleteRepoPacked    fromRepo _toRepo v cloneKind
           else copyCompleteRepoNotPacked fromRepo _toRepo v cloneKind
      else
       -- old-fashioned repositories are cloned differently since
       -- we need to copy all patches first and then build pristine
       copyRepoOldFashioned fromRepo _toRepo v withWorkingDir
      when (sse == YesSetScriptsExecutable) setAllScriptsExecutable
      case patchSetMatch matchFlags of
       Maybe PatchSetMatch
Nothing -> () -> IO ()
forall a. a -> IO a
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
        _toRepo <- Repository 'RO p Origin Origin
-> IO (Repository 'RW p Origin Origin)
forall (p :: * -> * -> *) wU wR.
RepoPatch p =>
Repository 'RO p wU wR -> IO (Repository 'RW p wU wR)
revertRepositoryChanges Repository 'RO p Origin Origin
_toRepo
        patches <- readPatches _toRepo
        Sealed context <- getOnePatchset _toRepo psm
        to_remove :\/: only_in_context <- return $ findUncommon patches context
        case only_in_context of
          FL (PatchInfoAnd p) wZ wX
NilFL -> do
            let num_to_remove :: Int
num_to_remove = FL (PatchInfoAnd p) wZ Origin -> Int
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL FL (PatchInfoAnd 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
""
              ]
            _toRepo <-
              Repository 'RW p Origin Origin
-> UpdatePending
-> FL (PatchInfoAnd p) wZ Origin
-> IO (Repository 'RW p Origin wZ)
forall (p :: * -> * -> *) wU wR wX.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR
-> UpdatePending
-> FL (PatchInfoAnd p) wX wR
-> IO (Repository 'RW p wU wX)
tentativelyRemovePatches Repository 'RW p Origin Origin
_toRepo UpdatePending
NoUpdatePending FL (PatchInfoAnd p) wZ Origin
to_remove
            _toRepo <- finalizeRepositoryChanges _toRepo NoDryRun
            runDefault (unapply to_remove) `catch` \(SomeException
e :: SomeException) ->
                String -> IO ()
forall a. String -> IO a
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)
            when (sse == YesSetScriptsExecutable) $ setScriptsExecutablePatches to_remove
          FL (PatchInfoAnd 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 a. String -> IO a
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 p) wZ wX -> Doc
forall wX wY. FL (PatchInfoAnd p) wX wY -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
description FL (PatchInfoAnd p) wZ wX
only_in_context
      when (forget == YesForgetParent) deleteSources
      -- check for unresolved conflicts
      patches <- readPatches _toRepo
      let conflicts = PatchSet p Origin Origin -> StandardResolution (PrimOf p) Origin
forall (p :: * -> * -> *) wX.
RepoPatch p =>
PatchSet p Origin wX -> StandardResolution (PrimOf p) wX
patchsetConflictResolutions PatchSet p Origin Origin
patches
      _ <- announceConflicts "clone" (YesAllowConflicts MarkConflicts) conflicts
      Sealed mangled_res <- return $ mangled conflicts
      unless (nullFL mangled_res) $
        withSignalsBlocked $ void $ applyToWorking _toRepo v mangled_res

putInfo :: Verbosity -> Doc -> IO ()
putInfo :: Verbosity -> Doc -> IO ()
putInfo Verbosity
Quiet Doc
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
putInfo Verbosity
_ Doc
d = Doc -> IO ()
putDocLn 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

copyBasicRepoNotPacked  :: forall p wU wR.
                           Repository 'RO p wU wR -- remote
                        -> Repository 'RO p wU wR -- existing empty local
                        -> Verbosity
                        -> RemoteDarcs
                        -> WithWorkingDir
                        -> IO ()
copyBasicRepoNotPacked :: forall (p :: * -> * -> *) wU wR.
Repository 'RO p wU wR
-> Repository 'RO p wU wR
-> Verbosity
-> RemoteDarcs
-> WithWorkingDir
-> IO ()
copyBasicRepoNotPacked Repository 'RO p wU wR
fromRepo Repository 'RO p wU wR
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 'RO p wU wR -> RemoteDarcs -> String -> IO ()
forall (p :: * -> * -> *) wU wR.
Repository 'RO p wU wR -> RemoteDarcs -> String -> IO ()
copyHashedInventory Repository 'RO p wU wR
toRepo RemoteDarcs
rdarcs (Repository 'RO p wU wR -> String
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String
repoLocation Repository 'RO p wU wR
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 'RO p wU wR -> String -> WithWorkingDir -> IO ()
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String -> WithWorkingDir -> IO ()
createPristineDirectoryTree Repository 'RO p wU wR
toRepo String
"." WithWorkingDir
withWorkingDir

copyCompleteRepoNotPacked :: forall rt p wU wR. (RepoPatch p, ApplyState p ~ Tree)
                        => Repository 'RO p wU wR -- remote
                        -> Repository rt p wU wR -- existing basic local
                        -> Verbosity
                        -> CloneKind
                        -> IO ()
copyCompleteRepoNotPacked :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RO p wU wR
-> Repository rt p wU wR -> Verbosity -> CloneKind -> IO ()
copyCompleteRepoNotPacked Repository 'RO p wU wR
_ Repository rt p wU wR
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 wU wR -> IO ()
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO ()
fetchPatchesIfNecessary Repository rt p wU wR
toRepo
         pi <- String -> IO Bool
doesPatchIndexExist (Repository rt p wU wR -> String
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String
repoLocation Repository rt p wU wR
toRepo)
         ps <- readPatches toRepo
         when pi $ createPIWithInterrupt toRepo ps

copyBasicRepoPacked ::
  forall p wU wR.
     Repository 'RO p wU wR -- remote
  -> Repository 'RO p wU wR -- existing empty local repository
  -> Verbosity
  -> RemoteDarcs
  -> WithWorkingDir
  -> IO ()
copyBasicRepoPacked :: forall (p :: * -> * -> *) wU wR.
Repository 'RO p wU wR
-> Repository 'RO p wU wR
-> Verbosity
-> RemoteDarcs
-> WithWorkingDir
-> IO ()
copyBasicRepoPacked Repository 'RO p wU wR
fromRepo Repository 'RO p wU wR
toRepo Verbosity
verb RemoteDarcs
rdarcs WithWorkingDir
withWorkingDir =
  do let fromLoc :: String
fromLoc = Repository 'RO p wU wR -> String
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String
repoLocation Repository 'RO p wU wR
fromRepo
     let hashURL :: String
hashURL = [String] -> String
joinUrl [String
fromLoc, String
darcsdir, String
packsDir, String
"pristine"]
     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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing)
     let hiURL = String
fromLoc String -> String -> String
</> String
hashedInventoryPath
     i <- gzFetchFilePS hiURL Uncachable
     let currentHash = String -> ByteString
BC.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ PristineHash -> String
forall h. ValidHash h => h -> String
encodeValidHash (PristineHash -> String) -> PristineHash -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> PristineHash
peekPristineHash ByteString
i
     let copyNormally = Repository 'RO p wU wR
-> Repository 'RO p wU wR
-> Verbosity
-> RemoteDarcs
-> WithWorkingDir
-> IO ()
forall (p :: * -> * -> *) wU wR.
Repository 'RO p wU wR
-> Repository 'RO p wU wR
-> Verbosity
-> RemoteDarcs
-> WithWorkingDir
-> IO ()
copyBasicRepoNotPacked Repository 'RO p wU wR
fromRepo Repository 'RO p wU wR
toRepo Verbosity
verb RemoteDarcs
rdarcs WithWorkingDir
withWorkingDir
     case mPackHash of
      Just ByteString
packHash | ByteString
packHash ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
currentHash
              -> ( do Repository 'RO p wU wR
-> Repository 'RO p wU wR -> Verbosity -> WithWorkingDir -> IO ()
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository 'RO p wU wR
-> Repository rt p wU wR -> Verbosity -> WithWorkingDir -> IO ()
copyBasicRepoPacked2 Repository 'RO p wU wR
fromRepo Repository 'RO p wU wR
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 'RO p wU wR -> RemoteDarcs -> String -> IO ()
forall (p :: * -> * -> *) wU wR.
Repository 'RO p wU wR -> RemoteDarcs -> String -> IO ()
copyHashedInventory Repository 'RO p wU wR
toRepo RemoteDarcs
rdarcs (Repository 'RO p wU wR -> String
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String
repoLocation Repository 'RO p wU wR
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 wU wR.
     Repository 'RO p wU wR -- remote
  -> Repository rt p wU wR -- existing empty local repository
  -> Verbosity
  -> WithWorkingDir
  -> IO ()
copyBasicRepoPacked2 :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository 'RO p wU wR
-> Repository rt p wU wR -> Verbosity -> WithWorkingDir -> IO ()
copyBasicRepoPacked2 Repository 'RO p wU wR
fromRepo Repository rt p wU wR
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
pristineDirPath
  String -> IO ()
removeFile String
hashedInventoryPath
  Cache -> String -> IO ()
fetchAndUnpackBasic (Repository rt p wU wR -> Cache
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache Repository rt p wU wR
toRepo) (Repository 'RO p wU wR -> String
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String
repoLocation Repository 'RO p wU wR
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 wU wR -> String -> WithWorkingDir -> IO ()
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String -> WithWorkingDir -> IO ()
createPristineDirectoryTree Repository rt p wU wR
toRepo String
"." WithWorkingDir
withWorkingDir

copyCompleteRepoPacked ::
  forall rt p wU wR. (RepoPatch p, ApplyState p ~ Tree)
  => Repository 'RO p wU wR -- remote
  -> Repository rt p wU wR -- existing basic local repository
  -> Verbosity
  -> CloneKind
  -> IO ()
copyCompleteRepoPacked :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RO p wU wR
-> Repository rt p wU wR -> Verbosity -> CloneKind -> IO ()
copyCompleteRepoPacked Repository 'RO p wU wR
from Repository rt p wU wR
to Verbosity
verb CloneKind
cloneKind =
    Repository 'RO p wU wR
-> Repository rt p wU wR -> Verbosity -> CloneKind -> IO ()
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RO p wU wR
-> Repository rt p wU wR -> Verbosity -> CloneKind -> IO ()
copyCompleteRepoPacked2 Repository 'RO p wU wR
from Repository rt p wU wR
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 'RO p wU wR
-> Repository rt p wU wR -> Verbosity -> CloneKind -> IO ()
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RO p wU wR
-> Repository rt p wU wR -> Verbosity -> CloneKind -> IO ()
copyCompleteRepoNotPacked Repository 'RO p wU wR
from Repository rt p wU wR
to Verbosity
verb CloneKind
cloneKind

copyCompleteRepoPacked2 ::
  forall rt p wU wR. (RepoPatch p, ApplyState p ~ Tree)
  => Repository 'RO p wU wR
  -> Repository rt p wU wR
  -> Verbosity
  -> CloneKind
  -> IO ()
copyCompleteRepoPacked2 :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RO p wU wR
-> Repository rt p wU wR -> Verbosity -> CloneKind -> IO ()
copyCompleteRepoPacked2 Repository 'RO p wU wR
fromRepo Repository rt p wU wR
toRepo Verbosity
verb CloneKind
cloneKind = do
  us <- Repository rt p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatches Repository rt p wU wR
toRepo
  -- get old patches
  let 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."
  allowCtrlC cloneKind cleanup $ do
    putVerbose verb $ text "Using patches pack."
    is <-
      forM (patchSetInventoryHashes us) $
        maybe (fail "unexpected unhashed inventory") return
    hs <-
      forM (mapRL hashedPatchHash $ patchSet2RL us) $
        maybe (fail "unexpected unhashed patch") return
    fetchAndUnpackPatches is hs (repoCache toRepo) (repoLocation fromRepo)
    pi <- doesPatchIndexExist (repoLocation toRepo)
    when pi $ createPIWithInterrupt toRepo us -- TODO or do another readPatches?

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 p wU wR. (RepoPatch p, ApplyState p ~ Tree)
                        => Repository 'RO p wU wR  -- remote repo
                        -> Repository 'RO p Origin Origin -- local empty repo
                        -> Verbosity
                        -> WithWorkingDir
                        -> IO ()
copyRepoOldFashioned :: forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RO p wU wR
-> Repository 'RO p Origin Origin
-> Verbosity
-> WithWorkingDir
-> IO ()
copyRepoOldFashioned Repository 'RO p wU wR
fromRepo Repository 'RO p Origin Origin
_toRepo Verbosity
verb WithWorkingDir
withWorkingDir = do
  _toRepo <- Repository 'RO p Origin Origin
-> IO (Repository 'RW p Origin Origin)
forall (p :: * -> * -> *) wU wR.
RepoPatch p =>
Repository 'RO p wU wR -> IO (Repository 'RW p wU wR)
revertRepositoryChanges Repository 'RO p Origin Origin
_toRepo
  _ <- writePristine _toRepo emptyTree
  patches <- readPatches fromRepo
  let k = String
"Copying patch"
  beginTedious k
  tediousSize k (lengthRL $ patchSet2RL patches)
  let patches' = String -> PatchSet p Origin wR -> PatchSet p Origin wR
forall (p :: * -> * -> *) wStart wX.
String -> PatchSet p wStart wX -> PatchSet p wStart wX
progressPatchSet String
k PatchSet p Origin wR
patches
  writeTentativeInventory _toRepo patches'
  endTedious k
  local_patches <- readPatches _toRepo
  let patchesToApply = String
-> FL (PatchInfoAnd p) Origin Origin
-> FL (PatchInfoAnd p) Origin Origin
forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL String
"Applying patch" (FL (PatchInfoAnd p) Origin Origin
 -> FL (PatchInfoAnd p) Origin Origin)
-> FL (PatchInfoAnd p) Origin Origin
-> FL (PatchInfoAnd p) Origin Origin
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin Origin -> FL (PatchInfoAnd p) Origin Origin
forall (p :: * -> * -> *) wStart wX.
PatchSet p wStart wX -> FL (PatchInfoAnd p) wStart wX
patchSet2FL PatchSet p Origin Origin
local_patches
  applyToTentativePristine _toRepo (mkInvertible patchesToApply)
  _toRepo <- finalizeRepositoryChanges _toRepo NoDryRun
  putVerbose verb $ text "Writing the working tree..."
  createPristineDirectoryTree _toRepo "." withWorkingDir

-- | This function fetches all patches that the given repository has
--   with fetchFileUsingCache.
fetchPatchesIfNecessary :: forall rt p wU wR. RepoPatch p
                        => Repository rt p wU wR
                        -> IO ()
fetchPatchesIfNecessary :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO ()
fetchPatchesIfNecessary Repository rt p wU wR
toRepo =
  do  ps <- Repository rt p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatches Repository rt p wU wR
toRepo
      let patches = PatchSet p Origin wR -> RL (PatchInfoAnd p) Origin wR
forall (p :: * -> * -> *) wStart wX.
PatchSet p wStart wX -> RL (PatchInfoAnd p) wStart wX
patchSet2RL PatchSet p Origin wR
ps
          ppatches = String
-> RL (PatchInfoAnd p) Origin wR -> RL (PatchInfoAnd p) Origin wR
forall (p :: * -> * -> *) wX wY.
String -> RL (PatchInfoAnd p) wX wY -> RL (PatchInfoAnd p) wX wY
progressRLShowTags String
"Copying patches" RL (PatchInfoAnd p) Origin wR
patches
          (first, other) = splitAt (100 - 1) $ tailErr $ hashes patches
          speculate = [] [PatchHash] -> [[PatchHash]] -> [[PatchHash]]
forall a. a -> [a] -> [a]
: [PatchHash]
first [PatchHash] -> [[PatchHash]] -> [[PatchHash]]
forall a. a -> [a] -> [a]
: (PatchHash -> [PatchHash]) -> [PatchHash] -> [[PatchHash]]
forall a b. (a -> b) -> [a] -> [b]
map (PatchHash -> [PatchHash] -> [PatchHash]
forall a. a -> [a] -> [a]
:[]) [PatchHash]
other
      mapM_ fetchAndSpeculate $ zip (hashes ppatches) (speculate ++ repeat [])
  where hashes :: forall wX wY . RL (PatchInfoAnd p) wX wY -> [PatchHash]
        hashes :: forall wX wY. RL (PatchInfoAnd p) wX wY -> [PatchHash]
hashes = [Maybe PatchHash] -> [PatchHash]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe PatchHash] -> [PatchHash])
-> (RL (PatchInfoAnd p) wX wY -> [Maybe PatchHash])
-> RL (PatchInfoAnd p) wX wY
-> [PatchHash]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall wW wZ. PatchInfoAnd p wW wZ -> Maybe PatchHash)
-> RL (PatchInfoAnd p) wX wY -> [Maybe PatchHash]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> RL a wX wY -> [b]
mapRL PatchInfoAnd p wW wZ -> Maybe PatchHash
forall wW wZ. PatchInfoAnd p wW wZ -> Maybe PatchHash
forall (p :: * -> * -> *) wA wB.
PatchInfoAnd p wA wB -> Maybe PatchHash
hashedPatchHash
        fetchAndSpeculate :: (PatchHash, [PatchHash]) -> IO ()
        fetchAndSpeculate :: (PatchHash, [PatchHash]) -> IO ()
fetchAndSpeculate (PatchHash
f, [PatchHash]
ss) = do
          _ <- Cache -> PatchHash -> IO (String, ByteString)
forall h. ValidHash h => Cache -> h -> IO (String, ByteString)
fetchFileUsingCache Cache
c PatchHash
f
          mapM_ (speculateFileUsingCache c) ss
        c :: Cache
c = Repository rt p wU wR -> Cache
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache Repository rt p wU wR
toRepo

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` do
    String -> IO ()
debugMessage String
"Cleanup after SIGINT in allowCtrlC"
    -- the SIGINT has also killed our running ssh connections,
    -- this will cause them to be restarted
    IO ()
resetSshConnections
    IO ()
cleanup

hashedPatchHash :: PatchInfoAnd p wA wB -> Maybe PatchHash
hashedPatchHash :: forall (p :: * -> * -> *) wA wB.
PatchInfoAnd p wA wB -> Maybe PatchHash
hashedPatchHash = (Named p wA wB -> Maybe PatchHash)
-> (PatchHash -> Maybe PatchHash)
-> Either (Named p wA wB) PatchHash
-> Maybe PatchHash
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe PatchHash -> Named p wA wB -> Maybe PatchHash
forall a b. a -> b -> a
const Maybe PatchHash
forall a. Maybe a
Nothing) PatchHash -> Maybe PatchHash
forall a. a -> Maybe a
Just (Either (Named p wA wB) PatchHash -> Maybe PatchHash)
-> (PatchInfoAnd p wA wB -> Either (Named p wA wB) PatchHash)
-> PatchInfoAnd p wA wB
-> Maybe PatchHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd p wA wB -> Either (Named p wA wB) PatchHash
forall (p :: * -> * -> *) wA wB.
PatchInfoAndG p wA wB -> Either (p wA wB) PatchHash
extractHash