module VCSWrapper.Git.Safe (
initDB
, add
, rm
, commit
, checkout
, status
, simpleLog
, localBranches
, revparse
, remote
, pull
, push
, runVcs
, module VCSWrapper.Git.Types
) where
import Control.Applicative
import Prelude
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 ((<>))
import Control.Monad (void)
initDB :: Bool
-> Ctx (Either VCSException ())
initDB bare = do
let opts = if bare then ["--bare"] else []
void <$> gitExec' "init-db" opts []
add :: [ FilePath ]
-> Ctx (Either VCSException ())
add paths = do
let opts = "--" : paths
void <$> gitExec' "add" (map T.pack opts) []
rm :: [ FilePath ]
-> Ctx (Either VCSException ())
rm paths = do
let opts = "--" : map T.pack paths
void <$> gitExec' "rm" opts []
commit :: [ FilePath ]
-> Maybe (Text, Text)
-> Text
-> [Text]
-> Ctx (Either VCSException ())
commit rsrcs mbAuthor logmsg extraopts =
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
void <$> gitExec' "commit" opts []
checkout :: Maybe Text
-> Maybe Text
-> Ctx (Either VCSException ())
checkout rev branch = do
let bopt = maybe [] (\b -> [ "-b", b ]) branch
let copt = maybeToList rev
void <$> gitExec' "checkout" (bopt ++ copt) []
status :: Ctx (Either VCSException [Status])
status = do
e <- gitExec' "status" ["--porcelain"] []
return (fmap parseStatus e)
simpleLog :: Maybe Text
-> Ctx (Either VCSException [LogEntry])
simpleLog mbBranch = do
e <- gitExec' "log" (maybeToList mbBranch ++ ["--pretty=tformat:commit:%H%n%an%n%ae%n%ai%n%s%n%b%x00", "--"]) []
return (fmap parseSimpleLog e)
localBranches :: Ctx (Either VCSException (Text, [Text]))
localBranches = do
e <- gitExec' "branch" [] []
return (fmap parseBranches e)
remote :: Ctx (Either VCSException [Text])
remote = do
e <- gitExec' "remote" [] []
return (fmap parseRemotes e)
push :: Ctx (Either VCSException ())
push = void <$> gitExec' "push" [] []
pull :: Ctx (Either VCSException (Maybe Text))
pull = do
o <- gitExec' "pull" [] []
case o of
Left exc@(VCSException _ out _ _ _) | parsePullMergeConflict out ->
return $ Right (Just out)
Left e -> return (Left e)
Right _ -> return (Right Nothing)
revparse :: Text
-> Ctx (Either VCSException Text)
revparse commit = do
o <- gitExec' "rev-parse" [commit] []
return $ fmap T.strip o