module Saturnin.Git
( readFile
, runCmd
, GitSource (..)
, GitURI (..)
, GitRevOrRef (..)
)
where
import qualified Data.ByteString as B
import Data.Text.Lazy (Text, unpack, pack)
import Formatting
import Prelude hiding (readFile)
import System.Exit
import System.FilePath.Posix
import System.IO hiding (readFile)
import System.Process
newtype GitURI = GitURI { uri :: Text }
deriving (Show, Read)
newtype GitRevOrRef = GitRevOrRef { revOrRef :: Text }
deriving (Show, Read)
data GitSource = GitSource
{ gsUri :: GitURI
, gsRevOrRef :: GitRevOrRef
}
deriving (Show, Read)
readFile
:: GitSource
-> FilePath
-> FilePath
-> IO B.ByteString
readFile (GitSource u r) p wd = do
_ <- clone u wd (Just "repo")
_ <- checkout (wd </> "repo") r
B.readFile (wd </> "repo" </> p)
clone
:: GitURI
-> FilePath
-> Maybe FilePath
-> IO (String, String)
clone (GitURI u) wd (Just n) = runGit wd ["clone", u, pack n]
clone (GitURI u) wd (Nothing) = runGit wd ["clone", u]
checkout :: FilePath -> GitRevOrRef -> IO (String, String)
checkout wd (GitRevOrRef r) = runGit wd ["checkout", r]
runGit
:: FilePath
-> [Text]
-> IO (String, String)
runGit wd argv = runCmd (Just wd) "git" $ fmap unpack argv
runCmd
:: Maybe FilePath
-> FilePath
-> [String]
-> IO (String, String)
runCmd cwd' exe argv = do
let cp = (proc exe argv)
{ cwd = cwd'
, std_out = CreatePipe
, std_err = CreatePipe
}
(_, Just hout, Just herr, ph) <- createProcess cp
ec <- waitForProcess ph
out <- hGetContents hout
err <- hGetContents herr
ret ec out err
where
ret (f @ (ExitFailure _)) out err = error . unpack $ format
( shown
% ": " % shown
% " " % shown
% " out: " % shown
% " err: " % shown
% "\n"
)
f exe argv out err
ret ExitSuccess out err = return (out, err)