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 qualified Data.HashMap.Strict as HashMap
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
#if MIN_VERSION_shelly(1, 0, 0)
import qualified Data.Text as TL
#else
import qualified Data.Text.Lazy as TL
#endif
import Data.Time
import Data.Tuple
import qualified Filesystem as F
import qualified Filesystem.Path.CurrentOS as F
import qualified Git
import qualified Git.Tree.Builder.Pure as Pure
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
toStrict :: TL.Text -> T.Text
#if MIN_VERSION_shelly(1, 0, 0)
toStrict = id
#else
toStrict = TL.toStrict
#endif
fromStrict :: T.Text -> TL.Text
#if MIN_VERSION_shelly(1, 0, 0)
fromStrict = id
#else
fromStrict = TL.fromStrict
#endif
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 Object m = Git.Object (CmdLineRepository m)
type ObjectOid m = Git.ObjectOid (CmdLineRepository m)
type RefTarget m = Git.RefTarget (CmdLineRepository m)
type TreeBuilder m = Git.TreeBuilder (CmdLineRepository m)
type ModifiedBuilder m = Git.ModifiedBuilder (CmdLineRepository m)
instance Git.MonadGit m => Git.Repository (CmdLineRepository m) where
type Oid (CmdLineRepository m) = Git.SHA
data Tree (CmdLineRepository m) = CmdLineTree (TreeOid m)
data Options (CmdLineRepository m) = Options
facts = return Git.RepositoryFacts
{ Git.hasSymbolicReferences = True }
parseOid = Git.textToSha
lookupReference = cliLookupRef
createReference = cliUpdateRef
updateReference = cliUpdateRef
deleteReference = cliDeleteRef
listReferences = cliListRefs
lookupCommit = cliLookupCommit
lookupTree = cliLookupTree
lookupBlob = cliLookupBlob
lookupTag = error "Not defined CmdLineRepository.cliLookupTag"
lookupObject = error "Not defined CmdLineRepository.cliLookupObject"
existsObject = cliExistsObject
sourceObjects = cliSourceObjects
newTreeBuilder = Pure.newPureTreeBuilder cliReadTree cliWriteTree
treeEntry = cliTreeEntry
listTreeEntries = cliListTreeEntries
treeOid = \(CmdLineTree toid) -> toid
hashContents = cliHashContents
createBlob = cliCreateBlob
createCommit = cliCreateCommit
createTag = cliCreateTag
deleteRepository =
cliGet >>= liftIO . F.removeTree . Git.repoPath . repoOptions
mkOid :: Git.MonadGit m
=> forall o. TL.Text -> CmdLineRepository m (Tagged o Git.SHA)
mkOid = fmap Tagged <$> Git.textToSha . toStrict
shaToRef :: Git.MonadGit m => TL.Text -> CmdLineRepository m (RefTarget m)
shaToRef = fmap Git.RefObj . mkOid
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
git :: [TL.Text] -> Sh TL.Text
git = run "git"
git_ :: [TL.Text] -> Sh ()
git_ = run_ "git"
doRunGit :: Git.MonadGit m
=> (FilePath -> [TL.Text] -> Sh a) -> [TL.Text] -> Sh ()
-> CmdLineRepository m a
doRunGit f args act = do
repo <- cliGet
shellyNoDir $ verbosely $ do
act
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", 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" . toStrict . toTextIgnore)
. liftIO
. F.canonicalizePath
cliPushCommit :: Git.MonadGit m
=> CommitOid m -> Text -> Text -> Maybe FilePath
-> CmdLineRepository m (CommitOid m)
cliPushCommit cname remoteNameOrURI remoteRefName msshCmd = do
repo <- cliGet
merr <- shellyNoDir $ verbosely $ 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", fromStrict remoteNameOrURI
, TL.concat [ fromStrict (Git.renderObjOid cname)
, ":", 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))
. toStrict <$> lastStderr
case merr of
Nothing -> do
mcref <- Git.resolveReference 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", fromStrict refname ] $ return ()
cliPullCommit :: Git.MonadGit m
=> Text
-> Text
-> Text
-> Text
-> Maybe FilePath
-> CmdLineRepository m
(Git.MergeResult (CmdLineRepository m))
cliPullCommit remoteNameOrURI remoteRefName user email msshCmd = do
repo <- cliGet
leftHead <- cliResolveRef "HEAD"
eres <- shellyNoDir $ verbosely $ 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", fromStrict user
]
git_ $ [ "--git-dir", repoPath repo
, "config", "user.email", fromStrict email
]
git_ $ [ "--git-dir", repoPath repo
, "-c", "merge.conflictstyle=merge"
]
<> [ "pull", "--quiet"
, fromStrict remoteNameOrURI
, 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 lh
where
recordMerge repo leftHead = do
rightHead <- getOid "MERGE_HEAD"
xs <- shellyNoDir $ verbosely $ 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", fromStrict fp ]
handleFile repo fp (Git.Unchanged, Git.Deleted) =
git_ [ "--git-dir", repoPath repo, "rm", "--cached", fromStrict fp ]
handleFile repo fp (_, _) =
git_ [ "--git-dir", repoPath repo, "add", fromStrict fp ]
getOid name = do
mref <- cliResolveRef name
case mref of
Nothing -> failure (Git.BackendError $
T.append "Reference missing: " name)
Just ref -> return 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 -> (toStrict $ 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)
(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@(Git.renderObjOid -> sha) = do
repo <- cliGet
(r,out,_) <-
liftIO $ readProcessWithExitCode "git"
[ "--git-dir", TL.unpack (repoPath repo)
, "cat-file", "-p", TL.unpack (fromStrict 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 mkOid . 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
=> Git.SHA -> CmdLineRepository m Bool
cliExistsObject (Git.shaToText -> sha) = do
repo <- cliGet
shellyNoDir $ verbosely $ errExit False $ do
git_ [ "--git-dir", repoPath repo, "cat-file", "-e", fromStrict sha ]
ec <- lastExitCode
return (ec == 0)
cliSourceObjects :: Git.MonadGit m
=> Maybe (CommitOid m) -> CommitOid m -> Bool
-> Source (CmdLineRepository m) (ObjectOid m)
cliSourceObjects mhave need alsoTrees = do
shas <- lift $ doRunGit run
([ "--no-pager", "log", "--format=%H %T" ]
<> (case mhave of
Nothing -> [ fromStrict (Git.renderObjOid need) ]
Just have ->
[ fromStrict (Git.renderObjOid have)
, TL.append "^"
(fromStrict (Git.renderObjOid need)) ]))
$ return ()
mapM_ (go . T.words . toStrict) (TL.lines shas)
where
go [csha,tsha] = do
coid <- lift $ Git.parseObjOid csha
yield $ Git.CommitObjOid coid
when alsoTrees $ do
toid <- lift $ Git.parseObjOid tsha
yield $ Git.TreeObjOid toid
go x = failure (Git.BackendError $
"Unexpected output from git-log: " <> T.pack (show x))
cliReadTree :: Git.MonadGit m
=> Tree m
-> CmdLineRepository m (Pure.EntryHashMap (CmdLineRepository m))
cliReadTree (CmdLineTree (Git.renderObjOid -> sha)) = do
contents <- runGit ["ls-tree", "-z", fromStrict sha]
HashMap.fromList
<$> mapM cliParseLsTree (L.init (TL.splitOn "\NUL" contents))
cliParseLsTree :: Git.MonadGit m
=> TL.Text -> CmdLineRepository m (Text, TreeEntry m)
cliParseLsTree line =
let [prefix,path] = TL.splitOn "\t" line
[mode,kind,sha] = TL.words prefix
in liftM2 (,) (return (toStrict path)) $ case kind of
"blob" -> do
oid <- mkOid sha
return $ Git.BlobEntry oid $ case mode of
"100644" -> Git.PlainBlob
"100755" -> Git.ExecutableBlob
"120000" -> Git.SymlinkBlob
_ -> Git.UnknownBlob
"commit" -> Git.CommitEntry <$> mkOid sha
"tree" -> Git.TreeEntry <$> mkOid sha
_ -> failure (Git.BackendError "This cannot happen")
cliWriteTree :: Git.MonadGit m
=> Pure.EntryHashMap (CmdLineRepository m)
-> CmdLineRepository m (TreeOid m)
cliWriteTree entMap = do
rendered <- mapM renderLine (HashMap.toList entMap)
when (null rendered) $ failure Git.TreeEmptyCreateFailed
oid <- doRunGit run ["mktree", "-z", "--missing"]
$ setStdin $ TL.append (TL.intercalate "\NUL" rendered) "\NUL"
mkOid (TL.init oid)
where
renderLine (path, Git.BlobEntry (Git.renderObjOid -> sha) kind) =
return $ TL.concat [ case kind of
Git.PlainBlob -> "100644"
Git.ExecutableBlob -> "100755"
Git.SymlinkBlob -> "120000"
Git.UnknownBlob -> "100000"
, " blob ", fromStrict sha, "\t", fromStrict path ]
renderLine (path, Git.CommitEntry coid) = do
return $ TL.concat [ "160000 commit "
, fromStrict (Git.renderObjOid coid), "\t"
, fromStrict path ]
renderLine (path, Git.TreeEntry toid) = do
return $ TL.concat
[ "040000 tree "
, fromStrict (Git.renderObjOid toid), "\t"
, fromStrict path ]
cliLookupTree :: Git.MonadGit m => TreeOid m -> CmdLineRepository m (Tree m)
cliLookupTree oid@(Git.renderObjOid -> sha) = do
repo <- cliGet
ec <- shellyNoDir $ verbosely $ errExit False $ do
git_ $ [ "--git-dir", repoPath repo, "cat-file", "-t", fromStrict sha ]
lastExitCode
if ec == 0
then return $ CmdLineTree oid
else failure (Git.ObjectLookupFailed sha 40)
cliTreeEntry :: Git.MonadGit m => Tree m -> Text
-> CmdLineRepository m (Maybe (TreeEntry m))
cliTreeEntry tree fp = do
repo <- cliGet
mentryLines <- shellyNoDir $ verbosely $ errExit False $ do
contents <- git $ [ "--git-dir", repoPath repo
, "ls-tree", "-z"
, fromStrict (Git.renderObjOid (Git.treeOid tree))
, "--", fromStrict fp ]
ec <- lastExitCode
return $ if ec == 0
then Just $ L.init (TL.splitOn "\NUL" contents)
else Nothing
case mentryLines of
Nothing -> return Nothing
Just entryLines -> do
entries <- mapM cliParseLsTree entryLines
return $ case entries of
[] -> Nothing
((_,x):_) -> Just x
cliListTreeEntries :: Git.MonadGit m
=> Tree m
-> CmdLineRepository m [(Text, TreeEntry m)]
cliListTreeEntries tree = do
contents <- runGit [ "ls-tree", "-t", "-r", "-z"
, fromStrict (Git.renderObjOid (Git.treeOid tree)) ]
mapM cliParseLsTree (L.init (TL.splitOn "\NUL" contents))
cliLookupCommit :: Git.MonadGit m
=> CommitOid m -> CmdLineRepository m (Commit m)
cliLookupCommit (Git.renderObjOid -> sha) = do
output <- doRunGit run ["cat-file", "--batch"]
$ setStdin (TL.append (fromStrict sha) "\n")
result <- runParserT parseOutput () "" (TL.unpack output)
case result of
Left e -> failure $ Git.CommitLookupFailed (T.pack (show e))
Right c -> return c
where
parseOutput = do
coid <- manyTill alphaNum space
_ <- string "commit " *> manyTill digit newline
treeOid <- string "tree " *> manyTill anyChar newline
parentOids <- many (string "parent " *> manyTill anyChar newline)
author <- parseSignature "author"
committer <- parseSignature "committer"
message <- newline *> many anyChar
coid' <- lift $ mkOid (TL.pack coid)
toid' <- lift $ mkOid (TL.pack treeOid)
poids' <- lift $ mapM (mkOid . TL.pack) parentOids
return Git.Commit
{ Git.commitOid = coid'
, Git.commitAuthor = author
, Git.commitCommitter = committer
, Git.commitLog = T.pack (init message)
, Git.commitTree = toid'
, Git.commitParents = poids'
, 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
=> [CommitOid m]
-> TreeOid m
-> Git.Signature
-> Git.Signature
-> Text
-> Maybe Text
-> CmdLineRepository m (Commit m)
cliCreateCommit parentOids treeOid author committer message ref = do
oid <- doRunGit run
(["commit-tree"]
<> [fromStrict (Git.renderObjOid treeOid)]
<> L.concat [["-p", fromStrict (Git.renderObjOid poid)] |
poid <- parentOids])
$ do mapM_ (\(var,f,val) -> setenv var (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 (fromStrict message)
coid <- mkOid (TL.init oid)
let commit = Git.Commit
{ Git.commitOid = coid
, Git.commitAuthor = author
, Git.commitCommitter = committer
, Git.commitLog = message
, Git.commitTree = treeOid
, Git.commitParents = parentOids
, Git.commitEncoding = "utf-8"
}
when (isJust ref) $
void $ cliUpdateRef (fromJust ref) (Git.RefObj (Git.commitOid 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 $ verbosely $ errExit False $ do
rev <- git $ [ "--git-dir", repoPath repo, "show-ref" ]
<> [ 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
cliLookupRef :: Git.MonadGit m
=> Text -> CmdLineRepository m (Maybe (RefTarget m))
cliLookupRef refName = do
repo <- cliGet
(ec,rev) <- shellyNoDir $ verbosely $ errExit False $ do
rev <- git $ [ "--git-dir", repoPath repo
, "symbolic-ref", fromStrict refName ]
ec <- lastExitCode
return (ec,rev)
if ec == 0
then return . Just . Git.RefSymbolic . toStrict . TL.init $ rev
else fmap Git.RefObj <$> cliResolveRef refName
cliUpdateRef :: Git.MonadGit m
=> Text -> Git.RefTarget (CmdLineRepository m)
-> CmdLineRepository m ()
cliUpdateRef refName (Git.RefObj (Git.renderObjOid -> sha)) =
runGit_ ["update-ref", fromStrict refName, fromStrict sha]
cliUpdateRef refName (Git.RefSymbolic targetName) =
runGit_ ["symbolic-ref", fromStrict refName, fromStrict targetName]
cliDeleteRef :: Git.MonadGit m => Text -> CmdLineRepository m ()
cliDeleteRef refName = runGit_ ["update-ref", "-d", fromStrict refName]
cliListRefs :: Git.MonadGit m
=> CmdLineRepository m [Text]
cliListRefs = do
mxs <- cliShowRef Nothing
return $ case mxs of
Nothing -> []
Just xs -> map (toStrict . fst) xs
cliResolveRef :: Git.MonadGit m
=> Text -> CmdLineRepository m (Maybe (CommitOid m))
cliResolveRef refName = do
repo <- cliGet
(rev, ec) <- shellyNoDir $ verbosely $ errExit False $ do
rev <- git [ "--git-dir", repoPath repo
, "rev-parse", "--quiet", "--verify"
, fromStrict refName ]
ec <- lastExitCode
return (rev, ec)
if ec == 0
then Just <$> mkOid (TL.init rev)
else return Nothing
cliCreateTag :: Git.MonadGit m
=> CommitOid m -> Git.Signature -> Text -> Text
-> CmdLineRepository m (Tag m)
cliCreateTag oid@(Git.renderObjOid -> sha) tagger msg name = do
tsha <- doRunGit run ["mktag"] $ setStdin $ TL.unlines $
[ "object " <> fromStrict sha
, "type commit"
, "tag " <> fromStrict name
, "tagger " <> fromStrict (Git.signatureName tagger)
<> " <" <> fromStrict (Git.signatureEmail tagger) <> "> "
<> TL.pack (formatTime defaultTimeLocale "%s %z"
(Git.signatureWhen tagger))
, ""] <> TL.lines (fromStrict msg)
Git.Tag <$> mkOid (TL.init tsha) <*> pure 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) $ do
liftIO $ F.createTree (fromText (fromStrict p))
shellyNoDir $ verbosely $
git_ $ ["--git-dir", 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