Commit 91c1a265 authored by Iustin Pop's avatar Iustin Pop
Browse files

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: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarGuido Trotter <ultrotter@google.com>
parent e7124835
......@@ -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)
]
......
......@@ -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
......
......@@ -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)
......
......@@ -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)
......
{-# 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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment