module VCSWrapper.Git (
initDB
, add
, rm
, commit
, checkout
, status
, simpleLog
, localBranches
, revparse
, remote
, pull
, push
, runVcs
, module VCSWrapper.Git.Types
) where
import System.Directory
import Control.Monad.Trans
import qualified Control.Exception as Exc
import VCSWrapper.Git.Parsers
import VCSWrapper.Git.Process
import VCSWrapper.Git.Types
import VCSWrapper.Common.VCSMonad (runVcs)
import Data.Maybe
import qualified Data.List
import Data.Text (Text)
import qualified Data.Text as T (strip, pack)
import Data.Monoid ((<>))
initDB :: Bool
-> Ctx ()
initDB bare = do
let opts = if bare then ["--bare"] else []
gitExecWithoutResult "init-db" opts []
add :: [ FilePath ]
-> Ctx ()
add paths = do
let opts = "--" : paths
gitExecWithoutResult "add" (map T.pack opts) []
rm :: [ FilePath ]
-> Ctx ()
rm paths = do
let opts = "--" : map T.pack paths
gitExecWithoutResult "rm" opts []
commit :: [ FilePath ]
-> Maybe (Text, Text)
-> Text
-> [Text]
-> Ctx ()
commit rsrcs mbAuthor logmsg extraopts = do
case mbAuthor of
Just (author, author_email) ->
commit' (map T.pack rsrcs) logmsg extraopts ["--author", author <> " <" <> author_email <> ">"]
Nothing ->
commit' (map T.pack rsrcs) logmsg extraopts []
where
commit' files logmsg extraopts authopts = do
let msgopts = [ "-m", logmsg ]
let opts = authopts ++ msgopts ++ extraopts ++ [ "--" ] ++ files
gitExecWithoutResult "commit" opts []
checkout :: Maybe Text
-> Maybe Text
-> Ctx ()
checkout rev branch = do
let bopt = maybe [] (\b -> [ "-b", b ]) branch
let copt = maybeToList rev
gitExecWithoutResult "checkout" (bopt ++ copt) []
status :: Ctx [Status]
status = do
o <- gitExec "status" ["--porcelain"] []
return $ parseStatus o
simpleLog :: Maybe Text
-> Ctx [LogEntry]
simpleLog mbBranch = do
o <- gitExec "log" ((branch mbBranch) ++ ["--pretty=tformat:commit:%H%n%an%n%ae%n%ai%n%s%n%b%x00", "--"]) []
return $ parseSimpleLog o
where
branch Nothing = []
branch (Just b) = [b]
localBranches :: Ctx (Text, [Text])
localBranches = do
o <- gitExec "branch" [] []
return $ parseBranches o
remote :: Ctx [Text]
remote = do
o <- gitExec "remote" [] []
return $ parseRemotes o
push :: Ctx ()
push = gitExecWithoutResult "push" [] []
pull :: Ctx (Either Text ())
pull = do
o <- gitExec' "pull" [] []
case o of
Right _ -> return $ Right ()
Left exc@(VCSException _ out _ _ _) -> if (parsePullMergeConflict out) then return $ Left out
else Exc.throw exc
revparse :: Text
-> Ctx (Text)
revparse commit = do
o <- gitExec "rev-parse" [commit] []
return $ T.strip o