{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DoAndIfThenElse #-}
module Data.FileStore.Git
( gitFileStore
)
where
import Data.FileStore.Types
import Data.Maybe (fromMaybe, mapMaybe)
import Data.List.Split (endByOneOf)
import System.Exit
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.FileStore.Utils (withSanityCheck, hashsMatch, runShellCommand, escapeRegexSpecialChars, withVerifyDir, encodeArg)
import Data.ByteString.Lazy.UTF8 (toString)
import qualified Data.ByteString.Lazy.Char8 as B
import Control.Monad (when)
import System.FilePath ((</>), splitFileName)
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, executable, getPermissions, setPermissions)
import Control.Exception (throwIO)
import qualified Control.Exception as E
gitFileStore :: FilePath -> FileStore
gitFileStore :: [Char] -> FileStore
gitFileStore [Char]
repo = FileStore {
initialize :: IO ()
initialize = [Char] -> IO ()
gitInit [Char]
repo
, save :: forall a. Contents a => [Char] -> Author -> [Char] -> a -> IO ()
save = forall a.
Contents a =>
[Char] -> [Char] -> Author -> [Char] -> a -> IO ()
gitSave [Char]
repo
, retrieve :: forall a. Contents a => [Char] -> Maybe [Char] -> IO a
retrieve = forall a. Contents a => [Char] -> [Char] -> Maybe [Char] -> IO a
gitRetrieve [Char]
repo
, delete :: [Char] -> Author -> [Char] -> IO ()
delete = [Char] -> [Char] -> Author -> [Char] -> IO ()
gitDelete [Char]
repo
, rename :: [Char] -> [Char] -> Author -> [Char] -> IO ()
rename = [Char] -> [Char] -> [Char] -> Author -> [Char] -> IO ()
gitMove [Char]
repo
, history :: [[Char]] -> TimeRange -> Maybe Int -> IO [Revision]
history = [Char] -> [[Char]] -> TimeRange -> Maybe Int -> IO [Revision]
gitLog [Char]
repo
, latest :: [Char] -> IO [Char]
latest = [Char] -> [Char] -> IO [Char]
gitLatestRevId [Char]
repo
, revision :: [Char] -> IO Revision
revision = [Char] -> [Char] -> IO Revision
gitGetRevision [Char]
repo
, index :: IO [[Char]]
index = [Char] -> IO [[Char]]
gitIndex [Char]
repo
, directory :: [Char] -> IO [Resource]
directory = [Char] -> [Char] -> IO [Resource]
gitDirectory [Char]
repo
, search :: SearchQuery -> IO [SearchMatch]
search = [Char] -> SearchQuery -> IO [SearchMatch]
gitSearch [Char]
repo
, idsMatch :: [Char] -> [Char] -> Bool
idsMatch = forall a b. a -> b -> a
const forall a. Eq a => [a] -> [a] -> Bool
hashsMatch [Char]
repo
}
runGitCommand :: FilePath -> String -> [String] -> IO (ExitCode, String, B.ByteString)
runGitCommand :: [Char] -> [Char] -> [[Char]] -> IO (ExitCode, [Char], ByteString)
runGitCommand = [([Char], [Char])]
-> [Char]
-> [Char]
-> [[Char]]
-> IO (ExitCode, [Char], ByteString)
runGitCommandWithEnv []
runGitCommandWithEnv :: [(String, String)] -> FilePath -> String -> [String] -> IO (ExitCode, String, B.ByteString)
runGitCommandWithEnv :: [([Char], [Char])]
-> [Char]
-> [Char]
-> [[Char]]
-> IO (ExitCode, [Char], ByteString)
runGitCommandWithEnv [([Char], [Char])]
givenEnv [Char]
repo [Char]
command [[Char]]
args = do
let env :: Maybe [([Char], [Char])]
env = forall a. a -> Maybe a
Just ([([Char]
"GIT_DIFF_OPTS", [Char]
"-u100000")] forall a. [a] -> [a] -> [a]
++ [([Char], [Char])]
givenEnv)
(ExitCode
status, ByteString
err, ByteString
out) <- [Char]
-> Maybe [([Char], [Char])]
-> [Char]
-> [[Char]]
-> IO (ExitCode, ByteString, ByteString)
runShellCommand [Char]
repo Maybe [([Char], [Char])]
env [Char]
"git" ([Char]
command forall a. a -> [a] -> [a]
: [[Char]]
args)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
status, ByteString -> [Char]
toString ByteString
err, ByteString
out)
gitInit :: FilePath -> IO ()
gitInit :: [Char] -> IO ()
gitInit [Char]
repo = do
Bool
exists <- [Char] -> IO Bool
doesDirectoryExist [Char]
repo
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> IO a -> IO a
withVerifyDir [Char]
repo forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO FileStoreError
RepositoryExists
Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
repo
(ExitCode
status, [Char]
err, ByteString
_) <- [Char] -> [Char] -> [[Char]] -> IO (ExitCode, [Char], ByteString)
runGitCommand [Char]
repo [Char]
"init" []
if ExitCode
status forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then do
let postupdatedir :: [Char]
postupdatedir = [Char]
repo [Char] -> [Char] -> [Char]
</> [Char]
".git" [Char] -> [Char] -> [Char]
</> [Char]
"hooks"
Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
postupdatedir
let postupdate :: [Char]
postupdate = [Char]
postupdatedir [Char] -> [Char] -> [Char]
</> [Char]
"post-update"
[Char] -> ByteString -> IO ()
B.writeFile [Char]
postupdate ByteString
postUpdate
Permissions
perms <- [Char] -> IO Permissions
getPermissions [Char]
postupdate
[Char] -> Permissions -> IO ()
setPermissions [Char]
postupdate (Permissions
perms {executable :: Bool
executable = Bool
True})
(ExitCode
status', [Char]
err', ByteString
_) <- [Char] -> [Char] -> [[Char]] -> IO (ExitCode, [Char], ByteString)
runGitCommand [Char]
repo [Char]
"config" [[Char]
"receive.denyCurrentBranch",[Char]
"ignore"]
if ExitCode
status' forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> FileStoreError
UnknownError forall a b. (a -> b) -> a -> b
$ [Char]
"git config failed:\n" forall a. [a] -> [a] -> [a]
++ [Char]
err'
else forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> FileStoreError
UnknownError forall a b. (a -> b) -> a -> b
$ [Char]
"git-init failed:\n" forall a. [a] -> [a] -> [a]
++ [Char]
err
gitCommit :: FilePath -> [FilePath] -> Author -> String -> IO ()
gitCommit :: [Char] -> [[Char]] -> Author -> [Char] -> IO ()
gitCommit [Char]
repo [[Char]]
names Author
author [Char]
logMsg = do
let env :: [([Char], [Char])]
env = [([Char]
"GIT_COMMITTER_NAME", Author -> [Char]
authorName Author
author),
([Char]
"GIT_COMMITTER_EMAIL", Author -> [Char]
authorEmail Author
author)]
(ExitCode
statusCommit, [Char]
errCommit, ByteString
_) <- [([Char], [Char])]
-> [Char]
-> [Char]
-> [[Char]]
-> IO (ExitCode, [Char], ByteString)
runGitCommandWithEnv [([Char], [Char])]
env [Char]
repo [Char]
"commit" forall a b. (a -> b) -> a -> b
$ [[Char]
"--author", Author -> [Char]
authorName Author
author forall a. [a] -> [a] -> [a]
++ [Char]
" <" forall a. [a] -> [a] -> [a]
++
Author -> [Char]
authorEmail Author
author forall a. [a] -> [a] -> [a]
++ [Char]
">", [Char]
"-m", [Char]
logMsg] forall a. [a] -> [a] -> [a]
++ [[Char]]
names
if ExitCode
statusCommit forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
errCommit
then FileStoreError
Unchanged
else [Char] -> FileStoreError
UnknownError forall a b. (a -> b) -> a -> b
$ [Char]
"Could not git commit " forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [[Char]]
names forall a. [a] -> [a] -> [a]
++ [Char]
"\n" forall a. [a] -> [a] -> [a]
++ [Char]
errCommit
gitSave :: Contents a => FilePath -> FilePath -> Author -> Description -> a -> IO ()
gitSave :: forall a.
Contents a =>
[Char] -> [Char] -> Author -> [Char] -> a -> IO ()
gitSave [Char]
repo [Char]
name Author
author [Char]
logMsg a
contents = do
forall b. [Char] -> [[Char]] -> [Char] -> IO b -> IO b
withSanityCheck [Char]
repo [[Char]
".git"] [Char]
name forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> IO ()
B.writeFile ([Char]
repo [Char] -> [Char] -> [Char]
</> [Char] -> [Char]
encodeArg [Char]
name) forall a b. (a -> b) -> a -> b
$ forall a. Contents a => a -> ByteString
toByteString a
contents
(ExitCode
statusAdd, [Char]
errAdd, ByteString
_) <- [Char] -> [Char] -> [[Char]] -> IO (ExitCode, [Char], ByteString)
runGitCommand [Char]
repo [Char]
"add" [[Char]
name]
if ExitCode
statusAdd forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then [Char] -> [[Char]] -> Author -> [Char] -> IO ()
gitCommit [Char]
repo [[Char]
name] Author
author [Char]
logMsg
else forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> FileStoreError
UnknownError forall a b. (a -> b) -> a -> b
$ [Char]
"Could not git add '" forall a. [a] -> [a] -> [a]
++ [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
"'\n" forall a. [a] -> [a] -> [a]
++ [Char]
errAdd
isSymlink :: FilePath -> FilePath -> Maybe RevisionId -> IO Bool
isSymlink :: [Char] -> [Char] -> Maybe [Char] -> IO Bool
isSymlink [Char]
repo [Char]
name Maybe [Char]
revid = do
(ExitCode
_, [Char]
_, ByteString
out) <- [Char] -> [Char] -> [[Char]] -> IO (ExitCode, [Char], ByteString)
runGitCommand [Char]
repo [Char]
"ls-tree" [forall a. a -> Maybe a -> a
fromMaybe [Char]
"HEAD" Maybe [Char]
revid, [Char]
name]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. Int -> [a] -> [a]
take Int
6 forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
B.unpack ByteString
out) forall a. Eq a => a -> a -> Bool
== [Char]
"120000"
targetContents :: Contents a => FilePath -> FilePath -> a -> IO (Maybe a)
targetContents :: forall a. Contents a => [Char] -> [Char] -> a -> IO (Maybe a)
targetContents [Char]
repo [Char]
linkName a
linkContent = do
let ([Char]
dirName, [Char]
_) = [Char] -> ([Char], [Char])
splitFileName [Char]
linkName
targetName :: [Char]
targetName = [Char]
repo [Char] -> [Char] -> [Char]
</> [Char]
dirName [Char] -> [Char] -> [Char]
</> (ByteString -> [Char]
B.unpack forall a b. (a -> b) -> a -> b
$ forall a. Contents a => a -> ByteString
toByteString a
linkContent)
Either SomeException ByteString
result <- forall e a. Exception e => IO a -> IO (Either e a)
E.try forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
B.readFile [Char]
targetName
case Either SomeException ByteString
result of
Left (SomeException
_ :: E.SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Right ByteString
contents -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall a. Contents a => ByteString -> a
fromByteString ByteString
contents)
gitRetrieve :: Contents a
=> FilePath
-> FilePath
-> Maybe RevisionId
-> IO a
gitRetrieve :: forall a. Contents a => [Char] -> [Char] -> Maybe [Char] -> IO a
gitRetrieve [Char]
repo [Char]
name Maybe [Char]
revid = do
let objectName :: [Char]
objectName = case Maybe [Char]
revid of
Maybe [Char]
Nothing -> [Char]
"HEAD:" forall a. [a] -> [a] -> [a]
++ [Char]
name
Just [Char]
rev -> [Char]
rev forall a. [a] -> [a] -> [a]
++ [Char]
":" forall a. [a] -> [a] -> [a]
++ [Char]
name
(ExitCode
_, [Char]
_, ByteString
output) <- [Char] -> [Char] -> [[Char]] -> IO (ExitCode, [Char], ByteString)
runGitCommand [Char]
repo [Char]
"cat-file" [[Char]
"-t", [Char]
objectName]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Int -> [a] -> [a]
take Int
4 (ByteString -> [Char]
toString ByteString
output) forall a. Eq a => a -> a -> Bool
/= [Char]
"blob") forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO FileStoreError
NotFound
(ExitCode
status', [Char]
err', ByteString
output') <- [Char] -> [Char] -> [[Char]] -> IO (ExitCode, [Char], ByteString)
runGitCommand [Char]
repo [Char]
"cat-file" [[Char]
"-p", [Char]
objectName]
if ExitCode
status' forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then do
Bool
isLink <- [Char] -> [Char] -> Maybe [Char] -> IO Bool
isSymlink [Char]
repo [Char]
name Maybe [Char]
revid
if Bool
isLink
then do
Maybe ByteString
contents <- forall a. Contents a => [Char] -> [Char] -> a -> IO (Maybe a)
targetContents [Char]
repo [Char]
name ByteString
output'
case Maybe ByteString
contents of
Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Contents a => ByteString -> a
fromByteString ByteString
output'
Just ByteString
bs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Contents a => ByteString -> a
fromByteString ByteString
bs
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Contents a => ByteString -> a
fromByteString ByteString
output'
else forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> FileStoreError
UnknownError forall a b. (a -> b) -> a -> b
$ [Char]
"Error in git cat-file:\n" forall a. [a] -> [a] -> [a]
++ [Char]
err'
gitDelete :: FilePath -> FilePath -> Author -> Description -> IO ()
gitDelete :: [Char] -> [Char] -> Author -> [Char] -> IO ()
gitDelete [Char]
repo [Char]
name Author
author [Char]
logMsg = forall b. [Char] -> [[Char]] -> [Char] -> IO b -> IO b
withSanityCheck [Char]
repo [[Char]
".git"] [Char]
name forall a b. (a -> b) -> a -> b
$ do
(ExitCode
statusAdd, [Char]
errRm, ByteString
_) <- [Char] -> [Char] -> [[Char]] -> IO (ExitCode, [Char], ByteString)
runGitCommand [Char]
repo [Char]
"rm" [[Char]
name]
if ExitCode
statusAdd forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then [Char] -> [[Char]] -> Author -> [Char] -> IO ()
gitCommit [Char]
repo [[Char]
name] Author
author [Char]
logMsg
else forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> FileStoreError
UnknownError forall a b. (a -> b) -> a -> b
$ [Char]
"Could not git rm '" forall a. [a] -> [a] -> [a]
++ [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
"'\n" forall a. [a] -> [a] -> [a]
++ [Char]
errRm
gitMove :: FilePath -> FilePath -> FilePath -> Author -> Description -> IO ()
gitMove :: [Char] -> [Char] -> [Char] -> Author -> [Char] -> IO ()
gitMove [Char]
repo [Char]
oldName [Char]
newName Author
author [Char]
logMsg = do
[Char]
_ <- [Char] -> [Char] -> IO [Char]
gitLatestRevId [Char]
repo [Char]
oldName
(ExitCode
statusAdd, [Char]
err, ByteString
_) <- forall b. [Char] -> [[Char]] -> [Char] -> IO b -> IO b
withSanityCheck [Char]
repo [[Char]
".git"] [Char]
newName forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [[Char]] -> IO (ExitCode, [Char], ByteString)
runGitCommand [Char]
repo [Char]
"mv" [[Char]
oldName, [Char]
newName]
if ExitCode
statusAdd forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then [Char] -> [[Char]] -> Author -> [Char] -> IO ()
gitCommit [Char]
repo [[Char]
oldName, [Char]
newName] Author
author [Char]
logMsg
else forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> FileStoreError
UnknownError forall a b. (a -> b) -> a -> b
$ [Char]
"Could not git mv " forall a. [a] -> [a] -> [a]
++ [Char]
oldName forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ [Char]
newName forall a. [a] -> [a] -> [a]
++ [Char]
"\n" forall a. [a] -> [a] -> [a]
++ [Char]
err
gitLatestRevId :: FilePath -> FilePath -> IO RevisionId
gitLatestRevId :: [Char] -> [Char] -> IO [Char]
gitLatestRevId [Char]
repo [Char]
name = do
(ExitCode
revListStatus, [Char]
_, ByteString
output) <- [Char] -> [Char] -> [[Char]] -> IO (ExitCode, [Char], ByteString)
runGitCommand [Char]
repo [Char]
"rev-list" [[Char]
"--max-count=1", [Char]
"HEAD", [Char]
"--", [Char]
name]
(ExitCode
catStatus,[Char]
_, ByteString
_) <- [Char] -> [Char] -> [[Char]] -> IO (ExitCode, [Char], ByteString)
runGitCommand [Char]
repo [Char]
"cat-file" [[Char]
"-e", [Char]
"HEAD:" forall a. [a] -> [a] -> [a]
++ [Char]
name]
if ExitCode
revListStatus forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess Bool -> Bool -> Bool
&& ExitCode
catStatus forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then do
let result :: [Char]
result = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char]
"\n\r \t") forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
toString ByteString
output
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
result
then forall e a. Exception e => e -> IO a
throwIO FileStoreError
NotFound
else forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
result
else forall e a. Exception e => e -> IO a
throwIO FileStoreError
NotFound
gitGetRevision :: FilePath -> RevisionId -> IO Revision
gitGetRevision :: [Char] -> [Char] -> IO Revision
gitGetRevision [Char]
repo [Char]
revid = do
(ExitCode
status, [Char]
_, ByteString
output) <- [Char] -> [Char] -> [[Char]] -> IO (ExitCode, [Char], ByteString)
runGitCommand [Char]
repo [Char]
"whatchanged" [[Char]
"-z",[Char]
"--pretty=format:" forall a. [a] -> [a] -> [a]
++ [Char]
gitLogFormat, [Char]
"--max-count=1", [Char]
revid]
if ExitCode
status forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then ByteString -> IO Revision
parseLogEntry forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> ByteString
B.drop Int64
1 ByteString
output
else forall e a. Exception e => e -> IO a
throwIO FileStoreError
NotFound
gitIndex :: FilePath ->IO [FilePath]
gitIndex :: [Char] -> IO [[Char]]
gitIndex [Char]
repo = forall a. [Char] -> IO a -> IO a
withVerifyDir [Char]
repo forall a b. (a -> b) -> a -> b
$ do
(ExitCode
status, [Char]
_err, ByteString
output) <- [Char] -> [Char] -> [[Char]] -> IO (ExitCode, [Char], ByteString)
runGitCommand [Char]
repo [Char]
"ls-tree" [[Char]
"-r",[Char]
"-t",[Char]
"-z",[Char]
"HEAD"]
if ExitCode
status forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([[Char]] -> Maybe [Char]
lineToFilename forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
words) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [[a]]
endByOneOf [Char
'\0'] forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
toString forall a b. (a -> b) -> a -> b
$ ByteString
output
else forall (m :: * -> *) a. Monad m => a -> m a
return []
where lineToFilename :: [[Char]] -> Maybe [Char]
lineToFilename ([Char]
_:[Char]
"blob":[Char]
_:[[Char]]
rest) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]]
rest
lineToFilename [[Char]]
_ = forall a. Maybe a
Nothing
gitDirectory :: FilePath -> FilePath -> IO [Resource]
gitDirectory :: [Char] -> [Char] -> IO [Resource]
gitDirectory [Char]
repo [Char]
dir = forall a. [Char] -> IO a -> IO a
withVerifyDir ([Char]
repo [Char] -> [Char] -> [Char]
</> [Char]
dir) forall a b. (a -> b) -> a -> b
$ do
(ExitCode
status, [Char]
_err, ByteString
output) <- [Char] -> [Char] -> [[Char]] -> IO (ExitCode, [Char], ByteString)
runGitCommand [Char]
repo [Char]
"ls-tree" [[Char]
"-z",[Char]
"HEAD:" forall a. [a] -> [a] -> [a]
++ [Char]
dir]
if ExitCode
status forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ([[Char]] -> Resource
lineToResource forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
words) forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> [[a]]
endByOneOf [Char
'\0'] forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
toString ByteString
output
else forall (m :: * -> *) a. Monad m => a -> m a
return []
where lineToResource :: [[Char]] -> Resource
lineToResource ([Char]
_:[Char]
"blob":[Char]
_:[[Char]]
rest) = [Char] -> Resource
FSFile forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]]
rest
lineToResource ([Char]
_:[Char]
"tree":[Char]
_:[[Char]]
rest) = [Char] -> Resource
FSDirectory forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]]
rest
lineToResource [[Char]]
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"Encountered an item that is neither blob nor tree in git ls-tree"
gitSearch :: FilePath -> SearchQuery -> IO [SearchMatch]
gitSearch :: [Char] -> SearchQuery -> IO [SearchMatch]
gitSearch [Char]
repo SearchQuery
query = do
let opts :: [[Char]]
opts = [[Char]
"-I",[Char]
"-n",[Char]
"--null"] forall a. [a] -> [a] -> [a]
++
[[Char]
"--ignore-case" | SearchQuery -> Bool
queryIgnoreCase SearchQuery
query] forall a. [a] -> [a] -> [a]
++
[[Char]
"--all-match" | SearchQuery -> Bool
queryMatchAll SearchQuery
query] forall a. [a] -> [a] -> [a]
++
[[Char]
"--word-regexp" | SearchQuery -> Bool
queryWholeWords SearchQuery
query]
(ExitCode
status, [Char]
errOutput, ByteString
output) <- [Char] -> [Char] -> [[Char]] -> IO (ExitCode, [Char], ByteString)
runGitCommand [Char]
repo [Char]
"grep" ([[Char]]
opts forall a. [a] -> [a] -> [a]
++
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\[Char]
term -> [[Char]
"-e", [Char] -> [Char]
escapeRegexSpecialChars [Char]
term]) (SearchQuery -> [[Char]]
queryPatterns SearchQuery
query))
case ExitCode
status of
ExitCode
ExitSuccess -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map [Char] -> SearchMatch
parseMatchLine forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
lines forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
toString ByteString
output
ExitFailure Int
1 -> forall (m :: * -> *) a. Monad m => a -> m a
return []
ExitFailure Int
_ -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> FileStoreError
UnknownError forall a b. (a -> b) -> a -> b
$ [Char]
"git grep returned error status.\n" forall a. [a] -> [a] -> [a]
++ [Char]
errOutput
parseMatchLine :: String -> SearchMatch
parseMatchLine :: [Char] -> SearchMatch
parseMatchLine [Char]
str =
SearchMatch{ matchResourceName :: [Char]
matchResourceName = [Char]
fname
, matchLineNumber :: Integer
matchLineNumber = if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
ln)
then forall a. Read a => [Char] -> a
read [Char]
ln
else forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"parseMatchLine: " forall a. [a] -> [a] -> [a]
++ [Char]
str
, matchLine :: [Char]
matchLine = [Char]
cont}
where ([Char]
fname,[Char]
xs) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'\NUL') [Char]
str
rest :: [Char]
rest = forall a. Int -> [a] -> [a]
drop Int
1 [Char]
xs
([Char]
ln,[Char]
ys) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'0'..Char
'9']) [Char]
rest
cont :: [Char]
cont = forall a. Int -> [a] -> [a]
drop Int
1 [Char]
ys
gitLogFormat :: String
gitLogFormat :: [Char]
gitLogFormat = [Char]
"%x01%H%x00%ct%x00%an%x00%ae%x00%B%n%x00"
gitLog :: FilePath -> [FilePath] -> TimeRange -> Maybe Int -> IO [Revision]
gitLog :: [Char] -> [[Char]] -> TimeRange -> Maybe Int -> IO [Revision]
gitLog [Char]
repo [[Char]]
names (TimeRange Maybe UTCTime
mbSince Maybe UTCTime
mbUntil) Maybe Int
mblimit = do
(ExitCode
status, [Char]
err, ByteString
output) <- [Char] -> [Char] -> [[Char]] -> IO (ExitCode, [Char], ByteString)
runGitCommand [Char]
repo [Char]
"whatchanged" forall a b. (a -> b) -> a -> b
$
[[Char]
"-z",[Char]
"--pretty=format:" forall a. [a] -> [a] -> [a]
++ [Char]
gitLogFormat] forall a. [a] -> [a] -> [a]
++
(case Maybe UTCTime
mbSince of
Just UTCTime
since -> [[Char]
"--since='" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show UTCTime
since forall a. [a] -> [a] -> [a]
++ [Char]
"'"]
Maybe UTCTime
Nothing -> []) forall a. [a] -> [a] -> [a]
++
(case Maybe UTCTime
mbUntil of
Just UTCTime
til -> [[Char]
"--until='" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show UTCTime
til forall a. [a] -> [a] -> [a]
++ [Char]
"'"]
Maybe UTCTime
Nothing -> []) forall a. [a] -> [a] -> [a]
++
(case Maybe Int
mblimit of
Just Int
lim -> [[Char]
"-n", forall a. Show a => a -> [Char]
show Int
lim]
Maybe Int
Nothing -> []) forall a. [a] -> [a] -> [a]
++
[[Char]
"--"] forall a. [a] -> [a] -> [a]
++ [[Char]]
names
if ExitCode
status forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then ByteString -> IO [Revision]
parseGitLog ByteString
output
else forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> FileStoreError
UnknownError forall a b. (a -> b) -> a -> b
$ [Char]
"git whatchanged returned error status.\n" forall a. [a] -> [a] -> [a]
++ [Char]
err
parseGitLog :: B.ByteString -> IO [Revision]
parseGitLog :: ByteString -> IO [Revision]
parseGitLog = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ByteString -> IO Revision
parseLogEntry forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
splitEntries
splitEntries :: B.ByteString -> [B.ByteString]
splitEntries :: ByteString -> [ByteString]
splitEntries = forall a. (a -> Bool) -> [a] -> [a]
dropWhile ByteString -> Bool
B.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteString -> [ByteString]
B.split Char
'\1'
parseLogEntry :: B.ByteString -> IO Revision
parseLogEntry :: ByteString -> IO Revision
parseLogEntry ByteString
entry = do
let (ByteString
rev : ByteString
date' : ByteString
author : ByteString
email : ByteString
subject : [ByteString]
rest) = Char -> ByteString -> [ByteString]
B.split Char
'\0' ByteString
entry
Integer
date <- case ByteString -> Maybe (Integer, ByteString)
B.readInteger ByteString
date' of
Just (Integer
x,ByteString
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Integer
x
Maybe (Integer, ByteString)
Nothing -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> FileStoreError
UnknownError forall a b. (a -> b) -> a -> b
$ [Char]
"Could not read date"
[Change]
changes <- [ByteString] -> IO [Change]
parseChanges forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
B.null) [ByteString]
rest
forall (m :: * -> *) a. Monad m => a -> m a
return Revision {
revId :: [Char]
revId = ByteString -> [Char]
toString ByteString
rev
, revDateTime :: UTCTime
revDateTime = POSIXTime -> UTCTime
posixSecondsToUTCTime forall a b. (a -> b) -> a -> b
$ forall a b. (Real a, Fractional b) => a -> b
realToFrac Integer
date
, revAuthor :: Author
revAuthor = Author{ authorName :: [Char]
authorName = ByteString -> [Char]
toString ByteString
author
, authorEmail :: [Char]
authorEmail = ByteString -> [Char]
toString ByteString
email }
, revDescription :: [Char]
revDescription = ByteString -> [Char]
toString forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
stripTrailingNewlines ByteString
subject
, revChanges :: [Change]
revChanges = [Change]
changes }
stripTrailingNewlines :: B.ByteString -> B.ByteString
stripTrailingNewlines :: ByteString -> ByteString
stripTrailingNewlines = ByteString -> ByteString
B.reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
B.dropWhile (forall a. Eq a => a -> a -> Bool
==Char
'\n') forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B.reverse
parseChanges :: [B.ByteString] -> IO [Change]
parseChanges :: [ByteString] -> IO [Change]
parseChanges (ByteString
x:ByteString
y:[ByteString]
zs) = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
B.null ByteString
x) forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> IO a
pcErr [Char]
"found empty change description"
let changeType :: Char
changeType = ByteString -> Char
B.head forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
B.words ByteString
x
let file' :: [Char]
file' = ByteString -> [Char]
toString ByteString
y
if Char
changeType forall a. Eq a => a -> a -> Bool
== Char
'R'
then [ByteString] -> IO [Change]
parseChanges (forall a. [a] -> [a]
tail [ByteString]
zs) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a] -> [a]
(++) ([Char] -> Change
Deleted [Char]
file' forall a. a -> [a] -> [a]
: [Char] -> Change
Added (ByteString -> [Char]
toString forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [ByteString]
zs) forall a. a -> [a] -> [a]
: [])
else
do Change
next <- case Char
changeType of
Char
'A' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> Change
Added [Char]
file'
Char
'M' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> Change
Modified [Char]
file'
Char
'D' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> Change
Deleted [Char]
file'
Char
_ -> forall a. [Char] -> IO a
pcErr ([Char]
"found unknown changeType '" forall a. [a] -> [a] -> [a]
++
(forall a. Show a => a -> [Char]
show Char
changeType) forall a. [a] -> [a] -> [a]
++
[Char]
"' in: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show ByteString
x) forall a. [a] -> [a] -> [a]
++
[Char]
" on " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show ByteString
y))
[Change]
rest <- [ByteString] -> IO [Change]
parseChanges [ByteString]
zs
forall (m :: * -> *) a. Monad m => a -> m a
return (Change
nextforall a. a -> [a] -> [a]
:[Change]
rest)
parseChanges [ByteString
_] =
forall a. [Char] -> IO a
pcErr [Char]
"encountered odd number of fields"
parseChanges [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
pcErr :: forall a. String -> IO a
pcErr :: forall a. [Char] -> IO a
pcErr = forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FileStoreError
UnknownError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a] -> [a]
(++) [Char]
"filestore parseChanges "
postUpdate :: B.ByteString
postUpdate :: ByteString
postUpdate =
[Char] -> ByteString
B.pack
[Char]
"#!/bin/bash\n\
\#\n\
\# This hook does two things:\n\
\#\n\
\# 1. update the \"info\" files that allow the list of references to be\n\
\# queries over dumb transports such as http\n\
\#\n\
\# 2. if this repository looks like it is a non-bare repository, and\n\
\# the checked-out branch is pushed to, then update the working copy.\n\
\# This makes \"push\" function somewhat similarly to darcs and bzr.\n\
\#\n\
\# To enable this hook, make this file executable by \"chmod +x post-update\".\n\
\\n\
\git-update-server-info\n\
\\n\
\is_bare=$(git-config --get --bool core.bare)\n\
\\n\
\if [ -z \"$is_bare\" ]\n\
\then\n\
\ # for compatibility's sake, guess\n\
\ git_dir_full=$(cd $GIT_DIR; pwd)\n\
\ case $git_dir_full in */.git) is_bare=false;; *) is_bare=true;; esac\n\
\fi\n\
\\n\
\update_wc() {\n\
\ ref=$1\n\
\ echo \"Push to checked out branch $ref\" >&2\n\
\ if [ ! -f $GIT_DIR/logs/HEAD ]\n\
\ then\n\
\ echo \"E:push to non-bare repository requires a HEAD reflog\" >&2\n\
\ exit 1\n\
\ fi\n\
\ if (cd $GIT_WORK_TREE; git-diff-files -q --exit-code >/dev/null)\n\
\ then\n\
\ wc_dirty=0\n\
\ else\n\
\ echo \"W:unstaged changes found in working copy\" >&2\n\
\ wc_dirty=1\n\
\ desc=\"working copy\"\n\
\ fi\n\
\ if git diff-index --cached HEAD@{1} >/dev/null\n\
\ then\n\
\ index_dirty=0\n\
\ else\n\
\ echo \"W:uncommitted, staged changes found\" >&2\n\
\ index_dirty=1\n\
\ if [ -n \"$desc\" ]\n\
\ then\n\
\ desc=\"$desc and index\"\n\
\ else\n\
\ desc=\"index\"\n\
\ fi\n\
\ fi\n\
\ if [ \"$wc_dirty\" -ne 0 -o \"$index_dirty\" -ne 0 ]\n\
\ then\n\
\ new=$(git rev-parse HEAD)\n\
\ echo \"W:stashing dirty $desc - see git-stash(1)\" >&2\n\
\ ( trap 'echo trapped $$; git symbolic-ref HEAD \"'\"$ref\"'\"' 2 3 13 15 ERR EXIT\n\
\ git-update-ref --no-deref HEAD HEAD@{1}\n\
\ cd $GIT_WORK_TREE\n\
\ git stash save \"dirty $desc before update to $new\";\n\
\ git-symbolic-ref HEAD \"$ref\"\n\
\ )\n\
\ fi\n\
\\n\
\ # eye candy - show the WC updates :)\n\
\ echo \"Updating working copy\" >&2\n\
\ (cd $GIT_WORK_TREE\n\
\ git-diff-index -R --name-status HEAD >&2\n\
\ git-reset --hard HEAD)\n\
\}\n\
\\n\
\if [ \"$is_bare\" = \"false\" ]\n\
\then\n\
\ active_branch=`git-symbolic-ref HEAD`\n\
\ export GIT_DIR=$(cd $GIT_DIR; pwd)\n\
\ GIT_WORK_TREE=${GIT_WORK_TREE-..}\n\
\ for ref\n\
\ do\n\
\ if [ \"$ref\" = \"$active_branch\" ]\n\
\ then\n\
\ update_wc $ref\n\
\ fi\n\
\ done\n\
\fi"