NodeGroup query in Haskell

Implementation of nodegroup queries in Haskell. This is not yet
complete as we are missing merged disk parameters and option
want_diskparams is not implemented.

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

diff --git a/Makefile.am b/Makefile.am
index b1f3ab8..644bddf 100644 (file)
--- a/Makefile.am
+++ b/Makefile.am
@@ -443,6 +443,7 @@ HS_LIB_SRCS = \
        htools/Ganeti/Path.hs \
        htools/Ganeti/Query/Common.hs \
        htools/Ganeti/Query/Filter.hs \
+       htools/Ganeti/Query/Group.hs \
        htools/Ganeti/Query/Language.hs \
        htools/Ganeti/Query/Node.hs \
        htools/Ganeti/Query/Query.hs \

diff --git a/htools/Ganeti/Query/Group.hs b/htools/Ganeti/Query/Group.hs
new file mode 100644 (file)
index 0000000..b76d6c3
--- /dev/null
+++ b/htools/Ganeti/Query/Group.hs
@@ -0,0 +1,87 @@
+{-| Implementation of the Ganeti Query2 node group 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.Group
+  ( GroupRuntime(..)
+  , groupFieldsMap
+  ) where
+
+import qualified Data.Map as Map
+
+import Ganeti.Config
+import Ganeti.Objects
+import Ganeti.Query.Language
+import Ganeti.Query.Common
+import Ganeti.Query.Types
+
+-- | There is no runtime.
+data GroupRuntime = GroupRuntime
+
+groupFields :: FieldList NodeGroup GroupRuntime
+groupFields =
+  [ (FieldDefinition "alloc_policy" "AllocPolicy" QFTText
+       "Allocation policy for group",
+     FieldSimple (rsNormal . groupAllocPolicy))
+  , (FieldDefinition "custom_diskparams" "CustomDiskParameters" QFTOther
+       "Custom disk parameters",
+     FieldSimple (rsNormal . groupDiskparams))
+  , (FieldDefinition "custom_ipolicy" "CustomInstancePolicy" QFTOther
+       "Custom instance policy limitations",
+     FieldSimple (rsNormal . groupIpolicy))
+  , (FieldDefinition "custom_ndparams" "CustomNDParams" QFTOther
+       "Custom node parameters",
+     FieldSimple (rsNormal . groupNdparams))
+  , (FieldDefinition "diskparams" "DiskParameters" QFTOther
+       "Disk parameters (merged)", FieldSimple (\_ -> rsNoData))
+  , (FieldDefinition "ipolicy" "InstancePolicy" QFTOther
+       "Instance policy limitations (merged)",
+     FieldConfig (\cfg ng -> rsNormal (getGroupIpolicy cfg ng)))
+  , (FieldDefinition "name" "Group" QFTText "Group name",
+     FieldSimple (rsNormal . groupName))
+  , (FieldDefinition "ndparams" "NDParams" QFTOther "Node parameters",
+     FieldConfig (\cfg ng -> rsNormal (getGroupNdParams cfg ng)))
+  , (FieldDefinition "node_cnt" "Nodes" QFTNumber "Number of nodes",
+     FieldConfig (\cfg -> rsNormal . length . getGroupNodes cfg . groupName))
+  , (FieldDefinition "node_list" "NodeList" QFTOther "List of nodes",
+     FieldConfig (\cfg -> rsNormal . map nodeName .
+                          getGroupNodes cfg . groupName))
+  , (FieldDefinition "pinst_cnt" "Instances" QFTNumber
+       "Number of primary instances",
+     FieldConfig
+       (\cfg -> rsNormal . length . fst . getGroupInstances cfg . groupName))
+  , (FieldDefinition "pinst_list" "InstanceList" QFTOther
+       "List of primary instances",
+     FieldConfig (\cfg -> rsNormal . map instName . fst .
+                          getGroupInstances cfg . groupName))
+  ] ++
+  map buildNdParamField allNDParamFields ++
+  timeStampFields ++
+  uuidFields "Group" ++
+  serialFields "Group" ++
+  tagsFields
+
+-- | The group fields map.
+groupFieldsMap :: FieldMap NodeGroup GroupRuntime
+groupFieldsMap = Map.fromList $ map (\v -> (fdefName (fst v), v)) groupFields

diff --git a/htools/Ganeti/Query/Query.hs b/htools/Ganeti/Query/Query.hs
index 5b09c63..d348be1 100644 (file)
--- a/htools/Ganeti/Query/Query.hs
+++ b/htools/Ganeti/Query/Query.hs
@@ -61,6 +61,7 @@ import Ganeti.Query.Common
 import Ganeti.Query.Filter
 import Ganeti.Query.Types
 import Ganeti.Query.Node
+import Ganeti.Query.Group
 import Ganeti.Objects
 
 -- * Helper functions
@@ -109,10 +110,25 @@ query cfg (Query QRNode fields qfilter) = return $ do
               fnodes
   return QueryResult { qresFields = fdefs, qresData = fdata }
 
+query cfg (Query QRGroup fields qfilter) = return $ do
+  -- FIXME: want_diskparams is defaulted to false and not taken as parameter
+  -- This is because the type for DiskParams is right now too generic for merges
+  -- (or else I cannot see how to do this with curent implementation)
+  cfilter <- compileFilter groupFieldsMap qfilter
+  let selected = getSelectedFields groupFieldsMap fields
+      (fdefs, fgetters) = unzip selected
+      groups = Map.elems . fromContainer $ configNodegroups cfg
+  -- there is no live data for groups, so filtering is much simpler
+  fgroups <- filterM (\n -> evaluateFilter cfg Nothing n cfilter) groups
+  let fdata = map (\node ->
+                       map (execGetter cfg GroupRuntime node) fgetters) fgroups
+  return QueryResult {qresFields = fdefs, qresData = fdata }
+
 query _ (Query qkind _ _) =
   return . Bad $ "Query '" ++ show qkind ++ "' not supported"
 
 -- | Query fields call.
+-- FIXME: Looks generic enough to use a typeclass
 queryFields :: QueryFields -> Result QueryFieldsResult
 queryFields (QueryFields QRNode fields) =
   let selected = if null fields
@@ -120,5 +136,12 @@ queryFields (QueryFields QRNode fields) =
                    else getSelectedFields nodeFieldsMap fields
   in Ok $ QueryFieldsResult (map fst selected)
 
+queryFields (QueryFields QRGroup fields) =
+  let selected = if null fields
+                   then map snd $ Map.toAscList groupFieldsMap
+                   else getSelectedFields groupFieldsMap fields
+  in Ok $ QueryFieldsResult (map fst selected)
+
+
 queryFields (QueryFields qkind _) =
   Bad $ "QueryFields '" ++ show qkind ++ "' not supported"