diff --git a/htest/Test/Ganeti/Query/Filter.hs b/htest/Test/Ganeti/Query/Filter.hs index 28947415d91bb0ae287168b3b3b2397ae85c887d..f011d208fe1ce2fba81ab1a233c5a5bc808dba8d 100644 --- a/htest/Test/Ganeti/Query/Filter.hs +++ b/htest/Test/Ganeti/Query/Filter.hs @@ -59,7 +59,7 @@ checkQueryResults cfg qr descr expected = monadicIO $ do -- | Makes a node name query, given a filter. makeNodeQuery :: Filter FilterField -> Query -makeNodeQuery = Query QRNode ["name"] +makeNodeQuery = Query (ItemTypeOpCode QRNode) ["name"] -- | Checks if a given operation failed. expectBadQuery :: ConfigData -> Query -> String -> Property diff --git a/htest/Test/Ganeti/Query/Language.hs b/htest/Test/Ganeti/Query/Language.hs index 5c4cd5cfb792418a2accfdee6cc8dc9c4e063a4c..d5b9eb6ddae782104c6312711e0511de97143f54 100644 --- a/htest/Test/Ganeti/Query/Language.hs +++ b/htest/Test/Ganeti/Query/Language.hs @@ -74,6 +74,10 @@ genFilter' n = n'' = max n' 2 -- but we don't want empty or 1-element lists, -- so use this for and/or filter list length +$(genArbitrary ''QueryTypeOp) + +$(genArbitrary ''QueryTypeLuxi) + $(genArbitrary ''ItemType) instance Arbitrary FilterRegex where @@ -148,6 +152,10 @@ prop_fieldsresult_serialisation :: Property prop_fieldsresult_serialisation = forAll (resize 20 arbitrary::Gen QueryFieldsResult) testSerialisation +-- | Tests 'ItemType' serialisation. +prop_itemtype_serialisation :: ItemType -> Property +prop_itemtype_serialisation = testSerialisation + testSuite "Query/Language" [ 'prop_filter_serialisation , 'prop_filterregex_instances @@ -156,4 +164,5 @@ testSuite "Query/Language" , 'prop_fielddef_serialisation , 'prop_resultentry_serialisation , 'prop_fieldsresult_serialisation + , 'prop_itemtype_serialisation ] diff --git a/htest/Test/Ganeti/Query/Query.hs b/htest/Test/Ganeti/Query/Query.hs index b9480082f470fbe42d42eecd3c312120fc6fbd65..71ada69767d50b681c48060ea23cca583a3860da 100644 --- a/htest/Test/Ganeti/Query/Query.hs +++ b/htest/Test/Ganeti/Query/Query.hs @@ -66,9 +66,10 @@ prop_queryNode_noUnknown = forAll (choose (0, maxNodes) >>= genEmptyCluster) $ \cluster -> forAll (elements (Map.keys nodeFieldsMap)) $ \field -> monadicIO $ do QueryResult fdefs fdata <- - run (query cluster False (Query QRNode [field] EmptyFilter)) >>= resultProp + run (query cluster False (Query (ItemTypeOpCode QRNode) + [field] EmptyFilter)) >>= resultProp QueryFieldsResult fdefs' <- - resultProp $ queryFields (QueryFields QRNode [field]) + resultProp $ queryFields (QueryFields (ItemTypeOpCode QRNode) [field]) stop $ conjoin [ printTestCase ("Got unknown fields via query (" ++ show fdefs ++ ")") (hasUnknownFields fdefs) @@ -86,9 +87,10 @@ prop_queryNode_Unknown = forAll (arbitrary `suchThat` (`notElem` Map.keys nodeFieldsMap)) $ \field -> monadicIO $ do QueryResult fdefs fdata <- - run (query cluster False (Query QRNode [field] EmptyFilter)) >>= resultProp + run (query cluster False (Query (ItemTypeOpCode QRNode) + [field] EmptyFilter)) >>= resultProp QueryFieldsResult fdefs' <- - resultProp $ queryFields (QueryFields QRNode [field]) + resultProp $ queryFields (QueryFields (ItemTypeOpCode QRNode) [field]) stop $ conjoin [ printTestCase ("Got known fields via query (" ++ show fdefs ++ ")") (not $ hasUnknownFields fdefs) @@ -132,7 +134,8 @@ prop_queryNode_types = forAll (genEmptyCluster numnodes) $ \cfg -> forAll (elements (Map.keys nodeFieldsMap)) $ \field -> monadicIO $ do QueryResult fdefs fdata <- - run (query cfg False (Query QRNode [field] EmptyFilter)) >>= resultProp + run (query cfg False (Query (ItemTypeOpCode QRNode) + [field] EmptyFilter)) >>= resultProp stop $ conjoin [ printTestCase ("Inconsistent result entries (" ++ show fdata ++ ")") (conjoin $ map (conjoin . zipWith checkResultType fdefs) fdata) @@ -147,7 +150,7 @@ prop_queryNode_types = -- | Test that queryFields with empty fields list returns all node fields. case_queryNode_allfields :: Assertion case_queryNode_allfields = do - fdefs <- case queryFields (QueryFields QRNode []) of + fdefs <- case queryFields (QueryFields (ItemTypeOpCode QRNode) []) of Bad msg -> fail $ "Error in query all fields: " ++ formatError msg Ok (QueryFieldsResult v) -> return v @@ -163,10 +166,11 @@ prop_queryGroup_noUnknown = forAll (choose (0, maxNodes) >>= genEmptyCluster) $ \cluster -> forAll (elements (Map.keys groupFieldsMap)) $ \field -> monadicIO $ do QueryResult fdefs fdata <- - run (query cluster False (Query QRGroup [field] EmptyFilter)) >>= + run (query cluster False (Query (ItemTypeOpCode QRGroup) + [field] EmptyFilter)) >>= resultProp QueryFieldsResult fdefs' <- - resultProp $ queryFields (QueryFields QRGroup [field]) + resultProp $ queryFields (QueryFields (ItemTypeOpCode QRGroup) [field]) stop $ conjoin [ printTestCase ("Got unknown fields via query (" ++ show fdefs ++ ")") (hasUnknownFields fdefs) @@ -183,9 +187,10 @@ prop_queryGroup_Unknown = forAll (arbitrary `suchThat` (`notElem` Map.keys groupFieldsMap)) $ \field -> monadicIO $ do QueryResult fdefs fdata <- - run (query cluster False (Query QRGroup [field] EmptyFilter)) >>= resultProp + run (query cluster False (Query (ItemTypeOpCode QRGroup) + [field] EmptyFilter)) >>= resultProp QueryFieldsResult fdefs' <- - resultProp $ queryFields (QueryFields QRGroup [field]) + resultProp $ queryFields (QueryFields (ItemTypeOpCode QRGroup) [field]) stop $ conjoin [ printTestCase ("Got known fields via query (" ++ show fdefs ++ ")") (not $ hasUnknownFields fdefs) @@ -205,7 +210,8 @@ prop_queryGroup_types = forAll (genEmptyCluster numnodes) $ \cfg -> forAll (elements (Map.keys groupFieldsMap)) $ \field -> monadicIO $ do QueryResult fdefs fdata <- - run (query cfg False (Query QRGroup [field] EmptyFilter)) >>= resultProp + run (query cfg False (Query (ItemTypeOpCode QRGroup) + [field] EmptyFilter)) >>= resultProp stop $ conjoin [ printTestCase ("Inconsistent result entries (" ++ show fdata ++ ")") (conjoin $ map (conjoin . zipWith checkResultType fdefs) fdata) @@ -216,7 +222,7 @@ prop_queryGroup_types = case_queryGroup_allfields :: Assertion case_queryGroup_allfields = do - fdefs <- case queryFields (QueryFields QRGroup []) of + fdefs <- case queryFields (QueryFields (ItemTypeOpCode QRGroup) []) of Bad msg -> fail $ "Error in query all fields: " ++ formatError msg Ok (QueryFieldsResult v) -> return v @@ -230,7 +236,7 @@ case_queryGroup_allfields = do prop_getRequestedNames :: Property prop_getRequestedNames = forAll getName $ \node1 -> - let chk = getRequestedNames . Query QRNode [] + let chk = getRequestedNames . Query (ItemTypeOpCode QRNode) [] q_node1 = QuotedString node1 eq_name = EQFilter "name" eq_node1 = eq_name q_node1 diff --git a/htools/Ganeti/HTools/Backend/Luxi.hs b/htools/Ganeti/HTools/Backend/Luxi.hs index 2f293e8b7448c9bbf783983197361cc7ecfa076a..b3178089788a617512fd200fad78328b1a6a0ce4 100644 --- a/htools/Ganeti/HTools/Backend/Luxi.hs +++ b/htools/Ganeti/HTools/Backend/Luxi.hs @@ -101,17 +101,19 @@ genericConvert otype oname oattr = -- | The input data for node query. queryNodesMsg :: L.LuxiOp queryNodesMsg = - L.Query Qlang.QRNode ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree", - "ctotal", "offline", "drained", "vm_capable", - "ndp/spindle_count", "group.uuid"] Qlang.EmptyFilter + L.Query (Qlang.ItemTypeOpCode Qlang.QRNode) + ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree", + "ctotal", "offline", "drained", "vm_capable", + "ndp/spindle_count", "group.uuid"] Qlang.EmptyFilter -- | The input data for instance query. queryInstancesMsg :: L.LuxiOp queryInstancesMsg = - L.Query Qlang.QRInstance ["name", "disk_usage", "be/memory", "be/vcpus", - "status", "pnode", "snodes", "tags", "oper_ram", - "be/auto_balance", "disk_template", - "be/spindle_use"] Qlang.EmptyFilter + L.Query (Qlang.ItemTypeOpCode Qlang.QRInstance) + ["name", "disk_usage", "be/memory", "be/vcpus", + "status", "pnode", "snodes", "tags", "oper_ram", + "be/auto_balance", "disk_template", + "be/spindle_use"] Qlang.EmptyFilter -- | The input data for cluster query. queryClusterInfoMsg :: L.LuxiOp @@ -120,8 +122,9 @@ queryClusterInfoMsg = L.QueryClusterInfo -- | The input data for node group query. queryGroupsMsg :: L.LuxiOp queryGroupsMsg = - L.Query Qlang.QRGroup ["uuid", "name", "alloc_policy", "ipolicy", "tags"] - Qlang.EmptyFilter + L.Query (Qlang.ItemTypeOpCode Qlang.QRGroup) + ["uuid", "name", "alloc_policy", "ipolicy", "tags"] + Qlang.EmptyFilter -- | Wraper over 'callMethod' doing node query. queryNodes :: L.Client -> IO (Result JSValue) diff --git a/htools/Ganeti/Query/Language.hs b/htools/Ganeti/Query/Language.hs index 26155f25e18b88cbf04deb7e2ff80261f3c3f102..f92540ac05d35b3080ccb04617a8e3ba18bb3175 100644 --- a/htools/Ganeti/Query/Language.hs +++ b/htools/Ganeti/Query/Language.hs @@ -47,6 +47,8 @@ module Ganeti.Query.Language , ResultStatus(..) , ResultValue , ItemType(..) + , QueryTypeOp(..) + , QueryTypeLuxi(..) , checkRS ) where @@ -98,17 +100,49 @@ $(declareSADT "FieldType" $(makeJSONInstance ''FieldType) -- | Supported items on which Qlang works. -$(declareSADT "ItemType" +$(declareSADT "QueryTypeOp" [ ("QRCluster", 'C.qrCluster ) , ("QRInstance", 'C.qrInstance ) , ("QRNode", 'C.qrNode ) - , ("QRLock", 'C.qrLock ) , ("QRGroup", 'C.qrGroup ) , ("QROs", 'C.qrOs ) - , ("QRJob", 'C.qrJob ) , ("QRExport", 'C.qrExport ) ]) -$(makeJSONInstance ''ItemType) +$(makeJSONInstance ''QueryTypeOp) + +-- | Supported items on which Qlang works. +$(declareSADT "QueryTypeLuxi" + [ ("QRLock", 'C.qrLock ) + , ("QRJob", 'C.qrJob ) + ]) +$(makeJSONInstance ''QueryTypeLuxi) + +-- | Overall query type. +data ItemType = ItemTypeLuxi QueryTypeLuxi + | ItemTypeOpCode QueryTypeOp + deriving (Show, Read, Eq) + +-- | Custom JSON decoder for 'ItemType'. +decodeItemType :: (Monad m) => JSValue -> m ItemType +decodeItemType (JSString s) = + case queryTypeOpFromRaw s' of + Just v -> return $ ItemTypeOpCode v + Nothing -> + case queryTypeLuxiFromRaw s' of + Just v -> return $ ItemTypeLuxi v + Nothing -> + fail $ "Can't parse value '" ++ s' ++ "' as neither" + ++ "QueryTypeLuxi nor QueryTypeOp" + where s' = fromJSString s +decodeItemType v = fail $ "Invalid value '" ++ show (pp_value v) ++ + "for query type" + +-- | Custom JSON instance for 'ItemType' since its encoding is not +-- consistent with the data type itself. +instance JSON ItemType where + showJSON (ItemTypeLuxi x) = showJSON x + showJSON (ItemTypeOpCode y) = showJSON y + readJSON = decodeItemType -- * Sub data types for query2 queries and responses. diff --git a/htools/Ganeti/Query/Query.hs b/htools/Ganeti/Query/Query.hs index 49a0490413c7033cdde695adfa317c962b53c570..70fe0c06cfb79486a52e855abe5547e7ead95f98 100644 --- a/htools/Ganeti/Query/Query.hs +++ b/htools/Ganeti/Query/Query.hs @@ -124,8 +124,8 @@ needsNames (Query kind _ qfilter) = requestedNames (nameField kind) qfilter -- | Computes the name field for different query types. nameField :: ItemType -> FilterField -nameField QRJob = "id" -nameField _ = "name" +nameField (ItemTypeLuxi QRJob) = "id" +nameField _ = "name" -- | Extracts all quoted strings from a list, ignoring the -- 'NumericValue' entries. @@ -157,7 +157,8 @@ queryInner :: ConfigData -- ^ The current configuration -> [String] -- ^ Requested names -> IO (ErrorResult QueryResult) -- ^ Result -queryInner cfg live (Query QRNode fields qfilter) wanted = runResultT $ do +queryInner cfg live (Query (ItemTypeOpCode QRNode) fields qfilter) wanted = + runResultT $ do cfilter <- resultT $ compileFilter nodeFieldsMap qfilter let selected = getSelectedFields nodeFieldsMap fields (fdefs, fgetters) = unzip selected @@ -177,7 +178,8 @@ queryInner cfg live (Query QRNode fields qfilter) wanted = runResultT $ do nruntimes return QueryResult { qresFields = fdefs, qresData = fdata } -queryInner cfg _ (Query QRGroup fields qfilter) wanted = return $ do +queryInner cfg _ (Query (ItemTypeOpCode QRGroup) fields qfilter) wanted = + return $ do cfilter <- compileFilter groupFieldsMap qfilter let selected = getSelectedFields groupFieldsMap fields (fdefs, fgetters) = unzip selected @@ -204,10 +206,10 @@ fieldsExtractor fieldsMap fields = -- | Query fields call. queryFields :: QueryFields -> ErrorResult QueryFieldsResult -queryFields (QueryFields QRNode fields) = +queryFields (QueryFields (ItemTypeOpCode QRNode) fields) = Ok $ fieldsExtractor nodeFieldsMap fields -queryFields (QueryFields QRGroup fields) = +queryFields (QueryFields (ItemTypeOpCode QRGroup) fields) = Ok $ fieldsExtractor groupFieldsMap fields queryFields (QueryFields qkind _) = diff --git a/htools/Ganeti/Query/Server.hs b/htools/Ganeti/Query/Server.hs index 8f2bfeb1f6aa9bb31a446bd41fbacc1f50372ee3..1d2f8e6a8b9e8ec987369f1d2979c7877dbe2cb8 100644 --- a/htools/Ganeti/Query/Server.hs +++ b/htools/Ganeti/Query/Server.hs @@ -156,10 +156,10 @@ handleCall _ (QueryFields qkind qfields) = do return $ J.showJSON <$> result handleCall cfg (QueryNodes names fields lock) = - handleClassicQuery cfg Qlang.QRNode names fields lock + handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRNode) names fields lock handleCall cfg (QueryGroups names fields lock) = - handleClassicQuery cfg Qlang.QRGroup names fields lock + handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRGroup) names fields lock handleCall _ op = return . Bad $