Git.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TemplateHaskell #-}
module Bindings.Cli.Git
  ( CommitId
  , gitProc
  , ensureCleanGitRepo
  , readGitProcess
  , isolateGitProc
  , gitProcNoRepo
  , gitLsRemote
  , gitLookupDefaultBranch
  , gitLookupCommitForRef
  , GitRef (..)
  ) where

import Control.Applicative hiding (many)
import Control.Monad.Catch (MonadMask)
import Control.Monad.Except
import Control.Monad.Fail
import Control.Monad.Log
import Data.Bool (bool)
import Data.Bifunctor
import Data.Char
import Data.Either
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (maybeToList)
import Data.Semigroup ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Void (Void)
import System.Exit (ExitCode)
import qualified Text.Megaparsec.Char.Lexer as ML
import Text.Megaparsec as MP
import Text.Megaparsec.Char as MP
import System.Which (staticWhich)

import Cli.Extras

cp :: FilePath
cp = $(staticWhich "cp")

gitPath :: FilePath
gitPath = $(staticWhich "git")

-- | Checks whether the given directory is a clean git repository.
checkGitCleanStatus ::
  ( MonadIO m
  , MonadLog Output m
  , MonadError e m
  , AsProcessFailure e
  , MonadFail m
  , MonadMask m
  )
  => FilePath  -- ^ The repository
  -> Bool      -- ^ Should ignored files be considered?
  -> m Bool    -- ^ True if the repository is clean.
checkGitCleanStatus repo withIgnored = do
  let
    runGit = readProcessAndLogStderr Debug . gitProc repo
    gitStatus = runGit $ ["status", "--porcelain"] <> bool [] ["--ignored"] withIgnored
    gitDiff = runGit ["diff"]
  T.null <$> liftA2 (<>) gitStatus gitDiff

-- | Ensure that the given directory is a clean git repository. If the
-- repository has changes, throw an error.
ensureCleanGitRepo ::
  ( MonadIO m
  , MonadLog Output m
  , MonadError e m
  , AsProcessFailure e
  , MonadFail m
  , AsUnstructuredError e
  , HasCliConfig e m
  , MonadMask m
  )
  => FilePath -- ^ The repository
  -> Bool     -- ^ Should ignored files be considered?
  -> Text     -- ^ The error message which should be thrown when the repository is unclean.
  -> m ()
ensureCleanGitRepo path withIgnored s =
  withSpinnerNoTrail ("Ensuring clean git repo at " <> T.pack path) $ do
    checkGitCleanStatus path withIgnored >>= \case
      False -> do
        statusDebug <- readGitProcess path $ ["status"] <> bool [] ["--ignored"] withIgnored
        putLog Warning "Working copy is unsaved; git status:"
        putLog Notice statusDebug
        failWith s
      True -> pure ()

-- | Initialize a Git repository and make a root commit at the given
-- path. The path must point to an existing directory without a @.git@
-- folder.
initGitRepo ::
  ( MonadIO m
  , MonadLog Output m
  , MonadError e m
  , AsProcessFailure e
  , MonadFail m
  , MonadMask m
  )
  => FilePath  -- ^ Where should we initialize the repository?
  -> m ()
initGitRepo repo = do
  let git = callProcessAndLogOutput (Debug, Debug) . gitProc repo
  git ["init"]
  git ["add", "."]
  git ["commit", "-m", "Initial commit."]

-- | Create a 'ProcessSpec' for invoking @git@ without a specified
-- repository, using the given arguments.
gitProcNoRepo :: [String] -> ProcessSpec
gitProcNoRepo args = setEnvOverride (M.singleton "GIT_TERMINAL_PROMPT" "0" <>) $ proc gitPath args

-- | Create a 'ProcessSpec' for invoking @git@ in a specified repository
-- path, using the given arguments.
gitProc :: FilePath -> [String] -> ProcessSpec
gitProc repo = gitProcNoRepo . runGitInDir
  where
    runGitInDir args' = case filter (not . null) args' of
      args@("clone":_) -> args <> [repo]
      args -> ["-C", repo] <> args

-- | Modify the 'ProcessSpec' to apply environment flags which ensure
-- @git@ has no dependency on external information. Specifically:
--
--  * The @HOME@ directory is unset
--  * @GIT_CONFIG_NOSYSTEM@ is set to 1
--  * @GIT_TERMINAL_PROMPT@ is set to 0 and @GIT_ASKPASS@ is set to
--  @echo@, so that password prompts will not pop up
--  * The SSH command used is @ssh -o PreferredAuthentications=password -o PubkeyAuthentication=no -o GSSAPIAuthentication=no@
isolateGitProc :: ProcessSpec -> ProcessSpec
isolateGitProc = setEnvOverride (overrides <>)
  where
    overrides = M.fromList
      [ ("HOME", "/dev/null")
      , ("GIT_CONFIG_NOSYSTEM", "1")
      , ("GIT_TERMINAL_PROMPT", "0") -- git 2.3+
      , ("GIT_ASKPASS", "echo") -- pre git 2.3 to just use empty password
      , ("GIT_SSH_COMMAND", "ssh -o PreferredAuthentications=password -o PubkeyAuthentication=no -o GSSAPIAuthentication=no")
      ]

-- | Recursively copy a directory using `cp -a` -- TODO: Should use -rT instead of -a
copyDir :: FilePath -> FilePath -> ProcessSpec
copyDir src dest =
  setCwd (Just src) $ proc cp ["-a", ".", dest] -- TODO: This will break if dest is relative since we change cwd

-- | Call @git@ in the specified directory with the given arguments and
-- return its standard output stream. Error messages from @git@, if any,
-- are printed with 'Notice' verbosity.
readGitProcess ::
  ( MonadIO m
  , MonadLog Output m
  , MonadError e m
  , AsProcessFailure e
  , MonadFail m
  , MonadMask m
  ) => FilePath -> [String] -> m Text
readGitProcess repo = readProcessAndLogOutput (Debug, Notice) . gitProc repo

-- | Call @git@ with the given arguments and return its standard output
-- stream. Error messages from @git@, if any, are printed with 'Notice'
-- verbosity.
readGitProcessNoRepo ::
  ( MonadIO m
  , MonadLog Output m
  , MonadError e m
  , AsProcessFailure e
  , MonadFail m
  , MonadMask m
  ) => [String] -> m Text
readGitProcessNoRepo = readProcessAndLogOutput (Debug, Notice) . gitProcNoRepo

gitLookupDefaultBranch :: GitLsRemoteMaps -> Either Text Text
gitLookupDefaultBranch (refs, _) = do
  ref <- case M.lookup GitRef_Head refs of
    Just ref -> pure ref
    Nothing -> throwError
      "No symref entry for HEAD. \
      \ Is your git version at least 1.8.5? \
      \ Otherwise `git ls-remote --symref` will not work."
  case ref of
    GitRef_Branch b -> pure b
    _ -> throwError $
      "Default ref " <> showGitRef ref <> " is not a branch!"

gitLookupCommitForRef :: GitLsRemoteMaps -> GitRef -> Either Text CommitId
gitLookupCommitForRef (_, commits) ref = case M.lookup ref commits of
  Just a -> pure a
  Nothing -> throwError $ "Did not find commit for " <> showGitRef ref

gitLsRemote
  :: ( MonadIO m
     , MonadLog Output m
     , MonadError e m
     , AsProcessFailure e
     , MonadFail m
     , AsUnstructuredError e
     )
  => String
  -> Maybe GitRef
  -> Maybe String
  -> m (ExitCode, GitLsRemoteMaps)
gitLsRemote repository mRef mBranch = do
  (exitCode, out, _err) <- case mBranch of
    Nothing -> readCreateProcessWithExitCode $ gitProcNoRepo $
        ["ls-remote", "--exit-code", "--symref", repository]
        ++ maybeToList (T.unpack . showGitRef <$> mRef)
    Just branchName -> readCreateProcessWithExitCode $ gitProcNoRepo
        ["ls-remote", "--exit-code", repository, branchName]
  let t = T.pack out
  maps <- case MP.runParser parseLsRemote "" t of
    Left err -> failWith $ T.pack $ MP.errorBundlePretty err
    Right table -> pure $ bimap M.fromList M.fromList $ partitionEithers table
  putLog Debug $ "git ls-remote maps: " <> T.pack (show maps)
  pure (exitCode, maps)

lexeme :: Parsec Void Text a -> Parsec Void Text a
lexeme = ML.lexeme $ void $ MP.takeWhileP (Just "within-line white space") $
  flip elem [' ', '\t']

-- $ git ls-remote --symref git@github.com:obsidiansystems/obelisk.git HEAD
-- ref: refs/heads/master	HEAD
-- d0a8d25dc93f0acd096bc4ff2f550da9e2d0c8f5	refs/heads/master
parseLsRemote :: Parsec Void Text [Either (GitRef, GitRef) (GitRef, CommitId)]
parseLsRemote =
  many ((fmap Left (try parseRef) <|> fmap Right parseCommit) <* try MP.eol) <* MP.eof
  where
    parseRef :: Parsec Void Text (GitRef, GitRef)
    parseRef = MP.label "ref and symbolic ref" $ do
      _ <- lexeme "ref:"
      ref <- lexeme $ MP.takeWhileP (Just "ref") $ not . isSpace
      symbolicRef <- lexeme $ MP.takeWhileP (Just "symbolic ref") $ not . isSpace
      return (toGitRef symbolicRef, toGitRef ref)
    parseCommit :: Parsec Void Text (GitRef, CommitId)
    parseCommit = MP.label "commit and ref" $ do
      commitId <- lexeme $ MP.takeWhileP (Just "commit id") $ not . isSpace
      ref <- lexeme $ MP.takeWhileP (Just "ref") $ not . isSpace
      return (toGitRef ref, commitId)

data GitRef
  = GitRef_Head
  | GitRef_Branch Text
  | GitRef_Tag Text
  | GitRef_Other Text
  deriving (Show, Eq, Ord)

showGitRef :: GitRef -> Text
showGitRef = \case
  GitRef_Head -> "HEAD"
  GitRef_Branch x -> "refs/heads/" <> x
  GitRef_Tag x -> "refs/tags/" <> x
  GitRef_Other x -> x

toGitRef :: Text -> GitRef
toGitRef = \case
  "HEAD" -> GitRef_Head
  r -> if
    | Just s <- "refs/heads/" `T.stripPrefix` r -> GitRef_Branch s
    | Just s <- "refs/tags/" `T.stripPrefix` r -> GitRef_Tag s
    | otherwise -> GitRef_Other r

type CommitId = Text

type GitLsRemoteMaps = (Map GitRef GitRef, Map GitRef CommitId)