62 lines
2.7 KiB
Haskell
62 lines
2.7 KiB
Haskell
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
|
|
module TiedoteMD.Git where
|
|
|
|
-- Most of this is stolen from filestore to implement gitPull, TODO: Upstream
|
|
|
|
import Codec.Binary.UTF8.String (encodeString)
|
|
import Control.Exception (throwIO)
|
|
import Control.Monad (liftM2, unless)
|
|
import Data.ByteString.Lazy.UTF8 (toString)
|
|
import Data.FileStore.Types (FileStoreError(..))
|
|
import Data.List (singleton)
|
|
import System.Directory (getTemporaryDirectory, removeFile)
|
|
import System.Environment (getEnvironment)
|
|
import System.Exit (ExitCode(..))
|
|
import System.IO (openTempFile)
|
|
import System.Process (runProcess, waitForProcess)
|
|
|
|
import qualified Control.Exception as E
|
|
import qualified Data.ByteString as S
|
|
import qualified Data.ByteString.Lazy as B
|
|
|
|
import TiedoteMD.Types (GitOrigin(..))
|
|
|
|
gitPull :: FilePath -> GitOrigin -> IO ()
|
|
gitPull repo GitOrigin {url, branch} = do
|
|
(exit, err, _) <- runGitCommand repo "fetch" (url : (maybe [] singleton branch))
|
|
unless (exit == ExitSuccess) $ throwIO $ UnknownError $ "git-fetch failed: " <> err
|
|
(exit', err', _) <- runGitCommand repo "reset" ["--hard","FETCH_HEAD"]
|
|
unless (exit' == ExitSuccess) $ throwIO $ UnknownError $ "git-reset failed: " <> err'
|
|
|
|
runGitCommand :: FilePath -> String -> [String] -> IO (ExitCode, String, B.ByteString)
|
|
runGitCommand = runGitCommandWithEnv []
|
|
|
|
runGitCommandWithEnv :: [(String, String)] -> FilePath -> String -> [String] -> IO (ExitCode, String, B.ByteString)
|
|
runGitCommandWithEnv givenEnv repo command args = do
|
|
let env = Just ([("GIT_DIFF_OPTS", "-u100000")] ++ givenEnv)
|
|
(status, err, out) <- runShellCommand repo env "git" (command : args)
|
|
return (status, toString err, out)
|
|
|
|
runShellCommand :: FilePath -- ^ Working directory
|
|
-> Maybe [(String, String)] -- ^ Environment
|
|
-> String -- ^ Command
|
|
-> [String] -- ^ Arguments
|
|
-> IO (ExitCode, B.ByteString, B.ByteString)
|
|
runShellCommand workingDir environment command optionList = do
|
|
tempPath <- E.catch getTemporaryDirectory (\(_ :: E.SomeException) -> return ".")
|
|
(outputPath, hOut) <- openTempFile tempPath "out"
|
|
(errorPath, hErr) <- openTempFile tempPath "err"
|
|
env <- liftM2 (++) environment . Just <$> getEnvironment
|
|
hProcess <- runProcess (encodeArg command) (map encodeArg optionList) (Just workingDir) env Nothing (Just hOut) (Just hErr)
|
|
status <- waitForProcess hProcess
|
|
errorOutput <- S.readFile errorPath
|
|
output <- S.readFile outputPath
|
|
removeFile errorPath
|
|
removeFile outputPath
|
|
return (status, B.fromChunks [errorOutput], B.fromChunks [output])
|
|
|
|
encodeArg :: String -> String
|
|
encodeArg = encodeString
|