Synnefo » snf-ganeti

{-| 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.

This program is free software; you can redistribute it and/or modify

it under the terms of the GNU General Public License as published by

the Free Software Foundation; either version 2 of the License, or

(at your option) any later version.

This program is distributed in the hope that it will be useful, but

WITHOUT ANY WARRANTY; without even the implied warranty of

MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU

General Public License for more details.

You should have received a copy of the GNU General Public License

along with this program; if not, write to the Free Software

Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA

02110-1301, USA.

-}

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