{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}

module DPM.UI.Commandline.Main (mainWithArgs) where

import Prelude hiding ( catch )
import System.Environment
import System.Console.GetOpt
import System.FilePath
import System.Posix.User
import System.Exit
import Control.Exception
import Control.Monad
import System.IO
import qualified Data.List as List
import qualified Data.ByteString as B
import Data.Typeable
import System.Directory ( doesFileExist, doesDirectoryExist )
import System.FilePath
import Data.List.Split
import System.Posix.IO ( stdOutput)
import System.Posix.Terminal ( queryTerminal )
import System.Exit ( ExitCode(..), exitWith )

import DPM.Core.DPM_Monad
import DPM.Core.Utils ( unlessM, findCommand, joinStrings )
import DPM.Core.DataTypes ( PatchID(..), Query(..), PatchGroupState(..) )
import DPM.Core.Storage ( setupStorageDir )
import DPM.Core.QueryParser
import DPM.UI.Commandline.Commands
import DPM.UI.Commandline.Interaction ( bugHeader )
import DPM.UI.Commandline.CDPM_Monad

-- keep in sync with version in .cabal file
versionString :: String
versionString = "DPM version 0.3.0"

data Options = Options { opt_repoDir        :: FilePath
                       , opt_storageDir     :: FilePath
                       , opt_longList       :: Bool
                       , opt_verbose        :: Bool
                       , opt_debug          :: Bool
                       , opt_batch          :: Bool
                       , opt_no_colors      :: Bool
                       , opt_tests          :: Bool
                       , opt_interactive    :: Bool
                       , opt_force          :: Bool
                       , opt_user           :: Maybe String
                       , opt_from           :: Maybe String
                       , opt_reviewAddress  :: Maybe String
                       , opt_help           :: Bool
                       , opt_version        :: Bool }
             deriving (Show)

type CommandName = String

type DPMOptDescr = OptDescr (Options -> Options)

data OptionMissingException = OptionMissingException { ome_msg :: String }
                  deriving (Show,Read,Eq,Typeable)

instance Exception OptionMissingException where

optionMissing :: String -> a
optionMissing s = throw (OptionMissingException s)

checkOptions :: Options -> IO ()
checkOptions opts =
    force `catch` (\ (e::OptionMissingException) ->
                       abort (ome_msg e) exitCodeArgParseFailed)
    where force = -- poor man's trick to force opts
              do evaluate (length (show opts))
                 return ()

defaultOptions :: Maybe CommandName -> Options
defaultOptions mc =
    let def = Options { opt_repoDir =
                            optionMissing "no repository directory given"
                      , opt_storageDir =
                          optionMissing "no storage directory given"
                      , opt_longList = False
                      , opt_verbose = False
                      , opt_debug = False
                      , opt_batch = False
                      , opt_no_colors = False
                      , opt_tests = True
                      , opt_interactive = False
                      , opt_force = False
                      , opt_user = Nothing
                      , opt_from = Nothing
                      , opt_reviewAddress = Nothing
                      , opt_help = False
                      , opt_version = False }
    in def

fillOptions :: [Options -> Options] -> Options -> Options
fillOptions otrans def = foldl (flip id) def otrans

globalOptionSpec :: [DPMOptDescr]
globalOptionSpec =
     [Option ['r'] ["repo-dir"]
             (ReqArg (\d opts -> opts { opt_repoDir = d }) "DIR")
             "directory of the darcs repository"
     ,Option ['s'] ["storage-dir"]
             (ReqArg (\d opts -> opts { opt_storageDir = d }) "DIR")
             "directory for storing DPM data"
     ,Option ['v']  ["verbose"]
             (NoArg (\opts -> opts { opt_verbose = True }))
             "be verbose"
     ,Option []  ["debug"]
             (NoArg (\opts -> opts { opt_debug = True }))
             "output debug messages"
     ,Option []  ["batch"]
             (NoArg (\opts -> opts { opt_batch = True }))
             "run in batch mode"
     ,Option []  ["no-colors"]
             (NoArg (\opts -> opts { opt_no_colors = True }))
             "do not use colors when printing text"
     ,Option []  ["user"]
             (ReqArg (\u opts -> opts { opt_user = Just u }) "USER")
             "current user"
     ,Option []  ["from"]
             (ReqArg (\f opts -> opts { opt_from = Just f }) "EMAIL_ADDRESS")
             "from address for emails"
     ,Option []  ["review-address"]
             (ReqArg (\f opts -> opts { opt_reviewAddress = Just f })
                     "EMAIL_ADDRESS")
             "email address for sending reviews"
     ,Option ['h', '?']  ["help"]
             (NoArg (\opts -> opts { opt_help = True }))
             "display this help message"
     ,Option []  ["version"]
             (NoArg (\opts -> opts { opt_version = True }))
             "display the version"
     ]

maxArgs :: Int
maxArgs = 1024

type CommandRunner = Options -> [String] -> CDPM ()

commands :: [(CommandName,       -- name of command
              (String,           -- description
               String,           -- argument specifier
               [DPMOptDescr],    -- options of the command
               Int,              -- minimal number of arguments
               Int,              -- maximal number of arguments
               CommandRunner))]  -- function to run
commands =
    [("add",
      ("Put the given patch bundles under DPM's control " ++
       "(use '-' to read from stdin).",
       "FILE...",
       [], 1, maxArgs,
       addCmd))
    ,("apply",
      ("Apply the patches with the IDs given to the darcs repository.",
       "ID...",
       [Option []  ["no-tests"]
             (NoArg (\opts -> opts { opt_tests = False }))
             "do not run tests when applying patches",
        Option ['i']  ["interactive"]
               (NoArg (\opts -> opts { opt_interactive = True }))
               "apply interactively"],
       1, maxArgs,
       applyCmd))
    ,("list",
      ("List the patches matching the given query.\n\n" ++
       querySyntax ++ "\n" ++
       "If no query is given, DPM lists all open patch groups.\n",
       "QUERY ...",
       [],
       0, maxArgs,
       listCmd))
    ,("review",
      ("Review the patches with the IDs given.",
       "ID...",
       [Option []  ["force"]
             (NoArg (\opts -> opts { opt_force = True }))
             "force review"],
       1, maxArgs,
       reviewCmd))
    ,("sync",
      ("Synchronize with the darcs repository.",
       "",
       [], 0, 0,
       syncCmd))
    ,("mark-as-reviewed",
      ("Mark the patch given as reviewed.",
       "ID COMMENT ...",
       [], 2, maxArgs,
       markAsReviewedCmd))
    ,("mark-as-undecided",
      ("Mark the patch given as undecided.",
       "ID COMMENT ...",
       [], 2, maxArgs,
       markAsUndecidedCmd))
    ,("mark-as-obsolete",
      ("Mark the patch given as obsolete.",
       "ID COMMENT ...",
       [], 2, maxArgs,
       markAsObsoleteCmd))
    ,("mark-as-rejected",
      ("Mark the patch given as rejected.",
       "ID COMMENT ...",
       [], 2, maxArgs,
       markAsRejectedCmd))
    ,("mark-as-applied",
      ("Mark the patch given as applied.",
       "ID COMMENT ...",
       [], 2, maxArgs,
       markAsAppliedCmd))
    ,("mark-as-unapplied",
      ("Mark the patch given (in state APPLIED) as UNDECIDED.",
       "ID COMMENT ...",
       [], 2, maxArgs,
       markAsUnappliedCmd))
    ,("close-group",
      ("Close the patch group given.",
       "NAME",
       [], 1, 1,
       closeGroupCmd))
    ,("open-group",
      ("Open the patch that contains the patch with the ID given.",
       "ID",
       [], 1, 1,
       openGroupCmd))
    ,("add-comment",
      ("Add a comment to the patch given.",
       "ID COMMENT ...",
       [], 2, maxArgs,
       addCommentCmd))
    ,("view",
      ("View the patch given.",
       "ID",
       [], 1, 1,
       viewCmd))
    ,("export",
      ("Export the bundle containing the patch given.",
       "ID",
       [], 1, 1,
       exportCmd))
    ]

addCmd :: CommandRunner
addCmd _ files =
    mapM_ (\f -> do bs <- liftIO (readBundleData f)
                    addPatchBundle f bs)
          files
    where
      readBundleData "-" = B.getContents
      readBundleData f = B.readFile f

applyCmd :: CommandRunner
applyCmd opts ids = mapM_ (applyPatch (opt_interactive opts)) ids

listCmd :: CommandRunner
listCmd opts args =
    do q <- case args of
               [] -> return (QGroupState PatchGroupOpen)
               l -> do let q = joinStrings l
                       debugCDPM ("Query: " ++ q)
                       case parseQuery q of
                         Just x -> return x
                         Nothing -> fail ("Cannot parse query: " ++ q)
       listPatches q

reviewCmd :: CommandRunner
reviewCmd _ ids = mapM_ reviewPatch ids

syncCmd :: CommandRunner
syncCmd _ _ = sync

markAsReviewedCmd :: CommandRunner
markAsReviewedCmd _ args = markAsReviewed (args!!0) (joinStrings (tail args))

markAsObsoleteCmd :: CommandRunner
markAsObsoleteCmd _ args = markAsObsolete (args!!0) (joinStrings (tail args))

markAsRejectedCmd :: CommandRunner
markAsRejectedCmd _ args = markAsRejected (args!!0) (joinStrings (tail args))

markAsUndecidedCmd :: CommandRunner
markAsUndecidedCmd _ args = markAsUndecided (args!!0) (joinStrings (tail args))

markAsAppliedCmd :: CommandRunner
markAsAppliedCmd _ args = markAsApplied (args!!0) (joinStrings (tail args))

markAsUnappliedCmd :: CommandRunner
markAsUnappliedCmd _ args = markAsUnapplied (args!!0) (joinStrings (tail args))

closeGroupCmd :: CommandRunner
closeGroupCmd _ args = closeGroup (args!!0)

openGroupCmd :: CommandRunner
openGroupCmd _ args = openGroup (args!!0)

addCommentCmd :: CommandRunner
addCommentCmd _ args = addComment (head args) (joinStrings (tail args))

viewCmd :: CommandRunner
viewCmd _ args = viewPatch (args!!0)

exportCmd :: CommandRunner
exportCmd _ args = exportBundle (args!!0)

getOpts :: [String] -> Either String (Options, CDPM ())
getOpts argv =
    case getOpt' Permute globalOptionSpec argv of
      (otrans, nonOptionArgs, extraOptionArgs, []) ->
          let options = fillOptions otrans (defaultOptions Nothing)
          in case nonOptionArgs of
               [] ->
                   case (opt_help options, opt_version options) of
                     (True, _) -> Left (helpMessage globalOptionSpec Nothing)
                     (_, True) -> Left versionString
                     _ -> Left ("No command given")
               (cmd:args) ->
                   case List.lookup cmd commands of
                     Nothing -> Left ("Unknown command " ++ show cmd)
                     Just (_, _, optSpec, lowerBound, upperBound, runner) ->
                         let options =
                               fillOptions otrans (defaultOptions (Just cmd))
                         in case () of
                             _| opt_help options ->
                                  Left (helpMessage globalOptionSpec (Just cmd))
                              | length args < lowerBound ->
                                  Left ("Not enough arguments for command " ++
                                        show cmd)
                              | length args > upperBound ->
                                  Left ("Too many arguments for command " ++
                                        show cmd)
                              | otherwise ->
                                  case getOpt Permute optSpec extraOptionArgs of
                                    (otrans', [], []) ->
                                        let options' = fillOptions otrans'
                                                         options
                                        in
                                        Right (options',
                                               runner options' args)
                                    (_, _, errs) ->
                                        Left ("Invalid options for command " ++
                                              show cmd ++ ": " ++ concat errs)
      (_, _, _, errs) ->
          Left (concat errs)

helpMessage :: [OptDescr a] -> Maybe String -> String
helpMessage opts Nothing =
    usageInfo header opts ++ footer
    where header = "Usage: dpm [OPTION]... COMMAND [ARGUMENT]...\n\n" ++
                   "Global options:"
          footer = "\nAvailable commands:\n" ++
                   (unlines (map (\x -> "  " ++ fst x) commands))
helpMessage opts (Just cmd) =
    usageInfo header argOpts ++
    usageInfo header' opts
    where
      Just (descr, argSpec, argOpts, minArgs, maxArgs, _) =
          List.lookup cmd commands
      header = cmd ++ ": " ++ descr ++ "\nUsage: " ++ cmd ++ " "
               ++ optSpec ++ argSpec ++ "\n\nCommand options:"
      header' = "\nGlobal options:"
      optSpec = if null argOpts then ""
                   else "[OPTION]... "

exitCodeArgParseFailed :: Int
exitCodeArgParseFailed = 2

exitCodeFailure :: Int
exitCodeFailure = 1

abort :: String -> Int -> IO a
abort msg exitCode =
    do hPutStrLn stderr msg
       exitWith (ExitFailure exitCode)

mainWithArgs args =
    do user <- getEffectiveUserName
       case getOpts args of
         Left err -> abort err exitCodeArgParseFailed
         Right (opts, runner) ->
             do checkOptions opts
                tty <- isatty
                let dpmCfg = DPMConfig {
                               cfg_modelFile = opt_storageDir opts </> "model"
                             , cfg_patchesFile =
                                 opt_storageDir opts </> "patches"
                             , cfg_dataDir = opt_storageDir opts </> "data"
                             , cfg_currentUser = getOptional (opt_user opts) user
                             , cfg_fromAddress = getOptional (opt_from opts) user
                             , cfg_patchLog = opt_storageDir opts </> "patchLog"
                             , cfg_patchGroupLog =
                                 opt_storageDir opts </> "patchGroupLog"
                             , cfg_lockFile = opt_storageDir opts </> ".lock"
                             , cfg_reviewDir = opt_storageDir opts </> "reviews"
                             , cfg_repoDir = opt_repoDir opts
                             , cfg_reviewAddress = opt_reviewAddress opts
                             , cfg_debug = opt_debug opts
                             }
                    cfg = defaultConfig {
                            cfg_verbose = opt_verbose opts
                          , cfg_batch = opt_batch opts
                          , cfg_colored = tty && not (opt_no_colors opts)
                          , cfg_tests = opt_tests opts
                          , cfg_force = opt_force opts
                          }
                -- same sanity checks
                checkDirExists (opt_storageDir opts)
                checkDirExists (opt_repoDir opts)
                runDPM dpmCfg $ runCDPM cfg $ liftDPM setupStorageDir >> runner
                `catches`
                       [Handler (\(DPMException err) ->
                                     abort err exitCodeFailure)
                       ,Handler (\(e::ExitCode) ->
                                     exitWith e)
                       ,Handler (\(e::AsyncException) ->
                                     case e of
                                       UserInterrupt ->
                                           abort "\nUser interrupt!"
                                                 exitCodeFailure
                                       _ -> reportBug e)
                       ,Handler (\(e::SomeException) ->
                                     reportBug e)]
    where
      getOptional Nothing x = x
      getOptional (Just x) _ = x
      reportBug :: Show a => a -> IO b
      reportBug e =
          abort (bugHeader ++ "Unhandled exception: " ++ show e)
                exitCodeFailure
      checkDirExists d =
          unlessM (doesDirectoryExist d) $
                 abort ("Directory " ++ show d ++ " does not exist")
                       exitCodeFailure
      checkFileExists f =
          unlessM (doesFileExist f) $
                 abort ("File " ++ show f ++ " does not exist")
                       exitCodeFailure
      isatty = queryTerminal stdOutput

mainWithString :: String -> IO ()
mainWithString s = mainWithArgs (splitOn " " s)