-- | -- Module : Data.Git.Monad -- License : BSD-style -- Maintainer : Nicolas DI PRIMA -- Stability : experimental -- Portability : unix -- -- Simplifies the Git operation presents in this package. -- -- You can easily access to the usual Git general informations: -- -- * access to Head, Branches or Tags -- * direct access to a Commit -- -- This module also defines a convenient Monad to access the whole information -- from a Commit: see 'CommitAccessMonad' and 'withCommit'. -- -- You can also easily create a new commit: see 'CommitM' and 'withNewCommit' -- {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeSynonymInstances #-} module Data.Git.Monad ( -- * GitMonad GitMonad(..) , GitM , withRepo , withCurrentRepo -- ** Operations , Resolvable(..) , branchList , branchWrite , tagList , tagWrite , headGet , headResolv , headSet , getCommit -- * Read a commit , CommitAccessM , withCommit -- ** Operations , getAuthor , getCommitter , getParents , getExtras , getEncoding , getMessage , getFile , getDir -- * Create a new Commit , CommitM , withNewCommit , withBranch -- ** Operations , setAuthor , setCommitter , setParents , setExtras , setEncoding , setMessage , setFile , deleteFile -- * convenients re-exports , 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 qualified Filesystem.Path as FP import Data.Set (Set) ------------------------------------------------------------------------------- -- Revision helper -- ------------------------------------------------------------------------------- revisionFromString :: String -> Git.Revision revisionFromString = Git.fromString -- | this is a convenient class to allow a common interface for what user may -- need to optain a Ref from a given Resolvable object. -- -- each of this instances is a convenient implementation of what a user would -- have to do in order to resolve a branch, a tag or a String. -- -- > resolve (Ref "2ad98b90...2ca") === Ref "2ad98b90...2ca" -- > resolve "master" -- > resolve "HEAD^^^" -- 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 ------------------------------------------------------------------------------- -- GitMonad -- ------------------------------------------------------------------------------- -- | Basic operations common between the different Monads defined in this -- package. class (Functor m, Applicative m, Monad m) => GitMonad m where -- | the current Monad must allow access to the current Git 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 -- ^ the commit Ref, Revision ("master", "HEAD^^" or a 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 ------------------------------------------------------------------------------- -- GitM -- ------------------------------------------------------------------------------- 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) ------------------------------------------------------------------------------- -- CommitAccessM -- ------------------------------------------------------------------------------- data CommitAccessContext = CommitAccessContext { commitAccessContextCommit :: !Git.Commit , commitAccessContextRef :: !Git.Ref } -- | ReadOnly operations on a given commit 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) -- Operations ----------------------------------------------------------------- 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 -- | get the content of the file at the given Path -- -- if the given Path is not a file or does not exist, -- the function returns Nothing. 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 -- | list the element present in the Given Directory Path -- -- if the given Path is not a directory or does not exist, -- the function returns Nothing. 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 -- | open a commit in the current GitMonad -- -- Read commit's info (Author, Committer, message...) or Commit's Tree. -- -- > withCurrentRepo $ -- > withCommit "master" $ do -- > -- print the commit's author information -- > author <- getAuthor -- > liftGit $ print author -- > -- > -- print the list of files|dirs in the root directory -- > l <- getDir [] -- > liftGit $ print l -- withCommit :: (Resolvable ref, GitMonad git) => ref -- ^ the commit revision or reference to open -> 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 ------------------------------------------------------------------------------- -- CommitM -- ------------------------------------------------------------------------------- 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) -- Operations ----------------------------------------------------------------- commitUpdateContext :: (CommitContext -> IO (CommitContext, a)) -> CommitM a commitUpdateContext operation = CommitM $ \ctx -> do (ctx', r) <- liftGit $ operation ctx return (ResultSuccess ctx' r) -- | replace the Commit's Author setAuthor :: Git.Person -> CommitM () setAuthor p = commitUpdateContext $ \ctx -> return (ctx { commitContextCommitter = p }, ()) -- | replace the Commit's Committer setCommitter :: Git.Person -> CommitM () setCommitter p = commitUpdateContext $ \ctx -> return (ctx { commitContextCommitter = p }, ()) -- | replace the Commit's Parents setParents :: [Git.Ref] -> CommitM () setParents l = commitUpdateContext $ \ctx -> return (ctx { commitContextParents = l }, ()) -- | replace the Commit's Extras setExtras :: [Git.CommitExtra] -> CommitM () setExtras l = commitUpdateContext $ \ctx -> return (ctx { commitContextExtras = l }, ()) -- | replace the Commit's encoding setEncoding :: Maybe ByteString -> CommitM () setEncoding e = commitUpdateContext $ \ctx -> return (ctx { commitContextEncoding = e }, ()) -- | replace the Commit's message with the new given message. 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, ()) -- | add a new file in in the Commit's Working Tree setFile :: Git.EntPath -> BL.ByteString -> CommitM () setFile path bl = setContextObject_ path (Git.EntFile , Git.Blob bl) -- | delete a file from the Commit's Working Tree. deleteFile :: Git.EntPath -> CommitM () deleteFile path = do git <- getGit commitUpdateContext $ \ctx -> do Git.workTreeDelete git (commitContextTree ctx) path return (ctx, ()) -- | create a new commit in the current GitMonad -- -- The commit is pre-filled with the following default values: -- -- * author and committer are the same -- * the commit's parents is an empty list -- * there is no commit encoding -- * the commit's extras is an empty list -- * the commit message is an empty ByteString -- * the working tree is a new empty Tree or the Tree associated to the -- given Revision or Ref. -- -- You can update these values with the commit setters (setFile, setAuthor...) -- -- Example: -- -- > withCurrentRepo $ -- > (r, ()) <- withNewCommit person Nothing $ do -- > setMessage "inital commit" -- > setFile ["README.md"] "# My awesome project\n\nthis is a new project\n" -- > branchWrite "master" r -- > -- -- you can also continue the work on a same branch. In this case the commit's -- parent is already set to the Reference associated to the revision. -- You can, change the parents if you wish to erase, or replace, this value. -- -- > withCurrentRepo $ -- > readmeContent <- withCommit (Just "master") $ getFile ["README.md"] -- > (r, ()) <- withNewCommit person (Just "master") $ do -- > setMessage "update the README" -- > setFile ["README.md"] $ readmeContent <> "just add some more description\n" -- > branchWrite "master" r -- withNewCommit :: (GitMonad git, Resolvable rev) => Git.Person -- ^ by default a commit must have an Author and a Committer. -- -- The given value will be given to both Author and Committer. -> Maybe rev -- ^ it is possible to prepopulate the Working Tree with a -- given Ref's Tree. -> CommitM a -- ^ the action to perform in the new commit (set files, -- Person, encoding or extras) -> 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) -- | create or continue to work on a branch -- -- This is a convenient function to create or to linearily work on a branch. -- This function applies a first Collect of information on the parent commit -- (the actual branch's commit). Then it creates a new commit and update -- the branch to point to this commit. -- -- for example: -- -- @ -- withCurrentRepo $ -- withBranch person "master" True -- (getAuthor) -- (maybe (setMessage "initial commit on this branch") -- (\author -> setMessage $ "continue the great work of " ++ show (personName author)) -- ) -- @ -- withBranch :: GitMonad git => Git.Person -- ^ the default Author and Committer (see 'withNewCommit') -> Git.RefName -- ^ the branch to work on -> Bool -- ^ propopulate the parent's tree (if it exists) in the -- new created commit. -- -- In any cases, if the branch already exists, the new commit -- parent will be filled with the result of ('resolv' "branchName") -> (CommitAccessM a) -- ^ the action to performs in the parent's new commit if it exists. -> (Maybe a -> CommitM b) -- ^ the action to performs in the new commit -- -- the argument is the result of the action on the parent commit. -- -- Nothing if the parent does not exist. -> git (Git.Ref, b) withBranch p branchName keepTree actionParent actionNew = do -- attempt to resolve the branch mRefParent <- resolve branchName -- configure the precedency of the tree and the action in the new commit (mRefTree, actionInCommit) <- case mRefParent of -- in the case the branch does not exist already: there is not precedency Nothing -> return (Nothing, actionNew Nothing) -- if the branch exists Just refParent -> do -- performs the action in the parent commit a <- withCommit refParent actionParent return $ if keepTree -- if user has choosen to prepopulate the Tree with the -- parent's tree we prepopulate the tree. then (Just refParent, actionNew $ Just a) -- else, we make sure the parent is at least setted else (Nothing, setParents [refParent] >> actionNew (Just a)) -- create the new commit (ref, b) <- withNewCommit p (mRefTree) actionInCommit -- write the branch branchWrite branchName ref return (ref, b)