+
+-- ** CLI tests
+
+-- | Test correct parsing.
+prop_CLI_parseISpec descr dsk mem cpu =
+ let str = printf "%d,%d,%d" dsk mem cpu
+ in CLI.parseISpecString descr str ==? Types.Ok (Types.RSpec cpu mem dsk)
+
+-- | Test parsing failure due to wrong section count.
+prop_CLI_parseISpecFail descr =
+ forAll (choose (0,100) `suchThat` ((/=) 3)) $ \nelems ->
+ forAll (replicateM nelems arbitrary) $ \values ->
+ let str = intercalate "," $ map show (values::[Int])
+ in case CLI.parseISpecString descr str of
+ Types.Ok v -> failTest $ "Expected failure, got " ++ show v
+ _ -> property True
+
+-- | Test parseYesNo.
+prop_CLI_parseYesNo def testval val =
+ forAll (elements [val, "yes", "no"]) $ \actual_val ->
+ if testval
+ then CLI.parseYesNo def Nothing ==? Types.Ok def
+ else let result = CLI.parseYesNo def (Just actual_val)
+ in if actual_val `elem` ["yes", "no"]
+ then result ==? Types.Ok (actual_val == "yes")
+ else property $ Types.isBad result
+
+-- | Helper to check for correct parsing of string arg.
+checkStringArg val (opt, fn) =
+ let GetOpt.Option _ longs _ _ = opt
+ in case longs of
+ [] -> failTest "no long options?"
+ cmdarg:_ ->
+ case CLI.parseOptsInner ["--" ++ cmdarg ++ "=" ++ val] "prog" [opt] of
+ Left e -> failTest $ "Failed to parse option: " ++ show e
+ Right (options, _) -> fn options ==? Just val
+
+-- | Test a few string arguments.
+prop_CLI_StringArg argument =
+ let args = [ (CLI.oDataFile, CLI.optDataFile)
+ , (CLI.oDynuFile, CLI.optDynuFile)
+ , (CLI.oSaveCluster, CLI.optSaveCluster)
+ , (CLI.oReplay, CLI.optReplay)
+ , (CLI.oPrintCommands, CLI.optShowCmds)
+ , (CLI.oLuxiSocket, CLI.optLuxi)
+ ]
+ in conjoin $ map (checkStringArg argument) args
+
+-- | Helper to test that a given option is accepted OK with quick exit.
+checkEarlyExit name options param =
+ case CLI.parseOptsInner [param] name options of
+ Left (code, _) -> if code == 0
+ then property True
+ else failTest $ "Program " ++ name ++
+ " returns invalid code " ++ show code ++
+ " for option " ++ param
+ _ -> failTest $ "Program " ++ name ++ " doesn't consider option " ++
+ param ++ " as early exit one"
+
+-- | Test that all binaries support some common options. There is
+-- nothing actually random about this test...
+prop_CLI_stdopts =
+ let params = ["-h", "--help", "-V", "--version"]
+ opts = map (\(name, (_, o)) -> (name, o)) Program.personalities
+ -- apply checkEarlyExit across the cartesian product of params and opts
+ in conjoin [checkEarlyExit n o p | p <- params, (n, o) <- opts]
+
+testSuite "CLI"
+ [ 'prop_CLI_parseISpec
+ , 'prop_CLI_parseISpecFail
+ , 'prop_CLI_parseYesNo
+ , 'prop_CLI_StringArg
+ , 'prop_CLI_stdopts
+ ]
+
+-- * JSON tests
+
+prop_JSON_toArray :: [Int] -> Property
+prop_JSON_toArray intarr =
+ let arr = map J.showJSON intarr in
+ case JSON.toArray (J.JSArray arr) of
+ Types.Ok arr' -> arr ==? arr'
+ Types.Bad err -> failTest $ "Failed to parse array: " ++ err
+
+prop_JSON_toArrayFail :: Int -> String -> Bool -> Property
+prop_JSON_toArrayFail i s b =
+ -- poor man's instance Arbitrary JSValue
+ forAll (elements [J.showJSON i, J.showJSON s, J.showJSON b]) $ \item ->
+ case JSON.toArray item of
+ Types.Bad _ -> property True
+ Types.Ok result -> failTest $ "Unexpected parse, got " ++ show result
+
+testSuite "JSON"
+ [ 'prop_JSON_toArray
+ , 'prop_JSON_toArrayFail
+ ]
+
+-- * Luxi tests
+
+instance Arbitrary Luxi.LuxiReq where
+ arbitrary = elements [minBound..maxBound]
+
+instance Arbitrary Luxi.QrViaLuxi where
+ arbitrary = elements [minBound..maxBound]
+
+instance Arbitrary Luxi.LuxiOp where
+ arbitrary = do
+ lreq <- arbitrary
+ case lreq of
+ Luxi.ReqQuery -> Luxi.Query <$> arbitrary <*> getFields <*> arbitrary
+ Luxi.ReqQueryNodes -> Luxi.QueryNodes <$> (listOf getFQDN) <*>
+ getFields <*> arbitrary
+ Luxi.ReqQueryGroups -> Luxi.QueryGroups <$> arbitrary <*>
+ arbitrary <*> arbitrary
+ Luxi.ReqQueryInstances -> Luxi.QueryInstances <$> (listOf getFQDN) <*>
+ getFields <*> arbitrary
+ Luxi.ReqQueryJobs -> Luxi.QueryJobs <$> arbitrary <*> getFields
+ Luxi.ReqQueryExports -> Luxi.QueryExports <$>
+ (listOf getFQDN) <*> arbitrary
+ Luxi.ReqQueryConfigValues -> Luxi.QueryConfigValues <$> getFields
+ Luxi.ReqQueryClusterInfo -> pure Luxi.QueryClusterInfo
+ Luxi.ReqQueryTags -> Luxi.QueryTags <$> getName <*> getFQDN
+ Luxi.ReqSubmitJob -> Luxi.SubmitJob <$> (resize maxOpCodes arbitrary)
+ Luxi.ReqSubmitManyJobs -> Luxi.SubmitManyJobs <$>
+ (resize maxOpCodes arbitrary)
+ Luxi.ReqWaitForJobChange -> Luxi.WaitForJobChange <$> arbitrary <*>
+ getFields <*> pure J.JSNull <*>
+ pure J.JSNull <*> arbitrary
+ Luxi.ReqArchiveJob -> Luxi.ArchiveJob <$> arbitrary
+ Luxi.ReqAutoArchiveJobs -> Luxi.AutoArchiveJobs <$> arbitrary <*>
+ arbitrary
+ Luxi.ReqCancelJob -> Luxi.CancelJob <$> arbitrary
+ Luxi.ReqSetDrainFlag -> Luxi.SetDrainFlag <$> arbitrary
+ Luxi.ReqSetWatcherPause -> Luxi.SetWatcherPause <$> arbitrary
+
+-- | Simple check that encoding/decoding of LuxiOp works.
+prop_Luxi_CallEncoding :: Luxi.LuxiOp -> Property
+prop_Luxi_CallEncoding op =
+ (Luxi.validateCall (Luxi.buildCall op) >>= Luxi.decodeCall) ==? Types.Ok op
+
+testSuite "LUXI"
+ [ 'prop_Luxi_CallEncoding
+ ]
+
+-- * Ssconf tests
+
+instance Arbitrary Ssconf.SSKey where
+ arbitrary = elements [minBound..maxBound]
+
+prop_Ssconf_filename key =
+ printTestCase "Key doesn't start with correct prefix" $
+ Ssconf.sSFilePrefix `isPrefixOf` Ssconf.keyToFilename (Just "") key
+
+testSuite "Ssconf"
+ [ 'prop_Ssconf_filename
+ ]
projects / ganeti-local / blobdiff