From 91c1a26542a47307df47ca5710c6a0099d323110 Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Wed, 27 Feb 2013 17:50:40 +0100
Subject: [PATCH] Fix node partial name matching in Haskell code

This implements QffHostname and fixes the node listing (as well as
export listing when filtering on node name).

This bug was hidden by the fact that node listing with "gnt-node list
aa" works if you don't have live queries (as it was originally), as
the choosing of wanted nodes out of the config based on short names
works. What didn't work was later post-filtering based on such short
names (kind of duplicate, but that's how the code path is).

By implementing QffHostname, we can have custom equality checks, like
in the Python code. What I don't like is how convoluted the testing on
various left/right combinations is, but I didn't find an easier way.

The included unittest tests the partial filtering behaviour, and fails
if the node name flag is not set to QffHostname.

Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Guido Trotter <ultrotter@google.com>
---
 src/Ganeti/Query/Export.hs         |  2 +-
 src/Ganeti/Query/Filter.hs         | 46 +++++++++++++++++++++++-------
 src/Ganeti/Query/Node.hs           |  2 +-
 src/Ganeti/Query/Types.hs          |  3 +-
 test/hs/Test/Ganeti/Query/Query.hs | 35 ++++++++++++++++++++++-
 5 files changed, 73 insertions(+), 15 deletions(-)

diff --git a/src/Ganeti/Query/Export.hs b/src/Ganeti/Query/Export.hs
index 6a9671b97..086357301 100644
--- a/src/Ganeti/Query/Export.hs
+++ b/src/Ganeti/Query/Export.hs
@@ -58,7 +58,7 @@ rpcExtractor node (Left err)  = [(node, rpcErrToRs err)]
 exportFields :: FieldList Node Runtime
 exportFields =
   [ (FieldDefinition "node" "Node" QFTText "Node name",
-     FieldSimple (rsNormal . nodeName), QffNormal)
+     FieldSimple (rsNormal . nodeName), QffHostname)
   , (FieldDefinition "export" "Export" QFTText "Export name",
      FieldRuntime (curry fst), QffNormal)
   ]
diff --git a/src/Ganeti/Query/Filter.hs b/src/Ganeti/Query/Filter.hs
index b4da1380b..ced50a929 100644
--- a/src/Ganeti/Query/Filter.hs
+++ b/src/Ganeti/Query/Filter.hs
@@ -25,7 +25,7 @@ between the two runs, hence we will not get inconsistent results).
 
 {-
 
-Copyright (C) 2012 Google Inc.
+Copyright (C) 2012, 2013 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
@@ -79,6 +79,7 @@ compileFilter fm =
 -- | Processes a field value given a QffMode.
 qffField :: QffMode -> JSValue -> ErrorResult JSValue
 qffField QffNormal    v = Ok v
+qffField QffHostname  v = Ok v
 qffField QffTimestamp v =
   case v of
     JSArray [secs@(JSRational _ _), JSRational _ _] -> return secs
@@ -92,19 +93,23 @@ wrapGetter :: ConfigData
            -> Maybe b
            -> a
            -> (FieldGetter a b, QffMode)
-           -> (JSValue -> ErrorResult Bool)
+           -> (QffMode -> JSValue -> ErrorResult Bool)
            -> ErrorResult Bool
 wrapGetter cfg b a (getter, qff) faction =
   case tryGetter cfg b a getter of
     Nothing -> Ok True -- runtime missing, accepting the value
     Just v ->
       case v of
-        ResultEntry RSNormal (Just fval) -> qffField qff fval >>= faction
+        ResultEntry RSNormal (Just fval) -> qffField qff fval >>= faction qff
         ResultEntry RSNormal Nothing ->
           Bad $ ProgrammerError
                 "Internal error: Getter returned RSNormal/Nothing"
         _ -> Ok True -- filter has no data to work, accepting it
 
+-- | Wrapper alias over field functions to ignore their first Qff argument.
+ignoreMode :: a -> QffMode -> a
+ignoreMode = const
+
 -- | Helper to evaluate a filter getter (and the value it generates) in
 -- a boolean context.
 trueFilter :: JSValue -> ErrorResult Bool
@@ -118,6 +123,25 @@ trueFilter v = Bad . ParameterError $
 -- and for them to be used in multiple contexts.
 type Comparator = (Eq a, Ord a) => a -> a -> Bool
 
+-- | Equality checker.
+--
+-- This will handle hostnames correctly, if the mode is set to
+-- 'QffHostname'.
+eqFilter :: FilterValue -> QffMode -> JSValue -> ErrorResult Bool
+-- send 'QffNormal' queries to 'binOpFilter'
+eqFilter flv QffNormal    jsv = binOpFilter (==) flv jsv
+-- and 'QffTimestamp' as well
+eqFilter flv QffTimestamp jsv = binOpFilter (==) flv jsv
+-- error out if we set 'QffHostname' on a non-string field
+eqFilter _ QffHostname (JSRational _ _) =
+  Bad . ProgrammerError $ "QffHostname field returned a numeric value"
+-- test strings via 'compareNameComponent'
+eqFilter (QuotedString y) QffHostname (JSString x) =
+  Ok $ goodLookupResult (fromJSString x `compareNameComponent` y)
+-- send all other combinations (all errors) to 'binOpFilter', which
+-- has good error messages
+eqFilter flv _ jsv = binOpFilter (==) flv jsv
+
 -- | Helper to evaluate a filder getter (and the value it generates)
 -- in a boolean context. Note the order of arguments is reversed from
 -- the filter definitions (due to the call chain), make sure to
@@ -178,21 +202,21 @@ evaluateFilter c mb a (OrFilter flts) = helper flts
 evaluateFilter c mb a (NotFilter flt)  =
   not <$> evaluateFilter c mb a flt
 evaluateFilter c mb a (TrueFilter getter)  =
-  wrapGetter c mb a getter trueFilter
+  wrapGetter c mb a getter $ ignoreMode trueFilter
 evaluateFilter c mb a (EQFilter getter val) =
-  wrapGetter c mb a getter (binOpFilter (==) val)
+  wrapGetter c mb a getter (eqFilter val)
 evaluateFilter c mb a (LTFilter getter val) =
-  wrapGetter c mb a getter (binOpFilter (<) val)
+  wrapGetter c mb a getter $ ignoreMode (binOpFilter (<) val)
 evaluateFilter c mb a (LEFilter getter val) =
-  wrapGetter c mb a getter (binOpFilter (<=) val)
+  wrapGetter c mb a getter $ ignoreMode (binOpFilter (<=) val)
 evaluateFilter c mb a (GTFilter getter val) =
-  wrapGetter c mb a getter (binOpFilter (>) val)
+  wrapGetter c mb a getter $ ignoreMode (binOpFilter (>) val)
 evaluateFilter c mb a (GEFilter getter val) =
-  wrapGetter c mb a getter (binOpFilter (>=) val)
+  wrapGetter c mb a getter $ ignoreMode (binOpFilter (>=) val)
 evaluateFilter c mb a (RegexpFilter getter re) =
-  wrapGetter c mb a getter (regexpFilter re)
+  wrapGetter c mb a getter $ ignoreMode (regexpFilter re)
 evaluateFilter c mb a (ContainsFilter getter val) =
-  wrapGetter c mb a getter (containsFilter val)
+  wrapGetter c mb a getter $ ignoreMode (containsFilter val)
 
 -- | Runs a getter with potentially missing runtime context.
 tryGetter :: ConfigData -> Maybe b -> a -> FieldGetter a b -> Maybe ResultEntry
diff --git a/src/Ganeti/Query/Node.hs b/src/Ganeti/Query/Node.hs
index 558305423..e639351ab 100644
--- a/src/Ganeti/Query/Node.hs
+++ b/src/Ganeti/Query/Node.hs
@@ -140,7 +140,7 @@ nodeFields =
        "Whether node can become a master candidate",
      FieldSimple (rsNormal . nodeMasterCapable), QffNormal)
   , (FieldDefinition "name" "Node" QFTText "Node name",
-     FieldSimple (rsNormal . nodeName), QffNormal)
+     FieldSimple (rsNormal . nodeName), QffHostname)
   , (FieldDefinition "offline" "Offline" QFTBool
        "Whether node is marked offline",
      FieldSimple (rsNormal . nodeOffline), QffNormal)
diff --git a/src/Ganeti/Query/Types.hs b/src/Ganeti/Query/Types.hs
index c9cbbbcdd..4c74dbaa2 100644
--- a/src/Ganeti/Query/Types.hs
+++ b/src/Ganeti/Query/Types.hs
@@ -7,7 +7,7 @@ use the library should not need to import it.
 
 {-
 
-Copyright (C) 2012 Google Inc.
+Copyright (C) 2012, 2013 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
@@ -56,6 +56,7 @@ data FieldGetter a b = FieldSimple  (a -> ResultEntry)
 -- don't use OR-able values.
 data QffMode = QffNormal     -- ^ Value is used as-is in filters
              | QffTimestamp  -- ^ Value is a timestamp tuple, convert to float
+             | QffHostname   -- ^ Value is a hostname, compare it smartly
                deriving (Show, Eq)
 
 
diff --git a/test/hs/Test/Ganeti/Query/Query.hs b/test/hs/Test/Ganeti/Query/Query.hs
index db5ae8853..43efbe2f7 100644
--- a/test/hs/Test/Ganeti/Query/Query.hs
+++ b/test/hs/Test/Ganeti/Query/Query.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell, BangPatterns #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 {-| Unittests for ganeti-htools.
@@ -36,6 +36,7 @@ import Data.Function (on)
 import Data.List
 import qualified Data.Map as Map
 import Data.Maybe
+import qualified Data.Set as Set
 import Text.JSON (JSValue(..), showJSON)
 
 import Test.Ganeti.TestHelper
@@ -44,12 +45,15 @@ import Test.Ganeti.Objects (genEmptyCluster)
 
 import Ganeti.BasicTypes
 import Ganeti.Errors
+import Ganeti.JSON
+import Ganeti.Objects
 import Ganeti.Query.Filter
 import qualified Ganeti.Query.Group as Group
 import Ganeti.Query.Language
 import qualified Ganeti.Query.Node as Node
 import Ganeti.Query.Query
 import qualified Ganeti.Query.Job as Job
+import Ganeti.Utils (sepSplit)
 
 {-# ANN module "HLint: ignore Use camelCase" #-}
 
@@ -163,6 +167,34 @@ case_queryNode_allfields = do
     (sortBy field_sort . map (\(f, _, _) -> f) $ Map.elems Node.fieldsMap)
     (sortBy field_sort fdefs)
 
+-- | Check if cluster node names are unique (first elems).
+areNodeNamesSane :: ConfigData -> Bool
+areNodeNamesSane cfg =
+  let fqdns = map nodeName . Map.elems . fromContainer $ configNodes cfg
+      names = map (head . sepSplit '.') fqdns
+  in length names == length (nub names)
+
+-- | Check that the nodes reported by a name filter are sane.
+prop_queryNode_filter :: Property
+prop_queryNode_filter =
+  forAll (choose (1, maxNodes)) $ \nodes ->
+  forAll (genEmptyCluster nodes `suchThat`
+          areNodeNamesSane) $ \cluster -> monadicIO $ do
+    let node_list = map nodeName . Map.elems . fromContainer $
+                    configNodes cluster
+    count <- pick $ choose (1, nodes)
+    fqdn_set <- pick . genSetHelper node_list $ Just count
+    let fqdns = Set.elems fqdn_set
+        names = map (head . sepSplit '.') fqdns
+        flt = makeSimpleFilter "name" $ map Left names
+    QueryResult _ fdata <-
+      run (query cluster False (Query (ItemTypeOpCode QRNode)
+                                ["name"] flt)) >>= resultProp
+    stop $ conjoin
+      [ printTestCase "Invalid node names" $
+        map (map rentryValue) fdata ==? map (\f -> [Just (showJSON f)]) fqdns
+      ]
+
 -- ** Group queries
 
 prop_queryGroup_noUnknown :: Property
@@ -328,6 +360,7 @@ testSuite "Query/Query"
   [ 'prop_queryNode_noUnknown
   , 'prop_queryNode_Unknown
   , 'prop_queryNode_types
+  , 'prop_queryNode_filter
   , 'case_queryNode_allfields
   , 'prop_queryGroup_noUnknown
   , 'prop_queryGroup_Unknown
-- 
GitLab