code.grnet.gr Git - ganeti-local/blob - src/Ganeti/Common.hs

   1 {-| Base common functionality.
   2
   3 This module holds common functionality shared across Ganeti daemons,
   4 HTools and any other programs.
   5
   6 -}
   7
   8 {-
   9
  10 Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
  11
  12 This program is free software; you can redistribute it and/or modify
  13 it under the terms of the GNU General Public License as published by
  14 the Free Software Foundation; either version 2 of the License, or
  15 (at your option) any later version.
  16
  17 This program is distributed in the hope that it will be useful, but
  18 WITHOUT ANY WARRANTY; without even the implied warranty of
  19 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 General Public License for more details.
  21
  22 You should have received a copy of the GNU General Public License
  23 along with this program; if not, write to the Free Software
  24 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  25 02110-1301, USA.
  26
  27 -}
  28
  29 module Ganeti.Common
  30   ( GenericOptType
  31   , StandardOptions(..)
  32   , OptCompletion(..)
  33   , ArgCompletion(..)
  34   , PersonalityList
  35   , optComplYesNo
  36   , oShowHelp
  37   , oShowVer
  38   , oShowComp
  39   , usageHelp
  40   , versionInfo
  41   , formatCommands
  42   , reqWithConversion
  43   , parseYesNo
  44   , parseOpts
  45   , parseOptsInner
  46   , parseOptsCmds
  47   , genericMainCmds
  48   ) where
  49
  50 import Control.Monad (foldM)
  51 import Data.Char (toLower)
  52 import Data.List (intercalate, stripPrefix, sortBy)
  53 import Data.Maybe (fromMaybe)
  54 import Data.Ord (comparing)
  55 import qualified Data.Version
  56 import System.Console.GetOpt
  57 import System.Environment
  58 import System.Exit
  59 import System.Info
  60 import System.IO
  61 import Text.Printf (printf)
  62
  63 import Ganeti.BasicTypes
  64 import qualified Ganeti.Constants as C
  65 import qualified Ganeti.Version as Version (version)
  66
  67 -- | Parameter type.
  68 data OptCompletion = OptComplNone             -- ^ No parameter to this option
  69                    | OptComplFile             -- ^ An existing file
  70                    | OptComplDir              -- ^ An existing directory
  71                    | OptComplHost             -- ^ Host name
  72                    | OptComplInetAddr         -- ^ One ipv4\/ipv6 address
  73                    | OptComplOneNode          -- ^ One node
  74                    | OptComplManyNodes        -- ^ Many nodes, comma-sep
  75                    | OptComplOneInstance      -- ^ One instance
  76                    | OptComplManyInstances    -- ^ Many instances, comma-sep
  77                    | OptComplOneOs            -- ^ One OS name
  78                    | OptComplOneIallocator    -- ^ One iallocator
  79                    | OptComplInstAddNodes     -- ^ Either one or two nodes
  80                    | OptComplOneGroup         -- ^ One group
  81                    | OptComplInteger          -- ^ Integer values
  82                    | OptComplFloat            -- ^ Float values
  83                    | OptComplJobId            -- ^ Job Id
  84                    | OptComplCommand          -- ^ Command (executable)
  85                    | OptComplString           -- ^ Arbitrary string
  86                    | OptComplChoices [String] -- ^ List of string choices
  87                    | OptComplSuggest [String] -- ^ Suggested choices
  88                    deriving (Show, Eq)
  89
  90 -- | Argument type. This differs from (and wraps) an Option by the
  91 -- fact that it can (and usually does) support multiple repetitions of
  92 -- the same argument, via a min and max limit.
  93 data ArgCompletion = ArgCompletion OptCompletion Int (Maybe Int)
  94                      deriving (Show, Eq)
  95
  96 -- | A personality definition.
  97 type Personality a = ( a -> [String] -> IO () -- The main function
  98                      , IO [GenericOptType a]  -- The options
  99                      , [ArgCompletion]        -- The description of args
 100                      , String                 -- Description
 101                      )
 102
 103 -- | Personality lists type, common across all binaries that expose
 104 -- multiple personalities.
 105 type PersonalityList  a = [(String, Personality a)]
 106
 107 -- | Yes\/no choices completion.
 108 optComplYesNo :: OptCompletion
 109 optComplYesNo = OptComplChoices ["yes", "no"]
 110
 111 -- | Text serialisation for 'OptCompletion', used on the Python side.
 112 complToText :: OptCompletion -> String
 113 complToText (OptComplChoices choices) = "choices=" ++ intercalate "," choices
 114 complToText (OptComplSuggest choices) = "suggest=" ++ intercalate "," choices
 115 complToText compl =
 116   let show_compl = show compl
 117       stripped = stripPrefix "OptCompl" show_compl
 118   in map toLower $ fromMaybe show_compl stripped
 119
 120 -- | Tex serialisation for 'ArgCompletion'.
 121 argComplToText :: ArgCompletion -> String
 122 argComplToText (ArgCompletion optc min_cnt max_cnt) =
 123   complToText optc ++ " " ++ show min_cnt ++ " " ++ maybe "none" show max_cnt
 124
 125 -- | Abrreviation for the option type.
 126 type GenericOptType a = (OptDescr (a -> Result a), OptCompletion)
 127
 128 -- | Type class for options which support help and version.
 129 class StandardOptions a where
 130   helpRequested :: a -> Bool
 131   verRequested  :: a -> Bool
 132   compRequested :: a -> Bool
 133   requestHelp   :: a -> a
 134   requestVer    :: a -> a
 135   requestComp   :: a -> a
 136
 137 -- | Option to request help output.
 138 oShowHelp :: (StandardOptions a) => GenericOptType a
 139 oShowHelp = (Option "h" ["help"] (NoArg (Ok . requestHelp)) "show help",
 140              OptComplNone)
 141
 142 -- | Option to request version information.
 143 oShowVer :: (StandardOptions a) => GenericOptType a
 144 oShowVer = (Option "V" ["version"] (NoArg (Ok . requestVer))
 145             "show the version of the program",
 146             OptComplNone)
 147
 148 -- | Option to request completion information
 149 oShowComp :: (StandardOptions a) => GenericOptType a
 150 oShowComp =
 151   (Option "" ["help-completion"] (NoArg (Ok . requestComp) )
 152    "show completion info", OptComplNone)
 153
 154 -- | Usage info.
 155 usageHelp :: String -> [GenericOptType a] -> String
 156 usageHelp progname =
 157   usageInfo (printf "%s %s\nUsage: %s [OPTION...]"
 158              progname Version.version progname) . map fst
 159
 160 -- | Show the program version info.
 161 versionInfo :: String -> String
 162 versionInfo progname =
 163   printf "%s %s\ncompiled with %s %s\nrunning on %s %s\n"
 164          progname Version.version compilerName
 165          (Data.Version.showVersion compilerVersion)
 166          os arch
 167
 168 -- | Show completion info.
 169 completionInfo :: String -> [GenericOptType a] -> [ArgCompletion] -> String
 170 completionInfo _ opts args =
 171   unlines $
 172   map (\(Option shorts longs _ _, compinfo) ->
 173          let all_opts = map (\c -> ['-', c]) shorts ++ map ("--" ++) longs
 174          in intercalate "," all_opts ++ " " ++ complToText compinfo
 175       ) opts ++
 176   map argComplToText args
 177
 178 -- | Helper for parsing a yes\/no command line flag.
 179 parseYesNo :: Bool         -- ^ Default value (when we get a @Nothing@)
 180            -> Maybe String -- ^ Parameter value
 181            -> Result Bool  -- ^ Resulting boolean value
 182 parseYesNo v Nothing      = return v
 183 parseYesNo _ (Just "yes") = return True
 184 parseYesNo _ (Just "no")  = return False
 185 parseYesNo _ (Just s)     = fail ("Invalid choice '" ++ s ++
 186                                   "', pass one of 'yes' or 'no'")
 187
 188 -- | Helper function for required arguments which need to be converted
 189 -- as opposed to stored just as string.
 190 reqWithConversion :: (String -> Result a)
 191                   -> (a -> b -> Result b)
 192                   -> String
 193                   -> ArgDescr (b -> Result b)
 194 reqWithConversion conversion_fn updater_fn =
 195   ReqArg (\string_opt opts -> do
 196             parsed_value <- conversion_fn string_opt
 197             updater_fn parsed_value opts)
 198
 199 -- | Max command length when formatting command list output.
 200 maxCmdLen :: Int
 201 maxCmdLen = 60
 202
 203 -- | Formats the description of various commands.
 204 formatCommands :: (StandardOptions a) => PersonalityList a -> [String]
 205 formatCommands personalities =
 206   -- FIXME: add wrapping of descriptions
 207   map (\(cmd, (_, _, _, desc)) -> printf " %-*s - %s" mlen cmd desc::String) $
 208   sortBy (comparing fst) personalities
 209     where mlen = min maxCmdLen . maximum $ map (length . fst) personalities
 210
 211 -- | Formats usage for a multi-personality program.
 212 formatCmdUsage :: (StandardOptions a) => String -> PersonalityList a -> String
 213 formatCmdUsage prog personalities =
 214   let header = [ printf "Usage: %s {command} [options...] [argument...]" prog
 215                , printf "%s <command> --help to see details, or man %s"
 216                    prog prog
 217                , ""
 218                , "Commands:"
 219                ]
 220       rows = formatCommands personalities
 221   in unlines $ header ++ rows
 222
 223 -- | Displays usage for a program and exits.
 224 showCmdUsage :: (StandardOptions a) =>
 225                 String            -- ^ Program name
 226              -> PersonalityList a -- ^ Personality list
 227              -> Bool              -- ^ Whether the exit code is success or not
 228              -> IO b
 229 showCmdUsage prog personalities success = do
 230   let usage = formatCmdUsage prog personalities
 231   putStr usage
 232   if success
 233     then exitSuccess
 234     else exitWith $ ExitFailure C.exitFailure
 235
 236 -- | Generates completion information for a multi-command binary.
 237 multiCmdCompletion :: (StandardOptions a) => PersonalityList a -> String
 238 multiCmdCompletion personalities =
 239   unlines .
 240   map argComplToText $
 241   map (\(cmd, _) -> ArgCompletion (OptComplChoices [cmd]) 1 (Just 1))
 242     personalities
 243
 244 -- | Displays completion information for a multi-command binary and exits.
 245 showCmdCompletion :: (StandardOptions a) => PersonalityList a -> IO b
 246 showCmdCompletion personalities =
 247   putStr (multiCmdCompletion personalities) >> exitSuccess
 248
 249 -- | Command line parser, using a generic 'Options' structure.
 250 parseOpts :: (StandardOptions a) =>
 251              a                      -- ^ The default options
 252           -> [String]               -- ^ The command line arguments
 253           -> String                 -- ^ The program name
 254           -> [GenericOptType a]     -- ^ The supported command line options
 255           -> [ArgCompletion]        -- ^ The supported command line arguments
 256           -> IO (a, [String])       -- ^ The resulting options and
 257                                     -- leftover arguments
 258 parseOpts defaults argv progname options arguments =
 259   case parseOptsInner defaults argv progname options arguments of
 260     Left (code, msg) -> do
 261       hPutStr (if code == ExitSuccess then stdout else stderr) msg
 262       exitWith code
 263     Right result ->
 264       return result
 265
 266 -- | Command line parser, for programs with sub-commands.
 267 parseOptsCmds :: (StandardOptions a) =>
 268                  a                      -- ^ The default options
 269               -> [String]               -- ^ The command line arguments
 270               -> String                 -- ^ The program name
 271               -> PersonalityList a      -- ^ The supported commands
 272               -> [GenericOptType a]     -- ^ Generic options
 273               -> IO (a, [String], a -> [String] -> IO ())
 274                      -- ^ The resulting options and leftover arguments
 275 parseOptsCmds defaults argv progname personalities genopts = do
 276   let usage = showCmdUsage progname personalities
 277       check c = case c of
 278                   -- hardcoded option strings here!
 279                   "--version" -> putStrLn (versionInfo progname) >> exitSuccess
 280                   "--help"    -> usage True
 281                   "--help-completion" -> showCmdCompletion personalities
 282                   _           -> return c
 283   (cmd, cmd_args) <- case argv of
 284                        cmd:cmd_args -> do
 285                          cmd' <- check cmd
 286                          return (cmd', cmd_args)
 287                        [] -> usage False
 288   case cmd `lookup` personalities of
 289     Nothing -> usage False
 290     Just (mainfn, optdefs, argdefs, _) -> do
 291       optdefs' <- optdefs
 292       (opts, args) <- parseOpts defaults cmd_args progname
 293                       (optdefs' ++ genopts) argdefs
 294       return (opts, args, mainfn)
 295
 296 -- | Inner parse options. The arguments are similar to 'parseOpts',
 297 -- but it returns either a 'Left' composed of exit code and message,
 298 -- or a 'Right' for the success case.
 299 parseOptsInner :: (StandardOptions a) =>
 300                   a
 301                -> [String]
 302                -> String
 303                -> [GenericOptType a]
 304                -> [ArgCompletion]
 305                -> Either (ExitCode, String) (a, [String])
 306 parseOptsInner defaults argv progname options arguments  =
 307   case getOpt Permute (map fst options) argv of
 308     (opts, args, []) ->
 309       case foldM (flip id) defaults opts of
 310            Bad msg -> Left (ExitFailure 1,
 311                             "Error while parsing command line arguments:\n"
 312                             ++ msg ++ "\n")
 313            Ok parsed ->
 314              select (Right (parsed, args))
 315                  [ (helpRequested parsed,
 316                     Left (ExitSuccess, usageHelp progname options))
 317                  , (verRequested parsed,
 318                     Left (ExitSuccess, versionInfo progname))
 319                  , (compRequested parsed,
 320                     Left (ExitSuccess, completionInfo progname options
 321                                          arguments))
 322                  ]
 323     (_, _, errs) ->
 324       Left (ExitFailure 2, "Command line error: "  ++ concat errs ++ "\n" ++
 325             usageHelp progname options)
 326
 327 -- | Parse command line options and execute the main function of a
 328 -- multi-personality binary.
 329 genericMainCmds :: (StandardOptions a) =>
 330                    a
 331                 -> PersonalityList a
 332                 -> [GenericOptType a]
 333                 -> IO ()
 334 genericMainCmds defaults personalities genopts = do
 335   cmd_args <- getArgs
 336   prog <- getProgName
 337   (opts, args, fn) <-
 338     parseOptsCmds defaults cmd_args prog personalities genopts
 339   fn opts args