root / htools / Ganeti / Query / Query.hs @ bc4cdeef
History | View | Annotate | Download (7.5 kB)
1 |
{-| Implementation of the Ganeti Query2 functionality. |
---|---|
2 |
|
3 |
-} |
4 |
|
5 |
{- |
6 |
|
7 |
Copyright (C) 2012 Google Inc. |
8 |
|
9 |
This program is free software; you can redistribute it and/or modify |
10 |
it under the terms of the GNU General Public License as published by |
11 |
the Free Software Foundation; either version 2 of the License, or |
12 |
(at your option) any later version. |
13 |
|
14 |
This program is distributed in the hope that it will be useful, but |
15 |
WITHOUT ANY WARRANTY; without even the implied warranty of |
16 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
17 |
General Public License for more details. |
18 |
|
19 |
You should have received a copy of the GNU General Public License |
20 |
along with this program; if not, write to the Free Software |
21 |
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
22 |
02110-1301, USA. |
23 |
|
24 |
-} |
25 |
|
26 |
{- |
27 |
|
28 |
TODO: problems with the current model: |
29 |
|
30 |
1. There's nothing preventing a result such as ResultEntry RSNormal |
31 |
Nothing, or ResultEntry RSNoData (Just ...); ideally, we would |
32 |
separate the the RSNormal and other types; we would need a new data |
33 |
type for this, though, with JSON encoding/decoding |
34 |
|
35 |
2. We don't have a way to 'bind' a FieldDefinition's field type |
36 |
(e.q. QFTBool) with the actual value that is returned from a |
37 |
FieldGetter. This means that the various getter functions can return |
38 |
divergent types for the same field when evaluated against multiple |
39 |
items. This is bad; it only works today because we 'hide' everything |
40 |
behind JSValue, but is not nice at all. We should probably remove the |
41 |
separation between FieldDefinition and the FieldGetter, and introduce |
42 |
a new abstract data type, similar to QFT*, that contains the values |
43 |
too. |
44 |
|
45 |
-} |
46 |
|
47 |
module Ganeti.Query.Query |
48 |
|
49 |
( query |
50 |
, queryFields |
51 |
, getRequestedNames |
52 |
) where |
53 |
|
54 |
import Control.Monad (filterM) |
55 |
import Control.Monad.Trans (lift) |
56 |
import Data.Maybe (fromMaybe) |
57 |
import qualified Data.Map as Map |
58 |
|
59 |
import Ganeti.BasicTypes |
60 |
import Ganeti.Config |
61 |
import Ganeti.JSON |
62 |
import Ganeti.Rpc |
63 |
import Ganeti.Query.Language |
64 |
import Ganeti.Query.Common |
65 |
import Ganeti.Query.Filter |
66 |
import Ganeti.Query.Types |
67 |
import Ganeti.Query.Node |
68 |
import Ganeti.Query.Group |
69 |
import Ganeti.Objects |
70 |
|
71 |
-- * Helper functions |
72 |
|
73 |
-- | Builds an unknown field definition. |
74 |
mkUnknownFDef :: String -> FieldData a b |
75 |
mkUnknownFDef name = |
76 |
( FieldDefinition name name QFTUnknown ("Unknown field '" ++ name ++ "'") |
77 |
, FieldUnknown ) |
78 |
|
79 |
-- | Runs a field getter on the existing contexts. |
80 |
execGetter :: ConfigData -> b -> a -> FieldGetter a b -> ResultEntry |
81 |
execGetter _ _ item (FieldSimple getter) = getter item |
82 |
execGetter cfg _ item (FieldConfig getter) = getter cfg item |
83 |
execGetter _ rt item (FieldRuntime getter) = getter rt item |
84 |
execGetter _ _ _ FieldUnknown = rsUnknown |
85 |
|
86 |
-- * Main query execution |
87 |
|
88 |
-- | Helper to build the list of requested fields. This transforms the |
89 |
-- list of string fields to a list of field defs and getters, with |
90 |
-- some of them possibly being unknown fields. |
91 |
getSelectedFields :: FieldMap a b -- ^ Defined fields |
92 |
-> [String] -- ^ Requested fields |
93 |
-> FieldList a b -- ^ Selected fields |
94 |
getSelectedFields defined = |
95 |
map (\name -> fromMaybe (mkUnknownFDef name) $ name `Map.lookup` defined) |
96 |
|
97 |
-- | Collect live data from RPC query if enabled. |
98 |
-- FIXME: Check which fields we actually need and possibly send empty |
99 |
-- hvs/vgs if no info from hypervisor/volume group respectively |
100 |
-- is required |
101 |
maybeCollectLiveData:: Bool -> ConfigData -> [Node] -> IO [(Node, NodeRuntime)] |
102 |
|
103 |
maybeCollectLiveData False _ nodes = |
104 |
return $ zip nodes (repeat $ Left (RpcResultError "Live data disabled")) |
105 |
|
106 |
maybeCollectLiveData True cfg nodes = do |
107 |
let vgs = [clusterVolumeGroupName $ configCluster cfg] |
108 |
hvs = [getDefaultHypervisor cfg] |
109 |
executeRpcCall nodes (RpcCallNodeInfo vgs hvs) |
110 |
|
111 |
-- | Check whether list of queried fields contains live fields. |
112 |
needsLiveData :: [FieldGetter a b] -> Bool |
113 |
needsLiveData = any (\getter -> case getter of |
114 |
FieldRuntime _ -> True |
115 |
_ -> False) |
116 |
|
117 |
-- | Checks whether we have requested exactly some names. This is a |
118 |
-- simple wrapper over 'requestedNames' and 'nameField'. |
119 |
needsNames :: Query -> Maybe [FilterValue] |
120 |
needsNames (Query kind _ qfilter) = requestedNames (nameField kind) qfilter |
121 |
|
122 |
-- | Computes the name field for different query types. |
123 |
nameField :: ItemType -> FilterField |
124 |
nameField QRJob = "id" |
125 |
nameField _ = "name" |
126 |
|
127 |
-- | Extracts all quoted strings from a list, ignoring the |
128 |
-- 'NumericValue' entries. |
129 |
getAllQuotedStrings :: [FilterValue] -> [String] |
130 |
getAllQuotedStrings = |
131 |
concatMap extractor |
132 |
where extractor (NumericValue _) = [] |
133 |
extractor (QuotedString val) = [val] |
134 |
|
135 |
-- | Checks that we have either requested a valid set of names, or we |
136 |
-- have a more complex filter. |
137 |
getRequestedNames :: Query -> [String] |
138 |
getRequestedNames qry = |
139 |
case needsNames qry of |
140 |
Just names -> getAllQuotedStrings names |
141 |
Nothing -> [] |
142 |
|
143 |
-- | Main query execution function. |
144 |
query :: ConfigData -- ^ The current configuration |
145 |
-> Bool -- ^ Whether to collect live data |
146 |
-> Query -- ^ The query (item, fields, filter) |
147 |
-> IO (Result QueryResult) -- ^ Result |
148 |
|
149 |
query cfg live (Query QRNode fields qfilter) = runResultT $ do |
150 |
cfilter <- resultT $ compileFilter nodeFieldsMap qfilter |
151 |
let selected = getSelectedFields nodeFieldsMap fields |
152 |
(fdefs, fgetters) = unzip selected |
153 |
nodes = Map.elems . fromContainer $ configNodes cfg |
154 |
live' = live && needsLiveData fgetters |
155 |
-- runs first pass of the filter, without a runtime context; this |
156 |
-- will limit the nodes that we'll contact for runtime data |
157 |
fnodes <- resultT $ filterM (\n -> evaluateFilter cfg Nothing n cfilter) nodes |
158 |
-- here we would run the runtime data gathering, then filter again |
159 |
-- the nodes, based on existing runtime data |
160 |
nruntimes <- lift $ maybeCollectLiveData live' cfg fnodes |
161 |
let fdata = map (\(node, nrt) -> map (execGetter cfg nrt node) fgetters) |
162 |
nruntimes |
163 |
return QueryResult { qresFields = fdefs, qresData = fdata } |
164 |
|
165 |
query cfg _ (Query QRGroup fields qfilter) = return $ do |
166 |
-- FIXME: want_diskparams is defaulted to false and not taken as parameter |
167 |
-- This is because the type for DiskParams is right now too generic for merges |
168 |
-- (or else I cannot see how to do this with curent implementation) |
169 |
cfilter <- compileFilter groupFieldsMap qfilter |
170 |
let selected = getSelectedFields groupFieldsMap fields |
171 |
(fdefs, fgetters) = unzip selected |
172 |
groups = Map.elems . fromContainer $ configNodegroups cfg |
173 |
-- there is no live data for groups, so filtering is much simpler |
174 |
fgroups <- filterM (\n -> evaluateFilter cfg Nothing n cfilter) groups |
175 |
let fdata = map (\node -> |
176 |
map (execGetter cfg GroupRuntime node) fgetters) fgroups |
177 |
return QueryResult {qresFields = fdefs, qresData = fdata } |
178 |
|
179 |
query _ _ (Query qkind _ _) = |
180 |
return . Bad $ "Query '" ++ show qkind ++ "' not supported" |
181 |
|
182 |
-- | Query fields call. |
183 |
-- FIXME: Looks generic enough to use a typeclass |
184 |
queryFields :: QueryFields -> Result QueryFieldsResult |
185 |
queryFields (QueryFields QRNode fields) = |
186 |
let selected = if null fields |
187 |
then map snd $ Map.toAscList nodeFieldsMap |
188 |
else getSelectedFields nodeFieldsMap fields |
189 |
in Ok $ QueryFieldsResult (map fst selected) |
190 |
|
191 |
queryFields (QueryFields QRGroup fields) = |
192 |
let selected = if null fields |
193 |
then map snd $ Map.toAscList groupFieldsMap |
194 |
else getSelectedFields groupFieldsMap fields |
195 |
in Ok $ QueryFieldsResult (map fst selected) |
196 |
|
197 |
|
198 |
queryFields (QueryFields qkind _) = |
199 |
Bad $ "QueryFields '" ++ show qkind ++ "' not supported" |