diff --git a/Makefile.am b/Makefile.am
index cd76ac70d9248490ac8e75f307f907640f69cb94..7c31f56a2ff1190feee8af480aef765070ae6628 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -496,6 +496,7 @@ HS_LIB_SRCS = \
htools/Ganeti/Query/Common.hs \
htools/Ganeti/Query/Filter.hs \
htools/Ganeti/Query/Group.hs \
+ htools/Ganeti/Query/Job.hs \
htools/Ganeti/Query/Language.hs \
htools/Ganeti/Query/Node.hs \
htools/Ganeti/Query/Query.hs \
diff --git a/htest/Test/Ganeti/Query/Query.hs b/htest/Test/Ganeti/Query/Query.hs
index 37ed56c341724e3db68f299e7dc7e0823a76fd3e..3b9ca53ffea1da29391705be6f61eb34b4225445 100644
--- a/htest/Test/Ganeti/Query/Query.hs
+++ b/htest/Test/Ganeti/Query/Query.hs
@@ -44,10 +44,12 @@ import Test.Ganeti.Objects (genEmptyCluster)
import Ganeti.BasicTypes
import Ganeti.Errors
+import Ganeti.Query.Filter
import Ganeti.Query.Group
import Ganeti.Query.Language
import Ganeti.Query.Node
import Ganeti.Query.Query
+import qualified Ganeti.Query.Job as Job
{-# ANN module "HLint: ignore Use camelCase" #-}
@@ -59,6 +61,8 @@ hasUnknownFields = (QFTUnknown `notElem`) . map fdefKind
-- * Test cases
+-- ** Node queries
+
-- | Tests that querying any existing fields, via either query or
-- queryFields, will not return unknown fields.
prop_queryNode_noUnknown :: Property
@@ -159,7 +163,7 @@ case_queryNode_allfields = do
(sortBy field_sort . map (\(f, _, _) -> f) $ Map.elems nodeFieldsMap)
(sortBy field_sort fdefs)
--- * Same as above, but for group
+-- ** Group queries
prop_queryGroup_noUnknown :: Property
prop_queryGroup_noUnknown =
@@ -231,6 +235,61 @@ case_queryGroup_allfields = do
(sortBy field_sort . map (\(f, _, _) -> f) $ Map.elems groupFieldsMap)
(sortBy field_sort fdefs)
+-- ** Job queries
+
+-- | Tests that querying any existing fields, via either query or
+-- queryFields, will not return unknown fields. This uses 'undefined'
+-- for config, as job queries shouldn't use the configuration, and an
+-- explicit filter as otherwise non-live queries wouldn't return any
+-- result rows.
+prop_queryJob_noUnknown :: Property
+prop_queryJob_noUnknown =
+ forAll (listOf (arbitrary::Gen (Positive Integer))) $ \ids ->
+ forAll (elements (Map.keys Job.fieldsMap)) $ \field -> monadicIO $ do
+ let qtype = ItemTypeLuxi QRJob
+ flt = makeSimpleFilter (nameField qtype) $
+ map (\(Positive i) -> Right i) ids
+ QueryResult fdefs fdata <-
+ run (query undefined False (Query qtype [field] flt)) >>= resultProp
+ QueryFieldsResult fdefs' <-
+ resultProp $ queryFields (QueryFields qtype [field])
+ stop $ conjoin
+ [ printTestCase ("Got unknown fields via query (" ++
+ show fdefs ++ ")") (hasUnknownFields fdefs)
+ , printTestCase ("Got unknown result status via query (" ++
+ show fdata ++ ")")
+ (all (all ((/= RSUnknown) . rentryStatus)) fdata)
+ , printTestCase ("Got unknown fields via query fields (" ++
+ show fdefs'++ ")") (hasUnknownFields fdefs')
+ ]
+
+-- | Tests that an unknown field is returned as such.
+prop_queryJob_Unknown :: Property
+prop_queryJob_Unknown =
+ forAll (listOf (arbitrary::Gen (Positive Integer))) $ \ids ->
+ forAll (arbitrary `suchThat` (`notElem` Map.keys Job.fieldsMap))
+ $ \field -> monadicIO $ do
+ let qtype = ItemTypeLuxi QRJob
+ flt = makeSimpleFilter (nameField qtype) $
+ map (\(Positive i) -> Right i) ids
+ QueryResult fdefs fdata <-
+ run (query undefined False (Query qtype [field] flt)) >>= resultProp
+ QueryFieldsResult fdefs' <-
+ resultProp $ queryFields (QueryFields qtype [field])
+ stop $ conjoin
+ [ printTestCase ("Got known fields via query (" ++ show fdefs ++ ")")
+ (not $ hasUnknownFields fdefs)
+ , printTestCase ("Got /= ResultUnknown result status via query (" ++
+ show fdata ++ ")")
+ (all (all ((== RSUnknown) . rentryStatus)) fdata)
+ , printTestCase ("Got a Just in a result value (" ++
+ show fdata ++ ")")
+ (all (all (isNothing . rentryValue)) fdata)
+ , printTestCase ("Got known fields via query fields (" ++ show fdefs'
+ ++ ")") (not $ hasUnknownFields fdefs')
+ ]
+
+-- ** Misc other tests
-- | Tests that requested names checking behaves as expected.
prop_getRequestedNames :: Property
@@ -258,5 +317,7 @@ testSuite "Query/Query"
, 'prop_queryGroup_Unknown
, 'prop_queryGroup_types
, 'case_queryGroup_allfields
+ , 'prop_queryJob_noUnknown
+ , 'prop_queryJob_Unknown
, 'prop_getRequestedNames
]
diff --git a/htools/Ganeti/Query/Job.hs b/htools/Ganeti/Query/Job.hs
new file mode 100644
index 0000000000000000000000000000000000000000..e41bfec0f5479350b123e76a6fe7e7f78347fd27
--- /dev/null
+++ b/htools/Ganeti/Query/Job.hs
@@ -0,0 +1,136 @@
+{-| Implementation of the Ganeti Query2 job queries.
+
+ -}
+
+{-
+
+Copyright (C) 2012 Google Inc.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.
+
+-}
+
+module Ganeti.Query.Job
+ ( RuntimeData
+ , fieldsMap
+ , loadRuntimeData
+ , wantArchived
+ ) where
+
+import qualified Data.Map as Map
+import qualified Text.JSON as J
+
+import Ganeti.BasicTypes
+import qualified Ganeti.Constants as C
+import Ganeti.JQueue
+import Ganeti.OpCodes (opSummary, metaOpCode)
+import Ganeti.Path
+import Ganeti.Query.Common
+import Ganeti.Query.Language
+import Ganeti.Query.Types
+import Ganeti.Types
+
+-- | The runtime data for a job.
+type RuntimeData = Result (QueuedJob, Bool)
+
+-- | Job priority explanation.
+jobPrioDoc :: String
+jobPrioDoc = "Current job priority (" ++ show C.opPrioLowest ++ " to " ++
+ show C.opPrioHighest ++ ")"
+
+-- | Timestamp doc.
+tsDoc :: String -> String
+tsDoc = (++ " (tuple containing seconds and microseconds)")
+
+-- | Wrapper for unavailable job.
+maybeJob :: (J.JSON a) =>
+ (QueuedJob -> a) -> RuntimeData -> JobId -> ResultEntry
+maybeJob _ (Bad _) _ = rsUnavail
+maybeJob f (Ok (v, _)) _ = rsNormal $ f v
+
+-- | Simple helper for a job getter.
+jobGetter :: (J.JSON a) => (QueuedJob -> a) -> FieldGetter JobId RuntimeData
+jobGetter = FieldRuntime . maybeJob
+
+-- | Simple helper for a per-opcode getter.
+opsGetter :: (J.JSON a) => (QueuedOpCode -> a) -> FieldGetter JobId RuntimeData
+opsGetter f = FieldRuntime $ maybeJob (map f . qjOps)
+
+-- | Archived field name.
+archivedField :: String
+archivedField = "archived"
+
+-- | Check whether we should look at archived jobs as well.
+wantArchived :: [FilterField] -> Bool
+wantArchived = (archivedField `elem`)
+
+-- | List of all node fields. FIXME: QFF_JOB_ID on the id field.
+jobFields :: FieldList JobId RuntimeData
+jobFields =
+ [ (FieldDefinition "id" "ID" QFTNumber "Job ID", FieldSimple rsNormal,
+ QffNormal)
+ , (FieldDefinition "status" "Status" QFTText "Job status",
+ jobGetter calcJobStatus, QffNormal)
+ , (FieldDefinition "priority" "Priority" QFTNumber jobPrioDoc,
+ jobGetter calcJobPriority, QffNormal)
+ , (FieldDefinition archivedField "Archived" QFTBool
+ "Whether job is archived",
+ FieldRuntime (\jinfo _ -> case jinfo of
+ Ok (_, archive) -> rsNormal archive
+ _ -> rsUnavail), QffNormal)
+ , (FieldDefinition "ops" "OpCodes" QFTOther "List of all opcodes",
+ opsGetter qoInput, QffNormal)
+ , (FieldDefinition "opresult" "OpCode_result" QFTOther
+ "List of opcodes results", opsGetter qoResult, QffNormal)
+ , (FieldDefinition "opstatus" "OpCode_status" QFTOther
+ "List of opcodes status", opsGetter qoStatus, QffNormal)
+ , (FieldDefinition "oplog" "OpCode_log" QFTOther
+ "List of opcode output logs", opsGetter qoLog, QffNormal)
+ , (FieldDefinition "opstart" "OpCode_start" QFTOther
+ "List of opcode start timestamps (before acquiring locks)",
+ opsGetter qoStartTimestamp, QffNormal)
+ , (FieldDefinition "opexec" "OpCode_exec" QFTOther
+ "List of opcode execution start timestamps (after acquiring locks)",
+ opsGetter qoExecTimestamp, QffNormal)
+ , (FieldDefinition "opend" "OpCode_end" QFTOther
+ "List of opcode execution end timestamps",
+ opsGetter qoEndTimestamp, QffNormal)
+ , (FieldDefinition "oppriority" "OpCode_prio" QFTOther
+ "List of opcode priorities", opsGetter qoPriority, QffNormal)
+ , (FieldDefinition "summary" "Summary" QFTOther
+ "List of per-opcode summaries",
+ opsGetter (opSummary . metaOpCode . qoInput), QffNormal)
+ , (FieldDefinition "received_ts" "Received" QFTOther
+ (tsDoc "Timestamp of when job was received"),
+ jobGetter qjReceivedTimestamp, QffTimestamp)
+ , (FieldDefinition "start_ts" "Start" QFTOther
+ (tsDoc "Timestamp of job start"),
+ jobGetter qjStartTimestamp, QffTimestamp)
+ , (FieldDefinition "end_ts" "End" QFTOther
+ (tsDoc "Timestamp of job end"),
+ jobGetter qjEndTimestamp, QffTimestamp)
+ ]
+
+-- | The node fields map.
+fieldsMap :: FieldMap JobId RuntimeData
+fieldsMap =
+ Map.fromList $ map (\v@(f, _, _) -> (fdefName f, v)) jobFields
+
+-- | Load the given jobs from disk.
+loadRuntimeData :: [JobId] -> Bool -> IO [RuntimeData]
+loadRuntimeData ids archived = do
+ qdir <- queueDir
+ mapM (loadJobFromDisk qdir archived) ids
diff --git a/htools/Ganeti/Query/Query.hs b/htools/Ganeti/Query/Query.hs
index d9997322775e4e101fc5081a209de9a6bd9d498f..026b5528fb4fec057a0a1c310774e96f1652147a 100644
--- a/htools/Ganeti/Query/Query.hs
+++ b/htools/Ganeti/Query/Query.hs
@@ -52,7 +52,8 @@ module Ganeti.Query.Query
, nameField
) where
-import Control.Monad (filterM)
+import Control.DeepSeq
+import Control.Monad (filterM, liftM, foldM)
import Control.Monad.Trans (lift)
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
@@ -60,17 +61,21 @@ import qualified Data.Map as Map
import qualified Text.JSON as J
import Ganeti.BasicTypes
-import Ganeti.Errors
import Ganeti.Config
+import Ganeti.Errors
+import Ganeti.JQueue
import Ganeti.JSON
import Ganeti.Rpc
-import Ganeti.Query.Language
+import Ganeti.Objects
import Ganeti.Query.Common
import Ganeti.Query.Filter
-import Ganeti.Query.Types
-import Ganeti.Query.Node
+import qualified Ganeti.Query.Job as Query.Job
import Ganeti.Query.Group
-import Ganeti.Objects
+import Ganeti.Query.Language
+import Ganeti.Query.Node
+import Ganeti.Query.Types
+import Ganeti.Path
+import Ganeti.Types
import Ganeti.Utils
-- * Helper functions
@@ -144,11 +149,26 @@ getRequestedNames qry =
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 ->
+ mapM (\e -> case e of
+ QuotedString s -> makeJobIdS s
+ NumericValue i -> makeJobId $ fromIntegral i
+ ) vals
+
-- | 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 qry = queryInner cfg live qry $ getRequestedNames qry
-- | Inner query execution function.
@@ -197,6 +217,58 @@ queryInner cfg _ (Query (ItemTypeOpCode QRGroup) 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
+ let wanted_names = getRequestedJobIDs qfilter
+ want_arch = Query.Job.wantArchived fields
+ rjids <- case wanted_names of
+ Bad msg -> resultT . Bad $ GenericError msg
+ Ok [] -> if live
+ -- we can check the filesystem for actual jobs
+ then lift $ liftM sortJobIDs
+ (determineJobDirectories rootdir want_arch >>=
+ getJobIDs)
+ -- else we shouldn't look at the filesystem...
+ else return []
+ Ok v -> resultT $ Ok v
+ cfilter <- resultT $ compileFilter Query.Job.fieldsMap qfilter
+ let selected = getSelectedFields Query.Job.fieldsMap fields
+ (fdefs, fgetters, _) = unzip3 selected
+ live' = live && needsLiveData fgetters
+ 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 <- resultT $
+ filterM (\jid -> evaluateFilter 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 want_arch jid
+ else return disabled_data
+ pass <- resultT $ evaluateFilter 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 =
@@ -213,6 +285,9 @@ queryFields (QueryFields (ItemTypeOpCode QRNode) fields) =
queryFields (QueryFields (ItemTypeOpCode QRGroup) fields) =
Ok $ fieldsExtractor groupFieldsMap fields
+queryFields (QueryFields (ItemTypeLuxi QRJob) fields) =
+ Ok $ fieldsExtractor Query.Job.fieldsMap fields
+
queryFields (QueryFields qkind _) =
Bad . GenericError $ "QueryFields '" ++ show qkind ++ "' not supported"
diff --git a/htools/Ganeti/Query/Server.hs b/htools/Ganeti/Query/Server.hs
index 7a751a6f1acecf113a7a4d78c03edef8f2da4cf8..db0af61fcd05b8973add545e2c9f11218e1ead92 100644
--- a/htools/Ganeti/Query/Server.hs
+++ b/htools/Ganeti/Query/Server.hs
@@ -163,6 +163,10 @@ handleCall cfg (QueryGroups names fields lock) =
handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRGroup)
(map Left names) fields lock
+handleCall cfg (QueryJobs names fields) =
+ handleClassicQuery cfg (Qlang.ItemTypeLuxi Qlang.QRJob)
+ (map (Right . fromIntegral . fromJobId) names) fields False
+
handleCall _ op =
return . Bad $
GenericError ("Luxi call '" ++ strOfOp op ++ "' not implemented")