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