code.grnet.gr Git - ganeti-local/blob - htest/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 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
  78
  79 instance Arbitrary IDiskParams where
  80   arbitrary = IDiskParams <$> arbitrary <*> arbitrary <*>
  81               genMaybe genNameNE <*> genMaybe genNameNE <*>
  82               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 <$> 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
 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 genNameNE <*>
 265           pure emptyJSObject <*> arbitrary <*> arbitrary <*> arbitrary
 266       "OP_INSTANCE_GROW_DISK" ->
 267         OpCodes.OpInstanceGrowDisk <$> genFQDN <*> arbitrary <*>
 268           arbitrary <*> arbitrary <*> arbitrary
 269       "OP_INSTANCE_CHANGE_GROUP" ->
 270         OpCodes.OpInstanceChangeGroup <$> genFQDN <*> arbitrary <*>
 271           genMaybe genNameNE <*> genMaybe (resize maxNodes (listOf genNameNE))
 272       "OP_GROUP_ADD" ->
 273         OpCodes.OpGroupAdd <$> genNameNE <*> arbitrary <*>
 274           emptyMUD <*> genMaybe genEmptyContainer <*>
 275           emptyMUD <*> emptyMUD <*> emptyMUD
 276       "OP_GROUP_ASSIGN_NODES" ->
 277         OpCodes.OpGroupAssignNodes <$> genNameNE <*> arbitrary <*>
 278           genNodeNamesNE
 279       "OP_GROUP_QUERY" ->
 280         OpCodes.OpGroupQuery <$> genFieldsNE <*> genNamesNE
 281       "OP_GROUP_SET_PARAMS" ->
 282         OpCodes.OpGroupSetParams <$> genNameNE <*> arbitrary <*>
 283           emptyMUD <*> genMaybe genEmptyContainer <*>
 284           emptyMUD <*> emptyMUD <*> emptyMUD
 285       "OP_GROUP_REMOVE" ->
 286         OpCodes.OpGroupRemove <$> genNameNE
 287       "OP_GROUP_RENAME" ->
 288         OpCodes.OpGroupRename <$> genNameNE <*> genNameNE
 289       "OP_GROUP_EVACUATE" ->
 290         OpCodes.OpGroupEvacuate <$> genNameNE <*> arbitrary <*>
 291           genMaybe genNameNE <*> genMaybe genNamesNE
 292       "OP_OS_DIAGNOSE" ->
 293         OpCodes.OpOsDiagnose <$> genFieldsNE <*> genNamesNE
 294       "OP_EXT_STORAGE_DIAGNOSE" ->
 295         OpCodes.OpOsDiagnose <$> genFieldsNE <*> genNamesNE
 296       "OP_BACKUP_QUERY" ->
 297         OpCodes.OpBackupQuery <$> arbitrary <*> genNodeNamesNE
 298       "OP_BACKUP_PREPARE" ->
 299         OpCodes.OpBackupPrepare <$> genFQDN <*> arbitrary
 300       "OP_BACKUP_EXPORT" ->
 301         OpCodes.OpBackupExport <$> genFQDN <*> arbitrary <*>
 302           arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>
 303           arbitrary <*> genMaybe (pure []) <*> genMaybe genNameNE
 304       "OP_BACKUP_REMOVE" ->
 305         OpCodes.OpBackupRemove <$> genFQDN
 306       "OP_TEST_ALLOCATOR" ->
 307         OpCodes.OpTestAllocator <$> arbitrary <*> arbitrary <*>
 308           genNameNE <*> pure [] <*> pure [] <*>
 309           arbitrary <*> genMaybe genNameNE <*>
 310           (genTags >>= mapM mkNonEmpty) <*>
 311           arbitrary <*> arbitrary <*> genMaybe genNameNE <*>
 312           arbitrary <*> genMaybe genNodeNamesNE <*> arbitrary <*>
 313           genMaybe genNamesNE <*> arbitrary <*> arbitrary
 314       "OP_TEST_JQUEUE" ->
 315         OpCodes.OpTestJqueue <$> arbitrary <*> arbitrary <*>
 316           resize 20 (listOf genFQDN) <*> arbitrary
 317       "OP_TEST_DUMMY" ->
 318         OpCodes.OpTestDummy <$> pure J.JSNull <*> pure J.JSNull <*>
 319           pure J.JSNull <*> pure J.JSNull
 320       "OP_NETWORK_ADD" ->
 321         OpCodes.OpNetworkAdd <$> genNameNE <*> arbitrary <*> genIp4Net <*>
 322           genMaybe genIp4Addr <*> pure Nothing <*> pure Nothing <*>
 323           genMaybe genMacPrefix <*> genMaybe (listOf genIp4Addr) <*>
 324           arbitrary <*> (genTags >>= mapM mkNonEmpty)
 325       "OP_NETWORK_REMOVE" ->
 326         OpCodes.OpNetworkRemove <$> genNameNE <*> arbitrary
 327       "OP_NETWORK_SET_PARAMS" ->
 328         OpCodes.OpNetworkSetParams <$> genNameNE <*> arbitrary <*>
 329           genMaybe genIp4Addr <*> pure Nothing <*> pure Nothing <*>
 330           genMaybe genMacPrefix <*> genMaybe (listOf genIp4Addr) <*>
 331           genMaybe (listOf genIp4Addr)
 332       "OP_NETWORK_CONNECT" ->
 333         OpCodes.OpNetworkConnect <$> genNameNE <*> genNameNE <*>
 334           arbitrary <*> genNameNE <*> arbitrary
 335       "OP_NETWORK_DISCONNECT" ->
 336         OpCodes.OpNetworkDisconnect <$> genNameNE <*> genNameNE <*> arbitrary
 337       "OP_NETWORK_QUERY" ->
 338         OpCodes.OpNetworkQuery <$> genFieldsNE <*> genNamesNE
 339       "OP_RESTRICTED_COMMAND" ->
 340         OpCodes.OpRestrictedCommand <$> arbitrary <*> genNodeNamesNE <*>
 341           genNameNE
 342       _ -> fail $ "Undefined arbitrary for opcode " ++ op_id
 343
 344 instance Arbitrary OpCodes.CommonOpParams where
 345   arbitrary = OpCodes.CommonOpParams <$> arbitrary <*> arbitrary <*>
 346                 arbitrary <*> resize 5 arbitrary <*> genMaybe genName
 347
 348 -- * Helper functions
 349
 350 -- | Empty JSObject.
 351 emptyJSObject :: J.JSObject J.JSValue
 352 emptyJSObject = J.toJSObject []
 353
 354 -- | Empty maybe unchecked dictionary.
 355 emptyMUD :: Gen (Maybe (J.JSObject J.JSValue))
 356 emptyMUD = genMaybe $ pure emptyJSObject
 357
 358 -- | Generates an empty container.
 359 genEmptyContainer :: (Ord a) => Gen (GenericContainer a b)
 360 genEmptyContainer = pure . GenericContainer $ Map.fromList []
 361
 362 -- | Generates list of disk indices.
 363 genDiskIndices :: Gen [DiskIndex]
 364 genDiskIndices = do
 365   cnt <- choose (0, C.maxDisks)
 366   genUniquesList cnt arbitrary
 367
 368 -- | Generates a list of node names.
 369 genNodeNames :: Gen [String]
 370 genNodeNames = resize maxNodes (listOf genFQDN)
 371
 372 -- | Generates a list of node names in non-empty string type.
 373 genNodeNamesNE :: Gen [NonEmptyString]
 374 genNodeNamesNE = genNodeNames >>= mapM mkNonEmpty
 375
 376 -- | Gets a node name in non-empty type.
 377 genNodeNameNE :: Gen NonEmptyString
 378 genNodeNameNE = genFQDN >>= mkNonEmpty
 379
 380 -- | Gets a name (non-fqdn) in non-empty type.
 381 genNameNE :: Gen NonEmptyString
 382 genNameNE = genName >>= mkNonEmpty
 383
 384 -- | Gets a list of names (non-fqdn) in non-empty type.
 385 genNamesNE :: Gen [NonEmptyString]
 386 genNamesNE = resize maxNodes (listOf genNameNE)
 387
 388 -- | Returns a list of non-empty fields.
 389 genFieldsNE :: Gen [NonEmptyString]
 390 genFieldsNE = genFields >>= mapM mkNonEmpty
 391
 392 -- | Generate a 3-byte MAC prefix.
 393 genMacPrefix :: Gen NonEmptyString
 394 genMacPrefix = do
 395   octets <- vectorOf 3 $ choose (0::Int, 255)
 396   mkNonEmpty . intercalate ":" $ map (printf "%02x") octets
 397
 398 -- | Arbitrary instance for MetaOpCode, defined here due to TH ordering.
 399 $(genArbitrary ''OpCodes.MetaOpCode)
 400
 401 -- | Small helper to check for a failed JSON deserialisation
 402 isJsonError :: J.Result a -> Bool
 403 isJsonError (J.Error _) = True
 404 isJsonError _           = False
 405
 406 -- * Test cases
 407
 408 -- | Check that opcode serialization is idempotent.
 409 prop_serialization :: OpCodes.OpCode -> Property
 410 prop_serialization = testSerialisation
 411
 412 -- | Check that Python and Haskell defined the same opcode list.
 413 case_AllDefined :: HUnit.Assertion
 414 case_AllDefined = do
 415   let py_ops = sort C.opcodesOpIds
 416       hs_ops = sort OpCodes.allOpIDs
 417       extra_py = py_ops \\ hs_ops
 418       extra_hs = hs_ops \\ py_ops
 419   HUnit.assertBool ("Missing OpCodes from the Haskell code:\n" ++
 420                     unlines extra_py) (null extra_py)
 421   HUnit.assertBool ("Extra OpCodes in the Haskell code code:\n" ++
 422                     unlines extra_hs) (null extra_hs)
 423
 424 -- | Custom HUnit test case that forks a Python process and checks
 425 -- correspondence between Haskell-generated OpCodes and their Python
 426 -- decoded, validated and re-encoded version.
 427 --
 428 -- Note that we have a strange beast here: since launching Python is
 429 -- expensive, we don't do this via a usual QuickProperty, since that's
 430 -- slow (I've tested it, and it's indeed quite slow). Rather, we use a
 431 -- single HUnit assertion, and in it we manually use QuickCheck to
 432 -- generate 500 opcodes times the number of defined opcodes, which
 433 -- then we pass in bulk to Python. The drawbacks to this method are
 434 -- two fold: we cannot control the number of generated opcodes, since
 435 -- HUnit assertions don't get access to the test options, and for the
 436 -- same reason we can't run a repeatable seed. We should probably find
 437 -- a better way to do this, for example by having a
 438 -- separately-launched Python process (if not running the tests would
 439 -- be skipped).
 440 case_py_compat_types :: HUnit.Assertion
 441 case_py_compat_types = do
 442   let num_opcodes = length OpCodes.allOpIDs * 100
 443   sample_opcodes <- sample' (vectorOf num_opcodes
 444                              (arbitrary::Gen OpCodes.MetaOpCode))
 445   let opcodes = head sample_opcodes
 446       with_sum = map (\o -> (OpCodes.opSummary $
 447                              OpCodes.metaOpCode o, o)) opcodes
 448       serialized = J.encode opcodes
 449   -- check for non-ASCII fields, usually due to 'arbitrary :: String'
 450   mapM_ (\op -> when (any (not . isAscii) (J.encode op)) .
 451                 HUnit.assertFailure $
 452                   "OpCode has non-ASCII fields: " ++ show op
 453         ) opcodes
 454   py_stdout <-
 455      runPython "from ganeti import opcodes\n\
 456                \import sys\n\
 457                \from ganeti import serializer\n\
 458                \op_data = serializer.Load(sys.stdin.read())\n\
 459                \decoded = [opcodes.OpCode.LoadOpCode(o) for o in op_data]\n\
 460                \for op in decoded:\n\
 461                \  op.Validate(True)\n\
 462                \encoded = [(op.Summary(), op.__getstate__())\n\
 463                \           for op in decoded]\n\
 464                \print serializer.Dump(encoded)" serialized
 465      >>= checkPythonResult
 466   let deserialised =
 467         J.decode py_stdout::J.Result [(String, OpCodes.MetaOpCode)]
 468   decoded <- case deserialised of
 469                J.Ok ops -> return ops
 470                J.Error msg ->
 471                  HUnit.assertFailure ("Unable to decode opcodes: " ++ msg)
 472                  -- this already raised an expection, but we need it
 473                  -- for proper types
 474                  >> fail "Unable to decode opcodes"
 475   HUnit.assertEqual "Mismatch in number of returned opcodes"
 476     (length decoded) (length with_sum)
 477   mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
 478         ) $ zip decoded with_sum
 479
 480 -- | Custom HUnit test case that forks a Python process and checks
 481 -- correspondence between Haskell OpCodes fields and their Python
 482 -- equivalent.
 483 case_py_compat_fields :: HUnit.Assertion
 484 case_py_compat_fields = do
 485   let hs_fields = sort $ map (\op_id -> (op_id, OpCodes.allOpFields op_id))
 486                          OpCodes.allOpIDs
 487   py_stdout <-
 488      runPython "from ganeti import opcodes\n\
 489                \import sys\n\
 490                \from ganeti import serializer\n\
 491                \fields = [(k, sorted([p[0] for p in v.OP_PARAMS]))\n\
 492                \           for k, v in opcodes.OP_MAPPING.items()]\n\
 493                \print serializer.Dump(fields)" ""
 494      >>= checkPythonResult
 495   let deserialised = J.decode py_stdout::J.Result [(String, [String])]
 496   py_fields <- case deserialised of
 497                  J.Ok v -> return $ sort v
 498                  J.Error msg ->
 499                    HUnit.assertFailure ("Unable to decode op fields: " ++ msg)
 500                    -- this already raised an expection, but we need it
 501                    -- for proper types
 502                    >> fail "Unable to decode op fields"
 503   HUnit.assertEqual "Mismatch in number of returned opcodes"
 504     (length hs_fields) (length py_fields)
 505   HUnit.assertEqual "Mismatch in defined OP_IDs"
 506     (map fst hs_fields) (map fst py_fields)
 507   mapM_ (\((py_id, py_flds), (hs_id, hs_flds)) -> do
 508            HUnit.assertEqual "Mismatch in OP_ID" py_id hs_id
 509            HUnit.assertEqual ("Mismatch in fields for " ++ hs_id)
 510              py_flds hs_flds
 511         ) $ zip py_fields hs_fields
 512
 513 -- | Checks that setOpComment works correctly.
 514 prop_setOpComment :: OpCodes.MetaOpCode -> String -> Property
 515 prop_setOpComment op comment =
 516   let (OpCodes.MetaOpCode common _) = OpCodes.setOpComment comment op
 517   in OpCodes.opComment common ==? Just comment
 518
 519 -- | Tests wrong tag object building (cluster takes only jsnull, the
 520 -- other take a string, so we test the opposites).
 521 case_TagObject_fail :: Assertion
 522 case_TagObject_fail =
 523   mapM_ (\(t, j) -> assertEqual (show t ++ "/" ++ J.encode j) Nothing $
 524                     tagObjectFrom t j)
 525     [ (TagTypeCluster,  J.showJSON "abc")
 526     , (TagTypeInstance, J.JSNull)
 527     , (TagTypeNode,     J.JSNull)
 528     , (TagTypeGroup,    J.JSNull)
 529     ]
 530
 531 -- | Tests wrong (negative) disk index.
 532 prop_mkDiskIndex_fail :: QuickCheck.Positive Int -> Property
 533 prop_mkDiskIndex_fail (Positive i) =
 534   case mkDiskIndex (negate i) of
 535     Bad msg -> printTestCase "error message " $
 536                "Invalid value" `isPrefixOf` msg
 537     Ok v -> failTest $ "Succeeded to build disk index '" ++ show v ++
 538                        "' from negative value " ++ show (negate i)
 539
 540 -- | Tests a few invalid 'readRecreateDisks' cases.
 541 case_readRecreateDisks_fail :: Assertion
 542 case_readRecreateDisks_fail = do
 543   assertBool "null" $
 544     isJsonError (J.readJSON J.JSNull::J.Result RecreateDisksInfo)
 545   assertBool "string" $
 546     isJsonError (J.readJSON (J.showJSON "abc")::J.Result RecreateDisksInfo)
 547
 548 -- | Tests a few invalid 'readDdmOldChanges' cases.
 549 case_readDdmOldChanges_fail :: Assertion
 550 case_readDdmOldChanges_fail = do
 551   assertBool "null" $
 552     isJsonError (J.readJSON J.JSNull::J.Result DdmOldChanges)
 553   assertBool "string" $
 554     isJsonError (J.readJSON (J.showJSON "abc")::J.Result DdmOldChanges)
 555
 556 -- | Tests a few invalid 'readExportTarget' cases.
 557 case_readExportTarget_fail :: Assertion
 558 case_readExportTarget_fail = do
 559   assertBool "null" $
 560     isJsonError (J.readJSON J.JSNull::J.Result ExportTarget)
 561   assertBool "int" $
 562     isJsonError (J.readJSON (J.showJSON (5::Int))::J.Result ExportTarget)
 563
 564 testSuite "OpCodes"
 565             [ 'prop_serialization
 566             , 'case_AllDefined
 567             , 'case_py_compat_types
 568             , 'case_py_compat_fields
 569             , 'prop_setOpComment
 570             , 'case_TagObject_fail
 571             , 'prop_mkDiskIndex_fail
 572             , 'case_readRecreateDisks_fail
 573             , 'case_readDdmOldChanges_fail
 574             , 'case_readExportTarget_fail
 575             ]