VCS.hs

{-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-}
module Distribution.Client.VCS (
    -- * VCS driver type
    VCS,
    vcsRepoType,
    vcsProgram,
    -- ** Type re-exports
    RepoType,
    Program,
    ConfiguredProgram,

    -- * Validating 'SourceRepo's and configuring VCS drivers
    validatePDSourceRepo,
    validateSourceRepo,
    validateSourceRepos,
    SourceRepoProblem(..),
    configureVCS,
    configureVCSs,

    -- * Running the VCS driver
    cloneSourceRepo,
    syncSourceRepos,

    -- * The individual VCS drivers
    knownVCSs,
    vcsBzr,
    vcsDarcs,
    vcsGit,
    vcsHg,
    vcsSvn,
    vcsPijul,
  ) where

import Prelude ()
import Distribution.Client.Compat.Prelude

import Distribution.Types.SourceRepo
         ( RepoType(..), KnownRepoType (..) )
import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..), srpToProxy)
import Distribution.Client.RebuildMonad
         ( Rebuild, monitorFiles, MonitorFilePath, monitorDirectoryExistence )
import Distribution.Verbosity as Verbosity
         ( normal )
import Distribution.Simple.Program
         ( Program(programFindVersion)
         , ConfiguredProgram(programVersion)
         , simpleProgram, findProgramVersion
         , ProgramInvocation(..), programInvocation, runProgramInvocation
         , emptyProgramDb, requireProgram )
import Distribution.Version
         ( mkVersion )
import qualified Distribution.PackageDescription as PD

import Control.Monad.Trans
         ( liftIO )
import qualified Data.Char as Char
import qualified Data.Map  as Map
import System.FilePath
         ( takeDirectory )
import System.Directory
         ( doesDirectoryExist )


-- | A driver for a version control system, e.g. git, darcs etc.
--
data VCS program = VCS {
       -- | The type of repository this driver is for.
       vcsRepoType  :: RepoType,

       -- | The vcs program itself.
       -- This is used at type 'Program' and 'ConfiguredProgram'.
       vcsProgram   :: program,

       -- | The program invocation(s) to get\/clone a repository into a fresh
       -- local directory.
       vcsCloneRepo :: forall f. Verbosity
                    -> ConfiguredProgram
                    -> SourceRepositoryPackage f
                    -> FilePath   -- Source URI
                    -> FilePath   -- Destination directory
                    -> [ProgramInvocation],

       -- | The program invocation(s) to synchronise a whole set of /related/
       -- repositories with corresponding local directories. Also returns the
       -- files that the command depends on, for change monitoring.
       vcsSyncRepos :: forall f. Verbosity
                    -> ConfiguredProgram
                    -> [(SourceRepositoryPackage f, FilePath)]
                    -> IO [MonitorFilePath]
     }


-- ------------------------------------------------------------
-- * Selecting repos and drivers
-- ------------------------------------------------------------

data SourceRepoProblem = SourceRepoRepoTypeUnspecified
                       | SourceRepoRepoTypeUnsupported (SourceRepositoryPackage Proxy) RepoType
                       | SourceRepoLocationUnspecified
  deriving Show

-- | Validates that the 'SourceRepo' specifies a location URI and a repository
-- type that is supported by a VCS driver.
--
-- | It also returns the 'VCS' driver we should use to work with it.
--
validateSourceRepo
    :: SourceRepositoryPackage f
    -> Either SourceRepoProblem (SourceRepositoryPackage f, String, RepoType, VCS Program)
validateSourceRepo = \repo -> do
    let rtype = srpType repo
    vcs   <- Map.lookup rtype knownVCSs  ?! SourceRepoRepoTypeUnsupported (srpToProxy repo) rtype
    let uri = srpLocation repo
    return (repo, uri, rtype, vcs)
  where
    a ?! e = maybe (Left e) Right a

validatePDSourceRepo
    :: PD.SourceRepo
    -> Either SourceRepoProblem (SourceRepoMaybe, String, RepoType, VCS Program)
validatePDSourceRepo repo = do
    rtype <- PD.repoType repo      ?! SourceRepoRepoTypeUnspecified
    uri   <- PD.repoLocation repo  ?! SourceRepoLocationUnspecified
    validateSourceRepo SourceRepositoryPackage
        { srpType     = rtype
        , srpLocation = uri
        , srpTag      = PD.repoTag repo
        , srpBranch   = PD.repoBranch repo
        , srpSubdir   = PD.repoSubdir repo
        }
  where
    a ?! e = maybe (Left e) Right a



-- | As 'validateSourceRepo' but for a bunch of 'SourceRepo's, and return
-- things in a convenient form to pass to 'configureVCSs', or to report
-- problems.
--
validateSourceRepos :: [SourceRepositoryPackage f]
                    -> Either [(SourceRepositoryPackage f, SourceRepoProblem)]
                              [(SourceRepositoryPackage f, String, RepoType, VCS Program)]
validateSourceRepos rs =
    case partitionEithers (map validateSourceRepo' rs) of
      (problems@(_:_), _) -> Left problems
      ([], vcss)          -> Right vcss
  where
    validateSourceRepo' r = either (Left . (,) r) Right
                                   (validateSourceRepo r)


configureVCS :: Verbosity
             -> VCS Program
             -> IO (VCS ConfiguredProgram)
configureVCS verbosity vcs@VCS{vcsProgram = prog} =
    asVcsConfigured <$> requireProgram verbosity prog emptyProgramDb
  where
    asVcsConfigured (prog', _) = vcs { vcsProgram = prog' }

configureVCSs :: Verbosity
              -> Map RepoType (VCS Program)
              -> IO (Map RepoType (VCS ConfiguredProgram))
configureVCSs verbosity = traverse (configureVCS verbosity)


-- ------------------------------------------------------------
-- * Running the driver
-- ------------------------------------------------------------

-- | Clone a single source repo into a fresh directory, using a configured VCS.
--
-- This is for making a new copy, not synchronising an existing copy. It will
-- fail if the destination directory already exists.
--
-- Make sure to validate the 'SourceRepo' using 'validateSourceRepo' first.
--

cloneSourceRepo
    :: Verbosity
    -> VCS ConfiguredProgram
    -> SourceRepositoryPackage f
    -> [Char]
    -> IO ()
cloneSourceRepo verbosity vcs
                repo@SourceRepositoryPackage{ srpLocation = srcuri } destdir =
    traverse_ (runProgramInvocation verbosity) invocations
  where
    invocations = vcsCloneRepo vcs verbosity
                               (vcsProgram vcs) repo
                               srcuri destdir


-- | Syncronise a set of 'SourceRepo's referring to the same repository with
-- corresponding local directories. The local directories may or may not
-- already exist.
--
-- The 'SourceRepo' values used in a single invocation of 'syncSourceRepos',
-- or used across a series of invocations with any local directory must refer
-- to the /same/ repository. That means it must be the same location but they
-- can differ in the branch, or tag or subdir.
--
-- The reason to allow multiple related 'SourceRepo's is to allow for the
-- network or storage to be shared between different checkouts of the repo.
-- For example if a single repo contains multiple packages in different subdirs
-- and in some project it may make sense to use a different state of the repo
-- for one subdir compared to another.
--
syncSourceRepos :: Verbosity
                -> VCS ConfiguredProgram
                -> [(SourceRepositoryPackage f, FilePath)]
                -> Rebuild ()
syncSourceRepos verbosity vcs repos = do
    files <- liftIO $ vcsSyncRepos vcs verbosity (vcsProgram vcs) repos
    monitorFiles files


-- ------------------------------------------------------------
-- * The various VCS drivers
-- ------------------------------------------------------------

-- | The set of all supported VCS drivers, organised by 'RepoType'.
--
knownVCSs :: Map RepoType (VCS Program)
knownVCSs = Map.fromList [ (vcsRepoType vcs, vcs) | vcs <- vcss ]
  where
    vcss = [ vcsBzr, vcsDarcs, vcsGit, vcsHg, vcsSvn ]


-- | VCS driver for Bazaar.
--
vcsBzr :: VCS Program
vcsBzr =
    VCS {
      vcsRepoType = KnownRepoType Bazaar,
      vcsProgram  = bzrProgram,
      vcsCloneRepo,
      vcsSyncRepos
    }
  where
    vcsCloneRepo :: Verbosity
                 -> ConfiguredProgram
                 -> SourceRepositoryPackage f
                 -> FilePath
                 -> FilePath
                 -> [ProgramInvocation]
    vcsCloneRepo verbosity prog repo srcuri destdir =
        [ programInvocation prog
            ([branchCmd, srcuri, destdir] ++ tagArgs ++ verboseArg) ]
      where
        -- The @get@ command was deprecated in version 2.4 in favour of
        -- the alias @branch@
        branchCmd | programVersion prog >= Just (mkVersion [2,4])
                              = "branch"
                  | otherwise = "get"

        tagArgs = case srpTag repo of
          Nothing  -> []
          Just tag -> ["-r", "tag:" ++ tag]
        verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]

    vcsSyncRepos :: Verbosity -> ConfiguredProgram
                 -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath]
    vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for bzr"

bzrProgram :: Program
bzrProgram = (simpleProgram "bzr") {
    programFindVersion = findProgramVersion "--version" $ \str ->
      case words str of
        -- "Bazaar (bzr) 2.6.0\n  ... lots of extra stuff"
        (_:_:ver:_) -> ver
        _ -> ""
  }


-- | VCS driver for Darcs.
--
vcsDarcs :: VCS Program
vcsDarcs =
    VCS {
      vcsRepoType = KnownRepoType Darcs,
      vcsProgram  = darcsProgram,
      vcsCloneRepo,
      vcsSyncRepos
    }
  where
    vcsCloneRepo :: Verbosity
                 -> ConfiguredProgram
                 -> SourceRepositoryPackage f
                 -> FilePath
                 -> FilePath
                 -> [ProgramInvocation]
    vcsCloneRepo verbosity prog repo srcuri destdir =
        [ programInvocation prog cloneArgs ]
      where
        cloneArgs  = [cloneCmd, srcuri, destdir] ++ tagArgs ++ verboseArg
        -- At some point the @clone@ command was introduced as an alias for
        -- @get@, and @clone@ seems to be the recommended one now.
        cloneCmd   | programVersion prog >= Just (mkVersion [2,8])
                               = "clone"
                   | otherwise = "get"
        tagArgs    = case srpTag repo of
          Nothing  -> []
          Just tag -> ["-t", tag]
        verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]

    vcsSyncRepos :: Verbosity -> ConfiguredProgram
                 -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath]
    vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for darcs"

darcsProgram :: Program
darcsProgram = (simpleProgram "darcs") {
    programFindVersion = findProgramVersion "--version" $ \str ->
      case words str of
        -- "2.8.5 (release)"
        (ver:_) -> ver
        _ -> ""
  }


-- | VCS driver for Git.
--
vcsGit :: VCS Program
vcsGit =
    VCS {
      vcsRepoType = KnownRepoType Git,
      vcsProgram  = gitProgram,
      vcsCloneRepo,
      vcsSyncRepos
    }
  where
    vcsCloneRepo :: Verbosity
                 -> ConfiguredProgram
                 -> SourceRepositoryPackage f
                 -> FilePath
                 -> FilePath
                 -> [ProgramInvocation]
    vcsCloneRepo verbosity prog repo srcuri destdir =
        [ programInvocation prog cloneArgs ]
        -- And if there's a tag, we have to do that in a second step:
     ++ [ (programInvocation prog (checkoutArgs tag)) {
            progInvokeCwd = Just destdir
          }
        | tag <- maybeToList (srpTag repo) ]
      where
        cloneArgs  = ["clone", srcuri, destdir]
                     ++ branchArgs ++ verboseArg
        branchArgs = case srpBranch repo of
          Just b  -> ["--branch", b]
          Nothing -> []
        checkoutArgs tag = "checkout" : verboseArg ++ [tag, "--"]
        verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]

    vcsSyncRepos :: Verbosity
                 -> ConfiguredProgram
                 -> [(SourceRepositoryPackage f, FilePath)]
                 -> IO [MonitorFilePath]
    vcsSyncRepos _ _ [] = return []
    vcsSyncRepos verbosity gitProg
                 ((primaryRepo, primaryLocalDir) : secondaryRepos) = do

      vcsSyncRepo verbosity gitProg primaryRepo primaryLocalDir Nothing
      sequence_
        [ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir)
        | (repo, localDir) <- secondaryRepos ]
      return [ monitorDirectoryExistence dir
             | dir <- (primaryLocalDir : map snd secondaryRepos) ]

    vcsSyncRepo verbosity gitProg SourceRepositoryPackage{..} localDir peer = do
        exists <- doesDirectoryExist localDir
        if exists
          then git localDir                 ["fetch"]
          else git (takeDirectory localDir) cloneArgs
        git localDir checkoutArgs
      where
        git :: FilePath -> [String] -> IO ()
        git cwd args = runProgramInvocation verbosity $
                         (programInvocation gitProg args) {
                           progInvokeCwd = Just cwd
                         }

        cloneArgs      = ["clone", "--no-checkout", loc, localDir]
                      ++ case peer of
                           Nothing           -> []
                           Just peerLocalDir -> ["--reference", peerLocalDir]
                      ++ verboseArg
                         where loc = srpLocation
        checkoutArgs   = "checkout" : verboseArg ++ ["--detach", "--force"
                         , checkoutTarget, "--" ]
        checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag)
        verboseArg     = [ "--quiet" | verbosity < Verbosity.normal ]

gitProgram :: Program
gitProgram = (simpleProgram "git") {
    programFindVersion = findProgramVersion "--version" $ \str ->
      case words str of
        -- "git version 2.5.5"
        (_:_:ver:_) | all isTypical ver -> ver

        -- or annoyingly "git version 2.17.1.windows.2" yes, really
        (_:_:ver:_) -> intercalate "."
                     . takeWhile (all isNum)
                     . split
                     $ ver
        _ -> ""
  }
  where
    isNum     c = c >= '0' && c <= '9'
    isTypical c = isNum c || c == '.'
    split    cs = case break (=='.') cs of
                    (chunk,[])     -> chunk : []
                    (chunk,_:rest) -> chunk : split rest

-- | VCS driver for Mercurial.
--
vcsHg :: VCS Program
vcsHg =
    VCS {
      vcsRepoType = KnownRepoType Mercurial,
      vcsProgram  = hgProgram,
      vcsCloneRepo,
      vcsSyncRepos
    }
  where
    vcsCloneRepo :: Verbosity
                 -> ConfiguredProgram
                 -> SourceRepositoryPackage f
                 -> FilePath
                 -> FilePath
                 -> [ProgramInvocation]
    vcsCloneRepo verbosity prog repo srcuri destdir =
        [ programInvocation prog cloneArgs ]
      where
        cloneArgs  = ["clone", srcuri, destdir]
                     ++ branchArgs ++ tagArgs ++ verboseArg
        branchArgs = case srpBranch repo of
          Just b  -> ["--branch", b]
          Nothing -> []
        tagArgs = case srpTag repo of
          Just t  -> ["--rev", t]
          Nothing -> []
        verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]

    vcsSyncRepos :: Verbosity
                 -> ConfiguredProgram
                 -> [(SourceRepositoryPackage f, FilePath)]
                 -> IO [MonitorFilePath]
    vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for hg"

hgProgram :: Program
hgProgram = (simpleProgram "hg") {
    programFindVersion = findProgramVersion "--version" $ \str ->
      case words str of
        -- Mercurial Distributed SCM (version 3.5.2)\n ... long message
        (_:_:_:_:ver:_) -> takeWhile (\c -> Char.isDigit c || c == '.') ver
        _ -> ""
  }


-- | VCS driver for Subversion.
--
vcsSvn :: VCS Program
vcsSvn =
    VCS {
      vcsRepoType = KnownRepoType SVN,
      vcsProgram  = svnProgram,
      vcsCloneRepo,
      vcsSyncRepos
    }
  where
    vcsCloneRepo :: Verbosity
                 -> ConfiguredProgram
                 -> SourceRepositoryPackage f
                 -> FilePath
                 -> FilePath
                 -> [ProgramInvocation]
    vcsCloneRepo verbosity prog _repo srcuri destdir =
        [ programInvocation prog checkoutArgs ]
      where
        checkoutArgs = ["checkout", srcuri, destdir] ++ verboseArg
        verboseArg   = [ "--quiet" | verbosity < Verbosity.normal ]
        --TODO: branch or tag?

    vcsSyncRepos :: Verbosity
                 -> ConfiguredProgram
                 -> [(SourceRepositoryPackage f, FilePath)]
                 -> IO [MonitorFilePath]
    vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for svn"

svnProgram :: Program
svnProgram = (simpleProgram "svn") {
    programFindVersion = findProgramVersion "--version" $ \str ->
      case words str of
        -- svn, version 1.9.4 (r1740329)\n ... long message
        (_:_:ver:_) -> ver
        _ -> ""
  }


-- | VCS driver for Pijul.
-- Documentation for Pijul can be found at <https://pijul.org/manual/introduction.html>
--
-- 2020-04-09 Oleg:
--
--    As far as I understand pijul, there are branches and "tags" in pijul,
--    but there aren't a "commit hash" identifying an arbitrary state.
--
--    One can create `a pijul tag`, which will make a patch hash,
--    which depends on everything currently in the repository.
--    I guess if you try to apply that patch, you'll be forced to apply
--    all the dependencies too. In other words, there are no named tags.
--
--    It's not clear to me whether there is an option to
--    "apply this patch *and* all of its dependencies".
--    And relatedly, whether how to make sure that there are no other
--    patches applied.
--
--    With branches it's easier, as you can `pull` and `checkout` them,
--    and they seem to be similar enough. Yet, pijul documentations says
--
--    > Note that the purpose of branches in Pijul is quite different from Git,
--      since Git's "feature branches" can usually be implemented by just
--      patches.
--
--    I guess it means that indeed instead of creating a branch and making PR
--    in "GitHub" workflow, you'd just create a patch and offer it.
--    You can do that with `git` too. Push (a branch with) commit to remote
--    and ask other to cherry-pick that commit. Yet, in git identity of commit
--    changes when it applied to other trees, where patches in pijul have
--    will continue to have the same hash.
--
--    Unfortunately pijul doesn't talk about conflict resolution.
--    It seems that you get something like:
--
--        % pijul status
--        On branch merge
--
--        Unresolved conflicts:
--          (fix conflicts and record the resolution with "pijul record ...")
--
--                foo
--
--        % cat foo
--        first line
--        >> >>>>>>>>>>>>>>>>>>>>>>>>>>>>>
--        branch BBB
--        ================================
--        branch AAA
--        <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
--        last line
--
--    And then the `pijul dependencies` would draw you a graph like
--
--
--                    ----->  foo on branch B ----->
--    resolve confict                                  Initial patch
--                    ----->  foo on branch A ----->
--
--    Which is seems reasonable.
--
--    So currently, pijul support is very experimental, and most likely
--    won't work, even the basics are in place. Tests are also written
--    but disabled, as the branching model differs from `git` one,
--    for which tests are written.
--
vcsPijul :: VCS Program
vcsPijul =
    VCS {
      vcsRepoType = KnownRepoType Pijul,
      vcsProgram  = pijulProgram,
      vcsCloneRepo,
      vcsSyncRepos
    }
  where
    vcsCloneRepo :: Verbosity -- ^ it seems that pijul does not have verbose flag
                 -> ConfiguredProgram
                 -> SourceRepositoryPackage f
                 -> FilePath
                 -> FilePath
                 -> [ProgramInvocation]
    vcsCloneRepo _verbosity prog repo srcuri destdir =
        [ programInvocation prog cloneArgs ]
        -- And if there's a tag, we have to do that in a second step:
     ++ [ (programInvocation prog (checkoutArgs tag)) {
            progInvokeCwd = Just destdir
          }
        | tag <- maybeToList (srpTag repo) ]
      where
        cloneArgs  = ["clone", srcuri, destdir]
                     ++ branchArgs
        branchArgs = case srpBranch repo of
          Just b  -> ["--from-branch", b]
          Nothing -> []
        checkoutArgs tag = "checkout" : [tag] -- TODO: this probably doesn't work either

    vcsSyncRepos :: Verbosity
                 -> ConfiguredProgram
                 -> [(SourceRepositoryPackage f, FilePath)]
                 -> IO [MonitorFilePath]
    vcsSyncRepos _ _ [] = return []
    vcsSyncRepos verbosity pijulProg
                 ((primaryRepo, primaryLocalDir) : secondaryRepos) = do

      vcsSyncRepo verbosity pijulProg primaryRepo primaryLocalDir Nothing
      sequence_
        [ vcsSyncRepo verbosity pijulProg repo localDir (Just primaryLocalDir)
        | (repo, localDir) <- secondaryRepos ]
      return [ monitorDirectoryExistence dir
             | dir <- (primaryLocalDir : map snd secondaryRepos) ]

    vcsSyncRepo verbosity pijulProg SourceRepositoryPackage{..} localDir peer = do
        exists <- doesDirectoryExist localDir
        if exists
        then pijul localDir                 ["pull"] -- TODO: this probably doesn't work.
        else pijul (takeDirectory localDir) cloneArgs
        pijul localDir checkoutArgs
      where
        pijul :: FilePath -> [String] -> IO ()
        pijul cwd args = runProgramInvocation verbosity $
                         (programInvocation pijulProg args) {
                           progInvokeCwd = Just cwd
                         }

        cloneArgs      = ["clone", loc, localDir]
                      ++ case peer of
                           Nothing           -> []
                           Just peerLocalDir -> [peerLocalDir]
                         where loc = srpLocation
        checkoutArgs   = "checkout" :  ["--force", checkoutTarget, "--" ]
        checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) -- TODO: this is definitely wrong.

pijulProgram :: Program
pijulProgram = (simpleProgram "pijul") {
    programFindVersion = findProgramVersion "--version" $ \str ->
      case words str of
        -- "pijul 0.12.2
        (_:ver:_) | all isTypical ver -> ver
        _ -> ""
  }
  where
    isNum     c = c >= '0' && c <= '9'
    isTypical c = isNum c || c == '.'