[PATCH master 00/23] Complete and enable node/group queries over query socket

[Iustin Pop]

This patch series fixes bugs with the current query implementation, adds
support for a few missing fields, changes a bit the behaviour so that
the output more closely matches the masterd output, adds support for
classic queries (like in Python, piggy-backed on top of query2) and then
enables the queries for nodes/groups to go over the query socket.

At the end of the patch series, there are a few cleanup patches for
things I've seen (and found wanting) during the writing of the main
content.

The patch series passes distcheck/commit check/a quick QA.

Iustin Pop (23):
Rename Ganeti/HTools/Utils.hs to Ganeti/Utils.hs
Remove qualified import of Utils.hs into its test module
Fixup TAGS generation with newer GHC
Add missing ipolicy field
Fixup node live field names
Fixup hypervisor queries in node query
Fixup node disk free/total queries
Add functionality for checking validity of names
Use the new name filtering behaviour in query
Add an Utils.NiceSort() equivalent
Switch ordering of names on query to niceSort
Add function for getting a group's merged disk params
Try to auto-enable htools-rapi and split query
Simplify a bit queryFields
Fix the node powered field
Add a makeSimpleFilter function
Add support for classic queries
Enable query socket usage in gnt-node/gnt-group
A few cleanups in Makefile.am
Add a helper for query field checks
Cleanup/expand the filter/query tests
Cleanup network timeouts and htools imports
Cleanup haddock documentation a bit

Makefile.am | 193 +++++++++++-----------
configure.ac | 67 +++++---
htest/Test/Ganeti/HTools/Text.hs | 2 +-
htest/Test/Ganeti/HTools/Utils.hs | 132 ---------------
htest/Test/Ganeti/Query/Filter.hs | 85 +++++++---
htest/Test/Ganeti/Query/Query.hs | 19 +++
htest/Test/Ganeti/Utils.hs | 218 +++++++++++++++++++++++++
htest/test.hs | 4 +-
htools/Ganeti/Confd/Server.hs | 4 +-
htools/Ganeti/Confd/Utils.hs | 2 +-
htools/Ganeti/Config.hs | 8 +
htools/Ganeti/Daemon.hs | 2 +-
htools/Ganeti/HTools/CLI.hs | 4 +-
htools/Ganeti/HTools/Cluster.hs | 2 +-
htools/Ganeti/HTools/ExtLoader.hs | 2 +-
htools/Ganeti/HTools/Instance.hs | 2 +-
htools/Ganeti/HTools/Loader.hs | 2 +-
htools/Ganeti/HTools/Program/Hbal.hs | 2 +-
htools/Ganeti/HTools/Program/Hinfo.hs | 2 +-
htools/Ganeti/HTools/Program/Hspace.hs | 2 +-
htools/Ganeti/HTools/Rapi.hs | 12 +-
htools/Ganeti/HTools/Simu.hs | 2 +-
htools/Ganeti/HTools/Text.hs | 2 +-
htools/Ganeti/HTools/Types.hs | 10 --
htools/Ganeti/HTools/Utils.hs | 232 ---------------------------
htools/Ganeti/Luxi.hs | 10 +-
htools/Ganeti/Objects.hs | 1 +
htools/Ganeti/Query/Common.hs | 5 +
htools/Ganeti/Query/Filter.hs | 21 +++
htools/Ganeti/Query/Group.hs | 3 +-
htools/Ganeti/Query/Node.hs | 56 ++++---
htools/Ganeti/Query/Query.hs | 98 +++++++++---
htools/Ganeti/Query/Server.hs | 20 +++
htools/Ganeti/Query/Types.hs | 13 +-
htools/Ganeti/Ssconf.hs | 2 +-
htools/Ganeti/THH.hs | 2 +-
htools/Ganeti/Utils.hs | 275 ++++++++++++++++++++++++++++++++
htools/haddock-prologue | 10 +-
htools/htools.hs | 2 +-
lib/client/gnt_group.py | 10 +-
lib/client/gnt_node.py | 19 ++-
lib/rapi/rlib2.py | 10 +-
42 files changed, 956 insertions(+), 613 deletions(-)
delete mode 100644 htest/Test/Ganeti/HTools/Utils.hs
create mode 100644 htest/Test/Ganeti/Utils.hs
delete mode 100644 htools/Ganeti/HTools/Utils.hs
create mode 100644 htools/Ganeti/Utils.hs

--
1.7.10.4

[Iustin Pop]

This is, I believe, the last non-htools specific file that still lived
in the htools directory; it's already widely used in non-htools code,
so let's move it before we add more functionality to this module.

All changes are related to the name change, imports fixup, etc.; there
are no other changes in this patch.

Signed-off-by: Iustin Pop <ius...@google.com>
---
Makefile.am | 8 +-
htest/Test/Ganeti/HTools/Text.hs | 2 +-
htest/Test/Ganeti/HTools/Utils.hs | 132 ------------------
htest/Test/Ganeti/Utils.hs | 132 ++++++++++++++++++
htest/test.hs | 4 +-
htools/Ganeti/Confd/Server.hs | 2 +-
htools/Ganeti/Confd/Utils.hs | 2 +-

htools/Ganeti/Daemon.hs | 2 +-
htools/Ganeti/HTools/CLI.hs | 4 +-
htools/Ganeti/HTools/Cluster.hs | 2 +-
htools/Ganeti/HTools/ExtLoader.hs | 2 +-
htools/Ganeti/HTools/Instance.hs | 2 +-
htools/Ganeti/HTools/Loader.hs | 2 +-
htools/Ganeti/HTools/Program/Hbal.hs | 2 +-
htools/Ganeti/HTools/Program/Hinfo.hs | 2 +-
htools/Ganeti/HTools/Program/Hspace.hs | 2 +-

htools/Ganeti/HTools/Simu.hs | 2 +-
htools/Ganeti/HTools/Text.hs | 2 +-

htools/Ganeti/HTools/Utils.hs | 232 --------------------------------
htools/Ganeti/Luxi.hs | 2 +-
htools/Ganeti/Ssconf.hs | 2 +-
htools/Ganeti/Utils.hs | 232 ++++++++++++++++++++++++++++++++
htools/htools.hs | 2 +-
23 files changed, 388 insertions(+), 388 deletions(-)

delete mode 100644 htest/Test/Ganeti/HTools/Utils.hs
create mode 100644 htest/Test/Ganeti/Utils.hs
delete mode 100644 htools/Ganeti/HTools/Utils.hs
create mode 100644 htools/Ganeti/Utils.hs

diff --git a/Makefile.am b/Makefile.am
index ee74e2c..b861318 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -420,7 +420,6 @@ HS_LIB_SRCS = \
htools/Ganeti/HTools/Simu.hs \
htools/Ganeti/HTools/Text.hs \
htools/Ganeti/HTools/Types.hs \
- htools/Ganeti/HTools/Utils.hs \
htools/Ganeti/HTools/Program.hs \
htools/Ganeti/HTools/Program/Hail.hs \
htools/Ganeti/HTools/Program/Hbal.hs \
@@ -455,7 +454,8 @@ HS_LIB_SRCS = \
htools/Ganeti/Rpc.hs \
htools/Ganeti/Runtime.hs \
htools/Ganeti/Ssconf.hs \
- htools/Ganeti/THH.hs
+ htools/Ganeti/THH.hs \
+ htools/Ganeti/Utils.hs

HS_TEST_SRCS = \
htest/Test/Ganeti/BasicTypes.hs \
@@ -472,7 +472,6 @@ HS_TEST_SRCS = \
htest/Test/Ganeti/HTools/Simu.hs \
htest/Test/Ganeti/HTools/Text.hs \
htest/Test/Ganeti/HTools/Types.hs \
- htest/Test/Ganeti/HTools/Utils.hs \
htest/Test/Ganeti/JSON.hs \
htest/Test/Ganeti/Jobs.hs \
htest/Test/Ganeti/Luxi.hs \
@@ -485,7 +484,8 @@ HS_TEST_SRCS = \
htest/Test/Ganeti/Ssconf.hs \
htest/Test/Ganeti/TestCommon.hs \
htest/Test/Ganeti/TestHTools.hs \
- htest/Test/Ganeti/TestHelper.hs
+ htest/Test/Ganeti/TestHelper.hs \
+ htest/Test/Ganeti/Utils.hs

HS_LIBTEST_SRCS = $(HS_LIB_SRCS) $(HS_TEST_SRCS)

diff --git a/htest/Test/Ganeti/HTools/Text.hs b/htest/Test/Ganeti/HTools/Text.hs
index c1c23c5..d64cb17 100644
--- a/htest/Test/Ganeti/HTools/Text.hs
+++ b/htest/Test/Ganeti/HTools/Text.hs
@@ -48,7 +48,7 @@ import qualified Ganeti.HTools.Loader as Loader
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Text as Text
import qualified Ganeti.HTools.Types as Types
-import qualified Ganeti.HTools.Utils as Utils
+import qualified Ganeti.Utils as Utils

-- * Instance text loader tests

diff --git a/htest/Test/Ganeti/HTools/Utils.hs b/htest/Test/Ganeti/HTools/Utils.hs
deleted file mode 100644
index abb3e32..0000000
--- a/htest/Test/Ganeti/HTools/Utils.hs
+++ /dev/null
@@ -1,132 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-{-| Unittests for ganeti-htools.
-
--}
-
-{-
-
-Copyright (C) 2009, 2010, 2011, 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 Test.Ganeti.HTools.Utils (testHTools_Utils) where
-
-import Test.QuickCheck
-
-import qualified Text.JSON as J
-
-import Test.Ganeti.TestHelper
-import Test.Ganeti.TestCommon
-
-import qualified Ganeti.JSON as JSON
-import qualified Ganeti.HTools.Types as Types
-import qualified Ganeti.HTools.Utils as Utils
-
--- | Helper to generate a small string that doesn't contain commas.
-genNonCommaString :: Gen String
-genNonCommaString = do
- size <- choose (0, 20) -- arbitrary max size
- vectorOf size (arbitrary `suchThat` (/=) ',')
-
--- | If the list is not just an empty element, and if the elements do
--- not contain commas, then join+split should be idempotent.
-prop_commaJoinSplit :: Property
-prop_commaJoinSplit =
- forAll (choose (0, 20)) $ \llen ->
- forAll (vectorOf llen genNonCommaString `suchThat` (/=) [""]) $ \lst ->
- Utils.sepSplit ',' (Utils.commaJoin lst) ==? lst
-
--- | Split and join should always be idempotent.
-prop_commaSplitJoin :: String -> Property
-prop_commaSplitJoin s =
- Utils.commaJoin (Utils.sepSplit ',' s) ==? s
-
--- | fromObjWithDefault, we test using the Maybe monad and an integer
--- value.
-prop_fromObjWithDefault :: Integer -> String -> Bool
-prop_fromObjWithDefault def_value random_key =
- -- a missing key will be returned with the default
- JSON.fromObjWithDefault [] random_key def_value == Just def_value &&
- -- a found key will be returned as is, not with default
- JSON.fromObjWithDefault [(random_key, J.showJSON def_value)]
- random_key (def_value+1) == Just def_value
-
--- | Test that functional if' behaves like the syntactic sugar if.
-prop_if'if :: Bool -> Int -> Int -> Gen Prop
-prop_if'if cnd a b =
- Utils.if' cnd a b ==? if cnd then a else b
-
--- | Test basic select functionality
-prop_select :: Int -- ^ Default result
- -> [Int] -- ^ List of False values
- -> [Int] -- ^ List of True values
- -> Gen Prop -- ^ Test result
-prop_select def lst1 lst2 =
- Utils.select def (flist ++ tlist) ==? expectedresult
- where expectedresult = Utils.if' (null lst2) def (head lst2)
- flist = zip (repeat False) lst1
- tlist = zip (repeat True) lst2
-
--- | Test basic select functionality with undefined default
-prop_select_undefd :: [Int] -- ^ List of False values
- -> NonEmptyList Int -- ^ List of True values
- -> Gen Prop -- ^ Test result
-prop_select_undefd lst1 (NonEmpty lst2) =
- Utils.select undefined (flist ++ tlist) ==? head lst2
- where flist = zip (repeat False) lst1
- tlist = zip (repeat True) lst2
-
--- | Test basic select functionality with undefined list values
-prop_select_undefv :: [Int] -- ^ List of False values
- -> NonEmptyList Int -- ^ List of True values
- -> Gen Prop -- ^ Test result
-prop_select_undefv lst1 (NonEmpty lst2) =
- Utils.select undefined cndlist ==? head lst2
- where flist = zip (repeat False) lst1
- tlist = zip (repeat True) lst2
- cndlist = flist ++ tlist ++ [undefined]
-
-prop_parseUnit :: NonNegative Int -> Property
-prop_parseUnit (NonNegative n) =
- Utils.parseUnit (show n) ==? Types.Ok n .&&.
- Utils.parseUnit (show n ++ "m") ==? Types.Ok n .&&.
- Utils.parseUnit (show n ++ "M") ==? Types.Ok (truncate n_mb::Int) .&&.
- Utils.parseUnit (show n ++ "g") ==? Types.Ok (n*1024) .&&.
- Utils.parseUnit (show n ++ "G") ==? Types.Ok (truncate n_gb::Int) .&&.
- Utils.parseUnit (show n ++ "t") ==? Types.Ok (n*1048576) .&&.
- Utils.parseUnit (show n ++ "T") ==? Types.Ok (truncate n_tb::Int) .&&.
- printTestCase "Internal error/overflow?"
- (n_mb >=0 && n_gb >= 0 && n_tb >= 0) .&&.
- property (Types.isBad (Utils.parseUnit (show n ++ "x")::Types.Result Int))
- where n_mb = (fromIntegral n::Rational) * 1000 * 1000 / 1024 / 1024
- n_gb = n_mb * 1000
- n_tb = n_gb * 1000
-
--- | Test list for the Utils module.
-testSuite "HTools/Utils"
- [ 'prop_commaJoinSplit
- , 'prop_commaSplitJoin
- , 'prop_fromObjWithDefault
- , 'prop_if'if
- , 'prop_select
- , 'prop_select_undefd
- , 'prop_select_undefv
- , 'prop_parseUnit
- ]
diff --git a/htest/Test/Ganeti/Utils.hs b/htest/Test/Ganeti/Utils.hs
new file mode 100644
index 0000000..e2ce7d7
--- /dev/null
+++ b/htest/Test/Ganeti/Utils.hs
@@ -0,0 +1,132 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{-| Unittests for ganeti-htools.
+
+-}
+
+{-
+
+Copyright (C) 2009, 2010, 2011, 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 Test.Ganeti.Utils (testUtils) where
+
+import Test.QuickCheck
+
+import qualified Text.JSON as J
+
+import Test.Ganeti.TestHelper
+import Test.Ganeti.TestCommon
+
+import qualified Ganeti.JSON as JSON
+import qualified Ganeti.HTools.Types as Types
+import qualified Ganeti.Utils as Utils
+
+-- | Helper to generate a small string that doesn't contain commas.
+genNonCommaString :: Gen String
+genNonCommaString = do
+ size <- choose (0, 20) -- arbitrary max size
+ vectorOf size (arbitrary `suchThat` (/=) ',')
+
+-- | If the list is not just an empty element, and if the elements do
+-- not contain commas, then join+split should be idempotent.
+prop_commaJoinSplit :: Property
+prop_commaJoinSplit =
+ forAll (choose (0, 20)) $ \llen ->
+ forAll (vectorOf llen genNonCommaString `suchThat` (/=) [""]) $ \lst ->
+ Utils.sepSplit ',' (Utils.commaJoin lst) ==? lst
+
+-- | Split and join should always be idempotent.
+prop_commaSplitJoin :: String -> Property
+prop_commaSplitJoin s =
+ Utils.commaJoin (Utils.sepSplit ',' s) ==? s
+
+-- | fromObjWithDefault, we test using the Maybe monad and an integer
+-- value.
+prop_fromObjWithDefault :: Integer -> String -> Bool
+prop_fromObjWithDefault def_value random_key =
+ -- a missing key will be returned with the default
+ JSON.fromObjWithDefault [] random_key def_value == Just def_value &&
+ -- a found key will be returned as is, not with default
+ JSON.fromObjWithDefault [(random_key, J.showJSON def_value)]
+ random_key (def_value+1) == Just def_value
+
+-- | Test that functional if' behaves like the syntactic sugar if.
+prop_if'if :: Bool -> Int -> Int -> Gen Prop
+prop_if'if cnd a b =
+ Utils.if' cnd a b ==? if cnd then a else b
+
+-- | Test basic select functionality
+prop_select :: Int -- ^ Default result
+ -> [Int] -- ^ List of False values
+ -> [Int] -- ^ List of True values
+ -> Gen Prop -- ^ Test result
+prop_select def lst1 lst2 =
+ Utils.select def (flist ++ tlist) ==? expectedresult
+ where expectedresult = Utils.if' (null lst2) def (head lst2)
+ flist = zip (repeat False) lst1
+ tlist = zip (repeat True) lst2
+
+-- | Test basic select functionality with undefined default
+prop_select_undefd :: [Int] -- ^ List of False values
+ -> NonEmptyList Int -- ^ List of True values
+ -> Gen Prop -- ^ Test result
+prop_select_undefd lst1 (NonEmpty lst2) =
+ Utils.select undefined (flist ++ tlist) ==? head lst2
+ where flist = zip (repeat False) lst1
+ tlist = zip (repeat True) lst2
+
+-- | Test basic select functionality with undefined list values
+prop_select_undefv :: [Int] -- ^ List of False values
+ -> NonEmptyList Int -- ^ List of True values
+ -> Gen Prop -- ^ Test result
+prop_select_undefv lst1 (NonEmpty lst2) =
+ Utils.select undefined cndlist ==? head lst2
+ where flist = zip (repeat False) lst1
+ tlist = zip (repeat True) lst2
+ cndlist = flist ++ tlist ++ [undefined]
+
+prop_parseUnit :: NonNegative Int -> Property
+prop_parseUnit (NonNegative n) =
+ Utils.parseUnit (show n) ==? Types.Ok n .&&.
+ Utils.parseUnit (show n ++ "m") ==? Types.Ok n .&&.
+ Utils.parseUnit (show n ++ "M") ==? Types.Ok (truncate n_mb::Int) .&&.
+ Utils.parseUnit (show n ++ "g") ==? Types.Ok (n*1024) .&&.
+ Utils.parseUnit (show n ++ "G") ==? Types.Ok (truncate n_gb::Int) .&&.
+ Utils.parseUnit (show n ++ "t") ==? Types.Ok (n*1048576) .&&.
+ Utils.parseUnit (show n ++ "T") ==? Types.Ok (truncate n_tb::Int) .&&.
+ printTestCase "Internal error/overflow?"
+ (n_mb >=0 && n_gb >= 0 && n_tb >= 0) .&&.
+ property (Types.isBad (Utils.parseUnit (show n ++ "x")::Types.Result Int))
+ where n_mb = (fromIntegral n::Rational) * 1000 * 1000 / 1024 / 1024
+ n_gb = n_mb * 1000
+ n_tb = n_gb * 1000
+
+-- | Test list for the Utils module.
+testSuite "Utils"
+ [ 'prop_commaJoinSplit
+ , 'prop_commaSplitJoin
+ , 'prop_fromObjWithDefault
+ , 'prop_if'if
+ , 'prop_select
+ , 'prop_select_undefd
+ , 'prop_select_undefv
+ , 'prop_parseUnit
+ ]
diff --git a/htest/test.hs b/htest/test.hs
index 9e00d36..9100095 100644
--- a/htest/test.hs
+++ b/htest/test.hs
@@ -44,7 +44,6 @@ import Test.Ganeti.HTools.PeerMap
import Test.Ganeti.HTools.Simu
import Test.Ganeti.HTools.Text
import Test.Ganeti.HTools.Types
-import Test.Ganeti.HTools.Utils
import Test.Ganeti.Jobs
import Test.Ganeti.JSON
import Test.Ganeti.Luxi
@@ -55,6 +54,7 @@ import Test.Ganeti.Query.Language
import Test.Ganeti.Query.Query
import Test.Ganeti.Rpc
import Test.Ganeti.Ssconf
+import Test.Ganeti.Utils

-- | Our default test options, overring the built-in test-framework
-- ones (but not the supplied command line parameters).
@@ -85,7 +85,6 @@ allTests =
, testHTools_Simu
, testHTools_Text
, testHTools_Types
- , testHTools_Utils
, testJSON
, testJobs
, testLuxi
@@ -96,6 +95,7 @@ allTests =
, testQuery_Query
, testRpc
, testSsconf
+ , testUtils
]

-- | Main function. Note we don't use defaultMain since we want to
diff --git a/htools/Ganeti/Confd/Server.hs b/htools/Ganeti/Confd/Server.hs
index b14eb43..5644f11 100644
--- a/htools/Ganeti/Confd/Server.hs
+++ b/htools/Ganeti/Confd/Server.hs
@@ -47,13 +47,13 @@ import System.INotify
import Ganeti.Daemon
import Ganeti.JSON
import Ganeti.HTools.Types
-import Ganeti.HTools.Utils
import Ganeti.Objects
import Ganeti.Confd
import Ganeti.Confd.Utils
import Ganeti.Config
import Ganeti.Hash
import Ganeti.Logging
+import Ganeti.Utils
import qualified Ganeti.Constants as C
import qualified Ganeti.Path as Path
import Ganeti.Query.Server (runQueryD)
diff --git a/htools/Ganeti/Confd/Utils.hs b/htools/Ganeti/Confd/Utils.hs
index 043ded0..01c7ee7 100644
--- a/htools/Ganeti/Confd/Utils.hs
+++ b/htools/Ganeti/Confd/Utils.hs
@@ -42,7 +42,7 @@ import Ganeti.Hash
import qualified Ganeti.Constants as C
import qualified Ganeti.Path as Path
import Ganeti.JSON
-import Ganeti.HTools.Utils
+import Ganeti.Utils

-- | Returns the HMAC key.
getClusterHmac :: IO HashKey
diff --git a/htools/Ganeti/Daemon.hs b/htools/Ganeti/Daemon.hs
index 2b715b5..1a53086 100644
--- a/htools/Ganeti/Daemon.hs
+++ b/htools/Ganeti/Daemon.hs
@@ -65,7 +65,7 @@ import Ganeti.Common as Common
import Ganeti.Logging
import Ganeti.Runtime
import Ganeti.BasicTypes
-import Ganeti.HTools.Utils
+import Ganeti.Utils
import qualified Ganeti.Constants as C
import qualified Ganeti.Ssconf as Ssconf

diff --git a/htools/Ganeti/HTools/CLI.hs b/htools/Ganeti/HTools/CLI.hs
index fee8df8..67b51a1 100644
--- a/htools/Ganeti/HTools/CLI.hs
+++ b/htools/Ganeti/HTools/CLI.hs
@@ -1,7 +1,7 @@
{-| Implementation of command-line functions.

This module holds the common command-line related functions for the
-binaries, separated into this module since "Ganeti.HTools.Utils" is
+binaries, separated into this module since "Ganeti.Utils" is
used in many other places and this is more IO oriented.

-}
@@ -95,9 +95,9 @@ import qualified Ganeti.HTools.Container as Container
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.Path as Path
import Ganeti.HTools.Types
-import Ganeti.HTools.Utils
import Ganeti.BasicTypes
import Ganeti.Common as Common
+import Ganeti.Utils

-- * Data types

diff --git a/htools/Ganeti/HTools/Cluster.hs b/htools/Ganeti/HTools/Cluster.hs
index deb56dd..b36b5de 100644
--- a/htools/Ganeti/HTools/Cluster.hs
+++ b/htools/Ganeti/HTools/Cluster.hs
@@ -86,9 +86,9 @@ import qualified Ganeti.HTools.Instance as Instance
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Group as Group
import Ganeti.HTools.Types
-import Ganeti.HTools.Utils
import Ganeti.Compat
import qualified Ganeti.OpCodes as OpCodes
+import Ganeti.Utils

-- * Types

diff --git a/htools/Ganeti/HTools/ExtLoader.hs b/htools/Ganeti/HTools/ExtLoader.hs
index 797a66f..2ecd100 100644
--- a/htools/Ganeti/HTools/ExtLoader.hs
+++ b/htools/Ganeti/HTools/ExtLoader.hs
@@ -51,7 +51,7 @@ import Ganeti.HTools.Loader (mergeData, checkData, ClusterData(..)

import Ganeti.HTools.Types
import Ganeti.HTools.CLI
-import Ganeti.HTools.Utils (sepSplit, tryRead, exitIfBad, exitWhen)
+import Ganeti.Utils (sepSplit, tryRead, exitIfBad, exitWhen)

-- | Error beautifier.
wrapIO :: IO (Result a) -> IO (Result a)
diff --git a/htools/Ganeti/HTools/Instance.hs b/htools/Ganeti/HTools/Instance.hs
index 9d13556..62803ff 100644
--- a/htools/Ganeti/HTools/Instance.hs
+++ b/htools/Ganeti/HTools/Instance.hs
@@ -60,7 +60,7 @@ module Ganeti.HTools.Instance
import qualified Ganeti.HTools.Types as T
import qualified Ganeti.HTools.Container as Container

-import Ganeti.HTools.Utils
+import Ganeti.Utils

-- * Type declarations

diff --git a/htools/Ganeti/HTools/Loader.hs b/htools/Ganeti/HTools/Loader.hs
index 71893e3..9acf96d 100644
--- a/htools/Ganeti/HTools/Loader.hs
+++ b/htools/Ganeti/HTools/Loader.hs
@@ -52,7 +52,7 @@ import qualified Ganeti.HTools.Cluster as Cluster

import Ganeti.BasicTypes
import Ganeti.HTools.Types
-import Ganeti.HTools.Utils
+import Ganeti.Utils

-- * Constants

diff --git a/htools/Ganeti/HTools/Program/Hbal.hs b/htools/Ganeti/HTools/Program/Hbal.hs
index dc103d3..90a056e 100644
--- a/htools/Ganeti/HTools/Program/Hbal.hs
+++ b/htools/Ganeti/HTools/Program/Hbal.hs
@@ -50,9 +50,9 @@ import qualified Ganeti.HTools.Instance as Instance

import Ganeti.HTools.CLI
import Ganeti.HTools.ExtLoader
-import Ganeti.HTools.Utils
import Ganeti.HTools.Types
import Ganeti.HTools.Loader
+import Ganeti.Utils

import qualified Ganeti.Luxi as L
import Ganeti.Jobs
diff --git a/htools/Ganeti/HTools/Program/Hinfo.hs b/htools/Ganeti/HTools/Program/Hinfo.hs
index 37f5bba..2c5200e 100644
--- a/htools/Ganeti/HTools/Program/Hinfo.hs
+++ b/htools/Ganeti/HTools/Program/Hinfo.hs
@@ -38,10 +38,10 @@ import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Group as Group
import qualified Ganeti.HTools.Instance as Instance

-import Ganeti.HTools.Utils
import Ganeti.HTools.CLI
import Ganeti.HTools.ExtLoader
import Ganeti.HTools.Loader
+import Ganeti.Utils

-- | Options list and functions.
options :: [OptType]
diff --git a/htools/Ganeti/HTools/Program/Hspace.hs b/htools/Ganeti/HTools/Program/Hspace.hs
index 960d4fd..605b4ff 100644
--- a/htools/Ganeti/HTools/Program/Hspace.hs
+++ b/htools/Ganeti/HTools/Program/Hspace.hs
@@ -40,11 +40,11 @@ import qualified Ganeti.HTools.Cluster as Cluster
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Instance as Instance

-import Ganeti.HTools.Utils
import Ganeti.HTools.Types
import Ganeti.HTools.CLI
import Ganeti.HTools.ExtLoader
import Ganeti.HTools.Loader
+import Ganeti.Utils

-- | Options list and functions.
options :: [OptType]
diff --git a/htools/Ganeti/HTools/Simu.hs b/htools/Ganeti/HTools/Simu.hs
index ec8b8b6..2e61ed7 100644
--- a/htools/Ganeti/HTools/Simu.hs
+++ b/htools/Ganeti/HTools/Simu.hs
@@ -33,7 +33,7 @@ module Ganeti.HTools.Simu
import Control.Monad (mplus, zipWithM)
import Text.Printf (printf)

-import Ganeti.HTools.Utils
+import Ganeti.Utils
import Ganeti.HTools.Types
import Ganeti.HTools.Loader
import qualified Ganeti.HTools.Container as Container
diff --git a/htools/Ganeti/HTools/Text.hs b/htools/Ganeti/HTools/Text.hs
index 39a568c..3731bcc 100644
--- a/htools/Ganeti/HTools/Text.hs
+++ b/htools/Ganeti/HTools/Text.hs
@@ -47,7 +47,7 @@ import Data.List

import Text.Printf (printf)

-import Ganeti.HTools.Utils
+import Ganeti.Utils
import Ganeti.HTools.Loader
import Ganeti.HTools.Types
import qualified Ganeti.HTools.Container as Container
diff --git a/htools/Ganeti/HTools/Utils.hs b/htools/Ganeti/HTools/Utils.hs
deleted file mode 100644
index 0efe7fe..0000000
--- a/htools/Ganeti/HTools/Utils.hs
+++ /dev/null
@@ -1,232 +0,0 @@
-{-| Utility functions. -}
-
-{-
-
-Copyright (C) 2009, 2010, 2011, 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.HTools.Utils
- ( debug
- , debugFn
- , debugXy
- , sepSplit
- , stdDev
- , if'
- , select
- , applyIf
- , commaJoin
- , ensureQuoted
- , tryRead
- , formatTable
- , printTable
- , parseUnit
- , plural
- , exitIfBad
- , exitErr
- , exitWhen
- , exitUnless
- ) where
-
-import Data.Char (toUpper, isAlphaNum)
-import Data.List
-
-import Debug.Trace
-
-import Ganeti.BasicTypes
-import System.IO
-import System.Exit
-
--- * Debug functions
-
--- | To be used only for debugging, breaks referential integrity.
-debug :: Show a => a -> a
-debug x = trace (show x) x
-
--- | Displays a modified form of the second parameter before returning
--- it.
-debugFn :: Show b => (a -> b) -> a -> a
-debugFn fn x = debug (fn x) `seq` x
-
--- | Show the first parameter before returning the second one.
-debugXy :: Show a => a -> b -> b
-debugXy = seq . debug
-
--- * Miscellaneous
-
--- | Apply the function if condition holds, otherwise use default value.
-applyIf :: Bool -> (a -> a) -> a -> a
-applyIf b f x = if b then f x else x
-
--- | Comma-join a string list.
-commaJoin :: [String] -> String
-commaJoin = intercalate ","
-
--- | Split a list on a separator and return an array.
-sepSplit :: Eq a => a -> [a] -> [[a]]
-sepSplit sep s
- | null s = []
- | null xs = [x]
- | null ys = [x,[]]
- | otherwise = x:sepSplit sep ys
- where (x, xs) = break (== sep) s
- ys = drop 1 xs
-
--- | Simple pluralize helper
-plural :: Int -> String -> String -> String
-plural 1 s _ = s
-plural _ _ p = p
-
--- | Ensure a value is quoted if needed.
-ensureQuoted :: String -> String
-ensureQuoted v = if not (all (\c -> isAlphaNum c || c == '.') v)
- then '\'':v ++ "'"
- else v
-
--- * Mathematical functions
-
--- Simple and slow statistical functions, please replace with better
--- versions
-
--- | Standard deviation function.
-stdDev :: [Double] -> Double
-stdDev lst =
- -- first, calculate the list length and sum lst in a single step,
- -- for performance reasons
- let (ll', sx) = foldl' (\(rl, rs) e ->
- let rl' = rl + 1
- rs' = rs + e
- in rl' `seq` rs' `seq` (rl', rs')) (0::Int, 0) lst
- ll = fromIntegral ll'::Double
- mv = sx / ll
- av = foldl' (\accu em -> let d = em - mv in accu + d * d) 0.0 lst
- in sqrt (av / ll) -- stddev
-
--- * Logical functions
-
--- Avoid syntactic sugar and enhance readability. These functions are proposed
--- by some for inclusion in the Prelude, and at the moment they are present
--- (with various definitions) in the utility-ht package. Some rationale and
--- discussion is available at <http://www.haskell.org/haskellwiki/If-then-else>
-
--- | \"if\" as a function, rather than as syntactic sugar.
-if' :: Bool -- ^ condition
- -> a -- ^ \"then\" result
- -> a -- ^ \"else\" result
- -> a -- ^ \"then\" or "else" result depending on the condition
-if' True x _ = x
-if' _ _ y = y
-
--- * Parsing utility functions
-
--- | Parse results from readsPrec.
-parseChoices :: (Monad m, Read a) => String -> String -> [(a, String)] -> m a
-parseChoices _ _ ((v, ""):[]) = return v
-parseChoices name s ((_, e):[]) =
- fail $ name ++ ": leftover characters when parsing '"
- ++ s ++ "': '" ++ e ++ "'"
-parseChoices name s _ = fail $ name ++ ": cannot parse string '" ++ s ++ "'"
-
--- | Safe 'read' function returning data encapsulated in a Result.
-tryRead :: (Monad m, Read a) => String -> String -> m a
-tryRead name s = parseChoices name s $ reads s
-
--- | Format a table of strings to maintain consistent length.
-formatTable :: [[String]] -> [Bool] -> [[String]]
-formatTable vals numpos =
- let vtrans = transpose vals -- transpose, so that we work on rows
- -- rather than columns
- mlens = map (maximum . map length) vtrans
- expnd = map (\(flds, isnum, ml) ->
- map (\val ->
- let delta = ml - length val
- filler = replicate delta ' '
- in if delta > 0
- then if isnum
- then filler ++ val
- else val ++ filler
- else val
- ) flds
- ) (zip3 vtrans numpos mlens)
- in transpose expnd
-
--- | Constructs a printable table from given header and rows
-printTable :: String -> [String] -> [[String]] -> [Bool] -> String
-printTable lp header rows isnum =
- unlines . map ((++) lp . (:) ' ' . unwords) $
- formatTable (header:rows) isnum
-
--- | Converts a unit (e.g. m or GB) into a scaling factor.
-parseUnitValue :: (Monad m) => String -> m Rational
-parseUnitValue unit
- -- binary conversions first
- | null unit = return 1
- | unit == "m" || upper == "MIB" = return 1
- | unit == "g" || upper == "GIB" = return kbBinary
- | unit == "t" || upper == "TIB" = return $ kbBinary * kbBinary
- -- SI conversions
- | unit == "M" || upper == "MB" = return mbFactor
- | unit == "G" || upper == "GB" = return $ mbFactor * kbDecimal
- | unit == "T" || upper == "TB" = return $ mbFactor * kbDecimal * kbDecimal
- | otherwise = fail $ "Unknown unit '" ++ unit ++ "'"
- where upper = map toUpper unit
- kbBinary = 1024 :: Rational
- kbDecimal = 1000 :: Rational
- decToBin = kbDecimal / kbBinary -- factor for 1K conversion
- mbFactor = decToBin * decToBin -- twice the factor for just 1K
-
--- | Tries to extract number and scale from the given string.
---
--- Input must be in the format NUMBER+ SPACE* [UNIT]. If no unit is
--- specified, it defaults to MiB. Return value is always an integral
--- value in MiB.
-parseUnit :: (Monad m, Integral a, Read a) => String -> m a
-parseUnit str =
- -- TODO: enhance this by splitting the unit parsing code out and
- -- accepting floating-point numbers
- case (reads str::[(Int, String)]) of
- [(v, suffix)] ->
- let unit = dropWhile (== ' ') suffix
- in do
- scaling <- parseUnitValue unit
- return $ truncate (fromIntegral v * scaling)
- _ -> fail $ "Can't parse string '" ++ str ++ "'"
-
--- | Unwraps a 'Result', exiting the program if it is a 'Bad' value,
--- otherwise returning the actual contained value.
-exitIfBad :: String -> Result a -> IO a
-exitIfBad msg (Bad s) = do
- hPutStrLn stderr $ "Error: " ++ msg ++ ": " ++ s
- exitWith (ExitFailure 1)
-exitIfBad _ (Ok v) = return v
-
--- | Exits immediately with an error message.
-exitErr :: String -> IO a
-exitErr errmsg = do
- hPutStrLn stderr $ "Error: " ++ errmsg ++ "."
- exitWith (ExitFailure 1)
-
--- | Exits with an error message if the given boolean condition if true.
-exitWhen :: Bool -> String -> IO ()
-exitWhen True msg = exitErr msg
-exitWhen False _ = return ()
-
--- | Exits with an error message /unless/ the given boolean condition
--- if true, the opposite of 'exitWhen'.
-exitUnless :: Bool -> String -> IO ()
-exitUnless cond = exitWhen (not cond)
diff --git a/htools/Ganeti/Luxi.hs b/htools/Ganeti/Luxi.hs
index 16fb27d..12dc6ed 100644
--- a/htools/Ganeti/Luxi.hs
+++ b/htools/Ganeti/Luxi.hs
@@ -69,7 +69,7 @@ import qualified Network.Socket as S

import Ganeti.JSON
import Ganeti.HTools.Types
-import Ganeti.HTools.Utils
+import Ganeti.Utils

import Ganeti.Constants
import Ganeti.Jobs (JobStatus)
diff --git a/htools/Ganeti/Ssconf.hs b/htools/Ganeti/Ssconf.hs
index 47a2e04..bf3713b 100644
--- a/htools/Ganeti/Ssconf.hs
+++ b/htools/Ganeti/Ssconf.hs
@@ -48,7 +48,7 @@ import System.IO.Error (isDoesNotExistError)
import qualified Ganeti.Constants as C
import qualified Ganeti.Path as Path
import Ganeti.BasicTypes
-import Ganeti.HTools.Utils
+import Ganeti.Utils

-- | Maximum ssconf file size we support.
maxFileSize :: Int
diff --git a/htools/Ganeti/Utils.hs b/htools/Ganeti/Utils.hs
new file mode 100644
index 0000000..708755e
--- /dev/null
+++ b/htools/Ganeti/Utils.hs
@@ -0,0 +1,232 @@
+{-| Utility functions. -}
+
+{-
+
+Copyright (C) 2009, 2010, 2011, 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.Utils
+ ( debug
+ , debugFn
+ , debugXy
+ , sepSplit
+ , stdDev
+ , if'
+ , select
+ , applyIf
+ , commaJoin
+ , ensureQuoted
+ , tryRead
+ , formatTable
+ , printTable
+ , parseUnit
+ , plural
+ , exitIfBad
+ , exitErr
+ , exitWhen
+ , exitUnless
+ ) where
+
+import Data.Char (toUpper, isAlphaNum)
+import Data.List
+
+import Debug.Trace
+
+import Ganeti.BasicTypes
+import System.IO
+import System.Exit
+
+-- * Debug functions
+
+-- | To be used only for debugging, breaks referential integrity.
+debug :: Show a => a -> a
+debug x = trace (show x) x
+
+-- | Displays a modified form of the second parameter before returning
+-- it.
+debugFn :: Show b => (a -> b) -> a -> a
+debugFn fn x = debug (fn x) `seq` x
+
+-- | Show the first parameter before returning the second one.
+debugXy :: Show a => a -> b -> b
+debugXy = seq . debug
+
+-- * Miscellaneous
+
+-- | Apply the function if condition holds, otherwise use default value.
+applyIf :: Bool -> (a -> a) -> a -> a
+applyIf b f x = if b then f x else x
+
+-- | Comma-join a string list.
+commaJoin :: [String] -> String
+commaJoin = intercalate ","
+
+-- | Split a list on a separator and return an array.
+sepSplit :: Eq a => a -> [a] -> [[a]]
+sepSplit sep s
+ | null s = []
+ | null xs = [x]
+ | null ys = [x,[]]
+ | otherwise = x:sepSplit sep ys
+ where (x, xs) = break (== sep) s
+ ys = drop 1 xs
+
+-- | Simple pluralize helper
+plural :: Int -> String -> String -> String
+plural 1 s _ = s
+plural _ _ p = p
+
+-- | Ensure a value is quoted if needed.
+ensureQuoted :: String -> String
+ensureQuoted v = if not (all (\c -> isAlphaNum c || c == '.') v)
+ then '\'':v ++ "'"
+ else v
+
+-- * Mathematical functions
+
+-- Simple and slow statistical functions, please replace with better
+-- versions
+
+-- | Standard deviation function.
+stdDev :: [Double] -> Double
+stdDev lst =
+ -- first, calculate the list length and sum lst in a single step,
+ -- for performance reasons
+ let (ll', sx) = foldl' (\(rl, rs) e ->
+ let rl' = rl + 1
+ rs' = rs + e
+ in rl' `seq` rs' `seq` (rl', rs')) (0::Int, 0) lst
+ ll = fromIntegral ll'::Double
+ mv = sx / ll
+ av = foldl' (\accu em -> let d = em - mv in accu + d * d) 0.0 lst
+ in sqrt (av / ll) -- stddev
+
+-- * Logical functions
+
+-- Avoid syntactic sugar and enhance readability. These functions are proposed
+-- by some for inclusion in the Prelude, and at the moment they are present
+-- (with various definitions) in the utility-ht package. Some rationale and
+-- discussion is available at <http://www.haskell.org/haskellwiki/If-then-else>
+
+-- | \"if\" as a function, rather than as syntactic sugar.
+if' :: Bool -- ^ condition
+ -> a -- ^ \"then\" result
+ -> a -- ^ \"else\" result
+ -> a -- ^ \"then\" or "else" result depending on the condition
+if' True x _ = x
+if' _ _ y = y
+
+-- * Parsing utility functions
+
+-- | Parse results from readsPrec.
+parseChoices :: (Monad m, Read a) => String -> String -> [(a, String)] -> m a
+parseChoices _ _ ((v, ""):[]) = return v
+parseChoices name s ((_, e):[]) =
+ fail $ name ++ ": leftover characters when parsing '"
+ ++ s ++ "': '" ++ e ++ "'"
+parseChoices name s _ = fail $ name ++ ": cannot parse string '" ++ s ++ "'"
+
+-- | Safe 'read' function returning data encapsulated in a Result.
+tryRead :: (Monad m, Read a) => String -> String -> m a
+tryRead name s = parseChoices name s $ reads s
+
+-- | Format a table of strings to maintain consistent length.
+formatTable :: [[String]] -> [Bool] -> [[String]]
+formatTable vals numpos =
+ let vtrans = transpose vals -- transpose, so that we work on rows
+ -- rather than columns
+ mlens = map (maximum . map length) vtrans
+ expnd = map (\(flds, isnum, ml) ->
+ map (\val ->
+ let delta = ml - length val
+ filler = replicate delta ' '
+ in if delta > 0
+ then if isnum
+ then filler ++ val
+ else val ++ filler
+ else val
+ ) flds
+ ) (zip3 vtrans numpos mlens)
+ in transpose expnd
+
+-- | Constructs a printable table from given header and rows
+printTable :: String -> [String] -> [[String]] -> [Bool] -> String
+printTable lp header rows isnum =
+ unlines . map ((++) lp . (:) ' ' . unwords) $
+ formatTable (header:rows) isnum
+
+-- | Converts a unit (e.g. m or GB) into a scaling factor.
+parseUnitValue :: (Monad m) => String -> m Rational
+parseUnitValue unit
+ -- binary conversions first
+ | null unit = return 1
+ | unit == "m" || upper == "MIB" = return 1
+ | unit == "g" || upper == "GIB" = return kbBinary
+ | unit == "t" || upper == "TIB" = return $ kbBinary * kbBinary
+ -- SI conversions
+ | unit == "M" || upper == "MB" = return mbFactor
+ | unit == "G" || upper == "GB" = return $ mbFactor * kbDecimal
+ | unit == "T" || upper == "TB" = return $ mbFactor * kbDecimal * kbDecimal
+ | otherwise = fail $ "Unknown unit '" ++ unit ++ "'"
+ where upper = map toUpper unit
+ kbBinary = 1024 :: Rational
+ kbDecimal = 1000 :: Rational
+ decToBin = kbDecimal / kbBinary -- factor for 1K conversion
+ mbFactor = decToBin * decToBin -- twice the factor for just 1K
+
+-- | Tries to extract number and scale from the given string.
+--
+-- Input must be in the format NUMBER+ SPACE* [UNIT]. If no unit is
+-- specified, it defaults to MiB. Return value is always an integral
+-- value in MiB.
+parseUnit :: (Monad m, Integral a, Read a) => String -> m a
+parseUnit str =
+ -- TODO: enhance this by splitting the unit parsing code out and
+ -- accepting floating-point numbers
+ case (reads str::[(Int, String)]) of
+ [(v, suffix)] ->
+ let unit = dropWhile (== ' ') suffix
+ in do
+ scaling <- parseUnitValue unit
+ return $ truncate (fromIntegral v * scaling)
+ _ -> fail $ "Can't parse string '" ++ str ++ "'"
+
+-- | Unwraps a 'Result', exiting the program if it is a 'Bad' value,
+-- otherwise returning the actual contained value.
+exitIfBad :: String -> Result a -> IO a
+exitIfBad msg (Bad s) = do
+ hPutStrLn stderr $ "Error: " ++ msg ++ ": " ++ s
+ exitWith (ExitFailure 1)
+exitIfBad _ (Ok v) = return v
+
+-- | Exits immediately with an error message.
+exitErr :: String -> IO a
+exitErr errmsg = do
+ hPutStrLn stderr $ "Error: " ++ errmsg ++ "."
+ exitWith (ExitFailure 1)
+
+-- | Exits with an error message if the given boolean condition if true.
+exitWhen :: Bool -> String -> IO ()
+exitWhen True msg = exitErr msg
+exitWhen False _ = return ()
+
+-- | Exits with an error message /unless/ the given boolean condition
+-- if true, the opposite of 'exitWhen'.
+exitUnless :: Bool -> String -> IO ()
+exitUnless cond = exitWhen (not cond)
diff --git a/htools/htools.hs b/htools/htools.hs
index 08a5a14..216fe3f 100644
--- a/htools/htools.hs
+++ b/htools/htools.hs
@@ -34,7 +34,7 @@ import System.Exit
import System.IO
import System.IO.Error (isDoesNotExistError)

-import Ganeti.HTools.Utils
+import Ganeti.Utils
import Ganeti.HTools.CLI (parseOpts, genericOpts)
import Ganeti.HTools.Program (personalities)

--
1.7.10.4

[Iustin Pop]

This is a leftover from the times when we had a single, huge test
module; nowadays it's only an annoyance.

Signed-off-by: Iustin Pop <ius...@google.com>
---

htest/Test/Ganeti/Utils.hs | 32 ++++++++++++++++----------------
1 file changed, 16 insertions(+), 16 deletions(-)

diff --git a/htest/Test/Ganeti/Utils.hs b/htest/Test/Ganeti/Utils.hs
index e2ce7d7..98ea53d 100644
--- a/htest/Test/Ganeti/Utils.hs
+++ b/htest/Test/Ganeti/Utils.hs
@@ -37,7 +37,7 @@ import Test.Ganeti.TestCommon

import qualified Ganeti.JSON as JSON

import qualified Ganeti.HTools.Types as Types

-import qualified Ganeti.Utils as Utils
+import Ganeti.Utils

-- | Helper to generate a small string that doesn't contain commas.

genNonCommaString :: Gen String
@@ -51,12 +51,12 @@ prop_commaJoinSplit :: Property
prop_commaJoinSplit =

forAll (choose (0, 20)) $ \llen ->

forAll (vectorOf llen genNonCommaString `suchThat` (/=) [""]) $ \lst ->
- Utils.sepSplit ',' (Utils.commaJoin lst) ==? lst

+ sepSplit ',' (commaJoin lst) ==? lst

-- | Split and join should always be idempotent.

prop_commaSplitJoin :: String -> Property

prop_commaSplitJoin s =
- Utils.commaJoin (Utils.sepSplit ',' s) ==? s

+ commaJoin (sepSplit ',' s) ==? s

-- | fromObjWithDefault, we test using the Maybe monad and an integer

-- value.
@@ -71,7 +71,7 @@ prop_fromObjWithDefault def_value random_key =

-- | Test that functional if' behaves like the syntactic sugar if.

prop_if'if :: Bool -> Int -> Int -> Gen Prop

prop_if'if cnd a b =
- Utils.if' cnd a b ==? if cnd then a else b

+ if' cnd a b ==? if cnd then a else b

-- | Test basic select functionality

prop_select :: Int -- ^ Default result

@@ -79,8 +79,8 @@ prop_select :: Int -- ^ Default result

-> [Int] -- ^ List of True values
-> Gen Prop -- ^ Test result

prop_select def lst1 lst2 =
- Utils.select def (flist ++ tlist) ==? expectedresult
- where expectedresult = Utils.if' (null lst2) def (head lst2)

+ select def (flist ++ tlist) ==? expectedresult
+ where expectedresult = if' (null lst2) def (head lst2)

flist = zip (repeat False) lst1

tlist = zip (repeat True) lst2

@@ -89,7 +89,7 @@ prop_select_undefd :: [Int] -- ^ List of False values

-> NonEmptyList Int -- ^ List of True values

-> Gen Prop -- ^ Test result

prop_select_undefd lst1 (NonEmpty lst2) =
- Utils.select undefined (flist ++ tlist) ==? head lst2

+ select undefined (flist ++ tlist) ==? head lst2

where flist = zip (repeat False) lst1

tlist = zip (repeat True) lst2

@@ -98,23 +98,23 @@ prop_select_undefv :: [Int] -- ^ List of False values

-> NonEmptyList Int -- ^ List of True values

-> Gen Prop -- ^ Test result

prop_select_undefv lst1 (NonEmpty lst2) =
- Utils.select undefined cndlist ==? head lst2

+ select undefined cndlist ==? head lst2

where flist = zip (repeat False) lst1

tlist = zip (repeat True) lst2

cndlist = flist ++ tlist ++ [undefined]

prop_parseUnit :: NonNegative Int -> Property

prop_parseUnit (NonNegative n) =
- Utils.parseUnit (show n) ==? Types.Ok n .&&.
- Utils.parseUnit (show n ++ "m") ==? Types.Ok n .&&.
- Utils.parseUnit (show n ++ "M") ==? Types.Ok (truncate n_mb::Int) .&&.
- Utils.parseUnit (show n ++ "g") ==? Types.Ok (n*1024) .&&.
- Utils.parseUnit (show n ++ "G") ==? Types.Ok (truncate n_gb::Int) .&&.
- Utils.parseUnit (show n ++ "t") ==? Types.Ok (n*1048576) .&&.
- Utils.parseUnit (show n ++ "T") ==? Types.Ok (truncate n_tb::Int) .&&.

+ parseUnit (show n) ==? Types.Ok n .&&.
+ parseUnit (show n ++ "m") ==? Types.Ok n .&&.
+ parseUnit (show n ++ "M") ==? Types.Ok (truncate n_mb::Int) .&&.
+ parseUnit (show n ++ "g") ==? Types.Ok (n*1024) .&&.
+ parseUnit (show n ++ "G") ==? Types.Ok (truncate n_gb::Int) .&&.
+ parseUnit (show n ++ "t") ==? Types.Ok (n*1048576) .&&.
+ parseUnit (show n ++ "T") ==? Types.Ok (truncate n_tb::Int) .&&.
printTestCase "Internal error/overflow?"

(n_mb >=0 && n_gb >= 0 && n_tb >= 0) .&&.
- property (Types.isBad (Utils.parseUnit (show n ++ "x")::Types.Result Int))

+ property (Types.isBad (parseUnit (show n ++ "x")::Types.Result Int))

where n_mb = (fromIntegral n::Rational) * 1000 * 1000 / 1024 / 1024

n_gb = n_mb * 1000

n_tb = n_gb * 1000
--

1.7.10.4

[Iustin Pop]

Newer GHC refuses to allow "-O" with interactive mode, so let's filter
that out. Furthermore, sometimes you don't have a clean tree exactly
when you need to look up something/update the tags, so let's filter
out the "-Werror" too.

And finally, we need to pass the actual exact flags (including
nocurl, parallel, etc.) that we use for building, so let's add those
too.

Signed-off-by: Iustin Pop <ius...@google.com>
---

Makefile.am | 5 ++++-
1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/Makefile.am b/Makefile.am
index b861318..36c1153 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1611,7 +1611,10 @@ hs-apidoc: $(HS_BUILT_SRCS)
.PHONY: TAGS
TAGS: $(GENERATED_FILES)
rm -f TAGS
- $(GHC) -e ":etags" -v0 $(HFLAGS) $(HS_LIBTEST_SRCS)
+ $(GHC) -e ":etags" -v0 \
+ $(filter-out -O -Werror,$(HFLAGS)) \
+ $(HTOOLS_NOCURL) $(HTOOLS_PARALLEL3) \
+ $(HS_LIBTEST_SRCS)
find . -path './lib/*.py' -o -path './scripts/gnt-*' -o \
-path './daemons/ganeti-*' -o -path './tools/*' -o \
-path './qa/*.py' | \
--
1.7.10.4

[Iustin Pop]

This was missing so far…

Signed-off-by: Iustin Pop <ius...@google.com>
---

htools/Ganeti/Objects.hs | 1 +
1 file changed, 1 insertion(+)

diff --git a/htools/Ganeti/Objects.hs b/htools/Ganeti/Objects.hs
index 3504ed5..dfc6480 100644
--- a/htools/Ganeti/Objects.hs
+++ b/htools/Ganeti/Objects.hs
@@ -409,6 +409,7 @@ $(buildParam "ISpec" "ispec"
, simpleField C.ispecDiskSize [t| Int |]
, simpleField C.ispecDiskCount [t| Int |]
, simpleField C.ispecCpuCount [t| Int |]
+ , simpleField C.ispecNicCount [t| Int |]
, simpleField C.ispecSpindleUse [t| Int |]
])

--
1.7.10.4

[Iustin Pop]

The String parameter to 'nodeLiveFieldExtract' is the query2 field
name, not the RPC-layer field name. Grrr for not having a real data
type for this.

Furthermore, we add some safety check that we don't return JSNull via
rsNormal…

Signed-off-by: Iustin Pop <ius...@google.com>
---

htools/Ganeti/Query/Node.hs | 38 ++++++++++++++++++++------------------
1 file changed, 20 insertions(+), 18 deletions(-)

diff --git a/htools/Ganeti/Query/Node.hs b/htools/Ganeti/Query/Node.hs
index ded9979..0630754 100644
--- a/htools/Ganeti/Query/Node.hs
+++ b/htools/Ganeti/Query/Node.hs
@@ -72,29 +72,31 @@ nodeLiveFieldsDefs =
-- the RPC result.
nodeLiveFieldExtract :: String -> RpcResultNodeInfo -> J.JSValue
nodeLiveFieldExtract "bootid" res =
- J.showJSON $ rpcResNodeInfoBootId res
-nodeLiveFieldExtract "cpu_nodes" res =
- jsonHead (rpcResNodeInfoHvInfo res) hvInfoCpuNodes
-nodeLiveFieldExtract "cpu_sockets" res =
- jsonHead (rpcResNodeInfoHvInfo res) hvInfoCpuSockets
-nodeLiveFieldExtract "cpu_total" res =
- jsonHead (rpcResNodeInfoHvInfo res) hvInfoCpuTotal
-nodeLiveFieldExtract "vg_free" res =
- jsonHead (rpcResNodeInfoVgInfo res) vgInfoVgFree
-nodeLiveFieldExtract "vg_size" res =
- jsonHead (rpcResNodeInfoVgInfo res) vgInfoVgSize
-nodeLiveFieldExtract "memory_free" res =
- jsonHead (rpcResNodeInfoHvInfo res) hvInfoMemoryFree
-nodeLiveFieldExtract "memory_dom0" res =
- jsonHead (rpcResNodeInfoHvInfo res) hvInfoMemoryDom0
-nodeLiveFieldExtract "memory_total" res =
- jsonHead (rpcResNodeInfoHvInfo res) hvInfoMemoryTotal
+ J.showJSON $ rpcResNodeInfoBootId res
+nodeLiveFieldExtract "cnodes" res =
+ jsonHead (rpcResNodeInfoHvInfo res) hvInfoCpuNodes
+nodeLiveFieldExtract "csockets" res =
+ jsonHead (rpcResNodeInfoHvInfo res) hvInfoCpuSockets
+nodeLiveFieldExtract "ctotal" res =
+ jsonHead (rpcResNodeInfoHvInfo res) hvInfoCpuTotal
+nodeLiveFieldExtract "dfree" res =
+ jsonHead (rpcResNodeInfoVgInfo res) vgInfoVgFree
+nodeLiveFieldExtract "dtotal" res =
+ jsonHead (rpcResNodeInfoVgInfo res) vgInfoVgSize
+nodeLiveFieldExtract "mfree" res =
+ jsonHead (rpcResNodeInfoHvInfo res) hvInfoMemoryFree
+nodeLiveFieldExtract "mnode" res =
+ jsonHead (rpcResNodeInfoHvInfo res) hvInfoMemoryDom0
+nodeLiveFieldExtract "mtotal" res =
+ jsonHead (rpcResNodeInfoHvInfo res) hvInfoMemoryTotal
nodeLiveFieldExtract _ _ = J.JSNull

-- | Helper for extracting field from RPC result.
nodeLiveRpcCall :: FieldName -> NodeRuntime -> Node -> ResultEntry
nodeLiveRpcCall fname (Right res) _ =
- rsNormal (nodeLiveFieldExtract fname res)
+ case nodeLiveFieldExtract fname res of
+ J.JSNull -> rsNoData
+ x -> rsNormal x
nodeLiveRpcCall _ (Left err) _ =
ResultEntry (rpcErrorToStatus err) Nothing

--
1.7.10.4

[Iustin Pop]

We need to only query the default (first enabled) hypervisor, not all
hypervisors. For this, we need to add a manual check to ensure that we
don't have a corrupt config (there's no "NonEmptyList" type…).

Signed-off-by: Iustin Pop <ius...@google.com>
---

htools/Ganeti/Query/Query.hs | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/htools/Ganeti/Query/Query.hs b/htools/Ganeti/Query/Query.hs
index a42cde6..ff7d33d 100644
--- a/htools/Ganeti/Query/Query.hs
+++ b/htools/Ganeti/Query/Query.hs
@@ -103,7 +103,9 @@ maybeCollectLiveData False _ nodes =

maybeCollectLiveData True cfg nodes = do
let vgs = [clusterVolumeGroupName $ configCluster cfg]
- hvs = clusterEnabledHypervisors $ configCluster cfg
+ hvs = case clusterEnabledHypervisors $ configCluster cfg of
+ [] -> [XenPvm] -- this case shouldn't happen, but we handle it
+ x:_ -> [x]
executeRpcCall nodes (RpcCallNodeInfo vgs hvs)

-- | Check whether list of queried fields contains live fields.
--
1.7.10.4

[Iustin Pop]

The disk free/total values are optional ones, wrapped in a Maybe, so
we shouldn't directly serialise them. In order to simplify the
embedded extraction, we add a small helper function.

Signed-off-by: Iustin Pop <ius...@google.com>
---

htools/Ganeti/Query/Node.hs | 9 +++++++--
1 file changed, 7 insertions(+), 2 deletions(-)

diff --git a/htools/Ganeti/Query/Node.hs b/htools/Ganeti/Query/Node.hs
index 0630754..01d0a89 100644
--- a/htools/Ganeti/Query/Node.hs
+++ b/htools/Ganeti/Query/Node.hs
@@ -68,6 +68,11 @@ nodeLiveFieldsDefs =
"Total amount of memory of physical machine")
]

+-- | Helper for extracting Maybe values from a possibly empty list.
+getMaybeJsonHead :: (J.JSON b) => [a] -> (a -> Maybe b) -> J.JSValue
+getMaybeJsonHead [] _ = J.JSNull
+getMaybeJsonHead (x:_) f = maybe J.JSNull J.showJSON (f x)
+
-- | Map each name to a function that extracts that value from

-- the RPC result.
nodeLiveFieldExtract :: String -> RpcResultNodeInfo -> J.JSValue

@@ -80,9 +85,9 @@ nodeLiveFieldExtract "csockets" res =
nodeLiveFieldExtract "ctotal" res =
jsonHead (rpcResNodeInfoHvInfo res) hvInfoCpuTotal
nodeLiveFieldExtract "dfree" res =

- jsonHead (rpcResNodeInfoVgInfo res) vgInfoVgFree

+ getMaybeJsonHead (rpcResNodeInfoVgInfo res) vgInfoVgFree
nodeLiveFieldExtract "dtotal" res =

- jsonHead (rpcResNodeInfoVgInfo res) vgInfoVgSize

+ getMaybeJsonHead (rpcResNodeInfoVgInfo res) vgInfoVgSize
nodeLiveFieldExtract "mfree" res =
jsonHead (rpcResNodeInfoHvInfo res) hvInfoMemoryFree
nodeLiveFieldExtract "mnode" res =
--
1.7.10.4

[Iustin Pop]

This replicates in the Haskell Query2 implementation the behaviour of
the Python code: if a "simple" filter is passed (one that contains
only Or aggregators and EQ binary ops on the name field), then an
failure is flagged if the given values are not known.

Our implementation is pretty straightforward, with a few details:

- we ignore any NumericValues passed, since that inconsistency will be
flagged by the filter compiler
- we return an the non-normalized names from the getRequestedNames
function, and not the fully-normalized ones; this will be done later
in individual query functions
- we test a few of the desired behaviours of the above-mentioned
function

Signed-off-by: Iustin Pop <ius...@google.com>
---

htest/Test/Ganeti/Query/Query.hs | 19 +++++++++++++++++++
htools/Ganeti/Query/Filter.hs | 14 ++++++++++++++
htools/Ganeti/Query/Query.hs | 27 +++++++++++++++++++++++++++
3 files changed, 60 insertions(+)

diff --git a/htest/Test/Ganeti/Query/Query.hs b/htest/Test/Ganeti/Query/Query.hs
index 74258ec..2090cd0 100644
--- a/htest/Test/Ganeti/Query/Query.hs
+++ b/htest/Test/Ganeti/Query/Query.hs
@@ -210,6 +210,24 @@ case_queryGroup_allfields = do
(sortBy field_sort . map fst $ Map.elems groupFieldsMap)
(sortBy field_sort fdefs)

+
+-- | Tests that requested names checking behaves as expected.
+prop_getRequestedNames :: Property
+prop_getRequestedNames =
+ forAll getName $ \node1 ->
+ let chk = getRequestedNames . Query QRNode []
+ q_node1 = QuotedString node1
+ eq_name = EQFilter "name"
+ eq_node1 = eq_name q_node1
+ in conjoin [ printTestCase "empty filter" $ chk EmptyFilter ==? []
+ , printTestCase "and filter" $ chk (AndFilter [eq_node1]) ==? []
+ , printTestCase "simple equality" $ chk eq_node1 ==? [node1]
+ , printTestCase "non-name field" $
+ chk (EQFilter "foo" q_node1) ==? []
+ , printTestCase "non-simple filter" $
+ chk (OrFilter [ eq_node1 , LTFilter "foo" q_node1]) ==? []
+ ]
+
testSuite "Query/Query"
[ 'prop_queryNode_noUnknown
, 'prop_queryNode_Unknown
@@ -219,4 +237,5 @@ testSuite "Query/Query"
, 'prop_queryGroup_Unknown
, 'prop_queryGroup_types
, 'case_queryGroup_allfields
+ , 'prop_getRequestedNames
]
diff --git a/htools/Ganeti/Query/Filter.hs b/htools/Ganeti/Query/Filter.hs
index 56e6a6a..24ce796 100644
--- a/htools/Ganeti/Query/Filter.hs
+++ b/htools/Ganeti/Query/Filter.hs
@@ -47,9 +47,11 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
module Ganeti.Query.Filter
( compileFilter
, evaluateFilter
+ , requestedNames
) where

import Control.Applicative
+import Control.Monad (liftM)
import qualified Data.Map as Map
import Data.Traversable (traverse)
import Text.JSON (JSValue(..), fromJSString)
@@ -171,3 +173,15 @@ tryGetter _ rt item (FieldRuntime getter) =
maybe Nothing (\rt' -> Just $ getter rt' item) rt
tryGetter _ _ _ FieldUnknown = Just $
ResultEntry RSUnknown Nothing
+
+-- | Computes the requested names, if only names were requested (and
+-- with equality). Otherwise returns 'Nothing'.
+requestedNames :: FilterField -> Filter FilterField -> Maybe [FilterValue]
+requestedNames _ EmptyFilter = Just []
+requestedNames namefield (OrFilter flts) =
+ liftM concat $ mapM (requestedNames namefield) flts
+requestedNames namefield (EQFilter fld val) =
+ if namefield == fld
+ then Just [val]
+ else Nothing
+requestedNames _ _ = Nothing
diff --git a/htools/Ganeti/Query/Query.hs b/htools/Ganeti/Query/Query.hs
index ff7d33d..a17a920 100644
--- a/htools/Ganeti/Query/Query.hs
+++ b/htools/Ganeti/Query/Query.hs
@@ -48,6 +48,7 @@ module Ganeti.Query.Query

( query
, queryFields
+ , getRequestedNames
) where

import Control.Monad (filterM)
@@ -114,6 +115,32 @@ needsLiveData = any (\getter -> case getter of
FieldRuntime _ -> True
_ -> False)

+-- | Checks whether we have requested exactly some names. This is a
+-- simple wrapper over 'requestedNames' and 'nameField'.
+needsNames :: Query -> Maybe [FilterValue]
+needsNames (Query kind _ qfilter) = requestedNames (nameField kind) qfilter
+
+-- | Computes the name field for different query types.
+nameField :: ItemType -> FilterField
+nameField QRJob = "id"
+nameField _ = "name"
+
+-- | Extracts all quoted strings from a list, ignoring the
+-- 'NumericValue' entries.
+getAllQuotedStrings :: [FilterValue] -> [String]
+getAllQuotedStrings =
+ concatMap extractor
+ where extractor (NumericValue _) = []
+ extractor (QuotedString val) = [val]
+
+-- | Checks that we have either requested a valid set of names, or we
+-- have a more complex filter.
+getRequestedNames :: Query -> [String]
+getRequestedNames qry =
+ case needsNames qry of
+ Just names -> getAllQuotedStrings names
+ Nothing -> []
+
-- | Main query execution function.
query :: ConfigData -- ^ The current configuration
-> Bool -- ^ Whether to collect live data
--
1.7.10.4

[Iustin Pop]

We do this not quite generically, which means we have to add
another layer in the call chain, and rename the current query
function, plus add special-case code for each query type. Hopefully we
will be able to improve on this in the future.

A (good) side effect of this patch is that we get the desired
ordering when names are requested, matching the Python code.

Signed-off-by: Iustin Pop <ius...@google.com>
---

htools/Ganeti/Query/Query.hs | 24 +++++++++++++++++++-----
1 file changed, 19 insertions(+), 5 deletions(-)

diff --git a/htools/Ganeti/Query/Query.hs b/htools/Ganeti/Query/Query.hs
index a17a920..875e870 100644
--- a/htools/Ganeti/Query/Query.hs
+++ b/htools/Ganeti/Query/Query.hs
@@ -57,6 +57,7 @@ import Data.Maybe (fromMaybe)

import qualified Data.Map as Map

import Ganeti.BasicTypes
+import Ganeti.Config
import Ganeti.JSON
import Ganeti.Rpc
import Ganeti.Query.Language
@@ -66,6 +67,7 @@ import Ganeti.Query.Types
import Ganeti.Query.Node
import Ganeti.Query.Group
import Ganeti.Objects
+import Ganeti.Utils

-- * Helper functions

@@ -146,13 +148,23 @@ query :: ConfigData -- ^ The current configuration

-> Bool -- ^ Whether to collect live data

-> Query -- ^ The query (item, fields, filter)
-> IO (Result QueryResult) -- ^ Result
+query cfg live qry = queryInner cfg live qry $ getRequestedNames qry

-query cfg live (Query QRNode fields qfilter) = runResultT $ do
+-- | Inner query execution function.
+queryInner :: ConfigData -- ^ The current configuration
+ -> Bool -- ^ Whether to collect live data
+ -> Query -- ^ The query (item, fields, filter)
+ -> [String] -- ^ Requested names
+ -> IO (Result QueryResult) -- ^ Result
+
+queryInner cfg live (Query QRNode fields qfilter) wanted = runResultT $ do
cfilter <- resultT $ compileFilter nodeFieldsMap qfilter
let selected = getSelectedFields nodeFieldsMap fields
(fdefs, fgetters) = unzip selected
- nodes = Map.elems . fromContainer $ configNodes cfg
live' = live && needsLiveData fgetters
+ nodes <- resultT $ case wanted of
+ [] -> Ok . Map.elems . fromContainer $ configNodes cfg
+ _ -> mapM (getNode cfg) wanted
-- runs first pass of the filter, without a runtime context; this
-- will limit the nodes that we'll contact for runtime data
fnodes <- resultT $ filterM (\n -> evaluateFilter cfg Nothing n cfilter) nodes
@@ -163,21 +175,23 @@ query cfg live (Query QRNode fields qfilter) = runResultT $ do
nruntimes
return QueryResult { qresFields = fdefs, qresData = fdata }

-query cfg _ (Query QRGroup fields qfilter) = return $ do
+queryInner cfg _ (Query QRGroup fields qfilter) wanted = 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
+ groups <- case wanted of
+ [] -> Ok . Map.elems . fromContainer $ configNodegroups cfg
+ _ -> mapM (getGroup cfg) wanted
-- 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 _ _) =
+queryInner _ _ (Query qkind _ _) _ =
return . Bad $ "Query '" ++ show qkind ++ "' not supported"

-- | Query fields call.
--
1.7.10.4

[Iustin Pop]

This patch adds a NiceSort equivalent and the corresponding unittest
(partially copied from Python unittest). The difference between the
Python version and this one is that this implementation doesn't use
regular expressions, and as such it doesn't have the 8-groups
limitation.

The key-based version is separate from the non-key one (since we don't
have default arguments in Haskell), and is tested less in its absolute
properties but only that it is identical to the non-key version under
some transformations (the non-key version is much more tested).

This will be needed later in query name sorting.

Signed-off-by: Iustin Pop <ius...@google.com>
---

htest/Test/Ganeti/Utils.hs | 86 ++++++++++++++++++++++++++++++++++++++++++++
htools/Ganeti/Utils.hs | 45 ++++++++++++++++++++++-
2 files changed, 130 insertions(+), 1 deletion(-)

diff --git a/htest/Test/Ganeti/Utils.hs b/htest/Test/Ganeti/Utils.hs
index 98ea53d..353dcef 100644
--- a/htest/Test/Ganeti/Utils.hs
+++ b/htest/Test/Ganeti/Utils.hs
@@ -29,7 +29,9 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
module Test.Ganeti.Utils (testUtils) where

import Test.QuickCheck
+import Test.HUnit

+import Data.List
import qualified Text.JSON as J

import Test.Ganeti.TestHelper
@@ -119,6 +121,85 @@ prop_parseUnit (NonNegative n) =

n_gb = n_mb * 1000
n_tb = n_gb * 1000

+{-# ANN case_niceSort_static "HLint: ignore Use camelCase" #-}
+
+case_niceSort_static :: Assertion
+case_niceSort_static = do
+ assertEqual "empty list" [] $ niceSort []
+ assertEqual "punctuation" [",", "."] $ niceSort [",", "."]
+ assertEqual "decimal numbers" ["0.1", "0.2"] $ niceSort["0.1", "0.2"]
+ assertEqual "various numbers" ["0,099", "0.1", "0.2", "0;099"] $
+ niceSort ["0;099", "0,099", "0.1", "0.2"]
+
+ assertEqual "simple concat" ["0000", "a0", "a1", "a2", "a20", "a99",
+ "b00", "b10", "b70"] $
+ niceSort ["a0", "a1", "a99", "a20", "a2", "b10", "b70", "b00", "0000"]
+
+ assertEqual "ranges" ["A", "Z", "a0-0", "a0-4", "a1-0", "a9-1", "a09-2",
+ "a20-3", "a99-3", "a99-10", "b"] $
+ niceSort ["a0-0", "a1-0", "a99-10", "a20-3", "a0-4", "a99-3", "a09-2",
+ "Z", "a9-1", "A", "b"]
+
+ assertEqual "large"
+ ["3jTwJPtrXOY22bwL2YoW", "Eegah9ei", "KOt7vn1dWXi",
+ "KVQqLPDjcPjf8T3oyzjcOsfkb", "WvNJd91OoXvLzdEiEXa6",
+ "Z8Ljf1Pf5eBfNg171wJR", "a07h8feON165N67PIE", "bH4Q7aCu3PUPjK3JtH",
+ "cPRi0lM7HLnSuWA2G9", "guKJkXnkULealVC8CyF1xefym",
+ "pqF8dkU5B1cMnyZuREaSOADYx", "uHXAyYYftCSG1o7qcCqe",
+ "xij88brTulHYAv8IEOyU", "xpIUJeVT1Rp"] $
+ niceSort ["Eegah9ei", "xij88brTulHYAv8IEOyU", "3jTwJPtrXOY22bwL2YoW",
+ "Z8Ljf1Pf5eBfNg171wJR", "WvNJd91OoXvLzdEiEXa6",
+ "uHXAyYYftCSG1o7qcCqe", "xpIUJeVT1Rp", "KOt7vn1dWXi",
+ "a07h8feON165N67PIE", "bH4Q7aCu3PUPjK3JtH",
+ "cPRi0lM7HLnSuWA2G9", "KVQqLPDjcPjf8T3oyzjcOsfkb",
+ "guKJkXnkULealVC8CyF1xefym", "pqF8dkU5B1cMnyZuREaSOADYx"]
+
+-- | Tests single-string behaviour of 'niceSort'. Last test is special
+-- in the sense that /0/ is before any other non-empty string (except
+-- itself, etc.).
+prop_niceSort_single :: Property
+prop_niceSort_single =
+ forAll getName $ \name ->
+ conjoin
+ [ printTestCase "single string" $ [name] ==? niceSort [name]
+ , printTestCase "single plus empty" $ ["", name] ==? niceSort [name, ""]
+ , printTestCase "single plus 0-digit" $ ["0", name] ==? niceSort [name, "0"]
+ ]
+
+-- | Tests some generic 'niceSort' properties. Note that the last test
+-- must add a non-digit prefix; a digit one might change ordering.
+prop_niceSort_generic :: Property
+prop_niceSort_generic =
+ forAll (resize 20 arbitrary) $ \names ->
+ let n_sorted = niceSort names in
+ conjoin [ printTestCase "length" $ length names ==? length n_sorted
+ , printTestCase "same strings" $ sort names ==? sort n_sorted
+ , printTestCase "idempotence" $ n_sorted ==? niceSort n_sorted
+ , printTestCase "static prefix" $ n_sorted ==?
+ map tail (niceSort $ map (" "++) names)
+ ]
+
+-- | Tests that niceSorting numbers is identical to actual sorting
+-- them (in numeric form).
+prop_niceSort_numbers :: Property
+prop_niceSort_numbers =
+ forAll (listOf (arbitrary::Gen (NonNegative Int))) $ \numbers ->
+ map show (sort numbers) ==? niceSort (map show numbers)
+
+-- | Tests that 'niceSort' and 'niceSortKey' are equivalent.
+prop_niceSortKey_equiv :: Property
+prop_niceSortKey_equiv =
+ forAll (resize 20 arbitrary) $ \names ->
+ forAll (vectorOf (length names) (arbitrary::Gen Int)) $ \numbers ->
+ let n_sorted = niceSort names in
+ conjoin
+ [ printTestCase "key id" $ n_sorted ==? niceSortKey id names
+ , printTestCase "key rev" $ niceSort (map reverse names) ==?
+ map reverse (niceSortKey reverse names)
+ , printTestCase "key snd" $ n_sorted ==? map snd (niceSortKey snd $
+ zip numbers names)
+ ]
+

-- | Test list for the Utils module.

testSuite "Utils"
[ 'prop_commaJoinSplit
@@ -129,4 +210,9 @@ testSuite "Utils"
, 'prop_select_undefd
, 'prop_select_undefv
, 'prop_parseUnit
+ , 'case_niceSort_static
+ , 'prop_niceSort_single
+ , 'prop_niceSort_generic
+ , 'prop_niceSort_numbers
+ , 'prop_niceSortKey_equiv
]
diff --git a/htools/Ganeti/Utils.hs b/htools/Ganeti/Utils.hs
index 708755e..8c1b0ce 100644
--- a/htools/Ganeti/Utils.hs
+++ b/htools/Ganeti/Utils.hs
@@ -37,13 +37,16 @@ module Ganeti.Utils
, printTable
, parseUnit
, plural
+ , niceSort
+ , niceSortKey
, exitIfBad
, exitErr
, exitWhen
, exitUnless
) where

-import Data.Char (toUpper, isAlphaNum)
+import Data.Char (toUpper, isAlphaNum, isDigit)
+import Data.Function (on)
import Data.List

import Debug.Trace
@@ -230,3 +233,43 @@ exitWhen False _ = return ()

-- if true, the opposite of 'exitWhen'.

exitUnless :: Bool -> String -> IO ()

exitUnless cond = exitWhen (not cond)

+
+-- | Helper for 'niceSort'. Computes the key element for a given string.
+extractKey :: [Either Integer String] -- ^ Current (partial) key, reversed
+ -> String -- ^ Remaining string
+ -> ([Either Integer String], String)
+extractKey ek [] = (reverse ek, [])
+extractKey ek xs@(x:_) =
+ let (span_fn, conv_fn) = if isDigit x
+ then (isDigit, Left . read)
+ else (not . isDigit, Right)
+ (k, rest) = span span_fn xs
+ in extractKey (conv_fn k:ek) rest
+
+{-| Sort a list of strings based on digit and non-digit groupings.
+
+Given a list of names @['a1', 'a10', 'a11', 'a2']@ this function
+will sort the list in the logical order @['a1', 'a2', 'a10', 'a11']@.
+
+The sort algorithm breaks each name in groups of either only-digits or
+no-digits, and sorts based on each group.
+
+Internally, this is not implemented via regexes (like the Python
+version), but via actual splitting of the string in sequences of
+either digits or everything else, and converting the digit sequences
+in /Left Integer/ and the non-digit ones in /Right String/, at which
+point sorting becomes trivial due to the built-in 'Either' ordering;
+we only need one extra step of dropping the key at the end.
+
+-}
+niceSort :: [String] -> [String]
+niceSort = map snd . sort . map (\s -> (fst $ extractKey [] s, s))
+
+-- | Key-version of 'niceSort'. We use 'sortBy' and @compare `on` fst@
+-- since we don't want to add an ordering constraint on the /a/ type,
+-- hence the need to only compare the first element of the /(key, a)/
+-- tuple.
+niceSortKey :: (a -> String) -> [a] -> [a]
+niceSortKey keyfn =
+ map snd . sortBy (compare `on` fst) .
+ map (\s -> (fst . extractKey [] $ keyfn s, s))
--
1.7.10.4

[Iustin Pop]

This makes the "all" names queries consistent with the Python
results. The change requires updating the unittests, at which point a
duplicate error message is simplified.

Signed-off-by: Iustin Pop <ius...@google.com>
---

htest/Test/Ganeti/Query/Filter.hs | 9 +++++----
htools/Ganeti/Query/Query.hs | 6 ++++--
2 files changed, 9 insertions(+), 6 deletions(-)

diff --git a/htest/Test/Ganeti/Query/Filter.hs b/htest/Test/Ganeti/Query/Filter.hs
index 1e99297..6bb0c2c 100644
--- a/htest/Test/Ganeti/Query/Filter.hs
+++ b/htest/Test/Ganeti/Query/Filter.hs
@@ -44,6 +44,7 @@ import Ganeti.JSON
import Ganeti.Objects
import Ganeti.Query.Language
import Ganeti.Query.Query
+import Ganeti.Utils (niceSort)

-- * Helpers

@@ -76,7 +77,7 @@ prop_node_single_filter :: Property
prop_node_single_filter =
forAll (choose (1, maxNodes)) $ \numnodes ->
forAll (genEmptyCluster numnodes) $ \cfg ->
- let allnodes = Map.keys . fromContainer $ configNodes cfg in
+ let allnodes = niceSort . Map.keys . fromContainer $ configNodes cfg in
forAll (elements allnodes) $ \nname ->
let fvalue = QuotedString nname
buildflt n = n "name" fvalue
@@ -102,7 +103,7 @@ prop_node_many_filter :: Property
prop_node_many_filter =
forAll (choose (2, maxNodes)) $ \numnodes ->
forAll (genEmptyCluster numnodes) $ \cfg ->
- let nnames = Map.keys . fromContainer $ configNodes cfg
+ let nnames = niceSort . Map.keys . fromContainer $ configNodes cfg
eqfilter = map (EQFilter "name" . QuotedString) nnames
alln = map ((:[]) . ResultEntry RSNormal . Just . showJSON) nnames
test_query = checkQueryResults cfg . makeNodeQuery
@@ -121,14 +122,14 @@ prop_node_regex_filter :: Property
prop_node_regex_filter =
forAll (choose (0, maxNodes)) $ \numnodes ->
forAll (genEmptyCluster numnodes) $ \cfg ->
- let nnames = Map.keys . fromContainer $ configNodes cfg
+ let nnames = niceSort . Map.keys . fromContainer $ configNodes cfg
expected = map ((:[]) . ResultEntry RSNormal . Just . showJSON) nnames
regex = mkRegex ".*"::Result FilterRegex
in case regex of
Bad msg -> failTest $ "Can't build regex?! Error: " ++ msg
Ok rx ->
checkQueryResults cfg (makeNodeQuery (RegexpFilter "name" rx))
- "Inconsistent result rows for all nodes regexp filter"
+ "rows for all nodes regexp filter"
expected

-- | Tests node regex filtering. This is a very basic test :(
diff --git a/htools/Ganeti/Query/Query.hs b/htools/Ganeti/Query/Query.hs
index 875e870..afb5830 100644
--- a/htools/Ganeti/Query/Query.hs
+++ b/htools/Ganeti/Query/Query.hs
@@ -163,7 +163,8 @@ queryInner cfg live (Query QRNode fields qfilter) wanted = runResultT $ do

(fdefs, fgetters) = unzip selected

live' = live && needsLiveData fgetters

nodes <- resultT $ case wanted of

- [] -> Ok . Map.elems . fromContainer $ configNodes cfg
+ [] -> Ok . niceSortKey nodeName .
+ Map.elems . fromContainer $ configNodes cfg

_ -> mapM (getNode cfg) wanted
-- runs first pass of the filter, without a runtime context; this
-- will limit the nodes that we'll contact for runtime data

@@ -183,7 +184,8 @@ queryInner cfg _ (Query QRGroup fields qfilter) wanted = return $ do

let selected = getSelectedFields groupFieldsMap fields
(fdefs, fgetters) = unzip selected

groups <- case wanted of

- [] -> Ok . Map.elems . fromContainer $ configNodegroups cfg
+ [] -> Ok . niceSortKey groupName .
+ Map.elems . fromContainer $ configNodegroups cfg

_ -> mapM (getGroup cfg) wanted
-- there is no live data for groups, so filtering is much simpler
fgroups <- filterM (\n -> evaluateFilter cfg Nothing n cfilter) groups

--
1.7.10.4

[Iustin Pop]

We try to automatically enable the htools-rapi and split query (if
confd and htools-rapi are enabled) options. This is our intended
default configuration, and allows easier test of the new code
path. Further cleanups for checking whether confd can be enabled will
come later.

The move block is due to the fact that we first have to check for
htools-rapi, and only then we can auto-enable the feature.

Signed-off-by: Iustin Pop <ius...@google.com>
---

configure.ac | 67 +++++++++++++++++++++++++++++++++++-----------------------
1 file changed, 41 insertions(+), 26 deletions(-)

diff --git a/configure.ac b/configure.ac
index 2d0cb92..b603562 100644
--- a/configure.ac
+++ b/configure.ac
@@ -324,7 +324,7 @@ AC_ARG_ENABLE([htools-rapi],
[AS_HELP_STRING([--enable-htools-rapi],
[enable use of RAPI in htools (needs curl, default: no)])],
[],
- [enable_htools_rapi=no])
+ [enable_htools_rapi=check])

# --enable-confd
ENABLE_CONFD=
@@ -349,31 +349,6 @@ AC_SUBST(ENABLE_CONFD, $enable_confd)

AM_CONDITIONAL([ENABLE_CONFD], [test x$enable_confd = xTrue])

-# --enable-split-query
-ENABLE_SPLIT_QUERY=
-AC_ARG_ENABLE([split-query],
- [AS_HELP_STRING([--enable-split-query],
- [enable use of custom query daemon via confd])],
- [[case "$enableval" in
- no)
- enable_split_query=False
- ;;
- yes)
- enable_split_query=True
- ;;
- *)
- echo "Invalid value for enable-confd '$enableval'"
- exit 1
- ;;
- esac
- ]],
- [enable_split_query=False])
-AC_SUBST(ENABLE_SPLIT_QUERY, $enable_split_query)
-
-if test x$enable_split_query = xTrue -a x$enable_confd != xTrue; then
- AC_MSG_ERROR([Split queries require the confd daemon])
-fi
-
# --with-disk-separator=...
AC_ARG_WITH([disk-separator],
[AS_HELP_STRING([--with-disk-separator=STRING],
@@ -548,6 +523,46 @@ if test "$enable_htools" != "no"; then
fi
AC_SUBST(HTOOLS)

+# --enable-split-query
+ENABLE_SPLIT_QUERY=
+AC_ARG_ENABLE([split-query],
+ [AS_HELP_STRING([--enable-split-query],
+ [enable use of custom query daemon via confd])],
+ [[case "$enableval" in
+ no)
+ enable_split_query=False
+ ;;
+ yes)
+ enable_split_query=True
+ ;;
+ *)
+ echo "Invalid value for enable-confd '$enableval'"
+ exit 1
+ ;;
+ esac
+ ]],
+ [[case "x${enable_confd}x${HTOOLS_NOCURL}x" in
+ xTruexx)
+ enable_split_query=True
+ ;;
+ *)
+ enable_split_query=False
+ ;;
+ esac]])
+AC_SUBST(ENABLE_SPLIT_QUERY, $enable_split_query)
+
+if test x$enable_split_query = xTrue -a x$enable_confd != xTrue; then
+ AC_MSG_ERROR([Split queries require the confd daemon])
+fi
+
+if test x$enable_split_query = xTrue -a x$HTOOLS_NOCURL != x; then
+ AC_MSG_ERROR([Split queries require the htools-rapi feature (curl library)])
+fi
+
+if test x$enable_split_query = xTrue; then
+ AC_MSG_NOTICE([Split query functionality enabled])
+fi
+
# Check for HsColour
HTOOLS_APIDOC=no
AC_ARG_VAR(HSCOLOUR, [HsColour path])
--
1.7.10.4

[Iustin Pop]

… and use it in the Query implementation, removing the last
non-correct query field for Groups.

Signed-off-by: Iustin Pop <ius...@google.com>
---

htools/Ganeti/Config.hs | 8 ++++++++
htools/Ganeti/Query/Group.hs | 3 ++-
htools/Ganeti/Query/Query.hs | 3 ---
3 files changed, 10 insertions(+), 4 deletions(-)

diff --git a/htools/Ganeti/Config.hs b/htools/Ganeti/Config.hs
index f88ba8a..e4df668 100644
--- a/htools/Ganeti/Config.hs
+++ b/htools/Ganeti/Config.hs
@@ -37,6 +37,7 @@ module Ganeti.Config
, getGroup
, getGroupNdParams
, getGroupIpolicy
+ , getGroupDiskParams
, getGroupNodes
, getGroupInstances
, getGroupOfNode
@@ -176,6 +177,13 @@ getGroupIpolicy :: ConfigData -> NodeGroup -> FilledIPolicy
getGroupIpolicy cfg ng =
fillIPolicy (clusterIpolicy $ configCluster cfg) (groupIpolicy ng)

+-- | Computes a group\'s (merged) disk params.
+getGroupDiskParams :: ConfigData -> NodeGroup -> DiskParams
+getGroupDiskParams cfg ng =
+ Container $
+ fillDict (fromContainer . clusterDiskparams $ configCluster cfg)
+ (fromContainer $ groupDiskparams ng) []
+
-- | Get nodes of a given node group.
getGroupNodes :: ConfigData -> String -> [Node]
getGroupNodes cfg gname =
diff --git a/htools/Ganeti/Query/Group.hs b/htools/Ganeti/Query/Group.hs
index b76d6c3..acf9083 100644
--- a/htools/Ganeti/Query/Group.hs
+++ b/htools/Ganeti/Query/Group.hs
@@ -54,7 +54,8 @@ groupFields =
"Custom node parameters",
FieldSimple (rsNormal . groupNdparams))
, (FieldDefinition "diskparams" "DiskParameters" QFTOther
- "Disk parameters (merged)", FieldSimple (\_ -> rsNoData))
+ "Disk parameters (merged)",
+ FieldConfig (\cfg -> rsNormal . getGroupDiskParams cfg))
, (FieldDefinition "ipolicy" "InstancePolicy" QFTOther
"Instance policy limitations (merged)",
FieldConfig (\cfg ng -> rsNormal (getGroupIpolicy cfg ng)))
diff --git a/htools/Ganeti/Query/Query.hs b/htools/Ganeti/Query/Query.hs
index afb5830..562fc62 100644
--- a/htools/Ganeti/Query/Query.hs
+++ b/htools/Ganeti/Query/Query.hs
@@ -177,9 +177,6 @@ queryInner cfg live (Query QRNode fields qfilter) wanted = runResultT $ do

return QueryResult { qresFields = fdefs, qresData = fdata }

queryInner cfg _ (Query QRGroup fields qfilter) wanted = 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

--
1.7.10.4

[Iustin Pop]

When initially implementing the node query, I thought the 'powered'
field is a representation of the run-time powered status, which would
make its query complex.

In reality, it's a simple config query, which we can support
easily. We also add a small helper, so that we don't hardcode the
RSUnavail case in many places.

Signed-off-by: Iustin Pop <ius...@google.com>
---

htools/Ganeti/Query/Common.hs | 5 +++++
htools/Ganeti/Query/Node.hs | 13 ++++++++++---
2 files changed, 15 insertions(+), 3 deletions(-)

diff --git a/htools/Ganeti/Query/Common.hs b/htools/Ganeti/Query/Common.hs
index 0149578..b9029bc 100644
--- a/htools/Ganeti/Query/Common.hs
+++ b/htools/Ganeti/Query/Common.hs
@@ -25,6 +25,7 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA

module Ganeti.Query.Common
( rsNoData
+ , rsUnavail
, rsNormal
, rsMaybe
, rsUnknown
@@ -66,6 +67,10 @@ vTypeToQFT VTypeInt = QFTNumber
rsNoData :: ResultEntry
rsNoData = ResultEntry RSNoData Nothing

+-- | Helper for result for an entity which supports no such field.
+rsUnavail :: ResultEntry
+rsUnavail = ResultEntry RSUnavail Nothing
+
-- | Helper to declare a normal result.
rsNormal :: (JSON a) => a -> ResultEntry
rsNormal a = ResultEntry RSNormal $ Just (showJSON a)
diff --git a/htools/Ganeti/Query/Node.hs b/htools/Ganeti/Query/Node.hs
index 01d0a89..163e517 100644
--- a/htools/Ganeti/Query/Node.hs
+++ b/htools/Ganeti/Query/Node.hs
@@ -122,6 +122,15 @@ nodeRoleDoc =
"\"" ++ nodeRoleToRaw role ++ "\" for " ++ roleDescription role)
(reverse [minBound..maxBound]))

+-- | Get node powered status.
+getNodePower :: ConfigData -> Node -> ResultEntry
+getNodePower cfg node =
+ case getNodeNdParams cfg node of
+ Nothing -> rsNoData
+ Just ndp -> if null (ndpOobProgram ndp)
+ then rsUnavail
+ else rsNormal (nodePowered node)
+
-- | List of all node fields.
nodeFields :: FieldList Node NodeRuntime
nodeFields =
@@ -179,11 +188,9 @@ nodeFields =
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)
+ FieldConfig getNodePower)
-- 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
--
1.7.10.4

[Iustin Pop]

We don't add a type class for fully-generic handling, but we do
abstract the duplicate part.

Signed-off-by: Iustin Pop <ius...@google.com>
---

htools/Ganeti/Query/Query.hs | 20 ++++++++++----------
1 file changed, 10 insertions(+), 10 deletions(-)

diff --git a/htools/Ganeti/Query/Query.hs b/htools/Ganeti/Query/Query.hs
index 562fc62..23bdbbd 100644
--- a/htools/Ganeti/Query/Query.hs
+++ b/htools/Ganeti/Query/Query.hs
@@ -193,21 +193,21 @@ queryInner cfg _ (Query QRGroup fields qfilter) wanted = return $ do

queryInner _ _ (Query qkind _ _) _ =
return . Bad $ "Query '" ++ show qkind ++ "' not supported"

+-- | Helper for 'queryFields'.
+fieldsExtractor :: FieldMap a b -> [FilterField] -> QueryFieldsResult
+fieldsExtractor fieldsMap fields =
+ let selected = if null fields
+ then map snd $ Map.toAscList fieldsMap
+ else getSelectedFields fieldsMap fields
+ in QueryFieldsResult (map fst selected)
+
-- | Query fields call.
--- FIXME: Looks generic enough to use a typeclass
queryFields :: QueryFields -> Result QueryFieldsResult
queryFields (QueryFields QRNode fields) =
- let selected = if null fields
- then map snd $ Map.toAscList nodeFieldsMap
- else getSelectedFields nodeFieldsMap fields
- in Ok $ QueryFieldsResult (map fst selected)
+ Ok $ fieldsExtractor nodeFieldsMap fields

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)
-
+ Ok $ fieldsExtractor groupFieldsMap fields

queryFields (QueryFields qkind _) =
Bad $ "QueryFields '" ++ show qkind ++ "' not supported"
--
1.7.10.4

[Iustin Pop]

And associated unittests. This will be needed for classic-style
queries.

Signed-off-by: Iustin Pop <ius...@google.com>
---

htest/Test/Ganeti/Query/Filter.hs | 14 ++++++++++++++
htools/Ganeti/Query/Filter.hs | 7 +++++++
2 files changed, 21 insertions(+)

diff --git a/htest/Test/Ganeti/Query/Filter.hs b/htest/Test/Ganeti/Query/Filter.hs
index 6bb0c2c..8f7044b 100644
--- a/htest/Test/Ganeti/Query/Filter.hs
+++ b/htest/Test/Ganeti/Query/Filter.hs
@@ -42,6 +42,7 @@ import Test.Ganeti.Objects (genEmptyCluster)
import Ganeti.BasicTypes
import Ganeti.JSON
import Ganeti.Objects
+import Ganeti.Query.Filter
import Ganeti.Query.Language
import Ganeti.Query.Query
import Ganeti.Utils (niceSort)
@@ -159,9 +160,22 @@ prop_node_bad_filter rndname rndint =
"numeric value in non-list field"
]

+-- | Tests make simple filter.
+prop_makeSimpleFilter :: Property
+prop_makeSimpleFilter =
+ forAll (resize 10 $ listOf1 getName) $ \names ->
+ forAll getName $ \namefield ->
+ conjoin [ printTestCase "test expected names" $
+ makeSimpleFilter namefield names ==?
+ OrFilter (map (EQFilter namefield . QuotedString) names)
+ , printTestCase "test empty names" $
+ makeSimpleFilter namefield [] ==? EmptyFilter
+ ]
+
testSuite "Query/Filter"
[ 'prop_node_single_filter
, 'prop_node_many_filter
, 'prop_node_regex_filter
, 'prop_node_bad_filter
+ , 'prop_makeSimpleFilter
]
diff --git a/htools/Ganeti/Query/Filter.hs b/htools/Ganeti/Query/Filter.hs
index 24ce796..42453e1 100644
--- a/htools/Ganeti/Query/Filter.hs
+++ b/htools/Ganeti/Query/Filter.hs
@@ -48,6 +48,7 @@ module Ganeti.Query.Filter
( compileFilter
, evaluateFilter
, requestedNames
+ , makeSimpleFilter
) where

import Control.Applicative
@@ -185,3 +186,9 @@ requestedNames namefield (EQFilter fld val) =
then Just [val]
else Nothing
requestedNames _ _ = Nothing
+
+-- | Builds a simple filter from a list of names.
+makeSimpleFilter :: String -> [String] -> Filter FilterField
+makeSimpleFilter _ [] = EmptyFilter
+makeSimpleFilter namefield vals =
+ OrFilter $ map (EQFilter namefield . QuotedString) vals
--
1.7.10.4

[Iustin Pop]

This patch adds support for classic-style queries (before query2) to
the query socket server. The patch is rather trivial, since as in
Python we just piggy-back on the query2 implementation.

Signed-off-by: Iustin Pop <ius...@google.com>
---

htools/Ganeti/Query/Query.hs | 14 +++++++++++++-
htools/Ganeti/Query/Server.hs | 20 ++++++++++++++++++++
2 files changed, 33 insertions(+), 1 deletion(-)

diff --git a/htools/Ganeti/Query/Query.hs b/htools/Ganeti/Query/Query.hs
index 23bdbbd..9dfcfa4 100644
--- a/htools/Ganeti/Query/Query.hs
+++ b/htools/Ganeti/Query/Query.hs
@@ -45,16 +45,19 @@ too.
-}

module Ganeti.Query.Query
-
( query
, queryFields
+ , queryCompat
, getRequestedNames
+ , nameField

) where

import Control.Monad (filterM)

import Control.Monad.Trans (lift)
+import Data.List (intercalate)

import Data.Maybe (fromMaybe)
import qualified Data.Map as Map

+import qualified Text.JSON as J

import Ganeti.BasicTypes
import Ganeti.Config
@@ -211,3 +214,12 @@ queryFields (QueryFields QRGroup fields) =

queryFields (QueryFields qkind _) =
Bad $ "QueryFields '" ++ show qkind ++ "' not supported"

+
+-- | Classic query converter. It gets a standard query result on input
+-- and computes the classic style results.
+queryCompat :: QueryResult -> Result [[J.JSValue]]
+queryCompat (QueryResult fields qrdata) =
+ case map fdefName $ filter ((== QFTUnknown) . fdefKind) fields of
+ [] -> Ok $ map (map (maybe J.JSNull J.showJSON . rentryValue)) qrdata
+ unknown -> Bad $ "Unknown output fields selected: " ++
+ intercalate ", " unknown
diff --git a/htools/Ganeti/Query/Server.hs b/htools/Ganeti/Query/Server.hs
index ca4409c..97ece0b 100644
--- a/htools/Ganeti/Query/Server.hs
+++ b/htools/Ganeti/Query/Server.hs
@@ -51,11 +51,25 @@ import Ganeti.Logging
import Ganeti.Luxi
import qualified Ganeti.Query.Language as Qlang
import Ganeti.Query.Query
+import Ganeti.Query.Filter (makeSimpleFilter)

-- | A type for functions that can return the configuration when
-- executed.
type ConfigReader = IO (Result ConfigData)

+-- | Helper for classic queries.
+handleClassicQuery :: ConfigData -- ^ Cluster config
+ -> Qlang.ItemType -- ^ Query type
+ -> [String] -- ^ Requested names (empty means all)
+ -> [String] -- ^ Requested fields
+ -> Bool -- ^ Whether to do sync queries or not
+ -> IO (Result JSValue)
+handleClassicQuery _ _ _ _ True = return . Bad $ "Sync queries are not allowed"
+handleClassicQuery cfg qkind names fields _ = do
+ let flt = makeSimpleFilter (nameField qkind) names
+ qr <- query cfg True (Qlang.Query qkind fields flt)
+ return $ showJSON <$> (qr >>= queryCompat)
+
-- | Minimal wrapper to handle the missing config case.
handleCallWrapper :: Result ConfigData -> LuxiOp -> IO (Result JSValue)
handleCallWrapper (Bad msg) _ =
@@ -136,6 +150,12 @@ handleCall _ (QueryFields qkind qfields) = do
let result = queryFields (Qlang.QueryFields qkind qfields)
return $ J.showJSON <$> result

+handleCall cfg (QueryNodes names fields lock) =
+ handleClassicQuery cfg Qlang.QRNode names fields lock
+
+handleCall cfg (QueryGroups names fields lock) =
+ handleClassicQuery cfg Qlang.QRGroup names fields lock
+
handleCall _ op =
return . Bad $ "Luxi call '" ++ strOfOp op ++ "' not implemented"

--
1.7.10.4

[Iustin Pop]

This switches gnt-node/gnt-group (and their equivalent RAPI resources)

to go over the query socket.

Signed-off-by: Iustin Pop <ius...@google.com>
---

lib/client/gnt_group.py | 10 +++++++---
lib/client/gnt_node.py | 19 +++++++++++++++----
lib/rapi/rlib2.py | 10 +++++-----
3 files changed, 27 insertions(+), 12 deletions(-)

diff --git a/lib/client/gnt_group.py b/lib/client/gnt_group.py
index ceee598..8e73da9 100644
--- a/lib/client/gnt_group.py
+++ b/lib/client/gnt_group.py
@@ -124,10 +124,12 @@ def ListGroups(opts, args):
"ndparams": (_FmtDict, False),
}

+ cl = GetClient(query=True)
+
return GenericList(constants.QR_GROUP, desired_fields, args, None,
opts.separator, not opts.no_headers,
format_override=fmtoverride, verbose=opts.verbose,
- force_filter=opts.force_filter)
+ force_filter=opts.force_filter, cl=cl)


def ListGroupFields(opts, args):
@@ -140,8 +142,10 @@ def ListGroupFields(opts, args):
@return: the desired exit code

"""
+ cl = GetClient(query=True)
+
return GenericListFields(constants.QR_GROUP, args, opts.separator,
- not opts.no_headers)
+ not opts.no_headers, cl=cl)


def SetGroupParams(opts, args):
@@ -295,7 +299,7 @@ def GroupInfo(_, args):
"""Shows info about node group.

"""
- cl = GetClient()
+ cl = GetClient(query=True)
selected_fields = ["name",
"ndparams", "custom_ndparams",
"diskparams", "custom_diskparams",
diff --git a/lib/client/gnt_node.py b/lib/client/gnt_node.py
index 7943424..86cdf0a 100644
--- a/lib/client/gnt_node.py
+++ b/lib/client/gnt_node.py
@@ -253,10 +253,12 @@ def ListNodes(opts, args):
fmtoverride = dict.fromkeys(["pinst_list", "sinst_list", "tags"],
(",".join, False))

+ cl = GetClient(query=True)
+
return GenericList(constants.QR_NODE, selected_fields, args, opts.units,
opts.separator, not opts.no_headers,
format_override=fmtoverride, verbose=opts.verbose,
- force_filter=opts.force_filter)
+ force_filter=opts.force_filter, cl=cl)


def ListNodeFields(opts, args):
@@ -269,8 +271,10 @@ def ListNodeFields(opts, args):
@return: the desired exit code

"""
+ cl = GetClient(query=True)
+
return GenericListFields(constants.QR_NODE, args, opts.separator,
- not opts.no_headers)
+ not opts.no_headers, cl=cl)


def EvacuateNode(opts, args):
@@ -310,7 +314,10 @@ def EvacuateNode(opts, args):

cl = GetClient()

- result = cl.QueryNodes(names=args, fields=fields, use_locking=False)
+ qcl = GetClient(query=True)
+ result = qcl.QueryNodes(names=args, fields=fields, use_locking=False)
+ qcl.Close()
+
instances = set(itertools.chain(*itertools.chain(*itertools.chain(result))))

if not instances:
@@ -366,8 +373,10 @@ def FailoverNode(opts, args):

# these fields are static data anyway, so it doesn't matter, but
# locking=True should be safer
+ qcl = GetClient(query=True)
result = cl.QueryNodes(names=args, fields=selected_fields,
use_locking=False)
+ qcl.Close()
node, pinst = result[0]

if not pinst:
@@ -406,7 +415,9 @@ def MigrateNode(opts, args):
force = opts.force
selected_fields = ["name", "pinst_list"]

+ qcl = GetClient(query=True)
result = cl.QueryNodes(names=args, fields=selected_fields, use_locking=False)
+ qcl.Close()
((node, pinst), ) = result

if not pinst:
@@ -468,7 +479,7 @@ def ShowNodeConfig(opts, args):
@return: the desired exit code

"""
- cl = GetClient()
+ cl = GetClient(query=True)
result = cl.QueryNodes(fields=["name", "pip", "sip",
"pinst_list", "sinst_list",
"master_candidate", "drained", "offline",
diff --git a/lib/rapi/rlib2.py b/lib/rapi/rlib2.py
index f5d9d63..f4dc219 100644
--- a/lib/rapi/rlib2.py
+++ b/lib/rapi/rlib2.py
@@ -388,7 +388,7 @@ class R_2_nodes(baserlib.OpcodeResource):
"""Returns a list of all nodes.

"""
- client = self.GetClient()
+ client = self.GetClient(query=True)

if self.useBulk():
bulkdata = client.QueryNodes([], N_FIELDS, False)
@@ -411,7 +411,7 @@ class R_2_nodes_name(baserlib.OpcodeResource):

"""
node_name = self.items[0]
- client = self.GetClient()
+ client = self.GetClient(query=True)

result = baserlib.HandleItemQueryErrors(client.QueryNodes,
names=[node_name], fields=N_FIELDS,
@@ -449,7 +449,7 @@ class R_2_nodes_name_role(baserlib.OpcodeResource):

"""
node_name = self.items[0]
- client = self.GetClient()
+ client = self.GetClient(query=True)
result = client.QueryNodes(names=[node_name], fields=["role"],
use_locking=self.useLocking())

@@ -666,7 +666,7 @@ class R_2_groups(baserlib.OpcodeResource):
"""Returns a list of all node groups.

"""
- client = self.GetClient()
+ client = self.GetClient(query=True)

if self.useBulk():
bulkdata = client.QueryGroups([], G_FIELDS, False)
@@ -689,7 +689,7 @@ class R_2_groups_name(baserlib.OpcodeResource):

"""
group_name = self.items[0]
- client = self.GetClient()
+ client = self.GetClient(query=True)

result = baserlib.HandleItemQueryErrors(client.QueryGroups,
names=[group_name], fields=G_FIELDS,
--
1.7.10.4

[Iustin Pop]

A lot of the lists in Makefile.am were not sorted properly (or at
all); let's sort them for more sanity.

Additionally, check-local used to spew this big shell block, even
though it does emit nice messages when failing, so we don't need to
show the code; let's silence it (@).

Signed-off-by: Iustin Pop <ius...@google.com>
---

Makefile.am | 178 +++++++++++++++++++++++++++++------------------------------
1 file changed, 89 insertions(+), 89 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 36c1153..89b4e6d 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -69,17 +69,20 @@ HTOOLS_DIRS = \
htest/Test/Ganeti/Query

DIRS = \
+ $(HTOOLS_DIRS) \
autotools \
daemons \
devel \
doc \
doc/examples \
- doc/examples/hooks \
doc/examples/gnt-debug \
- $(HTOOLS_DIRS) \
+ doc/examples/hooks \
+ htest/data \
+ htest/data/rapi \
+ htest/shelltests \
lib \
- lib/client \
lib/build \
+ lib/client \
lib/confd \
lib/http \
lib/hypervisor \
@@ -96,24 +99,21 @@ DIRS = \
test/data \
test/data/ovfdata \
test/data/ovfdata/other \
- htest/data \
- htest/data/rapi \
- htest/shelltests \
tools

BUILDTIME_DIR_AUTOCREATE = \
scripts \
$(APIDOC_DIR) \
- $(APIDOC_PY_DIR) \
$(APIDOC_HS_DIR) \
$(APIDOC_HS_DIR)/Ganeti \
$(APIDOC_HS_DIR)/Ganeti/Confd \
$(APIDOC_HS_DIR)/Ganeti/HTools \
$(APIDOC_HS_DIR)/Ganeti/HTools/Program \
$(APIDOC_HS_DIR)/Ganeti/Query \
+ $(APIDOC_PY_DIR) \
$(COVERAGE_DIR) \
- $(COVERAGE_PY_DIR) \
$(COVERAGE_HS_DIR) \
+ $(COVERAGE_PY_DIR) \
.hpc

BUILDTIME_DIRS = \
@@ -215,8 +215,8 @@ nodist_pkgpython_PYTHON = \

noinst_PYTHON = \
lib/build/__init__.py \
- lib/build/sphinx_ext.py \
- lib/build/shell_example_lexer.py
+ lib/build/shell_example_lexer.py \
+ lib/build/sphinx_ext.py

pkgpython_PYTHON = \
lib/__init__.py \
@@ -335,33 +335,33 @@ utils_PYTHON = \

docrst = \
doc/admin.rst \
+ doc/cluster-merge.rst \
doc/design-2.0.rst \
doc/design-2.1.rst \
doc/design-2.2.rst \
doc/design-2.3.rst \
- doc/design-htools-2.3.rst \
doc/design-2.4.rst \
doc/design-2.5.rst \
- doc/design-draft.rst \
- doc/design-oob.rst \
+ doc/design-autorepair.rst \
+ doc/design-bulk-create.rst \
+ doc/design-chained-jobs.rst \
doc/design-cpu-pinning.rst \
- doc/design-query2.rst \
- doc/design-x509-ca.rst \
+ doc/design-draft.rst \
+ doc/design-htools-2.3.rst \
doc/design-http-server.rst \
doc/design-impexp2.rst \
doc/design-lu-generated-jobs.rst \
doc/design-multi-reloc.rst \
doc/design-network.rst \
- doc/design-chained-jobs.rst \
+ doc/design-node-state-cache.rst \
+ doc/design-oob.rst \
doc/design-ovf-support.rst \
- doc/design-autorepair.rst \
+ doc/design-query-splitting.rst \
+ doc/design-query2.rst \
doc/design-resource-model.rst \
- doc/cluster-merge.rst \
doc/design-shared-storage.rst \
- doc/design-node-state-cache.rst \
doc/design-virtual-clusters.rst \
- doc/design-bulk-create.rst \
- doc/design-query-splitting.rst \
+ doc/design-x509-ca.rst \
doc/devnotes.rst \
doc/glossary.rst \
doc/hooks.rst \
@@ -395,8 +395,8 @@ HEXTRA_INT =
# exclude options for coverage reports
HPCEXCL = --exclude Main \
--exclude Ganeti.Constants \
- --exclude Ganeti.THH \
--exclude Ganeti.HTools.QC \
+ --exclude Ganeti.THH \
--exclude Ganeti.Version \
--exclude Test.Ganeti.TestCommon \
--exclude Test.Ganeti.TestHTools \
@@ -405,6 +405,14 @@ HPCEXCL = --exclude Main \
$(patsubst htools.%,--exclude Test.%,$(subst /,.,$(patsubst %.hs,%, $(HS_LIB_SRCS))))

HS_LIB_SRCS = \
+ htools/Ganeti/BasicTypes.hs \
+ htools/Ganeti/Common.hs \
+ htools/Ganeti/Compat.hs \
+ htools/Ganeti/Confd.hs \
+ htools/Ganeti/Confd/Server.hs \
+ htools/Ganeti/Confd/Utils.hs \
+ htools/Ganeti/Config.hs \
+ htools/Ganeti/Daemon.hs \
htools/Ganeti/HTools/CLI.hs \
htools/Ganeti/HTools/Cluster.hs \
htools/Ganeti/HTools/Container.hs \
@@ -416,10 +424,6 @@ HS_LIB_SRCS = \
htools/Ganeti/HTools/Luxi.hs \
htools/Ganeti/HTools/Node.hs \
htools/Ganeti/HTools/PeerMap.hs \
- htools/Ganeti/HTools/Rapi.hs \
- htools/Ganeti/HTools/Simu.hs \
- htools/Ganeti/HTools/Text.hs \
- htools/Ganeti/HTools/Types.hs \
htools/Ganeti/HTools/Program.hs \
htools/Ganeti/HTools/Program/Hail.hs \
htools/Ganeti/HTools/Program/Hbal.hs \
@@ -427,17 +431,13 @@ HS_LIB_SRCS = \
htools/Ganeti/HTools/Program/Hinfo.hs \
htools/Ganeti/HTools/Program/Hscan.hs \
htools/Ganeti/HTools/Program/Hspace.hs \
- htools/Ganeti/BasicTypes.hs \
- htools/Ganeti/Common.hs \
- htools/Ganeti/Compat.hs \
- htools/Ganeti/Confd.hs \
- htools/Ganeti/Confd/Server.hs \
- htools/Ganeti/Confd/Utils.hs \
- htools/Ganeti/Config.hs \
- htools/Ganeti/Daemon.hs \
+ htools/Ganeti/HTools/Rapi.hs \
+ htools/Ganeti/HTools/Simu.hs \
+ htools/Ganeti/HTools/Text.hs \
+ htools/Ganeti/HTools/Types.hs \
htools/Ganeti/Hash.hs \
- htools/Ganeti/Jobs.hs \
htools/Ganeti/JSON.hs \
+ htools/Ganeti/Jobs.hs \
htools/Ganeti/Logging.hs \
htools/Ganeti/Luxi.hs \
htools/Ganeti/Objects.hs \
@@ -460,8 +460,8 @@ HS_LIB_SRCS = \
HS_TEST_SRCS = \
htest/Test/Ganeti/BasicTypes.hs \
htest/Test/Ganeti/Common.hs \
- htest/Test/Ganeti/Daemon.hs \
htest/Test/Ganeti/Confd/Utils.hs \
+ htest/Test/Ganeti/Daemon.hs \
htest/Test/Ganeti/HTools/CLI.hs \
htest/Test/Ganeti/HTools/Cluster.hs \
htest/Test/Ganeti/HTools/Container.hs \
@@ -561,8 +561,8 @@ gnt_scripts = \
PYTHON_BOOTSTRAP_SBIN = \
daemons/ganeti-masterd \
daemons/ganeti-noded \
- daemons/ganeti-watcher \
daemons/ganeti-rapi \
+ daemons/ganeti-watcher \
$(gnt_scripts)

PYTHON_BOOTSTRAP = \
@@ -666,14 +666,14 @@ python_scripts = \
tools/lvmstrap \
tools/move-instance \
tools/ovfconverter \
- tools/setup-ssh \
- tools/sanitize-config
+ tools/sanitize-config \
+ tools/setup-ssh

dist_tools_SCRIPTS = \
$(python_scripts) \
tools/kvm-console-wrapper \
- tools/xm-console-wrapper \
- tools/master-ip-setup
+ tools/master-ip-setup \
+ tools/xm-console-wrapper

nodist_tools_SCRIPTS = \
tools/vcluster-setup
@@ -701,11 +701,11 @@ EXTRA_DIST = \
autotools/build-bash-completion \
autotools/build-rpc \
autotools/check-header \
- autotools/check-python-code \
autotools/check-imports \
autotools/check-man-dashes \
autotools/check-man-warnings \
autotools/check-news \
+ autotools/check-python-code \
autotools/check-tar \
autotools/check-version \
autotools/convert-constants \
@@ -750,16 +750,16 @@ EXTRA_DIST = \
htest/offline-test.sh

man_MANS = \
- man/ganeti.7 \
man/ganeti-cleaner.8 \
- man/ganeti-master-cleaner.8 \
man/ganeti-confd.8 \
man/ganeti-listrunner.8 \
+ man/ganeti-master-cleaner.8 \
man/ganeti-masterd.8 \
man/ganeti-noded.8 \
man/ganeti-os-interface.7 \
man/ganeti-rapi.8 \
man/ganeti-watcher.8 \
+ man/ganeti.7 \
man/gnt-backup.8 \
man/gnt-cluster.8 \
man/gnt-debug.8 \
@@ -785,6 +785,31 @@ maninput = \
man/footer.man man/footer.html $(mangen)

TEST_FILES = \
+ htest/data/common-suffix.data \
+ htest/data/hail-alloc-drbd.json \
+ htest/data/hail-change-group.json \
+ htest/data/hail-invalid-reloc.json \
+ htest/data/hail-node-evac.json \
+ htest/data/hail-reloc-drbd.json \
+ htest/data/hbal-split-insts.data \
+ htest/data/invalid-node.data \
+ htest/data/missing-resources.data \
+ htest/data/rapi/groups.json \
+ htest/data/rapi/info.json \
+ htest/data/rapi/instances.json \
+ htest/data/rapi/nodes.json \
+ htest/shelltests/htools-balancing.test \
+ htest/shelltests/htools-basic.test \
+ htest/shelltests/htools-dynutil.test \
+ htest/shelltests/htools-excl.test \
+ htest/shelltests/htools-hail.test \
+ htest/shelltests/htools-hspace.test \
+ htest/shelltests/htools-invalid.test \
+ htest/shelltests/htools-multi-group.test \
+ htest/shelltests/htools-no-backend.test \
+ htest/shelltests/htools-rapi.test \
+ htest/shelltests/htools-single-group.test \
+ htest/shelltests/htools-text-backend.test \
test/data/bdev-drbd-8.0.txt \
test/data/bdev-drbd-8.3.txt \
test/data/bdev-drbd-disk.txt \
@@ -798,16 +823,10 @@ TEST_FILES = \
test/data/ip-addr-show-lo-oneline-ipv6.txt \
test/data/ip-addr-show-lo-oneline.txt \
test/data/ip-addr-show-lo.txt \
- test/data/proc_drbd8.txt \
- test/data/proc_drbd80-emptyline.txt \
- test/data/proc_drbd83.txt \
- test/data/proc_drbd83_sync.txt \
- test/data/proc_drbd83_sync_krnl2.6.39.txt \
- test/data/kvm_1.0_help.txt \
- test/data/kvm_0.15.90_help.txt \
test/data/kvm_0.12.5_help.txt \
+ test/data/kvm_0.15.90_help.txt \
test/data/kvm_0.9.1_help.txt \
- test/data/sys_drbd_usermode_helper.txt \
+ test/data/kvm_1.0_help.txt \
test/data/ovfdata/compr_disk.vmdk.gz \
test/data/ovfdata/config.ini \
test/data/ovfdata/corrupted_resources.ovf \
@@ -821,76 +840,59 @@ TEST_FILES = \
test/data/ovfdata/no_disk_in_ref.ovf \
test/data/ovfdata/no_os.ini \
test/data/ovfdata/no_ovf.ova \
+ test/data/ovfdata/other/rawdisk.raw \
test/data/ovfdata/ova.ova \
- test/data/ovfdata/second_disk.vmdk \
test/data/ovfdata/rawdisk.raw \
+ test/data/ovfdata/second_disk.vmdk \
test/data/ovfdata/unsafe_path.ini \
test/data/ovfdata/virtualbox.ovf \
- test/data/ovfdata/wrong_extension.ovd \
test/data/ovfdata/wrong_config.ini \
+ test/data/ovfdata/wrong_extension.ovd \
test/data/ovfdata/wrong_manifest.mf \
test/data/ovfdata/wrong_manifest.ovf \
test/data/ovfdata/wrong_ova.ova \
test/data/ovfdata/wrong_xml.ovf \
- test/data/ovfdata/other/rawdisk.raw \
+ test/data/proc_drbd8.txt \
+ test/data/proc_drbd80-emptyline.txt \
+ test/data/proc_drbd83.txt \
+ test/data/proc_drbd83_sync.txt \
+ test/data/proc_drbd83_sync_krnl2.6.39.txt \
+ test/data/sys_drbd_usermode_helper.txt \
test/data/vgreduce-removemissing-2.02.02.txt \
test/data/vgreduce-removemissing-2.02.66-fail.txt \
test/data/vgreduce-removemissing-2.02.66-ok.txt \
test/data/vgs-missing-pvs-2.02.02.txt \
test/data/vgs-missing-pvs-2.02.66.txt \
- test/import-export_unittest-helper \
- test/gnt-cli.test \
test/ganeti-cli.test \
- htest/shelltests/htools-balancing.test \
- htest/shelltests/htools-basic.test \
- htest/shelltests/htools-dynutil.test \
- htest/shelltests/htools-excl.test \
- htest/shelltests/htools-hail.test \
- htest/shelltests/htools-hspace.test \
- htest/shelltests/htools-invalid.test \
- htest/shelltests/htools-multi-group.test \
- htest/shelltests/htools-no-backend.test \
- htest/shelltests/htools-rapi.test \
- htest/shelltests/htools-single-group.test \
- htest/shelltests/htools-text-backend.test \
- htest/data/hail-alloc-drbd.json \
- htest/data/hail-change-group.json \
- htest/data/hail-invalid-reloc.json \
- htest/data/hail-node-evac.json \
- htest/data/hail-reloc-drbd.json \
- htest/data/hbal-split-insts.data \
- htest/data/common-suffix.data \
- htest/data/invalid-node.data \
- htest/data/missing-resources.data \
- htest/data/rapi/groups.json \
- htest/data/rapi/info.json \
- htest/data/rapi/instances.json \
- htest/data/rapi/nodes.json
+ test/gnt-cli.test \
+ test/import-export_unittest-helper

python_tests = \
doc/examples/rapi_testutils.py \
+ test/cfgupgrade_unittest.py \
+ test/docs_unittest.py \
test/ganeti.asyncnotifier_unittest.py \
test/ganeti.backend_unittest.py \
test/ganeti.bdev_unittest.py \
test/ganeti.cli_unittest.py \
test/ganeti.client.gnt_cluster_unittest.py \
test/ganeti.client.gnt_instance_unittest.py \
- test/ganeti.daemon_unittest.py \
test/ganeti.cmdlib_unittest.py \
test/ganeti.compat_unittest.py \
test/ganeti.confd.client_unittest.py \
test/ganeti.config_unittest.py \
test/ganeti.constants_unittest.py \
+ test/ganeti.daemon_unittest.py \
test/ganeti.errors_unittest.py \
test/ganeti.hooks_unittest.py \
test/ganeti.ht_unittest.py \
test/ganeti.http_unittest.py \
- test/ganeti.hypervisor_unittest.py \
test/ganeti.hypervisor.hv_chroot_unittest.py \
test/ganeti.hypervisor.hv_fake_unittest.py \
test/ganeti.hypervisor.hv_kvm_unittest.py \
test/ganeti.hypervisor.hv_lxc_unittest.py \
test/ganeti.hypervisor.hv_xen_unittest.py \
+ test/ganeti.hypervisor_unittest.py \
test/ganeti.impexpd_unittest.py \
test/ganeti.jqueue_unittest.py \
test/ganeti.jstore_unittest.py \
@@ -921,8 +923,8 @@ python_tests = \
test/ganeti.utils.algo_unittest.py \
test/ganeti.utils.filelock_unittest.py \
test/ganeti.utils.hash_unittest.py \
- test/ganeti.utils.io_unittest.py \
test/ganeti.utils.io_unittest-runasroot.py \
+ test/ganeti.utils.io_unittest.py \
test/ganeti.utils.log_unittest.py \
test/ganeti.utils.mlock_unittest.py \
test/ganeti.utils.nodesetup_unittest.py \
@@ -934,10 +936,8 @@ python_tests = \
test/ganeti.utils_unittest.py \
test/ganeti.vcluster_unittest.py \
test/ganeti.workerpool_unittest.py \
- test/qa.qa_config_unittest.py \
- test/cfgupgrade_unittest.py \
- test/docs_unittest.py \
test/pycurl_reset_unittest.py \
+ test/qa.qa_config_unittest.py \
test/tempfile_fork_unittest.py

haskell_tests = htest/test
@@ -1414,7 +1414,7 @@ check-local: check-dirs $(GENERATED_FILES)
$(CHECK_VERSION) $(VERSION) $(top_srcdir)/NEWS
$(CHECK_NEWS) < $(top_srcdir)/NEWS
PYTHONPATH=. $(RUN_IN_TEMPDIR) $(CURDIR)/$(CHECK_IMPORTS) . $(standalone_python_modules)
- expver=$(VERSION_MAJOR).$(VERSION_MINOR); \
+ @expver=$(VERSION_MAJOR).$(VERSION_MINOR); \
if test "`head -n 1 $(top_srcdir)/README`" != "Ganeti $$expver"; then \
echo "Incorrect version in README, expected $$expver"; \
exit 1; \
--
1.7.10.4

[Iustin Pop]

This patch cleans up duplicate code in Test.Ganeti.Query.Filter and
then adds a test for names consistency with Python's code behaviour
(stable ordering for simple filters and otherwise niceSort'ed
ordering).

Signed-off-by: Iustin Pop <ius...@google.com>
---

htest/Test/Ganeti/Query/Filter.hs | 70 +++++++++++++++++++++++--------------
1 file changed, 44 insertions(+), 26 deletions(-)

diff --git a/htest/Test/Ganeti/Query/Filter.hs b/htest/Test/Ganeti/Query/Filter.hs
index 8f7044b..2894741 100644
--- a/htest/Test/Ganeti/Query/Filter.hs
+++ b/htest/Test/Ganeti/Query/Filter.hs
@@ -70,21 +70,30 @@ expectBadQuery cfg qr descr = monadicIO $ do
Ok a -> stop . failTest $ "Expected failure in " ++ descr ++
" but got " ++ show a

+-- | A helper to construct a list of results from an expected names list.
+namesToResult :: [String] -> [[ResultEntry]]
+namesToResult = map ((:[]) . ResultEntry RSNormal . Just . showJSON)
+
+-- | Generates a cluster and returns its node names too.
+genClusterNames :: Int -> Int -> Gen (ConfigData, [String])
+genClusterNames min_nodes max_nodes = do
+ numnodes <- choose (min_nodes, max_nodes)
+ cfg <- genEmptyCluster numnodes
+ return (cfg, niceSort . Map.keys . fromContainer $ configNodes cfg)
+
-- * Test cases

-- | Tests single node filtering: eq should return it, and (lt and gt)
-- should fail.
prop_node_single_filter :: Property
prop_node_single_filter =
- forAll (choose (1, maxNodes)) $ \numnodes ->

- forAll (genEmptyCluster numnodes) $ \cfg ->

- let allnodes = niceSort . Map.keys . fromContainer $ configNodes cfg in
+ forAll (genClusterNames 1 maxNodes) $ \(cfg, allnodes) ->

forAll (elements allnodes) $ \nname ->
let fvalue = QuotedString nname
buildflt n = n "name" fvalue

- expsingle = [[ResultEntry RSNormal (Just (showJSON nname))]]
+ expsingle = namesToResult [nname]
othernodes = nname `delete` allnodes
- expnot = map ((:[]) . ResultEntry RSNormal . Just . showJSON) othernodes
+ expnot = namesToResult othernodes

test_query = checkQueryResults cfg . makeNodeQuery

in conjoin
[ test_query (buildflt EQFilter) "single-name 'EQ' filter" expsingle
@@ -102,11 +111,9 @@ prop_node_single_filter =
-- the 'AndFilter' case breaks.
prop_node_many_filter :: Property
prop_node_many_filter =
- forAll (choose (2, maxNodes)) $ \numnodes ->

- forAll (genEmptyCluster numnodes) $ \cfg ->

- let nnames = niceSort . Map.keys . fromContainer $ configNodes cfg
- eqfilter = map (EQFilter "name" . QuotedString) nnames
- alln = map ((:[]) . ResultEntry RSNormal . Just . showJSON) nnames
+ forAll (genClusterNames 2 maxNodes) $ \(cfg, nnames) ->
+ let eqfilter = map (EQFilter "name" . QuotedString) nnames
+ alln = namesToResult nnames

test_query = checkQueryResults cfg . makeNodeQuery

num_zero = NumericValue 0
in conjoin
@@ -118,31 +125,41 @@ prop_node_many_filter =
, test_query (GTFilter "sinst_cnt" num_zero) "sinst_cnt 'GT' 0" []
]

+-- | Tests name ordering consistency: requesting a 'simple filter'
+-- results in identical name ordering as the wanted names, requesting
+-- a more complex filter results in a niceSort-ed order.
+prop_node_name_ordering :: Property
+prop_node_name_ordering =
+ forAll (genClusterNames 2 6) $ \(cfg, nnames) ->
+ forAll (elements (subsequences nnames)) $ \sorted_nodes ->
+ forAll (elements (permutations sorted_nodes)) $ \chosen_nodes ->
+ let orfilter = OrFilter $ map (EQFilter "name" . QuotedString) chosen_nodes
+ alln = namesToResult chosen_nodes
+ all_sorted = namesToResult $ niceSort chosen_nodes
+ test_query = checkQueryResults cfg . makeNodeQuery
+ in conjoin
+ [ test_query orfilter "simple filter/requested" alln
+ , test_query (AndFilter [orfilter]) "complex filter/sorted" all_sorted
+ ]
+

-- | Tests node regex filtering. This is a very basic test :(

prop_node_regex_filter :: Property
prop_node_regex_filter =
- forAll (choose (0, maxNodes)) $ \numnodes ->

- forAll (genEmptyCluster numnodes) $ \cfg ->

- let nnames = niceSort . Map.keys . fromContainer $ configNodes cfg
- expected = map ((:[]) . ResultEntry RSNormal . Just . showJSON) nnames
- regex = mkRegex ".*"::Result FilterRegex
- in case regex of
- Bad msg -> failTest $ "Can't build regex?! Error: " ++ msg
- Ok rx ->

- checkQueryResults cfg (makeNodeQuery (RegexpFilter "name" rx))

- "rows for all nodes regexp filter"
- expected
+ forAll (genClusterNames 0 maxNodes) $ \(cfg, nnames) ->
+ case mkRegex ".*"::Result FilterRegex of
+ Bad msg -> failTest $ "Can't build regex?! Error: " ++ msg
+ Ok rx ->
+ checkQueryResults cfg (makeNodeQuery (RegexpFilter "name" rx))
+ "rows for all nodes regexp filter" $ namesToResult nnames

-- | Tests node regex filtering. This is a very basic test :(

prop_node_bad_filter :: String -> Int -> Property
prop_node_bad_filter rndname rndint =
- forAll (choose (1, maxNodes)) $ \numnodes ->

- forAll (genEmptyCluster numnodes) $ \cfg ->

- let regex = mkRegex ".*"::Result FilterRegex
- test_query = expectBadQuery cfg . makeNodeQuery
+ forAll (genClusterNames 1 maxNodes) $ \(cfg, _) ->
+ let test_query = expectBadQuery cfg . makeNodeQuery
string_value = QuotedString rndname
numeric_value = NumericValue $ fromIntegral rndint
- in case regex of
+ in case mkRegex ".*"::Result FilterRegex of

Bad msg -> failTest $ "Can't build regex?! Error: " ++ msg
Ok rx ->

conjoin
@@ -175,6 +192,7 @@ prop_makeSimpleFilter =

testSuite "Query/Filter"
[ 'prop_node_single_filter
, 'prop_node_many_filter

+ , 'prop_node_name_ordering
, 'prop_node_regex_filter
, 'prop_node_bad_filter
, 'prop_makeSimpleFilter
--
1.7.10.4

[Iustin Pop]

… and also use it to simplify 'needsLiveData'. Additionally, add an
explicit export list to Ganeti.Query.Types, since otherwise we'd
(re)export all imported symbols.
---
htools/Ganeti/Query/Query.hs | 4 +---
htools/Ganeti/Query/Types.hs | 13 ++++++++++++-
2 files changed, 13 insertions(+), 4 deletions(-)

diff --git a/htools/Ganeti/Query/Query.hs b/htools/Ganeti/Query/Query.hs
index 9dfcfa4..9edbb4d 100644
--- a/htools/Ganeti/Query/Query.hs
+++ b/htools/Ganeti/Query/Query.hs
@@ -116,9 +116,7 @@ maybeCollectLiveData True cfg nodes = do

-- | Check whether list of queried fields contains live fields.

needsLiveData :: [FieldGetter a b] -> Bool
-needsLiveData = any (\getter -> case getter of
- FieldRuntime _ -> True
- _ -> False)
+needsLiveData = any isRuntimeField

-- | Checks whether we have requested exactly some names. This is a

-- simple wrapper over 'requestedNames' and 'nameField'.

diff --git a/htools/Ganeti/Query/Types.hs b/htools/Ganeti/Query/Types.hs
index 175dfa5..42300b2 100644
--- a/htools/Ganeti/Query/Types.hs
+++ b/htools/Ganeti/Query/Types.hs
@@ -26,7 +26,13 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA

-}

-module Ganeti.Query.Types where
+module Ganeti.Query.Types
+ ( FieldGetter(..)
+ , FieldData
+ , FieldList
+ , FieldMap
+ , isRuntimeField
+ ) where

import qualified Data.Map as Map

@@ -52,3 +58,8 @@ type FieldList a b = [FieldData a b]

-- | Alias for field maps.
type FieldMap a b = Map.Map String (FieldData a b)
+
+-- | Helper function to check if a getter is a runtime one.
+isRuntimeField :: FieldGetter a b -> Bool
+isRuntimeField (FieldRuntime _) = True
+isRuntimeField _ = False
--
1.7.10.4

[Iustin Pop]

While grepping for htools imports in the non-htools subdirectory, I
saw that our haddock prologue and title are very very old and refer to
the old htools-only state. Let's cleanup a bit…

Signed-off-by: Iustin Pop <ius...@google.com>
---

Makefile.am | 2 +-
htools/Ganeti/THH.hs | 2 +-
htools/haddock-prologue | 10 ++++------
3 files changed, 6 insertions(+), 8 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 89b4e6d..35c5f9e 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1602,7 +1602,7 @@ hs-apidoc: $(HS_BUILT_SRCS)
$(HSCOLOUR) -css -anchor $$file > ../$(APIDOC_HS_DIR)/$$hfile ; \
done ; \
$(HADDOCK) --odir ../$(APIDOC_HS_DIR) --html --ignore-all-exports -w \
- -t ganeti-htools -p haddock-prologue \
+ -t ganeti -p haddock-prologue \
--source-module="%{MODULE/.//}.html" \
--source-entity="%{MODULE/.//}.html#%{NAME}" \
$$OPTGHC \
diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs
index 95d93fe..9bdde6f 100644
--- a/htools/Ganeti/THH.hs
+++ b/htools/Ganeti/THH.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE TemplateHaskell #-}

-{-| TemplateHaskell helper for HTools.
+{-| TemplateHaskell helper for Ganeti Haskell code.

As TemplateHaskell require that splices be defined in a separate
module, we combine all the TemplateHaskell functionality that HTools
diff --git a/htools/haddock-prologue b/htools/haddock-prologue
index 5e156d8..a301e8f 100644
--- a/htools/haddock-prologue
+++ b/htools/haddock-prologue
@@ -1,7 +1,5 @@
-This is the internal documentation for ganeti-htools, a couple of
-small tools for Ganeti cluster analysis.
+This is the internal documentation for the Haskell components of Ganeti.

-The "Ganeti.HTools.Cluster" module is the one holding most high-level
-logic, the "Ganeti.HTools.Node" and "Ganeti.HTools.Instance" modules
-hold the model for nodes and instances respectively, while the
-"Ganeti.HTools.Rapi" contains the RAPI collector.
+The @Ganeti.HTools@ subtree contain the htools-specific component
+(rebalancing, allocation, capacity), while the @Ganeti@ tree contains
+basic functionality and core components.
--
1.7.10.4

[Iustin Pop]

This patch removes the last HTools module imports from non-htools code
(the HTools.Types module), but it requires an associated cleanup:
using luxi-specific constants for luxi timeouts (the only effect is
that one timeout decreases from 15 to 10, the default value in the
python code), and moving of the (now) RAPI specific constants to
RAPI.hs (which allows simplifying their type/usage).

Signed-off-by: Iustin Pop <ius...@google.com>
---

htools/Ganeti/Confd/Server.hs | 2 +-
htools/Ganeti/HTools/Rapi.hs | 12 ++++++++++--
htools/Ganeti/HTools/Types.hs | 10 ----------
htools/Ganeti/Luxi.hs | 8 ++++----
4 files changed, 15 insertions(+), 17 deletions(-)

diff --git a/htools/Ganeti/Confd/Server.hs b/htools/Ganeti/Confd/Server.hs
index 5644f11..e2aa6a5 100644
--- a/htools/Ganeti/Confd/Server.hs
+++ b/htools/Ganeti/Confd/Server.hs
@@ -44,9 +44,9 @@ import System.Time

import qualified Text.JSON as J

import System.INotify

+import Ganeti.BasicTypes
import Ganeti.Daemon
import Ganeti.JSON
-import Ganeti.HTools.Types

import Ganeti.Objects
import Ganeti.Confd
import Ganeti.Confd.Utils

diff --git a/htools/Ganeti/HTools/Rapi.hs b/htools/Ganeti/HTools/Rapi.hs
index 6f1a9fb..b7a7370 100644
--- a/htools/Ganeti/HTools/Rapi.hs
+++ b/htools/Ganeti/HTools/Rapi.hs
@@ -66,12 +66,20 @@ getUrl _ = return $ fail "RAPI/curl backend disabled at compile time"

#else

+-- | Connection timeout (when using non-file methods).
+connTimeout :: Long
+connTimeout = 15
+
+-- | The default timeout for queries (when using non-file methods).
+queryTimeout :: Long
+queryTimeout = 60
+
-- | The curl options we use.
curlOpts :: [CurlOption]
curlOpts = [ CurlSSLVerifyPeer False
, CurlSSLVerifyHost 0
- , CurlTimeout (fromIntegral queryTimeout)
- , CurlConnectTimeout (fromIntegral connTimeout)
+ , CurlTimeout queryTimeout
+ , CurlConnectTimeout connTimeout
]

getUrl url = do
diff --git a/htools/Ganeti/HTools/Types.hs b/htools/Ganeti/HTools/Types.hs
index 31b3d70..fb83910 100644
--- a/htools/Ganeti/HTools/Types.hs
+++ b/htools/Ganeti/HTools/Types.hs
@@ -72,8 +72,6 @@ module Ganeti.HTools.Types
, FailStats
, OpResult(..)
, opToResult
- , connTimeout
- , queryTimeout
, EvacMode(..)
, ISpec(..)
, IPolicy(..)
@@ -319,14 +317,6 @@ unknownField = "<unknown field>"
-- | A list of command elements.
type JobSet = [MoveJob]

--- | Connection timeout (when using non-file methods).
-connTimeout :: Int
-connTimeout = 15
-
--- | The default timeout for queries (when using non-file methods).
-queryTimeout :: Int
-queryTimeout = 60
-
-- | Default max disk usage ratio.
defReservedDiskRatio :: Double
defReservedDiskRatio = 0
diff --git a/htools/Ganeti/Luxi.hs b/htools/Ganeti/Luxi.hs
index 12dc6ed..2086a0e 100644
--- a/htools/Ganeti/Luxi.hs
+++ b/htools/Ganeti/Luxi.hs
@@ -67,8 +67,8 @@ import System.IO.Error (isEOFError)
import System.Timeout

import qualified Network.Socket as S

+import Ganeti.BasicTypes
import Ganeti.JSON
-import Ganeti.HTools.Types
import Ganeti.Utils

import Ganeti.Constants
@@ -214,7 +214,7 @@ data Client = Client { socket :: Handle -- ^ The socket of the client
getClient :: String -> IO Client
getClient path = do
s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
- withTimeout connTimeout "creating luxi connection" $
+ withTimeout luxiDefCtmo "creating luxi connection" $
S.connect s (S.SockAddrUnix path)
rf <- newIORef B.empty
h <- S.socketToHandle s ReadWriteMode
@@ -250,7 +250,7 @@ closeClient = hClose . socket

-- | Sends a message over a luxi transport.
sendMsg :: Client -> String -> IO ()
-sendMsg s buf = withTimeout queryTimeout "sending luxi message" $ do
+sendMsg s buf = withTimeout luxiDefRwto "sending luxi message" $ do
let encoded = UTF8.fromString buf
handle = socket s
B.hPut handle encoded
@@ -262,7 +262,7 @@ sendMsg s buf = withTimeout queryTimeout "sending luxi message" $ do
-- message and the leftover buffer contents.
recvUpdate :: Handle -> B.ByteString -> IO (B.ByteString, B.ByteString)
recvUpdate handle obuf = do
- nbuf <- withTimeout queryTimeout "reading luxi response" $ do
+ nbuf <- withTimeout luxiDefRwto "reading luxi response" $ do
_ <- hWaitForInput handle (-1)
B.hGetNonBlocking handle 4096
let (msg, remaining) = B.break (eOM ==) nbuf
--
1.7.10.4

[Agata Murawska]

2012/10/5 Iustin Pop <ius...@google.com>:

> The disk free/total values are optional ones, wrapped in a Maybe, so
> we shouldn't directly serialise them. In order to simplify the
> embedded extraction, we add a small helper function.
>
> Signed-off-by: Iustin Pop <ius...@google.com>
> ---
> htools/Ganeti/Query/Node.hs | 9 +++++++--
> 1 file changed, 7 insertions(+), 2 deletions(-)
>
> diff --git a/htools/Ganeti/Query/Node.hs b/htools/Ganeti/Query/Node.hs
> index 0630754..01d0a89 100644
> --- a/htools/Ganeti/Query/Node.hs
> +++ b/htools/Ganeti/Query/Node.hs
> @@ -68,6 +68,11 @@ nodeLiveFieldsDefs =
> "Total amount of memory of physical machine")
> ]
>
> +-- | Helper for extracting Maybe values from a possibly empty list.
> +getMaybeJsonHead :: (J.JSON b) => [a] -> (a -> Maybe b) -> J.JSValue
> +getMaybeJsonHead [] _ = J.JSNull
> +getMaybeJsonHead (x:_) f = maybe J.JSNull J.showJSON (f x)

I think this should be in JSON.hs, just in case we'd ever need that again

[Agata Murawska]

2012/10/5 Iustin Pop <ius...@google.com>:

> The String parameter to 'nodeLiveFieldExtract' is the query2 field
> name, not the RPC-layer field name. Grrr for not having a real data
> type for this.

Huh, this is interesting - I had it with FieldName originally, but
changed since the string values here were the same as names of the
fields used for dictionary creation (see Rpc.hs) and I hoped this can
then be at some point automated.

>
> Furthermore, we add some safety check that we don't return JSNull via
> rsNormal…
>
> Signed-off-by: Iustin Pop <ius...@google.com>
> ---
> htools/Ganeti/Query/Node.hs | 38 ++++++++++++++++++++------------------
> 1 file changed, 20 insertions(+), 18 deletions(-)
>
> diff --git a/htools/Ganeti/Query/Node.hs b/htools/Ganeti/Query/Node.hs
> index ded9979..0630754 100644
> --- a/htools/Ganeti/Query/Node.hs
> +++ b/htools/Ganeti/Query/Node.hs
> @@ -72,29 +72,31 @@ nodeLiveFieldsDefs =
> -- the RPC result.
> nodeLiveFieldExtract :: String -> RpcResultNodeInfo -> J.JSValue

I may have gaps in my memory (no code on this machine ;) ), but
shouldn't the type be FieldName not String now?

[Iustin Pop]

On Fri, Oct 05, 2012 at 09:42:34AM +0200, Agata Murawska wrote:
> 2012/10/5 Iustin Pop <ius...@google.com>:
> > The String parameter to 'nodeLiveFieldExtract' is the query2 field
> > name, not the RPC-layer field name. Grrr for not having a real data
> > type for this.
> Huh, this is interesting - I had it with FieldName originally, but
> changed since the string values here were the same as names of the
> fields used for dictionary creation (see Rpc.hs) and I hoped this can
> then be at some point automated.

I think you are mistaken. The bug was exactly that you used the same
string, when the opcode-layer and RPC-layer strings are different.

> > Furthermore, we add some safety check that we don't return JSNull via
> > rsNormal…
> >
> > Signed-off-by: Iustin Pop <ius...@google.com>
> > ---
> > htools/Ganeti/Query/Node.hs | 38 ++++++++++++++++++++------------------
> > 1 file changed, 20 insertions(+), 18 deletions(-)
> >
> > diff --git a/htools/Ganeti/Query/Node.hs b/htools/Ganeti/Query/Node.hs
> > index ded9979..0630754 100644
> > --- a/htools/Ganeti/Query/Node.hs
> > +++ b/htools/Ganeti/Query/Node.hs
> > @@ -72,29 +72,31 @@ nodeLiveFieldsDefs =
> > -- the RPC result.
> > nodeLiveFieldExtract :: String -> RpcResultNodeInfo -> J.JSValue
> I may have gaps in my memory (no code on this machine ;) ), but
> shouldn't the type be FieldName not String now?

Indeed, but type FieldName = String, so I didn't pay too much attention.
Consider it fixed.

thanks,
iustin

[Iustin Pop]

On Fri, Oct 05, 2012 at 09:46:48AM +0200, Agata Murawska wrote:
> 2012/10/5 Iustin Pop <ius...@google.com>:
> > The disk free/total values are optional ones, wrapped in a Maybe, so
> > we shouldn't directly serialise them. In order to simplify the
> > embedded extraction, we add a small helper function.
> >
> > Signed-off-by: Iustin Pop <ius...@google.com>
> > ---
> > htools/Ganeti/Query/Node.hs | 9 +++++++--
> > 1 file changed, 7 insertions(+), 2 deletions(-)
> >
> > diff --git a/htools/Ganeti/Query/Node.hs b/htools/Ganeti/Query/Node.hs
> > index 0630754..01d0a89 100644
> > --- a/htools/Ganeti/Query/Node.hs
> > +++ b/htools/Ganeti/Query/Node.hs
> > @@ -68,6 +68,11 @@ nodeLiveFieldsDefs =
> > "Total amount of memory of physical machine")
> > ]
> >
> > +-- | Helper for extracting Maybe values from a possibly empty list.
> > +getMaybeJsonHead :: (J.JSON b) => [a] -> (a -> Maybe b) -> J.JSValue
> > +getMaybeJsonHead [] _ = J.JSNull
> > +getMaybeJsonHead (x:_) f = maybe J.JSNull J.showJSON (f x)
> I think this should be in JSON.hs, just in case we'd ever need that again

Thanks, make sense. Will send interdiff.

iustin

[Michael Hanselmann]

2012/10/5 Iustin Pop <ius...@google.com>:

> A lot of the lists in Makefile.am were not sorted properly (or at
> all); let's sort them for more sanity.
>
> Additionally, check-local used to spew this big shell block, even
> though it does emit nice messages when failing, so we don't need to
> show the code; let's silence it (@).

LGTM

[Michael Hanselmann]

2012/10/5 Iustin Pop <ius...@google.com>:
> This is, I believe, the last non-htools specific file that still lived
> in the htools directory; it's already widely used in non-htools code,
> so let's move it before we add more functionality to this module.
>
> All changes are related to the name change, imports fixup, etc.; there
> are no other changes in this patch.

LGTM

[Michael Hanselmann]

2012/10/5 Iustin Pop <ius...@google.com>:
> This is a leftover from the times when we had a single, huge test
> module; nowadays it's only an annoyance.

LGTM

[Michael Hanselmann]

2012/10/5 Iustin Pop <ius...@google.com>:
> Newer GHC refuses to allow "-O" with interactive mode, so let's filter
> that out. Furthermore, sometimes you don't have a clean tree exactly
> when you need to look up something/update the tags, so let's filter
> out the "-Werror" too.
>
> And finally, we need to pass the actual exact flags (including
> nocurl, parallel, etc.) that we use for building, so let's add those
> too.

LGTM

[Michael Hanselmann]

2012/10/5 Iustin Pop <ius...@google.com>:
> This was missing so far…

LGTM

[Iustin Pop]

And here it is:

diff --git a/htools/Ganeti/JSON.hs b/htools/Ganeti/JSON.hs
index 7c7dd34..178915a 100644
--- a/htools/Ganeti/JSON.hs
+++ b/htools/Ganeti/JSON.hs
@@ -32,6 +32,7 @@ module Ganeti.JSON
, fromKeyValue
, fromJVal
, jsonHead
+ , getMaybeJsonHead
, asJSObject
, asObjectList
, tryFromObj
@@ -131,6 +132,11 @@ jsonHead :: (J.JSON b) => [a] -> (a -> b) -> J.JSValue
jsonHead [] _ = J.JSNull
jsonHead (x:_) f = J.showJSON $ f x

+-- | Helper for extracting Maybe values from a possibly empty list.
+getMaybeJsonHead :: (J.JSON b) => [a] -> (a -> Maybe b) -> J.JSValue
+getMaybeJsonHead [] _ = J.JSNull
+getMaybeJsonHead (x:_) f = maybe J.JSNull J.showJSON (f x)

+
-- | Converts a JSON value into a JSON object.
asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
asJSObject (J.JSObject a) = return a
diff --git a/htools/Ganeti/Query/Node.hs b/htools/Ganeti/Query/Node.hs
index 01d0a89..06ec199 100644
--- a/htools/Ganeti/Query/Node.hs
+++ b/htools/Ganeti/Query/Node.hs
@@ -68,11 +68,6 @@ nodeLiveFieldsDefs =

"Total amount of memory of physical machine")
]

--- | Helper for extracting Maybe values from a possibly empty list.
-getMaybeJsonHead :: (J.JSON b) => [a] -> (a -> Maybe b) -> J.JSValue
-getMaybeJsonHead [] _ = J.JSNull
-getMaybeJsonHead (x:_) f = maybe J.JSNull J.showJSON (f x)
-

-- | Map each name to a function that extracts that value from
-- the RPC result.
nodeLiveFieldExtract :: String -> RpcResultNodeInfo -> J.JSValue

--
thanks,
iustin

[Michael Hanselmann]

2012/10/5 Iustin Pop <ius...@google.com>:

> This patch adds a NiceSort equivalent and the corresponding unittest
> (partially copied from Python unittest). The difference between the
> Python version and this one is that this implementation doesn't use
> regular expressions, and as such it doesn't have the 8-groups
> limitation.
>
> The key-based version is separate from the non-key one (since we don't
> have default arguments in Haskell), and is tested less in its absolute
> properties but only that it is identical to the non-key version under
> some transformations (the non-key version is much more tested).
>
> This will be needed later in query name sorting.

LGTM

[Michael Hanselmann]

2012/10/5 Iustin Pop <ius...@google.com>:

> And associated unittests. This will be needed for classic-style
> queries.

LGTM

[Guido Trotter]

LGTM

Thanks,

Guido

--
Guido Trotter
SRE - Corp Computing Services (aka Horsepower)
Google Ireland

[Michael Hanselmann]

2012/10/5 Iustin Pop <ius...@google.com>:
> --- a/htools/Ganeti/Query/Query.hs
> +++ b/htools/Ganeti/Query/Query.hs
> @@ -103,7 +103,9 @@ maybeCollectLiveData False _ nodes =

>
> maybeCollectLiveData True cfg nodes = do

> let vgs = [clusterVolumeGroupName $ configCluster cfg]
> - hvs = clusterEnabledHypervisors $ configCluster cfg
> + hvs = case clusterEnabledHypervisors $ configCluster cfg of
> + [] -> [XenPvm] -- this case shouldn't happen, but we handle it

Why do you hardcode XenPvm here? Shouldn't you rather raise an
exception or have this in a global place?

> + x:_ -> [x]
> executeRpcCall nodes (RpcCallNodeInfo vgs hvs)

Michael

[Michael Hanselmann]

2012/10/5 Iustin Pop <ius...@google.com>:

> … and use it in the Query implementation, removing the last
> non-correct query field for Groups.

LGTM

[Michael Hanselmann]

2012/10/5 Iustin Pop <ius...@google.com>:
> This makes the "all" names queries consistent with the Python
> results. The change requires updating the unittests, at which point a
> duplicate error message is simplified.

LGTM

[Iustin Pop]

On Wed, Oct 10, 2012 at 11:54:48AM +0200, Michael Hanselmann wrote:
> 2012/10/5 Iustin Pop <ius...@google.com>:
> > --- a/htools/Ganeti/Query/Query.hs
> > +++ b/htools/Ganeti/Query/Query.hs
> > @@ -103,7 +103,9 @@ maybeCollectLiveData False _ nodes =
> >
> > maybeCollectLiveData True cfg nodes = do
> > let vgs = [clusterVolumeGroupName $ configCluster cfg]
> > - hvs = clusterEnabledHypervisors $ configCluster cfg
> > + hvs = case clusterEnabledHypervisors $ configCluster cfg of
> > + [] -> [XenPvm] -- this case shouldn't happen, but we handle it
>
> Why do you hardcode XenPvm here? Shouldn't you rather raise an
> exception or have this in a global place?

Eee, I was thinking exactly about moving this into a
getDefaultHypervisor function in Config.hs, but then though "if I send
an interdiff, I will delay review even more".

Thanks for catching this; interdiff:

diff --git a/htools/Ganeti/Config.hs b/htools/Ganeti/Config.hs
index f88ba8a..55cb492 100644
--- a/htools/Ganeti/Config.hs
+++ b/htools/Ganeti/Config.hs
@@ -31,6 +31,7 @@ module Ganeti.Config
, getNodeRole
, getNodeNdParams
, getDefaultNicLink
+ , getDefaultHypervisor
, getInstancesIpByLink
, getNode
, getInstance
@@ -126,6 +127,16 @@ getDefaultNicLink =
nicpLink . (M.! C.ppDefault) . fromContainer .
clusterNicparams . configCluster

+-- | Returns the default cluster hypervisor.
+getDefaultHypervisor :: ConfigData -> Hypervisor
+getDefaultHypervisor cfg =
+ case clusterEnabledHypervisors $ configCluster cfg of
+ -- FIXME: this case shouldn't happen (configuration broken), but
+ -- for now we handle it here because we're not authoritative for
+ -- the config
+ [] -> XenPvm

+ x:_ -> x

+
-- | Returns instances of a given link.
getInstancesIpByLink :: LinkIpMap -> String -> [String]
getInstancesIpByLink linkipmap link =
diff --git a/htools/Ganeti/Query/Query.hs b/htools/Ganeti/Query/Query.hs
index ff7d33d..7a172ff 100644
--- a/htools/Ganeti/Query/Query.hs
+++ b/htools/Ganeti/Query/Query.hs
@@ -56,6 +56,7 @@ import Data.Maybe (fromMaybe)

import qualified Data.Map as Map

import Ganeti.BasicTypes
+import Ganeti.Config
import Ganeti.JSON
import Ganeti.Rpc
import Ganeti.Query.Language
@@ -103,9 +104,7 @@ maybeCollectLiveData False _ nodes =

maybeCollectLiveData True cfg nodes = do
let vgs = [clusterVolumeGroupName $ configCluster cfg]

- hvs = case clusterEnabledHypervisors $ configCluster cfg of
- [] -> [XenPvm] -- this case shouldn't happen, but we handle it
- x:_ -> [x]
+ hvs = [getDefaultHypervisor cfg]

executeRpcCall nodes (RpcCallNodeInfo vgs hvs)

-- | Check whether list of queried fields contains live fields.

--
iustin

[Michael Hanselmann]

2012/10/10 Iustin Pop <ius...@google.com>:

> On Wed, Oct 10, 2012 at 11:54:48AM +0200, Michael Hanselmann wrote:
>> 2012/10/5 Iustin Pop <ius...@google.com>:
>> > --- a/htools/Ganeti/Query/Query.hs
>> > +++ b/htools/Ganeti/Query/Query.hs
>> > @@ -103,7 +103,9 @@ maybeCollectLiveData False _ nodes =
>> >
>> > maybeCollectLiveData True cfg nodes = do
>> > let vgs = [clusterVolumeGroupName $ configCluster cfg]
>> > - hvs = clusterEnabledHypervisors $ configCluster cfg
>> > + hvs = case clusterEnabledHypervisors $ configCluster cfg of
>> > + [] -> [XenPvm] -- this case shouldn't happen, but we handle it
>>
>> Why do you hardcode XenPvm here? Shouldn't you rather raise an
>> exception or have this in a global place?
>
> Eee, I was thinking exactly about moving this into a
> getDefaultHypervisor function in Config.hs, but then though "if I send
> an interdiff, I will delay review even more".
>
> Thanks for catching this; interdiff:

LGTM

[Iustin Pop]

Ping? Just to be clear, interdiff:

diff --git a/htools/Ganeti/Query/Node.hs b/htools/Ganeti/Query/Node.hs
index 0630754..62b625b 100644
--- a/htools/Ganeti/Query/Node.hs
+++ b/htools/Ganeti/Query/Node.hs
@@ -70,7 +70,7 @@ nodeLiveFieldsDefs =

-- | Map each name to a function that extracts that value from
-- the RPC result.

-nodeLiveFieldExtract :: String -> RpcResultNodeInfo -> J.JSValue
+nodeLiveFieldExtract :: FieldName -> RpcResultNodeInfo -> J.JSValue
nodeLiveFieldExtract "bootid" res =
J.showJSON $ rpcResNodeInfoBootId res
nodeLiveFieldExtract "cnodes" res =

--
thanks,
iustin

[Agata Murawska]

2012/10/10 Iustin Pop <ius...@google.com>:

I don't think I still have LGTM powers, but if I do then LGTM :)

[Iustin Pop]

Thanks, and you still do :)

iustin

[Iustin Pop]

On Mon, Oct 08, 2012 at 01:29:15PM +0200, Iustin Pop wrote:
> On Fri, Oct 05, 2012 at 08:29:41PM +0200, Iustin Pop wrote:
> > On Fri, Oct 05, 2012 at 09:46:48AM +0200, Agata Murawska wrote:
> > > 2012/10/5 Iustin Pop <ius...@google.com>:
> > > > The disk free/total values are optional ones, wrapped in a Maybe, so
> > > > we shouldn't directly serialise them. In order to simplify the
> > > > embedded extraction, we add a small helper function.
> > > >
> > > > Signed-off-by: Iustin Pop <ius...@google.com>
> > > > ---
> > > > htools/Ganeti/Query/Node.hs | 9 +++++++--
> > > > 1 file changed, 7 insertions(+), 2 deletions(-)
> > > >
> > > > diff --git a/htools/Ganeti/Query/Node.hs b/htools/Ganeti/Query/Node.hs
> > > > index 0630754..01d0a89 100644
> > > > --- a/htools/Ganeti/Query/Node.hs
> > > > +++ b/htools/Ganeti/Query/Node.hs
> > > > @@ -68,6 +68,11 @@ nodeLiveFieldsDefs =
> > > > "Total amount of memory of physical machine")
> > > > ]
> > > >
> > > > +-- | Helper for extracting Maybe values from a possibly empty list.
> > > > +getMaybeJsonHead :: (J.JSON b) => [a] -> (a -> Maybe b) -> J.JSValue
> > > > +getMaybeJsonHead [] _ = J.JSNull
> > > > +getMaybeJsonHead (x:_) f = maybe J.JSNull J.showJSON (f x)
> > > I think this should be in JSON.hs, just in case we'd ever need that again
> >
> > Thanks, make sense. Will send interdiff.
>
> And here it is:

Ping as well on this one? (thanks!)

iustin

[Agata Murawska]

2012/10/10 Iustin Pop <ius...@google.com>:

LGTM, sorry for late response :)

[Iustin Pop]

No problem, much appreciated!

iustin

[Agata Murawska]

2012/10/5 Iustin Pop <ius...@google.com>:
> This replicates in the Haskell Query2 implementation the behaviour of
> the Python code: if a "simple" filter is passed (one that contains
> only Or aggregators and EQ binary ops on the name field), then an
> failure is flagged if the given values are not known.
>
> Our implementation is pretty straightforward, with a few details:
>
> - we ignore any NumericValues passed, since that inconsistency will be
> flagged by the filter compiler
> - we return an the non-normalized names from the getRequestedNames
> function, and not the fully-normalized ones; this will be done later
> in individual query functions
> - we test a few of the desired behaviours of the above-mentioned
> function

>
> Signed-off-by: Iustin Pop <ius...@google.com>
> ---

> htest/Test/Ganeti/Query/Query.hs | 19 +++++++++++++++++++
> htools/Ganeti/Query/Filter.hs | 14 ++++++++++++++
> htools/Ganeti/Query/Query.hs | 27 +++++++++++++++++++++++++++
> 3 files changed, 60 insertions(+)
>
> diff --git a/htest/Test/Ganeti/Query/Query.hs b/htest/Test/Ganeti/Query/Query.hs
> index 74258ec..2090cd0 100644
> --- a/htest/Test/Ganeti/Query/Query.hs
> +++ b/htest/Test/Ganeti/Query/Query.hs
> @@ -210,6 +210,24 @@ case_queryGroup_allfields = do
> (sortBy field_sort . map fst $ Map.elems groupFieldsMap)
> (sortBy field_sort fdefs)
>
> +
> +-- | Tests that requested names checking behaves as expected.
> +prop_getRequestedNames :: Property
> +prop_getRequestedNames =
> + forAll getName $ \node1 ->
> + let chk = getRequestedNames . Query QRNode []
> + q_node1 = QuotedString node1
> + eq_name = EQFilter "name"
> + eq_node1 = eq_name q_node1
> + in conjoin [ printTestCase "empty filter" $ chk EmptyFilter ==? []
> + , printTestCase "and filter" $ chk (AndFilter [eq_node1]) ==? []
> + , printTestCase "simple equality" $ chk eq_node1 ==? [node1]
> + , printTestCase "non-name field" $
> + chk (EQFilter "foo" q_node1) ==? []
> + , printTestCase "non-simple filter" $
> + chk (OrFilter [ eq_node1 , LTFilter "foo" q_node1]) ==? []
> + ]
> +
> testSuite "Query/Query"
> [ 'prop_queryNode_noUnknown
> , 'prop_queryNode_Unknown
> @@ -219,4 +237,5 @@ testSuite "Query/Query"
> , 'prop_queryGroup_Unknown
> , 'prop_queryGroup_types
> , 'case_queryGroup_allfields
> + , 'prop_getRequestedNames
> ]
> diff --git a/htools/Ganeti/Query/Filter.hs b/htools/Ganeti/Query/Filter.hs
> index 56e6a6a..24ce796 100644
> --- a/htools/Ganeti/Query/Filter.hs
> +++ b/htools/Ganeti/Query/Filter.hs
> @@ -47,9 +47,11 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
> module Ganeti.Query.Filter
> ( compileFilter
> , evaluateFilter
> + , requestedNames
> ) where
>
> import Control.Applicative
> +import Control.Monad (liftM)

> import qualified Data.Map as Map

> import Data.Traversable (traverse)
> import Text.JSON (JSValue(..), fromJSString)
> @@ -171,3 +173,15 @@ tryGetter _ rt item (FieldRuntime getter) =
> maybe Nothing (\rt' -> Just $ getter rt' item) rt
> tryGetter _ _ _ FieldUnknown = Just $
> ResultEntry RSUnknown Nothing
> +
> +-- | Computes the requested names, if only names were requested (and
> +-- with equality). Otherwise returns 'Nothing'.
> +requestedNames :: FilterField -> Filter FilterField -> Maybe [FilterValue]
> +requestedNames _ EmptyFilter = Just []
> +requestedNames namefield (OrFilter flts) =
> + liftM concat $ mapM (requestedNames namefield) flts
> +requestedNames namefield (EQFilter fld val) =
> + if namefield == fld
> + then Just [val]
> + else Nothing
> +requestedNames _ _ = Nothing
> diff --git a/htools/Ganeti/Query/Query.hs b/htools/Ganeti/Query/Query.hs
> index ff7d33d..a17a920 100644
> --- a/htools/Ganeti/Query/Query.hs
> +++ b/htools/Ganeti/Query/Query.hs
> @@ -48,6 +48,7 @@ module Ganeti.Query.Query
>
> ( query
> , queryFields
> + , getRequestedNames
> ) where
>
> import Control.Monad (filterM)
> @@ -114,6 +115,32 @@ needsLiveData = any (\getter -> case getter of
> FieldRuntime _ -> True
> _ -> False)
>
> +-- | Checks whether we have requested exactly some names. This is a
> +-- simple wrapper over 'requestedNames' and 'nameField'.
> +needsNames :: Query -> Maybe [FilterValue]
> +needsNames (Query kind _ qfilter) = requestedNames (nameField kind) qfilter
> +
> +-- | Computes the name field for different query types.
> +nameField :: ItemType -> FilterField
> +nameField QRJob = "id"
> +nameField _ = "name"
> +
> +-- | Extracts all quoted strings from a list, ignoring the
> +-- 'NumericValue' entries.
> +getAllQuotedStrings :: [FilterValue] -> [String]
> +getAllQuotedStrings =
> + concatMap extractor
> + where extractor (NumericValue _) = []
> + extractor (QuotedString val) = [val]
> +
> +-- | Checks that we have either requested a valid set of names, or we
> +-- have a more complex filter.
> +getRequestedNames :: Query -> [String]
> +getRequestedNames qry =
> + case needsNames qry of
> + Just names -> getAllQuotedStrings names
> + Nothing -> []
> +
> -- | Main query execution function.
> query :: ConfigData -- ^ The current configuration
> -> Bool -- ^ Whether to collect live data
> --
> 1.7.10.4
>

LGTM

[Agata Murawska]

2012/10/5 Iustin Pop <ius...@google.com>:
> We do this not quite generically, which means we have to add
> another layer in the call chain, and rename the current query
> function, plus add special-case code for each query type. Hopefully we
> will be able to improve on this in the future.
>
> A (good) side effect of this patch is that we get the desired
> ordering when names are requested, matching the Python code.

>
> Signed-off-by: Iustin Pop <ius...@google.com>
> ---

> htools/Ganeti/Query/Query.hs | 24 +++++++++++++++++++-----
> 1 file changed, 19 insertions(+), 5 deletions(-)
>
> diff --git a/htools/Ganeti/Query/Query.hs b/htools/Ganeti/Query/Query.hs
> index a17a920..875e870 100644
> --- a/htools/Ganeti/Query/Query.hs
> +++ b/htools/Ganeti/Query/Query.hs
> @@ -57,6 +57,7 @@ import Data.Maybe (fromMaybe)

> import qualified Data.Map as Map
>

> import Ganeti.BasicTypes
> +import Ganeti.Config
> import Ganeti.JSON
> import Ganeti.Rpc
> import Ganeti.Query.Language

> @@ -66,6 +67,7 @@ import Ganeti.Query.Types
> import Ganeti.Query.Node
> import Ganeti.Query.Group
> import Ganeti.Objects
> +import Ganeti.Utils
>
> -- * Helper functions
>
> @@ -146,13 +148,23 @@ query :: ConfigData -- ^ The current configuration

> -> Bool -- ^ Whether to collect live data

> -> Query -- ^ The query (item, fields, filter)
> -> IO (Result QueryResult) -- ^ Result
> +query cfg live qry = queryInner cfg live qry $ getRequestedNames qry
>
> -query cfg live (Query QRNode fields qfilter) = runResultT $ do
> +-- | Inner query execution function.
> +queryInner :: ConfigData -- ^ The current configuration
> + -> Bool -- ^ Whether to collect live data
> + -> Query -- ^ The query (item, fields, filter)
> + -> [String] -- ^ Requested names
> + -> IO (Result QueryResult) -- ^ Result
> +
> +queryInner cfg live (Query QRNode fields qfilter) wanted = runResultT $ do
> cfilter <- resultT $ compileFilter nodeFieldsMap qfilter
> let selected = getSelectedFields nodeFieldsMap fields
> (fdefs, fgetters) = unzip selected
> - nodes = Map.elems . fromContainer $ configNodes cfg
> live' = live && needsLiveData fgetters
> + nodes <- resultT $ case wanted of
> + [] -> Ok . Map.elems . fromContainer $ configNodes cfg
> + _ -> mapM (getNode cfg) wanted
> -- runs first pass of the filter, without a runtime context; this
> -- will limit the nodes that we'll contact for runtime data
> fnodes <- resultT $ filterM (\n -> evaluateFilter cfg Nothing n cfilter) nodes
> @@ -163,21 +175,23 @@ query cfg live (Query QRNode fields qfilter) = runResultT $ do
> nruntimes
> return QueryResult { qresFields = fdefs, qresData = fdata }
>
> -query cfg _ (Query QRGroup fields qfilter) = return $ do
> +queryInner cfg _ (Query QRGroup fields qfilter) wanted = 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
> + groups <- case wanted of
> + [] -> Ok . Map.elems . fromContainer $ configNodegroups cfg
> + _ -> mapM (getGroup cfg) wanted
> -- 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 _ _) =
> +queryInner _ _ (Query qkind _ _) _ =
> return . Bad $ "Query '" ++ show qkind ++ "' not supported"
>
> -- | Query fields call.
> --
> 1.7.10.4
>

LGTM

[Agata Murawska]

2012/10/5 Iustin Pop <ius...@google.com>:
> We don't add a type class for fully-generic handling, but we do
> abstract the duplicate part.

>
> Signed-off-by: Iustin Pop <ius...@google.com>
> ---

> htools/Ganeti/Query/Query.hs | 20 ++++++++++----------
> 1 file changed, 10 insertions(+), 10 deletions(-)
>
> diff --git a/htools/Ganeti/Query/Query.hs b/htools/Ganeti/Query/Query.hs
> index 562fc62..23bdbbd 100644
> --- a/htools/Ganeti/Query/Query.hs
> +++ b/htools/Ganeti/Query/Query.hs
> @@ -193,21 +193,21 @@ queryInner cfg _ (Query QRGroup fields qfilter) wanted = return $ do

> queryInner _ _ (Query qkind _ _) _ =
> return . Bad $ "Query '" ++ show qkind ++ "' not supported"
>

> +-- | Helper for 'queryFields'.
> +fieldsExtractor :: FieldMap a b -> [FilterField] -> QueryFieldsResult
> +fieldsExtractor fieldsMap fields =
> + let selected = if null fields
> + then map snd $ Map.toAscList fieldsMap
> + else getSelectedFields fieldsMap fields
> + in QueryFieldsResult (map fst selected)
> +
> -- | Query fields call.
> --- FIXME: Looks generic enough to use a typeclass
> queryFields :: QueryFields -> Result QueryFieldsResult
> queryFields (QueryFields QRNode fields) =
> - let selected = if null fields
> - then map snd $ Map.toAscList nodeFieldsMap
> - else getSelectedFields nodeFieldsMap fields
> - in Ok $ QueryFieldsResult (map fst selected)
> + Ok $ fieldsExtractor nodeFieldsMap fields
>
> 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)
> -
> + Ok $ fieldsExtractor groupFieldsMap fields
>
> queryFields (QueryFields qkind _) =
> Bad $ "QueryFields '" ++ show qkind ++ "' not supported"
> --
> 1.7.10.4
>

LGTM

[Agata Murawska]

2012/10/5 Iustin Pop <ius...@google.com>:
> When initially implementing the node query, I thought the 'powered'
> field is a representation of the run-time powered status, which would
> make its query complex.
>
> In reality, it's a simple config query, which we can support
> easily. We also add a small helper, so that we don't hardcode the
> RSUnavail case in many places.

>
> Signed-off-by: Iustin Pop <ius...@google.com>
> ---

> htools/Ganeti/Query/Common.hs | 5 +++++
> htools/Ganeti/Query/Node.hs | 13 ++++++++++---
> 2 files changed, 15 insertions(+), 3 deletions(-)
>
> diff --git a/htools/Ganeti/Query/Common.hs b/htools/Ganeti/Query/Common.hs
> index 0149578..b9029bc 100644
> --- a/htools/Ganeti/Query/Common.hs
> +++ b/htools/Ganeti/Query/Common.hs
> @@ -25,6 +25,7 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
>
> module Ganeti.Query.Common
> ( rsNoData
> + , rsUnavail
> , rsNormal
> , rsMaybe
> , rsUnknown
> @@ -66,6 +67,10 @@ vTypeToQFT VTypeInt = QFTNumber
> rsNoData :: ResultEntry
> rsNoData = ResultEntry RSNoData Nothing
>
> +-- | Helper for result for an entity which supports no such field.
> +rsUnavail :: ResultEntry
> +rsUnavail = ResultEntry RSUnavail Nothing
> +
> -- | Helper to declare a normal result.
> rsNormal :: (JSON a) => a -> ResultEntry
> rsNormal a = ResultEntry RSNormal $ Just (showJSON a)
> diff --git a/htools/Ganeti/Query/Node.hs b/htools/Ganeti/Query/Node.hs
> index 01d0a89..163e517 100644
> --- a/htools/Ganeti/Query/Node.hs
> +++ b/htools/Ganeti/Query/Node.hs
> @@ -122,6 +122,15 @@ nodeRoleDoc =
> "\"" ++ nodeRoleToRaw role ++ "\" for " ++ roleDescription role)
> (reverse [minBound..maxBound]))
>
> +-- | Get node powered status.
> +getNodePower :: ConfigData -> Node -> ResultEntry
> +getNodePower cfg node =
> + case getNodeNdParams cfg node of
> + Nothing -> rsNoData
> + Just ndp -> if null (ndpOobProgram ndp)
> + then rsUnavail
> + else rsNormal (nodePowered node)
> +
> -- | List of all node fields.
> nodeFields :: FieldList Node NodeRuntime
> nodeFields =
> @@ -179,11 +188,9 @@ nodeFields =
> 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)
> + FieldConfig getNodePower)
> -- 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
> --
> 1.7.10.4
>

LGTM (Sorry for double-posting to you, Iustin ;) )

[Agata Murawska]

2012/10/5 Iustin Pop <ius...@google.com>:
> This patch adds support for classic-style queries (before query2) to
> the query socket server. The patch is rather trivial, since as in
> Python we just piggy-back on the query2 implementation.

>
> Signed-off-by: Iustin Pop <ius...@google.com>
> ---

> htools/Ganeti/Query/Query.hs | 14 +++++++++++++-
> htools/Ganeti/Query/Server.hs | 20 ++++++++++++++++++++
> 2 files changed, 33 insertions(+), 1 deletion(-)
>
> diff --git a/htools/Ganeti/Query/Query.hs b/htools/Ganeti/Query/Query.hs
> index 23bdbbd..9dfcfa4 100644
> --- a/htools/Ganeti/Query/Query.hs
> +++ b/htools/Ganeti/Query/Query.hs
> @@ -45,16 +45,19 @@ too.
> -}
>
> module Ganeti.Query.Query
> -
> ( query
> , queryFields
> + , queryCompat
> , getRequestedNames
> + , nameField

> ) where
>
> import Control.Monad (filterM)

> import Control.Monad.Trans (lift)
> +import Data.List (intercalate)

> import Data.Maybe (fromMaybe)
> import qualified Data.Map as Map

> +import qualified Text.JSON as J
>
> import Ganeti.BasicTypes
> import Ganeti.Config
> @@ -211,3 +214,12 @@ queryFields (QueryFields QRGroup fields) =

>
> queryFields (QueryFields qkind _) =
> Bad $ "QueryFields '" ++ show qkind ++ "' not supported"

> +
> +-- | Classic query converter. It gets a standard query result on input
> +-- and computes the classic style results.
> +queryCompat :: QueryResult -> Result [[J.JSValue]]
> +queryCompat (QueryResult fields qrdata) =
> + case map fdefName $ filter ((== QFTUnknown) . fdefKind) fields of
> + [] -> Ok $ map (map (maybe J.JSNull J.showJSON . rentryValue)) qrdata
> + unknown -> Bad $ "Unknown output fields selected: " ++
> + intercalate ", " unknown
> diff --git a/htools/Ganeti/Query/Server.hs b/htools/Ganeti/Query/Server.hs
> index ca4409c..97ece0b 100644
> --- a/htools/Ganeti/Query/Server.hs
> +++ b/htools/Ganeti/Query/Server.hs
> @@ -51,11 +51,25 @@ import Ganeti.Logging
> import Ganeti.Luxi
> import qualified Ganeti.Query.Language as Qlang
> import Ganeti.Query.Query
> +import Ganeti.Query.Filter (makeSimpleFilter)
>
> -- | A type for functions that can return the configuration when
> -- executed.
> type ConfigReader = IO (Result ConfigData)
>
> +-- | Helper for classic queries.
> +handleClassicQuery :: ConfigData -- ^ Cluster config
> + -> Qlang.ItemType -- ^ Query type
> + -> [String] -- ^ Requested names (empty means all)
> + -> [String] -- ^ Requested fields
> + -> Bool -- ^ Whether to do sync queries or not
> + -> IO (Result JSValue)
> +handleClassicQuery _ _ _ _ True = return . Bad $ "Sync queries are not allowed"
> +handleClassicQuery cfg qkind names fields _ = do
> + let flt = makeSimpleFilter (nameField qkind) names
> + qr <- query cfg True (Qlang.Query qkind fields flt)
> + return $ showJSON <$> (qr >>= queryCompat)
> +
> -- | Minimal wrapper to handle the missing config case.
> handleCallWrapper :: Result ConfigData -> LuxiOp -> IO (Result JSValue)
> handleCallWrapper (Bad msg) _ =
> @@ -136,6 +150,12 @@ handleCall _ (QueryFields qkind qfields) = do
> let result = queryFields (Qlang.QueryFields qkind qfields)
> return $ J.showJSON <$> result
>
> +handleCall cfg (QueryNodes names fields lock) =
> + handleClassicQuery cfg Qlang.QRNode names fields lock
> +
> +handleCall cfg (QueryGroups names fields lock) =
> + handleClassicQuery cfg Qlang.QRGroup names fields lock
> +
> handleCall _ op =
> return . Bad $ "Luxi call '" ++ strOfOp op ++ "' not implemented"
>
> --
> 1.7.10.4
>
LGTM

[Agata Murawska]

2012/10/5 Iustin Pop <ius...@google.com>:
> … and also use it to simplify 'needsLiveData'. Additionally, add an
> explicit export list to Ganeti.Query.Types, since otherwise we'd
> (re)export all imported symbols.
> ---
> htools/Ganeti/Query/Query.hs | 4 +---
> htools/Ganeti/Query/Types.hs | 13 ++++++++++++-
> 2 files changed, 13 insertions(+), 4 deletions(-)
>
> diff --git a/htools/Ganeti/Query/Query.hs b/htools/Ganeti/Query/Query.hs
> index 9dfcfa4..9edbb4d 100644
> --- a/htools/Ganeti/Query/Query.hs
> +++ b/htools/Ganeti/Query/Query.hs
> @@ -116,9 +116,7 @@ maybeCollectLiveData True cfg nodes = do

>
> -- | Check whether list of queried fields contains live fields.

> needsLiveData :: [FieldGetter a b] -> Bool
> -needsLiveData = any (\getter -> case getter of
> - FieldRuntime _ -> True
> - _ -> False)
> +needsLiveData = any isRuntimeField

>
> -- | Checks whether we have requested exactly some names. This is a

> -- simple wrapper over 'requestedNames' and 'nameField'.

> diff --git a/htools/Ganeti/Query/Types.hs b/htools/Ganeti/Query/Types.hs
> index 175dfa5..42300b2 100644
> --- a/htools/Ganeti/Query/Types.hs
> +++ b/htools/Ganeti/Query/Types.hs
> @@ -26,7 +26,13 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
>
> -}
>
> -module Ganeti.Query.Types where
> +module Ganeti.Query.Types
> + ( FieldGetter(..)
> + , FieldData
> + , FieldList
> + , FieldMap
> + , isRuntimeField
> + ) where

>
> import qualified Data.Map as Map
>

> @@ -52,3 +58,8 @@ type FieldList a b = [FieldData a b]
>
> -- | Alias for field maps.
> type FieldMap a b = Map.Map String (FieldData a b)
> +
> +-- | Helper function to check if a getter is a runtime one.
> +isRuntimeField :: FieldGetter a b -> Bool
> +isRuntimeField (FieldRuntime _) = True
> +isRuntimeField _ = False
> --
> 1.7.10.4
>

LGTM

[Michael Hanselmann]

2012/10/5 Iustin Pop <ius...@google.com>:
> This switches gnt-node/gnt-group (and their equivalent RAPI resources)
> to go over the query socket.

LGTM

[Iustin Pop]

On Thu, Oct 11, 2012 at 01:03:32AM +0200, Agata Murawska wrote:
> LGTM (Sorry for double-posting to you, Iustin ;) )

Heh, no problem. Again, thanks for the reviews!

iustin

[Michael Hanselmann]

2012/10/5 Iustin Pop <ius...@google.com>:
> This patch cleans up duplicate code in Test.Ganeti.Query.Filter and
> then adds a test for names consistency with Python's code behaviour
> (stable ordering for simple filters and otherwise niceSort'ed
> ordering).

LGTM

[Michael Hanselmann]

2012/10/5 Iustin Pop <ius...@google.com>:
> This patch removes the last HTools module imports from non-htools code
> (the HTools.Types module), but it requires an associated cleanup:
> using luxi-specific constants for luxi timeouts (the only effect is
> that one timeout decreases from 15 to 10, the default value in the
> python code), and moving of the (now) RAPI specific constants to
> RAPI.hs (which allows simplifying their type/usage).

LGTM

[Michael Hanselmann]

2012/10/5 Iustin Pop <ius...@google.com>:
> While grepping for htools imports in the non-htools subdirectory, I
> saw that our haddock prologue and title are very very old and refer to
> the old htools-only state. Let's cleanup a bit…

LGTM