Commit 260d0bda authored by Agata Murawska's avatar Agata Murawska
Browse files

Luxi support for Query status in htools


Signed-off-by: default avatarAgata Murawska <agatamurawska@google.com>
Reviewed-by: default avatarIustin Pop <iustin@google.com>
parent 4fbe3851
......@@ -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
......
......@@ -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'
......
......@@ -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.
......
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