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 <[email protected]> --- Makefile.am | 2 + htest/Test/Ganeti/Errors.hs | 48 ++++++++++++++++++ htest/test.hs | 2 + htools/Ganeti/Errors.hs | 117 +++++++++++++++++++++++++++++++++++++++++++ htools/Ganeti/THH.hs | 108 +++++++++++++++++++++++++++++++++++++++ 5 files changed, 277 insertions(+), 0 deletions(-) create mode 100644 htest/Test/Ganeti/Errors.hs create mode 100644 htools/Ganeti/Errors.hs diff --git a/Makefile.am b/Makefile.am index bd52ba8..1fff370 100644 --- a/Makefile.am +++ b/Makefile.am @@ -415,6 +415,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 \ @@ -464,6 +465,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 \ diff --git a/htest/Test/Ganeti/Errors.hs b/htest/Test/Ganeti/Errors.hs new file mode 100644 index 0000000..3bf7cac --- /dev/null +++ b/htest/Test/Ganeti/Errors.hs @@ -0,0 +1,48 @@ +{-# 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 + ] diff --git a/htest/test.hs b/htest/test.hs index 9100095..e5849a0 100644 --- a/htest/test.hs +++ b/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 diff --git a/htools/Ganeti/Errors.hs b/htools/Ganeti/Errors.hs new file mode 100644 index 0000000..74ffa21 --- /dev/null +++ b/htools/Ganeti/Errors.hs @@ -0,0 +1,117 @@ +{-# 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") diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs index 6436846..bf9802e 100644 --- a/htools/Ganeti/THH.hs +++ b/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]) -- 1.7.7.3
