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