{- |
   Module      : Data.FileStore.Mercurial
   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 mercurial.
   Normally this module should not be imported: import
   "Data.FileStore" instead.
-}

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)

-- | Return a filestore implemented using the mercurial distributed revision control system
-- (<http://mercurial.selenic.com/>).
mercurialFileStore :: FilePath -> FileStore
mercurialFileStore :: String -> FileStore
mercurialFileStore String
repo = FileStore {
    initialize :: IO ()
initialize        = String -> IO ()
mercurialInit String
repo
  , save :: forall a. Contents a => String -> Author -> String -> a -> IO ()
save              = String -> String -> Author -> String -> a -> IO ()
forall a.
Contents a =>
String -> String -> Author -> String -> a -> IO ()
mercurialSave String
repo 
  , retrieve :: forall a. Contents a => String -> Maybe String -> IO a
retrieve          = String -> String -> Maybe String -> IO a
forall a. Contents a => String -> String -> Maybe String -> IO a
mercurialRetrieve String
repo
  , delete :: String -> Author -> String -> IO ()
delete            = String -> String -> Author -> String -> IO ()
mercurialDelete String
repo
  , rename :: String -> String -> Author -> String -> IO ()
rename            = String -> String -> String -> Author -> String -> IO ()
mercurialMove String
repo
  , history :: [String] -> TimeRange -> Maybe Int -> IO [Revision]
history           = String -> [String] -> TimeRange -> Maybe Int -> IO [Revision]
mercurialLog String
repo
  , latest :: String -> IO String
latest            = String -> String -> IO String
mercurialLatestRevId String
repo
  , revision :: String -> IO Revision
revision          = String -> String -> IO Revision
mercurialGetRevision String
repo
  , index :: IO [String]
index             = String -> IO [String]
mercurialIndex String
repo
  , directory :: String -> IO [Resource]
directory         = String -> String -> IO [Resource]
mercurialDirectory String
repo
  , search :: SearchQuery -> IO [SearchMatch]
search            = String -> SearchQuery -> IO [SearchMatch]
mercurialSearch String
repo 
  , idsMatch :: String -> String -> Bool
idsMatch          = (String -> String -> Bool) -> String -> String -> String -> Bool
forall a b. a -> b -> a
const String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
hashsMatch String
repo
  }

-- | Initialize a repository, creating the directory if needed.
mercurialInit :: FilePath -> IO ()
mercurialInit :: String -> IO ()
mercurialInit String
repo = do
  Bool
exists <- String -> IO Bool
doesDirectoryExist String
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
$ String -> IO () -> IO ()
forall a. String -> IO a -> IO a
withVerifyDir String
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 -> String -> IO ()
createDirectoryIfMissing Bool
True String
repo
  (ExitCode
status, String
err, ByteString
_) <- String -> String -> [String] -> IO (ExitCode, String, ByteString)
rawRunMercurialCommand String
repo String
"init" []
  if ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
     then
       -- Add a hook so that changes made remotely via hg will be reflected in
       -- the working directory.  See:
       -- http://mercurial.selenic.com/wiki/FAQ#FAQ.2BAC8-CommonProblems.Any_way_to_.27hg_push.27_and_have_an_automatic_.27hg_update.27_on_the_remote_server.3F
       String -> ByteString -> IO ()
B.writeFile (String
repo String -> String -> String
</> String
".hg" String -> String -> String
</> String
"hgrc") (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
         String -> ByteString
forall a. Contents a => a -> ByteString
toByteString String
"[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
$ String -> FileStoreError
UnknownError (String -> FileStoreError) -> String -> FileStoreError
forall a b. (a -> b) -> a -> b
$ String
"mercurial init failed:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err 

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

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

-- | Retrieve contents from resource.
--   Mercurial does not track directories so catting from a directory returns all files
mercurialRetrieve :: Contents a
            => FilePath
            -> FilePath
            -> Maybe RevisionId    -- ^ @Just@ revision ID, or @Nothing@ for latest
            -> IO a
mercurialRetrieve :: forall a. Contents a => String -> String -> Maybe String -> IO a
mercurialRetrieve String
repo String
name Maybe String
revid = do
  let revname :: String
revname = case Maybe String
revid of
                        Maybe String
Nothing  -> String
"tip"
                        Just String
rev -> String
rev
  (ExitCode
statcheck, String
_, ByteString
_) <- String -> String -> [String] -> IO (ExitCode, String, ByteString)
runMercurialCommand String
repo String
"locate" [String
"-r", String
revname, String
"-X", String
"glob:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
</> String
"*", String
"path:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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
  (ExitCode
status, String
err, ByteString
output) <- String -> String -> [String] -> IO (ExitCode, String, ByteString)
runMercurialCommand String
repo String
"cat" [String
"-r", String
revname, String
"-X", String
"glob:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
</> String
"*", String
"path:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name]
  if ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
     then 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
$ String -> FileStoreError
UnknownError (String -> FileStoreError) -> String -> FileStoreError
forall a b. (a -> b) -> a -> b
$ String
"Error in mercurial cat:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err

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

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

-- | Return revision ID for latest commit for a resource.
mercurialLatestRevId :: FilePath -> FilePath -> IO RevisionId
mercurialLatestRevId :: String -> String -> IO String
mercurialLatestRevId String
repo String
name = do
  (ExitCode
status, String
_, ByteString
output) <- String -> String -> [String] -> IO (ExitCode, String, ByteString)
runMercurialCommand String
repo String
"log" [String
"--template", String
"{node}\\n{file_dels}\\n", String
"--limit", String
"1", String
"--removed", String
"path:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name]
  if ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
     then do
       let result :: [String]
result = String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ ByteString -> String
toString ByteString
output
       if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
result Bool -> Bool -> Bool
|| String
name String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
1 [String]
result
          then FileStoreError -> IO String
forall e a. Exception e => e -> IO a
throwIO FileStoreError
NotFound
          else String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. HasCallStack => [a] -> a
head [String]
result
     else FileStoreError -> IO String
forall e a. Exception e => e -> IO a
throwIO FileStoreError
NotFound

-- | Get revision information for a particular revision ID, or latest revision.
mercurialGetRevision :: FilePath -> RevisionId -> IO Revision
mercurialGetRevision :: String -> String -> IO Revision
mercurialGetRevision String
repo String
revid = do
  (ExitCode
status, String
_, ByteString
output) <- String -> String -> [String] -> IO (ExitCode, String, ByteString)
runMercurialCommand String
repo String
"log" [String
"--template", String
mercurialLogFormat, String
"--limit", String
"1", String
"-r", String
revid]
  if ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
     then case Parsec String () [Revision]
-> String -> String -> Either ParseError [Revision]
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
P.parse Parsec String () [Revision]
parseMercurialLog String
"" (ByteString -> String
toString ByteString
output) of
                 Left 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
$ String -> FileStoreError
UnknownError (String -> FileStoreError) -> String -> FileStoreError
forall a b. (a -> b) -> a -> b
$ String
"error parsing mercurial log: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseError -> String
forall a. Show a => a -> String
show ParseError
err'
                 Right [Revision
r]   -> Revision -> IO Revision
forall a. a -> IO a
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 [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
$ String -> FileStoreError
UnknownError (String -> FileStoreError) -> String -> FileStoreError
forall a b. (a -> b) -> a -> b
$ String
"mercurial log returned more than one result: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Revision] -> String
forall a. Show a => a -> String
show [Revision]
xs
     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.
mercurialIndex :: FilePath ->IO [FilePath]
mercurialIndex :: String -> IO [String]
mercurialIndex String
repo = String -> IO [String] -> IO [String]
forall a. String -> IO a -> IO a
withVerifyDir String
repo (IO [String] -> IO [String]) -> IO [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ do
  (ExitCode
status, String
_err, ByteString
output) <- String -> String -> [String] -> IO (ExitCode, String, ByteString)
runMercurialCommand String
repo String
"manifest" [String
"-r", String
"tip"]
  if ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
     then [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ ByteString -> String
toString (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString
output
     else [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [] -- if error, will return empty list

-- | Get list of resources in one directory of the repository.  Mercurial does not store or track directories,
--   so the locate command does not return any directories.  Instead we first list all the files, then list all
--   files in subdirectories of the given directory and use that to contruct the list of directories.
mercurialDirectory :: FilePath -> FilePath -> IO [Resource]
mercurialDirectory :: String -> String -> IO [Resource]
mercurialDirectory String
repo String
dir = String -> IO [Resource] -> IO [Resource]
forall a. String -> IO a -> IO a
withVerifyDir (String
repo String -> String -> String
</> String
dir) (IO [Resource] -> IO [Resource]) -> IO [Resource] -> IO [Resource]
forall a b. (a -> b) -> a -> b
$ do
  (ExitCode
status, String
_, ByteString
output) <- String -> String -> [String] -> IO (ExitCode, String, ByteString)
runMercurialCommand String
repo String
"locate" [String
"-r", String
"tip", String
"glob:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String
dir String -> String -> String
</> String
"*")]
  let files :: [Resource]
files = if ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
                then (String -> Resource) -> [String] -> [Resource]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Resource
FSFile (String -> Resource) -> (String -> String) -> String -> Resource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeFileName (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
forall {t :: * -> *} {a} {a}. Foldable t => t a -> [a] -> [a]
removePrefix String
dir) ([String] -> [Resource]) -> [String] -> [Resource]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ ByteString -> String
toString ByteString
output
                else []
  (ExitCode
status2, String
_, ByteString
output2) <- String -> String -> [String] -> IO (ExitCode, String, ByteString)
runMercurialCommand String
repo String
"locate" [String
"-r", String
"tip", String
"glob:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String
dir String -> String -> String
</> String
"*" String -> String -> String
</> String
"*")]
  let dirs :: [Resource]
dirs = if ExitCode
status2 ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
                then (String -> Resource) -> [String] -> [Resource]
forall a b. (a -> b) -> [a] -> [b]
map String -> Resource
FSDirectory ([String] -> [Resource]) -> [String] -> [Resource]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> String
forall a. HasCallStack => [a] -> a
head ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitDirectories (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
forall {t :: * -> *} {a} {a}. Foldable t => t a -> [a] -> [a]
removePrefix String
dir) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ ByteString -> String
toString ByteString
output2
                else []
  [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
$ [Resource]
files [Resource] -> [Resource] -> [Resource]
forall a. [a] -> [a] -> [a]
++ [Resource]
dirs
 where removePrefix :: t a -> [a] -> [a]
removePrefix 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 a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
d

-- | Use generic grep to search
mercurialSearch :: FilePath -> SearchQuery -> IO [SearchMatch]
mercurialSearch :: String -> SearchQuery -> IO [SearchMatch]
mercurialSearch = (String -> IO [String])
-> String -> SearchQuery -> IO [SearchMatch]
grepSearchRepo String -> IO [String]
mercurialIndex

{- The following code goes not work because of a bug in mercurial.  If the final line of a file
does not end with a newline and you search for a word in the final line, hg does not display
the line from the file correctly.  In the results, the last character line is not printed.
mercurialSearch repo query = do
  let patterns = map escapeRegexSpecialChars $ queryPatterns query
      pattern = if queryWholeWords query
                  then "(\\b" ++ foldr1 (\a b -> a ++ "\\b|\\b" ++ b) patterns ++ "\\b)"
                  else "(" ++ foldr1 (\a b -> a ++ "|" ++ b) patterns ++ ")"
  (status, errOutput, output) <- runMercurialCommand repo "grep" (["--ignore-case" | queryIgnoreCase query] ++ ["-n", "-0", pattern])
  case status of
     ExitSuccess   -> do
                       putStrLn $ show output
                       case P.parse parseMercurialSearch "" (toString output) of
                        Left err'    -> throwIO $ UnknownError $ "Error parsing mercurial search results.\n" ++ show err'
                        Right parsed -> return parsed
     ExitFailure 1 -> return []  -- status of 1 means no matches
     ExitFailure _ -> throwIO $ UnknownError $ "mercurial grep returned error status.\n" ++ errOutput
-}

mercurialLogFormat :: String
mercurialLogFormat :: String
mercurialLogFormat = String
"{node}\\n{date|rfc822date}\\n{author|person}\\n{author|email}\\n{desc}\\x00{file_adds}\\x00{file_mods}\\x00{file_dels}\\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.
mercurialLog :: FilePath -> [FilePath] -> TimeRange -> Maybe Int -> IO [Revision]
mercurialLog :: String -> [String] -> TimeRange -> Maybe Int -> IO [Revision]
mercurialLog String
repo [String]
names (TimeRange Maybe UTCTime
mbSince Maybe UTCTime
mbUntil) Maybe Int
mblimit = do
  (ExitCode
status, String
err, ByteString
output) <- String -> String -> [String] -> IO (ExitCode, String, ByteString)
runMercurialCommand String
repo String
"log" ([String] -> IO (ExitCode, String, ByteString))
-> [String] -> IO (ExitCode, String, ByteString)
forall a b. (a -> b) -> a -> b
$ [String
"--template", String
mercurialLogFormat] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Maybe UTCTime -> Maybe UTCTime -> [String]
revOpts Maybe UTCTime
mbSince Maybe UTCTime
mbUntil [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
limit [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
names
  if ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
     then case Parsec String () [Revision]
-> String -> String -> Either ParseError [Revision]
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
P.parse Parsec String () [Revision]
parseMercurialLog String
"" (ByteString -> String
toString ByteString
output) of
                Left 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
$ String -> FileStoreError
UnknownError (String -> FileStoreError) -> String -> FileStoreError
forall a b. (a -> b) -> a -> b
$ String
"Error parsing mercurial log.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseError -> String
forall a. Show a => a -> String
show ParseError
err'
                Right [Revision]
parsed -> [Revision] -> IO [Revision]
forall a. a -> IO a
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
$ String -> FileStoreError
UnknownError (String -> FileStoreError) -> String -> FileStoreError
forall a b. (a -> b) -> a -> b
$ String
"mercurial log returned error status.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
 where revOpts :: Maybe UTCTime -> Maybe UTCTime -> [String]
revOpts Maybe UTCTime
Nothing Maybe UTCTime
Nothing   = []
       revOpts Maybe UTCTime
Nothing (Just UTCTime
u)  = [String
"-d", String
"<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UTCTime -> String
showTime UTCTime
u]
       revOpts (Just UTCTime
s) Maybe UTCTime
Nothing  = [String
"-d", String
">" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UTCTime -> String
showTime UTCTime
s]
       revOpts (Just UTCTime
s) (Just UTCTime
u) = [String
"-d", UTCTime -> String
showTime UTCTime
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ UTCTime -> String
showTime UTCTime
u]
       showTime :: UTCTime -> String
showTime = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%F %X"
       limit :: [String]
limit = case Maybe Int
mblimit of
                    Just Int
lim  -> [String
"--limit", Int -> String
forall a. Show a => a -> String
show Int
lim]
                    Maybe Int
Nothing   -> []


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

parseMercurialLog :: P.Parser [Revision]
parseMercurialLog :: Parsec String () [Revision]
parseMercurialLog = ParsecT String () Identity Revision
-> ParsecT String () Identity () -> Parsec String () [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 String () Identity Revision
mercurialLogEntry ParsecT String () 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 :: forall st. GenParser Char st String
wholeLine = ParsecT String st Identity Char
-> ParsecT String st Identity Char
-> ParsecT String st Identity String
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 String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.anyChar ParsecT String 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 :: forall st. GenParser Char st String
nonblankLine = ParsecT String st Identity Char -> ParsecT String 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 String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.newline ParsecT String st Identity ()
-> ParsecT String st Identity String
-> ParsecT String st Identity String
forall a b.
ParsecT String st Identity a
-> ParsecT String st Identity b -> ParsecT String st Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String st Identity String
forall st. GenParser Char st String
wholeLine

nullStr :: P.GenParser Char st String
nullStr :: forall st. GenParser Char st String
nullStr = ParsecT String st Identity Char
-> ParsecT String st Identity Char
-> ParsecT String st Identity String
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 String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.anyChar ((Char -> Bool) -> ParsecT String 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
==Char
'\x00'))

mercurialLogEntry :: P.Parser Revision
mercurialLogEntry :: ParsecT String () Identity Revision
mercurialLogEntry = do
  String
rev <- GenParser Char () String
forall st. GenParser Char st String
nonblankLine
  String
date <- GenParser Char () String
forall st. GenParser Char st String
nonblankLine
  String
author <- GenParser Char () String
forall st. GenParser Char st String
nonblankLine
  String
email <- GenParser Char () String
forall st. GenParser Char st String
wholeLine
  String
subject <- GenParser Char () String
forall st. GenParser Char st String
nullStr
  ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
P.spaces
  [Change]
file_add <- (String -> [Change])
-> GenParser Char () String -> ParsecT String () Identity [Change]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((String -> Change) -> [String] -> [Change]
forall a b. (a -> b) -> [a] -> [b]
map String -> Change
Added ([String] -> [Change])
-> (String -> [String]) -> String -> [Change]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) (GenParser Char () String -> ParsecT String () Identity [Change])
-> GenParser Char () String -> ParsecT String () Identity [Change]
forall a b. (a -> b) -> a -> b
$ GenParser Char () String
forall st. GenParser Char st String
nullStr
  ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
P.spaces
  [Change]
file_mod <- (String -> [Change])
-> GenParser Char () String -> ParsecT String () Identity [Change]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((String -> Change) -> [String] -> [Change]
forall a b. (a -> b) -> [a] -> [b]
map String -> Change
Modified ([String] -> [Change])
-> (String -> [String]) -> String -> [Change]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) (GenParser Char () String -> ParsecT String () Identity [Change])
-> GenParser Char () String -> ParsecT String () Identity [Change]
forall a b. (a -> b) -> a -> b
$ GenParser Char () String
forall st. GenParser Char st String
nullStr
  ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
P.spaces
  [Change]
file_del <- (String -> [Change])
-> GenParser Char () String -> ParsecT String () Identity [Change]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((String -> Change) -> [String] -> [Change]
forall a b. (a -> b) -> [a] -> [b]
map String -> Change
Deleted ([String] -> [Change])
-> (String -> [String]) -> String -> [Change]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) (GenParser Char () String -> ParsecT String () Identity [Change])
-> GenParser Char () String -> ParsecT String () Identity [Change]
forall a b. (a -> b) -> a -> b
$ GenParser Char () String
forall st. GenParser Char st String
nullStr
  ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
P.spaces
  let stripTrailingNewlines :: String -> String
stripTrailingNewlines = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n') (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse
  Revision -> ParsecT String () Identity Revision
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Revision {
              revId :: String
revId          = String
rev
            , revDateTime :: UTCTime
revDateTime    = Maybe UTCTime -> UTCTime
forall a. HasCallStack => Maybe a -> a
fromJust (Bool -> TimeLocale -> String -> String -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%a, %d %b %Y %H:%M:%S %z" String
date :: Maybe UTCTime)
            , revAuthor :: Author
revAuthor      = Author { authorName :: String
authorName = String
author, authorEmail :: String
authorEmail = String
email }
            , revDescription :: String
revDescription = String -> String
stripTrailingNewlines String
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 
            }

{-
parseMercurialSearch :: P.Parser [SearchMatch]
parseMercurialSearch = P.manyTill mercurialSearchFormat P.eof

mercurialSearchFormat :: P.Parser SearchMatch
mercurialSearchFormat = do
  fname <- nullStr
  nullStr -- revision number
  lineNum <- nullStr
  txt <- nullStr
  return SearchMatch {
             matchResourceName = fname
           , matchLineNumber = read lineNum
           , matchLine = txt
           }
-}