{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Git.CmdLine where
import Control.Applicative hiding (many)
import Control.Exception hiding (try)
import Control.Failure
import Control.Monad
import Control.Monad.Base
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Control
import Control.Monad.Trans.Reader
import qualified Data.ByteString as B
import Data.Conduit hiding (MonadBaseControl)
import Data.Function
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.IORef
import Data.List as L
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import Data.Tagged
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import Data.Time
import Data.Tuple
import qualified Filesystem as F
import qualified Filesystem.Path.CurrentOS as F
import qualified Git
import qualified Git.Utils as Git
import Prelude hiding (FilePath)
import Shelly hiding (trace)
import System.Exit
import System.IO.Unsafe
import System.Locale (defaultTimeLocale)
import System.Process.ByteString
import Text.Parsec.Char
import Text.Parsec.Combinator
import Text.Parsec.Language (haskellDef)
import Text.Parsec.Prim
import Text.Parsec.Token
type Oid m = Git.Oid (CmdLineRepository m)
type BlobOid m = Git.BlobOid (CmdLineRepository m)
type TreeOid m = Git.TreeOid (CmdLineRepository m)
type CommitOid m = Git.CommitOid (CmdLineRepository m)
type TagOid m = Git.TagOid (CmdLineRepository m)
type Blob m = Git.Blob (CmdLineRepository m)
type Tree m = Git.Tree (CmdLineRepository m)
type TreeEntry m = Git.TreeEntry (CmdLineRepository m)
type Commit m = Git.Commit (CmdLineRepository m)
type Tag m = Git.Tag (CmdLineRepository m)
type TreeRef m = Git.TreeRef (CmdLineRepository m)
type CommitRef m = Git.CommitRef (CmdLineRepository m)
type CommitName m = Git.CommitName (CmdLineRepository m)
type Reference m = Git.Reference (CmdLineRepository m) (Commit m)
type Object m = Git.Object (CmdLineRepository m)
instance Git.MonadGit m => Git.Repository (CmdLineRepository m) where
data Oid (CmdLineRepository m) = Oid { getOid :: TL.Text }
data TreeData (CmdLineRepository m) = TreeData
{ cliTreeOid :: IORef (Maybe (TreeOid m))
, cliTreeContents :: IORef (HashMap Text (TreeEntry m))
}
data Options (CmdLineRepository m) = Options
facts = return Git.RepositoryFacts
{ Git.hasSymbolicReferences = True }
parseOid = return . Oid . TL.fromStrict
renderOid (Oid x) = TL.toStrict x
lookupRef = cliLookupRef
createRef = cliUpdateRef
updateRef = cliUpdateRef
deleteRef = cliDeleteRef
resolveRef = cliResolveRef
allRefs = cliAllRefs
lookupCommit = cliLookupCommit
lookupTree = cliLookupTree
lookupBlob = cliLookupBlob
lookupTag = error "Not defined CmdLineRepository.cliLookupTag"
lookupObject = error "Not defined CmdLineRepository.cliLookupObject"
existsObject = cliExistsObject
pushCommit = \name _ rrefname -> Git.genericPushCommit name rrefname
traverseCommits = cliTraverseCommits
missingObjects = cliMissingObjects
traverseObjects = error "Not defined: CmdLineRepository.traverseObjects"
newTree = cliNewTree
hashContents = cliHashContents
createBlob = cliCreateBlob
createCommit = cliCreateCommit
createTag = cliCreateTag
remoteFetch = error "Not defined: CmdLineRepository.remoteFetch"
deleteRepository =
cliGet >>= liftIO . F.removeTree . Git.repoPath . repoOptions
instance Show (Git.Oid (CmdLineRepository m)) where
show (Oid x) = show x
instance Ord (Git.Oid (CmdLineRepository m)) where
compare (Oid l) (Oid r) = compare l r
instance Eq (Git.Oid (CmdLineRepository m)) where
Oid l == Oid r = l == r
git :: [TL.Text] -> Sh TL.Text
git args = do
-- liftIO $ putStrLn $ "CmdLine: git " ++ show args
run "git" args
git_ :: [TL.Text] -> Sh ()
git_ args = do
-- liftIO $ putStrLn $ "CmdLine: git " ++ show args
run_ "git" args
doRunGit :: Git.MonadGit m
=> (FilePath -> [TL.Text] -> Sh a) -> [TL.Text] -> Sh ()
-> CmdLineRepository m a
doRunGit f args act = do
repo <- cliGet
shellyNoDir $ silently $ do
act
-- liftIO $ putStrLn $ "CmdLine: git "
-- ++ show (["--git-dir", repoPath repo] <> args)
f "git" $ ["--git-dir", repoPath repo] <> args
runGit :: Git.MonadGit m
=> [TL.Text] -> CmdLineRepository m TL.Text
runGit = flip (doRunGit run) (return ())
runGit_ :: Git.MonadGit m
=> [TL.Text] -> CmdLineRepository m ()
runGit_ = flip (doRunGit run_) (return ())
cliRepoDoesExist :: Text -> Sh (Either Git.GitException ())
cliRepoDoesExist remoteURI = do
setenv "SSH_ASKPASS" "echo"
setenv "GIT_ASKPASS" "echo"
git_ [ "ls-remote", TL.fromStrict remoteURI ]
ec <- lastExitCode
return $ if ec == 0
then Right ()
else Left $ Git.RepositoryCannotAccess remoteURI
cliFilePathToURI :: Git.MonadGit m => FilePath -> m Text
cliFilePathToURI =
fmap (T.append "file://localhost" . TL.toStrict . toTextIgnore)
. liftIO
. F.canonicalizePath
cliPushCommitDirectly :: Git.MonadGit m
=> CommitName m -> Text -> Text -> Maybe FilePath
-> CmdLineRepository m (CommitRef m)
cliPushCommitDirectly cname remoteNameOrURI remoteRefName msshCmd = do
repo <- cliGet
merr <- shellyNoDir $ silently $ errExit False $ do
case msshCmd of
Nothing -> return ()
Just sshCmd -> setenv "GIT_SSH" . toTextIgnore
=<< liftIO (F.canonicalizePath sshCmd)
eres <- cliRepoDoesExist remoteNameOrURI
case eres of
Left e -> return (Just e)
Right () -> do
git_ $ [ "--git-dir", repoPath repo ]
<> [ "push", TL.fromStrict remoteNameOrURI
, TL.concat [ TL.fromStrict (Git.renderCommitName cname)
, ":", TL.fromStrict remoteRefName ] ]
r <- lastExitCode
if r == 0
then return Nothing
else Just
. (\x -> if "non-fast-forward" `T.isInfixOf` x ||
"Note about fast-forwards" `T.isInfixOf` x
then Git.PushNotFastForward x
else (Git.BackendError $
"git push failed:\n" <> x))
. TL.toStrict <$> lastStderr
case merr of
Nothing -> do
mcref <- Git.resolveRef remoteRefName
case mcref of
Nothing -> failure (Git.BackendError $ "git push failed")
Just cref -> return cref
Just err -> failure err
cliResetHard :: Git.MonadGit m => Text -> CmdLineRepository m ()
cliResetHard refname =
doRunGit run_ [ "reset", "--hard", TL.fromStrict refname ] $ return ()
cliPullCommitDirectly :: Git.MonadGit m
=> Text
-> Text
-> Text
-> Text
-> Maybe FilePath
-> CmdLineRepository m
(Git.MergeResult (CmdLineRepository m))
cliPullCommitDirectly remoteNameOrURI remoteRefName user email msshCmd = do
repo <- cliGet
leftHead <- Git.resolveRef "HEAD"
eres <- shellyNoDir $ silently $ errExit False $ do
case msshCmd of
Nothing -> return ()
Just sshCmd -> setenv "GIT_SSH" . toTextIgnore
=<< liftIO (F.canonicalizePath sshCmd)
eres <- cliRepoDoesExist remoteNameOrURI
case eres of
Left e -> return (Left e)
Right () -> do
git_ $ [ "--git-dir", repoPath repo
, "config", "user.name", TL.fromStrict user
]
git_ $ [ "--git-dir", repoPath repo
, "config", "user.email", TL.fromStrict email
]
git_ $ [ "--git-dir", repoPath repo
, "-c", "merge.conflictstyle=merge"
]
<> [ "pull", "--quiet"
, TL.fromStrict remoteNameOrURI
, TL.fromStrict remoteRefName ]
Right <$> lastExitCode
case eres of
Left err -> failure err
Right r ->
if r == 0
then Git.MergeSuccess <$> getOid "HEAD"
else case leftHead of
Nothing ->
failure (Git.BackendError
"Reference missing: HEAD (left)")
Just lh -> recordMerge repo (Git.commitRefOid lh)
where
-- jww (2013-05-15): This function should not overwrite head, but simply
-- create a detached commit and return its id.
recordMerge repo leftHead = do
rightHead <- getOid "MERGE_HEAD"
xs <- shellyNoDir $ silently $ errExit False $ do
xs <- returnConflict . TL.init
<$> git [ "--git-dir", repoPath repo
, "status", "-z", "--porcelain" ]
forM_ (Map.assocs xs) $ uncurry (handleFile repo)
git_ [ "--git-dir", repoPath repo
, "commit", "-F", ".git/MERGE_MSG" ]
return xs
Git.MergeConflicted
<$> getOid "HEAD"
<*> pure leftHead
<*> pure rightHead
<*> pure (Map.fromList . filter (isConflict . snd)
. Map.toList $ xs)
isConflict (Git.Deleted, Git.Deleted) = False
isConflict (_, Git.Unchanged) = False
isConflict (Git.Unchanged, _) = False
isConflict _ = True
handleFile repo fp (Git.Deleted, Git.Deleted) =
git_ [ "--git-dir", repoPath repo, "rm", "--cached", toTextIgnore fp ]
handleFile repo fp (Git.Unchanged, Git.Deleted) =
git_ [ "--git-dir", repoPath repo, "rm", "--cached", toTextIgnore fp ]
handleFile repo fp (_, _) =
git_ [ "--git-dir", repoPath repo, "add", toTextIgnore fp ]
getOid name = do
mref <- Git.resolveRef name
case mref of
Nothing -> failure (Git.BackendError $
T.append "Reference missing: " name)
Just ref -> return (Git.commitRefOid ref)
charToModKind 'M' = Just Git.Modified
charToModKind 'U' = Just Git.Unchanged
charToModKind 'A' = Just Git.Added
charToModKind 'D' = Just Git.Deleted
charToModKind _ = Nothing
returnConflict xs =
Map.fromList
. map (\(f, (l, r)) -> (f, getModKinds l r))
. filter (\(_, (l, r)) -> ((&&) `on` isJust) l r)
. map (\l -> (fromText $ TL.drop 3 l,
(charToModKind (TL.index l 0),
charToModKind (TL.index l 1))))
. init
. TL.splitOn "\NUL" $ xs
getModKinds l r = case (l, r) of
(Nothing, Just x) -> (Git.Unchanged, x)
(Just x, Nothing) -> (x, Git.Unchanged)
-- 'U' really means unmerged, but it can mean both modified and
-- unmodified as a result. Example: UU means both sides have modified
-- a file, but AU means that the left side added the file and the
-- right side knows nothing about the file.
(Just Git.Unchanged,
Just Git.Unchanged) -> (Git.Modified, Git.Modified)
(Just x, Just y) -> (x, y)
(Nothing, Nothing) -> error "Both merge items cannot be Unchanged"
cliLookupBlob :: Git.MonadGit m
=> BlobOid m -> CmdLineRepository m (Blob m)
cliLookupBlob oid@(Tagged (Oid sha)) = do
repo <- cliGet
(r,out,_) <-
liftIO $ readProcessWithExitCode "git"
[ "--git-dir", TL.unpack (repoPath repo)
, "cat-file", "-p", TL.unpack sha ]
B.empty
if r == ExitSuccess
then return (Git.Blob oid (Git.BlobString out))
else failure Git.BlobLookupFailed
cliDoCreateBlob :: Git.MonadGit m
=> Git.BlobContents (CmdLineRepository m) -> Bool
-> CmdLineRepository m (BlobOid m)
cliDoCreateBlob b persist = do
repo <- cliGet
bs <- Git.blobContentsToByteString b
(r,out,_) <-
liftIO $ readProcessWithExitCode "git"
([ "--git-dir", TL.unpack (repoPath repo), "hash-object" ]
<> ["-w" | persist] <> ["--stdin"])
bs
if r == ExitSuccess
then return . Tagged . Oid . TL.fromStrict . T.init . T.decodeUtf8 $ out
else failure Git.BlobCreateFailed
cliHashContents :: Git.MonadGit m
=> Git.BlobContents (CmdLineRepository m)
-> CmdLineRepository m (BlobOid m)
cliHashContents b = cliDoCreateBlob b False
cliCreateBlob :: Git.MonadGit m
=> Git.BlobContents (CmdLineRepository m)
-> CmdLineRepository m (BlobOid m)
cliCreateBlob b = cliDoCreateBlob b True
cliExistsObject :: Git.MonadGit m => Oid m -> CmdLineRepository m Bool
cliExistsObject (Oid sha) = do
repo <- cliGet
shellyNoDir $ silently $ errExit False $ do
git_ [ "--git-dir", repoPath repo, "cat-file", "-e", sha ]
ec <- lastExitCode
return (ec == 0)
cliTraverseCommits :: Git.MonadGit m
=> (CommitRef m -> CmdLineRepository m a)
-> CommitName m
-> CmdLineRepository m [a]
cliTraverseCommits f name = do
shas <- doRunGit run [ "--no-pager", "log", "--format=%H"
, TL.fromStrict (Git.renderCommitName name) ]
$ return ()
mapM (\sha -> f =<< (Git.ByOid . Tagged <$> Git.parseOid (TL.toStrict sha)))
(TL.lines shas)
cliMissingObjects :: Git.MonadGit m
=> Maybe (CommitName m) -> CommitName m
-> CmdLineRepository m [Object m]
cliMissingObjects mhave need = do
shas <- doRunGit run
([ "--no-pager", "log", "--format=%H %T", "-z"]
<> (case mhave of
Nothing -> [ TL.fromStrict (Git.renderCommitName need) ]
Just have ->
[ TL.fromStrict (Git.renderCommitName have)
, TL.append "^"
(TL.fromStrict (Git.renderCommitName need)) ]))
$ return ()
concat <$> mapM (go . T.words . TL.toStrict) (TL.lines shas)
where
go [csha,tsha] = do
coid <- Git.parseOid csha
toid <- Git.parseOid tsha
return [ Git.CommitObj (Git.ByOid (Tagged coid))
, Git.TreeObj (Git.ByOid (Tagged toid))
]
go x = failure (Git.BackendError $
"Unexpected output from git-log: " <> T.pack (show x))
cliMakeTree :: Git.MonadGit m
=> IORef (Maybe (TreeOid m))
-> IORef (HashMap Text (TreeEntry m))
-> Tree m
cliMakeTree oid contents =
Git.mkTree cliModifyTree cliWriteTree cliTraverseEntries $
TreeData oid contents
cliNewTree :: Git.MonadGit m => CmdLineRepository m (Tree m)
cliNewTree = cliMakeTree <$> liftIO (newIORef Nothing)
<*> liftIO (newIORef HashMap.empty)
cliLookupTree :: Git.MonadGit m => TreeOid m -> CmdLineRepository m (Tree m)
cliLookupTree oid@(Tagged (Oid sha)) = do
contents <- runGit ["ls-tree", "-z", sha]
oidRef <- liftIO $ newIORef (Just oid)
-- Even though the tree entries are separated by \NUL, for whatever reason
-- @git ls-tree@ also outputs a newline at the end.
contentsRef <- liftIO $ newIORef $ HashMap.fromList $
map parseLine (L.init (TL.splitOn "\NUL" contents))
return $ cliMakeTree oidRef contentsRef
where
parseLine line =
let [prefix,path] = TL.splitOn "\t" line
[mode,kind,sha] = TL.words prefix
in (TL.toStrict path,
case kind of
"blob" -> Git.BlobEntry (Tagged (Oid sha)) $
case mode of
"100644" -> Git.PlainBlob
"100755" -> Git.ExecutableBlob
"120000" -> Git.SymlinkBlob
_ -> Git.UnknownBlob
"commit" -> Git.CommitEntry (Tagged (Oid sha))
"tree" -> Git.TreeEntry (Git.ByOid (Tagged (Oid sha)))
_ -> error "This cannot happen")
doLookupTreeEntry :: Git.MonadGit m => Tree m -> [Text]
-> CmdLineRepository m (Maybe (TreeEntry m))
doLookupTreeEntry t [] = return (Just (Git.treeEntry t))
doLookupTreeEntry t (name:names) = do
-- Lookup the current name in this tree. If it doesn't exist, and there are
-- more names in the path and 'createIfNotExist' is True, create a new Tree
-- and descend into it. Otherwise, if it exists we'll have @Just (TreeEntry
-- {})@, and if not we'll have Nothing.
y <- liftIO $ HashMap.lookup name
<$> readIORef (cliTreeContents (Git.getTreeData t))
if null names
then return y
else case y of
Just (Git.BlobEntry {}) ->
failure Git.TreeCannotTraverseBlob
Just (Git.CommitEntry {}) ->
failure Git.TreeCannotTraverseCommit
Just (Git.TreeEntry t') -> do
t'' <- Git.resolveTreeRef t'
doLookupTreeEntry t'' names
_ -> return Nothing
doModifyTree :: Git.MonadGit m
=> Tree m
-> [Text]
-> Bool
-> (Maybe (TreeEntry m)
-> CmdLineRepository m
(Git.ModifyTreeResult (CmdLineRepository m)))
-> CmdLineRepository m (Git.ModifyTreeResult (CmdLineRepository m))
doModifyTree t [] _ _ =
return . Git.TreeEntryPersistent . Git.TreeEntry . Git.Known $ t
doModifyTree t (name:names) createIfNotExist f = do
-- Lookup the current name in this tree. If it doesn't exist, and there
-- are more names in the path and 'createIfNotExist' is True, create a new
-- Tree and descend into it. Otherwise, if it exists we'll have @Just
-- (TreeEntry {})@, and if not we'll have Nothing.
y' <- doLookupTreeEntry t [name]
y <- if isNothing y' && createIfNotExist && not (null names)
then Just . Git.TreeEntry . Git.Known <$> Git.newTree
else return y'
if null names
then do
-- If there are no further names in the path, call the transformer
-- function, f. It receives a @Maybe TreeEntry@ to indicate if there
-- was a previous entry at this path. It should return a 'Left' value
-- to propagate out a user-defined error, or a @Maybe TreeEntry@ to
-- indicate whether the entry at this path should be deleted or
-- replaced with something new.
--
-- NOTE: There is no provision for leaving the entry unchanged! It is
-- assumed to always be changed, as we have no reliable method of
-- testing object equality that is not O(n).
ze <- f y
liftIO $ modifyIORef (cliTreeContents (Git.getTreeData t)) $
case ze of
Git.TreeEntryNotFound -> id
Git.TreeEntryPersistent _ -> id
Git.TreeEntryDeleted -> HashMap.delete name
Git.TreeEntryMutated z' -> HashMap.insert name z'
return ze
else
-- If there are further names in the path, descend them now. If
-- 'createIfNotExist' was False and there is no 'Tree' under the
-- current name, or if we encountered a 'Blob' when a 'Tree' was
-- required, throw an exception to avoid colliding with user-defined
-- 'Left' values.
case y of
Nothing -> return Git.TreeEntryNotFound
Just (Git.BlobEntry {}) -> failure Git.TreeCannotTraverseBlob
Just (Git.CommitEntry {}) -> failure Git.TreeCannotTraverseCommit
Just (Git.TreeEntry st') -> do
st <- Git.resolveTreeRef st'
ze <- doModifyTree st names createIfNotExist f
case ze of
Git.TreeEntryNotFound -> return ()
Git.TreeEntryPersistent _ -> return ()
Git.TreeEntryDeleted -> postUpdate st
Git.TreeEntryMutated _ -> postUpdate st
return ze
where
postUpdate st = liftIO $ do
modifyIORef (cliTreeOid (Git.getTreeData t)) (const Nothing)
stc <- readIORef (cliTreeContents (Git.getTreeData st))
modifyIORef (cliTreeContents (Git.getTreeData t)) $
if HashMap.null stc
then HashMap.delete name
else HashMap.insert name (Git.treeEntry st)
cliModifyTree :: Git.MonadGit m
=> Tree m -> FilePath -> Bool
-> (Maybe (TreeEntry m)
-> CmdLineRepository m
(Git.ModifyTreeResult (CmdLineRepository m)))
-> CmdLineRepository m (Maybe (TreeEntry m))
cliModifyTree t path createIfNotExist f =
Git.fromModifyTreeResult <$>
doModifyTree t (splitPath path) createIfNotExist f
splitPath :: FilePath -> [Text]
splitPath path = T.splitOn "/" text
where text = case F.toText path of
Left x -> error $ "Invalid path: " ++ T.unpack x
Right y -> y
cliWriteTree :: Git.MonadGit m
=> Tree m -> CmdLineRepository m (TreeOid m)
cliWriteTree tree = do
contents <- liftIO $ readIORef (cliTreeContents (Git.getTreeData tree))
rendered <- mapM renderLine (HashMap.toList contents)
oid <- doRunGit run ["mktree", "-z", "--missing"]
$ setStdin $ TL.append (TL.intercalate "\NUL" rendered) "\NUL"
return (Tagged (Oid (TL.init oid)))
where
renderLine (path, Git.BlobEntry (Tagged (Oid sha)) kind) =
return $ TL.concat [ case kind of
Git.PlainBlob -> "100644"
Git.ExecutableBlob -> "100755"
Git.SymlinkBlob -> "120000"
Git.UnknownBlob -> "100000"
, " blob ", sha, "\t", TL.fromStrict path ]
renderLine (path, Git.CommitEntry coid) = do
return $ TL.concat [ "160000 commit "
, TL.fromStrict (Git.renderObjOid coid), "\t"
, TL.fromStrict path ]
renderLine (path, Git.TreeEntry tref) = do
treeOid <- Git.treeRefOid tref
return $ TL.concat
[ "040000 tree "
, TL.fromStrict (Git.renderObjOid treeOid), "\t"
, TL.fromStrict path ]
cliTraverseEntries :: Git.MonadGit m
=> Tree m
-> (FilePath -> TreeEntry m -> CmdLineRepository m b)
-> CmdLineRepository m [b]
cliTraverseEntries tree f = do
Tagged (Oid sha) <- Git.writeTree tree
contents <- runGit ["ls-tree", "-t", "-r", "-z", sha]
-- Even though the tree entries are separated by \NUL, for whatever reason
-- @git ls-tree@ also outputs a newline at the end.
mapM (uncurry f) $ map parseLine (L.init (TL.splitOn "\NUL" contents))
where
parseLine line =
let [prefix,path] = TL.splitOn "\t" line
[mode,kind,sha] = TL.words prefix
in (fromText path,
case kind of
"blob" -> Git.BlobEntry (Tagged (Oid sha)) $
case mode of
"100644" -> Git.PlainBlob
"100755" -> Git.ExecutableBlob
"120000" -> Git.SymlinkBlob
_ -> Git.UnknownBlob
"commit" -> Git.CommitEntry (Tagged (Oid sha))
"tree" -> Git.TreeEntry (Git.ByOid (Tagged (Oid sha)))
_ -> error "This cannot happen")
parseCliTime :: String -> ZonedTime
parseCliTime = fromJust . parseTime defaultTimeLocale "%s %z"
formatCliTime :: ZonedTime -> Text
formatCliTime = T.pack . formatTime defaultTimeLocale "%s %z"
lexer :: TokenParser u
lexer = makeTokenParser haskellDef
cliLookupCommit :: Git.MonadGit m
=> CommitOid m -> CmdLineRepository m (Commit m)
cliLookupCommit (Tagged (Oid sha)) = do
output <- doRunGit run ["cat-file", "--batch"]
$ setStdin (TL.append sha "\n")
case parse parseOutput "" (TL.unpack output) of
Left e -> failure $ Git.CommitLookupFailed (T.pack (show e))
Right c -> return c
where
parseOutput = do
coid <- Tagged . Oid . TL.pack
<$> manyTill alphaNum space
_ <- string "commit " *> manyTill digit newline
treeOid <- string "tree " *>
(Tagged . Oid . TL.pack
<$> manyTill anyChar newline)
parentOids <- many (string "parent " *>
(Tagged . Oid . TL.pack
<$> manyTill anyChar newline))
author <- parseSignature "author"
committer <- parseSignature "committer"
message <- newline *> many anyChar
return Git.Commit
{ Git.commitOid = coid
, Git.commitAuthor = author
, Git.commitCommitter = committer
, Git.commitLog = T.pack (init message)
, Git.commitTree = Git.ByOid treeOid
, Git.commitParents = map Git.ByOid parentOids
, Git.commitEncoding = "utf-8"
}
parseSignature txt =
Git.Signature
<$> (string (T.unpack txt ++ " ")
*> (T.pack <$> manyTill anyChar (try (string " <"))))
<*> (T.pack <$> manyTill anyChar (try (string "> ")))
<*> (parseCliTime <$> manyTill anyChar newline)
cliCreateCommit :: Git.MonadGit m
=> [CommitRef m] -> TreeRef m
-> Git.Signature -> Git.Signature -> Text -> Maybe Text
-> CmdLineRepository m (Commit m)
cliCreateCommit parents tree author committer message ref = do
treeOid <- Git.treeRefOid tree
let parentOids = map Git.commitRefOid parents
oid <- doRunGit run
(["commit-tree"]
<> [TL.fromStrict (Git.renderObjOid treeOid)]
<> L.concat [["-p", TL.fromStrict (Git.renderObjOid poid)] |
poid <- parentOids])
$ do mapM_ (\(var,f,val) -> setenv var (TL.fromStrict (f val)))
[ ("GIT_AUTHOR_NAME", Git.signatureName, author)
, ("GIT_AUTHOR_EMAIL", Git.signatureEmail, author)
, ("GIT_AUTHOR_DATE",
formatCliTime . Git.signatureWhen, author)
, ("GIT_COMMITTER_NAME", Git.signatureName, committer)
, ("GIT_COMMITTER_EMAIL", Git.signatureEmail, committer)
, ("GIT_COMMITTER_DATE",
formatCliTime . Git.signatureWhen, committer)
]
setStdin (TL.fromStrict message)
let commit = Git.Commit
{ Git.commitOid = Tagged (Oid (TL.init oid))
, Git.commitAuthor = author
, Git.commitCommitter = committer
, Git.commitLog = message
, Git.commitTree = Git.ByOid treeOid
, Git.commitParents = map Git.ByOid parentOids
, Git.commitEncoding = "utf-8"
}
when (isJust ref) $
void $ cliUpdateRef (fromJust ref) (Git.RefObj (Git.Known commit))
return commit
data CliObjectRef = CliObjectRef
{ objectRefType :: Text
, objectRefSha :: Text } deriving Show
data CliReference = CliReference
{ referenceRef :: Text
, referenceObject :: CliObjectRef } deriving Show
cliShowRef :: Git.MonadGit m
=> Maybe Text -> CmdLineRepository m (Maybe [(TL.Text,TL.Text)])
cliShowRef mrefName = do
repo <- cliGet
shellyNoDir $ silently $ errExit False $ do
rev <- git $ [ "--git-dir", repoPath repo, "show-ref" ]
<> [ TL.fromStrict (fromJust mrefName) | isJust mrefName ]
ec <- lastExitCode
return $ if ec == 0
then Just $ map ((\(x:y:[]) -> (y,x)) . TL.words)
$ TL.lines rev
else Nothing
nameAndShaToRef :: TL.Text -> TL.Text -> Reference m
nameAndShaToRef name sha =
Git.Reference (TL.toStrict name)
(Git.RefObj (Git.ByOid (Tagged (Oid sha))))
cliLookupRef :: Git.MonadGit m
=> Text -> CmdLineRepository m (Maybe (Reference m))
cliLookupRef refName = do
xs <- cliShowRef (Just refName)
let name = TL.fromStrict refName
ref = maybe Nothing (lookup name) xs
return $ maybe Nothing (Just . uncurry nameAndShaToRef .
\sha -> (name,sha)) ref
cliUpdateRef :: Git.MonadGit m
=> Text -> Git.RefTarget (CmdLineRepository m) (Commit m)
-> CmdLineRepository m (Reference m)
cliUpdateRef refName refObj@(Git.RefObj commitRef) = do
let Tagged (Oid sha) = Git.commitRefOid commitRef
runGit_ ["update-ref", TL.fromStrict refName, sha]
return (Git.Reference refName refObj)
cliUpdateRef refName refObj@(Git.RefSymbolic targetName) = do
runGit_ ["symbolic-ref", TL.fromStrict refName, TL.fromStrict targetName]
return (Git.Reference refName refObj)
cliDeleteRef :: Git.MonadGit m => Text -> CmdLineRepository m ()
cliDeleteRef refName = runGit_ ["update-ref", "-d", TL.fromStrict refName]
cliAllRefs :: Git.MonadGit m
=> CmdLineRepository m [Reference m]
cliAllRefs = do
mxs <- cliShowRef Nothing
return $ case mxs of
Nothing -> []
Just xs -> map (uncurry nameAndShaToRef) xs
cliResolveRef :: Git.MonadGit m
=> Text -> CmdLineRepository m (Maybe (CommitRef m))
cliResolveRef refName = do
repo <- cliGet
shellyNoDir $ silently $ errExit False $ do
rev <- git [ "--git-dir", repoPath repo
, "rev-parse", "--quiet", "--verify"
, TL.fromStrict refName ]
ec <- lastExitCode
return $ if ec == 0
then Just (Git.ByOid (Tagged (Oid (TL.init rev))))
else Nothing
-- cliLookupTag :: TagOid -> CmdLineRepository Tag
-- cliLookupTag oid = undefined
cliCreateTag :: Git.MonadGit m
=> CommitOid m -> Git.Signature -> Text -> Text
-> CmdLineRepository m (Tag m)
cliCreateTag oid@(Tagged (Oid sha)) tagger msg name = do
tsha <- doRunGit run ["mktag"] $ setStdin $ TL.unlines $
[ "object " <> sha
, "type commit"
, "tag " <> TL.fromStrict name
, "tagger " <> TL.fromStrict (Git.signatureName tagger)
<> " <" <> TL.fromStrict (Git.signatureEmail tagger) <> "> "
<> TL.pack (formatTime defaultTimeLocale "%s %z"
(Git.signatureWhen tagger))
, ""] <> TL.lines (TL.fromStrict msg)
return $ Git.Tag (Tagged (Oid (TL.init tsha))) (Git.ByOid oid)
data Repository = Repository
{ repoOptions :: Git.RepositoryOptions
}
repoPath :: Repository -> TL.Text
repoPath = toTextIgnore . Git.repoPath . repoOptions
newtype CmdLineRepository m a = CmdLineRepository
{ cmdLineRepositoryReaderT :: ReaderT Repository m a }
instance Functor m => Functor (CmdLineRepository m) where
fmap f (CmdLineRepository x) = CmdLineRepository (fmap f x)
instance Applicative m => Applicative (CmdLineRepository m) where
pure = CmdLineRepository . pure
CmdLineRepository f <*> CmdLineRepository x = CmdLineRepository (f <*> x)
instance Monad m => Monad (CmdLineRepository m) where
return = CmdLineRepository . return
CmdLineRepository m >>= f =
CmdLineRepository (m >>= cmdLineRepositoryReaderT . f)
instance MonadIO m => MonadIO (CmdLineRepository m) where
liftIO m = CmdLineRepository (liftIO m)
instance (Monad m, MonadIO m, Applicative m)
=> MonadBase IO (CmdLineRepository m) where
liftBase = liftIO
instance Monad m => MonadUnsafeIO (CmdLineRepository m) where
unsafeLiftIO = return . unsafePerformIO
instance Monad m => MonadThrow (CmdLineRepository m) where
monadThrow = throw
instance MonadTrans CmdLineRepository where
lift = CmdLineRepository . ReaderT . const
instance MonadTransControl CmdLineRepository where
newtype StT CmdLineRepository a = StCmdLineRepository
{ unCmdLineRepository :: StT (ReaderT Repository) a
}
liftWith = defaultLiftWith CmdLineRepository
cmdLineRepositoryReaderT StCmdLineRepository
restoreT = defaultRestoreT CmdLineRepository unCmdLineRepository
instance (MonadIO m, MonadBaseControl IO m)
=> MonadBaseControl IO (CmdLineRepository m) where
newtype StM (CmdLineRepository m) a = StMT
{ unStMT :: ComposeSt CmdLineRepository m a
}
liftBaseWith = defaultLiftBaseWith StMT
restoreM = defaultRestoreM unStMT
cliGet :: Monad m => CmdLineRepository m Repository
cliGet = CmdLineRepository ask
cliFactory :: Git.MonadGit m
=> Git.RepositoryFactory CmdLineRepository m Repository
cliFactory = Git.RepositoryFactory
{ Git.openRepository = openCliRepository
, Git.runRepository = runCliRepository
, Git.closeRepository = closeCliRepository
, Git.getRepository = cliGet
, Git.defaultOptions = defaultCliOptions
, Git.startupBackend = return ()
, Git.shutdownBackend = return ()
}
openCliRepository :: Git.MonadGit m => Git.RepositoryOptions -> m Repository
openCliRepository opts = do
let path = Git.repoPath opts
exists <- liftIO $ F.isDirectory path
case F.toText path of
Left e -> failure (Git.BackendError e)
Right p -> do
when (not exists && Git.repoAutoCreate opts) $
shellyNoDir $ silently $
git_ $ ["--git-dir", TL.fromStrict p]
<> ["--bare" | Git.repoIsBare opts]
<> ["init"]
return Repository { repoOptions = opts }
runCliRepository :: Git.MonadGit m => Repository -> CmdLineRepository m a -> m a
runCliRepository repo action =
runReaderT (cmdLineRepositoryReaderT action) repo
closeCliRepository :: Git.MonadGit m => Repository -> m ()
closeCliRepository = const (return ())
defaultCliOptions :: Git.RepositoryOptions
defaultCliOptions = Git.RepositoryOptions "" False False
-- Cli.hs