{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DoAndIfThenElse #-}

{- |
   Module      : Data.FileStore.Git
   Copyright   : Copyright (C) 2009 John MacFarlane
   License     : BSD 3

   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : GHC 6.10 required

   A versioned filestore implemented using git.
   Normally this module should not be imported: import
   "Data.FileStore" instead.

   It is assumed that git >= 1.7.2 is available on
   the system path.
-}

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

-- | Return a filestore implemented using the git distributed revision control system
-- (<http://git-scm.com/>).
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              = [Char] -> [Char] -> Author -> [Char] -> a -> IO ()
forall a.
Contents a =>
[Char] -> [Char] -> Author -> [Char] -> a -> IO ()
gitSave [Char]
repo 
  , retrieve :: forall a. Contents a => [Char] -> Maybe [Char] -> IO a
retrieve          = [Char] -> [Char] -> Maybe [Char] -> IO a
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          = ([Char] -> [Char] -> Bool) -> [Char] -> [Char] -> [Char] -> Bool
forall a b. a -> b -> a
const [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
hashsMatch [Char]
repo
  }

-- | Run a git command and return error status, error output, standard output.  The repository
-- is used as working directory.
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 []

-- | Run a git command with the given environment and return error status, error output, standard
-- output.  The repository is used as working directory.
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 = [([Char], [Char])] -> Maybe [([Char], [Char])]
forall a. a -> Maybe a
Just ([([Char]
"GIT_DIFF_OPTS", [Char]
"-u100000")] [([Char], [Char])] -> [([Char], [Char])] -> [([Char], [Char])]
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 [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
args)
  (ExitCode, [Char], ByteString) -> IO (ExitCode, [Char], ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
status, ByteString -> [Char]
toString ByteString
err, ByteString
out)

-- | Initialize a repository, creating the directory if needed.
gitInit :: FilePath -> IO ()
gitInit :: [Char] -> IO ()
gitInit [Char]
repo = do
  Bool
exists <- [Char] -> IO Bool
doesDirectoryExist [Char]
repo
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO () -> IO ()
forall a. [Char] -> IO a -> IO a
withVerifyDir [Char]
repo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FileStoreError -> IO ()
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 ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
     then do
       -- Add the post-update hook, so that changes made remotely via git
       -- will be reflected in the working directory.
       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})
       -- Set up repo to allow push to current branch
       (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' ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
          then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          else FileStoreError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (FileStoreError -> IO ()) -> FileStoreError -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> FileStoreError
UnknownError ([Char] -> FileStoreError) -> [Char] -> FileStoreError
forall a b. (a -> b) -> a -> b
$ [Char]
"git config failed:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err'
     else FileStoreError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (FileStoreError -> IO ()) -> FileStoreError -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> FileStoreError
UnknownError ([Char] -> FileStoreError) -> [Char] -> FileStoreError
forall a b. (a -> b) -> a -> b
$ [Char]
"git-init failed:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err 

-- | Commit changes to a resource.  Raise 'Unchanged' exception if there were
-- no changes.
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" ([[Char]] -> IO (ExitCode, [Char], ByteString))
-> [[Char]] -> IO (ExitCode, [Char], ByteString)
forall a b. (a -> b) -> a -> b
$ [[Char]
"--author", Author -> [Char]
authorName Author
author [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" <" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                    Author -> [Char]
authorEmail Author
author [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
">", [Char]
"-m", [Char]
logMsg] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
names
  if ExitCode
statusCommit ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
     then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     else FileStoreError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (FileStoreError -> IO ()) -> FileStoreError -> IO ()
forall a b. (a -> b) -> a -> b
$ if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
errCommit
                       then FileStoreError
Unchanged
                       else [Char] -> FileStoreError
UnknownError ([Char] -> FileStoreError) -> [Char] -> FileStoreError
forall a b. (a -> b) -> a -> b
$ [Char]
"Could not git commit " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [[Char]]
names [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
errCommit

-- | Save changes (creating file and directory if needed), add, and commit.
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
  [Char] -> [[Char]] -> [Char] -> IO () -> IO ()
forall b. [Char] -> [[Char]] -> [Char] -> IO b -> IO b
withSanityCheck [Char]
repo [[Char]
".git"] [Char]
name (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> IO ()
B.writeFile ([Char]
repo [Char] -> [Char] -> [Char]
</> [Char] -> [Char]
encodeArg [Char]
name) (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
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 ExitCode -> ExitCode -> Bool
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 FileStoreError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (FileStoreError -> IO ()) -> FileStoreError -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> FileStoreError
UnknownError ([Char] -> FileStoreError) -> [Char] -> FileStoreError
forall a b. (a -> b) -> a -> b
$ [Char]
"Could not git add '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'\n" [Char] -> [Char] -> [Char]
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" [[Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"HEAD" Maybe [Char]
revid, [Char]
name]
  -- see http://stackoverflow.com/questions/737673
  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
6 ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
B.unpack ByteString
out) [Char] -> [Char] -> Bool
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 (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Contents a => a -> ByteString
toByteString a
linkContent)
  Either SomeException ByteString
result <- IO ByteString -> IO (Either SomeException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO ByteString -> IO (Either SomeException ByteString))
-> IO ByteString -> IO (Either SomeException ByteString)
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
B.readFile [Char]
targetName
  case Either SomeException ByteString
result of
    Left (SomeException
_ :: E.SomeException) -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    Right ByteString
contents -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just (ByteString -> a
forall a. Contents a => ByteString -> a
fromByteString ByteString
contents)

-- | Retrieve contents from resource.
gitRetrieve :: Contents a
            => FilePath
            -> FilePath
            -> Maybe RevisionId    -- ^ @Just@ revision ID, or @Nothing@ for latest
            -> 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:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name
                        Just [Char]
rev -> [Char]
rev [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name
  -- Check that the object is a file (blob), not a directory (tree)
  (ExitCode
_, [Char]
_, ByteString
output) <- [Char] -> [Char] -> [[Char]] -> IO (ExitCode, [Char], ByteString)
runGitCommand [Char]
repo [Char]
"cat-file" [[Char]
"-t", [Char]
objectName]
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
4 (ByteString -> [Char]
toString ByteString
output) [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
"blob") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FileStoreError -> IO ()
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' ExitCode -> ExitCode -> Bool
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 <- [Char] -> [Char] -> ByteString -> IO (Maybe ByteString)
forall a. Contents a => [Char] -> [Char] -> a -> IO (Maybe a)
targetContents [Char]
repo [Char]
name ByteString
output'
          case Maybe ByteString
contents of
            -- ideal output on Nothing would be something like
            -- "broken symlink: <output'>", but I couldn't figure
            -- out the bytestring types to do that.
            -- also didn't bother trying to get the browser
            -- to display the error as text if the symlink is to some
            -- other format.
            Maybe ByteString
Nothing -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ ByteString -> a
forall a. Contents a => ByteString -> a
fromByteString ByteString
output'
            Just ByteString
bs -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ ByteString -> a
forall a. Contents a => ByteString -> a
fromByteString ByteString
bs
        else a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ ByteString -> a
forall a. Contents a => ByteString -> a
fromByteString ByteString
output'
     else FileStoreError -> IO a
forall e a. Exception e => e -> IO a
throwIO (FileStoreError -> IO a) -> FileStoreError -> IO a
forall a b. (a -> b) -> a -> b
$ [Char] -> FileStoreError
UnknownError ([Char] -> FileStoreError) -> [Char] -> FileStoreError
forall a b. (a -> b) -> a -> b
$ [Char]
"Error in git cat-file:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err'

-- | Delete a resource from the repository.
gitDelete :: FilePath -> FilePath -> Author -> Description -> IO ()
gitDelete :: [Char] -> [Char] -> Author -> [Char] -> IO ()
gitDelete [Char]
repo [Char]
name Author
author [Char]
logMsg = [Char] -> [[Char]] -> [Char] -> IO () -> IO ()
forall b. [Char] -> [[Char]] -> [Char] -> IO b -> IO b
withSanityCheck [Char]
repo [[Char]
".git"] [Char]
name (IO () -> IO ()) -> IO () -> IO ()
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 ExitCode -> ExitCode -> Bool
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 FileStoreError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (FileStoreError -> IO ()) -> FileStoreError -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> FileStoreError
UnknownError ([Char] -> FileStoreError) -> [Char] -> FileStoreError
forall a b. (a -> b) -> a -> b
$ [Char]
"Could not git rm '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
errRm

-- | Change the name of a resource.
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   -- will throw a NotFound error if oldName doesn't exist
  (ExitCode
statusAdd, [Char]
err, ByteString
_) <- [Char]
-> [[Char]]
-> [Char]
-> IO (ExitCode, [Char], ByteString)
-> IO (ExitCode, [Char], ByteString)
forall b. [Char] -> [[Char]] -> [Char] -> IO b -> IO b
withSanityCheck [Char]
repo [[Char]
".git"] [Char]
newName (IO (ExitCode, [Char], ByteString)
 -> IO (ExitCode, [Char], ByteString))
-> IO (ExitCode, [Char], ByteString)
-> IO (ExitCode, [Char], ByteString)
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 ExitCode -> ExitCode -> Bool
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 FileStoreError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (FileStoreError -> IO ()) -> FileStoreError -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> FileStoreError
UnknownError ([Char] -> FileStoreError) -> [Char] -> FileStoreError
forall a b. (a -> b) -> a -> b
$ [Char]
"Could not git mv " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
oldName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
newName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err

-- | Return revision ID for latest commit for a resource.
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]
  -- we need to check separately to make sure the resource hasn't been removed
  -- from the repository:
  (ExitCode
catStatus,[Char]
_, ByteString
_) <- [Char] -> [Char] -> [[Char]] -> IO (ExitCode, [Char], ByteString)
runGitCommand [Char]
repo [Char]
"cat-file" [[Char]
"-e", [Char]
"HEAD:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name]
  if ExitCode
revListStatus ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess Bool -> Bool -> Bool
&& ExitCode
catStatus ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
     then do
       let result :: [Char]
result = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char]
"\n\r \t") ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
toString ByteString
output
       if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
result
          then FileStoreError -> IO [Char]
forall e a. Exception e => e -> IO a
throwIO FileStoreError
NotFound
          else [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
result
     else FileStoreError -> IO [Char]
forall e a. Exception e => e -> IO a
throwIO FileStoreError
NotFound

-- | Get revision information for a particular revision ID, or latest revision.
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:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
gitLogFormat, [Char]
"--max-count=1", [Char]
revid]
  if ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
     then ByteString -> IO Revision
parseLogEntry (ByteString -> IO Revision) -> ByteString -> IO Revision
forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> ByteString
B.drop Int64
1 ByteString
output -- drop initial \1
     else FileStoreError -> IO Revision
forall e a. Exception e => e -> IO a
throwIO FileStoreError
NotFound

-- | Get a list of all known files inside and managed by a repository.
gitIndex :: FilePath ->IO [FilePath]
gitIndex :: [Char] -> IO [[Char]]
gitIndex [Char]
repo = [Char] -> IO [[Char]] -> IO [[Char]]
forall a. [Char] -> IO a -> IO a
withVerifyDir [Char]
repo (IO [[Char]] -> IO [[Char]]) -> IO [[Char]] -> IO [[Char]]
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 ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
     then [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Char]] -> IO [[Char]]) -> [[Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> Maybe [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([[Char]] -> Maybe [Char]
lineToFilename ([[Char]] -> Maybe [Char])
-> ([Char] -> [[Char]]) -> [Char] -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
words) ([[Char]] -> [[Char]])
-> (ByteString -> [[Char]]) -> ByteString -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [[Char]]
forall a. Eq a => [a] -> [a] -> [[a]]
endByOneOf [Char
'\0'] ([Char] -> [[Char]])
-> (ByteString -> [Char]) -> ByteString -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
toString (ByteString -> [[Char]]) -> ByteString -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ByteString
output
     else [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [] -- if error, will return empty list
                    -- note:  on a newly initialized repo, 'git ls-tree HEAD' returns an error
   where lineToFilename :: [[Char]] -> Maybe [Char]
lineToFilename ([Char]
_:[Char]
"blob":[Char]
_:[[Char]]
rest) = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]]
rest
         lineToFilename [[Char]]
_                 = Maybe [Char]
forall a. Maybe a
Nothing

-- | Get list of resources in one directory of the repository.
gitDirectory :: FilePath -> FilePath -> IO [Resource]
gitDirectory :: [Char] -> [Char] -> IO [Resource]
gitDirectory [Char]
repo [Char]
dir = [Char] -> IO [Resource] -> IO [Resource]
forall a. [Char] -> IO a -> IO a
withVerifyDir ([Char]
repo [Char] -> [Char] -> [Char]
</> [Char]
dir) (IO [Resource] -> IO [Resource]) -> IO [Resource] -> IO [Resource]
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:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
dir]
  if ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
     then [Resource] -> IO [Resource]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Resource] -> IO [Resource]) -> [Resource] -> IO [Resource]
forall a b. (a -> b) -> a -> b
$ ([Char] -> Resource) -> [[Char]] -> [Resource]
forall a b. (a -> b) -> [a] -> [b]
map ([[Char]] -> Resource
lineToResource ([[Char]] -> Resource)
-> ([Char] -> [[Char]]) -> [Char] -> Resource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
words) ([[Char]] -> [Resource]) -> [[Char]] -> [Resource]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [[Char]]
forall a. Eq a => [a] -> [a] -> [[a]]
endByOneOf [Char
'\0'] ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
toString ByteString
output
     else [Resource] -> IO [Resource]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []   -- if error, this will return empty list
                      -- note:  on a newly initialized repo, 'git ls-tree HEAD:' returns an error
   where lineToResource :: [[Char]] -> Resource
lineToResource ([Char]
_:[Char]
"blob":[Char]
_:[[Char]]
rest) = [Char] -> Resource
FSFile ([Char] -> Resource) -> [Char] -> Resource
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]]
rest
         lineToResource ([Char]
_:[Char]
"tree":[Char]
_:[[Char]]
rest) = [Char] -> Resource
FSDirectory ([Char] -> Resource) -> [Char] -> Resource
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]]
rest
         lineToResource [[Char]]
_                 = [Char] -> Resource
forall a. HasCallStack => [Char] -> a
error [Char]
"Encountered an item that is neither blob nor tree in git ls-tree"

-- | Uses git-grep to search repository.  Escape regex special characters, so the pattern
-- is interpreted as an ordinary string.
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"] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
             [[Char]
"--ignore-case" | SearchQuery -> Bool
queryIgnoreCase SearchQuery
query] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
             [[Char]
"--all-match" | SearchQuery -> Bool
queryMatchAll SearchQuery
query] [[Char]] -> [[Char]] -> [[Char]]
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 [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
                                   ([Char] -> [[Char]]) -> [[Char]] -> [[Char]]
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   -> [SearchMatch] -> IO [SearchMatch]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([SearchMatch] -> IO [SearchMatch])
-> [SearchMatch] -> IO [SearchMatch]
forall a b. (a -> b) -> a -> b
$ ([Char] -> SearchMatch) -> [[Char]] -> [SearchMatch]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> SearchMatch
parseMatchLine ([[Char]] -> [SearchMatch]) -> [[Char]] -> [SearchMatch]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
lines ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
toString ByteString
output
     ExitFailure Int
1 -> [SearchMatch] -> IO [SearchMatch]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []  -- status of 1 means no matches in recent versions of git
     ExitFailure Int
_ -> FileStoreError -> IO [SearchMatch]
forall e a. Exception e => e -> IO a
throwIO (FileStoreError -> IO [SearchMatch])
-> FileStoreError -> IO [SearchMatch]
forall a b. (a -> b) -> a -> b
$ [Char] -> FileStoreError
UnknownError ([Char] -> FileStoreError) -> [Char] -> FileStoreError
forall a b. (a -> b) -> a -> b
$ [Char]
"git grep returned error status.\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
errOutput

-- Auxiliary function for searchResults
parseMatchLine :: String -> SearchMatch
parseMatchLine :: [Char] -> SearchMatch
parseMatchLine [Char]
str =
  SearchMatch{ matchResourceName :: [Char]
matchResourceName = [Char]
fname
             , matchLineNumber :: Integer
matchLineNumber = if Bool -> Bool
not ([Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
ln)
                                    then [Char] -> Integer
forall a. Read a => [Char] -> a
read [Char]
ln
                                    else [Char] -> Integer
forall a. HasCallStack => [Char] -> a
error ([Char] -> Integer) -> [Char] -> Integer
forall a b. (a -> b) -> a -> b
$ [Char]
"parseMatchLine: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
str
             , matchLine :: [Char]
matchLine = [Char]
cont}
    where ([Char]
fname,[Char]
xs) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\NUL') [Char]
str
          rest :: [Char]
rest = Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
1 [Char]
xs 
          -- for some reason, NUL is used after line number instead of
          -- : when --match-all is passed to git-grep.
          ([Char]
ln,[Char]
ys) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'0'..Char
'9']) [Char]
rest
          cont :: [Char]
cont = Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
1 [Char]
ys   -- drop : or NUL after line number

{-
-- | Uses git-diff to get a dif between two revisions.
gitDiff :: FilePath -> FilePath -> RevisionId -> RevisionId -> IO String
gitDiff repo name from to = do
  (status, _, output) <- runGitCommand repo "diff" [from, to, name]
  if status == ExitSuccess
     then return $ toString output
     else do
       -- try it without the path, since the error might be "not in working tree" for a deleted file
       (status', err', output') <- runGitCommand repo "diff" [from, to]
       if status' == ExitSuccess
          then return $ toString output'
          else throwIO $ UnknownError $ "git diff returned error:\n" ++ err'
-}

gitLogFormat :: String
gitLogFormat :: [Char]
gitLogFormat = [Char]
"%x01%H%x00%ct%x00%an%x00%ae%x00%B%n%x00"

-- | Return list of log entries for the given time frame and list of resources.
-- If list of resources is empty, log entries for all resources are returned.
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" ([[Char]] -> IO (ExitCode, [Char], ByteString))
-> [[Char]] -> IO (ExitCode, [Char], ByteString)
forall a b. (a -> b) -> a -> b
$
                           [[Char]
"-z",[Char]
"--pretty=format:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
gitLogFormat] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
                           (case Maybe UTCTime
mbSince of
                                 Just UTCTime
since   -> [[Char]
"--since='" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ UTCTime -> [Char]
forall a. Show a => a -> [Char]
show UTCTime
since [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'"]
                                 Maybe UTCTime
Nothing      -> []) [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
                           (case Maybe UTCTime
mbUntil of
                                 Just UTCTime
til   -> [[Char]
"--until='" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ UTCTime -> [Char]
forall a. Show a => a -> [Char]
show UTCTime
til [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'"]
                                 Maybe UTCTime
Nothing      -> []) [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
                           (case Maybe Int
mblimit of
                                 Just Int
lim   -> [[Char]
"-n", Int -> [Char]
forall a. Show a => a -> [Char]
show Int
lim]
                                 Maybe Int
Nothing    -> []) [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
                           [[Char]
"--"] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
names
  if ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
     then ByteString -> IO [Revision]
parseGitLog ByteString
output
     else FileStoreError -> IO [Revision]
forall e a. Exception e => e -> IO a
throwIO (FileStoreError -> IO [Revision])
-> FileStoreError -> IO [Revision]
forall a b. (a -> b) -> a -> b
$ [Char] -> FileStoreError
UnknownError ([Char] -> FileStoreError) -> [Char] -> FileStoreError
forall a b. (a -> b) -> a -> b
$ [Char]
"git whatchanged returned error status.\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err

--
-- Parsers to parse git log into Revisions.
--

parseGitLog :: B.ByteString -> IO [Revision]
parseGitLog :: ByteString -> IO [Revision]
parseGitLog = (ByteString -> IO Revision) -> [ByteString] -> IO [Revision]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ByteString -> IO Revision
parseLogEntry ([ByteString] -> IO [Revision])
-> (ByteString -> [ByteString]) -> ByteString -> IO [Revision]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
splitEntries

splitEntries :: B.ByteString -> [B.ByteString]
splitEntries :: ByteString -> [ByteString]
splitEntries = (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ByteString -> Bool
B.null ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteString -> [ByteString]
B.split Char
'\1' -- occurs just before each hash

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
_) -> Integer -> IO Integer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
x
               Maybe (Integer, ByteString)
Nothing    -> FileStoreError -> IO Integer
forall e a. Exception e => e -> IO a
throwIO (FileStoreError -> IO Integer) -> FileStoreError -> IO Integer
forall a b. (a -> b) -> a -> b
$ [Char] -> FileStoreError
UnknownError ([Char] -> FileStoreError) -> [Char] -> FileStoreError
forall a b. (a -> b) -> a -> b
$ [Char]
"Could not read date"
  [Change]
changes <- [ByteString] -> IO [Change]
parseChanges ([ByteString] -> IO [Change]) -> [ByteString] -> IO [Change]
forall a b. (a -> b) -> a -> b
$ (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
B.null) [ByteString]
rest
  Revision -> IO Revision
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Revision {
              revId :: [Char]
revId          = ByteString -> [Char]
toString ByteString
rev
            , revDateTime :: UTCTime
revDateTime    = POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime) -> POSIXTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ Integer -> POSIXTime
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 (ByteString -> [Char]) -> ByteString -> [Char]
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 (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
B.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n') (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B.reverse

-- | This function converts the git "log" %B (raw body) format into a
-- list of Change items (e.g. `Added FilePath`, `Modified FilePath`,
-- or `Deleted FilePath`).  The raw body format is normally pairs of
-- ByteStrings, like:
--
--    ":000000 100644 0000000... 9cf8bba... A", "path/to/file.foo"
--
-- where the last letter of the first element is the type of change.
-- Git can track renames however, and those are noted by a triple of
-- ByteStrings; for example:
--
--   ":100644 100644 6c2c6e2... d333ad0... R063",
--   "old/file/path/name.foo",
--   "new/file/path/newname.bar"
--
-- Since filestore does not track renames, these are converted to
-- a remove of the first file and an add of the second.
--
-- n.b. without reading git sources, it's not clear what the raw body
-- format details are; specifically, the three digits following the R
-- are ignored.
parseChanges :: [B.ByteString] -> IO [Change]
parseChanges :: [ByteString] -> IO [Change]
parseChanges (ByteString
x:ByteString
y:[ByteString]
zs) = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
B.null ByteString
x) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. [Char] -> IO a
pcErr [Char]
"found empty change description"
  let changeType :: Char
changeType = ByteString -> Char
B.head (ByteString -> Char) -> ByteString -> Char
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
forall a. HasCallStack => [a] -> a
last ([ByteString] -> ByteString) -> [ByteString] -> ByteString
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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'R'
  then [ByteString] -> IO [Change]
parseChanges ([ByteString] -> [ByteString]
forall a. HasCallStack => [a] -> [a]
tail [ByteString]
zs) IO [Change] -> ([Change] -> IO [Change]) -> IO [Change]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
       [Change] -> IO [Change]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Change] -> IO [Change])
-> ([Change] -> [Change]) -> [Change] -> IO [Change]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Change] -> [Change] -> [Change]
forall a. [a] -> [a] -> [a]
(++) ([Char] -> Change
Deleted [Char]
file' Change -> [Change] -> [Change]
forall a. a -> [a] -> [a]
: [Char] -> Change
Added (ByteString -> [Char]
toString (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
forall a. HasCallStack => [a] -> a
head [ByteString]
zs) Change -> [Change] -> [Change]
forall a. a -> [a] -> [a]
: [])
  else
      do Change
next <- case Char
changeType of
                   Char
'A'  -> Change -> IO Change
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Change -> IO Change) -> Change -> IO Change
forall a b. (a -> b) -> a -> b
$ [Char] -> Change
Added [Char]
file'
                   Char
'M'  -> Change -> IO Change
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Change -> IO Change) -> Change -> IO Change
forall a b. (a -> b) -> a -> b
$ [Char] -> Change
Modified [Char]
file'
                   Char
'D'  -> Change -> IO Change
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Change -> IO Change) -> Change -> IO Change
forall a b. (a -> b) -> a -> b
$ [Char] -> Change
Deleted [Char]
file'
                   Char
_    -> [Char] -> IO Change
forall a. [Char] -> IO a
pcErr ([Char]
"found unknown changeType '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                  (Char -> [Char]
forall a. Show a => a -> [Char]
show Char
changeType) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                  [Char]
"' in: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
x) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                  [Char]
" on " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
y))
         [Change]
rest <- [ByteString] -> IO [Change]
parseChanges [ByteString]
zs
         [Change] -> IO [Change]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Change
nextChange -> [Change] -> [Change]
forall a. a -> [a] -> [a]
:[Change]
rest)
parseChanges [ByteString
_] =
  [Char] -> IO [Change]
forall a. [Char] -> IO a
pcErr [Char]
"encountered odd number of fields"
parseChanges [] = [Change] -> IO [Change]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

pcErr :: forall a. String -> IO a
pcErr :: forall a. [Char] -> IO a
pcErr = FileStoreError -> IO a
forall e a. Exception e => e -> IO a
throwIO (FileStoreError -> IO a)
-> ([Char] -> FileStoreError) -> [Char] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FileStoreError
UnknownError ([Char] -> FileStoreError)
-> ([Char] -> [Char]) -> [Char] -> FileStoreError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
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"