From 88609f00af9f9169677d7c897040bf06908cc4b7 Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Thu, 8 Nov 2012 13:26:40 +0100
Subject: [PATCH] Switch Luxi TH code from simple to custom fields
This is needed so that we have more flexibility in generating Luxi
serialisation code (deserialisation is still custom). Also, only
exceptions are now using the 'simple' field types, so we might be able
later to convert and remove that TH code as well.
Since we will use custom serialisation fields in the future, we change
the order of serialisation for custom-save fields; Luxi uses
positional as opposed to name-based ordering, so we need to keep this
stable.
Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Helga Velroyen <helgav@google.com>
---
htools/Ganeti/Luxi.hs | 68 +++++++++++++++++++++----------------------
htools/Ganeti/THH.hs | 33 +++++++++++++--------
2 files changed, 55 insertions(+), 46 deletions(-)
diff --git a/htools/Ganeti/Luxi.hs b/htools/Ganeti/Luxi.hs
index b933eb5c3..622eceb6c 100644
--- a/htools/Ganeti/Luxi.hs
+++ b/htools/Ganeti/Luxi.hs
@@ -101,73 +101,73 @@ type JobId = Int
-- | Currently supported Luxi operations and JSON serialization.
$(genLuxiOp "LuxiOp"
[ (luxiReqQuery,
- [ ("what", [t| Qlang.ItemType |])
- , ("fields", [t| [String] |])
- , ("qfilter", [t| Qlang.Filter Qlang.FilterField |])
+ [ simpleField "what" [t| Qlang.ItemType |]
+ , simpleField "fields" [t| [String] |]
+ , simpleField "qfilter" [t| Qlang.Filter Qlang.FilterField |]
])
, (luxiReqQueryFields,
- [ ("what", [t| Qlang.ItemType |])
- , ("fields", [t| [String] |])
+ [ simpleField "what" [t| Qlang.ItemType |]
+ , simpleField "fields" [t| [String] |]
])
, (luxiReqQueryNodes,
- [ ("names", [t| [String] |])
- , ("fields", [t| [String] |])
- , ("lock", [t| Bool |])
+ [ simpleField "names" [t| [String] |]
+ , simpleField "fields" [t| [String] |]
+ , simpleField "lock" [t| Bool |]
])
, (luxiReqQueryGroups,
- [ ("names", [t| [String] |])
- , ("fields", [t| [String] |])
- , ("lock", [t| Bool |])
+ [ simpleField "names" [t| [String] |]
+ , simpleField "fields" [t| [String] |]
+ , simpleField "lock" [t| Bool |]
])
, (luxiReqQueryInstances,
- [ ("names", [t| [String] |])
- , ("fields", [t| [String] |])
- , ("lock", [t| Bool |])
+ [ simpleField "names" [t| [String] |]
+ , simpleField "fields" [t| [String] |]
+ , simpleField "lock" [t| Bool |]
])
, (luxiReqQueryJobs,
- [ ("ids", [t| [Int] |])
- , ("fields", [t| [String] |])
+ [ simpleField "ids" [t| [Int] |]
+ , simpleField "fields" [t| [String] |]
])
, (luxiReqQueryExports,
- [ ("nodes", [t| [String] |])
- , ("lock", [t| Bool |])
+ [ simpleField "nodes" [t| [String] |]
+ , simpleField "lock" [t| Bool |]
])
, (luxiReqQueryConfigValues,
- [ ("fields", [t| [String] |]) ]
+ [ simpleField "fields" [t| [String] |] ]
)
, (luxiReqQueryClusterInfo, [])
, (luxiReqQueryTags,
- [ ("kind", [t| TagObject |])
- , ("name", [t| String |])
+ [ simpleField "kind" [t| TagObject |]
+ , simpleField "name" [t| String |]
])
, (luxiReqSubmitJob,
- [ ("job", [t| [OpCode] |]) ]
+ [ simpleField "job" [t| [OpCode] |] ]
)
, (luxiReqSubmitManyJobs,
- [ ("ops", [t| [[OpCode]] |]) ]
+ [ simpleField "ops" [t| [[OpCode]] |] ]
)
, (luxiReqWaitForJobChange,
- [ ("job", [t| Int |])
- , ("fields", [t| [String]|])
- , ("prev_job", [t| JSValue |])
- , ("prev_log", [t| JSValue |])
- , ("tmout", [t| Int |])
+ [ simpleField "job" [t| Int |]
+ , simpleField "fields" [t| [String]|]
+ , simpleField "prev_job" [t| JSValue |]
+ , simpleField "prev_log" [t| JSValue |]
+ , simpleField "tmout" [t| Int |]
])
, (luxiReqArchiveJob,
- [ ("job", [t| Int |]) ]
+ [ simpleField "job" [t| Int |] ]
)
, (luxiReqAutoArchiveJobs,
- [ ("age", [t| Int |])
- , ("tmout", [t| Int |])
+ [ simpleField "age" [t| Int |]
+ , simpleField "tmout" [t| Int |]
])
, (luxiReqCancelJob,
- [ ("job", [t| Int |]) ]
+ [ simpleField "job" [t| Int |] ]
)
, (luxiReqSetDrainFlag,
- [ ("flag", [t| Bool |]) ]
+ [ simpleField "flag" [t| Bool |] ]
)
, (luxiReqSetWatcherPause,
- [ ("duration", [t| Double |]) ]
+ [ simpleField "duration" [t| Double |] ]
)
])
diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs
index 584c71223..489413d78 100644
--- a/htools/Ganeti/THH.hs
+++ b/htools/Ganeti/THH.hs
@@ -621,11 +621,17 @@ genStrOfKey = genConstrToStr ensureLower
--
-- * type
--
-genLuxiOp :: String -> SimpleObject -> Q [Dec]
+genLuxiOp :: String -> [(String, [Field])] -> Q [Dec]
genLuxiOp name cons = do
let tname = mkName name
- declD <- buildSimpleCons tname cons
- (savesig, savefn) <- genSaveSimpleObj tname "opToArgs"
+ decl_d <- mapM (\(cname, fields) -> do
+ -- we only need the type of the field, without Q
+ fields' <- mapM actualFieldType fields
+ let fields'' = zip (repeat NotStrict) fields'
+ return $ NormalC (mkName cname) fields'')
+ cons
+ let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
+ (savesig, savefn) <- genSaveOpCode tname "opToArgs"
cons saveLuxiConstructor
req_defs <- declareSADT "LuxiReq" .
map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
@@ -638,16 +644,16 @@ saveLuxiField fvar (_, qt) =
[| JSON.showJSON $(varE fvar) |]
-- | Generates the \"save\" clause for entire LuxiOp constructor.
-saveLuxiConstructor :: SimpleConstructor -> Q Clause
+saveLuxiConstructor :: (String, [Field]) -> Q Clause
saveLuxiConstructor (sname, fields) = do
let cname = mkName sname
- fnames = map (mkName . fst) fields
- pat = conP cname (map varP fnames)
- flist = map (uncurry saveLuxiField) (zip fnames fields)
- finval = if null flist
- then [| JSON.showJSON () |]
- else [| JSON.showJSON $(listE flist) |]
- clause [pat] (normalB finval) []
+ fnames <- mapM (newName . fieldVariable) fields
+ let pat = conP cname (map varP fnames)
+ let felems = map (uncurry saveObjectField) (zip fnames fields)
+ flist = if null felems
+ then [| JSON.showJSON () |]
+ else [| JSON.showJSON (map snd $ concat $(listE felems)) |]
+ clause [pat] (normalB flist) []
-- * "Objects" functionality
@@ -721,9 +727,12 @@ saveObjectField fvar field =
|]
NotOptional ->
case fieldShow field of
+ -- Note: the order of actual:extra is important, since for
+ -- some serialisation types (e.g. Luxi), we use tuples
+ -- (positional info) rather than object (name info)
Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
Just fn -> [| let (actual, extra) = $fn $fvarE
- in extra ++ [( $nameE, JSON.showJSON actual)]
+ in ($nameE, JSON.showJSON actual):extra
|]
where nameE = stringE (fieldName field)
fvarE = varE fvar
--
GitLab