{-# 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.IO.Class (MonadIO)
import Control.Monad.Fail
import Control.Monad.Log
import Data.Bool (bool)
import Data.Bifunctor
import Data.Char
import Data.Either
import Data.Functor (void)
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 :: String
cp = $(staticWhich "cp")

gitPath :: FilePath
gitPath :: String
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 :: forall (m :: * -> *) e.
(MonadIO m, MonadLog Output m, MonadError e m, AsProcessFailure e,
 MonadFail m, MonadMask m) =>
String -> Bool -> m Bool
checkGitCleanStatus String
repo Bool
withIgnored = do
  let
    runGit :: [String] -> m Text
runGit = Severity -> ProcessSpec -> m Text
forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
 MonadMask m) =>
Severity -> ProcessSpec -> m Text
readProcessAndLogStderr Severity
Debug (ProcessSpec -> m Text)
-> ([String] -> ProcessSpec) -> [String] -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> ProcessSpec
gitProc String
repo
    gitStatus :: m Text
gitStatus = [String] -> m Text
runGit ([String] -> m Text) -> [String] -> m Text
forall a b. (a -> b) -> a -> b
$ [String
"status", String
"--porcelain"] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String] -> [String] -> Bool -> [String]
forall a. a -> a -> Bool -> a
bool [] [String
"--ignored"] Bool
withIgnored
    gitDiff :: m Text
gitDiff = [String] -> m Text
runGit [String
"diff"]
  Text -> Bool
T.null (Text -> Bool) -> m Text -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Text -> Text) -> m Text -> m Text -> m Text
forall a b c. (a -> b -> c) -> m a -> m b -> m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>) m Text
gitStatus m Text
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 :: forall (m :: * -> *) e.
(MonadIO m, MonadLog Output m, MonadError e m, AsProcessFailure e,
 MonadFail m, AsUnstructuredError e, HasCliConfig e m,
 MonadMask m) =>
String -> Bool -> Text -> m ()
ensureCleanGitRepo String
path Bool
withIgnored Text
s =
  Text -> m () -> m ()
forall (m :: * -> *) e a.
(MonadIO m, MonadMask m, CliLog m, HasCliConfig e m) =>
Text -> m a -> m a
withSpinnerNoTrail (Text
"Ensuring clean git repo at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
path) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    String -> Bool -> m Bool
forall (m :: * -> *) e.
(MonadIO m, MonadLog Output m, MonadError e m, AsProcessFailure e,
 MonadFail m, MonadMask m) =>
String -> Bool -> m Bool
checkGitCleanStatus String
path Bool
withIgnored m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
False -> do
        statusDebug <- String -> [String] -> m Text
forall (m :: * -> *) e.
(MonadIO m, MonadLog Output m, MonadError e m, AsProcessFailure e,
 MonadFail m, MonadMask m) =>
String -> [String] -> m Text
readGitProcess String
path ([String] -> m Text) -> [String] -> m Text
forall a b. (a -> b) -> a -> b
$ [String
"status"] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String] -> [String] -> Bool -> [String]
forall a. a -> a -> Bool -> a
bool [] [String
"--ignored"] Bool
withIgnored
        putLog Warning "Working copy is unsaved; git status:"
        putLog Notice statusDebug
        failWith s
      Bool
True -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
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 :: forall (m :: * -> *) e.
(MonadIO m, MonadLog Output m, MonadError e m, AsProcessFailure e,
 MonadFail m, MonadMask m) =>
String -> m ()
initGitRepo String
repo = do
  let git :: [String] -> m ()
git = (Severity, Severity) -> ProcessSpec -> m ()
forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
 MonadMask m) =>
(Severity, Severity) -> ProcessSpec -> m ()
callProcessAndLogOutput (Severity
Debug, Severity
Debug) (ProcessSpec -> m ())
-> ([String] -> ProcessSpec) -> [String] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> ProcessSpec
gitProc String
repo
  [String] -> m ()
git [String
"init"]
  [String] -> m ()
git [String
"add", String
"."]
  [String] -> m ()
git [String
"commit", String
"-m", String
"Initial commit."]

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

-- | Create a 'ProcessSpec' for invoking @git@ in a specified repository
-- path, using the given arguments.
gitProc :: FilePath -> [String] -> ProcessSpec
gitProc :: String -> [String] -> ProcessSpec
gitProc String
repo = [String] -> ProcessSpec
gitProcNoRepo ([String] -> ProcessSpec)
-> ([String] -> [String]) -> [String] -> ProcessSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
runGitInDir
  where
    runGitInDir :: [String] -> [String]
runGitInDir [String]
args' = case (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [String]
args' of
      args :: [String]
args@(String
"clone":[String]
_) -> [String]
args [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
repo]
      [String]
args -> [String
"-C", String
repo] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
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 :: ProcessSpec -> ProcessSpec
isolateGitProc = (Map String String -> Map String String)
-> ProcessSpec -> ProcessSpec
setEnvOverride (Map String String
overrides Map String String -> Map String String -> Map String String
forall a. Semigroup a => a -> a -> a
<>)
  where
    overrides :: Map String String
overrides = [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
      [ (String
"HOME", String
"/dev/null")
      , (String
"GIT_CONFIG_NOSYSTEM", String
"1")
      , (String
"GIT_TERMINAL_PROMPT", String
"0") -- git 2.3+
      , (String
"GIT_ASKPASS", String
"echo") -- pre git 2.3 to just use empty password
      , (String
"GIT_SSH_COMMAND", String
"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 :: String -> String -> ProcessSpec
copyDir String
src String
dest =
  Maybe String -> ProcessSpec -> ProcessSpec
setCwd (String -> Maybe String
forall a. a -> Maybe a
Just String
src) (ProcessSpec -> ProcessSpec) -> ProcessSpec -> ProcessSpec
forall a b. (a -> b) -> a -> b
$ String -> [String] -> ProcessSpec
proc String
cp [String
"-a", String
".", String
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 :: forall (m :: * -> *) e.
(MonadIO m, MonadLog Output m, MonadError e m, AsProcessFailure e,
 MonadFail m, MonadMask m) =>
String -> [String] -> m Text
readGitProcess String
repo = (Severity, Severity) -> ProcessSpec -> m Text
forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
 MonadFail m) =>
(Severity, Severity) -> ProcessSpec -> m Text
readProcessAndLogOutput (Severity
Debug, Severity
Notice) (ProcessSpec -> m Text)
-> ([String] -> ProcessSpec) -> [String] -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> ProcessSpec
gitProc String
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 :: forall (m :: * -> *) e.
(MonadIO m, MonadLog Output m, MonadError e m, AsProcessFailure e,
 MonadFail m, MonadMask m) =>
[String] -> m Text
readGitProcessNoRepo = (Severity, Severity) -> ProcessSpec -> m Text
forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
 MonadFail m) =>
(Severity, Severity) -> ProcessSpec -> m Text
readProcessAndLogOutput (Severity
Debug, Severity
Notice) (ProcessSpec -> m Text)
-> ([String] -> ProcessSpec) -> [String] -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> ProcessSpec
gitProcNoRepo

gitLookupDefaultBranch :: GitLsRemoteMaps -> Either Text Text
gitLookupDefaultBranch :: GitLsRemoteMaps -> Either Text Text
gitLookupDefaultBranch (Map GitRef GitRef
refs, Map GitRef Text
_) = do
  ref <- case GitRef -> Map GitRef GitRef -> Maybe GitRef
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup GitRef
GitRef_Head Map GitRef GitRef
refs of
    Just GitRef
ref -> GitRef -> Either Text GitRef
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GitRef
ref
    Maybe GitRef
Nothing -> Text -> Either Text GitRef
forall a. Text -> Either Text a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
      Text
"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 Text
b -> Text -> Either Text Text
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
b
    GitRef
_ -> Text -> Either Text Text
forall a. Text -> Either Text a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$
      Text
"Default ref " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GitRef -> Text
showGitRef GitRef
ref Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not a branch!"

gitLookupCommitForRef :: GitLsRemoteMaps -> GitRef -> Either Text CommitId
gitLookupCommitForRef :: GitLsRemoteMaps -> GitRef -> Either Text Text
gitLookupCommitForRef (Map GitRef GitRef
_, Map GitRef Text
commits) GitRef
ref = case GitRef -> Map GitRef Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup GitRef
ref Map GitRef Text
commits of
  Just Text
a -> Text -> Either Text Text
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
a
  Maybe Text
Nothing -> Text -> Either Text Text
forall a. Text -> Either Text a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text
"Did not find commit for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GitRef -> Text
showGitRef GitRef
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 :: forall (m :: * -> *) e.
(MonadIO m, MonadLog Output m, MonadError e m, AsProcessFailure e,
 MonadFail m, AsUnstructuredError e) =>
String
-> Maybe GitRef -> Maybe String -> m (ExitCode, GitLsRemoteMaps)
gitLsRemote String
repository Maybe GitRef
mRef Maybe String
mBranch = do
  (exitCode, out, _err) <- case Maybe String
mBranch of
    Maybe String
Nothing -> ProcessSpec -> m (ExitCode, String, String)
forall (m :: * -> *).
(MonadIO m, CliLog m) =>
ProcessSpec -> m (ExitCode, String, String)
readCreateProcessWithExitCode (ProcessSpec -> m (ExitCode, String, String))
-> ProcessSpec -> m (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ [String] -> ProcessSpec
gitProcNoRepo ([String] -> ProcessSpec) -> [String] -> ProcessSpec
forall a b. (a -> b) -> a -> b
$
        [String
"ls-remote", String
"--exit-code", String
"--symref", String
repository]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList (Text -> String
T.unpack (Text -> String) -> (GitRef -> Text) -> GitRef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GitRef -> Text
showGitRef (GitRef -> String) -> Maybe GitRef -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe GitRef
mRef)
    Just String
branchName -> ProcessSpec -> m (ExitCode, String, String)
forall (m :: * -> *).
(MonadIO m, CliLog m) =>
ProcessSpec -> m (ExitCode, String, String)
readCreateProcessWithExitCode (ProcessSpec -> m (ExitCode, String, String))
-> ProcessSpec -> m (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ [String] -> ProcessSpec
gitProcNoRepo
        [String
"ls-remote", String
"--exit-code", String
repository, String
branchName]
  let t = String -> Text
T.pack String
out
  maps <- case MP.runParser parseLsRemote "" t of
    Left ParseErrorBundle Text Void
err -> Text -> m GitLsRemoteMaps
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith (Text -> m GitLsRemoteMaps) -> Text -> m GitLsRemoteMaps
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
MP.errorBundlePretty ParseErrorBundle Text Void
err
    Right [Either (GitRef, GitRef) (GitRef, Text)]
table -> GitLsRemoteMaps -> m GitLsRemoteMaps
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GitLsRemoteMaps -> m GitLsRemoteMaps)
-> GitLsRemoteMaps -> m GitLsRemoteMaps
forall a b. (a -> b) -> a -> b
$ ([(GitRef, GitRef)] -> Map GitRef GitRef)
-> ([(GitRef, Text)] -> Map GitRef Text)
-> ([(GitRef, GitRef)], [(GitRef, Text)])
-> GitLsRemoteMaps
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap [(GitRef, GitRef)] -> Map GitRef GitRef
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(GitRef, Text)] -> Map GitRef Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (([(GitRef, GitRef)], [(GitRef, Text)]) -> GitLsRemoteMaps)
-> ([(GitRef, GitRef)], [(GitRef, Text)]) -> GitLsRemoteMaps
forall a b. (a -> b) -> a -> b
$ [Either (GitRef, GitRef) (GitRef, Text)]
-> ([(GitRef, GitRef)], [(GitRef, Text)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (GitRef, GitRef) (GitRef, Text)]
table
  putLog Debug $ "git ls-remote maps: " <> T.pack (show maps)
  pure (exitCode, maps)

lexeme :: Parsec Void Text a -> Parsec Void Text a
lexeme :: forall a. Parsec Void Text a -> Parsec Void Text a
lexeme = ParsecT Void Text Identity ()
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
ML.lexeme (ParsecT Void Text Identity ()
 -> ParsecT Void Text Identity a -> ParsecT Void Text Identity a)
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity a
-> ParsecT Void Text Identity a
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Tokens Text)
 -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
MP.takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"within-line white space") ((Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text))
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall a b. (a -> b) -> a -> b
$
  (Token Text -> String -> Bool) -> String -> Token Text -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> String -> Bool
Token Text -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char
' ', Char
'\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 :: Parsec Void Text [Either (GitRef, GitRef) (GitRef, Text)]
parseLsRemote =
  ParsecT Void Text Identity (Either (GitRef, GitRef) (GitRef, Text))
-> Parsec Void Text [Either (GitRef, GitRef) (GitRef, Text)]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ((((GitRef, GitRef) -> Either (GitRef, GitRef) (GitRef, Text))
-> ParsecT Void Text Identity (GitRef, GitRef)
-> ParsecT
     Void Text Identity (Either (GitRef, GitRef) (GitRef, Text))
forall a b.
(a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GitRef, GitRef) -> Either (GitRef, GitRef) (GitRef, Text)
forall a b. a -> Either a b
Left (ParsecT Void Text Identity (GitRef, GitRef)
-> ParsecT Void Text Identity (GitRef, GitRef)
forall a. Parsec Void Text a -> Parsec Void Text a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT Void Text Identity (GitRef, GitRef)
parseRef) ParsecT Void Text Identity (Either (GitRef, GitRef) (GitRef, Text))
-> ParsecT
     Void Text Identity (Either (GitRef, GitRef) (GitRef, Text))
-> ParsecT
     Void Text Identity (Either (GitRef, GitRef) (GitRef, Text))
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((GitRef, Text) -> Either (GitRef, GitRef) (GitRef, Text))
-> ParsecT Void Text Identity (GitRef, Text)
-> ParsecT
     Void Text Identity (Either (GitRef, GitRef) (GitRef, Text))
forall a b.
(a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GitRef, Text) -> Either (GitRef, GitRef) (GitRef, Text)
forall a b. b -> Either a b
Right ParsecT Void Text Identity (GitRef, Text)
parseCommit) ParsecT Void Text Identity (Either (GitRef, GitRef) (GitRef, Text))
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT
     Void Text Identity (Either (GitRef, GitRef) (GitRef, Text))
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
forall a. Parsec Void Text a -> Parsec Void Text a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
MP.eol) Parsec Void Text [Either (GitRef, GitRef) (GitRef, Text)]
-> ParsecT Void Text Identity ()
-> Parsec Void Text [Either (GitRef, GitRef) (GitRef, Text)]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
MP.eof
  where
    parseRef :: Parsec Void Text (GitRef, GitRef)
    parseRef :: ParsecT Void Text Identity (GitRef, GitRef)
parseRef = String
-> ParsecT Void Text Identity (GitRef, GitRef)
-> ParsecT Void Text Identity (GitRef, GitRef)
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
MP.label String
"ref and symbolic ref" (ParsecT Void Text Identity (GitRef, GitRef)
 -> ParsecT Void Text Identity (GitRef, GitRef))
-> ParsecT Void Text Identity (GitRef, GitRef)
-> ParsecT Void Text Identity (GitRef, GitRef)
forall a b. (a -> b) -> a -> b
$ do
      _ <- Parsec Void Text Text -> Parsec Void Text Text
forall a. Parsec Void Text a -> Parsec Void Text a
lexeme Parsec Void Text Text
"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 :: ParsecT Void Text Identity (GitRef, Text)
parseCommit = String
-> ParsecT Void Text Identity (GitRef, Text)
-> ParsecT Void Text Identity (GitRef, Text)
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
MP.label String
"commit and ref" (ParsecT Void Text Identity (GitRef, Text)
 -> ParsecT Void Text Identity (GitRef, Text))
-> ParsecT Void Text Identity (GitRef, Text)
-> ParsecT Void Text Identity (GitRef, Text)
forall a b. (a -> b) -> a -> b
$ do
      commitId <- Parsec Void Text Text -> Parsec Void Text Text
forall a. Parsec Void Text a -> Parsec Void Text a
lexeme (Parsec Void Text Text -> Parsec Void Text Text)
-> Parsec Void Text Text -> Parsec Void Text Text
forall a b. (a -> b) -> a -> b
$ Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
MP.takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"commit id") ((Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text))
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (Token Text -> Bool) -> Token Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
Token Text -> Bool
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 (Int -> GitRef -> String -> String
[GitRef] -> String -> String
GitRef -> String
(Int -> GitRef -> String -> String)
-> (GitRef -> String)
-> ([GitRef] -> String -> String)
-> Show GitRef
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> GitRef -> String -> String
showsPrec :: Int -> GitRef -> String -> String
$cshow :: GitRef -> String
show :: GitRef -> String
$cshowList :: [GitRef] -> String -> String
showList :: [GitRef] -> String -> String
Show, GitRef -> GitRef -> Bool
(GitRef -> GitRef -> Bool)
-> (GitRef -> GitRef -> Bool) -> Eq GitRef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GitRef -> GitRef -> Bool
== :: GitRef -> GitRef -> Bool
$c/= :: GitRef -> GitRef -> Bool
/= :: GitRef -> GitRef -> Bool
Eq, Eq GitRef
Eq GitRef =>
(GitRef -> GitRef -> Ordering)
-> (GitRef -> GitRef -> Bool)
-> (GitRef -> GitRef -> Bool)
-> (GitRef -> GitRef -> Bool)
-> (GitRef -> GitRef -> Bool)
-> (GitRef -> GitRef -> GitRef)
-> (GitRef -> GitRef -> GitRef)
-> Ord GitRef
GitRef -> GitRef -> Bool
GitRef -> GitRef -> Ordering
GitRef -> GitRef -> GitRef
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: GitRef -> GitRef -> Ordering
compare :: GitRef -> GitRef -> Ordering
$c< :: GitRef -> GitRef -> Bool
< :: GitRef -> GitRef -> Bool
$c<= :: GitRef -> GitRef -> Bool
<= :: GitRef -> GitRef -> Bool
$c> :: GitRef -> GitRef -> Bool
> :: GitRef -> GitRef -> Bool
$c>= :: GitRef -> GitRef -> Bool
>= :: GitRef -> GitRef -> Bool
$cmax :: GitRef -> GitRef -> GitRef
max :: GitRef -> GitRef -> GitRef
$cmin :: GitRef -> GitRef -> GitRef
min :: GitRef -> GitRef -> GitRef
Ord)

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

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

type CommitId = Text

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