Commit 92678b3c authored by Iustin Pop's avatar Iustin Pop
Browse files

Haskell support for generic Query in Luxi



Untill now htools did not have support for generic Query in Luxi. This
patch introduces Query as a supported Luxi operation and replaces
QueryNodes, QueryInstances and QueryGroups with Query.
Signed-off-by: default avatarAgata Murawska <agatamurawska@google.com>
Signed-off-by: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarIustin Pop <iustin@google.com>
parent 9d74cb04
......@@ -50,6 +50,31 @@ toArray v =
JSArray arr -> return arr
o -> fail ("Invalid input, expected array but got " ++ show o)
-- | Get values behind \"data\" part of the result.
getData :: (Monad m) => JSValue -> m JSValue
getData v =
case v of
JSObject o ->
case fromJSObject o of
[("data", jsdata), ("fields", _)] -> return jsdata
x -> fail $ "Invalid input, expected two-element list but got "
++ show x
x -> fail ("Invalid input, expected dict entry but got " ++ show x)
-- | Get [(status, value)] list for each element queried.
toPairs :: (Monad m) => JSValue -> m [[(JSValue, JSValue)]]
toPairs (JSArray arr) = do
arr' <- mapM toArray arr -- list of resulting elements
arr'' <- mapM (mapM toArray) arr' -- list of list of [status, value]
return $ map (map (\a -> (a!!0, a!!1))) arr'' -- FIXME: hackish
toPairs o = fail ("Invalid input, expected array but got " ++ show o)
-- | Prepare resulting output as parsers expect it.
extractArray :: (Monad m) => JSValue -> m [JSValue]
extractArray v = do
arr <- getData v >>= toPairs
return $ map (JSArray. map snd) arr
-- | Annotate errors when converting values with owner/attribute for
-- better debugging.
genericConvert :: (Text.JSON.JSON a) =>
......@@ -68,16 +93,16 @@ genericConvert otype oname oattr =
-- | The input data for node query.
queryNodesMsg :: L.LuxiOp
queryNodesMsg =
L.QueryNodes [] ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree",
"ctotal", "offline", "drained", "vm_capable",
"group.uuid"] False
L.Query L.QRNode ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree",
"ctotal", "offline", "drained", "vm_capable",
"group.uuid"] Nothing
-- | The input data for instance query.
queryInstancesMsg :: L.LuxiOp
queryInstancesMsg =
L.QueryInstances [] ["name", "disk_usage", "be/memory", "be/vcpus",
"status", "pnode", "snodes", "tags", "oper_ram",
"be/auto_balance", "disk_template"] False
L.Query L.QRInstance ["name", "disk_usage", "be/memory", "be/vcpus",
"status", "pnode", "snodes", "tags", "oper_ram",
"be/auto_balance", "disk_template"] Nothing
-- | The input data for cluster query.
queryClusterInfoMsg :: L.LuxiOp
......@@ -86,7 +111,7 @@ queryClusterInfoMsg = L.QueryClusterInfo
-- | The input data for node group query.
queryGroupsMsg :: L.LuxiOp
queryGroupsMsg =
L.QueryGroups [] ["uuid", "name", "alloc_policy"] False
L.Query L.QRGroup ["uuid", "name", "alloc_policy"] Nothing
-- | Wraper over 'callMethod' doing node query.
queryNodes :: L.Client -> IO (Result JSValue)
......@@ -108,7 +133,7 @@ queryGroups = L.callMethod queryGroupsMsg
getInstances :: NameAssoc
-> JSValue
-> Result [(String, Instance.Instance)]
getInstances ktn arr = toArray arr >>= mapM (parseInstance ktn)
getInstances ktn arr = extractArray arr >>= mapM (parseInstance ktn)
-- | Construct an instance from a JSON object.
parseInstance :: NameAssoc
......@@ -140,7 +165,7 @@ parseInstance _ v = fail ("Invalid instance query result: " ++ show v)
-- | Parse a node list in JSON format.
getNodes :: NameAssoc -> JSValue -> Result [(String, Node.Node)]
getNodes ktg arr = toArray arr >>= mapM (parseNode ktg)
getNodes ktg arr = extractArray arr >>= mapM (parseNode ktg)
-- | Construct a node from a JSON object.
parseNode :: NameAssoc -> JSValue -> Result (String, Node.Node)
......@@ -177,11 +202,11 @@ getClusterTags v = do
-- | Parses the cluster groups.
getGroups :: JSValue -> Result [(String, Group.Group)]
getGroups arr = toArray arr >>= mapM parseGroup
getGroups jsv = extractArray jsv >>= mapM parseGroup
-- | Parses a given group information.
parseGroup :: JSValue -> Result (String, Group.Group)
parseGroup (JSArray [ uuid, name, apol ]) = do
parseGroup (JSArray [uuid, name, apol]) = do
xname <- annotateResult "Parsing new group" (fromJVal name)
let convert a = genericConvert "Group" xname a
xuuid <- convert "uuid" uuid
......
......@@ -27,6 +27,7 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
module Ganeti.Luxi
( LuxiOp(..)
, QrViaLuxi(..)
, Client
, getClient
, closeClient
......@@ -46,6 +47,7 @@ import qualified Network.Socket as S
import Ganeti.HTools.Utils
import Ganeti.HTools.Types
import Ganeti.Constants
import Ganeti.Jobs (JobStatus)
import Ganeti.OpCodes (OpCode)
import Ganeti.THH
......@@ -62,61 +64,82 @@ withTimeout secs descr action = do
-- * Generic protocol functionality
$(declareSADT "QrViaLuxi"
[ ("QRLock", 'qrLock)
, ("QRInstance", 'qrInstance)
, ("QRNode", 'qrNode)
, ("QRGroup", 'qrGroup)
, ("QROs", 'qrOs)
])
$(makeJSONInstance ''QrViaLuxi)
-- | Currently supported Luxi operations and JSON serialization.
$(genLuxiOp "LuxiOp"
[ ("QueryNodes",
[("Query" ,
[ ("what", [t| QrViaLuxi |], [| id |])
, ("fields", [t| [String] |], [| id |])
, ("filter", [t| Maybe (String, [[String]]) |], [| id |])
], SDict)
, ("QueryNodes",
[ ("names", [t| [String] |], [| id |])
, ("fields", [t| [String] |], [| id |])
, ("lock", [t| Bool |], [| id |])
])
], SList)
, ("QueryGroups",
[ ("names", [t| [String] |], [| id |])
, ("fields", [t| [String] |], [| id |])
, ("lock", [t| Bool |], [| id |])
])
], SList)
, ("QueryInstances",
[ ("names", [t| [String] |], [| id |])
, ("fields", [t| [String] |], [| id |])
, ("lock", [t| Bool |], [| id |])
])
], SList)
, ("QueryJobs",
[ ("ids", [t| [Int] |], [| map show |])
, ("fields", [t| [String] |], [| id |])
])
], SList)
, ("QueryExports",
[ ("nodes", [t| [String] |], [| id |])
, ("lock", [t| Bool |], [| id |])
])
], SList)
, ("QueryConfigValues",
[ ("fields", [t| [String] |], [| id |]) ])
, ("QueryClusterInfo", [])
[ ("fields", [t| [String] |], [| id |]) ],
SList)
, ("QueryClusterInfo", [], SList)
, ("QueryTags",
[ ("kind", [t| String |], [| id |])
, ("name", [t| String |], [| id |])
])
], SList)
, ("SubmitJob",
[ ("job", [t| [OpCode] |], [| id |]) ])
[ ("job", [t| [OpCode] |], [| id |]) ],
SList)
, ("SubmitManyJobs",
[ ("ops", [t| [[OpCode]] |], [| id |]) ])
[ ("ops", [t| [[OpCode]] |], [| id |]) ],
SList)
, ("WaitForJobChange",
[ ("job", [t| Int |], [| id |])
, ("fields", [t| [String]|], [| id |])
, ("prev_job", [t| JSValue |], [| id |])
, ("prev_log", [t| JSValue |], [| id |])
, ("tmout", [t| Int |], [| id |])
])
], SList)
, ("ArchiveJob",
[ ("job", [t| Int |], [| show |]) ])
[ ("job", [t| Int |], [| show |]) ],
SList)
, ("AutoArchiveJobs",
[ ("age", [t| Int |], [| id |])
, ("tmout", [t| Int |], [| id |])
])
], SList)
, ("CancelJob",
[("job", [t| Int |], [| show |]) ])
[("job", [t| Int |], [| show |]) ],
SList)
, ("SetDrainFlag",
[ ("flag", [t| Bool |], [| id |]) ])
[ ("flag", [t| Bool |], [| id |]) ],
SList)
, ("SetWatcherPause",
[ ("duration", [t| Double |], [| (: []) |]) ])
[ ("duration", [t| Double |], [| (: []) |]) ],
SList)
])
-- | The serialisation of LuxiOps into strings in messages.
......
......@@ -29,7 +29,8 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module Ganeti.THH ( declareSADT
module Ganeti.THH ( Store(..)
, declareSADT
, makeJSONInstance
, genOpID
, genOpCode
......@@ -428,6 +429,9 @@ genStrOfKey = genConstrToStr ensureLower
-- | LuxiOp parameter type.
type LuxiParam = (String, Q Type, Q Exp)
-- | Storage options for JSON.
data Store = SList | SDict
-- | Generates the LuxiOp data type.
--
-- This takes a Luxi operation definition and builds both the
......@@ -444,9 +448,9 @@ type LuxiParam = (String, Q Type, Q Exp)
-- * operation; this is the operation performed on the parameter before
-- serialization
--
genLuxiOp :: String -> [(String, [LuxiParam])] -> Q [Dec]
genLuxiOp :: String -> [(String, [LuxiParam], Store)] -> Q [Dec]
genLuxiOp name cons = do
decl_d <- mapM (\(cname, fields) -> do
decl_d <- mapM (\(cname, fields, _) -> do
fields' <- mapM (\(_, qt, _) ->
qt >>= \t -> return (NotStrict, t))
fields
......@@ -456,21 +460,42 @@ genLuxiOp name cons = do
(savesig, savefn) <- genSaveLuxiOp cons
return [declD, savesig, savefn]
-- | Generates a Q Exp for an element, depending of the JSON return type.
helperLuxiField :: Store -> String -> Q Exp -> Q Exp
helperLuxiField SList name val = [| [ JSON.showJSON $val ] |]
helperLuxiField SDict name val = [| [(name, JSON.showJSON $val)] |]
-- | Generates the \"save\" expression for a single luxi parameter.
saveLuxiField :: Store -> Name -> LuxiParam -> Q Exp
saveLuxiField store fvar (fname, qt, fn) = do
t <- qt
let fvare = varE fvar
(if isOptional t
then [| case $fvare of
Just v' ->
$(helperLuxiField store fname $ liftM2 appFn fn [| v' |])
Nothing -> []
|]
else helperLuxiField store fname $ liftM2 appFn fn fvare)
-- | Generates final JSON Q Exp for constructor.
helperLuxiConstructor :: Store -> Q Exp -> Q Exp
helperLuxiConstructor SDict val = [| JSON.showJSON $ JSON.makeObj $val |]
helperLuxiConstructor SList val = [| JSON.JSArray $val |]
-- | Generates the \"save\" clause for entire LuxiOp constructor.
saveLuxiConstructor :: (String, [LuxiParam]) -> Q Clause
saveLuxiConstructor (sname, fields) =
saveLuxiConstructor :: (String, [LuxiParam], Store) -> Q Clause
saveLuxiConstructor (sname, fields, store) = do
let cname = mkName sname
fnames = map (\(nm, _, _) -> mkName nm) fields
pat = conP cname (map varP fnames)
flist = map (\(nm, _, fn) -> liftM2 appFn fn $ (varNameE nm)) fields
showlist = map (\x -> [| JSON.showJSON $x |]) flist
finval = case showlist of
[] -> [| JSON.showJSON () |]
_ -> [| JSON.showJSON $(listE showlist) |]
in clause [pat] (normalB finval) []
flist = map (uncurry $ saveLuxiField store) (zip fnames fields)
flist' = appE [| concat |] (listE flist)
finval = helperLuxiConstructor store flist'
clause [pat] (normalB finval) []
-- | Generates the main save LuxiOp function.
genSaveLuxiOp :: [(String, [LuxiParam])] -> Q (Dec, Dec)
genSaveLuxiOp :: [(String, [LuxiParam], Store)]-> Q (Dec, Dec)
genSaveLuxiOp opdefs = do
sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |]
let fname = mkName "opToArgs"
......
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