{-# LANGUAGE FlexibleContexts #-}
module Git.CommandLine
( make
-- ** Internal functions, for tests
, takePythonUnquote
) where
import ClassyPrelude hiding (hash, stderr, stdin, stdout)
import qualified Conduit
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Char8 as BS8
import qualified Git.Class as Git
import qualified Log
import qualified System.Process as Process
import Conduit (ConduitT, MonadResource)
import Control.Monad.Trans.Writer.CPS (runWriterT, tell, writerT)
import Data.ByteString.Char8 (strip)
import Data.Text.Encoding (decodeUtf8')
import Git.Class (GitObject (..), HistoryItem (..))
import Numeric (showHex)
import System.Directory.OsPath (createDirectory, renameDirectory)
import System.Exit (ExitCode (..))
import System.OsPath (OsPath, OsString, decodeFS, osp)
import System.Process (CreateProcess, waitForProcess, withCreateProcess)
-- TODO: probably need a mutex on all write operations. Not a priority, because
-- races are avoided by the user just not doing concurrent operations
make :: OsPath -> Git.GitImpl
make gitPath =
Git.GitImpl
{ Git.createRepo = createRepo gitPath
, Git.renameRepo = renameRepo
, Git.getBranches = getBranches gitPath
, Git.getObject = getObject gitPath
, Git.getLastCommits = getLastCommits gitPath
, Git.advertiseRefsUpload = advertiseRefsUpload gitPath
, Git.advertiseRefsReceive = advertiseRefsReceive gitPath
, Git.uploadPack = uploadPack gitPath
, Git.receivePack = receivePack gitPath
}
createProcess
:: CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, Process.ProcessHandle)
createProcess p =
Log.debug ("Git: creating " <> tshow p) >> Process.createProcess p
-- Uses strings while OsPath api doesn't exist
gitProc :: FilePath -> FilePath -> [String] -> CreateProcess
gitProc git cwd args =
(Process.proc git args)
{ Process.cwd = Just cwd
, Process.std_in = Process.CreatePipe
, Process.std_out = Process.CreatePipe
, Process.std_err = Process.CreatePipe
, Process.env = Just []
}
gitOutput :: OsPath -> OsPath -> [OsString] -> IO ByteString
gitOutput git cwd args = do
git' <- decodeFS git
cwd' <- decodeFS cwd
args' <- traverse decodeFS args
let p = (gitProc git' cwd' args')
Log.debug ("Git: creating " <> tshow p) >> withCreateProcess p getOutput
where
getOutput _stdin (Just stdout) (Just stderr) process = do
outputPromise <- async $ hGetContents stdout
errorPromise <- async $ hGetContents stderr
exitCode <- waitForProcess process
case exitCode of
ExitSuccess -> waitAsync outputPromise
ExitFailure _ -> do
message <- waitAsync errorPromise
throwIO $ GitError{message, exitCode}
getOutput _ _ _ _ = error "XXX failed to get process handles"
gitStreamOutput
:: MonadResource m
=> CreateProcess
-> ConduitT () ByteString m ()
gitStreamOutput p = Conduit.bracketP
(createProcess p)
Process.cleanupProcess
$ \case
(_stdin, Just stdout, Just stderr, process) -> do
Conduit.sourceHandle stdout
exitCode <- liftIO $ waitForProcess process
case exitCode of
ExitSuccess -> pure ()
ExitFailure _ -> do
message <- hGetContents stderr
throwIO $ GitError{message, exitCode}
_ -> error "XXX failed to get process handles"
gitStreamInputOutput
:: MonadResource m
=> CreateProcess
-> ConduitT ByteString ByteString m ()
gitStreamInputOutput p = Conduit.bracketP
(createProcess p)
Process.cleanupProcess
$ \case
(Just stdin, Just stdout, Just stderr, process) -> do
Conduit.sinkHandle stdin
hFlush stdin
Conduit.sourceHandle stdout
exitCode <- liftIO $ waitForProcess process
case exitCode of
ExitSuccess -> pure ()
ExitFailure _ -> do
message <- hGetContents stderr
throwIO $ GitError{message, exitCode}
_ -> error "XXX failed to get process handles"
getBranches :: OsPath -> OsPath -> IO [Text]
getBranches git path =
throwLeft
. traverse decodeUtf8'
. mapMaybe (stripPrefix "refs/heads/")
. splitElem 10
=<< gitOutput git path [[osp|for-each-ref|], [osp|--format=%(refname)|], [osp|refs/heads/|]]
where
throwLeft (Left e) = throwIO e
throwLeft (Right x) = pure x
getObject :: OsPath -> OsPath -> OsPath -> IO GitObject
getObject git repoPath fullObjectPath = do
objectType <-
strip <$> gitOutput git repoPath [[osp|cat-file|], [osp|-t|], fullObjectPath]
case objectType of
"tree" ->
Tree
. splitElem 10
. strip
<$> gitOutput git repoPath [[osp|ls-tree|], fullObjectPath, [osp|--format=%(path)|]]
"blob" ->
Blob <$> do
size' <-
readMay
. decodeUtf8
. strip
<$> gitOutput
git
repoPath
[[osp|cat-file|], [osp|-s|], fullObjectPath]
size <- case size' of
Nothing -> error "XXX failed to get size"
Just x -> pure (x :: Int)
if size >= 1024 * 1024
then pure "File too large to display"
else gitOutput git repoPath [[osp|cat-file|], [osp|blob|], fullObjectPath]
"commit" -> pure $ Commit "TODO type commit unsupported"
"tag" -> pure $ Tag "TODO tag type unsupported"
_ -> error "XXX unexpected git object type"
-- created repositories need to be bare, we don't care about checkouts and they
-- interfere with upload-receive packs
-- git ls-tree --help
-- git ls-tree HEAD
-- git ls-tree HEAD:src
-- git cat-file --help
-- git cat-file -s HEAD:hie.yaml
-- git cat-file blob HEAD:src/Hagia.hs
-- git for-each-ref --format='%(refname)%(objectname)%(authorname)%(authordate:short)%(contents:subject)' --python 'refs/heads' # or refs/tags
-- | First step of pull
advertiseRefsUpload
:: MonadResource m
=> OsPath
-> OsPath
-> Maybe ByteString
-> ConduitT () ByteString m ()
advertiseRefsUpload git repoPath protocolVersion = do
git' <- liftIO $ decodeFS git
repoPath' <- liftIO $ decodeFS repoPath
gitStreamOutput
( gitProc git' repoPath' ["upload-pack", "--stateless-rpc", "--advertise-refs", "."]
)
{ Process.env = flip fmap protocolVersion $
\v -> [("GIT_PROTOCOL", unpack . decodeUtf8 $ v)]
}
-- | First step of push
advertiseRefsReceive
:: MonadResource m
=> OsPath
-> OsPath
-> Maybe ByteString
-> ConduitT () ByteString m ()
advertiseRefsReceive git repoPath protocolVersion = do
git' <- liftIO $ decodeFS git
repoPath' <- liftIO $ decodeFS repoPath
when (isNothing protocolVersion) (yieldGitPacket "# service=git-receive-pack\n")
>> gitStreamOutput
( gitProc
git'
repoPath'
["receive-pack", "--stateless-rpc", "--advertise-refs", "."]
)
{ Process.env = flip fmap protocolVersion $
\v -> [("GIT_PROTOCOL", unpack . decodeUtf8 $ v)]
}
-- | Second step of pull
uploadPack
:: MonadResource m
=> OsPath
-> OsPath
-> Maybe ByteString
-> ConduitT ByteString ByteString m ()
uploadPack git repoPath protocolVersion = do
git' <- liftIO $ decodeFS git
repoPath' <- liftIO $ decodeFS repoPath
gitStreamInputOutput
(gitProc git' repoPath' ["upload-pack", "--stateless-rpc", "."])
{ Process.env = flip fmap protocolVersion $
\v -> [("GIT_PROTOCOL", unpack . decodeUtf8 $ v)]
}
-- | Second step of push
receivePack
:: MonadResource m
=> OsPath
-> OsPath
-> Maybe ByteString
-> ConduitT ByteString ByteString m ()
receivePack git repoPath protocolVersion = do
git' <- liftIO $ decodeFS git
repoPath' <- liftIO $ decodeFS repoPath
gitStreamInputOutput
(gitProc git' repoPath' ["receive-pack", "--stateless-rpc", "."])
{ Process.env = flip fmap protocolVersion $
\v -> [("GIT_PROTOCOL", unpack . decodeUtf8 $ v)]
}
-- | Git data stream as outputted by @git@ command consists of packets like this
yieldGitPacket :: Monad m => ByteString -> ConduitT i ByteString m ()
yieldGitPacket p = Conduit.yield len >> Conduit.yield p >> Conduit.yield "0000"
where
len = leftPad 4 zero . BS8.pack . flip showHex "" $ length p + 4
zero = fromIntegral . fromEnum $ '0'
leftPad n c s =
let prefix = replicate (n - length s) c
in prefix <> s
createRepo :: OsPath -> OsPath -> IO ()
createRepo git path = do
createDirectory path
_ <- gitOutput git path [[osp|init|], [osp|--bare|]]
pure ()
renameRepo :: OsPath -> OsPath -> IO ()
renameRepo oldName newName =
-- this will throw if directory already exists
createDirectory newName
-- this will silently replace existing directoty
>> renameDirectory oldName newName
-- | Get latest commits across all branches and tags
getLastCommits :: OsPath -> OsPath -> IO [HistoryItem]
getLastCommits git path = do
let run pattern =
gitOutput
git
path
[ [osp|for-each-ref|]
, [osp|--format|]
, [osp|%(refname)%(objectname)%(authorname)%(taggername)|]
<> [osp|%(authordate:short)%(taggerdate:short)%(contents:subject)|]
, [osp|--python|]
, pattern
]
branchesOutput <- run [osp|refs/heads|]
tagsOutput <- run [osp|refs/tags|]
let parse isTag line = do
(rawRef, rest1) <- takePythonUnquote line
(hash, rest2) <- takePythonUnquote rest1
(author, rest3) <- takePythonUnquote rest2
(tagger, rest4) <- takePythonUnquote rest3
(rawAuthorDate, rest5) <- takePythonUnquote rest4
(rawTaggerDate, rest6) <- takePythonUnquote rest5
(message, rest7) <- takePythonUnquote rest6
guard $ null rest7
commitAuthor <- right . decodeUtf8' $ if null author then tagger else author
let parentRef =
decodeUtf8
. dropPrefix "refs/tags/"
. dropPrefix "refs/heads/"
$ rawRef
let parseDate = parseTimeM False defaultTimeLocale "%Y-%-m-%-d" . unpack <=< right . decodeUtf8'
createDate <- parseDate rawAuthorDate <|> parseDate rawTaggerDate
pure
HistoryItem
{ commitHash = decodeUtf8 hash
, commitAuthor
, parentRef
, createDate
, shortCommitMessage = decodeUtf8 message
, isTag
}
let branches = catMaybes . map (parse False) . splitElem 10 $ branchesOutput
let tags = catMaybes . map (parse True) . splitElem 10 $ tagsOutput
pure $ branches <> tags
where
right (Left _) = Nothing
right (Right x) = Just x
-- | Unquote first string from git's python-quoted string. Returns the unquoted
-- chunk and rest of input.
--
-- Quoting reference: https://github.com/git/git/blob/bcb6cae2966cc407ca1afc77413b3ef11103c175/quote.c#L493
takePythonUnquote :: ByteString -> Maybe (ByteString, ByteString)
takePythonUnquote = unwraps . unquote
where
unwraps = map (first (toStrict . builderToLazy) . swap) . runWriterT
unquote bs = case uncons bs of
-- starts with quote
Just (39, rest) -> go rest
_other -> parseError
go bs = do
let (chunk, rest) = span (\c -> c /= 92 && c /= 39) bs
tell $ toBuilder chunk
case uncons rest of
-- quote, ends string
Just (39, rest') -> pure rest'
-- backslash, starts control symbol
Just (92, withControl) -> case uncons withControl of
-- escaped backslash
Just (92, rest') -> tell (Builder.word8 92) >> go rest'
-- escaped quote
Just (39, rest') -> tell (Builder.word8 39) >> go rest'
-- escaped newline
Just (110, rest') -> tell (Builder.word8 10) >> go rest'
-- Quoter inserts no other control symbols
_other -> parseError
Nothing -> parseError
_impossible -> parseError
parseError = writerT Nothing
data GitError = GitError
{ message :: ByteString
, exitCode :: ExitCode
}
deriving (Show, Typeable)
instance Exception GitError