From f94a9680a0c991de69db413c149143fbbb1669a0 Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Mon, 10 Dec 2012 10:58:33 +0100
Subject: [PATCH] Implement support for QFF_SPLIT_TIMESTAMP
I am very very unhappy with this patch. We have to do this, in order
to be compatible with the Python code and behaviour, but there's lots
of duplication; both the Python and the Haskell code will need to be
cleaned up and simplified (we don't need QFF_* at all).
For now though, this implements QffTimestamp and associated code.
Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Guido Trotter <ultrotter@google.com>
---
htest/Test/Ganeti/Query/Query.hs | 4 +--
htools/Ganeti/Query/Common.hs | 12 ++++----
htools/Ganeti/Query/Filter.hs | 21 +++++++++----
htools/Ganeti/Query/Group.hs | 29 ++++++++++--------
htools/Ganeti/Query/Node.hs | 52 ++++++++++++++++++--------------
htools/Ganeti/Query/Query.hs | 9 +++---
htools/Ganeti/Query/Types.hs | 11 ++++++-
7 files changed, 83 insertions(+), 55 deletions(-)
diff --git a/htest/Test/Ganeti/Query/Query.hs b/htest/Test/Ganeti/Query/Query.hs
index 9c50948e2..37ed56c34 100644
--- a/htest/Test/Ganeti/Query/Query.hs
+++ b/htest/Test/Ganeti/Query/Query.hs
@@ -156,7 +156,7 @@ case_queryNode_allfields = do
Ok (QueryFieldsResult v) -> return v
let field_sort = compare `on` fdefName
assertEqual "Mismatch in all fields list"
- (sortBy field_sort . map fst $ Map.elems nodeFieldsMap)
+ (sortBy field_sort . map (\(f, _, _) -> f) $ Map.elems nodeFieldsMap)
(sortBy field_sort fdefs)
-- * Same as above, but for group
@@ -228,7 +228,7 @@ case_queryGroup_allfields = do
Ok (QueryFieldsResult v) -> return v
let field_sort = compare `on` fdefName
assertEqual "Mismatch in all fields list"
- (sortBy field_sort . map fst $ Map.elems groupFieldsMap)
+ (sortBy field_sort . map (\(f, _, _) -> f) $ Map.elems groupFieldsMap)
(sortBy field_sort fdefs)
diff --git a/htools/Ganeti/Query/Common.hs b/htools/Ganeti/Query/Common.hs
index b9029bc28..67d1547b4 100644
--- a/htools/Ganeti/Query/Common.hs
+++ b/htools/Ganeti/Query/Common.hs
@@ -104,29 +104,29 @@ rpcErrorToStatus _ = RSNoData
timeStampFields :: (TimeStampObject a) => FieldList a b
timeStampFields =
[ (FieldDefinition "ctime" "CTime" QFTTimestamp "Creation timestamp",
- FieldSimple (rsNormal . cTimeOf))
+ FieldSimple (rsNormal . cTimeOf), QffNormal)
, (FieldDefinition "mtime" "MTime" QFTTimestamp "Modification timestamp",
- FieldSimple (rsNormal . mTimeOf))
+ FieldSimple (rsNormal . mTimeOf), QffNormal)
]
-- | The list of UUID fields.
uuidFields :: (UuidObject a) => String -> FieldList a b
uuidFields name =
[ (FieldDefinition "uuid" "UUID" QFTText (name ++ " UUID"),
- FieldSimple (rsNormal . uuidOf)) ]
+ FieldSimple (rsNormal . uuidOf), QffNormal) ]
-- | The list of serial number fields.
serialFields :: (SerialNoObject a) => String -> FieldList a b
serialFields name =
[ (FieldDefinition "serial_no" "SerialNo" QFTNumber
(name ++ " object serial number, incremented on each modification"),
- FieldSimple (rsNormal . serialOf)) ]
+ FieldSimple (rsNormal . serialOf), QffNormal) ]
-- | The list of tag fields.
tagsFields :: (TagsObject a) => FieldList a b
tagsFields =
[ (FieldDefinition "tags" "Tags" QFTOther "Tags",
- FieldSimple (rsNormal . tagsOf)) ]
+ FieldSimple (rsNormal . tagsOf), QffNormal) ]
-- * Generic parameter functions
@@ -169,4 +169,4 @@ buildNdParamField field =
qft = fromMaybe QFTOther $ field `Map.lookup` ndParamTypes
desc = "The \"" ++ field ++ "\" node parameter"
in (FieldDefinition full_name title qft desc,
- FieldConfig (ndParamGetter field))
+ FieldConfig (ndParamGetter field), QffNormal)
diff --git a/htools/Ganeti/Query/Filter.hs b/htools/Ganeti/Query/Filter.hs
index 94f65c9a0..ad7faa236 100644
--- a/htools/Ganeti/Query/Filter.hs
+++ b/htools/Ganeti/Query/Filter.hs
@@ -69,12 +69,21 @@ import Ganeti.JSON
-- | Compiles a filter based on field names to one based on getters.
compileFilter :: FieldMap a b
-> Filter FilterField
- -> ErrorResult (Filter (FieldGetter a b))
+ -> ErrorResult (Filter (FieldGetter a b, QffMode))
compileFilter fm =
traverse (\field -> maybe
(Bad . ParameterError $ "Can't find field named '" ++
field ++ "'")
- (Ok . snd) (field `Map.lookup` fm))
+ (\(_, g, q) -> Ok (g, q)) (field `Map.lookup` fm))
+
+-- | Processes a field value given a QffMode.
+qffField :: QffMode -> JSValue -> ErrorResult JSValue
+qffField QffNormal v = Ok v
+qffField QffTimestamp v =
+ case v of
+ JSArray [secs@(JSRational _ _), JSRational _ _] -> return secs
+ _ -> Bad $ ProgrammerError
+ "Internal error: Getter returned non-timestamp for QffTimestamp"
-- | Wraps a getter, filter pair. If the getter is 'FieldRuntime' but
-- we don't have a runtime context, we skip the filtering, returning
@@ -82,15 +91,15 @@ compileFilter fm =
wrapGetter :: ConfigData
-> Maybe b
-> a
- -> FieldGetter a b
+ -> (FieldGetter a b, QffMode)
-> (JSValue -> ErrorResult Bool)
-> ErrorResult Bool
-wrapGetter cfg b a getter faction =
+wrapGetter cfg b a (getter, qff) faction =
case tryGetter cfg b a getter of
Nothing -> Ok True -- runtime missing, accepting the value
Just v ->
case v of
- ResultEntry RSNormal (Just fval) -> faction fval
+ ResultEntry RSNormal (Just fval) -> qffField qff fval >>= faction
ResultEntry RSNormal Nothing ->
Bad $ ProgrammerError
"Internal error: Getter returned RSNormal/Nothing"
@@ -149,7 +158,7 @@ containsFilter (NumericValue val) lst = do
-- 'any' and 'all' do not play nice with monadic values, resulting in
-- either too much memory use or in too many thunks being created.
evaluateFilter :: ConfigData -> Maybe b -> a
- -> Filter (FieldGetter a b)
+ -> Filter (FieldGetter a b, QffMode)
-> ErrorResult Bool
evaluateFilter _ _ _ EmptyFilter = Ok True
evaluateFilter c mb a (AndFilter flts) = helper flts
diff --git a/htools/Ganeti/Query/Group.hs b/htools/Ganeti/Query/Group.hs
index acf908381..7711deab0 100644
--- a/htools/Ganeti/Query/Group.hs
+++ b/htools/Ganeti/Query/Group.hs
@@ -43,39 +43,41 @@ groupFields :: FieldList NodeGroup GroupRuntime
groupFields =
[ (FieldDefinition "alloc_policy" "AllocPolicy" QFTText
"Allocation policy for group",
- FieldSimple (rsNormal . groupAllocPolicy))
+ FieldSimple (rsNormal . groupAllocPolicy), QffNormal)
, (FieldDefinition "custom_diskparams" "CustomDiskParameters" QFTOther
"Custom disk parameters",
- FieldSimple (rsNormal . groupDiskparams))
+ FieldSimple (rsNormal . groupDiskparams), QffNormal)
, (FieldDefinition "custom_ipolicy" "CustomInstancePolicy" QFTOther
"Custom instance policy limitations",
- FieldSimple (rsNormal . groupIpolicy))
+ FieldSimple (rsNormal . groupIpolicy), QffNormal)
, (FieldDefinition "custom_ndparams" "CustomNDParams" QFTOther
"Custom node parameters",
- FieldSimple (rsNormal . groupNdparams))
+ FieldSimple (rsNormal . groupNdparams), QffNormal)
, (FieldDefinition "diskparams" "DiskParameters" QFTOther
"Disk parameters (merged)",
- FieldConfig (\cfg -> rsNormal . getGroupDiskParams cfg))
+ FieldConfig (\cfg -> rsNormal . getGroupDiskParams cfg), QffNormal)
, (FieldDefinition "ipolicy" "InstancePolicy" QFTOther
"Instance policy limitations (merged)",
- FieldConfig (\cfg ng -> rsNormal (getGroupIpolicy cfg ng)))
+ FieldConfig (\cfg ng -> rsNormal (getGroupIpolicy cfg ng)), QffNormal)
, (FieldDefinition "name" "Group" QFTText "Group name",
- FieldSimple (rsNormal . groupName))
+ FieldSimple (rsNormal . groupName), QffNormal)
, (FieldDefinition "ndparams" "NDParams" QFTOther "Node parameters",
- FieldConfig (\cfg ng -> rsNormal (getGroupNdParams cfg ng)))
+ FieldConfig (\cfg ng -> rsNormal (getGroupNdParams cfg ng)), QffNormal)
, (FieldDefinition "node_cnt" "Nodes" QFTNumber "Number of nodes",
- FieldConfig (\cfg -> rsNormal . length . getGroupNodes cfg . groupName))
+ FieldConfig (\cfg -> rsNormal . length . getGroupNodes cfg . groupName),
+ QffNormal)
, (FieldDefinition "node_list" "NodeList" QFTOther "List of nodes",
FieldConfig (\cfg -> rsNormal . map nodeName .
- getGroupNodes cfg . groupName))
+ getGroupNodes cfg . groupName), QffNormal)
, (FieldDefinition "pinst_cnt" "Instances" QFTNumber
"Number of primary instances",
FieldConfig
- (\cfg -> rsNormal . length . fst . getGroupInstances cfg . groupName))
+ (\cfg -> rsNormal . length . fst . getGroupInstances cfg . groupName),
+ QffNormal)
, (FieldDefinition "pinst_list" "InstanceList" QFTOther
"List of primary instances",
FieldConfig (\cfg -> rsNormal . map instName . fst .
- getGroupInstances cfg . groupName))
+ getGroupInstances cfg . groupName), QffNormal)
] ++
map buildNdParamField allNDParamFields ++
timeStampFields ++
@@ -85,4 +87,5 @@ groupFields =
-- | The group fields map.
groupFieldsMap :: FieldMap NodeGroup GroupRuntime
-groupFieldsMap = Map.fromList $ map (\v -> (fdefName (fst v), v)) groupFields
+groupFieldsMap =
+ Map.fromList $ map (\v@(f, _, _) -> (fdefName f, v)) groupFields
diff --git a/htools/Ganeti/Query/Node.hs b/htools/Ganeti/Query/Node.hs
index 1fbc80eac..8809c316d 100644
--- a/htools/Ganeti/Query/Node.hs
+++ b/htools/Ganeti/Query/Node.hs
@@ -105,7 +105,8 @@ nodeLiveFieldBuilder :: (FieldName, FieldTitle, FieldType, String, FieldDoc)
-> FieldData Node NodeRuntime
nodeLiveFieldBuilder (fname, ftitle, ftype, _, fdoc) =
( FieldDefinition fname ftitle ftype fdoc
- , FieldRuntime $ nodeLiveRpcCall fname)
+ , FieldRuntime $ nodeLiveRpcCall fname
+ , QffNormal)
-- | The docstring for the node role. Note that we use 'reverse in
-- order to keep the same order as Python.
@@ -130,69 +131,73 @@ getNodePower cfg node =
nodeFields :: FieldList Node NodeRuntime
nodeFields =
[ (FieldDefinition "drained" "Drained" QFTBool "Whether node is drained",
- FieldSimple (rsNormal . nodeDrained))
+ FieldSimple (rsNormal . nodeDrained), QffNormal)
, (FieldDefinition "master_candidate" "MasterC" QFTBool
"Whether node is a master candidate",
- FieldSimple (rsNormal . nodeMasterCandidate))
+ FieldSimple (rsNormal . nodeMasterCandidate), QffNormal)
, (FieldDefinition "master_capable" "MasterCapable" QFTBool
"Whether node can become a master candidate",
- FieldSimple (rsNormal . nodeMasterCapable))
+ FieldSimple (rsNormal . nodeMasterCapable), QffNormal)
, (FieldDefinition "name" "Node" QFTText "Node name",
- FieldSimple (rsNormal . nodeName))
+ FieldSimple (rsNormal . nodeName), QffNormal)
, (FieldDefinition "offline" "Offline" QFTBool
"Whether node is marked offline",
- FieldSimple (rsNormal . nodeOffline))
+ FieldSimple (rsNormal . nodeOffline), QffNormal)
, (FieldDefinition "vm_capable" "VMCapable" QFTBool
"Whether node can host instances",
- FieldSimple (rsNormal . nodeVmCapable))
+ FieldSimple (rsNormal . nodeVmCapable), QffNormal)
, (FieldDefinition "pip" "PrimaryIP" QFTText "Primary IP address",
- FieldSimple (rsNormal . nodePrimaryIp))
+ FieldSimple (rsNormal . nodePrimaryIp), QffNormal)
, (FieldDefinition "sip" "SecondaryIP" QFTText "Secondary IP address",
- FieldSimple (rsNormal . nodeSecondaryIp))
+ FieldSimple (rsNormal . nodeSecondaryIp), QffNormal)
, (FieldDefinition "master" "IsMaster" QFTBool "Whether node is master",
FieldConfig (\cfg node ->
rsNormal (nodeName node ==
- clusterMasterNode (configCluster cfg))))
+ clusterMasterNode (configCluster cfg))),
+ QffNormal)
, (FieldDefinition "group" "Group" QFTText "Node group",
FieldConfig (\cfg node ->
- rsMaybe (groupName <$> getGroupOfNode cfg node)))
+ rsMaybe (groupName <$> getGroupOfNode cfg node)),
+ QffNormal)
, (FieldDefinition "group.uuid" "GroupUUID" QFTText "UUID of node group",
- FieldSimple (rsNormal . nodeGroup))
+ FieldSimple (rsNormal . nodeGroup), QffNormal)
, (FieldDefinition "ndparams" "NodeParameters" QFTOther
"Merged node parameters",
- FieldConfig ((rsMaybe .) . getNodeNdParams))
+ FieldConfig ((rsMaybe .) . getNodeNdParams), QffNormal)
, (FieldDefinition "custom_ndparams" "CustomNodeParameters" QFTOther
"Custom node parameters",
- FieldSimple (rsNormal . nodeNdparams))
+ FieldSimple (rsNormal . nodeNdparams), QffNormal)
-- FIXME: the below could be generalised a bit, like in Python
, (FieldDefinition "pinst_cnt" "Pinst" QFTNumber
"Number of instances with this node as primary",
FieldConfig (\cfg ->
- rsNormal . length . fst . getNodeInstances cfg . nodeName))
+ rsNormal . length . fst . getNodeInstances cfg . nodeName),
+ QffNormal)
, (FieldDefinition "sinst_cnt" "Sinst" QFTNumber
"Number of instances with this node as secondary",
FieldConfig (\cfg ->
- rsNormal . length . snd . getNodeInstances cfg . nodeName))
+ rsNormal . length . snd . getNodeInstances cfg . nodeName),
+ QffNormal)
, (FieldDefinition "pinst_list" "PriInstances" QFTOther
"List of instances with this node as primary",
FieldConfig (\cfg -> rsNormal . map instName . fst .
- getNodeInstances cfg . nodeName))
+ getNodeInstances cfg . nodeName), QffNormal)
, (FieldDefinition "sinst_list" "SecInstances" QFTOther
"List of instances with this node as secondary",
FieldConfig (\cfg -> rsNormal . map instName . snd .
- getNodeInstances cfg . nodeName))
+ getNodeInstances cfg . nodeName), QffNormal)
, (FieldDefinition "role" "Role" QFTText nodeRoleDoc,
- FieldConfig ((rsNormal .) . getNodeRole))
+ FieldConfig ((rsNormal .) . getNodeRole), QffNormal)
, (FieldDefinition "powered" "Powered" QFTBool
"Whether node is thought to be powered on",
- FieldConfig getNodePower)
+ FieldConfig getNodePower, QffNormal)
-- FIXME: the two fields below are incomplete in Python, part of the
-- non-implemented node resource model; they are declared just for
-- parity, but are not functional
, (FieldDefinition "hv_state" "HypervisorState" QFTOther "Hypervisor state",
- missingRuntime)
+ missingRuntime, QffNormal)
, (FieldDefinition "disk_state" "DiskState" QFTOther "Disk state",
- missingRuntime)
+ missingRuntime, QffNormal)
] ++
map nodeLiveFieldBuilder nodeLiveFieldsDefs ++
map buildNdParamField allNDParamFields ++
@@ -203,4 +208,5 @@ nodeFields =
-- | The node fields map.
nodeFieldsMap :: FieldMap Node NodeRuntime
-nodeFieldsMap = Map.fromList $ map (\v -> (fdefName (fst v), v)) nodeFields
+nodeFieldsMap =
+ Map.fromList $ map (\v@(f, _, _) -> (fdefName f, v)) nodeFields
diff --git a/htools/Ganeti/Query/Query.hs b/htools/Ganeti/Query/Query.hs
index 70fe0c06c..d99973227 100644
--- a/htools/Ganeti/Query/Query.hs
+++ b/htools/Ganeti/Query/Query.hs
@@ -79,7 +79,8 @@ import Ganeti.Utils
mkUnknownFDef :: String -> FieldData a b
mkUnknownFDef name =
( FieldDefinition name name QFTUnknown ("Unknown field '" ++ name ++ "'")
- , FieldUnknown )
+ , FieldUnknown
+ , QffNormal )
-- | Runs a field getter on the existing contexts.
execGetter :: ConfigData -> b -> a -> FieldGetter a b -> ResultEntry
@@ -161,7 +162,7 @@ queryInner cfg live (Query (ItemTypeOpCode QRNode) fields qfilter) wanted =
runResultT $ do
cfilter <- resultT $ compileFilter nodeFieldsMap qfilter
let selected = getSelectedFields nodeFieldsMap fields
- (fdefs, fgetters) = unzip selected
+ (fdefs, fgetters, _) = unzip3 selected
live' = live && needsLiveData fgetters
nodes <- resultT $ case wanted of
[] -> Ok . niceSortKey nodeName .
@@ -182,7 +183,7 @@ queryInner cfg _ (Query (ItemTypeOpCode QRGroup) fields qfilter) wanted =
return $ do
cfilter <- compileFilter groupFieldsMap qfilter
let selected = getSelectedFields groupFieldsMap fields
- (fdefs, fgetters) = unzip selected
+ (fdefs, fgetters, _) = unzip3 selected
groups <- case wanted of
[] -> Ok . niceSortKey groupName .
Map.elems . fromContainer $ configNodegroups cfg
@@ -202,7 +203,7 @@ fieldsExtractor fieldsMap fields =
let selected = if null fields
then map snd $ Map.toAscList fieldsMap
else getSelectedFields fieldsMap fields
- in QueryFieldsResult (map fst selected)
+ in QueryFieldsResult (map (\(defs, _, _) -> defs) selected)
-- | Query fields call.
queryFields :: QueryFields -> ErrorResult QueryFieldsResult
diff --git a/htools/Ganeti/Query/Types.hs b/htools/Ganeti/Query/Types.hs
index 42300b2cd..c9cbbbcdd 100644
--- a/htools/Ganeti/Query/Types.hs
+++ b/htools/Ganeti/Query/Types.hs
@@ -28,6 +28,7 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
module Ganeti.Query.Types
( FieldGetter(..)
+ , QffMode(..)
, FieldData
, FieldList
, FieldMap
@@ -50,8 +51,16 @@ data FieldGetter a b = FieldSimple (a -> ResultEntry)
| FieldConfig (ConfigData -> a -> ResultEntry)
| FieldUnknown
+-- | Type defining how the value of a field is used in filtering. This
+-- implements the equivalent to Python's QFF_ flags, except that we
+-- don't use OR-able values.
+data QffMode = QffNormal -- ^ Value is used as-is in filters
+ | QffTimestamp -- ^ Value is a timestamp tuple, convert to float
+ deriving (Show, Eq)
+
+
-- | Alias for a field data (definition and getter).
-type FieldData a b = (FieldDefinition, FieldGetter a b)
+type FieldData a b = (FieldDefinition, FieldGetter a b, QffMode)
-- | Alias for a field data list.
type FieldList a b = [FieldData a b]
--
GitLab