module Data.Git.Monad
(
GitMonad(..)
, GitM
, withRepo
, withCurrentRepo
, Resolvable(..)
, branchList
, branchWrite
, tagList
, tagWrite
, headGet
, headResolv
, headSet
, getCommit
, CommitAccessM
, withCommit
, getAuthor
, getCommitter
, getParents
, getExtras
, getEncoding
, getMessage
, getFile
, getDir
, CommitM
, withNewCommit
, withBranch
, setAuthor
, setCommitter
, setParents
, setExtras
, setEncoding
, setMessage
, setFile
, deleteFile
, Git.Git
, Git.Ref
, Git.RefName(..)
, Git.Commit(..)
, Git.Person(..)
) where
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Git as Git
import qualified Data.Git.Revision as Git
import qualified Data.Git.Repository as Git
import qualified Data.Git.Storage.Object as Git
import Data.Git.Imports
import Data.Git.OS
import Data.Set (Set)
revisionFromString :: String -> Git.Revision
revisionFromString = Git.fromString
class Resolvable rev where
resolve :: GitMonad m => rev -> m (Maybe Git.Ref)
instance Resolvable Git.Ref where
resolve = return . Just
instance Resolvable Git.Revision where
resolve rev = do
git <- getGit
liftGit $ Git.resolveRevision git rev
instance Resolvable String where
resolve = resolve . revisionFromString
instance Resolvable Git.RefName where
resolve = resolve . Git.refNameRaw
class (Functor m, Applicative m, Monad m) => GitMonad m where
getGit :: m Git.Git
liftGit :: IO a -> m a
branchList :: GitMonad git => git (Set Git.RefName)
branchList = getGit >>= liftGit . Git.branchList
branchWrite :: GitMonad git => Git.RefName -> Git.Ref -> git ()
branchWrite rn ref = do
git <- getGit
liftGit $ Git.branchWrite git rn ref
tagList :: GitMonad git => git (Set Git.RefName)
tagList = getGit >>= liftGit . Git.tagList
tagWrite :: GitMonad git => Git.RefName -> Git.Ref -> git ()
tagWrite rn ref = do
git <- getGit
liftGit $ Git.tagWrite git rn ref
headGet :: GitMonad git => git (Either Git.Ref Git.RefName)
headGet = getGit >>= liftGit . Git.headGet
headResolv :: GitMonad git => git (Maybe Git.Ref)
headResolv = do
e <- headGet
case e of
Left ref -> resolve ref
Right v -> resolve v
headSet :: GitMonad git => Either Git.Ref Git.RefName -> git ()
headSet e = do
git <- getGit
liftGit $ Git.headSet git e
getCommit :: (GitMonad git, Resolvable ref) => ref -> git (Maybe Git.Commit)
getCommit r = do
mRef <- resolve r
case mRef of
Nothing -> return Nothing
Just ref -> do
git <- getGit
liftGit $ Git.getCommitMaybe git ref
setObject :: (GitMonad git, Git.Objectable obj) => obj -> git Git.Ref
setObject obj = do
git <- getGit
liftGit $ Git.setObject git $ Git.toObject obj
getObject :: (GitMonad git, Resolvable ref)
=> ref
-> Bool
-> git (Maybe Git.Object)
getObject rev resolvDelta = do
git <- getGit
mRef <- resolve rev
case mRef of
Nothing -> return Nothing
Just ref -> liftGit $ Git.getObject git ref resolvDelta
workTreeNew :: GitMonad git => git Git.WorkTree
workTreeNew = liftGit Git.workTreeNew
workTreeFrom :: GitMonad git => Git.Ref -> git Git.WorkTree
workTreeFrom ref = liftGit $ Git.workTreeFrom ref
workTreeFlush :: GitMonad git => Git.WorkTree -> git Git.Ref
workTreeFlush tree = do
git <- getGit
liftGit $ Git.workTreeFlush git tree
resolvPath :: (GitMonad git, Resolvable ref)
=> ref
-> Git.EntPath
-> git (Maybe Git.Ref)
resolvPath commitRev entPath = do
git <- getGit
mRef <- resolve commitRev
case mRef of
Nothing -> return Nothing
Just ref -> liftGit $ Git.resolvePath git ref entPath
data Result ctx a
= ResultSuccess !ctx !a
| ResultFailure !String
data GitContext = GitContext
{ gitContextGit :: !Git.Git
}
newtype GitM a = GitM
{ runGitM :: GitContext -> IO (Result GitContext a)
}
instance Functor GitM where
fmap = fmapGitM
instance Applicative GitM where
pure = returnGitM
(<*>) = appendGitM
instance Monad GitM where
return = returnGitM
(>>=) = bindGitM
fail = failGitM
instance GitMonad GitM where
getGit = getGitM
liftGit = liftGitM
fmapGitM :: (a -> b) -> GitM a -> GitM b
fmapGitM f m = GitM $ \ctx -> do
r <- runGitM m ctx
return $ case r of
ResultSuccess ctx' v -> ResultSuccess ctx' (f v)
ResultFailure err -> ResultFailure err
returnGitM :: a -> GitM a
returnGitM v = GitM $ \ctx -> return (ResultSuccess ctx v)
appendGitM :: GitM (a -> b) -> GitM a -> GitM b
appendGitM m1f m2 = m1f >>= \f -> m2 >>= \v -> return (f v)
bindGitM :: GitM a -> (a -> GitM b) -> GitM b
bindGitM m fm = GitM $ \ctx -> do
r <- runGitM m ctx
case r of
ResultSuccess ctx' v -> runGitM (fm v) ctx'
ResultFailure err -> return (ResultFailure err)
failGitM :: String -> GitM a
failGitM msg = GitM $ \_ -> return (ResultFailure msg)
getGitM :: GitM Git.Git
getGitM = GitM $ \ctx -> return (ResultSuccess ctx (gitContextGit ctx))
liftGitM :: IO a -> GitM a
liftGitM f = GitM $ \ctx -> ResultSuccess ctx <$> f
executeGitM :: Git.Git -> GitM a -> IO (Either String a)
executeGitM git m = do
r <- runGitM m $ GitContext git
return $ case r of
ResultSuccess _ v -> Right v
ResultFailure err -> Left err
withRepo :: LocalPath -> GitM a -> IO (Either String a)
withRepo repoPath m = Git.withRepo repoPath (\git -> executeGitM git m)
withCurrentRepo :: GitM a -> IO (Either String a)
withCurrentRepo m = Git.withCurrentRepo (\git -> executeGitM git m)
data CommitAccessContext = CommitAccessContext
{ commitAccessContextCommit :: !Git.Commit
, commitAccessContextRef :: !Git.Ref
}
newtype CommitAccessM a = CommitAccessM
{ runCommitAccessM :: forall git . GitMonad git => CommitAccessContext -> git (Result CommitAccessContext a)
}
instance Functor CommitAccessM where
fmap = fmapCommitAccessM
instance Applicative CommitAccessM where
pure = returnCommitAccessM
(<*>) = appendCommitAccessM
instance Monad CommitAccessM where
return = returnCommitAccessM
(>>=) = bindCommitAccessM
fail = failCommitAccessM
instance GitMonad CommitAccessM where
getGit = getCommitAccessM
liftGit = liftCommitAccessM
fmapCommitAccessM :: (a -> b) -> CommitAccessM a -> CommitAccessM b
fmapCommitAccessM f m = CommitAccessM $ \ctx -> do
r <- runCommitAccessM m ctx
return $ case r of
ResultSuccess ctx' v -> ResultSuccess ctx' (f v)
ResultFailure err -> ResultFailure err
returnCommitAccessM :: a -> CommitAccessM a
returnCommitAccessM v = CommitAccessM $ \ctx -> return (ResultSuccess ctx v)
appendCommitAccessM :: CommitAccessM (a -> b) -> CommitAccessM a -> CommitAccessM b
appendCommitAccessM m1f m2 = m1f >>= \f -> m2 >>= \v -> return (f v)
bindCommitAccessM :: CommitAccessM a -> (a -> CommitAccessM b) -> CommitAccessM b
bindCommitAccessM m fm = CommitAccessM $ \ctx -> do
r <- runCommitAccessM m ctx
case r of
ResultSuccess ctx' v -> runCommitAccessM (fm v) ctx'
ResultFailure err -> return (ResultFailure err)
failCommitAccessM :: String -> CommitAccessM a
failCommitAccessM msg = CommitAccessM $ \_ -> return (ResultFailure msg)
getCommitAccessM :: CommitAccessM Git.Git
getCommitAccessM = CommitAccessM $ \ctx -> ResultSuccess ctx <$> getGit
liftCommitAccessM :: IO a -> CommitAccessM a
liftCommitAccessM f = CommitAccessM $ \ctx -> ResultSuccess ctx <$> (liftGit f)
withCommitAccessContext :: (CommitAccessContext -> a) -> CommitAccessM a
withCommitAccessContext operation = CommitAccessM $ \ctx ->
return $ ResultSuccess ctx $ operation ctx
getAuthor :: CommitAccessM Git.Person
getAuthor = withCommitAccessContext (Git.commitAuthor . commitAccessContextCommit)
getCommitter :: CommitAccessM Git.Person
getCommitter = withCommitAccessContext (Git.commitCommitter . commitAccessContextCommit)
getParents :: CommitAccessM [Git.Ref]
getParents = withCommitAccessContext (Git.commitParents . commitAccessContextCommit)
getExtras :: CommitAccessM [Git.CommitExtra]
getExtras = withCommitAccessContext (Git.commitExtras . commitAccessContextCommit)
getEncoding :: CommitAccessM (Maybe ByteString)
getEncoding = withCommitAccessContext (Git.commitEncoding . commitAccessContextCommit)
getMessage :: CommitAccessM ByteString
getMessage = withCommitAccessContext (Git.commitMessage . commitAccessContextCommit)
getContextRef_ :: CommitAccessM Git.Ref
getContextRef_ = withCommitAccessContext commitAccessContextRef
getContextObject_ :: Git.EntPath -> CommitAccessM (Maybe Git.Object)
getContextObject_ fp = do
commitRef <- getContextRef_
mRef <- resolvPath commitRef fp
case mRef of
Nothing -> return Nothing
Just ref -> getObject ref True
getFile :: Git.EntPath -> CommitAccessM (Maybe BL.ByteString)
getFile fp = do
mObj <- getContextObject_ fp
return $ case mObj of
Nothing -> Nothing
Just obj -> case Git.objectToBlob obj of
Nothing -> Nothing
Just b -> Just $ Git.blobGetContent b
getDir :: Git.EntPath -> CommitAccessM (Maybe [Git.EntName])
getDir fp = do
mObj <- getContextObject_ fp
return $ case mObj of
Nothing -> Nothing
Just obj -> case Git.objectToTree obj of
Nothing -> Nothing
Just tree -> Just $ map (\(_, n, _) -> n) $ Git.treeGetEnts tree
withCommit :: (Resolvable ref, GitMonad git)
=> ref
-> CommitAccessM a
-> git a
withCommit rev m = do
mRef <- resolve rev
case mRef of
Nothing -> fail "revision does not exist"
Just ref -> do
mCommit <- getCommit ref
case mCommit of
Nothing -> fail $ "the given ref does not exist or is not a commit"
Just commit -> do
let ctx = CommitAccessContext
{ commitAccessContextCommit = commit
, commitAccessContextRef = ref
}
r <- runCommitAccessM m ctx
case r of
ResultFailure err -> fail err
ResultSuccess _ a -> return a
data CommitContext = CommitContext
{ commitContextAuthor :: !Git.Person
, commitContextCommitter :: !Git.Person
, commitContextParents :: ![Git.Ref]
, commitContextExtras :: ![Git.CommitExtra]
, commitContextEncoding :: !(Maybe ByteString)
, commitContextMessage :: !ByteString
, commitContextTree :: !Git.WorkTree
}
newtype CommitM a = CommitM
{ runCommitM :: forall git . GitMonad git => CommitContext -> git (Result CommitContext a)
}
instance Functor CommitM where
fmap = fmapCommitM
instance Applicative CommitM where
pure = returnCommitM
(<*>) = appendCommitM
instance Monad CommitM where
return = returnCommitM
(>>=) = bindCommitM
fail = failCommitM
instance GitMonad CommitM where
getGit = getCommitM
liftGit = liftCommitM
fmapCommitM :: (a -> b) -> CommitM a -> CommitM b
fmapCommitM f m = CommitM $ \ctx -> do
r <- runCommitM m ctx
return $ case r of
ResultSuccess ctx' v -> ResultSuccess ctx' (f v)
ResultFailure err -> ResultFailure err
returnCommitM :: a -> CommitM a
returnCommitM v = CommitM $ \ctx -> return (ResultSuccess ctx v)
appendCommitM :: CommitM (a -> b) -> CommitM a -> CommitM b
appendCommitM m1f m2 = m1f >>= \f -> m2 >>= \v -> return (f v)
bindCommitM :: CommitM a -> (a -> CommitM b) -> CommitM b
bindCommitM m fm = CommitM $ \ctx -> do
r <- runCommitM m ctx
case r of
ResultSuccess ctx' v -> runCommitM (fm v) ctx'
ResultFailure err -> return (ResultFailure err)
failCommitM :: String -> CommitM a
failCommitM msg = CommitM $ \_ -> return (ResultFailure msg)
getCommitM :: CommitM Git.Git
getCommitM = CommitM $ \ctx -> ResultSuccess ctx <$> getGit
liftCommitM :: IO a -> CommitM a
liftCommitM f = CommitM $ \ctx -> ResultSuccess ctx <$> (liftGit f)
commitUpdateContext :: (CommitContext -> IO (CommitContext, a)) -> CommitM a
commitUpdateContext operation = CommitM $ \ctx -> do
(ctx', r) <- liftGit $ operation ctx
return (ResultSuccess ctx' r)
setAuthor :: Git.Person -> CommitM ()
setAuthor p = commitUpdateContext $ \ctx -> return (ctx { commitContextCommitter = p }, ())
setCommitter :: Git.Person -> CommitM ()
setCommitter p = commitUpdateContext $ \ctx -> return (ctx { commitContextCommitter = p }, ())
setParents :: [Git.Ref] -> CommitM ()
setParents l = commitUpdateContext $ \ctx -> return (ctx { commitContextParents = l }, ())
setExtras :: [Git.CommitExtra] -> CommitM ()
setExtras l = commitUpdateContext $ \ctx -> return (ctx { commitContextExtras = l }, ())
setEncoding :: Maybe ByteString -> CommitM ()
setEncoding e = commitUpdateContext $ \ctx -> return (ctx { commitContextEncoding = e }, ())
setMessage :: ByteString -> CommitM ()
setMessage msg = commitUpdateContext $ \ctx -> return (ctx { commitContextMessage = msg }, ())
setContextObject_ :: Git.Objectable object
=> Git.EntPath
-> (Git.EntType, object)
-> CommitM ()
setContextObject_ path (t, obj) = do
ref <- setObject obj
git <- getGit
commitUpdateContext $ \ctx -> do
Git.workTreeSet git (commitContextTree ctx) path (t, ref)
return (ctx, ())
setFile :: Git.EntPath
-> BL.ByteString
-> CommitM ()
setFile path bl = setContextObject_ path (Git.EntFile , Git.Blob bl)
deleteFile :: Git.EntPath -> CommitM ()
deleteFile path = do
git <- getGit
commitUpdateContext $ \ctx -> do
Git.workTreeDelete git (commitContextTree ctx) path
return (ctx, ())
withNewCommit :: (GitMonad git, Resolvable rev)
=> Git.Person
-> Maybe rev
-> CommitM a
-> git (Git.Ref, a)
withNewCommit p mPrec m = do
workTree <- case mPrec of
Nothing -> workTreeNew
Just r -> do
mc <- getCommit r
case mc of
Nothing -> fail "the given revision does not exist or is not a commit"
Just c -> workTreeFrom (Git.commitTreeish c)
parents <- case mPrec of
Nothing -> return []
Just r -> do
mr <- resolve r
return $ case mr of
Nothing -> []
Just ref -> [ref]
let ctx = CommitContext
{ commitContextAuthor = p
, commitContextCommitter = p
, commitContextParents = parents
, commitContextExtras = []
, commitContextEncoding = Nothing
, commitContextMessage = B.empty
, commitContextTree = workTree
}
r <- runCommitM m ctx
case r of
ResultFailure err -> fail err
ResultSuccess ctx' a -> do
treeRef <- workTreeFlush (commitContextTree ctx')
let commit = Git.Commit
{ Git.commitTreeish = treeRef
, Git.commitParents = commitContextParents ctx'
, Git.commitAuthor = commitContextAuthor ctx'
, Git.commitCommitter = commitContextCommitter ctx'
, Git.commitEncoding = commitContextEncoding ctx'
, Git.commitExtras = commitContextExtras ctx'
, Git.commitMessage = commitContextMessage ctx'
}
ref <- setObject commit
return (ref, a)
withBranch :: GitMonad git
=> Git.Person
-> Git.RefName
-> Bool
-> (CommitAccessM a)
-> (Maybe a -> CommitM b)
-> git (Git.Ref, b)
withBranch p branchName keepTree actionParent actionNew = do
mRefParent <- resolve branchName
(mRefTree, actionInCommit) <- case mRefParent of
Nothing -> return (Nothing, actionNew Nothing)
Just refParent -> do
a <- withCommit refParent actionParent
return $ if keepTree
then (Just refParent, actionNew $ Just a)
else (Nothing, setParents [refParent] >> actionNew (Just a))
(ref, b) <- withNewCommit p (mRefTree) actionInCommit
branchWrite branchName ref
return (ref, b)