never executed always true always false
    1 {-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-}
    2 module Distribution.Client.VCS (
    3     -- * VCS driver type
    4     VCS,
    5     vcsRepoType,
    6     vcsProgram,
    7     -- ** Type re-exports
    8     RepoType,
    9     Program,
   10     ConfiguredProgram,
   11 
   12     -- * Validating 'SourceRepo's and configuring VCS drivers
   13     validatePDSourceRepo,
   14     validateSourceRepo,
   15     validateSourceRepos,
   16     SourceRepoProblem(..),
   17     configureVCS,
   18     configureVCSs,
   19 
   20     -- * Running the VCS driver
   21     cloneSourceRepo,
   22     syncSourceRepos,
   23 
   24     -- * The individual VCS drivers
   25     knownVCSs,
   26     vcsBzr,
   27     vcsDarcs,
   28     vcsGit,
   29     vcsHg,
   30     vcsSvn,
   31     vcsPijul,
   32   ) where
   33 
   34 import Prelude ()
   35 import Distribution.Client.Compat.Prelude
   36 
   37 import Distribution.Types.SourceRepo
   38          ( RepoType(..), KnownRepoType (..) )
   39 import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..), srpToProxy)
   40 import Distribution.Client.RebuildMonad
   41          ( Rebuild, monitorFiles, MonitorFilePath, monitorDirectoryExistence )
   42 import Distribution.Verbosity as Verbosity
   43          ( normal )
   44 import Distribution.Simple.Program
   45          ( Program(programFindVersion)
   46          , ConfiguredProgram(programVersion)
   47          , simpleProgram, findProgramVersion
   48          , ProgramInvocation(..), programInvocation, runProgramInvocation
   49          , emptyProgramDb, requireProgram )
   50 import Distribution.Version
   51          ( mkVersion )
   52 import qualified Distribution.PackageDescription as PD
   53 
   54 import Control.Monad.Trans
   55          ( liftIO )
   56 import qualified Data.Char as Char
   57 import qualified Data.Map  as Map
   58 import System.FilePath
   59          ( takeDirectory )
   60 import System.Directory
   61          ( doesDirectoryExist )
   62 
   63 
   64 -- | A driver for a version control system, e.g. git, darcs etc.
   65 --
   66 data VCS program = VCS {
   67        -- | The type of repository this driver is for.
   68        vcsRepoType  :: RepoType,
   69 
   70        -- | The vcs program itself.
   71        -- This is used at type 'Program' and 'ConfiguredProgram'.
   72        vcsProgram   :: program,
   73 
   74        -- | The program invocation(s) to get\/clone a repository into a fresh
   75        -- local directory.
   76        vcsCloneRepo :: forall f. Verbosity
   77                     -> ConfiguredProgram
   78                     -> SourceRepositoryPackage f
   79                     -> FilePath   -- Source URI
   80                     -> FilePath   -- Destination directory
   81                     -> [ProgramInvocation],
   82 
   83        -- | The program invocation(s) to synchronise a whole set of /related/
   84        -- repositories with corresponding local directories. Also returns the
   85        -- files that the command depends on, for change monitoring.
   86        vcsSyncRepos :: forall f. Verbosity
   87                     -> ConfiguredProgram
   88                     -> [(SourceRepositoryPackage f, FilePath)]
   89                     -> IO [MonitorFilePath]
   90      }
   91 
   92 
   93 -- ------------------------------------------------------------
   94 -- * Selecting repos and drivers
   95 -- ------------------------------------------------------------
   96 
   97 data SourceRepoProblem = SourceRepoRepoTypeUnspecified
   98                        | SourceRepoRepoTypeUnsupported (SourceRepositoryPackage Proxy) RepoType
   99                        | SourceRepoLocationUnspecified
  100   deriving Show
  101 
  102 -- | Validates that the 'SourceRepo' specifies a location URI and a repository
  103 -- type that is supported by a VCS driver.
  104 --
  105 -- | It also returns the 'VCS' driver we should use to work with it.
  106 --
  107 validateSourceRepo
  108     :: SourceRepositoryPackage f
  109     -> Either SourceRepoProblem (SourceRepositoryPackage f, String, RepoType, VCS Program)
  110 validateSourceRepo = \repo -> do
  111     let rtype = srpType repo
  112     vcs   <- Map.lookup rtype knownVCSs  ?! SourceRepoRepoTypeUnsupported (srpToProxy repo) rtype
  113     let uri = srpLocation repo
  114     return (repo, uri, rtype, vcs)
  115   where
  116     a ?! e = maybe (Left e) Right a
  117 
  118 validatePDSourceRepo
  119     :: PD.SourceRepo
  120     -> Either SourceRepoProblem (SourceRepoMaybe, String, RepoType, VCS Program)
  121 validatePDSourceRepo repo = do
  122     rtype <- PD.repoType repo      ?! SourceRepoRepoTypeUnspecified
  123     uri   <- PD.repoLocation repo  ?! SourceRepoLocationUnspecified
  124     validateSourceRepo SourceRepositoryPackage
  125         { srpType     = rtype
  126         , srpLocation = uri
  127         , srpTag      = PD.repoTag repo
  128         , srpBranch   = PD.repoBranch repo
  129         , srpSubdir   = PD.repoSubdir repo
  130         , srpCommand  = mempty
  131         }
  132   where
  133     a ?! e = maybe (Left e) Right a
  134 
  135 
  136 
  137 -- | As 'validateSourceRepo' but for a bunch of 'SourceRepo's, and return
  138 -- things in a convenient form to pass to 'configureVCSs', or to report
  139 -- problems.
  140 --
  141 validateSourceRepos :: [SourceRepositoryPackage f]
  142                     -> Either [(SourceRepositoryPackage f, SourceRepoProblem)]
  143                               [(SourceRepositoryPackage f, String, RepoType, VCS Program)]
  144 validateSourceRepos rs =
  145     case partitionEithers (map validateSourceRepo' rs) of
  146       (problems@(_:_), _) -> Left problems
  147       ([], vcss)          -> Right vcss
  148   where
  149     validateSourceRepo' r = either (Left . (,) r) Right
  150                                    (validateSourceRepo r)
  151 
  152 
  153 configureVCS :: Verbosity
  154              -> VCS Program
  155              -> IO (VCS ConfiguredProgram)
  156 configureVCS verbosity vcs@VCS{vcsProgram = prog} =
  157     asVcsConfigured <$> requireProgram verbosity prog emptyProgramDb
  158   where
  159     asVcsConfigured (prog', _) = vcs { vcsProgram = prog' }
  160 
  161 configureVCSs :: Verbosity
  162               -> Map RepoType (VCS Program)
  163               -> IO (Map RepoType (VCS ConfiguredProgram))
  164 configureVCSs verbosity = traverse (configureVCS verbosity)
  165 
  166 
  167 -- ------------------------------------------------------------
  168 -- * Running the driver
  169 -- ------------------------------------------------------------
  170 
  171 -- | Clone a single source repo into a fresh directory, using a configured VCS.
  172 --
  173 -- This is for making a new copy, not synchronising an existing copy. It will
  174 -- fail if the destination directory already exists.
  175 --
  176 -- Make sure to validate the 'SourceRepo' using 'validateSourceRepo' first.
  177 --
  178 
  179 cloneSourceRepo
  180     :: Verbosity
  181     -> VCS ConfiguredProgram
  182     -> SourceRepositoryPackage f
  183     -> [Char]
  184     -> IO ()
  185 cloneSourceRepo verbosity vcs
  186                 repo@SourceRepositoryPackage{ srpLocation = srcuri } destdir =
  187     traverse_ (runProgramInvocation verbosity) invocations
  188   where
  189     invocations = vcsCloneRepo vcs verbosity
  190                                (vcsProgram vcs) repo
  191                                srcuri destdir
  192 
  193 
  194 -- | Syncronise a set of 'SourceRepo's referring to the same repository with
  195 -- corresponding local directories. The local directories may or may not
  196 -- already exist.
  197 --
  198 -- The 'SourceRepo' values used in a single invocation of 'syncSourceRepos',
  199 -- or used across a series of invocations with any local directory must refer
  200 -- to the /same/ repository. That means it must be the same location but they
  201 -- can differ in the branch, or tag or subdir.
  202 --
  203 -- The reason to allow multiple related 'SourceRepo's is to allow for the
  204 -- network or storage to be shared between different checkouts of the repo.
  205 -- For example if a single repo contains multiple packages in different subdirs
  206 -- and in some project it may make sense to use a different state of the repo
  207 -- for one subdir compared to another.
  208 --
  209 syncSourceRepos :: Verbosity
  210                 -> VCS ConfiguredProgram
  211                 -> [(SourceRepositoryPackage f, FilePath)]
  212                 -> Rebuild ()
  213 syncSourceRepos verbosity vcs repos = do
  214     files <- liftIO $ vcsSyncRepos vcs verbosity (vcsProgram vcs) repos
  215     monitorFiles files
  216 
  217 
  218 -- ------------------------------------------------------------
  219 -- * The various VCS drivers
  220 -- ------------------------------------------------------------
  221 
  222 -- | The set of all supported VCS drivers, organised by 'RepoType'.
  223 --
  224 knownVCSs :: Map RepoType (VCS Program)
  225 knownVCSs = Map.fromList [ (vcsRepoType vcs, vcs) | vcs <- vcss ]
  226   where
  227     vcss = [ vcsBzr, vcsDarcs, vcsGit, vcsHg, vcsSvn ]
  228 
  229 
  230 -- | VCS driver for Bazaar.
  231 --
  232 vcsBzr :: VCS Program
  233 vcsBzr =
  234     VCS {
  235       vcsRepoType = KnownRepoType Bazaar,
  236       vcsProgram  = bzrProgram,
  237       vcsCloneRepo,
  238       vcsSyncRepos
  239     }
  240   where
  241     vcsCloneRepo :: Verbosity
  242                  -> ConfiguredProgram
  243                  -> SourceRepositoryPackage f
  244                  -> FilePath
  245                  -> FilePath
  246                  -> [ProgramInvocation]
  247     vcsCloneRepo verbosity prog repo srcuri destdir =
  248         [ programInvocation prog
  249             ([branchCmd, srcuri, destdir] ++ tagArgs ++ verboseArg) ]
  250       where
  251         -- The @get@ command was deprecated in version 2.4 in favour of
  252         -- the alias @branch@
  253         branchCmd | programVersion prog >= Just (mkVersion [2,4])
  254                               = "branch"
  255                   | otherwise = "get"
  256 
  257         tagArgs = case srpTag repo of
  258           Nothing  -> []
  259           Just tag -> ["-r", "tag:" ++ tag]
  260         verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
  261 
  262     vcsSyncRepos :: Verbosity -> ConfiguredProgram
  263                  -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath]
  264     vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for bzr"
  265 
  266 bzrProgram :: Program
  267 bzrProgram = (simpleProgram "bzr") {
  268     programFindVersion = findProgramVersion "--version" $ \str ->
  269       case words str of
  270         -- "Bazaar (bzr) 2.6.0\n  ... lots of extra stuff"
  271         (_:_:ver:_) -> ver
  272         _ -> ""
  273   }
  274 
  275 
  276 -- | VCS driver for Darcs.
  277 --
  278 vcsDarcs :: VCS Program
  279 vcsDarcs =
  280     VCS {
  281       vcsRepoType = KnownRepoType Darcs,
  282       vcsProgram  = darcsProgram,
  283       vcsCloneRepo,
  284       vcsSyncRepos
  285     }
  286   where
  287     vcsCloneRepo :: Verbosity
  288                  -> ConfiguredProgram
  289                  -> SourceRepositoryPackage f
  290                  -> FilePath
  291                  -> FilePath
  292                  -> [ProgramInvocation]
  293     vcsCloneRepo verbosity prog repo srcuri destdir =
  294         [ programInvocation prog cloneArgs ]
  295       where
  296         cloneArgs  = [cloneCmd, srcuri, destdir] ++ tagArgs ++ verboseArg
  297         -- At some point the @clone@ command was introduced as an alias for
  298         -- @get@, and @clone@ seems to be the recommended one now.
  299         cloneCmd   | programVersion prog >= Just (mkVersion [2,8])
  300                                = "clone"
  301                    | otherwise = "get"
  302         tagArgs    = case srpTag repo of
  303           Nothing  -> []
  304           Just tag -> ["-t", tag]
  305         verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
  306 
  307     vcsSyncRepos :: Verbosity -> ConfiguredProgram
  308                  -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath]
  309     vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for darcs"
  310 
  311 darcsProgram :: Program
  312 darcsProgram = (simpleProgram "darcs") {
  313     programFindVersion = findProgramVersion "--version" $ \str ->
  314       case words str of
  315         -- "2.8.5 (release)"
  316         (ver:_) -> ver
  317         _ -> ""
  318   }
  319 
  320 
  321 -- | VCS driver for Git.
  322 --
  323 vcsGit :: VCS Program
  324 vcsGit =
  325     VCS {
  326       vcsRepoType = KnownRepoType Git,
  327       vcsProgram  = gitProgram,
  328       vcsCloneRepo,
  329       vcsSyncRepos
  330     }
  331   where
  332     vcsCloneRepo :: Verbosity
  333                  -> ConfiguredProgram
  334                  -> SourceRepositoryPackage f
  335                  -> FilePath
  336                  -> FilePath
  337                  -> [ProgramInvocation]
  338     vcsCloneRepo verbosity prog repo srcuri destdir =
  339         [ programInvocation prog cloneArgs ]
  340         -- And if there's a tag, we have to do that in a second step:
  341      ++ [ (programInvocation prog (checkoutArgs tag)) {
  342             progInvokeCwd = Just destdir
  343           }
  344         | tag <- maybeToList (srpTag repo) ]
  345       where
  346         cloneArgs  = ["clone", srcuri, destdir]
  347                      ++ branchArgs ++ verboseArg
  348         branchArgs = case srpBranch repo of
  349           Just b  -> ["--branch", b]
  350           Nothing -> []
  351         checkoutArgs tag = "checkout" : verboseArg ++ [tag, "--"]
  352         verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
  353 
  354     vcsSyncRepos :: Verbosity
  355                  -> ConfiguredProgram
  356                  -> [(SourceRepositoryPackage f, FilePath)]
  357                  -> IO [MonitorFilePath]
  358     vcsSyncRepos _ _ [] = return []
  359     vcsSyncRepos verbosity gitProg
  360                  ((primaryRepo, primaryLocalDir) : secondaryRepos) = do
  361 
  362       vcsSyncRepo verbosity gitProg primaryRepo primaryLocalDir Nothing
  363       sequence_
  364         [ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir)
  365         | (repo, localDir) <- secondaryRepos ]
  366       return [ monitorDirectoryExistence dir
  367              | dir <- (primaryLocalDir : map snd secondaryRepos) ]
  368 
  369     vcsSyncRepo verbosity gitProg SourceRepositoryPackage{..} localDir peer = do
  370         exists <- doesDirectoryExist localDir
  371         if exists
  372           then git localDir                 ["fetch"]
  373           else git (takeDirectory localDir) cloneArgs
  374         git localDir checkoutArgs
  375       where
  376         git :: FilePath -> [String] -> IO ()
  377         git cwd args = runProgramInvocation verbosity $
  378                          (programInvocation gitProg args) {
  379                            progInvokeCwd = Just cwd
  380                          }
  381 
  382         cloneArgs      = ["clone", "--no-checkout", loc, localDir]
  383                       ++ case peer of
  384                            Nothing           -> []
  385                            Just peerLocalDir -> ["--reference", peerLocalDir]
  386                       ++ verboseArg
  387                          where loc = srpLocation
  388         checkoutArgs   = "checkout" : verboseArg ++ ["--detach", "--force"
  389                          , checkoutTarget, "--" ]
  390         checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag)
  391         verboseArg     = [ "--quiet" | verbosity < Verbosity.normal ]
  392 
  393 gitProgram :: Program
  394 gitProgram = (simpleProgram "git") {
  395     programFindVersion = findProgramVersion "--version" $ \str ->
  396       case words str of
  397         -- "git version 2.5.5"
  398         (_:_:ver:_) | all isTypical ver -> ver
  399 
  400         -- or annoyingly "git version 2.17.1.windows.2" yes, really
  401         (_:_:ver:_) -> intercalate "."
  402                      . takeWhile (all isNum)
  403                      . split
  404                      $ ver
  405         _ -> ""
  406   }
  407   where
  408     isNum     c = c >= '0' && c <= '9'
  409     isTypical c = isNum c || c == '.'
  410     split    cs = case break (=='.') cs of
  411                     (chunk,[])     -> chunk : []
  412                     (chunk,_:rest) -> chunk : split rest
  413 
  414 -- | VCS driver for Mercurial.
  415 --
  416 vcsHg :: VCS Program
  417 vcsHg =
  418     VCS {
  419       vcsRepoType = KnownRepoType Mercurial,
  420       vcsProgram  = hgProgram,
  421       vcsCloneRepo,
  422       vcsSyncRepos
  423     }
  424   where
  425     vcsCloneRepo :: Verbosity
  426                  -> ConfiguredProgram
  427                  -> SourceRepositoryPackage f
  428                  -> FilePath
  429                  -> FilePath
  430                  -> [ProgramInvocation]
  431     vcsCloneRepo verbosity prog repo srcuri destdir =
  432         [ programInvocation prog cloneArgs ]
  433       where
  434         cloneArgs  = ["clone", srcuri, destdir]
  435                      ++ branchArgs ++ tagArgs ++ verboseArg
  436         branchArgs = case srpBranch repo of
  437           Just b  -> ["--branch", b]
  438           Nothing -> []
  439         tagArgs = case srpTag repo of
  440           Just t  -> ["--rev", t]
  441           Nothing -> []
  442         verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
  443 
  444     vcsSyncRepos :: Verbosity
  445                  -> ConfiguredProgram
  446                  -> [(SourceRepositoryPackage f, FilePath)]
  447                  -> IO [MonitorFilePath]
  448     vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for hg"
  449 
  450 hgProgram :: Program
  451 hgProgram = (simpleProgram "hg") {
  452     programFindVersion = findProgramVersion "--version" $ \str ->
  453       case words str of
  454         -- Mercurial Distributed SCM (version 3.5.2)\n ... long message
  455         (_:_:_:_:ver:_) -> takeWhile (\c -> Char.isDigit c || c == '.') ver
  456         _ -> ""
  457   }
  458 
  459 
  460 -- | VCS driver for Subversion.
  461 --
  462 vcsSvn :: VCS Program
  463 vcsSvn =
  464     VCS {
  465       vcsRepoType = KnownRepoType SVN,
  466       vcsProgram  = svnProgram,
  467       vcsCloneRepo,
  468       vcsSyncRepos
  469     }
  470   where
  471     vcsCloneRepo :: Verbosity
  472                  -> ConfiguredProgram
  473                  -> SourceRepositoryPackage f
  474                  -> FilePath
  475                  -> FilePath
  476                  -> [ProgramInvocation]
  477     vcsCloneRepo verbosity prog _repo srcuri destdir =
  478         [ programInvocation prog checkoutArgs ]
  479       where
  480         checkoutArgs = ["checkout", srcuri, destdir] ++ verboseArg
  481         verboseArg   = [ "--quiet" | verbosity < Verbosity.normal ]
  482         --TODO: branch or tag?
  483 
  484     vcsSyncRepos :: Verbosity
  485                  -> ConfiguredProgram
  486                  -> [(SourceRepositoryPackage f, FilePath)]
  487                  -> IO [MonitorFilePath]
  488     vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for svn"
  489 
  490 svnProgram :: Program
  491 svnProgram = (simpleProgram "svn") {
  492     programFindVersion = findProgramVersion "--version" $ \str ->
  493       case words str of
  494         -- svn, version 1.9.4 (r1740329)\n ... long message
  495         (_:_:ver:_) -> ver
  496         _ -> ""
  497   }
  498 
  499 
  500 -- | VCS driver for Pijul.
  501 -- Documentation for Pijul can be found at <https://pijul.org/manual/introduction.html>
  502 --
  503 -- 2020-04-09 Oleg:
  504 --
  505 --    As far as I understand pijul, there are branches and "tags" in pijul,
  506 --    but there aren't a "commit hash" identifying an arbitrary state.
  507 --
  508 --    One can create `a pijul tag`, which will make a patch hash,
  509 --    which depends on everything currently in the repository.
  510 --    I guess if you try to apply that patch, you'll be forced to apply
  511 --    all the dependencies too. In other words, there are no named tags.
  512 --
  513 --    It's not clear to me whether there is an option to
  514 --    "apply this patch *and* all of its dependencies".
  515 --    And relatedly, whether how to make sure that there are no other
  516 --    patches applied.
  517 --
  518 --    With branches it's easier, as you can `pull` and `checkout` them,
  519 --    and they seem to be similar enough. Yet, pijul documentations says
  520 --
  521 --    > Note that the purpose of branches in Pijul is quite different from Git,
  522 --      since Git's "feature branches" can usually be implemented by just
  523 --      patches.
  524 --
  525 --    I guess it means that indeed instead of creating a branch and making PR
  526 --    in "GitHub" workflow, you'd just create a patch and offer it.
  527 --    You can do that with `git` too. Push (a branch with) commit to remote
  528 --    and ask other to cherry-pick that commit. Yet, in git identity of commit
  529 --    changes when it applied to other trees, where patches in pijul have
  530 --    will continue to have the same hash.
  531 --
  532 --    Unfortunately pijul doesn't talk about conflict resolution.
  533 --    It seems that you get something like:
  534 --
  535 --        % pijul status
  536 --        On branch merge
  537 --
  538 --        Unresolved conflicts:
  539 --          (fix conflicts and record the resolution with "pijul record ...")
  540 --
  541 --                foo
  542 --
  543 --        % cat foo
  544 --        first line
  545 --        >> >>>>>>>>>>>>>>>>>>>>>>>>>>>>>
  546 --        branch BBB
  547 --        ================================
  548 --        branch AAA
  549 --        <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  550 --        last line
  551 --
  552 --    And then the `pijul dependencies` would draw you a graph like
  553 --
  554 --
  555 --                    ----->  foo on branch B ----->
  556 --    resolve confict                                  Initial patch
  557 --                    ----->  foo on branch A ----->
  558 --
  559 --    Which is seems reasonable.
  560 --
  561 --    So currently, pijul support is very experimental, and most likely
  562 --    won't work, even the basics are in place. Tests are also written
  563 --    but disabled, as the branching model differs from `git` one,
  564 --    for which tests are written.
  565 --
  566 vcsPijul :: VCS Program
  567 vcsPijul =
  568     VCS {
  569       vcsRepoType = KnownRepoType Pijul,
  570       vcsProgram  = pijulProgram,
  571       vcsCloneRepo,
  572       vcsSyncRepos
  573     }
  574   where
  575     vcsCloneRepo :: Verbosity -- ^ it seems that pijul does not have verbose flag
  576                  -> ConfiguredProgram
  577                  -> SourceRepositoryPackage f
  578                  -> FilePath
  579                  -> FilePath
  580                  -> [ProgramInvocation]
  581     vcsCloneRepo _verbosity prog repo srcuri destdir =
  582         [ programInvocation prog cloneArgs ]
  583         -- And if there's a tag, we have to do that in a second step:
  584      ++ [ (programInvocation prog (checkoutArgs tag)) {
  585             progInvokeCwd = Just destdir
  586           }
  587         | tag <- maybeToList (srpTag repo) ]
  588       where
  589         cloneArgs  = ["clone", srcuri, destdir]
  590                      ++ branchArgs
  591         branchArgs = case srpBranch repo of
  592           Just b  -> ["--from-branch", b]
  593           Nothing -> []
  594         checkoutArgs tag = "checkout" : [tag] -- TODO: this probably doesn't work either
  595 
  596     vcsSyncRepos :: Verbosity
  597                  -> ConfiguredProgram
  598                  -> [(SourceRepositoryPackage f, FilePath)]
  599                  -> IO [MonitorFilePath]
  600     vcsSyncRepos _ _ [] = return []
  601     vcsSyncRepos verbosity pijulProg
  602                  ((primaryRepo, primaryLocalDir) : secondaryRepos) = do
  603 
  604       vcsSyncRepo verbosity pijulProg primaryRepo primaryLocalDir Nothing
  605       sequence_
  606         [ vcsSyncRepo verbosity pijulProg repo localDir (Just primaryLocalDir)
  607         | (repo, localDir) <- secondaryRepos ]
  608       return [ monitorDirectoryExistence dir
  609              | dir <- (primaryLocalDir : map snd secondaryRepos) ]
  610 
  611     vcsSyncRepo verbosity pijulProg SourceRepositoryPackage{..} localDir peer = do
  612         exists <- doesDirectoryExist localDir
  613         if exists
  614         then pijul localDir                 ["pull"] -- TODO: this probably doesn't work.
  615         else pijul (takeDirectory localDir) cloneArgs
  616         pijul localDir checkoutArgs
  617       where
  618         pijul :: FilePath -> [String] -> IO ()
  619         pijul cwd args = runProgramInvocation verbosity $
  620                          (programInvocation pijulProg args) {
  621                            progInvokeCwd = Just cwd
  622                          }
  623 
  624         cloneArgs      = ["clone", loc, localDir]
  625                       ++ case peer of
  626                            Nothing           -> []
  627                            Just peerLocalDir -> [peerLocalDir]
  628                          where loc = srpLocation
  629         checkoutArgs   = "checkout" :  ["--force", checkoutTarget, "--" ]
  630         checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) -- TODO: this is definitely wrong.
  631 
  632 pijulProgram :: Program
  633 pijulProgram = (simpleProgram "pijul") {
  634     programFindVersion = findProgramVersion "--version" $ \str ->
  635       case words str of
  636         -- "pijul 0.12.2
  637         (_:ver:_) | all isTypical ver -> ver
  638         _ -> ""
  639   }
  640   where
  641     isNum     c = c >= '0' && c <= '9'
  642     isTypical c = isNum c || c == '.'