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