Add Query support for Nodes (no filtering, no RPC)

This is the initial support for Query2: basic infrastructure (except
filtering) and node query support (without RPC).

It implements all the fields (tests by comparison with list-fields on
the Python side), except that:

- filter is not done
- since RPC is not integrated yet, the runtime gathering/computing is
  simply stubbed out

However, the infrastructure seems pretty reasonable, so I'm sending as
is.

Note that I've split the functions/declarations into multiple files,
to keep each file clean and readable.
Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Agata Murawska <agatamurawska@google.com>

Makefile.am

@@ -416,7 +416,10 @@ HS_LIB_SRCS = \
 	htools/Ganeti/OpCodes.hs \
 	htools/Ganeti/Rpc.hs \
 	htools/Ganeti/Qlang.hs \
+	htools/Ganeti/Query/Common.hs \
+	htools/Ganeti/Query/Node.hs \
 	htools/Ganeti/Query/Query.hs \
+	htools/Ganeti/Query/Types.hs \
 	htools/Ganeti/Queryd.hs \
 	htools/Ganeti/Runtime.hs \
 	htools/Ganeti/Ssconf.hs \

htools/Ganeti/Qlang.hs

@@ -33,10 +33,14 @@ module Ganeti.Qlang
     , QueryResult(..)
     , QueryFields(..)
     , QueryFieldsResult(..)
+    , FieldName
+    , FieldTitle
     , FieldType(..)
+    , FieldDoc
     , FieldDefinition(..)
     , ResultEntry(..)
     , ResultStatus(..)
+    , ResultValue
     , ItemType(..)
     , checkRS
     ) where

htools/Ganeti/Query/Common.hs

+{-| Implementation of the Ganeti Query2 common objects.
+
+ -}
+
+{-
+
+Copyright (C) 2012 Google Inc.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.
+
+-}
+
+module Ganeti.Query.Common
+  ( rsNoData
+  , rsNormal
+  , rsMaybe
+  , rsUnknown
+  , missingRuntime
+  , timeStampFields
+  , uuidFields
+  , serialFields
+  , tagsFields
+  , dictFieldGetter
+  , buildQFTLookup
+  , buildNdParamField
+  ) where
+
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe)
+import Text.JSON (JSON, showJSON)
+
+import qualified Ganeti.Constants as C
+import Ganeti.Config
+import Ganeti.Objects
+import Ganeti.Qlang
+import Ganeti.Query.Types
+
+-- * Generic functions
+
+-- | Conversion from 'VType' to 'FieldType'.
+vTypeToQFT :: VType -> FieldType
+vTypeToQFT VTypeString      = QFTOther
+vTypeToQFT VTypeMaybeString = QFTOther
+vTypeToQFT VTypeBool        = QFTBool
+vTypeToQFT VTypeSize        = QFTUnit
+vTypeToQFT VTypeInt         = QFTNumber
+
+-- * Result helpers
+
+-- | Helper for a result with no data.
+rsNoData :: ResultEntry
+rsNoData = ResultEntry RSNoData Nothing
+
+-- | Helper to declare a normal result.
+rsNormal :: (JSON a) => a -> ResultEntry
+rsNormal a = ResultEntry RSNormal $ Just (showJSON a)
+
+-- | Helper to declare a result from a 'Maybe' (the item might be
+-- missing, in which case we return no data). Note that there's some
+-- ambiguity here: in some cases, we mean 'RSNoData', but in other
+-- 'RSUnavail'; this is easy to solve in simple cases, but not in
+-- nested dicts.
+rsMaybe :: (JSON a) => Maybe a -> ResultEntry
+rsMaybe = maybe rsNoData rsNormal
+
+-- | Helper for unknown field result.
+rsUnknown :: ResultEntry
+rsUnknown = ResultEntry RSUnknown Nothing
+
+-- | Helper for a missing runtime parameter.
+missingRuntime :: FieldGetter a b
+missingRuntime = FieldRuntime (\_ _ -> ResultEntry RSNoData Nothing)
+
+-- * Common fields
+
+-- | The list of timestamp fields.
+timeStampFields :: (TimeStampObject a) => FieldList a b
+timeStampFields =
+  [ (FieldDefinition "ctime" "CTime" QFTTimestamp "Creation timestamp",
+     FieldSimple (rsNormal . cTimeOf))
+  , (FieldDefinition "mtime" "MTime" QFTTimestamp "Modification timestamp",
+     FieldSimple (rsNormal . mTimeOf))
+  ]
+
+-- | The list of UUID fields.
+uuidFields :: (UuidObject a) => String -> FieldList a b
+uuidFields name =
+  [ (FieldDefinition "uuid" "UUID" QFTText  (name ++ " UUID"),
+     FieldSimple (rsNormal . uuidOf)) ]
+
+-- | 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)) ]
+
+-- | The list of tag fields.
+tagsFields :: (TagsObject a) => FieldList a b
+tagsFields =
+  [ (FieldDefinition "tags" "Tags" QFTOther "Tags",
+     FieldSimple (rsNormal . tagsOf)) ]
+
+-- * Generic parameter functions
+
+-- | Returns a field from a (possibly missing) 'DictObject'. This is
+-- used by parameter dictionaries, usually. Note that we have two
+-- levels of maybe: the top level dict might be missing, or one key in
+-- the dictionary might be.
+dictFieldGetter :: (DictObject a) => String -> Maybe a -> ResultEntry
+dictFieldGetter k = maybe rsNoData (rsMaybe . lookup k . toDict)
+
+-- | Build an optimised lookup map from a Python _PARAMETER_TYPES
+-- association list.
+buildQFTLookup :: [(String, String)] -> Map.Map String FieldType
+buildQFTLookup =
+  Map.fromList .
+  map (\(k, v) -> (k, maybe QFTOther vTypeToQFT (vTypeFromRaw v)))
+
+-- | Ndparams optimised lookup map.
+ndParamTypes :: Map.Map String FieldType
+ndParamTypes = buildQFTLookup C.ndsParameterTypes
+
+-- | Ndparams title map.
+ndParamTitles :: Map.Map String FieldTitle
+ndParamTitles = Map.fromList C.ndsParameterTitles
+
+-- | Ndparam getter builder: given a field, it returns a FieldConfig
+-- getter, that is a function that takes the config and the object and
+-- returns the Ndparam field specified when the getter was built.
+ndParamGetter :: (NdParamObject a) =>
+                 String -- ^ The field we're building the getter for
+              -> ConfigData -> a -> ResultEntry
+ndParamGetter field config =
+  dictFieldGetter field . getNdParamsOf config
+
+-- | Builds the ndparam fields for an object.
+buildNdParamField :: (NdParamObject a) => String -> FieldData a b
+buildNdParamField field =
+  let full_name = "ndp/" ++ field
+      title = fromMaybe field $ field `Map.lookup` ndParamTitles
+      qft = fromMaybe QFTOther $ field `Map.lookup` ndParamTypes
+      desc = "The \"" ++ field ++ "\" node parameter"
+  in (FieldDefinition full_name title qft desc,
+      FieldConfig (ndParamGetter field))

htools/Ganeti/Query/Node.hs

+{-| Implementation of the Ganeti Query2 node queries.
+
+ -}
+
+{-
+
+Copyright (C) 2012 Google Inc.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.
+
+-}
+
+module Ganeti.Query.Node
+  ( NodeRuntime(..)
+  , nodeFieldsMap
+  ) where
+
+import Control.Applicative
+import Data.List
+import qualified Data.Map as Map
+
+import Ganeti.Config
+import Ganeti.Objects
+import Ganeti.Qlang
+import Ganeti.Query.Common
+import Ganeti.Query.Types
+
+-- | Stub data type until we integrate the RPC.
+data NodeRuntime = NodeRuntime
+
+-- | List of node live fields, all ignored for now (no RPC).
+nodeLiveFieldsDefs :: [(FieldName, FieldTitle, FieldType, String, FieldDoc)]
+nodeLiveFieldsDefs =
+  [ ("bootid", "BootID", QFTText, "bootid",
+     "Random UUID renewed for each system reboot, can be used\
+     \ for detecting reboots by tracking changes")
+  , ("cnodes", "CNodes", QFTNumber, "cpu_nodes",
+     "Number of NUMA domains on node (if exported by hypervisor)")
+  , ("csockets", "CSockets", QFTNumber, "cpu_sockets",
+     "Number of physical CPU sockets (if exported by hypervisor)")
+  , ("ctotal", "CTotal", QFTNumber, "cpu_total",
+     "Number of logical processors")
+  , ("dfree", "DFree", QFTUnit, "vg_free",
+     "Available disk space in volume group")
+  , ("dtotal", "DTotal", QFTUnit, "vg_size",
+     "Total disk space in volume group used for instance disk allocation")
+  , ("mfree", "MFree", QFTUnit, "memory_free",
+     "Memory available for instance allocations")
+  , ("mnode", "MNode", QFTUnit, "memory_dom0",
+     "Amount of memory used by node (dom0 for Xen)")
+  , ("mtotal", "MTotal", QFTUnit, "memory_total",
+     "Total amount of memory of physical machine")
+  ]
+
+-- | Builder for node live fields.
+nodeLiveFieldBuilder :: (FieldName, FieldTitle, FieldType, String, FieldDoc)
+                     -> FieldData Node NodeRuntime
+nodeLiveFieldBuilder (fname, ftitle, ftype, _, fdoc) =
+  (FieldDefinition fname ftitle ftype fdoc, missingRuntime)
+
+-- | The docstring for the node role. Note that we use 'reverse in
+-- order to keep the same order as Python.
+nodeRoleDoc :: String
+nodeRoleDoc =
+  "Node role; " ++
+  (intercalate ", " $
+   map (\role ->
+          "\"" ++ nodeRoleToRaw role ++ "\" for " ++ roleDescription role)
+   (reverse [minBound..maxBound]))
+
+-- | List of all node fields.
+nodeFields :: FieldList Node NodeRuntime
+nodeFields =
+  [ (FieldDefinition "drained" "Drained" QFTBool "Whether node is drained",
+     FieldSimple (rsNormal . nodeDrained))
+  , (FieldDefinition "master_candidate" "MasterC" QFTBool
+       "Whether node is a master candidate",
+     FieldSimple (rsNormal . nodeMasterCandidate))
+  , (FieldDefinition "master_capable" "MasterCapable" QFTBool
+       "Whether node can become a master candidate",
+     FieldSimple (rsNormal . nodeMasterCapable))
+  , (FieldDefinition "name" "Node" QFTText "Node name",
+     FieldSimple (rsNormal . nodeName))
+  , (FieldDefinition "offline" "Offline" QFTBool
+       "Whether node is marked offline",
+     FieldSimple (rsNormal . nodeOffline))
+  , (FieldDefinition "vm_capable" "VMCapable" QFTBool
+       "Whether node can host instances",
+     FieldSimple (rsNormal . nodeVmCapable))
+  , (FieldDefinition "pip" "PrimaryIP" QFTText "Primary IP address",
+     FieldSimple (rsNormal . nodePrimaryIp))
+  , (FieldDefinition "sip" "SecondaryIP" QFTText "Secondary IP address",
+     FieldSimple (rsNormal . nodeSecondaryIp))
+  , (FieldDefinition "master" "IsMaster" QFTBool "Whether node is master",
+     FieldConfig (\cfg node ->
+                    rsNormal (nodeName node ==
+                              clusterMasterNode (configCluster cfg))))
+  , (FieldDefinition "group" "Group" QFTText "Node group",
+     FieldConfig (\cfg node ->
+                    rsMaybe (groupName <$> getGroupOfNode cfg node)))
+  , (FieldDefinition "group.uuid" "GroupUUID" QFTText "UUID of node group",
+     FieldSimple (rsNormal . nodeGroup))
+  ,  (FieldDefinition "ndparams" "NodeParameters" QFTOther
+        "Merged node parameters",
+      FieldConfig ((rsMaybe .) . getNodeNdParams))
+  , (FieldDefinition "custom_ndparams" "CustomNodeParameters" QFTOther
+                       "Custom node parameters",
+     FieldSimple (rsNormal . nodeNdparams))
+  -- 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))
+  , (FieldDefinition "sinst_cnt" "Sinst" QFTNumber
+       "Number of instances with this node as secondary",
+     FieldConfig (\cfg ->
+                    rsNormal . length . snd . getNodeInstances cfg . nodeName))
+  , (FieldDefinition "pinst_list" "PriInstances" QFTNumber
+       "List of instances with this node as primary",
+     FieldConfig (\cfg -> rsNormal . map instName . fst .
+                          getNodeInstances cfg . nodeName))
+  , (FieldDefinition "sinst_list" "SecInstances" QFTNumber
+       "List of instances with this node as secondary",
+     FieldConfig (\cfg -> rsNormal . map instName . snd .
+                          getNodeInstances cfg . nodeName))
+  , (FieldDefinition "role" "Role" QFTText nodeRoleDoc,
+     FieldConfig ((rsNormal .) . getNodeRole))
+  -- FIXME: the powered state is special (has an different context,
+  -- not runtime) in Python
+  , (FieldDefinition "powered" "Powered" QFTBool
+       "Whether node is thought to be powered on",
+     missingRuntime)
+  -- 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)
+  , (FieldDefinition "disk_state" "DiskState" QFTOther "Disk state",
+     missingRuntime)
+  ] ++
+  map nodeLiveFieldBuilder nodeLiveFieldsDefs ++
+  map buildNdParamField allNDParamFields ++
+  timeStampFields ++
+  uuidFields "Node" ++
+  serialFields "Node" ++
+  tagsFields
+
+-- | The node fields map.
+nodeFieldsMap :: FieldMap Node NodeRuntime
+nodeFieldsMap = Map.fromList $ map (\v -> (fdefName (fst v), v)) nodeFields

htools/Ganeti/Query/Query.hs

@@ -27,13 +27,55 @@ module Ganeti.Query.Query
     ( query
     ) where
 
+import Data.Maybe (fromMaybe)
+import qualified Data.Map as Map
+
 import Ganeti.BasicTypes
+import Ganeti.HTools.JSON
 import Ganeti.Qlang
+import Ganeti.Query.Common
+import Ganeti.Query.Types
+import Ganeti.Query.Node
 import Ganeti.Objects
 
+-- * Helper functions
+
+-- | Builds an unknown field definition.
+mkUnknownFDef :: String -> FieldData a b
+mkUnknownFDef name =
+  ( FieldDefinition name name QFTUnknown ("Unknown field '" ++ name ++ "'")
+  , FieldUnknown )
+
+-- | Runs a field getter on the existing contexts.
+execGetter :: ConfigData -> b -> a -> FieldGetter a b -> ResultEntry
+execGetter _   _ item (FieldSimple getter)  = getter item
+execGetter cfg _ item (FieldConfig getter)  = getter cfg item
+execGetter _  rt item (FieldRuntime getter) = getter rt item
+execGetter _   _ _    FieldUnknown          = rsUnknown
+
+-- * Main query execution
+
+-- | Helper to build the list of requested fields. This transforms the
+-- list of string fields to a list of field defs and getters, with
+-- some of them possibly being unknown fields.
+getSelectedFields :: FieldMap a b  -- ^ Defined fields
+                  -> [String]      -- ^ Requested fields
+                  -> FieldList a b -- ^ Selected fields
+getSelectedFields defined =
+  map (\name -> fromMaybe (mkUnknownFDef name) $ name `Map.lookup` defined)
+
 -- | Main query execution function.
 query :: ConfigData   -- ^ The current configuration
       -> Query        -- ^ The query (item, fields, filter)
       -> IO (Result QueryResult) -- ^ Result
+
+query cfg (Query QRNode fields _) = return $ do
+  let selected = getSelectedFields nodeFieldsMap fields
+      (fdefs, fgetters) = unzip selected
+      nodes = Map.elems . fromContainer $ configNodes cfg
+      fdata = map (\node -> map (execGetter cfg NodeRuntime node) fgetters)
+              nodes
+  return QueryResult { qresFields = fdefs, qresData = fdata }
+
 query _ (Query qkind _ _) =
   return . Bad $ "Query '" ++ show qkind ++ "' not supported"

htools/Ganeti/Query/Types.hs

+{-| Implementation of the Ganeti Query2 basic types.
+
+These are types internal to the library, and for example clients that
+use the library should not need to import it.
+
+ -}
+
+{-
+
+Copyright (C) 2012 Google Inc.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.
+
+-}
+
+module Ganeti.Query.Types where
+
+import qualified Data.Map as Map
+
+import Ganeti.Qlang
+import Ganeti.Objects
+
+-- | The type of field getters. The \"a\" type represents the type
+-- we're querying, whereas the \"b\" type represents the \'runtime\'
+-- data for that type (if any). Note that we don't support multiple
+-- runtime sources, and we always consider the entire configuration as
+-- a given (so no equivalent for Python's /*_CONFIG/ and /*_GROUP/;
+-- configuration accesses are cheap for us).
+data FieldGetter a b = FieldSimple  (a -> ResultEntry)
+                     | FieldRuntime (b -> a -> ResultEntry)
+                     | FieldConfig  (ConfigData -> a -> ResultEntry)
+                     | FieldUnknown
+
+-- | Alias for a field data (definition and getter).
+type FieldData a b = (FieldDefinition, FieldGetter a b)
+
+-- | Alias for a field data list.
+type FieldList a b = [FieldData a b]
+
+-- | Alias for field maps.
+type FieldMap a b = Map.Map String (FieldData a b)