diff --git a/htools/Ganeti/HTools/Luxi.hs b/htools/Ganeti/HTools/Luxi.hs
index 1249e22bb1d7c74cf3a2526b428d2883c718227a..4baa98b3b9a0ffd831f559f7c34016cb3aeed9bd 100644
--- a/htools/Ganeti/HTools/Luxi.hs
+++ b/htools/Ganeti/HTools/Luxi.hs
@@ -69,22 +69,28 @@ parseQueryResult o =
fail $ "Invalid query result, expected array but got " ++ show o
-- | Prepare resulting output as parsers expect it.
-extractArray :: (Monad m) => JSValue -> m [JSValue]
+extractArray :: (Monad m) => JSValue -> m [[(JSValue, JSValue)]]
extractArray v =
- getData v >>= parseQueryResult >>= (return . map (JSArray . map snd))
+ getData v >>= parseQueryResult
+
+-- | Testing result status for more verbose error message.
+fromJValWithStatus :: (Text.JSON.JSON a, Monad m) => (JSValue, JSValue) -> m a
+fromJValWithStatus (st, v) = do
+ st' <- fromJVal st
+ L.checkRS st' v >>= fromJVal
-- | Annotate errors when converting values with owner/attribute for
-- better debugging.
genericConvert :: (Text.JSON.JSON a) =>
- String -- ^ The object type
- -> String -- ^ The object name
- -> String -- ^ The attribute we're trying to convert
- -> JSValue -- ^ The value we try to convert
- -> Result a -- ^ The annotated result
+ String -- ^ The object type
+ -> String -- ^ The object name
+ -> String -- ^ The attribute we're trying to convert
+ -> (JSValue, JSValue) -- ^ The value we're trying to convert
+ -> Result a -- ^ The annotated result
genericConvert otype oname oattr =
annotateResult (otype ++ " '" ++ oname ++
"', error while reading attribute '" ++
- oattr ++ "'") . fromJVal
+ oattr ++ "'") . fromJValWithStatus
-- * Data querying functionality
@@ -135,16 +141,16 @@ getInstances ktn arr = extractArray arr >>= mapM (parseInstance ktn)
-- | Construct an instance from a JSON object.
parseInstance :: NameAssoc
- -> JSValue
+ -> [(JSValue, JSValue)]
-> Result (String, Instance.Instance)
-parseInstance ktn (JSArray [ name, disk, mem, vcpus
- , status, pnode, snodes, tags, oram
- , auto_balance, disk_template ]) = do
- xname <- annotateResult "Parsing new instance" (fromJVal name)
+parseInstance ktn [ name, disk, mem, vcpus
+ , status, pnode, snodes, tags, oram
+ , auto_balance, disk_template ] = do
+ xname <- annotateResult "Parsing new instance" (fromJValWithStatus name)
let convert a = genericConvert "Instance" xname a
xdisk <- convert "disk_usage" disk
- xmem <- (case oram of
- JSRational _ _ -> convert "oper_ram" oram
+ xmem <- (case oram of -- FIXME: remove the "guessing"
+ (_, JSRational _ _) -> convert "oper_ram" oram
_ -> convert "be/memory" mem)
xvcpus <- convert "be/vcpus" vcpus
xpnode <- convert "pnode" pnode >>= lookupNode ktn xname
@@ -166,11 +172,11 @@ getNodes :: NameAssoc -> JSValue -> Result [(String, Node.Node)]
getNodes ktg arr = extractArray arr >>= mapM (parseNode ktg)
-- | Construct a node from a JSON object.
-parseNode :: NameAssoc -> JSValue -> Result (String, Node.Node)
-parseNode ktg (JSArray [ name, mtotal, mnode, mfree, dtotal, dfree
- , ctotal, offline, drained, vm_capable, g_uuid ])
+parseNode :: NameAssoc -> [(JSValue, JSValue)] -> Result (String, Node.Node)
+parseNode ktg [ name, mtotal, mnode, mfree, dtotal, dfree
+ , ctotal, offline, drained, vm_capable, g_uuid ]
= do
- xname <- annotateResult "Parsing new node" (fromJVal name)
+ xname <- annotateResult "Parsing new node" (fromJValWithStatus name)
let convert a = genericConvert "Node" xname a
xoffline <- convert "offline" offline
xdrained <- convert "drained" drained
@@ -203,9 +209,9 @@ getGroups :: JSValue -> Result [(String, Group.Group)]
getGroups jsv = extractArray jsv >>= mapM parseGroup
-- | Parses a given group information.
-parseGroup :: JSValue -> Result (String, Group.Group)
-parseGroup (JSArray [uuid, name, apol]) = do
- xname <- annotateResult "Parsing new group" (fromJVal name)
+parseGroup :: [(JSValue, JSValue)] -> Result (String, Group.Group)
+parseGroup [uuid, name, apol] = do
+ xname <- annotateResult "Parsing new group" (fromJValWithStatus name)
let convert a = genericConvert "Group" xname a
xuuid <- convert "uuid" uuid
xapol <- convert "alloc_policy" apol
diff --git a/htools/Ganeti/Luxi.hs b/htools/Ganeti/Luxi.hs
index 20c0b141cbf16c726dbc8090c1fb4982716901eb..ade6c229b08828b111b2fcee6e607f91a2d246a1 100644
--- a/htools/Ganeti/Luxi.hs
+++ b/htools/Ganeti/Luxi.hs
@@ -28,7 +28,9 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
module Ganeti.Luxi
( LuxiOp(..)
, QrViaLuxi(..)
+ , ResultStatus(..)
, Client
+ , checkRS
, getClient
, closeClient
, callMethod
@@ -145,6 +147,23 @@ $(genLuxiOp "LuxiOp"
-- | The serialisation of LuxiOps into strings in messages.
$(genStrOfOp ''LuxiOp "strOfOp")
+$(declareIADT "ResultStatus"
+ [ ("RSNormal", 'rsNormal)
+ , ("RSUnknown", 'rsUnknown)
+ , ("RSNoData", 'rsNodata)
+ , ("RSUnavailable", 'rsUnavail)
+ , ("RSOffline", 'rsOffline)
+ ])
+$(makeJSONInstanceInt ''ResultStatus)
+
+-- | Check that ResultStatus is success or fail with descriptive message.
+checkRS :: (Monad m) => ResultStatus -> a -> m a
+checkRS RSNormal val = return val
+checkRS RSUnknown _ = fail "Unknown field"
+checkRS RSNoData _ = fail "No data for a field"
+checkRS RSUnavailable _ = fail "Ganeti reports unavailable data"
+checkRS RSOffline _ = fail "Ganeti reports resource as offline"
+
-- | The end-of-message separator.
eOM :: Char
eOM = '\3'
diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs
index 6bb377e62baf407d9e109bdc35c0b6f10d8e4cd1..e3c1110a864a671ebc934ac0a4859a4690ae98b5 100644
--- a/htools/Ganeti/THH.hs
+++ b/htools/Ganeti/THH.hs
@@ -30,7 +30,9 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module Ganeti.THH ( declareSADT
+ , declareIADT
, makeJSONInstance
+ , makeJSONInstanceInt
, genOpID
, genOpCode
, noDefault
@@ -68,10 +70,18 @@ showJSONE = varNameE "showJSON"
toStrName :: String -> Name
toStrName = mkName . (++ "ToString") . ensureLower
+-- | ToInt function name.
+toIntName :: String -> Name
+toIntName= mkName . (++ "ToInt") . ensureLower
+
-- | FromString function name.
fromStrName :: String -> Name
fromStrName = mkName . (++ "FromString") . ensureLower
+-- | FromInt function name.
+fromIntName:: String -> Name
+fromIntName = mkName . (++ "FromInt") . ensureLower
+
-- | Converts a name to it's varE/litE representations.
--
reprE :: Either String Name -> Q Exp
@@ -85,6 +95,77 @@ appFn :: Exp -> Exp -> Exp
appFn f x | f == VarE 'id = x
| otherwise = AppE f x
+-- * Template code for simple integer-equivalent ADTs
+
+-- | Generates a data type declaration.
+--
+-- The type will have a fixed list of instances.
+intADTDecl :: Name -> [String] -> Dec
+intADTDecl name constructors =
+ DataD [] name []
+ (map (flip NormalC [] . mkName) constructors)
+ [''Show]
+
+-- | Generates a toInt function.
+genToInt :: Name -> Name -> [(String, Name)] -> Q [Dec]
+genToInt fname tname constructors = do
+ sigt <- [t| $(conT tname) -> Int |]
+ clauses <- mapM (\(c, v) -> clause [recP (mkName c) []]
+ (normalB (varE v)) []) constructors
+ return [SigD fname sigt, FunD fname clauses]
+
+-- | Generates a fromInt function.
+genFromInt :: Name -> Name -> [(String, Name)] -> Q [Dec]
+genFromInt fname tname constructors = do
+ sigt <- [t| (Monad m) => Int-> m $(conT tname) |]
+ let varp = mkName "s"
+ varpe = varE varp
+ clauses <- mapM (\(c, v) -> do
+ g <- normalG [| $varpe == $(varE v) |]
+ r <- [| return $(conE (mkName c)) |]
+ return (g, r)) constructors
+ oth_clause <- do
+ g <- normalG [| otherwise |]
+ r <- [|fail ("Invalid int value for type " ++
+ $(litE (stringL (nameBase tname))) ++ ": " ++ show $varpe) |]
+ return (g, r)
+ let fun = FunD fname [Clause [VarP varp]
+ (GuardedB (clauses++[oth_clause])) []]
+ return [SigD fname sigt, fun]
+
+-- | Generates a data type from a given string format.
+declareIADT:: String -> [(String, Name)] -> Q [Dec]
+declareIADT sname cons = do
+ let name = mkName sname
+ ddecl = intADTDecl name (map fst cons)
+ tostr <- genToInt (toIntName sname) name cons
+ fromstr <- genFromInt (fromIntName sname) name cons
+ return $ ddecl:tostr ++ fromstr
+
+-- | Creates the showJSON member of a JSON instance declaration.
+genShowJSONInt :: String -> Q [Dec]
+genShowJSONInt name = [d| showJSON = JSON.showJSON . $(varE (toIntName name)) |]
+
+-- | Creates the readJSON member of a JSON instance declaration.
+genReadJSONInt :: String -> Q Dec
+genReadJSONInt name = do
+ let s = mkName "s"
+ body <- [| case JSON.readJSON $(varE s) of
+ JSON.Ok s' -> $(varE (fromIntName name)) s'
+ JSON.Error e ->
+ JSON.Error $ "Can't parse int value for type " ++
+ $(stringE name) ++ ": " ++ e
+ |]
+ return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
+
+-- | Generates a JSON instance for a given type.
+makeJSONInstanceInt :: Name -> Q [Dec]
+makeJSONInstanceInt name = do
+ let base = nameBase name
+ showJ <- genShowJSONInt base
+ readJ <- genReadJSONInt base
+ return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) (readJ:showJ)]
+
-- * Template code for simple string-equivalent ADTs
-- | Generates a data type declaration.