Use TemplateHaskell to create LUXI operations

Signed-off-by: Agata Murawska <agatamurawska@google.com>
Reviewed-by: Iustin Pop <iustin@google.com>

htools/Ganeti/Luxi.hs

+{-# LANGUAGE TemplateHaskell #-}
+
 {-| Implementation of the Ganeti LUXI interface.
 
 -}
@@ -46,6 +48,7 @@ import Ganeti.HTools.Types
 
 import Ganeti.Jobs (JobStatus)
 import Ganeti.OpCodes (OpCode)
+import Ganeti.THH
 
 -- * Utility functions
 
@@ -59,43 +62,82 @@ withTimeout secs descr action = do
 
 -- * Generic protocol functionality
 
--- | Currently supported Luxi operations.
-data LuxiOp = QueryInstances [String] [String] Bool
-            | QueryNodes [String] [String] Bool
-            | QueryGroups [String] [String] Bool
-            | QueryJobs [Int] [String]
-            | QueryExports [String] Bool
-            | QueryConfigValues [String]
-            | QueryClusterInfo
-            | QueryTags String String
-            | SubmitJob [OpCode]
-            | SubmitManyJobs [[OpCode]]
-            | WaitForJobChange Int [String] JSValue JSValue Int
-            | ArchiveJob Int
-            | AutoArchiveJobs Int Int
-            | CancelJob Int
-            | SetDrainFlag Bool
-            | SetWatcherPause Double
-              deriving (Show, Read)
+-- | Currently supported Luxi operations and JSON serialization.
+$(genLuxiOp "LuxiOp"
+    [ ("QueryNodes",
+       [ ("names",  [t| [String] |], [| id |])
+       , ("fields", [t| [String] |], [| id |])
+       , ("lock",   [t| Bool     |], [| id |])
+       ],
+       [| J.showJSON |])
+    , ("QueryGroups",
+       [ ("names",  [t| [String] |], [| id |])
+       , ("fields", [t| [String] |], [| id |])
+       , ("lock",   [t| Bool     |], [| id |])
+       ],
+       [| J.showJSON |])
+    , ("QueryInstances",
+       [ ("names",  [t| [String] |], [| id |])
+       , ("fields", [t| [String] |], [| id |])
+       , ("lock",   [t| Bool     |], [| id |])
+       ],
+       [| J.showJSON |])
+    , ("QueryJobs",
+       [ ("ids",    [t| [Int]    |], [| map show |])
+       , ("fields", [t| [String] |], [| id |])
+       ],
+       [| J.showJSON |])
+    , ("QueryExports",
+       [ ("nodes", [t| [String] |], [| id |])
+       , ("lock",  [t| Bool     |], [| id |])
+       ],
+       [| J.showJSON |])
+    , ("QueryConfigValues",
+       [ ("fields", [t| [String] |], [| id |]) ],
+       [| J.showJSON |])
+    , ("QueryClusterInfo",
+       [],
+       [| J.showJSON |])
+    , ("QueryTags",
+       [ ("kind", [t| String |], [| id |])
+       , ("name", [t| String |], [| id |])
+       ],
+       [| J.showJSON |])
+    , ("SubmitJob",
+       [ ("job", [t| [OpCode] |], [| id |]) ],
+       [| J.showJSON |])
+    , ("SubmitManyJobs",
+       [ ("ops", [t| [[OpCode]] |], [| id |]) ],
+       [| J.showJSON |])
+    , ("WaitForJobChange",
+       [ ("job",      [t| Int     |], [| J.showJSON |])
+       , ("fields",   [t| [String]|], [| J.showJSON |])
+       , ("prev_job", [t| JSValue |], [| J.showJSON |])
+       , ("prev_log", [t| JSValue |], [| J.showJSON |])
+       , ("tmout",    [t| Int     |], [| J.showJSON |])
+       ],
+       [| \(j, f, pj, pl, t) -> JSArray [j, f, pj, pl, t] |])
+    , ("ArchiveJob",
+       [ ("job", [t| Int |], [| show |]) ],
+       [| J.showJSON |])
+    , ("AutoArchiveJobs",
+       [ ("age",   [t| Int |], [| id |])
+       , ("tmout", [t| Int |], [| id |])
+       ],
+       [| J.showJSON |])
+    , ("CancelJob",
+       [("job", [t| Int |], [| show |]) ],
+       [| J.showJSON |])
+    , ("SetDrainFlag",
+       [ ("flag", [t| Bool |], [| id |]) ],
+       [| J.showJSON |])
+    , ("SetWatcherPause",
+       [ ("duration", [t| Double |], [| \x -> [x] |]) ],
+       [| J.showJSON |])
+  ])
 
 -- | The serialisation of LuxiOps into strings in messages.
-strOfOp :: LuxiOp -> String
-strOfOp QueryNodes {}        = "QueryNodes"
-strOfOp QueryGroups {}       = "QueryGroups"
-strOfOp QueryInstances {}    = "QueryInstances"
-strOfOp QueryJobs {}         = "QueryJobs"
-strOfOp QueryExports {}      = "QueryExports"
-strOfOp QueryConfigValues {} = "QueryConfigValues"
-strOfOp QueryClusterInfo {}  = "QueryClusterInfo"
-strOfOp QueryTags {}         = "QueryTags"
-strOfOp SubmitManyJobs {}    = "SubmitManyJobs"
-strOfOp WaitForJobChange {}  = "WaitForJobChange"
-strOfOp SubmitJob {}         = "SubmitJob"
-strOfOp ArchiveJob {}        = "ArchiveJob"
-strOfOp AutoArchiveJobs {}   = "AutoArchiveJobs"
-strOfOp CancelJob {}         = "CancelJob"
-strOfOp SetDrainFlag {}      = "SetDrainFlag"
-strOfOp SetWatcherPause {}   = "SetWatcherPause"
+$(genStrOfOp ''LuxiOp "strOfOp")
 
 -- | The end-of-message separator.
 eOM :: Char
@@ -108,11 +150,7 @@ data MsgKeys = Method
              | Result
 
 -- | The serialisation of MsgKeys into strings in messages.
-strOfKey :: MsgKeys -> String
-strOfKey Method = "method"
-strOfKey Args = "args"
-strOfKey Success = "success"
-strOfKey Result = "result"
+$(genStrOfKey ''MsgKeys "strOfKey")
 
 -- | Luxi client encapsulation.
 data Client = Client { socket :: S.Socket   -- ^ The socket of the client
@@ -161,29 +199,6 @@ recvMsg s = do
   writeIORef (rbuf s) nbuf
   return msg
 
--- | Compute the serialized form of a Luxi operation.
-opToArgs :: LuxiOp -> JSValue
-opToArgs (QueryNodes names fields lock) = J.showJSON (names, fields, lock)
-opToArgs (QueryGroups names fields lock) = J.showJSON (names, fields, lock)
-opToArgs (QueryInstances names fields lock) = J.showJSON (names, fields, lock)
-opToArgs (QueryJobs ids fields) = J.showJSON (map show ids, fields)
-opToArgs (QueryExports nodes lock) = J.showJSON (nodes, lock)
-opToArgs (QueryConfigValues fields) = J.showJSON fields
-opToArgs (QueryClusterInfo) = J.showJSON ()
-opToArgs (QueryTags kind name) =  J.showJSON (kind, name)
-opToArgs (SubmitJob j) = J.showJSON j
-opToArgs (SubmitManyJobs ops) = J.showJSON ops
--- This is special, since the JSON library doesn't export an instance
--- of a 5-tuple
-opToArgs (WaitForJobChange a b c d e) =
-    JSArray [ J.showJSON a, J.showJSON b, J.showJSON c
-            , J.showJSON d, J.showJSON e]
-opToArgs (ArchiveJob a) = J.showJSON (show a)
-opToArgs (AutoArchiveJobs a b) = J.showJSON (a, b)
-opToArgs (CancelJob a) = J.showJSON (show a)
-opToArgs (SetDrainFlag flag) = J.showJSON flag
-opToArgs (SetWatcherPause duration) = J.showJSON [duration]
-
 -- | Serialize a request to String.
 buildCall :: LuxiOp  -- ^ The method
           -> String  -- ^ The serialized form

htools/Ganeti/THH.hs

@@ -34,6 +34,9 @@ module Ganeti.THH ( declareSADT
                   , genOpID
                   , genOpCode
                   , noDefault
+                  , genStrOfOp
+                  , genStrOfKey
+                  , genLuxiOp
                   ) where
 
 import Control.Monad (liftM)
@@ -222,24 +225,27 @@ constructorName (NormalC name _) = return name
 constructorName (RecC name _)    = return name
 constructorName x                = fail $ "Unhandled constructor " ++ show x
 
--- | Builds the constructor-to-string function.
+-- | Builds the generic constructor-to-string function.
 --
 -- This generates a simple function of the following form:
 --
 -- @
--- fname (ConStructorOne {}) = "CON_STRUCTOR_ONE"
--- fname (ConStructorTwo {}) = "CON_STRUCTOR_TWO"
+-- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
+-- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
 -- @
 --
 -- This builds a custom list of name/string pairs and then uses
 -- 'genToString' to actually generate the function
-genOpID :: Name -> String -> Q [Dec]
-genOpID name fname = do
+genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]
+genConstrToStr trans_fun name fname = do
   TyConI (DataD _ _ _ cons _) <- reify name
   cnames <- mapM (liftM nameBase . constructorName) cons
-  let svalues = map (Left . deCamelCase) cnames
+  let svalues = map (Left . trans_fun) cnames
   genToString (mkName fname) name $ zip cnames svalues
 
+-- | Constructor-to-string for OpCode.
+genOpID :: Name -> String -> Q [Dec]
+genOpID = genConstrToStr deCamelCase
 
 -- | OpCode parameter (field) type
 type OpParam = (String, Q Type, Q Exp)
@@ -400,3 +406,63 @@ genLoadOpCode opdefs = do
 -- | No default type.
 noDefault :: Q Exp
 noDefault = conE 'Nothing
+
+-- * Template code for luxi
+
+-- | Constructor-to-string for LuxiOp.
+genStrOfOp :: Name -> String -> Q [Dec]
+genStrOfOp = genConstrToStr id
+
+-- | Constructor-to-string for MsgKeys.
+genStrOfKey :: Name -> String -> Q [Dec]
+genStrOfKey = genConstrToStr ensureLower
+
+-- | LuxiOp parameter type.
+type LuxiParam = (String, Q Type, Q Exp)
+
+-- | Generates the LuxiOp data type.
+--
+-- This takes a Luxi operation definition and builds both the
+-- datatype and the function trnasforming the arguments to JSON.
+-- We can't use anything less generic, because the way different
+-- operations are serialized differs on both parameter- and top-level.
+--
+-- There are three things to be defined for each parameter:
+--
+-- * name
+--
+-- * type
+--
+-- * operation; this is the operation performed on the parameter before
+--   serialization
+--
+genLuxiOp :: String -> [(String, [LuxiParam], Q Exp)] -> Q [Dec]
+genLuxiOp name cons = do
+  decl_d <- mapM (\(cname, fields, _) -> do
+                    fields' <- mapM (\(_, qt, _) ->
+                                         qt >>= \t -> return (NotStrict, t))
+                               fields
+                    return $ NormalC (mkName cname) fields')
+            cons
+  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read]
+  (savesig, savefn) <- genSaveLuxiOp cons
+  return [declD, savesig, savefn]
+
+-- | Generates the \"save\" clause for entire LuxiOp constructor.
+saveLuxiConstructor :: (String, [LuxiParam], Q Exp) -> Q Clause
+saveLuxiConstructor (sname, fields, finfn) =
+  let cname = mkName sname
+      fnames = map (\(nm, _, _) -> mkName nm) fields
+      pat = conP cname (map varP fnames)
+      flist = map (\(nm, _, fn) -> appE fn $ varNameE nm) fields
+      finval = appE finfn (tupE flist)
+  in
+    clause [pat] (normalB finval) []
+
+-- | Generates the main save LuxiOp function.
+genSaveLuxiOp :: [(String, [LuxiParam], Q Exp)] -> Q (Dec, Dec)
+genSaveLuxiOp opdefs = do
+  sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |]
+  let fname = mkName "opToArgs"
+  cclauses <- mapM saveLuxiConstructor opdefs
+  return $ (SigD fname sigt, FunD fname cclauses)