module Control.Biegunka.Source.Git
(
git', git, git_
, Git(..), defaultGit
, actions, remotes, branch
, Branch, Remote, URI
) where
import Control.Exception (bracket)
import Control.Lens
import Control.Monad (forM_)
import Data.Default.Class (Default(..))
import Data.Foldable (for_)
import Data.Monoid (mempty)
import qualified Data.Text as T
import System.Directory (getCurrentDirectory, setCurrentDirectory, doesDirectoryExist)
import System.FilePath ((</>))
import System.Process (readProcessWithExitCode)
import Control.Biegunka.Execute.Exception (onFailure, sourceFailure)
import Control.Biegunka.Language (Scope(..))
import Control.Biegunka.Script
import Control.Biegunka.Source (Sourceable(..))
data Git = Git
{ gitactions :: Script Actions ()
, _remotes :: [Remote]
, _branch :: Branch
}
instance Default Git where
def = defaultGit
instance Sourceable Git where
actions f x = f (gitactions x) <&> \as -> x { gitactions = as }
(==>) = git'
defaultGit :: Git
defaultGit = Git
{ gitactions = return ()
, _remotes = ["origin"]
, _branch = "master"
}
remotes :: Lens' Git [Remote]
remotes f x = f (_remotes x) <&> \rs -> x { _remotes = rs }
branch :: Lens' Git Branch
branch f x = f (_branch x) <&> \b -> x { _branch = b }
type Branch = String
type Remote = String
git' :: URI -> FilePath -> Git -> Script Sources ()
git' url path (Git { gitactions, _remotes, _branch }) =
sourced "git" url path gitactions (updateGit url _remotes _branch)
git :: URI -> FilePath -> Script Actions () -> Script Sources ()
git u p s = git' u p def { gitactions = s }
git_ :: URI -> FilePath -> Script Sources ()
git_ u p = git u p (return ())
updateGit :: URI -> [Remote] -> Branch -> FilePath -> IO ()
updateGit u rs br p = do
exists <- doesDirectoryExist p
if exists
then do
readGitProcess ["remote", "update"] (Just p)
forM_ rs $ \r ->
readGitProcess ["merge", r </> br, br] (Just p)
else
readGitProcess ["clone", u, p] Nothing
readGitProcess ["checkout", br] (Just p)
where
readGitProcess args workingDirectory = bracket
getCurrentDirectory
setCurrentDirectory $ \_ -> do
for_ workingDirectory setCurrentDirectory
(exitcode, _, errors) <- readProcessWithExitCode "git" args mempty
exitcode `onFailure`
\_ -> sourceFailure u p (T.pack errors)