{-| Base common functionality.

This module holds common functionality shared across Ganeti daemons,
HTools and any other programs.

-}

{-

Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

1. Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.

2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

-}

module Ganeti.Common
  ( GenericOptType
  , StandardOptions(..)
  , OptCompletion(..)
  , ArgCompletion(..)
  , PersonalityList
  , optComplYesNo
  , oShowHelp
  , oShowVer
  , oShowComp
  , usageHelp
  , versionInfo
  , formatCommands
  , reqWithConversion
  , parseYesNo
  , parseOpts
  , parseOptsInner
  , parseOptsCmds
  , genericMainCmds
  , fillUpList
  , fillPairFromMaybe
  , pickPairUnique
  ) where

import Control.Monad (foldM)
import Data.Char (toLower)
import Data.List (intercalate, stripPrefix, sortBy)
import Data.Maybe (fromMaybe)
import Data.Ord (comparing)
import qualified Data.Version
import System.Console.GetOpt
import System.Environment
import System.Exit
import System.Info
import System.IO
import Text.Printf (printf)

import Ganeti.BasicTypes
import qualified Ganeti.Constants as C
import Ganeti.Utils (wrap)
import qualified Ganeti.Version as Version (version)

-- | Parameter type.
data OptCompletion = OptComplNone             -- ^ No parameter to this option
                   | OptComplFile             -- ^ An existing file
                   | OptComplDir              -- ^ An existing directory
                   | OptComplHost             -- ^ Host name
                   | OptComplInetAddr         -- ^ One ipv4\/ipv6 address
                   | OptComplOneNode          -- ^ One node
                   | OptComplManyNodes        -- ^ Many nodes, comma-sep
                   | OptComplOneInstance      -- ^ One instance
                   | OptComplManyInstances    -- ^ Many instances, comma-sep
                   | OptComplOneOs            -- ^ One OS name
                   | OptComplOneIallocator    -- ^ One iallocator
                   | OptComplInstAddNodes     -- ^ Either one or two nodes
                   | OptComplOneGroup         -- ^ One group
                   | OptComplInteger          -- ^ Integer values
                   | OptComplFloat            -- ^ Float values
                   | OptComplJobId            -- ^ Job Id
                   | OptComplCommand          -- ^ Command (executable)
                   | OptComplString           -- ^ Arbitrary string
                   | OptComplChoices [String] -- ^ List of string choices
                   | OptComplSuggest [String] -- ^ Suggested choices
                   deriving (Show, Eq)

-- | Argument type. This differs from (and wraps) an Option by the
-- fact that it can (and usually does) support multiple repetitions of
-- the same argument, via a min and max limit.
data ArgCompletion = ArgCompletion OptCompletion Int (Maybe Int)
                     deriving (Show, Eq)

-- | A personality definition.
type Personality a = ( a -> [String] -> IO () -- The main function
                     , IO [GenericOptType a]  -- The options
                     , [ArgCompletion]        -- The description of args
                     , String                 -- Description
                     )

-- | Personality lists type, common across all binaries that expose
-- multiple personalities.
type PersonalityList  a = [(String, Personality a)]

-- | Yes\/no choices completion.
optComplYesNo :: OptCompletion
optComplYesNo = OptComplChoices ["yes", "no"]

-- | Text serialisation for 'OptCompletion', used on the Python side.
complToText :: OptCompletion -> String
complToText (OptComplChoices choices) = "choices=" ++ intercalate "," choices
complToText (OptComplSuggest choices) = "suggest=" ++ intercalate "," choices
complToText compl =
  let show_compl = show compl
      stripped = stripPrefix "OptCompl" show_compl
  in map toLower $ fromMaybe show_compl stripped

-- | Text serialisation for 'ArgCompletion'.
argComplToText :: ArgCompletion -> String
argComplToText (ArgCompletion optc min_cnt max_cnt) =
  complToText optc ++ " " ++ show min_cnt ++ " " ++ maybe "none" show max_cnt

-- | Abbreviation for the option type.
type GenericOptType a = (OptDescr (a -> Result a), OptCompletion)

-- | Type class for options which support help and version.
class StandardOptions a where
  helpRequested :: a -> Bool
  verRequested  :: a -> Bool
  compRequested :: a -> Bool
  requestHelp   :: a -> a
  requestVer    :: a -> a
  requestComp   :: a -> a

-- | Option to request help output.
oShowHelp :: (StandardOptions a) => GenericOptType a
oShowHelp = (Option "h" ["help"] (NoArg (Ok . requestHelp)) "show help",
             OptComplNone)

-- | Option to request version information.
oShowVer :: (StandardOptions a) => GenericOptType a
oShowVer = (Option "V" ["version"] (NoArg (Ok . requestVer))
            "show the version of the program",
            OptComplNone)

-- | Option to request completion information
oShowComp :: (StandardOptions a) => GenericOptType a
oShowComp =
  (Option "" ["help-completion"] (NoArg (Ok . requestComp) )
   "show completion info", OptComplNone)

-- | Usage info.
usageHelp :: String -> [GenericOptType a] -> String
usageHelp progname =
  usageInfo (printf "%s %s\nUsage: %s [OPTION...]"
             progname Version.version progname) . map fst

-- | Show the program version info.
versionInfo :: String -> String
versionInfo progname =
  printf "%s %s\ncompiled with %s %s\nrunning on %s %s\n"
         progname Version.version compilerName
         (Data.Version.showVersion compilerVersion)
         os arch

-- | Show completion info.
completionInfo :: String -> [GenericOptType a] -> [ArgCompletion] -> String
completionInfo _ opts args =
  unlines $
  map (\(Option shorts longs _ _, compinfo) ->
         let all_opts = map (\c -> ['-', c]) shorts ++ map ("--" ++) longs
         in intercalate "," all_opts ++ " " ++ complToText compinfo
      ) opts ++
  map argComplToText args

-- | Helper for parsing a yes\/no command line flag.
parseYesNo :: Bool         -- ^ Default value (when we get a @Nothing@)
           -> Maybe String -- ^ Parameter value
           -> Result Bool  -- ^ Resulting boolean value
parseYesNo v Nothing      = return v
parseYesNo _ (Just "yes") = return True
parseYesNo _ (Just "no")  = return False
parseYesNo _ (Just s)     = fail ("Invalid choice '" ++ s ++
                                  "', pass one of 'yes' or 'no'")

-- | Helper function for required arguments which need to be converted
-- as opposed to stored just as string.
reqWithConversion :: (String -> Result a)
                  -> (a -> b -> Result b)
                  -> String
                  -> ArgDescr (b -> Result b)
reqWithConversion conversion_fn updater_fn =
  ReqArg (\string_opt opts -> do
            parsed_value <- conversion_fn string_opt
            updater_fn parsed_value opts)

-- | Max command length when formatting command list output.
maxCmdLen :: Int
maxCmdLen = 60

-- | Formats the description of various commands.
formatCommands :: (StandardOptions a) => PersonalityList a -> [String]
formatCommands personalities =
  concatMap (\(cmd, (_, _, _, desc)) ->
              fmtDesc cmd (wrap maxWidth desc) "-" []) $
  sortBy (comparing fst) personalities
    where mlen = min maxCmdLen . maximum $ map (length . fst) personalities
          maxWidth = 79 - 3 - mlen
          fmtDesc _ [] _ acc = reverse acc
          fmtDesc cmd (d : ds) sep acc =
            fmtDesc "" ds " " (printf " %-*s %s %s" mlen cmd sep d : acc)

-- | Formats usage for a multi-personality program.
formatCmdUsage :: (StandardOptions a) => String -> PersonalityList a -> String
formatCmdUsage prog personalities =
  let header = [ printf "Usage: %s {command} [options...] [argument...]" prog
               , printf "%s <command> --help to see details, or man %s"
                   prog prog
               , ""
               , "Commands:"
               ]
      rows = formatCommands personalities
  in unlines $ header ++ rows

-- | Displays usage for a program and exits.
showCmdUsage :: (StandardOptions a) =>
                String            -- ^ Program name
             -> PersonalityList a -- ^ Personality list
             -> Bool              -- ^ Whether the exit code is success or not
             -> IO b
showCmdUsage prog personalities success = do
  let usage = formatCmdUsage prog personalities
  putStr usage
  if success
    then exitSuccess
    else exitWith $ ExitFailure C.exitFailure

-- | Generates completion information for a multi-command binary.
multiCmdCompletion :: (StandardOptions a) => PersonalityList a -> String
multiCmdCompletion personalities =
  argComplToText $
    ArgCompletion (OptComplChoices (map fst personalities))
      1 (Just 1)

-- | Displays completion information for a multi-command binary and exits.
showCmdCompletion :: (StandardOptions a) => PersonalityList a -> IO b
showCmdCompletion personalities =
  putStrLn (multiCmdCompletion personalities) >> exitSuccess

-- | Command line parser, using a generic 'Options' structure.
parseOpts :: (StandardOptions a) =>
             a                      -- ^ The default options
          -> [String]               -- ^ The command line arguments
          -> String                 -- ^ The program name
          -> [GenericOptType a]     -- ^ The supported command line options
          -> [ArgCompletion]        -- ^ The supported command line arguments
          -> IO (a, [String])       -- ^ The resulting options and
                                    -- leftover arguments
parseOpts defaults argv progname options arguments =
  case parseOptsInner defaults argv progname options arguments of
    Left (code, msg) -> do
      hPutStr (if code == ExitSuccess then stdout else stderr) msg
      exitWith code
    Right result ->
      return result

-- | Command line parser, for programs with sub-commands.
parseOptsCmds :: (StandardOptions a) =>
                 a                      -- ^ The default options
              -> [String]               -- ^ The command line arguments
              -> String                 -- ^ The program name
              -> PersonalityList a      -- ^ The supported commands
              -> [GenericOptType a]     -- ^ Generic options
              -> IO (a, [String], a -> [String] -> IO ())
                     -- ^ The resulting options and leftover arguments
parseOptsCmds defaults argv progname personalities genopts = do
  let usage = showCmdUsage progname personalities
      check c = case c of
                  -- hardcoded option strings here!
                  "--version" -> putStrLn (versionInfo progname) >> exitSuccess
                  "--help"    -> usage True
                  "--help-completion" -> showCmdCompletion personalities
                  _           -> return c
  (cmd, cmd_args) <- case argv of
                       cmd:cmd_args -> do
                         cmd' <- check cmd
                         return (cmd', cmd_args)
                       [] -> usage False
  case cmd `lookup` personalities of
    Nothing -> usage False
    Just (mainfn, optdefs, argdefs, _) -> do
      optdefs' <- optdefs
      (opts, args) <- parseOpts defaults cmd_args progname
                      (optdefs' ++ genopts) argdefs
      return (opts, args, mainfn)

-- | Inner parse options. The arguments are similar to 'parseOpts',
-- but it returns either a 'Left' composed of exit code and message,
-- or a 'Right' for the success case.
parseOptsInner :: (StandardOptions a) =>
                  a
               -> [String]
               -> String
               -> [GenericOptType a]
               -> [ArgCompletion]
               -> Either (ExitCode, String) (a, [String])
parseOptsInner defaults argv progname options arguments  =
  case getOpt Permute (map fst options) argv of
    (opts, args, []) ->
      case foldM (flip id) defaults opts of
           Bad msg -> Left (ExitFailure 1,
                            "Error while parsing command line arguments:\n"
                            ++ msg ++ "\n")
           Ok parsed ->
             select (Right (parsed, args))
                 [ (helpRequested parsed,
                    Left (ExitSuccess, usageHelp progname options))
                 , (verRequested parsed,
                    Left (ExitSuccess, versionInfo progname))
                 , (compRequested parsed,
                    Left (ExitSuccess, completionInfo progname options
                                         arguments))
                 ]
    (_, _, errs) ->
      Left (ExitFailure 2, "Command line error: "  ++ concat errs ++ "\n" ++
            usageHelp progname options)

-- | Parse command line options and execute the main function of a
-- multi-personality binary.
genericMainCmds :: (StandardOptions a) =>
                   a
                -> PersonalityList a
                -> [GenericOptType a]
                -> IO ()
genericMainCmds defaults personalities genopts = do
  cmd_args <- getArgs
  prog <- getProgName
  (opts, args, fn) <-
    parseOptsCmds defaults cmd_args prog personalities genopts
  fn opts args

-- | Order a list of pairs in the order of the given list and fill up
-- the list for elements that don't have a matching pair
fillUpList :: ([(a, b)] -> a -> (a, b)) -> [a] -> [(a, b)] -> [(a, b)]
fillUpList fill_fn inputs pairs =
  map (fill_fn pairs) inputs

-- | Fill up a pair with fillup element if no matching pair is present
fillPairFromMaybe :: (a -> (a, b)) -> (a -> [(a, b)] -> Maybe (a, b))
                  -> [(a, b)] -> a -> (a, b)
fillPairFromMaybe fill_fn pick_fn pairs element = fromMaybe (fill_fn element)
    (pick_fn element pairs)

-- | Check if the given element matches the given pair
isMatchingPair :: (Eq a) => a -> (a, b) -> Bool
isMatchingPair element (pair_element, _) = element == pair_element

-- | Pick a specific element's pair from the list
pickPairUnique :: (Eq a) => a -> [(a, b)] -> Maybe (a, b)
pickPairUnique element pairs =
  let res = filter (isMatchingPair element) pairs
  in case res of
    [x] -> Just x
    -- if we have more than one result, we should get suspcious
    _ -> Nothing