Store keys as ByteStrings
[ganeti-github.git] / src / Ganeti / Query / Query.hs
1 {-# LANGUAGE TupleSections #-}
2
3 {-| Implementation of the Ganeti Query2 functionality.
4
5 -}
6
7 {-
8
9 Copyright (C) 2012, 2013 Google Inc.
10 All rights reserved.
11
12 Redistribution and use in source and binary forms, with or without
13 modification, are permitted provided that the following conditions are
14 met:
15
16 1. Redistributions of source code must retain the above copyright notice,
17 this list of conditions and the following disclaimer.
18
19 2. Redistributions in binary form must reproduce the above copyright
20 notice, this list of conditions and the following disclaimer in the
21 documentation and/or other materials provided with the distribution.
22
23 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
24 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
25 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
26 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
27 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
28 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
29 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
30 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
31 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
32 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
33 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
34
35 -}
36
37 {-
38
39 TODO: problems with the current model:
40
41 1. There's nothing preventing a result such as ResultEntry RSNormal
42 Nothing, or ResultEntry RSNoData (Just ...); ideally, we would
43 separate the the RSNormal and other types; we would need a new data
44 type for this, though, with JSON encoding/decoding
45
46 2. We don't have a way to 'bind' a FieldDefinition's field type
47 (e.q. QFTBool) with the actual value that is returned from a
48 FieldGetter. This means that the various getter functions can return
49 divergent types for the same field when evaluated against multiple
50 items. This is bad; it only works today because we 'hide' everything
51 behind JSValue, but is not nice at all. We should probably remove the
52 separation between FieldDefinition and the FieldGetter, and introduce
53 a new abstract data type, similar to QFT*, that contains the values
54 too.
55
56 -}
57
58 module Ganeti.Query.Query
59 ( query
60 , queryFields
61 , queryCompat
62 , getRequestedNames
63 , nameField
64 , NoDataRuntime
65 , uuidField
66 ) where
67
68 import Control.Arrow ((&&&))
69 import Control.DeepSeq
70 import Control.Monad (filterM, foldM, liftM, unless)
71 import Control.Monad.IO.Class
72 import Control.Monad.Trans (lift)
73 import qualified Data.ByteString.UTF8 as UTF8
74 import qualified Data.Foldable as Foldable
75 import Data.List (intercalate, nub, find)
76 import Data.Maybe (fromMaybe)
77 import qualified Data.Map as Map
78 import qualified Data.Set as Set
79 import qualified Text.JSON as J
80
81 import Ganeti.BasicTypes
82 import Ganeti.Config
83 import Ganeti.Errors
84 import Ganeti.JQueue
85 import Ganeti.JSON
86 import Ganeti.Locking.Allocation (OwnerState, LockRequest(..), OwnerState(..))
87 import Ganeti.Locking.Locks (GanetiLocks, ClientId, lockName)
88 import Ganeti.Logging
89 import Ganeti.Objects
90 import Ganeti.Query.Common
91 import qualified Ganeti.Query.Export as Export
92 import qualified Ganeti.Query.FilterRules as FilterRules
93 import Ganeti.Query.Filter
94 import qualified Ganeti.Query.Instance as Instance
95 import qualified Ganeti.Query.Job as Query.Job
96 import qualified Ganeti.Query.Group as Group
97 import Ganeti.Query.Language
98 import qualified Ganeti.Query.Locks as Locks
99 import qualified Ganeti.Query.Network as Network
100 import qualified Ganeti.Query.Node as Node
101 import Ganeti.Query.Types
102 import Ganeti.Path
103 import Ganeti.THH.HsRPC (runRpcClient)
104 import Ganeti.Types
105 import Ganeti.Utils
106 import Ganeti.WConfd.Client (getWConfdClient, listLocksWaitingStatus)
107
108 -- | Collector type
109 data CollectorType a b
110 = CollectorSimple (Bool -> ConfigData -> [a] -> IO [(a, b)])
111 | CollectorFieldAware (Bool -> ConfigData -> [String] -> [a] -> IO [(a, b)])
112
113 -- * Helper functions
114
115 -- | Builds an unknown field definition.
116 mkUnknownFDef :: String -> FieldData a b
117 mkUnknownFDef name =
118 ( FieldDefinition name name QFTUnknown ("Unknown field '" ++ name ++ "'")
119 , FieldUnknown
120 , QffNormal )
121
122 -- | Runs a field getter on the existing contexts.
123 execGetter :: ConfigData -> b -> a -> FieldGetter a b -> ResultEntry
124 execGetter _ _ item (FieldSimple getter) = getter item
125 execGetter cfg _ item (FieldConfig getter) = getter cfg item
126 execGetter _ rt item (FieldRuntime getter) = getter rt item
127 execGetter cfg rt item (FieldConfigRuntime getter) = getter cfg rt item
128 execGetter _ _ _ FieldUnknown = rsUnknown
129
130 -- * Main query execution
131
132 -- | Helper to build the list of requested fields. This transforms the
133 -- list of string fields to a list of field defs and getters, with
134 -- some of them possibly being unknown fields.
135 getSelectedFields :: FieldMap a b -- ^ Defined fields
136 -> [String] -- ^ Requested fields
137 -> FieldList a b -- ^ Selected fields
138 getSelectedFields defined =
139 map (\name -> fromMaybe (mkUnknownFDef name) $ name `Map.lookup` defined)
140
141 -- | Check whether list of queried fields contains live fields.
142 needsLiveData :: [FieldGetter a b] -> Bool
143 needsLiveData = any isRuntimeField
144
145 -- | Checks whether we have requested exactly some names. This is a
146 -- simple wrapper over 'requestedNames' and 'nameField'.
147 needsNames :: Query -> Maybe [FilterValue]
148 needsNames (Query kind _ qfilter) = requestedNames (nameField kind) qfilter
149
150 -- | Computes the name field for different query types.
151 nameField :: ItemType -> FilterField
152 nameField (ItemTypeLuxi QRJob) = "id"
153 nameField (ItemTypeOpCode QRExport) = "node"
154 nameField _ = "name"
155
156 -- | Computes the uuid field, or the best possible substitute, for different
157 -- query types.
158 uuidField :: ItemType -> FilterField
159 uuidField (ItemTypeLuxi QRJob) = nameField (ItemTypeLuxi QRJob)
160 uuidField (ItemTypeOpCode QRExport) = nameField (ItemTypeOpCode QRExport)
161 uuidField _ = "uuid"
162
163 -- | Extracts all quoted strings from a list, ignoring the
164 -- 'NumericValue' entries.
165 getAllQuotedStrings :: [FilterValue] -> [String]
166 getAllQuotedStrings =
167 concatMap extractor
168 where extractor (NumericValue _) = []
169 extractor (QuotedString val) = [val]
170
171 -- | Checks that we have either requested a valid set of names, or we
172 -- have a more complex filter.
173 getRequestedNames :: Query -> [String]
174 getRequestedNames qry =
175 case needsNames qry of
176 Just names -> getAllQuotedStrings names
177 Nothing -> []
178
179 -- | Compute the requested job IDs. This is custom since we need to
180 -- handle both strings and integers.
181 getRequestedJobIDs :: Filter FilterField -> Result [JobId]
182 getRequestedJobIDs qfilter =
183 case requestedNames (nameField (ItemTypeLuxi QRJob)) qfilter of
184 Nothing -> Ok []
185 Just [] -> Ok []
186 Just vals ->
187 liftM nub $
188 mapM (\e -> case e of
189 QuotedString s -> makeJobIdS s
190 NumericValue i -> makeJobId $ fromIntegral i
191 ) vals
192
193 -- | Generic query implementation for resources that are backed by
194 -- some configuration objects.
195 --
196 -- Different query types use the same 'genericQuery' function by providing
197 -- a collector function and a field map. The collector function retrieves
198 -- live data, and the field map provides both the requirements and the logic
199 -- necessary to retrieve the data needed for the field.
200 --
201 -- The 'b' type in the specification is the runtime. Every query can gather
202 -- additional live data related to the configuration object using the collector
203 -- to perform RPC calls.
204 --
205 -- The gathered data, or the failure to get it, is expressed through a runtime
206 -- object. The type of a runtime object is determined by every query type for
207 -- itself, and used exclusively by that query.
208 genericQuery :: FieldMap a b -- ^ Maps field names to field definitions
209 -> CollectorType a b -- ^ Collector of live data
210 -> (a -> String) -- ^ Object to name function
211 -> (ConfigData -> Container a) -- ^ Get all objects from config
212 -> (ConfigData -> String -> ErrorResult a) -- ^ Lookup object
213 -> ConfigData -- ^ The config to run the query against
214 -> Bool -- ^ Whether the query should be run live
215 -> [String] -- ^ List of requested fields
216 -> Filter FilterField -- ^ Filter field
217 -> [String] -- ^ List of requested names
218 -> IO (ErrorResult QueryResult)
219 genericQuery fieldsMap collector nameFn configFn getFn cfg
220 live fields qfilter wanted =
221 runResultT $ do
222 cfilter <- toError $ compileFilter fieldsMap qfilter
223 let allfields = (++) fields . filter (not . (`elem` fields))
224 . ordNub $ filterArguments qfilter
225 count = length fields
226 selected = getSelectedFields fieldsMap allfields
227 (fdefs, fgetters, _) = unzip3 selected
228 live' = live && needsLiveData fgetters
229 objects <- toError $ case wanted of
230 [] -> Ok . niceSortKey nameFn .
231 Foldable.toList $ configFn cfg
232 _ -> mapM (getFn cfg) wanted
233 -- Run the first pass of the filter, without a runtime context; this will
234 -- limit the objects that we'll contact for exports
235 fobjects <- toError $
236 filterM (\n -> evaluateQueryFilter cfg Nothing n cfilter) objects
237 -- Gather the runtime data and filter the results again,
238 -- based on the gathered data
239 runtimes <- (case collector of
240 CollectorSimple collFn -> lift $ collFn live' cfg fobjects
241 CollectorFieldAware collFn -> lift $ collFn live' cfg allfields fobjects)
242 >>= (toError . filterM (\(obj, runtime) ->
243 evaluateQueryFilter cfg (Just runtime) obj cfilter))
244 let fdata = map (\(obj, runtime) ->
245 map (execGetter cfg runtime obj) fgetters)
246 runtimes
247 return QueryResult { qresFields = take count fdefs
248 , qresData = map (take count) fdata }
249
250 -- | Dummy recollection of the data for a lock from the prefected
251 -- data for all locks.
252 recollectLocksData :: ( [(GanetiLocks, [(ClientId, OwnerState)])]
253 , [(Integer, ClientId, [LockRequest GanetiLocks])]
254 )
255 -> Bool -> ConfigData -> [String]
256 -> IO [(String, Locks.RuntimeData)]
257 recollectLocksData (allLocks, pending) _ _ =
258 let getPending lock = pending >>= \(_, cid, req) ->
259 let req' = filter ((==) lock . lockName . lockAffected) req
260 in case () of
261 _ | any ((==) (Just OwnExclusive) . lockRequestType) req'
262 -> [(cid, OwnExclusive)]
263 _ | any ((==) (Just OwnShared) . lockRequestType) req'
264 -> [(cid, OwnShared)]
265 _ -> []
266 lookuplock lock = (,) lock
267 . maybe ([], getPending lock)
268 (\(_, c) -> (c, getPending lock))
269 . find ((==) lock . lockName . fst)
270 $ allLocks
271 in return . map lookuplock
272
273 -- | Main query execution function.
274 query :: ConfigData -- ^ The current configuration
275 -> Bool -- ^ Whether to collect live data
276 -> Query -- ^ The query (item, fields, filter)
277 -> IO (ErrorResult QueryResult) -- ^ Result
278 query cfg live (Query (ItemTypeLuxi QRJob) fields qfilter) =
279 queryJobs cfg live fields qfilter
280 query cfg live (Query (ItemTypeLuxi QRLock) fields qfilter) = runResultT $ do
281 unless live (failError "Locks can only be queried live")
282 cl <- liftIO $ do
283 socketpath <- defaultWConfdSocket
284 getWConfdClient socketpath
285 livedata <- runRpcClient listLocksWaitingStatus cl
286 logDebug $ "Live state of all locks is " ++ show livedata
287 let allLocks = Set.toList . Set.unions
288 $ (Set.fromList . map fst $ fst livedata)
289 : map (\(_, _, req) -> Set.fromList $ map lockAffected req)
290 (snd livedata)
291 answer <- liftIO $ genericQuery
292 Locks.fieldsMap
293 (CollectorSimple $ recollectLocksData livedata)
294 id
295 (const . GenericContainer . Map.fromList
296 . map ((UTF8.fromString &&& id) . lockName) $ allLocks)
297 (const Ok)
298 cfg live fields qfilter []
299 toError answer
300
301 query cfg live qry = queryInner cfg live qry $ getRequestedNames qry
302
303
304 -- | Dummy data collection fuction
305 dummyCollectLiveData :: Bool -> ConfigData -> [a] -> IO [(a, NoDataRuntime)]
306 dummyCollectLiveData _ _ = return . map (, NoDataRuntime)
307
308 -- | Inner query execution function.
309 queryInner :: ConfigData -- ^ The current configuration
310 -> Bool -- ^ Whether to collect live data
311 -> Query -- ^ The query (item, fields, filter)
312 -> [String] -- ^ Requested names
313 -> IO (ErrorResult QueryResult) -- ^ Result
314
315 queryInner cfg live (Query (ItemTypeOpCode QRNode) fields qfilter) wanted =
316 genericQuery Node.fieldsMap (CollectorFieldAware Node.collectLiveData)
317 nodeName configNodes getNode cfg live fields qfilter wanted
318
319 queryInner cfg live (Query (ItemTypeOpCode QRInstance) fields qfilter) wanted =
320 genericQuery Instance.fieldsMap (CollectorFieldAware Instance.collectLiveData)
321 (fromMaybe "" . instName) configInstances getInstance cfg live
322 fields qfilter
323 wanted
324
325 queryInner cfg live (Query (ItemTypeOpCode QRGroup) fields qfilter) wanted =
326 genericQuery Group.fieldsMap (CollectorSimple dummyCollectLiveData) groupName
327 configNodegroups getGroup cfg live fields qfilter wanted
328
329 queryInner cfg live (Query (ItemTypeOpCode QRNetwork) fields qfilter) wanted =
330 genericQuery Network.fieldsMap (CollectorSimple dummyCollectLiveData)
331 (fromNonEmpty . networkName)
332 configNetworks getNetwork cfg live fields qfilter wanted
333
334 queryInner cfg live (Query (ItemTypeOpCode QRExport) fields qfilter) wanted =
335 genericQuery Export.fieldsMap (CollectorSimple Export.collectLiveData)
336 nodeName configNodes getNode cfg live fields qfilter wanted
337
338 queryInner cfg live (Query (ItemTypeLuxi QRFilter) fields qfilter) wanted =
339 genericQuery FilterRules.fieldsMap (CollectorSimple dummyCollectLiveData)
340 uuidOf configFilters getFilterRule cfg live fields qfilter wanted
341
342 queryInner _ _ (Query qkind _ _) _ =
343 return . Bad . GenericError $ "Query '" ++ show qkind ++ "' not supported"
344
345 -- | Query jobs specific query function, needed as we need to accept
346 -- both 'QuotedString' and 'NumericValue' as wanted names.
347 queryJobs :: ConfigData -- ^ The current configuration
348 -> Bool -- ^ Whether to collect live data
349 -> [FilterField] -- ^ Item
350 -> Filter FilterField -- ^ Filter
351 -> IO (ErrorResult QueryResult) -- ^ Result
352 queryJobs cfg live fields qfilter = runResultT $ do
353 rootdir <- lift queueDir
354 wanted_names <- toErrorStr $ getRequestedJobIDs qfilter
355 rjids <- case wanted_names of
356 [] | live -> do -- we can check the filesystem for actual jobs
357 let want_arch = Query.Job.wantArchived fields
358 jobIDs <-
359 withErrorT (BlockDeviceError .
360 (++) "Unable to fetch the job list: " . show) $
361 liftIO (determineJobDirectories rootdir want_arch)
362 >>= ResultT . getJobIDs
363 return $ sortJobIDs jobIDs
364 -- else we shouldn't look at the filesystem...
365 v -> return v
366 cfilter <- toError $ compileFilter Query.Job.fieldsMap qfilter
367 let selected = getSelectedFields Query.Job.fieldsMap fields
368 (fdefs, fgetters, _) = unzip3 selected
369 (_, filtergetters, _) = unzip3 . getSelectedFields Query.Job.fieldsMap
370 $ Foldable.toList qfilter
371 live' = live && needsLiveData (fgetters ++ filtergetters)
372 disabled_data = Bad "live data disabled"
373 -- runs first pass of the filter, without a runtime context; this
374 -- will limit the jobs that we'll load from disk
375 jids <- toError $
376 filterM (\jid -> evaluateQueryFilter cfg Nothing jid cfilter) rjids
377 -- here we run the runtime data gathering, filtering and evaluation,
378 -- all in the same step, so that we don't keep jobs in memory longer
379 -- than we need; we can't be fully lazy due to the multiple monad
380 -- wrapping across different steps
381 qdir <- lift queueDir
382 fdata <- foldM
383 -- big lambda, but we use many variables from outside it...
384 (\lst jid -> do
385 job <- lift $ if live'
386 then loadJobFromDisk qdir True jid
387 else return disabled_data
388 pass <- toError $ evaluateQueryFilter cfg (Just job) jid cfilter
389 let nlst = if pass
390 then let row = map (execGetter cfg job jid) fgetters
391 in rnf row `seq` row:lst
392 else lst
393 -- evaluate nlst (to WHNF), otherwise we're too lazy
394 return $! nlst
395 ) [] jids
396 return QueryResult { qresFields = fdefs, qresData = reverse fdata }
397
398 -- | Helper for 'queryFields'.
399 fieldsExtractor :: FieldMap a b -> [FilterField] -> QueryFieldsResult
400 fieldsExtractor fieldsMap fields =
401 let selected = if null fields
402 then map snd . niceSortKey fst $ Map.toList fieldsMap
403 else getSelectedFields fieldsMap fields
404 in QueryFieldsResult (map (\(defs, _, _) -> defs) selected)
405
406 -- | Query fields call.
407 queryFields :: QueryFields -> ErrorResult QueryFieldsResult
408 queryFields (QueryFields (ItemTypeOpCode QRNode) fields) =
409 Ok $ fieldsExtractor Node.fieldsMap fields
410
411 queryFields (QueryFields (ItemTypeOpCode QRGroup) fields) =
412 Ok $ fieldsExtractor Group.fieldsMap fields
413
414 queryFields (QueryFields (ItemTypeOpCode QRNetwork) fields) =
415 Ok $ fieldsExtractor Network.fieldsMap fields
416
417 queryFields (QueryFields (ItemTypeLuxi QRJob) fields) =
418 Ok $ fieldsExtractor Query.Job.fieldsMap fields
419
420 queryFields (QueryFields (ItemTypeOpCode QRExport) fields) =
421 Ok $ fieldsExtractor Export.fieldsMap fields
422
423 queryFields (QueryFields (ItemTypeOpCode QRInstance) fields) =
424 Ok $ fieldsExtractor Instance.fieldsMap fields
425
426 queryFields (QueryFields (ItemTypeLuxi QRLock) fields) =
427 Ok $ fieldsExtractor Locks.fieldsMap fields
428
429 queryFields (QueryFields (ItemTypeLuxi QRFilter) fields) =
430 Ok $ fieldsExtractor FilterRules.fieldsMap fields
431
432 queryFields (QueryFields qkind _) =
433 Bad . GenericError $ "QueryFields '" ++ show qkind ++ "' not supported"
434
435 -- | Classic query converter. It gets a standard query result on input
436 -- and computes the classic style results.
437 queryCompat :: QueryResult -> ErrorResult [[J.JSValue]]
438 queryCompat (QueryResult fields qrdata) =
439 case map fdefName $ filter ((== QFTUnknown) . fdefKind) fields of
440 [] -> Ok $ map (map (maybe J.JSNull J.showJSON . rentryValue)) qrdata
441 unknown -> Bad $ OpPrereqError ("Unknown output fields selected: " ++
442 intercalate ", " unknown) ECodeInval