| {-# LANGUAGE TupleSections #-} |
| |
| {-| Implementation of the Ganeti Query2 functionality. |
| |
| -} |
| |
| {- |
| |
| Copyright (C) 2012, 2013 Google Inc. |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are |
| met: |
| |
| 1. Redistributions of source code must retain the above copyright notice, |
| this list of conditions and the following disclaimer. |
| |
| 2. Redistributions in binary form must reproduce the above copyright |
| notice, this list of conditions and the following disclaimer in the |
| documentation and/or other materials provided with the distribution. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS |
| IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED |
| TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR |
| PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR |
| CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, |
| EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, |
| PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR |
| PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF |
| LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING |
| NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS |
| SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
| |
| -} |
| |
| {- |
| |
| TODO: problems with the current model: |
| |
| 1. There's nothing preventing a result such as ResultEntry RSNormal |
| Nothing, or ResultEntry RSNoData (Just ...); ideally, we would |
| separate the the RSNormal and other types; we would need a new data |
| type for this, though, with JSON encoding/decoding |
| |
| 2. We don't have a way to 'bind' a FieldDefinition's field type |
| (e.q. QFTBool) with the actual value that is returned from a |
| FieldGetter. This means that the various getter functions can return |
| divergent types for the same field when evaluated against multiple |
| items. This is bad; it only works today because we 'hide' everything |
| behind JSValue, but is not nice at all. We should probably remove the |
| separation between FieldDefinition and the FieldGetter, and introduce |
| a new abstract data type, similar to QFT*, that contains the values |
| too. |
| |
| -} |
| |
| module Ganeti.Query.Query |
| ( query |
| , queryFields |
| , queryCompat |
| , getRequestedNames |
| , nameField |
| , NoDataRuntime |
| , uuidField |
| ) where |
| |
| import Control.Arrow ((&&&)) |
| import Control.DeepSeq |
| import Control.Monad (filterM, foldM, liftM, unless) |
| import Control.Monad.IO.Class |
| import Control.Monad.Trans (lift) |
| import qualified Data.ByteString.UTF8 as UTF8 |
| import qualified Data.Foldable as Foldable |
| import Data.List (intercalate, nub, find) |
| import Data.Maybe (fromMaybe) |
| import qualified Data.Map as Map |
| import qualified Data.Set as Set |
| import qualified Text.JSON as J |
| |
| import Ganeti.BasicTypes |
| import Ganeti.Config |
| import Ganeti.Errors |
| import Ganeti.JQueue |
| import Ganeti.JSON (Container, GenericContainer(..)) |
| import Ganeti.Locking.Allocation (OwnerState, LockRequest(..), OwnerState(..)) |
| import Ganeti.Locking.Locks (GanetiLocks, ClientId, lockName) |
| import Ganeti.Logging |
| import Ganeti.Objects |
| import Ganeti.Query.Common |
| import qualified Ganeti.Query.Export as Export |
| import qualified Ganeti.Query.FilterRules as FilterRules |
| import Ganeti.Query.Filter |
| import qualified Ganeti.Query.Instance as Instance |
| import qualified Ganeti.Query.Job as Query.Job |
| import qualified Ganeti.Query.Group as Group |
| import Ganeti.Query.Language |
| import qualified Ganeti.Query.Locks as Locks |
| import qualified Ganeti.Query.Network as Network |
| import qualified Ganeti.Query.Node as Node |
| import Ganeti.Query.Types |
| import Ganeti.Path |
| import Ganeti.THH.HsRPC (runRpcClient) |
| import Ganeti.Types |
| import Ganeti.Utils |
| import Ganeti.WConfd.Client (getWConfdClient, listLocksWaitingStatus) |
| |
| -- | Collector type |
| data CollectorType a b |
| = CollectorSimple (Bool -> ConfigData -> [a] -> IO [(a, b)]) |
| | CollectorFieldAware (Bool -> ConfigData -> [String] -> [a] -> IO [(a, b)]) |
| |
| -- * Helper functions |
| |
| -- | Builds an unknown field definition. |
| mkUnknownFDef :: String -> FieldData a b |
| mkUnknownFDef name = |
| ( FieldDefinition name name QFTUnknown ("Unknown field '" ++ name ++ "'") |
| , FieldUnknown |
| , QffNormal ) |
| |
| -- | Runs a field getter on the existing contexts. |
| execGetter :: ConfigData -> b -> a -> FieldGetter a b -> ResultEntry |
| execGetter _ _ item (FieldSimple getter) = getter item |
| execGetter cfg _ item (FieldConfig getter) = getter cfg item |
| execGetter _ rt item (FieldRuntime getter) = getter rt item |
| execGetter cfg rt item (FieldConfigRuntime getter) = getter cfg rt item |
| execGetter _ _ _ FieldUnknown = rsUnknown |
| |
| -- * Main query execution |
| |
| -- | Helper to build the list of requested fields. This transforms the |
| -- list of string fields to a list of field defs and getters, with |
| -- some of them possibly being unknown fields. |
| getSelectedFields :: FieldMap a b -- ^ Defined fields |
| -> [String] -- ^ Requested fields |
| -> FieldList a b -- ^ Selected fields |
| getSelectedFields defined = |
| map (\name -> fromMaybe (mkUnknownFDef name) $ name `Map.lookup` defined) |
| |
| -- | Check whether list of queried fields contains live fields. |
| needsLiveData :: [FieldGetter a b] -> Bool |
| needsLiveData = any isRuntimeField |
| |
| -- | Checks whether we have requested exactly some names. This is a |
| -- simple wrapper over 'requestedNames' and 'nameField'. |
| needsNames :: Query -> Maybe [FilterValue] |
| needsNames (Query kind _ qfilter) = requestedNames (nameField kind) qfilter |
| |
| -- | Computes the name field for different query types. |
| nameField :: ItemType -> FilterField |
| nameField (ItemTypeLuxi QRJob) = "id" |
| nameField (ItemTypeOpCode QRExport) = "node" |
| nameField _ = "name" |
| |
| -- | Computes the uuid field, or the best possible substitute, for different |
| -- query types. |
| uuidField :: ItemType -> FilterField |
| uuidField (ItemTypeLuxi QRJob) = nameField (ItemTypeLuxi QRJob) |
| uuidField (ItemTypeOpCode QRExport) = nameField (ItemTypeOpCode QRExport) |
| uuidField _ = "uuid" |
| |
| -- | Extracts all quoted strings from a list, ignoring the |
| -- 'NumericValue' entries. |
| getAllQuotedStrings :: [FilterValue] -> [String] |
| getAllQuotedStrings = |
| concatMap extractor |
| where extractor (NumericValue _) = [] |
| extractor (QuotedString val) = [val] |
| |
| -- | Checks that we have either requested a valid set of names, or we |
| -- have a more complex filter. |
| getRequestedNames :: Query -> [String] |
| getRequestedNames qry = |
| case needsNames qry of |
| Just names -> getAllQuotedStrings names |
| Nothing -> [] |
| |
| -- | Compute the requested job IDs. This is custom since we need to |
| -- handle both strings and integers. |
| getRequestedJobIDs :: Filter FilterField -> Result [JobId] |
| getRequestedJobIDs qfilter = |
| case requestedNames (nameField (ItemTypeLuxi QRJob)) qfilter of |
| Nothing -> Ok [] |
| Just [] -> Ok [] |
| Just vals -> |
| liftM nub $ |
| mapM (\e -> case e of |
| QuotedString s -> makeJobIdS s |
| NumericValue i -> makeJobId $ fromIntegral i |
| ) vals |
| |
| -- | Generic query implementation for resources that are backed by |
| -- some configuration objects. |
| -- |
| -- Different query types use the same 'genericQuery' function by providing |
| -- a collector function and a field map. The collector function retrieves |
| -- live data, and the field map provides both the requirements and the logic |
| -- necessary to retrieve the data needed for the field. |
| -- |
| -- The 'b' type in the specification is the runtime. Every query can gather |
| -- additional live data related to the configuration object using the collector |
| -- to perform RPC calls. |
| -- |
| -- The gathered data, or the failure to get it, is expressed through a runtime |
| -- object. The type of a runtime object is determined by every query type for |
| -- itself, and used exclusively by that query. |
| genericQuery :: FieldMap a b -- ^ Maps field names to field definitions |
| -> CollectorType a b -- ^ Collector of live data |
| -> (a -> String) -- ^ Object to name function |
| -> (ConfigData -> Container a) -- ^ Get all objects from config |
| -> (ConfigData -> String -> ErrorResult a) -- ^ Lookup object |
| -> ConfigData -- ^ The config to run the query against |
| -> Bool -- ^ Whether the query should be run live |
| -> [String] -- ^ List of requested fields |
| -> Filter FilterField -- ^ Filter field |
| -> [String] -- ^ List of requested names |
| -> IO (ErrorResult QueryResult) |
| genericQuery fieldsMap collector nameFn configFn getFn cfg |
| live fields qfilter wanted = |
| runResultT $ do |
| cfilter <- toError $ compileFilter fieldsMap qfilter |
| let allfields = (++) fields . filter (not . (`elem` fields)) |
| . ordNub $ filterArguments qfilter |
| count = length fields |
| selected = getSelectedFields fieldsMap allfields |
| (fdefs, fgetters, _) = unzip3 selected |
| live' = live && needsLiveData fgetters |
| objects <- toError $ case wanted of |
| [] -> Ok . niceSortKey nameFn . |
| Foldable.toList $ configFn cfg |
| _ -> mapM (getFn cfg) wanted |
| -- Run the first pass of the filter, without a runtime context; this will |
| -- limit the objects that we'll contact for exports |
| fobjects <- toError $ |
| filterM (\n -> evaluateQueryFilter cfg Nothing n cfilter) objects |
| -- Gather the runtime data and filter the results again, |
| -- based on the gathered data |
| runtimes <- (case collector of |
| CollectorSimple collFn -> lift $ collFn live' cfg fobjects |
| CollectorFieldAware collFn -> lift $ collFn live' cfg allfields fobjects) |
| >>= (toError . filterM (\(obj, runtime) -> |
| evaluateQueryFilter cfg (Just runtime) obj cfilter)) |
| let fdata = map (\(obj, runtime) -> |
| map (execGetter cfg runtime obj) fgetters) |
| runtimes |
| return QueryResult { qresFields = take count fdefs |
| , qresData = map (take count) fdata } |
| |
| -- | Dummy recollection of the data for a lock from the prefected |
| -- data for all locks. |
| recollectLocksData :: ( [(GanetiLocks, [(ClientId, OwnerState)])] |
| , [(Integer, ClientId, [LockRequest GanetiLocks])] |
| ) |
| -> Bool -> ConfigData -> [String] |
| -> IO [(String, Locks.RuntimeData)] |
| recollectLocksData (allLocks, pending) _ _ = |
| let getPending lock = pending >>= \(_, cid, req) -> |
| let req' = filter ((==) lock . lockName . lockAffected) req |
| in case () of |
| _ | any ((==) (Just OwnExclusive) . lockRequestType) req' |
| -> [(cid, OwnExclusive)] |
| _ | any ((==) (Just OwnShared) . lockRequestType) req' |
| -> [(cid, OwnShared)] |
| _ -> [] |
| lookuplock lock = (,) lock |
| . maybe ([], getPending lock) |
| (\(_, c) -> (c, getPending lock)) |
| . find ((==) lock . lockName . fst) |
| $ allLocks |
| in return . map lookuplock |
| |
| -- | Main query execution function. |
| query :: ConfigData -- ^ The current configuration |
| -> Bool -- ^ Whether to collect live data |
| -> Query -- ^ The query (item, fields, filter) |
| -> IO (ErrorResult QueryResult) -- ^ Result |
| query cfg live (Query (ItemTypeLuxi QRJob) fields qfilter) = |
| queryJobs cfg live fields qfilter |
| query cfg live (Query (ItemTypeLuxi QRLock) fields qfilter) = runResultT $ do |
| unless live (failError "Locks can only be queried live") |
| cl <- liftIO $ do |
| socketpath <- defaultWConfdSocket |
| getWConfdClient socketpath |
| livedata <- runRpcClient listLocksWaitingStatus cl |
| logDebug $ "Live state of all locks is " ++ show livedata |
| let allLocks = Set.toList . Set.unions |
| $ (Set.fromList . map fst $ fst livedata) |
| : map (\(_, _, req) -> Set.fromList $ map lockAffected req) |
| (snd livedata) |
| answer <- liftIO $ genericQuery |
| Locks.fieldsMap |
| (CollectorSimple $ recollectLocksData livedata) |
| id |
| (const . GenericContainer . Map.fromList |
| . map ((UTF8.fromString &&& id) . lockName) $ allLocks) |
| (const Ok) |
| cfg live fields qfilter [] |
| toError answer |
| |
| query cfg live qry = queryInner cfg live qry $ getRequestedNames qry |
| |
| |
| -- | Dummy data collection fuction |
| dummyCollectLiveData :: Bool -> ConfigData -> [a] -> IO [(a, NoDataRuntime)] |
| dummyCollectLiveData _ _ = return . map (, NoDataRuntime) |
| |
| -- | Inner query execution function. |
| queryInner :: ConfigData -- ^ The current configuration |
| -> Bool -- ^ Whether to collect live data |
| -> Query -- ^ The query (item, fields, filter) |
| -> [String] -- ^ Requested names |
| -> IO (ErrorResult QueryResult) -- ^ Result |
| |
| queryInner cfg live (Query (ItemTypeOpCode QRNode) fields qfilter) wanted = |
| genericQuery Node.fieldsMap (CollectorFieldAware Node.collectLiveData) |
| nodeName configNodes getNode cfg live fields qfilter wanted |
| |
| queryInner cfg live (Query (ItemTypeOpCode QRInstance) fields qfilter) wanted = |
| genericQuery Instance.fieldsMap (CollectorFieldAware Instance.collectLiveData) |
| (fromMaybe "" . instName) configInstances getInstance cfg live |
| fields qfilter |
| wanted |
| |
| queryInner cfg live (Query (ItemTypeOpCode QRGroup) fields qfilter) wanted = |
| genericQuery Group.fieldsMap (CollectorSimple dummyCollectLiveData) groupName |
| configNodegroups getGroup cfg live fields qfilter wanted |
| |
| queryInner cfg live (Query (ItemTypeOpCode QRNetwork) fields qfilter) wanted = |
| genericQuery Network.fieldsMap (CollectorSimple dummyCollectLiveData) |
| (fromNonEmpty . networkName) |
| configNetworks getNetwork cfg live fields qfilter wanted |
| |
| queryInner cfg live (Query (ItemTypeOpCode QRExport) fields qfilter) wanted = |
| genericQuery Export.fieldsMap (CollectorSimple Export.collectLiveData) |
| nodeName configNodes getNode cfg live fields qfilter wanted |
| |
| queryInner cfg live (Query (ItemTypeLuxi QRFilter) fields qfilter) wanted = |
| genericQuery FilterRules.fieldsMap (CollectorSimple dummyCollectLiveData) |
| uuidOf configFilters getFilterRule cfg live fields qfilter wanted |
| |
| queryInner _ _ (Query qkind _ _) _ = |
| return . Bad . GenericError $ "Query '" ++ show qkind ++ "' not supported" |
| |
| -- | Query jobs specific query function, needed as we need to accept |
| -- both 'QuotedString' and 'NumericValue' as wanted names. |
| queryJobs :: ConfigData -- ^ The current configuration |
| -> Bool -- ^ Whether to collect live data |
| -> [FilterField] -- ^ Item |
| -> Filter FilterField -- ^ Filter |
| -> IO (ErrorResult QueryResult) -- ^ Result |
| queryJobs cfg live fields qfilter = runResultT $ do |
| rootdir <- lift queueDir |
| wanted_names <- toErrorStr $ getRequestedJobIDs qfilter |
| rjids <- case wanted_names of |
| [] | live -> do -- we can check the filesystem for actual jobs |
| let want_arch = Query.Job.wantArchived fields |
| jobIDs <- |
| withErrorT (BlockDeviceError . |
| (++) "Unable to fetch the job list: " . show) $ |
| liftIO (determineJobDirectories rootdir want_arch) |
| >>= ResultT . getJobIDs |
| return $ sortJobIDs jobIDs |
| -- else we shouldn't look at the filesystem... |
| v -> return v |
| cfilter <- toError $ compileFilter Query.Job.fieldsMap qfilter |
| let selected = getSelectedFields Query.Job.fieldsMap fields |
| (fdefs, fgetters, _) = unzip3 selected |
| (_, filtergetters, _) = unzip3 . getSelectedFields Query.Job.fieldsMap |
| $ Foldable.toList qfilter |
| live' = live && needsLiveData (fgetters ++ filtergetters) |
| disabled_data = Bad "live data disabled" |
| -- runs first pass of the filter, without a runtime context; this |
| -- will limit the jobs that we'll load from disk |
| jids <- toError $ |
| filterM (\jid -> evaluateQueryFilter cfg Nothing jid cfilter) rjids |
| -- here we run the runtime data gathering, filtering and evaluation, |
| -- all in the same step, so that we don't keep jobs in memory longer |
| -- than we need; we can't be fully lazy due to the multiple monad |
| -- wrapping across different steps |
| qdir <- lift queueDir |
| fdata <- foldM |
| -- big lambda, but we use many variables from outside it... |
| (\lst jid -> do |
| job <- lift $ if live' |
| then loadJobFromDisk qdir True jid |
| else return disabled_data |
| pass <- toError $ evaluateQueryFilter cfg (Just job) jid cfilter |
| let nlst = if pass |
| then let row = map (execGetter cfg job jid) fgetters |
| in rnf row `seq` row:lst |
| else lst |
| -- evaluate nlst (to WHNF), otherwise we're too lazy |
| return $! nlst |
| ) [] jids |
| return QueryResult { qresFields = fdefs, qresData = reverse fdata } |
| |
| -- | Helper for 'queryFields'. |
| fieldsExtractor :: FieldMap a b -> [FilterField] -> QueryFieldsResult |
| fieldsExtractor fieldsMap fields = |
| let selected = if null fields |
| then map snd . niceSortKey fst $ Map.toList fieldsMap |
| else getSelectedFields fieldsMap fields |
| in QueryFieldsResult (map (\(defs, _, _) -> defs) selected) |
| |
| -- | Query fields call. |
| queryFields :: QueryFields -> ErrorResult QueryFieldsResult |
| queryFields (QueryFields (ItemTypeOpCode QRNode) fields) = |
| Ok $ fieldsExtractor Node.fieldsMap fields |
| |
| queryFields (QueryFields (ItemTypeOpCode QRGroup) fields) = |
| Ok $ fieldsExtractor Group.fieldsMap fields |
| |
| queryFields (QueryFields (ItemTypeOpCode QRNetwork) fields) = |
| Ok $ fieldsExtractor Network.fieldsMap fields |
| |
| queryFields (QueryFields (ItemTypeLuxi QRJob) fields) = |
| Ok $ fieldsExtractor Query.Job.fieldsMap fields |
| |
| queryFields (QueryFields (ItemTypeOpCode QRExport) fields) = |
| Ok $ fieldsExtractor Export.fieldsMap fields |
| |
| queryFields (QueryFields (ItemTypeOpCode QRInstance) fields) = |
| Ok $ fieldsExtractor Instance.fieldsMap fields |
| |
| queryFields (QueryFields (ItemTypeLuxi QRLock) fields) = |
| Ok $ fieldsExtractor Locks.fieldsMap fields |
| |
| queryFields (QueryFields (ItemTypeLuxi QRFilter) fields) = |
| Ok $ fieldsExtractor FilterRules.fieldsMap fields |
| |
| queryFields (QueryFields qkind _) = |
| Bad . GenericError $ "QueryFields '" ++ show qkind ++ "' not supported" |
| |
| -- | Classic query converter. It gets a standard query result on input |
| -- and computes the classic style results. |
| queryCompat :: QueryResult -> ErrorResult [[J.JSValue]] |
| queryCompat (QueryResult fields qrdata) = |
| case map fdefName $ filter ((== QFTUnknown) . fdefKind) fields of |
| [] -> Ok $ map (map (maybe J.JSNull J.showJSON . rentryValue)) qrdata |
| unknown -> Bad $ OpPrereqError ("Unknown output fields selected: " ++ |
| intercalate ", " unknown) ECodeInval |
