Add an Errors module mirroring the Python one

As described in the module doc string, while writing this it dawned
upon me that we're mixing all errors together into a single hierarchy
(well, type on the Haskell side), which is not good. Some errors are
used purely within noded, some in the CLI frontends, etc. so these
should not be the same type; frontend functions should only be able to
raise frontend errors, not backend ones.

As to this patch itself, I've used again Template Haskell to generate
both the data type and the serialisation functions, as the initial
version, hand-written, seemed too prone to errors due to string
matching.

A small unittest for checking serialisation consistency is also added.

Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Guido Trotter <ultrotter@google.com>

Makefile.am

@@ -426,6 +426,7 @@ HS_LIB_SRCS = \
 	htools/Ganeti/Confd/Utils.hs \
 	htools/Ganeti/Config.hs \
 	htools/Ganeti/Daemon.hs \
+	htools/Ganeti/Errors.hs \
 	htools/Ganeti/HTools/CLI.hs \
 	htools/Ganeti/HTools/Cluster.hs \
 	htools/Ganeti/HTools/Container.hs \
@@ -475,6 +476,7 @@ HS_TEST_SRCS = \
 	htest/Test/Ganeti/Common.hs \
 	htest/Test/Ganeti/Confd/Utils.hs \
 	htest/Test/Ganeti/Daemon.hs \
+	htest/Test/Ganeti/Errors.hs \
 	htest/Test/Ganeti/HTools/CLI.hs \
 	htest/Test/Ganeti/HTools/Cluster.hs \
 	htest/Test/Ganeti/HTools/Container.hs \

htest/Test/Ganeti/Errors.hs

+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{-| Unittests for "Ganeti.Errors".
+
+-}
+
+{-
+
+Copyright (C) 2012 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 Test.Ganeti.Errors (testErrors) where
+
+import Test.QuickCheck
+
+import Test.Ganeti.TestHelper
+import Test.Ganeti.TestCommon
+
+import qualified Ganeti.Errors as Errors
+
+$(genArbitrary ''Errors.ErrorCode)
+
+$(genArbitrary ''Errors.GanetiException)
+
+-- | Tests error serialisation.
+prop_GenericError_serialisation :: Errors.GanetiException -> Property
+prop_GenericError_serialisation = testSerialisation
+
+testSuite "Errors"
+          [ 'prop_GenericError_serialisation
+          ]

htest/test.hs

@@ -34,6 +34,7 @@ import Test.Ganeti.BasicTypes
 import Test.Ganeti.Confd.Utils
 import Test.Ganeti.Common
 import Test.Ganeti.Daemon
+import Test.Ganeti.Errors
 import Test.Ganeti.HTools.CLI
 import Test.Ganeti.HTools.Cluster
 import Test.Ganeti.HTools.Container
@@ -75,6 +76,7 @@ allTests =
   , testCommon
   , testConfd_Utils
   , testDaemon
+  , testErrors
   , testHTools_CLI
   , testHTools_Cluster
   , testHTools_Container

htools/Ganeti/Errors.hs

+{-# LANGUAGE TemplateHaskell #-}
+
+{-| Implementation of the Ganeti error types.
+
+This module implements our error hierarchy. Currently we implement one
+identical to the Python one; later we might one to have separate ones
+for frontend (clients), master and backend code.
+
+-}
+
+{-
+
+Copyright (C) 2012 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.Errors
+  ( ErrorCode(..)
+  , GanetiException(..)
+  , ErrorResult
+  , excName
+  ) where
+
+import Text.JSON hiding (Result, Ok)
+
+import Ganeti.THH
+import Ganeti.BasicTypes
+import qualified Ganeti.Constants as C
+
+-- | Error code types for 'OpPrereqError'.
+$(declareSADT "ErrorCode"
+  [ ("ECodeResolver",  'C.errorsEcodeResolver)
+  , ("ECodeNoRes",     'C.errorsEcodeNores)
+  , ("ECodeInval",     'C.errorsEcodeInval)
+  , ("ECodeState",     'C.errorsEcodeState)
+  , ("ECodeNoEnt",     'C.errorsEcodeNoent)
+  , ("ECodeExists",    'C.errorsEcodeExists)
+  , ("ECodeNotUnique", 'C.errorsEcodeNotunique)
+  , ("ECodeFault",     'C.errorsEcodeFault)
+  , ("ECodeEnviron",   'C.errorsEcodeEnviron)
+  ])
+$(makeJSONInstance ''ErrorCode)
+
+$(genException "GanetiException"
+  [ ("GenericError", [excErrMsg])
+  , ("LockError", [excErrMsg])
+  , ("PidFileLockError", [excErrMsg])
+  , ("HypervisorError", [excErrMsg])
+  , ("ProgrammerError", [excErrMsg])
+  , ("BlockDeviceError", [excErrMsg])
+  , ("ConfigurationError", [excErrMsg])
+  , ("ConfigVersionMismatch", [ ("expCode", [t| Int |])
+                              , ("actCode", [t| Int |])])
+  , ("ReservationError", [excErrMsg])
+  , ("RemoteError", [excErrMsg])
+  , ("SignatureError", [excErrMsg])
+  , ("ParameterError", [excErrMsg])
+  , ("ResultValidationError", [excErrMsg])
+  , ("OpPrereqError", [excErrMsg, ("errCode", [t| ErrorCode |])])
+  , ("OpExecError", [excErrMsg])
+  , ("OpResultError", [excErrMsg])
+  , ("OpCodeUnknown", [excErrMsg])
+  , ("JobLost", [excErrMsg])
+  , ("JobFileCorrupted", [excErrMsg])
+  , ("ResolverError", [ ("errHostname", [t| String |])
+                      , ("errResolverCode", [t| Int |])
+                      , ("errResolverMsg", [t| String |])])
+  , ("HooksFailure", [excErrMsg])
+  , ("HooksAbort", [("errs", [t| [(String, String, String)] |])])
+  , ("UnitParseError", [excErrMsg])
+  , ("ParseError", [excErrMsg])
+  , ("TypeEnforcementError", [excErrMsg])
+  , ("X509CertError", [excErrMsg])
+  , ("TagError", [excErrMsg])
+  , ("CommandError", [excErrMsg])
+  , ("StorageError", [excErrMsg])
+  , ("InotifyError", [excErrMsg])
+  , ("JobQueueError", [excErrMsg])
+  , ("JobQueueDrainError", [excErrMsg])
+  , ("JobQueueFull", [])
+  , ("ConfdMagicError", [excErrMsg])
+  , ("ConfdClientError", [excErrMsg])
+  , ("UdpDataSizeError", [excErrMsg])
+  , ("NoCtypesError", [excErrMsg])
+  , ("IPAddressError", [excErrMsg])
+  , ("LuxiError", [excErrMsg])
+  , ("QueryFilterParseError", [excErrMsg]) -- not consistent with Python
+  , ("RapiTestResult", [excErrMsg])
+  , ("FileStoragePathError", [excErrMsg])
+  ])
+
+instance JSON GanetiException where
+  showJSON = saveGanetiException
+  readJSON = loadGanetiException
+
+instance FromString GanetiException where
+  mkFromString = GenericError
+
+-- | Error monad using 'GanetiException' type alias.
+type ErrorResult = GenericResult GanetiException
+
+$(genStrOfOp ''GanetiException "excName")

htools/Ganeti/THH.hs

@@ -53,6 +53,8 @@ module Ganeti.THH ( declareSADT
                   , buildObjectSerialisation
                   , buildParam
                   , DictObject(..)
+                  , genException
+                  , excErrMsg
                   ) where
 
 import Control.Monad (liftM)
@@ -63,6 +65,7 @@ import qualified Data.Set as Set
 import Language.Haskell.TH
 
 import qualified Text.JSON as JSON
+import Text.JSON.Pretty (pp_value)
 
 -- * Exported types
 
@@ -881,3 +884,108 @@ fillParam sname field_pfx fields = do
                 (NormalB $ LetE (le_full:le_part:le_new) obj_new) []
       fun = FunD fun_name [fclause]
   return [sig, fun]
+
+-- * Template code for exceptions
+
+-- | Exception simple error message field.
+excErrMsg :: (String, Q Type)
+excErrMsg = ("errMsg", [t| String |])
+
+-- | Builds an exception type definition.
+genException :: String                  -- ^ Name of new type
+             -> SimpleObject -- ^ Constructor name and parameters
+             -> Q [Dec]
+genException name cons = do
+  let tname = mkName name
+  declD <- buildSimpleCons tname cons
+  (savesig, savefn) <- genSaveSimpleObj tname ("save" ++ name) cons $
+                         uncurry saveExcCons
+  (loadsig, loadfn) <- genLoadExc tname ("load" ++ name) cons
+  return [declD, loadsig, loadfn, savesig, savefn]
+
+-- | Generates the \"save\" clause for an entire exception constructor.
+--
+-- This matches the exception with variables named the same as the
+-- constructor fields (just so that the spliced in code looks nicer),
+-- and calls showJSON on it.
+saveExcCons :: String        -- ^ The constructor name
+            -> [SimpleField] -- ^ The parameter definitions for this
+                             -- constructor
+            -> Q Clause      -- ^ Resulting clause
+saveExcCons sname fields = do
+  let cname = mkName sname
+  fnames <- mapM (newName . fst) fields
+  let pat = conP cname (map varP fnames)
+      felems = if null fnames
+                 then conE '() -- otherwise, empty list has no type
+                 else listE $ map (\f -> [| JSON.showJSON $(varE f) |]) fnames
+  let tup = tupE [ litE (stringL sname), felems ]
+  clause [pat] (normalB [| JSON.showJSON $tup |]) []
+
+-- | Generates load code for a single constructor of an exception.
+--
+-- Generates the code (if there's only one argument, we will use a
+-- list, not a tuple:
+--
+-- @
+-- do
+--  (x1, x2, ...) <- readJSON args
+--  return $ Cons x1 x2 ...
+-- @
+loadExcConstructor :: Name -> String -> [SimpleField] -> Q Exp
+loadExcConstructor inname sname fields = do
+  let name = mkName sname
+  f_names <- mapM (newName . fst) fields
+  let read_args = AppE (VarE 'JSON.readJSON) (VarE inname)
+  let binds = case f_names of
+                [x] -> BindS (ListP [VarP x])
+                _   -> BindS (TupP (map VarP f_names))
+      cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) f_names
+  return $ DoE [binds read_args, NoBindS (AppE (VarE 'return) cval)]
+
+{-| Generates the loadException function.
+
+This generates a quite complicated function, along the lines of:
+
+@
+loadFn (JSArray [JSString name, args]) = case name of
+   "A1" -> do
+     (x1, x2, ...) <- readJSON args
+     return $ A1 x1 x2 ...
+   "a2" -> ...
+   s -> fail $ "Unknown exception" ++ s
+loadFn v = fail $ "Expected array but got " ++ show v
+@
+-}
+genLoadExc :: Name -> String -> SimpleObject -> Q (Dec, Dec)
+genLoadExc tname sname opdefs = do
+  let fname = mkName sname
+  exc_name <- newName "name"
+  exc_args <- newName "args"
+  exc_else <- newName "s"
+  arg_else <- newName "v"
+  fails <- [| fail $ "Unknown exception '" ++ $(varE exc_else) ++ "'" |]
+  -- default match for unknown exception name
+  let defmatch = Match (VarP exc_else) (NormalB fails) []
+  -- the match results (per-constructor blocks)
+  str_matches <-
+    mapM (\(s, params) -> do
+            body_exp <- loadExcConstructor exc_args s params
+            return $ Match (LitP (StringL s)) (NormalB body_exp) [])
+    opdefs
+  -- the first function clause; we can't use [| |] due to TH
+  -- limitations, so we have to build the AST by hand
+  let clause1 = Clause [ConP 'JSON.JSArray
+                               [ListP [ConP 'JSON.JSString [VarP exc_name],
+                                            VarP exc_args]]]
+                (NormalB (CaseE (AppE (VarE 'JSON.fromJSString)
+                                        (VarE exc_name))
+                          (str_matches ++ [defmatch]))) []
+  -- the fail expression for the second function clause
+  fail_type <- [| fail $ "Invalid exception: expected '(string, [args])' " ++
+                  "      but got " ++ show (pp_value $(varE arg_else)) ++ "'"
+                |]
+  -- the second function clause
+  let clause2 = Clause [VarP arg_else] (NormalB fail_type) []
+  sigt <- [t| JSON.JSValue -> JSON.Result $(conT tname) |]
+  return $ (SigD fname sigt, FunD fname [clause1, clause2])