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                      )
 100
 101 -- | Personality lists type, common across all binaries that expose
 102 -- multiple personalities.
 103 type PersonalityList  a = [(String, Personality a)]
 104
 105 -- | Yes\/no choices completion.
 106 optComplYesNo :: OptCompletion
 107 optComplYesNo = OptComplChoices ["yes", "no"]
 108
 109 -- | Text serialisation for 'OptCompletion', used on the Python side.
 110 complToText :: OptCompletion -> String
 111 complToText (OptComplChoices choices) = "choices=" ++ intercalate "," choices
 112 complToText (OptComplSuggest choices) = "suggest=" ++ intercalate "," choices
 113 complToText compl =
 114   let show_compl = show compl
 115       stripped = stripPrefix "OptCompl" show_compl
 116   in map toLower $ fromMaybe show_compl stripped
 117
 118 -- | Tex serialisation for 'ArgCompletion'.
 119 argComplToText :: ArgCompletion -> String
 120 argComplToText (ArgCompletion optc min_cnt max_cnt) =
 121   complToText optc ++ " " ++ show min_cnt ++ " " ++ maybe "none" show max_cnt
 122
 123 -- | Abrreviation for the option type.
 124 type GenericOptType a = (OptDescr (a -> Result a), OptCompletion)
 125
 126 -- | Type class for options which support help and version.
 127 class StandardOptions a where
 128   helpRequested :: a -> Bool
 129   verRequested  :: a -> Bool
 130   compRequested :: a -> Bool
 131   requestHelp   :: a -> a
 132   requestVer    :: a -> a
 133   requestComp   :: a -> a
 134
 135 -- | Option to request help output.
 136 oShowHelp :: (StandardOptions a) => GenericOptType a
 137 oShowHelp = (Option "h" ["help"] (NoArg (Ok . requestHelp)) "show help",
 138              OptComplNone)
 139
 140 -- | Option to request version information.
 141 oShowVer :: (StandardOptions a) => GenericOptType a
 142 oShowVer = (Option "V" ["version"] (NoArg (Ok . requestVer))
 143             "show the version of the program",
 144             OptComplNone)
 145
 146 -- | Option to request completion information
 147 oShowComp :: (StandardOptions a) => GenericOptType a
 148 oShowComp =
 149   (Option "" ["help-completion"] (NoArg (Ok . requestComp) )
 150    "show completion info", OptComplNone)
 151
 152 -- | Usage info.
 153 usageHelp :: String -> [GenericOptType a] -> String
 154 usageHelp progname =
 155   usageInfo (printf "%s %s\nUsage: %s [OPTION...]"
 156              progname Version.version progname) . map fst
 157
 158 -- | Show the program version info.
 159 versionInfo :: String -> String
 160 versionInfo progname =
 161   printf "%s %s\ncompiled with %s %s\nrunning on %s %s\n"
 162          progname Version.version compilerName
 163          (Data.Version.showVersion compilerVersion)
 164          os arch
 165
 166 -- | Show completion info.
 167 completionInfo :: String -> [GenericOptType a] -> [ArgCompletion] -> String
 168 completionInfo _ opts args =
 169   unlines $
 170   map (\(Option shorts longs _ _, compinfo) ->
 171          let all_opts = map (\c -> ['-', c]) shorts ++ map ("--" ++) longs
 172          in intercalate "," all_opts ++ " " ++ complToText compinfo
 173       ) opts ++
 174   map argComplToText args
 175
 176 -- | Helper for parsing a yes\/no command line flag.
 177 parseYesNo :: Bool         -- ^ Default value (when we get a @Nothing@)
 178            -> Maybe String -- ^ Parameter value
 179            -> Result Bool  -- ^ Resulting boolean value
 180 parseYesNo v Nothing      = return v
 181 parseYesNo _ (Just "yes") = return True
 182 parseYesNo _ (Just "no")  = return False
 183 parseYesNo _ (Just s)     = fail ("Invalid choice '" ++ s ++
 184                                   "', pass one of 'yes' or 'no'")
 185
 186 -- | Helper function for required arguments which need to be converted
 187 -- as opposed to stored just as string.
 188 reqWithConversion :: (String -> Result a)
 189                   -> (a -> b -> Result b)
 190                   -> String
 191                   -> ArgDescr (b -> Result b)
 192 reqWithConversion conversion_fn updater_fn =
 193   ReqArg (\string_opt opts -> do
 194             parsed_value <- conversion_fn string_opt
 195             updater_fn parsed_value opts)
 196
 197 -- | Max command length when formatting command list output.
 198 maxCmdLen :: Int
 199 maxCmdLen = 60
 200
 201 -- | Formats usage for a multi-personality program.
 202 formatCmdUsage :: (StandardOptions a) => String -> PersonalityList a -> String
 203 formatCmdUsage prog personalities =
 204   let mlen = min maxCmdLen . maximum $ map (length . fst) personalities
 205       sorted = sortBy (comparing fst) personalities
 206       header = [ printf "Usage: %s {command} [options...] [argument...]" prog
 207                , printf "%s <command> --help to see details, or man %s"
 208                    prog prog
 209                , ""
 210                , "Commands:"
 211                ]
 212       rows = map (\(cmd, _) ->
 213                     printf " %-*s" mlen cmd::String) sorted
 214   in unlines $ header ++ rows
 215
 216 -- | Displays usage for a program and exits.
 217 showCmdUsage :: (StandardOptions a) =>
 218                 String            -- ^ Program name
 219              -> PersonalityList a -- ^ Personality list
 220              -> Bool              -- ^ Whether the exit code is success or not
 221              -> IO b
 222 showCmdUsage prog personalities success = do
 223   let usage = formatCmdUsage prog personalities
 224   putStr usage
 225   if success
 226     then exitSuccess
 227     else exitWith $ ExitFailure C.exitFailure
 228
 229 -- | Command line parser, using a generic 'Options' structure.
 230 parseOpts :: (StandardOptions a) =>
 231              a                      -- ^ The default options
 232           -> [String]               -- ^ The command line arguments
 233           -> String                 -- ^ The program name
 234           -> [GenericOptType a]     -- ^ The supported command line options
 235           -> [ArgCompletion]        -- ^ The supported command line arguments
 236           -> IO (a, [String])       -- ^ The resulting options and
 237                                     -- leftover arguments
 238 parseOpts defaults argv progname options arguments =
 239   case parseOptsInner defaults argv progname options arguments of
 240     Left (code, msg) -> do
 241       hPutStr (if code == ExitSuccess then stdout else stderr) msg
 242       exitWith code
 243     Right result ->
 244       return result
 245
 246 -- | Command line parser, for programs with sub-commands.
 247 parseOptsCmds :: (StandardOptions a) =>
 248                  a                      -- ^ The default options
 249               -> [String]               -- ^ The command line arguments
 250               -> String                 -- ^ The program name
 251               -> PersonalityList a      -- ^ The supported commands
 252               -> [GenericOptType a]     -- ^ Generic options
 253               -> IO (a, [String], a -> [String] -> IO ())
 254                      -- ^ The resulting options and leftover arguments
 255 parseOptsCmds defaults argv progname personalities genopts = do
 256   let usage = showCmdUsage progname personalities
 257       check c = case c of
 258                   -- hardcoded option strings here!
 259                   "--version" -> putStrLn (versionInfo progname) >> exitSuccess
 260                   "--help"    -> usage True
 261                   _           -> return c
 262   (cmd, cmd_args) <- case argv of
 263                        cmd:cmd_args -> do
 264                          cmd' <- check cmd
 265                          return (cmd', cmd_args)
 266                        [] -> usage False
 267   case cmd `lookup` personalities of
 268     Nothing -> usage False
 269     Just (mainfn, optdefs, argdefs) -> do
 270       optdefs' <- optdefs
 271       (opts, args) <- parseOpts defaults cmd_args progname
 272                       (optdefs' ++ genopts) argdefs
 273       return (opts, args, mainfn)
 274
 275 -- | Inner parse options. The arguments are similar to 'parseOpts',
 276 -- but it returns either a 'Left' composed of exit code and message,
 277 -- or a 'Right' for the success case.
 278 parseOptsInner :: (StandardOptions a) =>
 279                   a
 280                -> [String]
 281                -> String
 282                -> [GenericOptType a]
 283                -> [ArgCompletion]
 284                -> Either (ExitCode, String) (a, [String])
 285 parseOptsInner defaults argv progname options arguments  =
 286   case getOpt Permute (map fst options) argv of
 287     (opts, args, []) ->
 288       case foldM (flip id) defaults opts of
 289            Bad msg -> Left (ExitFailure 1,
 290                             "Error while parsing command line arguments:\n"
 291                             ++ msg ++ "\n")
 292            Ok parsed ->
 293              select (Right (parsed, args))
 294                  [ (helpRequested parsed,
 295                     Left (ExitSuccess, usageHelp progname options))
 296                  , (verRequested parsed,
 297                     Left (ExitSuccess, versionInfo progname))
 298                  , (compRequested parsed,
 299                     Left (ExitSuccess, completionInfo progname options
 300                                          arguments))
 301                  ]
 302     (_, _, errs) ->
 303       Left (ExitFailure 2, "Command line error: "  ++ concat errs ++ "\n" ++
 304             usageHelp progname options)
 305
 306 -- | Parse command line options and execute the main function of a
 307 -- multi-personality binary.
 308 genericMainCmds :: (StandardOptions a) =>
 309                    a
 310                 -> PersonalityList a
 311                 -> [GenericOptType a]
 312                 -> IO ()
 313 genericMainCmds defaults personalities genopts = do
 314   cmd_args <- getArgs
 315   prog <- getProgName
 316   (opts, args, fn) <-
 317     parseOptsCmds defaults cmd_args prog personalities genopts
 318   fn opts args