code.grnet.gr Git - ganeti-local/blob - test/hs/Test/Ganeti/OpCodes.hs

   1 {-# LANGUAGE TemplateHaskell #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3
   4 {-| Unittests for ganeti-htools.
   5
   6 -}
   7
   8 {-
   9
  10 Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
  11
  12 This program is free software; you can redistribute it and/or modify
  13 it under the terms of the GNU General Public License as published by
  14 the Free Software Foundation; either version 2 of the License, or
  15 (at your option) any later version.
  16
  17 This program is distributed in the hope that it will be useful, but
  18 WITHOUT ANY WARRANTY; without even the implied warranty of
  19 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 General Public License for more details.
  21
  22 You should have received a copy of the GNU General Public License
  23 along with this program; if not, write to the Free Software
  24 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  25 02110-1301, USA.
  26
  27 -}
  28
  29 module Test.Ganeti.OpCodes
  30   ( testOpCodes
  31   , OpCodes.OpCode(..)
  32   ) where
  33
  34 import Test.HUnit as HUnit
  35 import Test.QuickCheck as QuickCheck
  36
  37 import Control.Applicative
  38 import Control.Monad
  39 import Data.Char
  40 import Data.List
  41 import qualified Data.Map as Map
  42 import qualified Text.JSON as J
  43 import Text.Printf (printf)
  44
  45 import Test.Ganeti.TestHelper
  46 import Test.Ganeti.TestCommon
  47 import Test.Ganeti.Types ()
  48 import Test.Ganeti.Query.Language ()
  49
  50 import Ganeti.BasicTypes
  51 import qualified Ganeti.Constants as C
  52 import qualified Ganeti.OpCodes as OpCodes
  53 import Ganeti.Types
  54 import Ganeti.OpParams
  55 import Ganeti.JSON
  56
  57 {-# ANN module "HLint: ignore Use camelCase" #-}
  58
  59 -- * Arbitrary instances
  60
  61 instance Arbitrary OpCodes.TagObject where
  62   arbitrary = oneof [ OpCodes.TagInstance <$> genFQDN
  63                     , OpCodes.TagNode     <$> genFQDN
  64                     , OpCodes.TagGroup    <$> genFQDN
  65                     , pure OpCodes.TagCluster
  66                     ]
  67
  68 arbitraryOpTagsGet :: Gen OpCodes.OpCode
  69 arbitraryOpTagsGet = do
  70   kind <- arbitrary
  71   OpCodes.OpTagsSet kind <$> arbitrary <*> genOpCodesTagName kind
  72
  73 arbitraryOpTagsSet :: Gen OpCodes.OpCode
  74 arbitraryOpTagsSet = do
  75   kind <- arbitrary
  76   OpCodes.OpTagsSet kind <$> genTags <*> genOpCodesTagName kind
  77
  78 arbitraryOpTagsDel :: Gen OpCodes.OpCode
  79 arbitraryOpTagsDel = do
  80   kind <- arbitrary
  81   OpCodes.OpTagsDel kind <$> genTags <*> genOpCodesTagName kind
  82
  83 $(genArbitrary ''OpCodes.ReplaceDisksMode)
  84
  85 $(genArbitrary ''DiskAccess)
  86
  87 instance Arbitrary OpCodes.DiskIndex where
  88   arbitrary = choose (0, C.maxDisks - 1) >>= OpCodes.mkDiskIndex
  89
  90 instance Arbitrary INicParams where
  91   arbitrary = INicParams <$> genMaybe genNameNE <*> genMaybe genName <*>
  92               genMaybe genNameNE <*> genMaybe genNameNE <*>
  93               genMaybe genNameNE <*> genMaybe genNameNE <*>
  94               genMaybe genNameNE
  95
  96 instance Arbitrary IDiskParams where
  97   arbitrary = IDiskParams <$> arbitrary <*> arbitrary <*>
  98               genMaybe genNameNE <*> genMaybe genNameNE <*>
  99               genMaybe genNameNE <*> genMaybe genNameNE
 100
 101 instance Arbitrary RecreateDisksInfo where
 102   arbitrary = oneof [ pure RecreateDisksAll
 103                     , RecreateDisksIndices <$> arbitrary
 104                     , RecreateDisksParams <$> arbitrary
 105                     ]
 106
 107 instance Arbitrary DdmOldChanges where
 108   arbitrary = oneof [ DdmOldIndex <$> arbitrary
 109                     , DdmOldMod   <$> arbitrary
 110                     ]
 111
 112 instance (Arbitrary a) => Arbitrary (SetParamsMods a) where
 113   arbitrary = oneof [ pure SetParamsEmpty
 114                     , SetParamsDeprecated <$> arbitrary
 115                     , SetParamsNew        <$> arbitrary
 116                     ]
 117
 118 instance Arbitrary ExportTarget where
 119   arbitrary = oneof [ ExportTargetLocal <$> genNodeNameNE
 120                     , ExportTargetRemote <$> pure []
 121                     ]
 122
 123 instance Arbitrary OpCodes.OpCode where
 124   arbitrary = do
 125     op_id <- elements OpCodes.allOpIDs
 126     case op_id of
 127       "OP_TEST_DELAY" ->
 128         OpCodes.OpTestDelay <$> arbitrary <*> arbitrary <*>
 129           genNodeNamesNE <*> return Nothing <*> arbitrary
 130       "OP_INSTANCE_REPLACE_DISKS" ->
 131         OpCodes.OpInstanceReplaceDisks <$> genFQDN <*> return Nothing <*>
 132           arbitrary <*> arbitrary <*> arbitrary <*> genDiskIndices <*>
 133           genMaybe genNodeNameNE <*> return Nothing <*> genMaybe genNameNE
 134       "OP_INSTANCE_FAILOVER" ->
 135         OpCodes.OpInstanceFailover <$> genFQDN <*> return Nothing <*>
 136         arbitrary <*> arbitrary <*> genMaybe genNodeNameNE <*>
 137         return Nothing <*> arbitrary <*> genMaybe genNameNE
 138       "OP_INSTANCE_MIGRATE" ->
 139         OpCodes.OpInstanceMigrate <$> genFQDN <*> return Nothing <*>
 140           arbitrary <*> arbitrary <*> genMaybe genNodeNameNE <*>
 141           return Nothing <*> arbitrary <*> arbitrary <*> arbitrary <*>
 142           genMaybe genNameNE <*> arbitrary
 143       "OP_TAGS_GET" ->
 144         arbitraryOpTagsGet
 145       "OP_TAGS_SEARCH" ->
 146         OpCodes.OpTagsSearch <$> genNameNE
 147       "OP_TAGS_SET" ->
 148         arbitraryOpTagsSet
 149       "OP_TAGS_DEL" ->
 150         arbitraryOpTagsDel
 151       "OP_CLUSTER_POST_INIT" -> pure OpCodes.OpClusterPostInit
 152       "OP_CLUSTER_DESTROY" -> pure OpCodes.OpClusterDestroy
 153       "OP_CLUSTER_QUERY" -> pure OpCodes.OpClusterQuery
 154       "OP_CLUSTER_VERIFY" ->
 155         OpCodes.OpClusterVerify <$> arbitrary <*> arbitrary <*>
 156           genSet Nothing <*> genSet Nothing <*> arbitrary <*>
 157           genMaybe genNameNE
 158       "OP_CLUSTER_VERIFY_CONFIG" ->
 159         OpCodes.OpClusterVerifyConfig <$> arbitrary <*> arbitrary <*>
 160           genSet Nothing <*> arbitrary
 161       "OP_CLUSTER_VERIFY_GROUP" ->
 162         OpCodes.OpClusterVerifyGroup <$> genNameNE <*> arbitrary <*>
 163           arbitrary <*> genSet Nothing <*> genSet Nothing <*> arbitrary
 164       "OP_CLUSTER_VERIFY_DISKS" -> pure OpCodes.OpClusterVerifyDisks
 165       "OP_GROUP_VERIFY_DISKS" ->
 166         OpCodes.OpGroupVerifyDisks <$> genNameNE
 167       "OP_CLUSTER_REPAIR_DISK_SIZES" ->
 168         OpCodes.OpClusterRepairDiskSizes <$> genNodeNamesNE
 169       "OP_CLUSTER_CONFIG_QUERY" ->
 170         OpCodes.OpClusterConfigQuery <$> genFieldsNE
 171       "OP_CLUSTER_RENAME" ->
 172         OpCodes.OpClusterRename <$> genNameNE
 173       "OP_CLUSTER_SET_PARAMS" ->
 174         OpCodes.OpClusterSetParams <$> arbitrary <*> emptyMUD <*> emptyMUD <*>
 175           arbitrary <*> genMaybe arbitrary <*>
 176           genMaybe genEmptyContainer <*> emptyMUD <*>
 177           genMaybe genEmptyContainer <*> genMaybe genEmptyContainer <*>
 178           genMaybe genEmptyContainer <*> genMaybe arbitrary <*>
 179           arbitrary <*> arbitrary <*> arbitrary <*>
 180           arbitrary <*> arbitrary <*> arbitrary <*>
 181           emptyMUD <*> emptyMUD <*> arbitrary <*>
 182           arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>
 183           arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>
 184           genMaybe (genName >>= mkNonEmpty)
 185       "OP_CLUSTER_REDIST_CONF" -> pure OpCodes.OpClusterRedistConf
 186       "OP_CLUSTER_ACTIVATE_MASTER_IP" ->
 187         pure OpCodes.OpClusterActivateMasterIp
 188       "OP_CLUSTER_DEACTIVATE_MASTER_IP" ->
 189         pure OpCodes.OpClusterDeactivateMasterIp
 190       "OP_QUERY" ->
 191         OpCodes.OpQuery <$> arbitrary <*> arbitrary <*> arbitrary <*>
 192         pure Nothing
 193       "OP_QUERY_FIELDS" ->
 194         OpCodes.OpQueryFields <$> arbitrary <*> arbitrary
 195       "OP_OOB_COMMAND" ->
 196         OpCodes.OpOobCommand <$> genNodeNamesNE <*> return Nothing <*>
 197           arbitrary <*> arbitrary <*> arbitrary <*>
 198           (arbitrary `suchThat` (>0))
 199       "OP_NODE_REMOVE" ->
 200         OpCodes.OpNodeRemove <$> genNodeNameNE <*> return Nothing
 201       "OP_NODE_ADD" ->
 202         OpCodes.OpNodeAdd <$> genNodeNameNE <*> emptyMUD <*> emptyMUD <*>
 203           genNameNE <*> genMaybe genNameNE <*> arbitrary <*>
 204           genMaybe genNameNE <*> arbitrary <*> arbitrary <*> emptyMUD
 205       "OP_NODE_QUERY" ->
 206         OpCodes.OpNodeQuery <$> genFieldsNE <*> genNamesNE <*> arbitrary
 207       "OP_NODE_QUERYVOLS" ->
 208         OpCodes.OpNodeQueryvols <$> arbitrary <*> genNodeNamesNE
 209       "OP_NODE_QUERY_STORAGE" ->
 210         OpCodes.OpNodeQueryStorage <$> arbitrary <*> arbitrary <*>
 211           genNodeNamesNE <*> genMaybe genNameNE
 212       "OP_NODE_MODIFY_STORAGE" ->
 213         OpCodes.OpNodeModifyStorage <$> genNodeNameNE <*> return Nothing <*>
 214           arbitrary <*> genMaybe genNameNE <*> pure emptyJSObject
 215       "OP_REPAIR_NODE_STORAGE" ->
 216         OpCodes.OpRepairNodeStorage <$> genNodeNameNE <*> return Nothing <*>
 217           arbitrary <*> genMaybe genNameNE <*> arbitrary
 218       "OP_NODE_SET_PARAMS" ->
 219         OpCodes.OpNodeSetParams <$> genNodeNameNE <*> return Nothing <*>
 220           arbitrary <*> emptyMUD <*> emptyMUD <*> arbitrary <*> arbitrary <*>
 221           arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>
 222           genMaybe genNameNE <*> emptyMUD <*> arbitrary
 223       "OP_NODE_POWERCYCLE" ->
 224         OpCodes.OpNodePowercycle <$> genNodeNameNE <*> return Nothing <*>
 225           arbitrary
 226       "OP_NODE_MIGRATE" ->
 227         OpCodes.OpNodeMigrate <$> genNodeNameNE <*> return Nothing <*>
 228           arbitrary <*> arbitrary <*> genMaybe genNodeNameNE <*>
 229           return Nothing <*> arbitrary <*> arbitrary <*> genMaybe genNameNE
 230       "OP_NODE_EVACUATE" ->
 231         OpCodes.OpNodeEvacuate <$> arbitrary <*> genNodeNameNE <*>
 232           return Nothing <*> genMaybe genNodeNameNE <*> return Nothing <*>
 233           genMaybe genNameNE <*> arbitrary
 234       "OP_INSTANCE_CREATE" ->
 235         OpCodes.OpInstanceCreate <$> genFQDN <*> arbitrary <*>
 236           arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>
 237           pure emptyJSObject <*> arbitrary <*> arbitrary <*> arbitrary <*>
 238           genMaybe genNameNE <*> pure emptyJSObject <*> arbitrary <*>
 239           genMaybe genNameNE <*> arbitrary <*> arbitrary <*> arbitrary <*>
 240           arbitrary <*> arbitrary <*> arbitrary <*> pure emptyJSObject <*>
 241           genMaybe genNameNE <*> genMaybe genNodeNameNE <*> return Nothing <*>
 242           genMaybe genNodeNameNE <*> return Nothing <*> genMaybe (pure []) <*>
 243           genMaybe genNodeNameNE <*> arbitrary <*> genMaybe genNodeNameNE <*>
 244           return Nothing <*> genMaybe genNodeNameNE <*> genMaybe genNameNE <*>
 245           arbitrary <*> (genTags >>= mapM mkNonEmpty)
 246       "OP_INSTANCE_MULTI_ALLOC" ->
 247         OpCodes.OpInstanceMultiAlloc <$> arbitrary <*> genMaybe genNameNE <*>
 248         pure []
 249       "OP_INSTANCE_REINSTALL" ->
 250         OpCodes.OpInstanceReinstall <$> genFQDN <*> return Nothing <*>
 251           arbitrary <*> genMaybe genNameNE <*> genMaybe (pure emptyJSObject)
 252       "OP_INSTANCE_REMOVE" ->
 253         OpCodes.OpInstanceRemove <$> genFQDN <*> return Nothing <*>
 254           arbitrary <*> arbitrary
 255       "OP_INSTANCE_RENAME" ->
 256         OpCodes.OpInstanceRename <$> genFQDN <*> return Nothing <*>
 257           genNodeNameNE <*> arbitrary <*> arbitrary
 258       "OP_INSTANCE_STARTUP" ->
 259         OpCodes.OpInstanceStartup <$> genFQDN <*> return Nothing <*>
 260           arbitrary <*> arbitrary <*> pure emptyJSObject <*>
 261           pure emptyJSObject <*> arbitrary <*> arbitrary
 262       "OP_INSTANCE_SHUTDOWN" ->
 263         OpCodes.OpInstanceShutdown <$> genFQDN <*> return Nothing <*>
 264           arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
 265       "OP_INSTANCE_REBOOT" ->
 266         OpCodes.OpInstanceReboot <$> genFQDN <*> return Nothing <*>
 267           arbitrary <*> arbitrary <*> arbitrary
 268       "OP_INSTANCE_MOVE" ->
 269         OpCodes.OpInstanceMove <$> genFQDN <*> return Nothing <*>
 270           arbitrary <*> arbitrary <*> genNodeNameNE <*> return Nothing <*>
 271           arbitrary
 272       "OP_INSTANCE_CONSOLE" -> OpCodes.OpInstanceConsole <$> genFQDN <*>
 273           return Nothing
 274       "OP_INSTANCE_ACTIVATE_DISKS" ->
 275         OpCodes.OpInstanceActivateDisks <$> genFQDN <*> return Nothing <*>
 276           arbitrary <*> arbitrary
 277       "OP_INSTANCE_DEACTIVATE_DISKS" ->
 278         OpCodes.OpInstanceDeactivateDisks <$> genFQDN <*> return Nothing <*>
 279           arbitrary
 280       "OP_INSTANCE_RECREATE_DISKS" ->
 281         OpCodes.OpInstanceRecreateDisks <$> genFQDN <*> return Nothing <*>
 282           arbitrary <*> genNodeNamesNE <*> return Nothing <*>
 283           genMaybe genNameNE
 284       "OP_INSTANCE_QUERY" ->
 285         OpCodes.OpInstanceQuery <$> genFieldsNE <*> arbitrary <*> genNamesNE
 286       "OP_INSTANCE_QUERY_DATA" ->
 287         OpCodes.OpInstanceQueryData <$> arbitrary <*>
 288           genNodeNamesNE <*> arbitrary
 289       "OP_INSTANCE_SET_PARAMS" ->
 290         OpCodes.OpInstanceSetParams <$> genFQDN <*> return Nothing <*>
 291           arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>
 292           arbitrary <*> pure emptyJSObject <*> arbitrary <*>
 293           pure emptyJSObject <*> arbitrary <*> genMaybe genNodeNameNE <*>
 294           return Nothing <*> genMaybe genNodeNameNE <*> return Nothing <*>
 295           genMaybe genNameNE <*> pure emptyJSObject <*> arbitrary <*>
 296           arbitrary <*> arbitrary
 297       "OP_INSTANCE_GROW_DISK" ->
 298         OpCodes.OpInstanceGrowDisk <$> genFQDN <*> return Nothing <*>
 299           arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
 300       "OP_INSTANCE_CHANGE_GROUP" ->
 301         OpCodes.OpInstanceChangeGroup <$> genFQDN <*> return Nothing <*>
 302           arbitrary <*> genMaybe genNameNE <*>
 303           genMaybe (resize maxNodes (listOf genNameNE))
 304       "OP_GROUP_ADD" ->
 305         OpCodes.OpGroupAdd <$> genNameNE <*> arbitrary <*>
 306           emptyMUD <*> genMaybe genEmptyContainer <*>
 307           emptyMUD <*> emptyMUD <*> emptyMUD
 308       "OP_GROUP_ASSIGN_NODES" ->
 309         OpCodes.OpGroupAssignNodes <$> genNameNE <*> arbitrary <*>
 310           genNodeNamesNE <*> return Nothing
 311       "OP_GROUP_QUERY" ->
 312         OpCodes.OpGroupQuery <$> genFieldsNE <*> genNamesNE
 313       "OP_GROUP_SET_PARAMS" ->
 314         OpCodes.OpGroupSetParams <$> genNameNE <*> arbitrary <*>
 315           emptyMUD <*> genMaybe genEmptyContainer <*>
 316           emptyMUD <*> emptyMUD <*> emptyMUD
 317       "OP_GROUP_REMOVE" ->
 318         OpCodes.OpGroupRemove <$> genNameNE
 319       "OP_GROUP_RENAME" ->
 320         OpCodes.OpGroupRename <$> genNameNE <*> genNameNE
 321       "OP_GROUP_EVACUATE" ->
 322         OpCodes.OpGroupEvacuate <$> genNameNE <*> arbitrary <*>
 323           genMaybe genNameNE <*> genMaybe genNamesNE
 324       "OP_OS_DIAGNOSE" ->
 325         OpCodes.OpOsDiagnose <$> genFieldsNE <*> genNamesNE
 326       "OP_EXT_STORAGE_DIAGNOSE" ->
 327         OpCodes.OpOsDiagnose <$> genFieldsNE <*> genNamesNE
 328       "OP_BACKUP_QUERY" ->
 329         OpCodes.OpBackupQuery <$> arbitrary <*> genNodeNamesNE
 330       "OP_BACKUP_PREPARE" ->
 331         OpCodes.OpBackupPrepare <$> genFQDN <*> return Nothing <*> arbitrary
 332       "OP_BACKUP_EXPORT" ->
 333         OpCodes.OpBackupExport <$> genFQDN <*> return Nothing <*>
 334           arbitrary <*> arbitrary <*> return Nothing <*> arbitrary <*>
 335           arbitrary <*> arbitrary <*> arbitrary <*> genMaybe (pure []) <*>
 336           genMaybe genNameNE
 337       "OP_BACKUP_REMOVE" ->
 338         OpCodes.OpBackupRemove <$> genFQDN <*> return Nothing
 339       "OP_TEST_ALLOCATOR" ->
 340         OpCodes.OpTestAllocator <$> arbitrary <*> arbitrary <*>
 341           genNameNE <*> genMaybe (pure []) <*> genMaybe (pure []) <*>
 342           arbitrary <*> genMaybe genNameNE <*>
 343           (genTags >>= mapM mkNonEmpty) <*>
 344           arbitrary <*> arbitrary <*> genMaybe genNameNE <*>
 345           arbitrary <*> genMaybe genNodeNamesNE <*> arbitrary <*>
 346           genMaybe genNamesNE <*> arbitrary <*> arbitrary
 347       "OP_TEST_JQUEUE" ->
 348         OpCodes.OpTestJqueue <$> arbitrary <*> arbitrary <*>
 349           resize 20 (listOf genFQDN) <*> arbitrary
 350       "OP_TEST_DUMMY" ->
 351         OpCodes.OpTestDummy <$> pure J.JSNull <*> pure J.JSNull <*>
 352           pure J.JSNull <*> pure J.JSNull
 353       "OP_NETWORK_ADD" ->
 354         OpCodes.OpNetworkAdd <$> genNameNE <*> genIPv4Network <*>
 355           genMaybe genIPv4Address <*> pure Nothing <*> pure Nothing <*>
 356           genMaybe genMacPrefix <*> genMaybe (listOf genIPv4Address) <*>
 357           arbitrary <*> (genTags >>= mapM mkNonEmpty)
 358       "OP_NETWORK_REMOVE" ->
 359         OpCodes.OpNetworkRemove <$> genNameNE <*> arbitrary
 360       "OP_NETWORK_SET_PARAMS" ->
 361         OpCodes.OpNetworkSetParams <$> genNameNE <*>
 362           genMaybe genIPv4Address <*> pure Nothing <*> pure Nothing <*>
 363           genMaybe genMacPrefix <*> genMaybe (listOf genIPv4Address) <*>
 364           genMaybe (listOf genIPv4Address)
 365       "OP_NETWORK_CONNECT" ->
 366         OpCodes.OpNetworkConnect <$> genNameNE <*> genNameNE <*>
 367           arbitrary <*> genNameNE <*> arbitrary
 368       "OP_NETWORK_DISCONNECT" ->
 369         OpCodes.OpNetworkDisconnect <$> genNameNE <*> genNameNE
 370       "OP_NETWORK_QUERY" ->
 371         OpCodes.OpNetworkQuery <$> genFieldsNE <*> arbitrary <*> genNamesNE
 372       "OP_RESTRICTED_COMMAND" ->
 373         OpCodes.OpRestrictedCommand <$> arbitrary <*> genNodeNamesNE <*>
 374           return Nothing <*> genNameNE
 375       _ -> fail $ "Undefined arbitrary for opcode " ++ op_id
 376
 377 -- | Generates one element of a reason trail
 378 genReasonElem :: Gen ReasonElem
 379 genReasonElem = (,,) <$> genFQDN <*> genFQDN <*> arbitrary
 380
 381 -- | Generates a reason trail
 382 genReasonTrail :: Gen ReasonTrail
 383 genReasonTrail = do
 384   size <- choose (0, 10)
 385   vectorOf size genReasonElem
 386
 387 instance Arbitrary OpCodes.CommonOpParams where
 388   arbitrary = OpCodes.CommonOpParams <$> arbitrary <*> arbitrary <*>
 389                 arbitrary <*> resize 5 arbitrary <*> genMaybe genName <*>
 390                 genReasonTrail
 391
 392 -- * Helper functions
 393
 394 -- | Empty JSObject.
 395 emptyJSObject :: J.JSObject J.JSValue
 396 emptyJSObject = J.toJSObject []
 397
 398 -- | Empty maybe unchecked dictionary.
 399 emptyMUD :: Gen (Maybe (J.JSObject J.JSValue))
 400 emptyMUD = genMaybe $ pure emptyJSObject
 401
 402 -- | Generates an empty container.
 403 genEmptyContainer :: (Ord a) => Gen (GenericContainer a b)
 404 genEmptyContainer = pure . GenericContainer $ Map.fromList []
 405
 406 -- | Generates list of disk indices.
 407 genDiskIndices :: Gen [DiskIndex]
 408 genDiskIndices = do
 409   cnt <- choose (0, C.maxDisks)
 410   genUniquesList cnt arbitrary
 411
 412 -- | Generates a list of node names.
 413 genNodeNames :: Gen [String]
 414 genNodeNames = resize maxNodes (listOf genFQDN)
 415
 416 -- | Generates a list of node names in non-empty string type.
 417 genNodeNamesNE :: Gen [NonEmptyString]
 418 genNodeNamesNE = genNodeNames >>= mapM mkNonEmpty
 419
 420 -- | Gets a node name in non-empty type.
 421 genNodeNameNE :: Gen NonEmptyString
 422 genNodeNameNE = genFQDN >>= mkNonEmpty
 423
 424 -- | Gets a name (non-fqdn) in non-empty type.
 425 genNameNE :: Gen NonEmptyString
 426 genNameNE = genName >>= mkNonEmpty
 427
 428 -- | Gets a list of names (non-fqdn) in non-empty type.
 429 genNamesNE :: Gen [NonEmptyString]
 430 genNamesNE = resize maxNodes (listOf genNameNE)
 431
 432 -- | Returns a list of non-empty fields.
 433 genFieldsNE :: Gen [NonEmptyString]
 434 genFieldsNE = genFields >>= mapM mkNonEmpty
 435
 436 -- | Generate a 3-byte MAC prefix.
 437 genMacPrefix :: Gen NonEmptyString
 438 genMacPrefix = do
 439   octets <- vectorOf 3 $ choose (0::Int, 255)
 440   mkNonEmpty . intercalate ":" $ map (printf "%02x") octets
 441
 442 -- | Arbitrary instance for MetaOpCode, defined here due to TH ordering.
 443 $(genArbitrary ''OpCodes.MetaOpCode)
 444
 445 -- | Small helper to check for a failed JSON deserialisation
 446 isJsonError :: J.Result a -> Bool
 447 isJsonError (J.Error _) = True
 448 isJsonError _           = False
 449
 450 -- * Test cases
 451
 452 -- | Check that opcode serialization is idempotent.
 453 prop_serialization :: OpCodes.OpCode -> Property
 454 prop_serialization = testSerialisation
 455
 456 -- | Check that Python and Haskell defined the same opcode list.
 457 case_AllDefined :: HUnit.Assertion
 458 case_AllDefined = do
 459   py_stdout <-
 460      runPython "from ganeti import opcodes\n\
 461                \from ganeti import serializer\n\
 462                \import sys\n\
 463                \print serializer.Dump([opid for opid in opcodes.OP_MAPPING])\n"
 464                ""
 465      >>= checkPythonResult
 466   py_ops <- case J.decode py_stdout::J.Result [String] of
 467                J.Ok ops -> return ops
 468                J.Error msg ->
 469                  HUnit.assertFailure ("Unable to decode opcode names: " ++ msg)
 470                  -- this already raised an expection, but we need it
 471                  -- for proper types
 472                  >> fail "Unable to decode opcode names"
 473   let hs_ops = sort OpCodes.allOpIDs
 474       extra_py = py_ops \\ hs_ops
 475       extra_hs = hs_ops \\ py_ops
 476   HUnit.assertBool ("Missing OpCodes from the Haskell code:\n" ++
 477                     unlines extra_py) (null extra_py)
 478   HUnit.assertBool ("Extra OpCodes in the Haskell code code:\n" ++
 479                     unlines extra_hs) (null extra_hs)
 480
 481 -- | Custom HUnit test case that forks a Python process and checks
 482 -- correspondence between Haskell-generated OpCodes and their Python
 483 -- decoded, validated and re-encoded version.
 484 --
 485 -- Note that we have a strange beast here: since launching Python is
 486 -- expensive, we don't do this via a usual QuickProperty, since that's
 487 -- slow (I've tested it, and it's indeed quite slow). Rather, we use a
 488 -- single HUnit assertion, and in it we manually use QuickCheck to
 489 -- generate 500 opcodes times the number of defined opcodes, which
 490 -- then we pass in bulk to Python. The drawbacks to this method are
 491 -- two fold: we cannot control the number of generated opcodes, since
 492 -- HUnit assertions don't get access to the test options, and for the
 493 -- same reason we can't run a repeatable seed. We should probably find
 494 -- a better way to do this, for example by having a
 495 -- separately-launched Python process (if not running the tests would
 496 -- be skipped).
 497 case_py_compat_types :: HUnit.Assertion
 498 case_py_compat_types = do
 499   let num_opcodes = length OpCodes.allOpIDs * 100
 500   opcodes <- genSample (vectorOf num_opcodes
 501                                    (arbitrary::Gen OpCodes.MetaOpCode))
 502   let with_sum = map (\o -> (OpCodes.opSummary $
 503                              OpCodes.metaOpCode o, o)) opcodes
 504       serialized = J.encode opcodes
 505   -- check for non-ASCII fields, usually due to 'arbitrary :: String'
 506   mapM_ (\op -> when (any (not . isAscii) (J.encode op)) .
 507                 HUnit.assertFailure $
 508                   "OpCode has non-ASCII fields: " ++ show op
 509         ) opcodes
 510   py_stdout <-
 511      runPython "from ganeti import opcodes\n\
 512                \from ganeti import serializer\n\
 513                \import sys\n\
 514                \op_data = serializer.Load(sys.stdin.read())\n\
 515                \decoded = [opcodes.OpCode.LoadOpCode(o) for o in op_data]\n\
 516                \for op in decoded:\n\
 517                \  op.Validate(True)\n\
 518                \encoded = [(op.Summary(), op.__getstate__())\n\
 519                \           for op in decoded]\n\
 520                \print serializer.Dump(encoded)" serialized
 521      >>= checkPythonResult
 522   let deserialised =
 523         J.decode py_stdout::J.Result [(String, OpCodes.MetaOpCode)]
 524   decoded <- case deserialised of
 525                J.Ok ops -> return ops
 526                J.Error msg ->
 527                  HUnit.assertFailure ("Unable to decode opcodes: " ++ msg)
 528                  -- this already raised an expection, but we need it
 529                  -- for proper types
 530                  >> fail "Unable to decode opcodes"
 531   HUnit.assertEqual "Mismatch in number of returned opcodes"
 532     (length decoded) (length with_sum)
 533   mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
 534         ) $ zip decoded with_sum
 535
 536 -- | Custom HUnit test case that forks a Python process and checks
 537 -- correspondence between Haskell OpCodes fields and their Python
 538 -- equivalent.
 539 case_py_compat_fields :: HUnit.Assertion
 540 case_py_compat_fields = do
 541   let hs_fields = sort $ map (\op_id -> (op_id, OpCodes.allOpFields op_id))
 542                          OpCodes.allOpIDs
 543   py_stdout <-
 544      runPython "from ganeti import opcodes\n\
 545                \import sys\n\
 546                \from ganeti import serializer\n\
 547                \fields = [(k, sorted([p[0] for p in v.OP_PARAMS]))\n\
 548                \           for k, v in opcodes.OP_MAPPING.items()]\n\
 549                \print serializer.Dump(fields)" ""
 550      >>= checkPythonResult
 551   let deserialised = J.decode py_stdout::J.Result [(String, [String])]
 552   py_fields <- case deserialised of
 553                  J.Ok v -> return $ sort v
 554                  J.Error msg ->
 555                    HUnit.assertFailure ("Unable to decode op fields: " ++ msg)
 556                    -- this already raised an expection, but we need it
 557                    -- for proper types
 558                    >> fail "Unable to decode op fields"
 559   HUnit.assertEqual "Mismatch in number of returned opcodes"
 560     (length hs_fields) (length py_fields)
 561   HUnit.assertEqual "Mismatch in defined OP_IDs"
 562     (map fst hs_fields) (map fst py_fields)
 563   mapM_ (\((py_id, py_flds), (hs_id, hs_flds)) -> do
 564            HUnit.assertEqual "Mismatch in OP_ID" py_id hs_id
 565            HUnit.assertEqual ("Mismatch in fields for " ++ hs_id)
 566              py_flds hs_flds
 567         ) $ zip py_fields hs_fields
 568
 569 -- | Checks that setOpComment works correctly.
 570 prop_setOpComment :: OpCodes.MetaOpCode -> String -> Property
 571 prop_setOpComment op comment =
 572   let (OpCodes.MetaOpCode common _) = OpCodes.setOpComment comment op
 573   in OpCodes.opComment common ==? Just comment
 574
 575 -- | Tests wrong (negative) disk index.
 576 prop_mkDiskIndex_fail :: QuickCheck.Positive Int -> Property
 577 prop_mkDiskIndex_fail (Positive i) =
 578   case mkDiskIndex (negate i) of
 579     Bad msg -> printTestCase "error message " $
 580                "Invalid value" `isPrefixOf` msg
 581     Ok v -> failTest $ "Succeeded to build disk index '" ++ show v ++
 582                        "' from negative value " ++ show (negate i)
 583
 584 -- | Tests a few invalid 'readRecreateDisks' cases.
 585 case_readRecreateDisks_fail :: Assertion
 586 case_readRecreateDisks_fail = do
 587   assertBool "null" $
 588     isJsonError (J.readJSON J.JSNull::J.Result RecreateDisksInfo)
 589   assertBool "string" $
 590     isJsonError (J.readJSON (J.showJSON "abc")::J.Result RecreateDisksInfo)
 591
 592 -- | Tests a few invalid 'readDdmOldChanges' cases.
 593 case_readDdmOldChanges_fail :: Assertion
 594 case_readDdmOldChanges_fail = do
 595   assertBool "null" $
 596     isJsonError (J.readJSON J.JSNull::J.Result DdmOldChanges)
 597   assertBool "string" $
 598     isJsonError (J.readJSON (J.showJSON "abc")::J.Result DdmOldChanges)
 599
 600 -- | Tests a few invalid 'readExportTarget' cases.
 601 case_readExportTarget_fail :: Assertion
 602 case_readExportTarget_fail = do
 603   assertBool "null" $
 604     isJsonError (J.readJSON J.JSNull::J.Result ExportTarget)
 605   assertBool "int" $
 606     isJsonError (J.readJSON (J.showJSON (5::Int))::J.Result ExportTarget)
 607
 608 testSuite "OpCodes"
 609             [ 'prop_serialization
 610             , 'case_AllDefined
 611             , 'case_py_compat_types
 612             , 'case_py_compat_fields
 613             , 'prop_setOpComment
 614             , 'prop_mkDiskIndex_fail
 615             , 'case_readRecreateDisks_fail
 616             , 'case_readDdmOldChanges_fail
 617             , 'case_readExportTarget_fail
 618             ]