X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/22278fa7b6f4034d265edfbd70695750165bae26..638e0a6fe04e5973e0bb8ffbe444944d712dcf9b:/htools/Ganeti/Common.hs

diff --git a/htools/Ganeti/Common.hs b/htools/Ganeti/Common.hs
index 94e256d..cd82889 100644
--- a/htools/Ganeti/Common.hs
+++ b/htools/Ganeti/Common.hs
@@ -31,6 +31,7 @@ module Ganeti.Common
   , StandardOptions(..)
   , OptCompletion(..)
   , ArgCompletion(..)
+  , PersonalityList
   , optComplYesNo
   , oShowHelp
   , oShowVer
@@ -41,20 +42,25 @@ module Ganeti.Common
   , parseYesNo
   , parseOpts
   , parseOptsInner
+  , parseOptsCmds
+  , genericMainCmds
   ) where
 
 import Control.Monad (foldM)
 import Data.Char (toLower)
-import Data.List (intercalate, stripPrefix)
+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 qualified Ganeti.Version as Version (version)
 
 -- | Parameter type.
@@ -71,19 +77,31 @@ data OptCompletion = OptComplNone             -- ^ No parameter to this option
                    | OptComplOneIallocator    -- ^ One iallocator
                    | OptComplInstAddNodes     -- ^ Either one or two nodes
                    | OptComplOneGroup         -- ^ One group
-                   | OptComplNumeric          -- ^ Float values
+                   | 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, Read, Eq)
+                   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, Read, Eq)
+                     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
@@ -177,6 +195,52 @@ reqWithConversion conversion_fn updater_fn =
             parsed_value <- conversion_fn string_opt
             updater_fn parsed_value opts)
 
+-- | Max command length when formatting command list output.
+maxCmdLen :: Int
+maxCmdLen = 60
+
+-- | Formats usage for a multi-personality program.
+formatCmdUsage :: (StandardOptions a) => String -> PersonalityList a -> String
+formatCmdUsage prog personalities =
+  let mlen = min maxCmdLen . maximum $ map (length . fst) personalities
+      sorted = sortBy (comparing fst) personalities
+      header = [ printf "Usage: %s {command} [options...] [argument...]" prog
+               , printf "%s <command> --help to see details, or man %s"
+                   prog prog
+               , ""
+               , "Commands:"
+               ]
+      rows = map (\(cmd, (_, _, _, desc)) ->
+                    -- FIXME: not wrapped here
+                    printf " %-*s - %s" mlen cmd desc::String) sorted
+  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 =
+  unlines .
+  map argComplToText $
+  map (\(cmd, _) -> ArgCompletion (OptComplChoices [cmd]) 1 (Just 1))
+    personalities
+
+-- | Displays completion information for a multi-command binary and exits.
+showCmdCompletion :: (StandardOptions a) => PersonalityList a -> IO b
+showCmdCompletion personalities =
+  putStr (multiCmdCompletion personalities) >> exitSuccess
+
 -- | Command line parser, using a generic 'Options' structure.
 parseOpts :: (StandardOptions a) =>
              a                      -- ^ The default options
@@ -194,6 +258,36 @@ parseOpts defaults argv progname options arguments =
     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.
@@ -224,3 +318,17 @@ parseOptsInner defaults argv 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