Commit ef3ad027 authored by Iustin Pop's avatar Iustin Pop

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: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarGuido Trotter <ultrotter@google.com>
parent 185b5b0d
......@@ -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 \
......
{-# 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
]
......@@ -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
......
{-# 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")
......@@ -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])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment