Prefer the UuidObject type class over specific functions
[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.Foldable as Foldable
74 import Data.List (intercalate, nub, find)
75 import Data.Maybe (fromMaybe)
76 import qualified Data.Map as Map
77 import qualified Data.Set as Set
78 import qualified Text.JSON as J
79
80 import Ganeti.BasicTypes
81 import Ganeti.Config
82 import Ganeti.Errors
83 import Ganeti.JQueue
84 import Ganeti.JSON
85 import Ganeti.Locking.Allocation (OwnerState, LockRequest(..), OwnerState(..))
86 import Ganeti.Locking.Locks (GanetiLocks, ClientId, lockName)
87 import Ganeti.Logging
88 import Ganeti.Objects
89 import Ganeti.Query.Common
90 import qualified Ganeti.Query.Export as Export
91 import qualified Ganeti.Query.FilterRules as FilterRules
92 import Ganeti.Query.Filter
93 import qualified Ganeti.Query.Instance as Instance
94 import qualified Ganeti.Query.Job as Query.Job
95 import qualified Ganeti.Query.Group as Group
96 import Ganeti.Query.Language
97 import qualified Ganeti.Query.Locks as Locks
98 import qualified Ganeti.Query.Network as Network
99 import qualified Ganeti.Query.Node as Node
100 import Ganeti.Query.Types
101 import Ganeti.Path
102 import Ganeti.THH.HsRPC (runRpcClient)
103 import Ganeti.Types
104 import Ganeti.Utils
105 import Ganeti.WConfd.Client (getWConfdClient, listLocksWaitingStatus)
106
107 -- | Collector type
108 data CollectorType a b
109 = CollectorSimple (Bool -> ConfigData -> [a] -> IO [(a, b)])
110 | CollectorFieldAware (Bool -> ConfigData -> [String] -> [a] -> IO [(a, b)])
111
112 -- * Helper functions
113
114 -- | Builds an unknown field definition.
115 mkUnknownFDef :: String -> FieldData a b
116 mkUnknownFDef name =
117 ( FieldDefinition name name QFTUnknown ("Unknown field '" ++ name ++ "'")
118 , FieldUnknown
119 , QffNormal )
120
121 -- | Runs a field getter on the existing contexts.
122 execGetter :: ConfigData -> b -> a -> FieldGetter a b -> ResultEntry
123 execGetter _ _ item (FieldSimple getter) = getter item
124 execGetter cfg _ item (FieldConfig getter) = getter cfg item
125 execGetter _ rt item (FieldRuntime getter) = getter rt item
126 execGetter cfg rt item (FieldConfigRuntime getter) = getter cfg rt item
127 execGetter _ _ _ FieldUnknown = rsUnknown
128
129 -- * Main query execution
130
131 -- | Helper to build the list of requested fields. This transforms the
132 -- list of string fields to a list of field defs and getters, with
133 -- some of them possibly being unknown fields.
134 getSelectedFields :: FieldMap a b -- ^ Defined fields
135 -> [String] -- ^ Requested fields
136 -> FieldList a b -- ^ Selected fields
137 getSelectedFields defined =
138 map (\name -> fromMaybe (mkUnknownFDef name) $ name `Map.lookup` defined)
139
140 -- | Check whether list of queried fields contains live fields.
141 needsLiveData :: [FieldGetter a b] -> Bool
142 needsLiveData = any isRuntimeField
143
144 -- | Checks whether we have requested exactly some names. This is a
145 -- simple wrapper over 'requestedNames' and 'nameField'.
146 needsNames :: Query -> Maybe [FilterValue]
147 needsNames (Query kind _ qfilter) = requestedNames (nameField kind) qfilter
148
149 -- | Computes the name field for different query types.
150 nameField :: ItemType -> FilterField
151 nameField (ItemTypeLuxi QRJob) = "id"
152 nameField (ItemTypeOpCode QRExport) = "node"
153 nameField _ = "name"
154
155 -- | Computes the uuid field, or the best possible substitute, for different
156 -- query types.
157 uuidField :: ItemType -> FilterField
158 uuidField (ItemTypeLuxi QRJob) = nameField (ItemTypeLuxi QRJob)
159 uuidField (ItemTypeOpCode QRExport) = nameField (ItemTypeOpCode QRExport)
160 uuidField _ = "uuid"
161
162 -- | Extracts all quoted strings from a list, ignoring the
163 -- 'NumericValue' entries.
164 getAllQuotedStrings :: [FilterValue] -> [String]
165 getAllQuotedStrings =
166 concatMap extractor
167 where extractor (NumericValue _) = []
168 extractor (QuotedString val) = [val]
169
170 -- | Checks that we have either requested a valid set of names, or we
171 -- have a more complex filter.
172 getRequestedNames :: Query -> [String]
173 getRequestedNames qry =
174 case needsNames qry of
175 Just names -> getAllQuotedStrings names
176 Nothing -> []
177
178 -- | Compute the requested job IDs. This is custom since we need to
179 -- handle both strings and integers.
180 getRequestedJobIDs :: Filter FilterField -> Result [JobId]
181 getRequestedJobIDs qfilter =
182 case requestedNames (nameField (ItemTypeLuxi QRJob)) qfilter of
183 Nothing -> Ok []
184 Just [] -> Ok []
185 Just vals ->
186 liftM nub $
187 mapM (\e -> case e of
188 QuotedString s -> makeJobIdS s
189 NumericValue i -> makeJobId $ fromIntegral i
190 ) vals
191
192 -- | Generic query implementation for resources that are backed by
193 -- some configuration objects.
194 --
195 -- Different query types use the same 'genericQuery' function by providing
196 -- a collector function and a field map. The collector function retrieves
197 -- live data, and the field map provides both the requirements and the logic
198 -- necessary to retrieve the data needed for the field.
199 --
200 -- The 'b' type in the specification is the runtime. Every query can gather
201 -- additional live data related to the configuration object using the collector
202 -- to perform RPC calls.
203 --
204 -- The gathered data, or the failure to get it, is expressed through a runtime
205 -- object. The type of a runtime object is determined by every query type for
206 -- itself, and used exclusively by that query.
207 genericQuery :: FieldMap a b -- ^ Maps field names to field definitions
208 -> CollectorType a b -- ^ Collector of live data
209 -> (a -> String) -- ^ Object to name function
210 -> (ConfigData -> Container a) -- ^ Get all objects from config
211 -> (ConfigData -> String -> ErrorResult a) -- ^ Lookup object
212 -> ConfigData -- ^ The config to run the query against
213 -> Bool -- ^ Whether the query should be run live
214 -> [String] -- ^ List of requested fields
215 -> Filter FilterField -- ^ Filter field
216 -> [String] -- ^ List of requested names
217 -> IO (ErrorResult QueryResult)
218 genericQuery fieldsMap collector nameFn configFn getFn cfg
219 live fields qfilter wanted =
220 runResultT $ do
221 cfilter <- toError $ compileFilter fieldsMap qfilter
222 let allfields = (++) fields . filter (not . (`elem` fields))
223 . ordNub $ filterArguments qfilter
224 count = length fields
225 selected = getSelectedFields fieldsMap allfields
226 (fdefs, fgetters, _) = unzip3 selected
227 live' = live && needsLiveData fgetters
228 objects <- toError $ case wanted of
229 [] -> Ok . niceSortKey nameFn .
230 Foldable.toList $ configFn cfg
231 _ -> mapM (getFn cfg) wanted
232 -- Run the first pass of the filter, without a runtime context; this will
233 -- limit the objects that we'll contact for exports
234 fobjects <- toError $
235 filterM (\n -> evaluateQueryFilter cfg Nothing n cfilter) objects
236 -- Gather the runtime data and filter the results again,
237 -- based on the gathered data
238 runtimes <- (case collector of
239 CollectorSimple collFn -> lift $ collFn live' cfg fobjects
240 CollectorFieldAware collFn -> lift $ collFn live' cfg allfields fobjects)
241 >>= (toError . filterM (\(obj, runtime) ->
242 evaluateQueryFilter cfg (Just runtime) obj cfilter))
243 let fdata = map (\(obj, runtime) ->
244 map (execGetter cfg runtime obj) fgetters)
245 runtimes
246 return QueryResult { qresFields = take count fdefs
247 , qresData = map (take count) fdata }
248
249 -- | Dummy recollection of the data for a lock from the prefected
250 -- data for all locks.
251 recollectLocksData :: ( [(GanetiLocks, [(ClientId, OwnerState)])]
252 , [(Integer, ClientId, [LockRequest GanetiLocks])]
253 )
254 -> Bool -> ConfigData -> [String]
255 -> IO [(String, Locks.RuntimeData)]
256 recollectLocksData (allLocks, pending) _ _ =
257 let getPending lock = pending >>= \(_, cid, req) ->
258 let req' = filter ((==) lock . lockName . lockAffected) req
259 in case () of
260 _ | any ((==) (Just OwnExclusive) . lockRequestType) req'
261 -> [(cid, OwnExclusive)]
262 _ | any ((==) (Just OwnShared) . lockRequestType) req'
263 -> [(cid, OwnShared)]
264 _ -> []
265 lookuplock lock = (,) lock
266 . maybe ([], getPending lock)
267 (\(_, c) -> (c, getPending lock))
268 . find ((==) lock . lockName . fst)
269 $ allLocks
270 in return . map lookuplock
271
272 -- | Main query execution function.
273 query :: ConfigData -- ^ The current configuration
274 -> Bool -- ^ Whether to collect live data
275 -> Query -- ^ The query (item, fields, filter)
276 -> IO (ErrorResult QueryResult) -- ^ Result
277 query cfg live (Query (ItemTypeLuxi QRJob) fields qfilter) =
278 queryJobs cfg live fields qfilter
279 query cfg live (Query (ItemTypeLuxi QRLock) fields qfilter) = runResultT $ do
280 unless live (failError "Locks can only be queried live")
281 cl <- liftIO $ do
282 socketpath <- defaultWConfdSocket
283 getWConfdClient socketpath
284 livedata <- runRpcClient listLocksWaitingStatus cl
285 logDebug $ "Live state of all locks is " ++ show livedata
286 let allLocks = Set.toList . Set.unions
287 $ (Set.fromList . map fst $ fst livedata)
288 : map (\(_, _, req) -> Set.fromList $ map lockAffected req)
289 (snd livedata)
290 answer <- liftIO $ genericQuery
291 Locks.fieldsMap
292 (CollectorSimple $ recollectLocksData livedata)
293 id
294 (const . GenericContainer . Map.fromList
295 . map ((id &&& id) . lockName) $ allLocks)
296 (const Ok)
297 cfg live fields qfilter []
298 toError answer
299
300 query cfg live qry = queryInner cfg live qry $ getRequestedNames qry
301
302
303 -- | Dummy data collection fuction
304 dummyCollectLiveData :: Bool -> ConfigData -> [a] -> IO [(a, NoDataRuntime)]
305 dummyCollectLiveData _ _ = return . map (, NoDataRuntime)
306
307 -- | Inner query execution function.
308 queryInner :: ConfigData -- ^ The current configuration
309 -> Bool -- ^ Whether to collect live data
310 -> Query -- ^ The query (item, fields, filter)
311 -> [String] -- ^ Requested names
312 -> IO (ErrorResult QueryResult) -- ^ Result
313
314 queryInner cfg live (Query (ItemTypeOpCode QRNode) fields qfilter) wanted =
315 genericQuery Node.fieldsMap (CollectorFieldAware Node.collectLiveData)
316 nodeName configNodes getNode cfg live fields qfilter wanted
317
318 queryInner cfg live (Query (ItemTypeOpCode QRInstance) fields qfilter) wanted =
319 genericQuery Instance.fieldsMap (CollectorFieldAware Instance.collectLiveData)
320 (fromMaybe "" . instName) configInstances getInstance cfg live
321 fields qfilter
322 wanted
323
324 queryInner cfg live (Query (ItemTypeOpCode QRGroup) fields qfilter) wanted =
325 genericQuery Group.fieldsMap (CollectorSimple dummyCollectLiveData) groupName
326 configNodegroups getGroup cfg live fields qfilter wanted
327
328 queryInner cfg live (Query (ItemTypeOpCode QRNetwork) fields qfilter) wanted =
329 genericQuery Network.fieldsMap (CollectorSimple dummyCollectLiveData)
330 (fromNonEmpty . networkName)
331 configNetworks getNetwork cfg live fields qfilter wanted
332
333 queryInner cfg live (Query (ItemTypeOpCode QRExport) fields qfilter) wanted =
334 genericQuery Export.fieldsMap (CollectorSimple Export.collectLiveData)
335 nodeName configNodes getNode cfg live fields qfilter wanted
336
337 queryInner cfg live (Query (ItemTypeLuxi QRFilter) fields qfilter) wanted =
338 genericQuery FilterRules.fieldsMap (CollectorSimple dummyCollectLiveData)
339 uuidOf configFilters getFilterRule cfg live fields qfilter wanted
340
341 queryInner _ _ (Query qkind _ _) _ =
342 return . Bad . GenericError $ "Query '" ++ show qkind ++ "' not supported"
343
344 -- | Query jobs specific query function, needed as we need to accept
345 -- both 'QuotedString' and 'NumericValue' as wanted names.
346 queryJobs :: ConfigData -- ^ The current configuration
347 -> Bool -- ^ Whether to collect live data
348 -> [FilterField] -- ^ Item
349 -> Filter FilterField -- ^ Filter
350 -> IO (ErrorResult QueryResult) -- ^ Result
351 queryJobs cfg live fields qfilter = runResultT $ do
352 rootdir <- lift queueDir
353 wanted_names <- toErrorStr $ getRequestedJobIDs qfilter
354 rjids <- case wanted_names of
355 [] | live -> do -- we can check the filesystem for actual jobs
356 let want_arch = Query.Job.wantArchived fields
357 jobIDs <-
358 withErrorT (BlockDeviceError .
359 (++) "Unable to fetch the job list: " . show) $
360 liftIO (determineJobDirectories rootdir want_arch)
361 >>= ResultT . getJobIDs
362 return $ sortJobIDs jobIDs
363 -- else we shouldn't look at the filesystem...
364 v -> return v
365 cfilter <- toError $ compileFilter Query.Job.fieldsMap qfilter
366 let selected = getSelectedFields Query.Job.fieldsMap fields
367 (fdefs, fgetters, _) = unzip3 selected
368 (_, filtergetters, _) = unzip3 . getSelectedFields Query.Job.fieldsMap
369 $ Foldable.toList qfilter
370 live' = live && needsLiveData (fgetters ++ filtergetters)
371 disabled_data = Bad "live data disabled"
372 -- runs first pass of the filter, without a runtime context; this
373 -- will limit the jobs that we'll load from disk
374 jids <- toError $
375 filterM (\jid -> evaluateQueryFilter cfg Nothing jid cfilter) rjids
376 -- here we run the runtime data gathering, filtering and evaluation,
377 -- all in the same step, so that we don't keep jobs in memory longer
378 -- than we need; we can't be fully lazy due to the multiple monad
379 -- wrapping across different steps
380 qdir <- lift queueDir
381 fdata <- foldM
382 -- big lambda, but we use many variables from outside it...
383 (\lst jid -> do
384 job <- lift $ if live'
385 then loadJobFromDisk qdir True jid
386 else return disabled_data
387 pass <- toError $ evaluateQueryFilter cfg (Just job) jid cfilter
388 let nlst = if pass
389 then let row = map (execGetter cfg job jid) fgetters
390 in rnf row `seq` row:lst
391 else lst
392 -- evaluate nlst (to WHNF), otherwise we're too lazy
393 return $! nlst
394 ) [] jids
395 return QueryResult { qresFields = fdefs, qresData = reverse fdata }
396
397 -- | Helper for 'queryFields'.
398 fieldsExtractor :: FieldMap a b -> [FilterField] -> QueryFieldsResult
399 fieldsExtractor fieldsMap fields =
400 let selected = if null fields
401 then map snd . niceSortKey fst $ Map.toList fieldsMap
402 else getSelectedFields fieldsMap fields
403 in QueryFieldsResult (map (\(defs, _, _) -> defs) selected)
404
405 -- | Query fields call.
406 queryFields :: QueryFields -> ErrorResult QueryFieldsResult
407 queryFields (QueryFields (ItemTypeOpCode QRNode) fields) =
408 Ok $ fieldsExtractor Node.fieldsMap fields
409
410 queryFields (QueryFields (ItemTypeOpCode QRGroup) fields) =
411 Ok $ fieldsExtractor Group.fieldsMap fields
412
413 queryFields (QueryFields (ItemTypeOpCode QRNetwork) fields) =
414 Ok $ fieldsExtractor Network.fieldsMap fields
415
416 queryFields (QueryFields (ItemTypeLuxi QRJob) fields) =
417 Ok $ fieldsExtractor Query.Job.fieldsMap fields
418
419 queryFields (QueryFields (ItemTypeOpCode QRExport) fields) =
420 Ok $ fieldsExtractor Export.fieldsMap fields
421
422 queryFields (QueryFields (ItemTypeOpCode QRInstance) fields) =
423 Ok $ fieldsExtractor Instance.fieldsMap fields
424
425 queryFields (QueryFields (ItemTypeLuxi QRLock) fields) =
426 Ok $ fieldsExtractor Locks.fieldsMap fields
427
428 queryFields (QueryFields (ItemTypeLuxi QRFilter) fields) =
429 Ok $ fieldsExtractor FilterRules.fieldsMap fields
430
431 queryFields (QueryFields qkind _) =
432 Bad . GenericError $ "QueryFields '" ++ show qkind ++ "' not supported"
433
434 -- | Classic query converter. It gets a standard query result on input
435 -- and computes the classic style results.
436 queryCompat :: QueryResult -> ErrorResult [[J.JSValue]]
437 queryCompat (QueryResult fields qrdata) =
438 case map fdefName $ filter ((== QFTUnknown) . fdefKind) fields of
439 [] -> Ok $ map (map (maybe J.JSNull J.showJSON . rentryValue)) qrdata
440 unknown -> Bad $ OpPrereqError ("Unknown output fields selected: " ++
441 intercalate ", " unknown) ECodeInval