Revision 5183e8be htools/Ganeti/Query/Filter.hs
b/htools/Ganeti/Query/Filter.hs | ||
---|---|---|
60 | 60 |
import qualified Text.Regex.PCRE as PCRE |
61 | 61 |
|
62 | 62 |
import Ganeti.BasicTypes |
63 |
import Ganeti.Errors |
|
63 | 64 |
import Ganeti.Objects |
64 | 65 |
import Ganeti.Query.Language |
65 | 66 |
import Ganeti.Query.Types |
... | ... | |
68 | 69 |
-- | Compiles a filter based on field names to one based on getters. |
69 | 70 |
compileFilter :: FieldMap a b |
70 | 71 |
-> Filter FilterField |
71 |
-> Result (Filter (FieldGetter a b)) |
|
72 |
-> ErrorResult (Filter (FieldGetter a b))
|
|
72 | 73 |
compileFilter fm = |
73 |
traverse (\field -> maybe (Bad $ "Can't find field named '" ++ field ++ "'") |
|
74 |
traverse (\field -> maybe |
|
75 |
(Bad . ParameterError $ "Can't find field named '" ++ |
|
76 |
field ++ "'") |
|
74 | 77 |
(Ok . snd) (field `Map.lookup` fm)) |
75 | 78 |
|
76 | 79 |
-- | Wraps a getter, filter pair. If the getter is 'FieldRuntime' but |
... | ... | |
80 | 83 |
-> Maybe b |
81 | 84 |
-> a |
82 | 85 |
-> FieldGetter a b |
83 |
-> (JSValue -> Result Bool) |
|
84 |
-> Result Bool |
|
86 |
-> (JSValue -> ErrorResult Bool)
|
|
87 |
-> ErrorResult Bool
|
|
85 | 88 |
wrapGetter cfg b a getter faction = |
86 | 89 |
case tryGetter cfg b a getter of |
87 | 90 |
Nothing -> Ok True -- runtime missing, accepting the value |
... | ... | |
89 | 92 |
case v of |
90 | 93 |
ResultEntry RSNormal (Just fval) -> faction fval |
91 | 94 |
ResultEntry RSNormal Nothing -> |
92 |
Bad "Internal error: Getter returned RSNormal/Nothing" |
|
95 |
Bad $ ProgrammerError |
|
96 |
"Internal error: Getter returned RSNormal/Nothing" |
|
93 | 97 |
_ -> Ok True -- filter has no data to work, accepting it |
94 | 98 |
|
95 | 99 |
-- | Helper to evaluate a filter getter (and the value it generates) in |
96 | 100 |
-- a boolean context. |
97 |
trueFilter :: JSValue -> Result Bool |
|
101 |
trueFilter :: JSValue -> ErrorResult Bool
|
|
98 | 102 |
trueFilter (JSBool x) = Ok x |
99 |
trueFilter v = Bad $ "Unexpected value '" ++ show (pp_value v) ++ |
|
103 |
trueFilter v = Bad . ParameterError $ |
|
104 |
"Unexpected value '" ++ show (pp_value v) ++ |
|
100 | 105 |
"' in boolean context" |
101 | 106 |
|
102 | 107 |
-- | A type synonim for a rank-2 comparator function. This is used so |
... | ... | |
108 | 113 |
-- in a boolean context. Note the order of arguments is reversed from |
109 | 114 |
-- the filter definitions (due to the call chain), make sure to |
110 | 115 |
-- compare in the reverse order too!. |
111 |
binOpFilter :: Comparator -> FilterValue -> JSValue -> Result Bool |
|
116 |
binOpFilter :: Comparator -> FilterValue -> JSValue -> ErrorResult Bool
|
|
112 | 117 |
binOpFilter comp (QuotedString y) (JSString x) = |
113 | 118 |
Ok $ fromJSString x `comp` y |
114 | 119 |
binOpFilter comp (NumericValue y) (JSRational _ x) = |
115 | 120 |
Ok $ x `comp` fromIntegral y |
116 | 121 |
binOpFilter _ expr actual = |
117 |
Bad $ "Invalid types in comparison, trying to compare " ++ |
|
122 |
Bad . ParameterError $ "Invalid types in comparison, trying to compare " ++
|
|
118 | 123 |
show (pp_value actual) ++ " with '" ++ show expr ++ "'" |
119 | 124 |
|
120 | 125 |
-- | Implements the 'RegexpFilter' matching. |
121 |
regexpFilter :: FilterRegex -> JSValue -> Result Bool |
|
126 |
regexpFilter :: FilterRegex -> JSValue -> ErrorResult Bool
|
|
122 | 127 |
regexpFilter re (JSString val) = |
123 | 128 |
Ok $ PCRE.match (compiledRegex re) (fromJSString val) |
124 | 129 |
regexpFilter _ x = |
125 |
Bad $ "Invalid field value used in regexp matching,\ |
|
130 |
Bad . ParameterError $ "Invalid field value used in regexp matching,\
|
|
126 | 131 |
\ expecting string but got '" ++ show (pp_value x) ++ "'" |
127 | 132 |
|
128 | 133 |
-- | Implements the 'ContainsFilter' matching. |
129 |
containsFilter :: FilterValue -> JSValue -> Result Bool |
|
134 |
containsFilter :: FilterValue -> JSValue -> ErrorResult Bool
|
|
130 | 135 |
-- note: the next two implementations are the same, but we have to |
131 | 136 |
-- repeat them due to the encapsulation done by FilterValue |
132 | 137 |
containsFilter (QuotedString val) lst = do |
... | ... | |
141 | 146 |
-- this as passing the filter. |
142 | 147 |
evaluateFilter :: ConfigData -> Maybe b -> a |
143 | 148 |
-> Filter (FieldGetter a b) |
144 |
-> Result Bool |
|
149 |
-> ErrorResult Bool
|
|
145 | 150 |
evaluateFilter _ _ _ EmptyFilter = Ok True |
146 | 151 |
evaluateFilter c mb a (AndFilter flts) = |
147 | 152 |
all id <$> mapM (evaluateFilter c mb a) flts |
Also available in: Unified diff