    {- |
       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 (parseTime, formatTime)

    -- | Return a filestore implemented using the mercurial distributed revision control system
    -- (<http://mercurial.selenic.com/>).
    mercurialFileStore :: FilePath -> FileStore
    mercurialFileStore repo = FileStore {
        initialize        = mercurialInit repo
      , save              = mercurialSave repo
      , retrieve          = mercurialRetrieve repo
      , delete            = mercurialDelete repo
      , rename            = mercurialMove repo
      , history           = mercurialLog repo
      , latest            = mercurialLatestRevId repo
      , revision          = mercurialGetRevision repo
      , index             = mercurialIndex repo
      , directory         = mercurialDirectory repo
      , search            = mercurialSearch repo
      , idsMatch          = const hashsMatch repo
      }

    -- | Initialize a repository, creating the directory if needed.
    mercurialInit :: FilePath -> IO ()
    mercurialInit repo = do
      exists <- doesDirectoryExist repo
      when exists $ withVerifyDir repo $ throwIO RepositoryExists
      createDirectoryIfMissing True repo
      (status, err, _) <- rawRunMercurialCommand repo "init" []
      if status == 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
           B.writeFile (repo </> ".hg" </> "hgrc") $
             toByteString "[hooks]\nchangegroup = hg update >&2\n"
         else throwIO $ UnknownError $ "mercurial init failed:\n" ++ err

    -- | Commit changes to a resource.  Raise 'Unchanged' exception if there were
    -- no changes.
    mercurialCommit :: FilePath -> [FilePath] -> Author -> String -> IO ()
    mercurialCommit repo names author logMsg = do
      let email = authorEmail author
          email' = if not (null email)
                    then " <" ++ email ++ ">"
                    else ""
      (statusCommit, errCommit, _) <- runMercurialCommand repo "commit" $ ["--user", authorName author ++ email', "-m", logMsg] ++ names
      unless (statusCommit == ExitSuccess) $ do
         throwIO $ if null errCommit
                      then Unchanged
                      else UnknownError $ "Could not hg commit " ++ unwords names ++ "\n" ++ errCommit

    -- | Save changes (creating file and directory if needed), add, and commit.
    mercurialSave :: Contents a => FilePath -> FilePath -> Author -> Description -> a -> IO ()
    mercurialSave repo name author logMsg contents = do
      withSanityCheck repo [".hg"] name $ B.writeFile (repo </> encodeArg name) $ toByteString contents
      (statusAdd, errAdd, _) <- runMercurialCommand repo "add" ["path:" ++ name]
      if statusAdd == ExitSuccess
         then mercurialCommit repo [name] author logMsg
         else throwIO $ UnknownError $ "Could not hg add '" ++ name ++ "'\n" ++ 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 repo name revid = do
      let revname = case revid of
                            Nothing  -> "tip"
                            Just rev -> rev
      (statcheck, _, _) <- runMercurialCommand repo "locate" ["-r", revname, "-X", "glob:" ++ name </> "*", "path:" ++ name]
      when (statcheck /= ExitSuccess) $ throwIO NotFound
      (status, err, output) <- runMercurialCommand repo "cat" ["-r", revname, "-X", "glob:" ++ name </> "*", "path:" ++ name]
      if status == ExitSuccess
         then return $ fromByteString output
         else throwIO $ UnknownError $ "Error in mercurial cat:\n" ++ err

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

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

    -- | Return revision ID for latest commit for a resource.
    mercurialLatestRevId :: FilePath -> FilePath -> IO RevisionId
    mercurialLatestRevId repo name = do
      (status, _, output) <- runMercurialCommand repo "log" ["--template", "{node}\\n{file_dels}\\n", "--limit", "1", "--removed", "path:" ++ name]
      if status == ExitSuccess
         then do
           let result = lines $ toString output
           if null result || name `elem` drop 1 result
              then throwIO NotFound
              else return $ head result
         else throwIO NotFound

    -- | Get revision information for a particular revision ID, or latest revision.
    mercurialGetRevision :: FilePath -> RevisionId -> IO Revision
    mercurialGetRevision repo revid = do
      (status, _, output) <- runMercurialCommand repo "log" ["--template", mercurialLogFormat, "--limit", "1", "-r", revid]
      if status == ExitSuccess
         then case P.parse parseMercurialLog "" (toString output) of
                     Left err'   -> throwIO $ UnknownError $ "error parsing mercurial log: " ++ show err'
                     Right [r]   -> return r
                     Right []    -> throwIO NotFound
                     Right xs    -> throwIO $ UnknownError $ "mercurial log returned more than one result: " ++ show xs
         else throwIO NotFound

    -- | Get a list of all known files inside and managed by a repository.
    mercurialIndex :: FilePath ->IO [FilePath]
    mercurialIndex repo = withVerifyDir repo $ do
      (status, _err, output) <- runMercurialCommand repo "manifest" ["-r", "tip"]
      if status == ExitSuccess
         then return $ lines $ toString $ output
         else 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 repo dir = withVerifyDir (repo </> dir) $ do
      (status, _, output) <- runMercurialCommand repo "locate" ["-r", "tip", "glob:" ++ (dir </> "*")]
      let files = if status == ExitSuccess
                    then map (FSFile . takeFileName . removePrefix dir) $ lines $ toString output
                    else []
      (status2, _, output2) <- runMercurialCommand repo "locate" ["-r", "tip", "glob:" ++ (dir </> "*" </> "*")]
      let dirs = if status2 == ExitSuccess
                    then map FSDirectory $ nub $ map (head . splitDirectories . removePrefix dir) $ lines $ toString output2
                    else []
      return $ files ++ dirs
     where removePrefix d = drop $ length d

    -- | Use generic grep to search
    mercurialSearch :: FilePath -> SearchQuery -> IO [SearchMatch]
    mercurialSearch = grepSearchRepo 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 = "{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 repo names (TimeRange mbSince mbUntil) mblimit = do
      (status, err, output) <- runMercurialCommand repo "log" $ ["--template", mercurialLogFormat] ++ revOpts mbSince mbUntil ++ limit ++ names
      if status == ExitSuccess
         then case P.parse parseMercurialLog "" (toString output) of
                    Left err'    -> throwIO $ UnknownError $ "Error parsing mercurial log.\n" ++ show err'
                    Right parsed -> return parsed
         else throwIO $ UnknownError $ "mercurial log returned error status.\n" ++ err
     where revOpts Nothing Nothing   = []
           revOpts Nothing (Just u)  = ["-d", "<" ++ showTime u]
           revOpts (Just s) Nothing  = ["-d", ">" ++ showTime s]
           revOpts (Just s) (Just u) = ["-d", showTime s ++ " to " ++ showTime u]
           showTime = formatTime defaultTimeLocale "%F %X"
           limit = case mblimit of
                        Just lim  -> ["--limit", show lim]
                        Nothing   -> []

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

    parseMercurialLog :: P.Parser [Revision]
    parseMercurialLog = P.manyTill mercurialLogEntry P.eof

    wholeLine :: P.GenParser Char st String
    wholeLine = P.manyTill P.anyChar P.newline

    nonblankLine :: P.GenParser Char st String
    nonblankLine = P.notFollowedBy P.newline >> wholeLine

    nullStr :: P.GenParser Char st String
    nullStr = P.manyTill P.anyChar (P.satisfy (=='\x00'))

    mercurialLogEntry :: P.Parser Revision
    mercurialLogEntry = do
      rev <- nonblankLine
      date <- nonblankLine
      author <- nonblankLine
      email <- wholeLine
      subject <- nullStr
      P.spaces
      file_add <- liftM (map Added . lines) $ nullStr
      P.spaces
      file_mod <- liftM (map Modified . lines) $ nullStr
      P.spaces
      file_del <- liftM (map Deleted . lines) $ nullStr
      P.spaces
      let stripTrailingNewlines = reverse . dropWhile (=='\n') . reverse
      return Revision {
                  revId          = rev
                , revDateTime    = fromJust (parseTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" date :: Maybe UTCTime)
                , revAuthor      = Author { authorName = author, authorEmail = email }
                , revDescription = stripTrailingNewlines subject
                , revChanges     = file_add ++ file_mod ++ 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
               }
    -}