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