Convert option parsing to a monadic flow

This allows us to do verification of option arguments in the assignment
functions themselves.

Ganeti/HTools/CLI.hs

@@ -144,21 +144,21 @@ defaultOptions  = Options
  }
 
 -- | Abrreviation for the option type
-type OptType = OptDescr (Options -> Options)
+type OptType = OptDescr (Options -> Result Options)
 
 oPrintNodes :: OptType
 oPrintNodes = Option "p" ["print-nodes"]
-              (NoArg (\ opts -> opts { optShowNodes = True }))
+              (NoArg (\ opts -> Ok opts { optShowNodes = True }))
               "print the final node list"
 
 oPrintInsts :: OptType
 oPrintInsts = Option "" ["print-instances"]
-              (NoArg (\ opts -> opts { optShowInsts = True }))
+              (NoArg (\ opts -> Ok opts { optShowInsts = True }))
               "print the final instance map"
 
 oPrintCommands :: OptType
 oPrintCommands = Option "C" ["print-commands"]
-                 (OptArg ((\ f opts -> opts { optShowCmds = Just f }) .
+                 (OptArg ((\ f opts -> Ok opts { optShowCmds = Just f }) .
                           fromMaybe "-")
                   "FILE")
                  "print the ganeti command list for reaching the solution,\
@@ -167,126 +167,128 @@ oPrintCommands = Option "C" ["print-commands"]
 
 oOneline :: OptType
 oOneline = Option "o" ["oneline"]
-           (NoArg (\ opts -> opts { optOneline = True }))
+           (NoArg (\ opts -> Ok opts { optOneline = True }))
            "print the ganeti command list for reaching the solution"
 
 oNoHeaders :: OptType
 oNoHeaders = Option "" ["no-headers"]
-             (NoArg (\ opts -> opts { optNoHeaders = True }))
+             (NoArg (\ opts -> Ok opts { optNoHeaders = True }))
              "do not show a header line"
 
 oOutputDir :: OptType
 oOutputDir = Option "d" ["output-dir"]
-             (ReqArg (\ d opts -> opts { optOutPath = d }) "PATH")
+             (ReqArg (\ d opts -> Ok opts { optOutPath = d }) "PATH")
              "directory in which to write output files"
 
 oNodeFile :: OptType
 oNodeFile = Option "n" ["nodes"]
-            (ReqArg (\ f o -> o { optNodeFile = f, optNodeSet = True }) "FILE")
+            (ReqArg (\ f o -> Ok o { optNodeFile = f,
+                                     optNodeSet = True }) "FILE")
             "the node list FILE"
 
 oInstFile :: OptType
 oInstFile = Option "i" ["instances"]
-            (ReqArg (\ f o -> o { optInstFile = f, optInstSet = True }) "FILE")
+            (ReqArg (\ f o -> Ok o { optInstFile = f,
+                                     optInstSet = True }) "FILE")
             "the instance list FILE"
 
 oNodeSim :: OptType
 oNodeSim = Option "" ["simulate"]
-            (ReqArg (\ f o -> o { optNodeSim = Just f }) "SPEC")
+            (ReqArg (\ f o -> Ok o { optNodeSim = Just f }) "SPEC")
             "simulate an empty cluster, given as 'num_nodes,disk,memory,cpus'"
 
 oRapiMaster :: OptType
 oRapiMaster = Option "m" ["master"]
-              (ReqArg (\ m opts -> opts { optMaster = m }) "ADDRESS")
+              (ReqArg (\ m opts -> Ok opts { optMaster = m }) "ADDRESS")
               "collect data via RAPI at the given ADDRESS"
 
 oLuxiSocket :: OptType
 oLuxiSocket = Option "L" ["luxi"]
-              (OptArg ((\ f opts -> opts { optLuxi = Just f }) .
+              (OptArg ((\ f opts -> Ok opts { optLuxi = Just f }) .
                        fromMaybe defaultLuxiSocket) "SOCKET")
               "collect data via Luxi, optionally using the given SOCKET path"
 
 oExecJobs :: OptType
 oExecJobs = Option "X" ["exec"]
-             (NoArg (\ opts -> opts { optExecJobs = True}))
+             (NoArg (\ opts -> Ok opts { optExecJobs = True}))
              "execute the suggested moves via Luxi (only available when using\
              \ it for data gathering"
 
 oVerbose :: OptType
 oVerbose = Option "v" ["verbose"]
-           (NoArg (\ opts -> opts { optVerbose = optVerbose opts + 1 }))
+           (NoArg (\ opts -> Ok opts { optVerbose = optVerbose opts + 1 }))
            "increase the verbosity level"
 
 oQuiet :: OptType
 oQuiet = Option "q" ["quiet"]
-         (NoArg (\ opts -> opts { optVerbose = optVerbose opts - 1 }))
+         (NoArg (\ opts -> Ok opts { optVerbose = optVerbose opts - 1 }))
          "decrease the verbosity level"
 
 oOfflineNode :: OptType
 oOfflineNode = Option "O" ["offline"]
-               (ReqArg (\ n o -> o { optOffline = n:optOffline o }) "NODE")
+               (ReqArg (\ n o -> Ok o { optOffline = n:optOffline o }) "NODE")
                "set node as offline"
 
 oMaxSolLength :: OptType
 oMaxSolLength = Option "l" ["max-length"]
-                (ReqArg (\ i opts -> opts { optMaxLength =  read i::Int }) "N")
+                (ReqArg (\ i opts -> Ok opts { optMaxLength = read i }) "N")
                 "cap the solution at this many moves (useful for very\
                 \ unbalanced clusters)"
 
 oMinScore :: OptType
 oMinScore = Option "e" ["min-score"]
-            (ReqArg (\ e opts -> opts { optMinScore = read e }) "EPSILON")
+            (ReqArg (\ e opts -> Ok opts { optMinScore = read e }) "EPSILON")
             " mininum score to aim for"
 
 oIMem :: OptType
 oIMem = Option "" ["memory"]
-        (ReqArg (\ m opts -> opts { optIMem = read m }) "MEMORY")
+        (ReqArg (\ m opts -> Ok opts { optIMem = read m }) "MEMORY")
         "memory size for instances"
 
 oIDisk :: OptType
 oIDisk = Option "" ["disk"]
-         (ReqArg (\ d opts -> opts { optIDsk = read d }) "DISK")
+         (ReqArg (\ d opts -> Ok opts { optIDsk = read d }) "DISK")
          "disk size for instances"
 
 oIVcpus :: OptType
 oIVcpus = Option "" ["vcpus"]
-          (ReqArg (\ p opts -> opts { optIVCPUs = read p }) "NUM")
+          (ReqArg (\ p opts -> Ok opts { optIVCPUs = read p }) "NUM")
           "number of virtual cpus for instances"
 
 oINodes :: OptType
 oINodes = Option "" ["req-nodes"]
-          (ReqArg (\ n opts -> opts { optINodes = read n }) "NODES")
+          (ReqArg (\ n opts -> Ok opts { optINodes = read n }) "NODES")
           "number of nodes for the new instances (1=plain, 2=mirrored)"
 
 oMaxCpu :: OptType
 oMaxCpu = Option "" ["max-cpu"]
-          (ReqArg (\ n opts -> opts { optMcpu = read n }) "RATIO")
+          (ReqArg (\ n opts -> Ok opts { optMcpu = read n }) "RATIO")
           "maximum virtual-to-physical cpu ratio for nodes"
 
 oMinDisk :: OptType
 oMinDisk = Option "" ["min-disk"]
-           (ReqArg (\ n opts -> opts { optMdsk = read n }) "RATIO")
+           (ReqArg (\ n opts -> Ok opts { optMdsk = read n }) "RATIO")
            "minimum free disk space for nodes (between 0 and 1)"
 
 oDiskMoves :: OptType
 oDiskMoves = Option "" ["no-disk-moves"]
-             (NoArg (\ opts -> opts { optDiskMoves = False}))
+             (NoArg (\ opts -> Ok opts { optDiskMoves = False}))
              "disallow disk moves from the list of allowed instance changes,\
              \ thus allowing only the 'cheap' failover/migrate operations"
 
 oDynuFile :: OptType
 oDynuFile = Option "U" ["dynu-file"]
-            (ReqArg (\ f opts -> opts { optDynuFile = Just f }) "FILE")
+            (ReqArg (\ f opts -> Ok opts { optDynuFile = Just f }) "FILE")
             "Import dynamic utilisation data from the given FILE"
 
 oShowVer :: OptType
 oShowVer = Option "V" ["version"]
-           (NoArg (\ opts -> opts { optShowVer = True}))
+           (NoArg (\ opts -> Ok opts { optShowVer = True}))
            "show the version of the program"
 
 oShowHelp :: OptType
 oShowHelp = Option "h" ["help"]
-            (NoArg (\ opts -> opts { optShowHelp = True}))
+            (NoArg (\ opts -> Ok opts { optShowHelp = True}))
             "show help"
 
 -- | Usage info
@@ -305,7 +307,14 @@ parseOpts argv progname options =
     case getOpt Permute options argv of
       (o, n, []) ->
           do
-            let resu@(po, _) = (foldl (flip id) defaultOptions o, n)
+            let (pr, args) = (foldM (flip id) defaultOptions o, n)
+            po <- (case pr of
+                     Bad msg -> do
+                       hPutStrLn stderr "Error while parsing command\
+                                        \line arguments:"
+                       hPutStrLn stderr msg
+                       exitWith $ ExitFailure 1
+                     Ok val -> return val)
             when (optShowHelp po) $ do
               putStr $ usageHelp progname options
               exitWith ExitSuccess
@@ -315,7 +324,7 @@ parseOpts argv progname options =
                      compilerName (Data.Version.showVersion compilerVersion)
                      os arch
               exitWith ExitSuccess
-            return resu
+            return (po, args)
       (_, _, errs) -> do
         hPutStrLn stderr $ "Command line error: "  ++ concat errs
         hPutStrLn stderr $ usageHelp progname options