module Data.FileStore.Mercurial
( mercurialFileStore
)
where
import Data.FileStore.Types
import Data.Maybe (fromJust)
import System.Exit
import Data.FileStore.Utils (withSanityCheck, hashsMatch, withVerifyDir, grepSearchRepo, encodeArg)
import Data.FileStore.MercurialCommandServer
import Data.ByteString.Lazy.UTF8 (toString)
import qualified Data.ByteString.Lazy as B
import qualified Text.ParserCombinators.Parsec as P
import Data.List (nub)
import Control.Monad (when, liftM, unless)
import System.FilePath ((</>), splitDirectories, takeFileName)
import System.Directory (createDirectoryIfMissing, doesDirectoryExist)
import Control.Exception (throwIO)
import Data.FileStore.Compat.Locale (defaultTimeLocale)
import Data.Time (parseTimeM, formatTime)
mercurialFileStore :: FilePath -> FileStore
mercurialFileStore :: FilePath -> FileStore
mercurialFileStore 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 ()
mercurialInit 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 ()
mercurialSave 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
mercurialRetrieve FilePath
repo
, delete :: FilePath -> Author -> FilePath -> IO ()
delete = FilePath -> FilePath -> Author -> FilePath -> IO ()
mercurialDelete FilePath
repo
, rename :: FilePath -> FilePath -> Author -> FilePath -> IO ()
rename = FilePath -> FilePath -> FilePath -> Author -> FilePath -> IO ()
mercurialMove FilePath
repo
, history :: [FilePath] -> TimeRange -> Maybe Int -> IO [Revision]
history = FilePath -> [FilePath] -> TimeRange -> Maybe Int -> IO [Revision]
mercurialLog FilePath
repo
, latest :: FilePath -> IO FilePath
latest = FilePath -> FilePath -> IO FilePath
mercurialLatestRevId FilePath
repo
, revision :: FilePath -> IO Revision
revision = FilePath -> FilePath -> IO Revision
mercurialGetRevision FilePath
repo
, index :: IO [FilePath]
index = FilePath -> IO [FilePath]
mercurialIndex FilePath
repo
, directory :: FilePath -> IO [Resource]
directory = FilePath -> FilePath -> IO [Resource]
mercurialDirectory FilePath
repo
, search :: SearchQuery -> IO [SearchMatch]
search = FilePath -> SearchQuery -> IO [SearchMatch]
mercurialSearch 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
}
mercurialInit :: FilePath -> IO ()
mercurialInit :: FilePath -> IO ()
mercurialInit 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)
rawRunMercurialCommand FilePath
repo "init" []
if ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then
FilePath -> ByteString -> IO ()
B.writeFile (FilePath
repo FilePath -> FilePath -> FilePath
</> ".hg" FilePath -> FilePath -> FilePath
</> "hgrc") (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
FilePath -> ByteString
forall a. Contents a => a -> ByteString
toByteString "[hooks]\nchangegroup = hg update >&2\n"
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
$ "mercurial init failed:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err
mercurialCommit :: FilePath -> [FilePath] -> Author -> String -> IO ()
mercurialCommit :: FilePath -> [FilePath] -> Author -> FilePath -> IO ()
mercurialCommit repo :: FilePath
repo names :: [FilePath]
names author :: Author
author logMsg :: FilePath
logMsg = do
let email :: FilePath
email = Author -> FilePath
authorEmail Author
author
email' :: FilePath
email' = if Bool -> Bool
not (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
email)
then " <" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
email FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ">"
else ""
(statusCommit :: ExitCode
statusCommit, errCommit :: FilePath
errCommit, _) <- FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runMercurialCommand FilePath
repo "commit" ([FilePath] -> IO (ExitCode, FilePath, ByteString))
-> [FilePath] -> IO (ExitCode, FilePath, ByteString)
forall a b. (a -> b) -> a -> b
$ ["--user", Author -> FilePath
authorName Author
author FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
email', "-m", FilePath
logMsg] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
names
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
statusCommit ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
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 hg 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
mercurialSave :: Contents a => FilePath -> FilePath -> Author -> Description -> a -> IO ()
mercurialSave :: FilePath -> FilePath -> Author -> FilePath -> a -> IO ()
mercurialSave 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 [".hg"] 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)
runMercurialCommand FilePath
repo "add" ["path:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name]
if ExitCode
statusAdd ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then FilePath -> [FilePath] -> Author -> FilePath -> IO ()
mercurialCommit 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 hg 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
mercurialRetrieve :: Contents a
=> FilePath
-> FilePath
-> Maybe RevisionId
-> IO a
mercurialRetrieve :: FilePath -> FilePath -> Maybe FilePath -> IO a
mercurialRetrieve repo :: FilePath
repo name :: FilePath
name revid :: Maybe FilePath
revid = do
let revname :: FilePath
revname = case Maybe FilePath
revid of
Nothing -> "tip"
Just rev :: FilePath
rev -> FilePath
rev
(statcheck :: ExitCode
statcheck, _, _) <- FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runMercurialCommand FilePath
repo "locate" ["-r", FilePath
revname, "-X", "glob:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name FilePath -> FilePath -> FilePath
</> "*", "path:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name]
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
statcheck ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (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)
runMercurialCommand FilePath
repo "cat" ["-r", FilePath
revname, "-X", "glob:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name FilePath -> FilePath -> FilePath
</> "*", "path:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name]
if ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then 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 mercurial cat:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err
mercurialDelete :: FilePath -> FilePath -> Author -> Description -> IO ()
mercurialDelete :: FilePath -> FilePath -> Author -> FilePath -> IO ()
mercurialDelete 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 [".hg"] 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)
runMercurialCommand FilePath
repo "remove" ["path:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name]
if ExitCode
statusAdd ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then FilePath -> [FilePath] -> Author -> FilePath -> IO ()
mercurialCommit 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 hg 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
mercurialMove :: FilePath -> FilePath -> FilePath -> Author -> Description -> IO ()
mercurialMove :: FilePath -> FilePath -> FilePath -> Author -> FilePath -> IO ()
mercurialMove repo :: FilePath
repo oldName :: FilePath
oldName newName :: FilePath
newName author :: Author
author logMsg :: FilePath
logMsg = do
FilePath -> FilePath -> IO FilePath
mercurialLatestRevId FilePath
repo FilePath
oldName
(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 [".hg"] 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)
runMercurialCommand 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 ()
mercurialCommit 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 hg 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
mercurialLatestRevId :: FilePath -> FilePath -> IO RevisionId
mercurialLatestRevId :: FilePath -> FilePath -> IO FilePath
mercurialLatestRevId repo :: FilePath
repo name :: FilePath
name = do
(status :: ExitCode
status, _, output :: ByteString
output) <- FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runMercurialCommand FilePath
repo "log" ["--template", "{node}\\n{file_dels}\\n", "--limit", "1", "--removed", "path:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name]
if ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then do
let result :: [FilePath]
result = FilePath -> [FilePath]
lines (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 Bool -> Bool -> Bool
|| FilePath
name FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
drop 1 [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 -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall a. [a] -> a
head [FilePath]
result
else FileStoreError -> IO FilePath
forall e a. Exception e => e -> IO a
throwIO FileStoreError
NotFound
mercurialGetRevision :: FilePath -> RevisionId -> IO Revision
mercurialGetRevision :: FilePath -> FilePath -> IO Revision
mercurialGetRevision repo :: FilePath
repo revid :: FilePath
revid = do
(status :: ExitCode
status, _, output :: ByteString
output) <- FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runMercurialCommand FilePath
repo "log" ["--template", FilePath
mercurialLogFormat, "--limit", "1", "-r", FilePath
revid]
if ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then case Parsec FilePath () [Revision]
-> FilePath -> FilePath -> Either ParseError [Revision]
forall s t a.
Stream s Identity t =>
Parsec s () a -> FilePath -> s -> Either ParseError a
P.parse Parsec FilePath () [Revision]
parseMercurialLog "" (ByteString -> FilePath
toString ByteString
output) of
Left err' :: ParseError
err' -> 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
$ "error parsing mercurial log: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ParseError -> FilePath
forall a. Show a => a -> FilePath
show ParseError
err'
Right [r :: Revision
r] -> Revision -> IO Revision
forall (m :: * -> *) a. Monad m => a -> m a
return Revision
r
Right [] -> FileStoreError -> IO Revision
forall e a. Exception e => e -> IO a
throwIO FileStoreError
NotFound
Right xs :: [Revision]
xs -> 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
$ "mercurial log returned more than one result: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [Revision] -> FilePath
forall a. Show a => a -> FilePath
show [Revision]
xs
else FileStoreError -> IO Revision
forall e a. Exception e => e -> IO a
throwIO FileStoreError
NotFound
mercurialIndex :: FilePath ->IO [FilePath]
mercurialIndex :: FilePath -> IO [FilePath]
mercurialIndex 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)
runMercurialCommand FilePath
repo "manifest" ["-r", "tip"]
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 -> [FilePath]
lines (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ 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 []
mercurialDirectory :: FilePath -> FilePath -> IO [Resource]
mercurialDirectory :: FilePath -> FilePath -> IO [Resource]
mercurialDirectory 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, _, output :: ByteString
output) <- FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runMercurialCommand FilePath
repo "locate" ["-r", "tip", "glob:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (FilePath
dir FilePath -> FilePath -> FilePath
</> "*")]
let files :: [Resource]
files = if ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then (FilePath -> Resource) -> [FilePath] -> [Resource]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Resource
FSFile (FilePath -> Resource)
-> (FilePath -> FilePath) -> FilePath -> Resource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeFileName (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
forall (t :: * -> *) a a. Foldable t => t a -> [a] -> [a]
removePrefix FilePath
dir) ([FilePath] -> [Resource]) -> [FilePath] -> [Resource]
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
else []
(status2 :: ExitCode
status2, _, output2 :: ByteString
output2) <- FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runMercurialCommand FilePath
repo "locate" ["-r", "tip", "glob:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (FilePath
dir FilePath -> FilePath -> FilePath
</> "*" FilePath -> FilePath -> FilePath
</> "*")]
let dirs :: [Resource]
dirs = if ExitCode
status2 ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then (FilePath -> Resource) -> [FilePath] -> [Resource]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Resource
FSDirectory ([FilePath] -> [Resource]) -> [FilePath] -> [Resource]
forall a b. (a -> b) -> a -> b
$ [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ([FilePath] -> FilePath
forall a. [a] -> a
head ([FilePath] -> FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
splitDirectories (FilePath -> [FilePath])
-> (FilePath -> FilePath) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
forall (t :: * -> *) a a. Foldable t => t a -> [a] -> [a]
removePrefix FilePath
dir) ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
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
output2
else []
[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
$ [Resource]
files [Resource] -> [Resource] -> [Resource]
forall a. [a] -> [a] -> [a]
++ [Resource]
dirs
where removePrefix :: t a -> [a] -> [a]
removePrefix d :: t a
d = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Int -> [a] -> [a]) -> Int -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
d
mercurialSearch :: FilePath -> SearchQuery -> IO [SearchMatch]
mercurialSearch :: FilePath -> SearchQuery -> IO [SearchMatch]
mercurialSearch = (FilePath -> IO [FilePath])
-> FilePath -> SearchQuery -> IO [SearchMatch]
grepSearchRepo FilePath -> IO [FilePath]
mercurialIndex
mercurialLogFormat :: String
mercurialLogFormat :: FilePath
mercurialLogFormat = "{node}\\n{date|rfc822date}\\n{author|person}\\n{author|email}\\n{desc}\\x00{file_adds}\\x00{file_mods}\\x00{file_dels}\\x00"
mercurialLog :: FilePath -> [FilePath] -> TimeRange -> Maybe Int -> IO [Revision]
mercurialLog :: FilePath -> [FilePath] -> TimeRange -> Maybe Int -> IO [Revision]
mercurialLog 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)
runMercurialCommand FilePath
repo "log" ([FilePath] -> IO (ExitCode, FilePath, ByteString))
-> [FilePath] -> IO (ExitCode, FilePath, ByteString)
forall a b. (a -> b) -> a -> b
$ ["--template", FilePath
mercurialLogFormat] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ Maybe UTCTime -> Maybe UTCTime -> [FilePath]
revOpts Maybe UTCTime
mbSince Maybe UTCTime
mbUntil [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
limit [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 case Parsec FilePath () [Revision]
-> FilePath -> FilePath -> Either ParseError [Revision]
forall s t a.
Stream s Identity t =>
Parsec s () a -> FilePath -> s -> Either ParseError a
P.parse Parsec FilePath () [Revision]
parseMercurialLog "" (ByteString -> FilePath
toString ByteString
output) of
Left err' :: ParseError
err' -> 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
$ "Error parsing mercurial log.\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ParseError -> FilePath
forall a. Show a => a -> FilePath
show ParseError
err'
Right parsed :: [Revision]
parsed -> [Revision] -> IO [Revision]
forall (m :: * -> *) a. Monad m => a -> m a
return [Revision]
parsed
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
$ "mercurial log returned error status.\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err
where revOpts :: Maybe UTCTime -> Maybe UTCTime -> [FilePath]
revOpts Nothing Nothing = []
revOpts Nothing (Just u :: UTCTime
u) = ["-d", "<" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ UTCTime -> FilePath
showTime UTCTime
u]
revOpts (Just s :: UTCTime
s) Nothing = ["-d", ">" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ UTCTime -> FilePath
showTime UTCTime
s]
revOpts (Just s :: UTCTime
s) (Just u :: UTCTime
u) = ["-d", UTCTime -> FilePath
showTime UTCTime
s FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " to " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ UTCTime -> FilePath
showTime UTCTime
u]
showTime :: UTCTime -> FilePath
showTime = TimeLocale -> FilePath -> UTCTime -> FilePath
forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale "%F %X"
limit :: [FilePath]
limit = case Maybe Int
mblimit of
Just lim :: Int
lim -> ["--limit", Int -> FilePath
forall a. Show a => a -> FilePath
show Int
lim]
Nothing -> []
parseMercurialLog :: P.Parser [Revision]
parseMercurialLog :: Parsec FilePath () [Revision]
parseMercurialLog = ParsecT FilePath () Identity Revision
-> ParsecT FilePath () Identity () -> Parsec FilePath () [Revision]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
P.manyTill ParsecT FilePath () Identity Revision
mercurialLogEntry ParsecT FilePath () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
P.eof
wholeLine :: P.GenParser Char st String
wholeLine :: GenParser Char st FilePath
wholeLine = ParsecT FilePath st Identity Char
-> ParsecT FilePath st Identity Char -> GenParser Char st FilePath
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
P.manyTill ParsecT FilePath st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.anyChar ParsecT FilePath st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.newline
nonblankLine :: P.GenParser Char st String
nonblankLine :: GenParser Char st FilePath
nonblankLine = ParsecT FilePath st Identity Char
-> ParsecT FilePath st Identity ()
forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
P.notFollowedBy ParsecT FilePath st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.newline ParsecT FilePath st Identity ()
-> GenParser Char st FilePath -> GenParser Char st FilePath
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GenParser Char st FilePath
forall st. GenParser Char st FilePath
wholeLine
nullStr :: P.GenParser Char st String
nullStr :: GenParser Char st FilePath
nullStr = ParsecT FilePath st Identity Char
-> ParsecT FilePath st Identity Char -> GenParser Char st FilePath
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
P.manyTill ParsecT FilePath st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.anyChar ((Char -> Bool) -> ParsecT FilePath st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
P.satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='\x00'))
mercurialLogEntry :: P.Parser Revision
mercurialLogEntry :: ParsecT FilePath () Identity Revision
mercurialLogEntry = do
FilePath
rev <- GenParser Char () FilePath
forall st. GenParser Char st FilePath
nonblankLine
FilePath
date <- GenParser Char () FilePath
forall st. GenParser Char st FilePath
nonblankLine
FilePath
author <- GenParser Char () FilePath
forall st. GenParser Char st FilePath
nonblankLine
FilePath
email <- GenParser Char () FilePath
forall st. GenParser Char st FilePath
wholeLine
FilePath
subject <- GenParser Char () FilePath
forall st. GenParser Char st FilePath
nullStr
ParsecT FilePath () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
P.spaces
[Change]
file_add <- (FilePath -> [Change])
-> GenParser Char () FilePath
-> ParsecT FilePath () Identity [Change]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((FilePath -> Change) -> [FilePath] -> [Change]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Change
Added ([FilePath] -> [Change])
-> (FilePath -> [FilePath]) -> FilePath -> [Change]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines) (GenParser Char () FilePath
-> ParsecT FilePath () Identity [Change])
-> GenParser Char () FilePath
-> ParsecT FilePath () Identity [Change]
forall a b. (a -> b) -> a -> b
$ GenParser Char () FilePath
forall st. GenParser Char st FilePath
nullStr
ParsecT FilePath () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
P.spaces
[Change]
file_mod <- (FilePath -> [Change])
-> GenParser Char () FilePath
-> ParsecT FilePath () Identity [Change]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((FilePath -> Change) -> [FilePath] -> [Change]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Change
Modified ([FilePath] -> [Change])
-> (FilePath -> [FilePath]) -> FilePath -> [Change]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines) (GenParser Char () FilePath
-> ParsecT FilePath () Identity [Change])
-> GenParser Char () FilePath
-> ParsecT FilePath () Identity [Change]
forall a b. (a -> b) -> a -> b
$ GenParser Char () FilePath
forall st. GenParser Char st FilePath
nullStr
ParsecT FilePath () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
P.spaces
[Change]
file_del <- (FilePath -> [Change])
-> GenParser Char () FilePath
-> ParsecT FilePath () Identity [Change]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((FilePath -> Change) -> [FilePath] -> [Change]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Change
Deleted ([FilePath] -> [Change])
-> (FilePath -> [FilePath]) -> FilePath -> [Change]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines) (GenParser Char () FilePath
-> ParsecT FilePath () Identity [Change])
-> GenParser Char () FilePath
-> ParsecT FilePath () Identity [Change]
forall a b. (a -> b) -> a -> b
$ GenParser Char () FilePath
forall st. GenParser Char st FilePath
nullStr
ParsecT FilePath () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
P.spaces
let stripTrailingNewlines :: FilePath -> FilePath
stripTrailingNewlines = FilePath -> FilePath
forall a. [a] -> [a]
reverse (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='\n') (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
forall a. [a] -> [a]
reverse
Revision -> ParsecT FilePath () Identity Revision
forall (m :: * -> *) a. Monad m => a -> m a
return Revision :: FilePath -> UTCTime -> Author -> FilePath -> [Change] -> Revision
Revision {
revId :: FilePath
revId = FilePath
rev
, revDateTime :: UTCTime
revDateTime = Maybe UTCTime -> UTCTime
forall a. HasCallStack => Maybe a -> a
fromJust (Bool -> TimeLocale -> FilePath -> FilePath -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> FilePath -> FilePath -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" FilePath
date :: Maybe UTCTime)
, revAuthor :: Author
revAuthor = Author :: FilePath -> FilePath -> Author
Author { authorName :: FilePath
authorName = FilePath
author, authorEmail :: FilePath
authorEmail = FilePath
email }
, revDescription :: FilePath
revDescription = FilePath -> FilePath
stripTrailingNewlines FilePath
subject
, revChanges :: [Change]
revChanges = [Change]
file_add [Change] -> [Change] -> [Change]
forall a. [a] -> [a] -> [a]
++ [Change]
file_mod [Change] -> [Change] -> [Change]
forall a. [a] -> [a] -> [a]
++ [Change]
file_del
}