Revision ef3ad027

b/Makefile.am
426 426
	htools/Ganeti/Confd/Utils.hs \
427 427
	htools/Ganeti/Config.hs \
428 428
	htools/Ganeti/Daemon.hs \
429
	htools/Ganeti/Errors.hs \
429 430
	htools/Ganeti/HTools/CLI.hs \
430 431
	htools/Ganeti/HTools/Cluster.hs \
431 432
	htools/Ganeti/HTools/Container.hs \
......
475 476
	htest/Test/Ganeti/Common.hs \
476 477
	htest/Test/Ganeti/Confd/Utils.hs \
477 478
	htest/Test/Ganeti/Daemon.hs \
479
	htest/Test/Ganeti/Errors.hs \
478 480
	htest/Test/Ganeti/HTools/CLI.hs \
479 481
	htest/Test/Ganeti/HTools/Cluster.hs \
480 482
	htest/Test/Ganeti/HTools/Container.hs \
b/htest/Test/Ganeti/Errors.hs
1
{-# LANGUAGE TemplateHaskell #-}
2
{-# OPTIONS_GHC -fno-warn-orphans #-}
3

  
4
{-| Unittests for "Ganeti.Errors".
5

  
6
-}
7

  
8
{-
9

  
10
Copyright (C) 2012 Google Inc.
11

  
12
This program is free software; you can redistribute it and/or modify
13
it under the terms of the GNU General Public License as published by
14
the Free Software Foundation; either version 2 of the License, or
15
(at your option) any later version.
16

  
17
This program is distributed in the hope that it will be useful, but
18
WITHOUT ANY WARRANTY; without even the implied warranty of
19
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
20
General Public License for more details.
21

  
22
You should have received a copy of the GNU General Public License
23
along with this program; if not, write to the Free Software
24
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
25
02110-1301, USA.
26

  
27
-}
28

  
29
module Test.Ganeti.Errors (testErrors) where
30

  
31
import Test.QuickCheck
32

  
33
import Test.Ganeti.TestHelper
34
import Test.Ganeti.TestCommon
35

  
36
import qualified Ganeti.Errors as Errors
37

  
38
$(genArbitrary ''Errors.ErrorCode)
39

  
40
$(genArbitrary ''Errors.GanetiException)
41

  
42
-- | Tests error serialisation.
43
prop_GenericError_serialisation :: Errors.GanetiException -> Property
44
prop_GenericError_serialisation = testSerialisation
45

  
46
testSuite "Errors"
47
          [ 'prop_GenericError_serialisation
48
          ]
b/htest/test.hs
34 34
import Test.Ganeti.Confd.Utils
35 35
import Test.Ganeti.Common
36 36
import Test.Ganeti.Daemon
37
import Test.Ganeti.Errors
37 38
import Test.Ganeti.HTools.CLI
38 39
import Test.Ganeti.HTools.Cluster
39 40
import Test.Ganeti.HTools.Container
......
75 76
  , testCommon
76 77
  , testConfd_Utils
77 78
  , testDaemon
79
  , testErrors
78 80
  , testHTools_CLI
79 81
  , testHTools_Cluster
80 82
  , testHTools_Container
b/htools/Ganeti/Errors.hs
1
{-# LANGUAGE TemplateHaskell #-}
2

  
3
{-| Implementation of the Ganeti error types.
4

  
5
This module implements our error hierarchy. Currently we implement one
6
identical to the Python one; later we might one to have separate ones
7
for frontend (clients), master and backend code.
8

  
9
-}
10

  
11
{-
12

  
13
Copyright (C) 2012 Google Inc.
14

  
15
This program is free software; you can redistribute it and/or modify
16
it under the terms of the GNU General Public License as published by
17
the Free Software Foundation; either version 2 of the License, or
18
(at your option) any later version.
19

  
20
This program is distributed in the hope that it will be useful, but
21
WITHOUT ANY WARRANTY; without even the implied warranty of
22
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
23
General Public License for more details.
24

  
25
You should have received a copy of the GNU General Public License
26
along with this program; if not, write to the Free Software
27
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
28
02110-1301, USA.
29

  
30
-}
31

  
32
module Ganeti.Errors
33
  ( ErrorCode(..)
34
  , GanetiException(..)
35
  , ErrorResult
36
  , excName
37
  ) where
38

  
39
import Text.JSON hiding (Result, Ok)
40

  
41
import Ganeti.THH
42
import Ganeti.BasicTypes
43
import qualified Ganeti.Constants as C
44

  
45
-- | Error code types for 'OpPrereqError'.
46
$(declareSADT "ErrorCode"
47
  [ ("ECodeResolver",  'C.errorsEcodeResolver)
48
  , ("ECodeNoRes",     'C.errorsEcodeNores)
49
  , ("ECodeInval",     'C.errorsEcodeInval)
50
  , ("ECodeState",     'C.errorsEcodeState)
51
  , ("ECodeNoEnt",     'C.errorsEcodeNoent)
52
  , ("ECodeExists",    'C.errorsEcodeExists)
53
  , ("ECodeNotUnique", 'C.errorsEcodeNotunique)
54
  , ("ECodeFault",     'C.errorsEcodeFault)
55
  , ("ECodeEnviron",   'C.errorsEcodeEnviron)
56
  ])
57
$(makeJSONInstance ''ErrorCode)
58

  
59
$(genException "GanetiException"
60
  [ ("GenericError", [excErrMsg])
61
  , ("LockError", [excErrMsg])
62
  , ("PidFileLockError", [excErrMsg])
63
  , ("HypervisorError", [excErrMsg])
64
  , ("ProgrammerError", [excErrMsg])
65
  , ("BlockDeviceError", [excErrMsg])
66
  , ("ConfigurationError", [excErrMsg])
67
  , ("ConfigVersionMismatch", [ ("expCode", [t| Int |])
68
                              , ("actCode", [t| Int |])])
69
  , ("ReservationError", [excErrMsg])
70
  , ("RemoteError", [excErrMsg])
71
  , ("SignatureError", [excErrMsg])
72
  , ("ParameterError", [excErrMsg])
73
  , ("ResultValidationError", [excErrMsg])
74
  , ("OpPrereqError", [excErrMsg, ("errCode", [t| ErrorCode |])])
75
  , ("OpExecError", [excErrMsg])
76
  , ("OpResultError", [excErrMsg])
77
  , ("OpCodeUnknown", [excErrMsg])
78
  , ("JobLost", [excErrMsg])
79
  , ("JobFileCorrupted", [excErrMsg])
80
  , ("ResolverError", [ ("errHostname", [t| String |])
81
                      , ("errResolverCode", [t| Int |])
82
                      , ("errResolverMsg", [t| String |])])
83
  , ("HooksFailure", [excErrMsg])
84
  , ("HooksAbort", [("errs", [t| [(String, String, String)] |])])
85
  , ("UnitParseError", [excErrMsg])
86
  , ("ParseError", [excErrMsg])
87
  , ("TypeEnforcementError", [excErrMsg])
88
  , ("X509CertError", [excErrMsg])
89
  , ("TagError", [excErrMsg])
90
  , ("CommandError", [excErrMsg])
91
  , ("StorageError", [excErrMsg])
92
  , ("InotifyError", [excErrMsg])
93
  , ("JobQueueError", [excErrMsg])
94
  , ("JobQueueDrainError", [excErrMsg])
95
  , ("JobQueueFull", [])
96
  , ("ConfdMagicError", [excErrMsg])
97
  , ("ConfdClientError", [excErrMsg])
98
  , ("UdpDataSizeError", [excErrMsg])
99
  , ("NoCtypesError", [excErrMsg])
100
  , ("IPAddressError", [excErrMsg])
101
  , ("LuxiError", [excErrMsg])
102
  , ("QueryFilterParseError", [excErrMsg]) -- not consistent with Python
103
  , ("RapiTestResult", [excErrMsg])
104
  , ("FileStoragePathError", [excErrMsg])
105
  ])
106

  
107
instance JSON GanetiException where
108
  showJSON = saveGanetiException
109
  readJSON = loadGanetiException
110

  
111
instance FromString GanetiException where
112
  mkFromString = GenericError
113

  
114
-- | Error monad using 'GanetiException' type alias.
115
type ErrorResult = GenericResult GanetiException
116

  
117
$(genStrOfOp ''GanetiException "excName")
b/htools/Ganeti/THH.hs
53 53
                  , buildObjectSerialisation
54 54
                  , buildParam
55 55
                  , DictObject(..)
56
                  , genException
57
                  , excErrMsg
56 58
                  ) where
57 59

  
58 60
import Control.Monad (liftM)
......
63 65
import Language.Haskell.TH
64 66

  
65 67
import qualified Text.JSON as JSON
68
import Text.JSON.Pretty (pp_value)
66 69

  
67 70
-- * Exported types
68 71

  
......
881 884
                (NormalB $ LetE (le_full:le_part:le_new) obj_new) []
882 885
      fun = FunD fun_name [fclause]
883 886
  return [sig, fun]
887

  
888
-- * Template code for exceptions
889

  
890
-- | Exception simple error message field.
891
excErrMsg :: (String, Q Type)
892
excErrMsg = ("errMsg", [t| String |])
893

  
894
-- | Builds an exception type definition.
895
genException :: String                  -- ^ Name of new type
896
             -> SimpleObject -- ^ Constructor name and parameters
897
             -> Q [Dec]
898
genException name cons = do
899
  let tname = mkName name
900
  declD <- buildSimpleCons tname cons
901
  (savesig, savefn) <- genSaveSimpleObj tname ("save" ++ name) cons $
902
                         uncurry saveExcCons
903
  (loadsig, loadfn) <- genLoadExc tname ("load" ++ name) cons
904
  return [declD, loadsig, loadfn, savesig, savefn]
905

  
906
-- | Generates the \"save\" clause for an entire exception constructor.
907
--
908
-- This matches the exception with variables named the same as the
909
-- constructor fields (just so that the spliced in code looks nicer),
910
-- and calls showJSON on it.
911
saveExcCons :: String        -- ^ The constructor name
912
            -> [SimpleField] -- ^ The parameter definitions for this
913
                             -- constructor
914
            -> Q Clause      -- ^ Resulting clause
915
saveExcCons sname fields = do
916
  let cname = mkName sname
917
  fnames <- mapM (newName . fst) fields
918
  let pat = conP cname (map varP fnames)
919
      felems = if null fnames
920
                 then conE '() -- otherwise, empty list has no type
921
                 else listE $ map (\f -> [| JSON.showJSON $(varE f) |]) fnames
922
  let tup = tupE [ litE (stringL sname), felems ]
923
  clause [pat] (normalB [| JSON.showJSON $tup |]) []
924

  
925
-- | Generates load code for a single constructor of an exception.
926
--
927
-- Generates the code (if there's only one argument, we will use a
928
-- list, not a tuple:
929
--
930
-- @
931
-- do
932
--  (x1, x2, ...) <- readJSON args
933
--  return $ Cons x1 x2 ...
934
-- @
935
loadExcConstructor :: Name -> String -> [SimpleField] -> Q Exp
936
loadExcConstructor inname sname fields = do
937
  let name = mkName sname
938
  f_names <- mapM (newName . fst) fields
939
  let read_args = AppE (VarE 'JSON.readJSON) (VarE inname)
940
  let binds = case f_names of
941
                [x] -> BindS (ListP [VarP x])
942
                _   -> BindS (TupP (map VarP f_names))
943
      cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) f_names
944
  return $ DoE [binds read_args, NoBindS (AppE (VarE 'return) cval)]
945

  
946
{-| Generates the loadException function.
947

  
948
This generates a quite complicated function, along the lines of:
949

  
950
@
951
loadFn (JSArray [JSString name, args]) = case name of
952
   "A1" -> do
953
     (x1, x2, ...) <- readJSON args
954
     return $ A1 x1 x2 ...
955
   "a2" -> ...
956
   s -> fail $ "Unknown exception" ++ s
957
loadFn v = fail $ "Expected array but got " ++ show v
958
@
959
-}
960
genLoadExc :: Name -> String -> SimpleObject -> Q (Dec, Dec)
961
genLoadExc tname sname opdefs = do
962
  let fname = mkName sname
963
  exc_name <- newName "name"
964
  exc_args <- newName "args"
965
  exc_else <- newName "s"
966
  arg_else <- newName "v"
967
  fails <- [| fail $ "Unknown exception '" ++ $(varE exc_else) ++ "'" |]
968
  -- default match for unknown exception name
969
  let defmatch = Match (VarP exc_else) (NormalB fails) []
970
  -- the match results (per-constructor blocks)
971
  str_matches <-
972
    mapM (\(s, params) -> do
973
            body_exp <- loadExcConstructor exc_args s params
974
            return $ Match (LitP (StringL s)) (NormalB body_exp) [])
975
    opdefs
976
  -- the first function clause; we can't use [| |] due to TH
977
  -- limitations, so we have to build the AST by hand
978
  let clause1 = Clause [ConP 'JSON.JSArray
979
                               [ListP [ConP 'JSON.JSString [VarP exc_name],
980
                                            VarP exc_args]]]
981
                (NormalB (CaseE (AppE (VarE 'JSON.fromJSString)
982
                                        (VarE exc_name))
983
                          (str_matches ++ [defmatch]))) []
984
  -- the fail expression for the second function clause
985
  fail_type <- [| fail $ "Invalid exception: expected '(string, [args])' " ++
986
                  "      but got " ++ show (pp_value $(varE arg_else)) ++ "'"
987
                |]
988
  -- the second function clause
989
  let clause2 = Clause [VarP arg_else] (NormalB fail_type) []
990
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT tname) |]
991
  return $ (SigD fname sigt, FunD fname [clause1, clause2])

Also available in: Unified diff