{-# 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 Paths_filestore
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 :: FilePath -> FileStore
gitFileStore repo :: FilePath
repo = FileStore :: IO ()
-> (forall a.
    Contents a =>
    FilePath -> Author -> FilePath -> a -> IO ())
-> (forall a. Contents a => FilePath -> Maybe FilePath -> IO a)
-> (FilePath -> Author -> FilePath -> IO ())
-> (FilePath -> FilePath -> Author -> FilePath -> IO ())
-> ([FilePath] -> TimeRange -> Maybe Int -> IO [Revision])
-> (FilePath -> IO FilePath)
-> (FilePath -> IO Revision)
-> IO [FilePath]
-> (FilePath -> IO [Resource])
-> (FilePath -> FilePath -> Bool)
-> (SearchQuery -> IO [SearchMatch])
-> FileStore
FileStore {
    initialize :: IO ()
initialize        = FilePath -> IO ()
gitInit FilePath
repo
  , save :: forall a.
Contents a =>
FilePath -> Author -> FilePath -> a -> IO ()
save              = FilePath -> FilePath -> Author -> FilePath -> a -> IO ()
forall a.
Contents a =>
FilePath -> FilePath -> Author -> FilePath -> a -> IO ()
gitSave FilePath
repo 
  , retrieve :: forall a. Contents a => FilePath -> Maybe FilePath -> IO a
retrieve          = FilePath -> FilePath -> Maybe FilePath -> IO a
forall a.
Contents a =>
FilePath -> FilePath -> Maybe FilePath -> IO a
gitRetrieve FilePath
repo
  , delete :: FilePath -> Author -> FilePath -> IO ()
delete            = FilePath -> FilePath -> Author -> FilePath -> IO ()
gitDelete FilePath
repo
  , rename :: FilePath -> FilePath -> Author -> FilePath -> IO ()
rename            = FilePath -> FilePath -> FilePath -> Author -> FilePath -> IO ()
gitMove FilePath
repo
  , history :: [FilePath] -> TimeRange -> Maybe Int -> IO [Revision]
history           = FilePath -> [FilePath] -> TimeRange -> Maybe Int -> IO [Revision]
gitLog FilePath
repo
  , latest :: FilePath -> IO FilePath
latest            = FilePath -> FilePath -> IO FilePath
gitLatestRevId FilePath
repo
  , revision :: FilePath -> IO Revision
revision          = FilePath -> FilePath -> IO Revision
gitGetRevision FilePath
repo
  , index :: IO [FilePath]
index             = FilePath -> IO [FilePath]
gitIndex FilePath
repo
  , directory :: FilePath -> IO [Resource]
directory         = FilePath -> FilePath -> IO [Resource]
gitDirectory FilePath
repo
  , search :: SearchQuery -> IO [SearchMatch]
search            = FilePath -> SearchQuery -> IO [SearchMatch]
gitSearch FilePath
repo 
  , idsMatch :: FilePath -> FilePath -> Bool
idsMatch          = (FilePath -> FilePath -> Bool)
-> FilePath -> FilePath -> FilePath -> Bool
forall a b. a -> b -> a
const FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
hashsMatch FilePath
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 :: FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runGitCommand = [(FilePath, FilePath)]
-> FilePath
-> FilePath
-> [FilePath]
-> IO (ExitCode, FilePath, 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 :: [(FilePath, FilePath)]
-> FilePath
-> FilePath
-> [FilePath]
-> IO (ExitCode, FilePath, ByteString)
runGitCommandWithEnv givenEnv :: [(FilePath, FilePath)]
givenEnv repo :: FilePath
repo command :: FilePath
command args :: [FilePath]
args = do
  let env :: Maybe [(FilePath, FilePath)]
env = [(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)]
forall a. a -> Maybe a
Just ([("GIT_DIFF_OPTS", "-u100000")] [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, FilePath)]
givenEnv)
  (status :: ExitCode
status, err :: ByteString
err, out :: ByteString
out) <- FilePath
-> Maybe [(FilePath, FilePath)]
-> FilePath
-> [FilePath]
-> IO (ExitCode, ByteString, ByteString)
runShellCommand FilePath
repo Maybe [(FilePath, FilePath)]
env "git" (FilePath
command FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
args)
  (ExitCode, FilePath, ByteString)
-> IO (ExitCode, FilePath, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
status, ByteString -> FilePath
toString ByteString
err, ByteString
out)

-- | Initialize a repository, creating the directory if needed.
gitInit :: FilePath -> IO ()
gitInit :: FilePath -> IO ()
gitInit repo :: FilePath
repo = do
  Bool
exists <- FilePath -> IO Bool
doesDirectoryExist FilePath
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
$ FilePath -> IO () -> IO ()
forall a. FilePath -> IO a -> IO a
withVerifyDir FilePath
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 -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
repo
  (status :: ExitCode
status, err :: FilePath
err, _) <- FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runGitCommand FilePath
repo "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.
       FilePath
postupdatepath <- FilePath -> IO FilePath
getDataFileName (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ "extra" FilePath -> FilePath -> FilePath
</> "post-update"
       ByteString
postupdatecontents <- FilePath -> IO ByteString
B.readFile FilePath
postupdatepath
       let postupdatedir :: FilePath
postupdatedir = FilePath
repo FilePath -> FilePath -> FilePath
</> ".git" FilePath -> FilePath -> FilePath
</> "hooks"
       Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
postupdatedir
       let postupdate :: FilePath
postupdate = FilePath
postupdatedir FilePath -> FilePath -> FilePath
</> "post-update"
       FilePath -> ByteString -> IO ()
B.writeFile FilePath
postupdate ByteString
postupdatecontents
       Permissions
perms <- FilePath -> IO Permissions
getPermissions FilePath
postupdate
       FilePath -> Permissions -> IO ()
setPermissions FilePath
postupdate (Permissions
perms {executable :: Bool
executable = Bool
True})
       -- Set up repo to allow push to current branch
       (status' :: ExitCode
status', err' :: FilePath
err', _) <- FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runGitCommand FilePath
repo "config" ["receive.denyCurrentBranch","ignore"]
       if ExitCode
status' ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
          then () -> IO ()
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
$ FilePath -> FileStoreError
UnknownError (FilePath -> FileStoreError) -> FilePath -> FileStoreError
forall a b. (a -> b) -> a -> b
$ "git config failed:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err'
     else FileStoreError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (FileStoreError -> IO ()) -> FileStoreError -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FileStoreError
UnknownError (FilePath -> FileStoreError) -> FilePath -> FileStoreError
forall a b. (a -> b) -> a -> b
$ "git-init failed:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err 

-- | Commit changes to a resource.  Raise 'Unchanged' exception if there were
-- no changes.
gitCommit :: FilePath -> [FilePath] -> Author -> String -> IO ()
gitCommit :: FilePath -> [FilePath] -> Author -> FilePath -> IO ()
gitCommit repo :: FilePath
repo names :: [FilePath]
names author :: Author
author logMsg :: FilePath
logMsg = do
  let env :: [(FilePath, FilePath)]
env = [("GIT_COMMITTER_NAME", Author -> FilePath
authorName Author
author),
             ("GIT_COMMITTER_EMAIL", Author -> FilePath
authorEmail Author
author)]
  (statusCommit :: ExitCode
statusCommit, errCommit :: FilePath
errCommit, _) <- [(FilePath, FilePath)]
-> FilePath
-> FilePath
-> [FilePath]
-> IO (ExitCode, FilePath, ByteString)
runGitCommandWithEnv [(FilePath, FilePath)]
env FilePath
repo "commit" ([FilePath] -> IO (ExitCode, FilePath, ByteString))
-> [FilePath] -> IO (ExitCode, FilePath, ByteString)
forall a b. (a -> b) -> a -> b
$ ["--author", Author -> FilePath
authorName Author
author FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " <" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                                    Author -> FilePath
authorEmail Author
author FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ">", "-m", FilePath
logMsg] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
names
  if ExitCode
statusCommit ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
     then () -> IO ()
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 FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
errCommit
                       then FileStoreError
Unchanged
                       else FilePath -> FileStoreError
UnknownError (FilePath -> FileStoreError) -> FilePath -> FileStoreError
forall a b. (a -> b) -> a -> b
$ "Could not git commit " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords [FilePath]
names FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
errCommit

-- | Save changes (creating file and directory if needed), add, and commit.
gitSave :: Contents a => FilePath -> FilePath -> Author -> Description -> a -> IO ()
gitSave :: FilePath -> FilePath -> Author -> FilePath -> a -> IO ()
gitSave repo :: FilePath
repo name :: FilePath
name author :: Author
author logMsg :: FilePath
logMsg contents :: a
contents = do
  FilePath -> [FilePath] -> FilePath -> IO () -> IO ()
forall b. FilePath -> [FilePath] -> FilePath -> IO b -> IO b
withSanityCheck FilePath
repo [".git"] FilePath
name (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
B.writeFile (FilePath
repo FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
encodeArg FilePath
name) (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Contents a => a -> ByteString
toByteString a
contents
  (statusAdd :: ExitCode
statusAdd, errAdd :: FilePath
errAdd, _) <- FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runGitCommand FilePath
repo "add" [FilePath
name]
  if ExitCode
statusAdd ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
     then FilePath -> [FilePath] -> Author -> FilePath -> IO ()
gitCommit FilePath
repo [FilePath
name] Author
author FilePath
logMsg
     else FileStoreError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (FileStoreError -> IO ()) -> FileStoreError -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FileStoreError
UnknownError (FilePath -> FileStoreError) -> FilePath -> FileStoreError
forall a b. (a -> b) -> a -> b
$ "Could not git add '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "'\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
errAdd

isSymlink :: FilePath -> FilePath -> Maybe RevisionId -> IO Bool
isSymlink :: FilePath -> FilePath -> Maybe FilePath -> IO Bool
isSymlink repo :: FilePath
repo name :: FilePath
name revid :: Maybe FilePath
revid = do
  (_, _, out :: ByteString
out) <- FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runGitCommand FilePath
repo "ls-tree" [FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe "HEAD" Maybe FilePath
revid, FilePath
name]
  -- see http://stackoverflow.com/questions/737673
  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ (Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take 6 (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
B.unpack ByteString
out) FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "120000"

targetContents :: Contents a => FilePath -> FilePath -> a -> IO (Maybe a)
targetContents :: FilePath -> FilePath -> a -> IO (Maybe a)
targetContents repo :: FilePath
repo linkName :: FilePath
linkName linkContent :: a
linkContent = do
  let (dirName :: FilePath
dirName, _) = FilePath -> (FilePath, FilePath)
splitFileName FilePath
linkName
      targetName :: FilePath
targetName   = FilePath
repo FilePath -> FilePath -> FilePath
</> FilePath
dirName FilePath -> FilePath -> FilePath
</> (ByteString -> FilePath
B.unpack (ByteString -> FilePath) -> ByteString -> FilePath
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
$ FilePath -> IO ByteString
B.readFile FilePath
targetName
  case Either SomeException ByteString
result of
    Left (SomeException
_ :: E.SomeException) -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    Right contents :: ByteString
contents -> Maybe a -> IO (Maybe 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 :: FilePath -> FilePath -> Maybe FilePath -> IO a
gitRetrieve repo :: FilePath
repo name :: FilePath
name revid :: Maybe FilePath
revid = do
  let objectName :: FilePath
objectName = case Maybe FilePath
revid of
                        Nothing  -> "HEAD:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name
                        Just rev :: FilePath
rev -> FilePath
rev FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name
  -- Check that the object is a file (blob), not a directory (tree)
  (_, _, output :: ByteString
output) <- FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runGitCommand FilePath
repo "cat-file" ["-t", FilePath
objectName]
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take 4 (ByteString -> FilePath
toString ByteString
output) FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= "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
  (status' :: ExitCode
status', err' :: FilePath
err', output' :: ByteString
output') <- FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runGitCommand FilePath
repo "cat-file" ["-p", FilePath
objectName]
  if ExitCode
status' ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
     then do
       Bool
isLink <- FilePath -> FilePath -> Maybe FilePath -> IO Bool
isSymlink FilePath
repo FilePath
name Maybe FilePath
revid
       if Bool
isLink
        then do
          Maybe ByteString
contents <- FilePath -> FilePath -> ByteString -> IO (Maybe ByteString)
forall a. Contents a => FilePath -> FilePath -> a -> IO (Maybe a)
targetContents FilePath
repo FilePath
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.
            Nothing -> 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 bs :: ByteString
bs -> 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 (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
$ FilePath -> FileStoreError
UnknownError (FilePath -> FileStoreError) -> FilePath -> FileStoreError
forall a b. (a -> b) -> a -> b
$ "Error in git cat-file:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err'

-- | Delete a resource from the repository.
gitDelete :: FilePath -> FilePath -> Author -> Description -> IO ()
gitDelete :: FilePath -> FilePath -> Author -> FilePath -> IO ()
gitDelete repo :: FilePath
repo name :: FilePath
name author :: Author
author logMsg :: FilePath
logMsg = FilePath -> [FilePath] -> FilePath -> IO () -> IO ()
forall b. FilePath -> [FilePath] -> FilePath -> IO b -> IO b
withSanityCheck FilePath
repo [".git"] FilePath
name (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  (statusAdd :: ExitCode
statusAdd, errRm :: FilePath
errRm, _) <- FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runGitCommand FilePath
repo "rm" [FilePath
name]
  if ExitCode
statusAdd ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
     then FilePath -> [FilePath] -> Author -> FilePath -> IO ()
gitCommit FilePath
repo [FilePath
name] Author
author FilePath
logMsg
     else FileStoreError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (FileStoreError -> IO ()) -> FileStoreError -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FileStoreError
UnknownError (FilePath -> FileStoreError) -> FilePath -> FileStoreError
forall a b. (a -> b) -> a -> b
$ "Could not git rm '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "'\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
errRm

-- | Change the name of a resource.
gitMove :: FilePath -> FilePath -> FilePath -> Author -> Description -> IO ()
gitMove :: FilePath -> FilePath -> FilePath -> Author -> FilePath -> IO ()
gitMove repo :: FilePath
repo oldName :: FilePath
oldName newName :: FilePath
newName author :: Author
author logMsg :: FilePath
logMsg = do
  FilePath
_ <- FilePath -> FilePath -> IO FilePath
gitLatestRevId FilePath
repo FilePath
oldName   -- will throw a NotFound error if oldName doesn't exist
  (statusAdd :: ExitCode
statusAdd, err :: FilePath
err, _) <- FilePath
-> [FilePath]
-> FilePath
-> IO (ExitCode, FilePath, ByteString)
-> IO (ExitCode, FilePath, ByteString)
forall b. FilePath -> [FilePath] -> FilePath -> IO b -> IO b
withSanityCheck FilePath
repo [".git"] FilePath
newName (IO (ExitCode, FilePath, ByteString)
 -> IO (ExitCode, FilePath, ByteString))
-> IO (ExitCode, FilePath, ByteString)
-> IO (ExitCode, FilePath, ByteString)
forall a b. (a -> b) -> a -> b
$ FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runGitCommand FilePath
repo "mv" [FilePath
oldName, FilePath
newName] 
  if ExitCode
statusAdd ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
     then FilePath -> [FilePath] -> Author -> FilePath -> IO ()
gitCommit FilePath
repo [FilePath
oldName, FilePath
newName] Author
author FilePath
logMsg
     else FileStoreError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (FileStoreError -> IO ()) -> FileStoreError -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FileStoreError
UnknownError (FilePath -> FileStoreError) -> FilePath -> FileStoreError
forall a b. (a -> b) -> a -> b
$ "Could not git mv " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
oldName FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
newName FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err

-- | Return revision ID for latest commit for a resource.
gitLatestRevId :: FilePath -> FilePath -> IO RevisionId
gitLatestRevId :: FilePath -> FilePath -> IO FilePath
gitLatestRevId repo :: FilePath
repo name :: FilePath
name = do
  (revListStatus :: ExitCode
revListStatus, _, output :: ByteString
output) <- FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runGitCommand FilePath
repo "rev-list" ["--max-count=1", "HEAD", "--", FilePath
name]
  -- we need to check separately to make sure the resource hasn't been removed
  -- from the repository:
  (catStatus :: ExitCode
catStatus,_, _) <- FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runGitCommand FilePath
repo "cat-file" ["-e", "HEAD:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
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 :: FilePath
result = (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` "\n\r \t") (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
toString ByteString
output
       if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
result
          then FileStoreError -> IO FilePath
forall e a. Exception e => e -> IO a
throwIO FileStoreError
NotFound
          else FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
result
     else FileStoreError -> IO FilePath
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 :: FilePath -> FilePath -> IO Revision
gitGetRevision repo :: FilePath
repo revid :: FilePath
revid = do
  (status :: ExitCode
status, _, output :: ByteString
output) <- FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runGitCommand FilePath
repo "whatchanged" ["-z","--pretty=format:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
gitLogFormat, "--max-count=1", FilePath
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 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 :: FilePath -> IO [FilePath]
gitIndex repo :: FilePath
repo = FilePath -> IO [FilePath] -> IO [FilePath]
forall a. FilePath -> IO a -> IO a
withVerifyDir FilePath
repo (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ do
  (status :: ExitCode
status, _err :: FilePath
_err, output :: ByteString
output) <- FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runGitCommand FilePath
repo "ls-tree" ["-r","-t","-z","HEAD"]
  if ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
     then [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Maybe FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([FilePath] -> Maybe FilePath
lineToFilename ([FilePath] -> Maybe FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
words) ([FilePath] -> [FilePath])
-> (ByteString -> [FilePath]) -> ByteString -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> [FilePath]
forall a. Eq a => [a] -> [a] -> [[a]]
endByOneOf ['\0'] (FilePath -> [FilePath])
-> (ByteString -> FilePath) -> ByteString -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
toString (ByteString -> [FilePath]) -> ByteString -> [FilePath]
forall a b. (a -> b) -> a -> b
$ ByteString
output
     else [FilePath] -> IO [FilePath]
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 :: [FilePath] -> Maybe FilePath
lineToFilename (_:"blob":_:rest :: [FilePath]
rest) = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords [FilePath]
rest
         lineToFilename _                 = Maybe FilePath
forall a. Maybe a
Nothing

-- | Get list of resources in one directory of the repository.
gitDirectory :: FilePath -> FilePath -> IO [Resource]
gitDirectory :: FilePath -> FilePath -> IO [Resource]
gitDirectory repo :: FilePath
repo dir :: FilePath
dir = FilePath -> IO [Resource] -> IO [Resource]
forall a. FilePath -> IO a -> IO a
withVerifyDir (FilePath
repo FilePath -> FilePath -> FilePath
</> FilePath
dir) (IO [Resource] -> IO [Resource]) -> IO [Resource] -> IO [Resource]
forall a b. (a -> b) -> a -> b
$ do
  (status :: ExitCode
status, _err :: FilePath
_err, output :: ByteString
output) <- FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runGitCommand FilePath
repo "ls-tree" ["-z","HEAD:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
dir]
  if ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
     then [Resource] -> IO [Resource]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Resource] -> IO [Resource]) -> [Resource] -> IO [Resource]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Resource) -> [FilePath] -> [Resource]
forall a b. (a -> b) -> [a] -> [b]
map ([FilePath] -> Resource
lineToResource ([FilePath] -> Resource)
-> (FilePath -> [FilePath]) -> FilePath -> Resource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
words) ([FilePath] -> [Resource]) -> [FilePath] -> [Resource]
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> [FilePath]
forall a. Eq a => [a] -> [a] -> [[a]]
endByOneOf ['\0'] (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
toString ByteString
output
     else [Resource] -> IO [Resource]
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 :: [FilePath] -> Resource
lineToResource (_:"blob":_:rest :: [FilePath]
rest) = FilePath -> Resource
FSFile (FilePath -> Resource) -> FilePath -> Resource
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords [FilePath]
rest
         lineToResource (_:"tree":_:rest :: [FilePath]
rest) = FilePath -> Resource
FSDirectory (FilePath -> Resource) -> FilePath -> Resource
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords [FilePath]
rest
         lineToResource _                 = FilePath -> Resource
forall a. HasCallStack => FilePath -> a
error "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 :: FilePath -> SearchQuery -> IO [SearchMatch]
gitSearch repo :: FilePath
repo query :: SearchQuery
query = do
  let opts :: [FilePath]
opts = ["-I","-n","--null"] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
             ["--ignore-case" | SearchQuery -> Bool
queryIgnoreCase SearchQuery
query] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
             ["--all-match" | SearchQuery -> Bool
queryMatchAll SearchQuery
query] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
             ["--word-regexp" | SearchQuery -> Bool
queryWholeWords SearchQuery
query]
  (status :: ExitCode
status, errOutput :: FilePath
errOutput, output :: ByteString
output) <- FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runGitCommand FilePath
repo "grep" ([FilePath]
opts [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
                                   (FilePath -> [FilePath]) -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\term :: FilePath
term -> ["-e", FilePath -> FilePath
escapeRegexSpecialChars FilePath
term]) (SearchQuery -> [FilePath]
queryPatterns SearchQuery
query))
  case ExitCode
status of
     ExitSuccess   -> [SearchMatch] -> IO [SearchMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return ([SearchMatch] -> IO [SearchMatch])
-> [SearchMatch] -> IO [SearchMatch]
forall a b. (a -> b) -> a -> b
$ (FilePath -> SearchMatch) -> [FilePath] -> [SearchMatch]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> SearchMatch
parseMatchLine ([FilePath] -> [SearchMatch]) -> [FilePath] -> [SearchMatch]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
lines (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
toString ByteString
output
     ExitFailure 1 -> [SearchMatch] -> IO [SearchMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return []  -- status of 1 means no matches in recent versions of git
     ExitFailure _ -> 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
$ FilePath -> FileStoreError
UnknownError (FilePath -> FileStoreError) -> FilePath -> FileStoreError
forall a b. (a -> b) -> a -> b
$ "git grep returned error status.\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
errOutput

-- Auxiliary function for searchResults
parseMatchLine :: String -> SearchMatch
parseMatchLine :: FilePath -> SearchMatch
parseMatchLine str :: FilePath
str =
  SearchMatch :: FilePath -> Integer -> FilePath -> SearchMatch
SearchMatch{ matchResourceName :: FilePath
matchResourceName = FilePath
fname
             , matchLineNumber :: Integer
matchLineNumber = if Bool -> Bool
not (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
ln)
                                    then FilePath -> Integer
forall a. Read a => FilePath -> a
read FilePath
ln
                                    else FilePath -> Integer
forall a. HasCallStack => FilePath -> a
error (FilePath -> Integer) -> FilePath -> Integer
forall a b. (a -> b) -> a -> b
$ "parseMatchLine: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
str
             , matchLine :: FilePath
matchLine = FilePath
cont}
    where (fname :: FilePath
fname,xs :: FilePath
xs) = (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\NUL') FilePath
str
          rest :: FilePath
rest = Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop 1 FilePath
xs 
          -- for some reason, NUL is used after line number instead of
          -- : when --match-all is passed to git-grep.
          (ln :: FilePath
ln,ys :: FilePath
ys) = (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ['0'..'9']) FilePath
rest
          cont :: FilePath
cont = Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop 1 FilePath
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 :: FilePath
gitLogFormat = "%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 :: FilePath -> [FilePath] -> TimeRange -> Maybe Int -> IO [Revision]
gitLog repo :: FilePath
repo names :: [FilePath]
names (TimeRange mbSince :: Maybe UTCTime
mbSince mbUntil :: Maybe UTCTime
mbUntil) mblimit :: Maybe Int
mblimit = do
  (status :: ExitCode
status, err :: FilePath
err, output :: ByteString
output) <- FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runGitCommand FilePath
repo "whatchanged" ([FilePath] -> IO (ExitCode, FilePath, ByteString))
-> [FilePath] -> IO (ExitCode, FilePath, ByteString)
forall a b. (a -> b) -> a -> b
$
                           ["-z","--pretty=format:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
gitLogFormat] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
                           (case Maybe UTCTime
mbSince of
                                 Just since :: UTCTime
since   -> ["--since='" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ UTCTime -> FilePath
forall a. Show a => a -> FilePath
show UTCTime
since FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "'"]
                                 Nothing      -> []) [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
                           (case Maybe UTCTime
mbUntil of
                                 Just til :: UTCTime
til   -> ["--until='" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ UTCTime -> FilePath
forall a. Show a => a -> FilePath
show UTCTime
til FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "'"]
                                 Nothing      -> []) [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
                           (case Maybe Int
mblimit of
                                 Just lim :: Int
lim   -> ["-n", Int -> FilePath
forall a. Show a => a -> FilePath
show Int
lim]
                                 Nothing    -> []) [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
                           ["--"] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
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
$ FilePath -> FileStoreError
UnknownError (FilePath -> FileStoreError) -> FilePath -> FileStoreError
forall a b. (a -> b) -> a -> b
$ "git whatchanged returned error status.\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
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)
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 '\1' -- occurs just before each hash

parseLogEntry :: B.ByteString -> IO Revision
parseLogEntry :: ByteString -> IO Revision
parseLogEntry entry :: ByteString
entry = do
  let (rev :: ByteString
rev : date' :: ByteString
date' : author :: ByteString
author : email :: ByteString
email : subject :: ByteString
subject : rest :: [ByteString]
rest) = Char -> ByteString -> [ByteString]
B.split '\0' ByteString
entry
  Integer
date <- case ByteString -> Maybe (Integer, ByteString)
B.readInteger ByteString
date' of
               Just (x :: Integer
x,_) -> Integer -> IO Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
x
               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
$ FilePath -> FileStoreError
UnknownError (FilePath -> FileStoreError) -> FilePath -> FileStoreError
forall a b. (a -> b) -> a -> b
$ "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 (m :: * -> *) a. Monad m => a -> m a
return Revision :: FilePath -> UTCTime -> Author -> FilePath -> [Change] -> Revision
Revision {
              revId :: FilePath
revId          = ByteString -> FilePath
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 :: FilePath -> FilePath -> Author
Author{ authorName :: FilePath
authorName = ByteString -> FilePath
toString ByteString
author
                                     , authorEmail :: FilePath
authorEmail = ByteString -> FilePath
toString ByteString
email }
            , revDescription :: FilePath
revDescription = ByteString -> FilePath
toString (ByteString -> FilePath) -> ByteString -> FilePath
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
=='\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 (x :: ByteString
x:y :: ByteString
y:zs :: [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
$ FilePath -> IO ()
forall a. FilePath -> IO a
pcErr "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. [a] -> a
last ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
B.words ByteString
x
  let file' :: FilePath
file' = ByteString -> FilePath
toString ByteString
y
  if Char
changeType Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'R'
  then [ByteString] -> IO [Change]
parseChanges ([ByteString] -> [ByteString]
forall a. [a] -> [a]
tail [ByteString]
zs) IO [Change] -> ([Change] -> IO [Change]) -> IO [Change]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
       [Change] -> IO [Change]
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]
(++) (FilePath -> Change
Deleted FilePath
file' Change -> [Change] -> [Change]
forall a. a -> [a] -> [a]
: FilePath -> Change
Added (ByteString -> FilePath
toString (ByteString -> FilePath) -> ByteString -> FilePath
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
forall a. [a] -> a
head [ByteString]
zs) Change -> [Change] -> [Change]
forall a. a -> [a] -> [a]
: [])
  else
      do Change
next <- case Char
changeType of
                   'A'  -> Change -> IO Change
forall (m :: * -> *) a. Monad m => a -> m a
return (Change -> IO Change) -> Change -> IO Change
forall a b. (a -> b) -> a -> b
$ FilePath -> Change
Added FilePath
file'
                   'M'  -> Change -> IO Change
forall (m :: * -> *) a. Monad m => a -> m a
return (Change -> IO Change) -> Change -> IO Change
forall a b. (a -> b) -> a -> b
$ FilePath -> Change
Modified FilePath
file'
                   'D'  -> Change -> IO Change
forall (m :: * -> *) a. Monad m => a -> m a
return (Change -> IO Change) -> Change -> IO Change
forall a b. (a -> b) -> a -> b
$ FilePath -> Change
Deleted FilePath
file'
                   _    -> FilePath -> IO Change
forall a. FilePath -> IO a
pcErr ("found unknown changeType '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                                  (Char -> FilePath
forall a. Show a => a -> FilePath
show Char
changeType) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                                  "' in: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (ByteString -> FilePath
forall a. Show a => a -> FilePath
show ByteString
x) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                                  " on " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (ByteString -> FilePath
forall a. Show a => a -> FilePath
show ByteString
y))
         [Change]
rest <- [ByteString] -> IO [Change]
parseChanges [ByteString]
zs
         [Change] -> IO [Change]
forall (m :: * -> *) a. Monad m => a -> m a
return (Change
nextChange -> [Change] -> [Change]
forall a. a -> [a] -> [a]
:[Change]
rest)
parseChanges [_] =
  FilePath -> IO [Change]
forall a. FilePath -> IO a
pcErr "encountered odd number of fields"
parseChanges [] = [Change] -> IO [Change]
forall (m :: * -> *) a. Monad m => a -> m a
return []

pcErr :: forall a. String -> IO a
pcErr :: FilePath -> IO a
pcErr = FileStoreError -> IO a
forall e a. Exception e => e -> IO a
throwIO (FileStoreError -> IO a)
-> (FilePath -> FileStoreError) -> FilePath -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FileStoreError
UnknownError (FilePath -> FileStoreError)
-> (FilePath -> FilePath) -> FilePath -> FileStoreError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
(++) "filestore parseChanges "