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: Agata Murawska <agatamurawska@google.com>
Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Iustin Pop <iustin@google.com>

htools/Ganeti/HTools/Luxi.hs

@@ -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

htools/Ganeti/Luxi.hs

@@ -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.

htools/Ganeti/THH.hs

@@ -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"