OpCodes.hs 30.1 KB
Newer Older
1 2 3 4 5 6 7 8 9
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{-| Unittests for ganeti-htools.

-}

{-

10
Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

module Test.Ganeti.OpCodes
  ( testOpCodes
  , OpCodes.OpCode(..)
  ) where

34 35
import Test.HUnit as HUnit
import Test.QuickCheck as QuickCheck
36 37

import Control.Applicative
38 39
import Control.Monad
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 46

import Test.Ganeti.TestHelper
import Test.Ganeti.TestCommon
47
import Test.Ganeti.Types ()
48
import Test.Ganeti.Query.Language ()
49

50
import Ganeti.BasicTypes
51 52
import qualified Ganeti.Constants as C
import qualified Ganeti.OpCodes as OpCodes
53 54
import Ganeti.Types
import Ganeti.OpParams
55
import Ganeti.JSON
56

Iustin Pop's avatar
Iustin Pop committed
57 58
{-# ANN module "HLint: ignore Use camelCase" #-}

59 60
-- * Arbitrary instances

Jose A. Lopes's avatar
Jose A. Lopes committed
61 62
instance (Ord k, Arbitrary k, Arbitrary a) => Arbitrary (Map.Map k a) where
  arbitrary = Map.fromList <$> arbitrary
63

64 65 66 67 68 69 70 71 72 73 74 75 76 77 78
arbitraryOpTagsGet :: Gen OpCodes.OpCode
arbitraryOpTagsGet = do
  kind <- arbitrary
  OpCodes.OpTagsSet kind <$> arbitrary <*> genOpCodesTagName kind

arbitraryOpTagsSet :: Gen OpCodes.OpCode
arbitraryOpTagsSet = do
  kind <- arbitrary
  OpCodes.OpTagsSet kind <$> genTags <*> genOpCodesTagName kind

arbitraryOpTagsDel :: Gen OpCodes.OpCode
arbitraryOpTagsDel = do
  kind <- arbitrary
  OpCodes.OpTagsDel kind <$> genTags <*> genOpCodesTagName kind

79
$(genArbitrary ''OpCodes.ReplaceDisksMode)
80

81 82
$(genArbitrary ''DiskAccess)

83 84
$(genArbitrary ''ImportExportCompression)

85 86 87
instance Arbitrary OpCodes.DiskIndex where
  arbitrary = choose (0, C.maxDisks - 1) >>= OpCodes.mkDiskIndex

88
instance Arbitrary INicParams where
89
  arbitrary = INicParams <$> genMaybe genNameNE <*> genMaybe genName <*>
90
              genMaybe genNameNE <*> genMaybe genNameNE <*>
91
              genMaybe genNameNE <*> genMaybe genName <*>
92
              genMaybe genNameNE
93

94 95
instance Arbitrary IDiskParams where
  arbitrary = IDiskParams <$> arbitrary <*> arbitrary <*>
96
              genMaybe genNameNE <*> genMaybe genNameNE <*>
97
              genMaybe genNameNE <*> genMaybe genNameNE <*>
98
              genMaybe genNameNE <*> arbitrary <*> genAndRestArguments
99

100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
instance Arbitrary RecreateDisksInfo where
  arbitrary = oneof [ pure RecreateDisksAll
                    , RecreateDisksIndices <$> arbitrary
                    , RecreateDisksParams <$> arbitrary
                    ]

instance Arbitrary DdmOldChanges where
  arbitrary = oneof [ DdmOldIndex <$> arbitrary
                    , DdmOldMod   <$> arbitrary
                    ]

instance (Arbitrary a) => Arbitrary (SetParamsMods a) where
  arbitrary = oneof [ pure SetParamsEmpty
                    , SetParamsDeprecated <$> arbitrary
                    , SetParamsNew        <$> arbitrary
                    ]

Iustin Pop's avatar
Iustin Pop committed
117 118 119 120 121
instance Arbitrary ExportTarget where
  arbitrary = oneof [ ExportTargetLocal <$> genNodeNameNE
                    , ExportTargetRemote <$> pure []
                    ]

122 123 124 125 126
instance Arbitrary OpCodes.OpCode where
  arbitrary = do
    op_id <- elements OpCodes.allOpIDs
    case op_id of
      "OP_TEST_DELAY" ->
127
        OpCodes.OpTestDelay <$> arbitrary <*> arbitrary <*>
Thomas Thrainer's avatar
Thomas Thrainer committed
128
          genNodeNamesNE <*> return Nothing <*> arbitrary
129
      "OP_INSTANCE_REPLACE_DISKS" ->
130 131
        OpCodes.OpInstanceReplaceDisks <$> genFQDN <*> return Nothing <*>
          arbitrary <*> arbitrary <*> arbitrary <*> genDiskIndices <*>
Thomas Thrainer's avatar
Thomas Thrainer committed
132
          genMaybe genNodeNameNE <*> return Nothing <*> genMaybe genNameNE
133
      "OP_INSTANCE_FAILOVER" ->
134 135
        OpCodes.OpInstanceFailover <$> genFQDN <*> return Nothing <*>
        arbitrary <*> arbitrary <*> genMaybe genNodeNameNE <*>
Thomas Thrainer's avatar
Thomas Thrainer committed
136
        return Nothing <*> arbitrary <*> arbitrary <*> genMaybe genNameNE
137
      "OP_INSTANCE_MIGRATE" ->
138 139 140 141
        OpCodes.OpInstanceMigrate <$> genFQDN <*> return Nothing <*>
          arbitrary <*> arbitrary <*> genMaybe genNodeNameNE <*>
          return Nothing <*> arbitrary <*> arbitrary <*> arbitrary <*>
          genMaybe genNameNE <*> arbitrary
142
      "OP_TAGS_GET" ->
143
        arbitraryOpTagsGet
144 145
      "OP_TAGS_SEARCH" ->
        OpCodes.OpTagsSearch <$> genNameNE
146
      "OP_TAGS_SET" ->
147
        arbitraryOpTagsSet
148
      "OP_TAGS_DEL" ->
149
        arbitraryOpTagsDel
150
      "OP_CLUSTER_POST_INIT" -> pure OpCodes.OpClusterPostInit
151
      "OP_CLUSTER_RENEW_CRYPTO" -> pure OpCodes.OpClusterRenewCrypto
152 153 154 155
      "OP_CLUSTER_DESTROY" -> pure OpCodes.OpClusterDestroy
      "OP_CLUSTER_QUERY" -> pure OpCodes.OpClusterQuery
      "OP_CLUSTER_VERIFY" ->
        OpCodes.OpClusterVerify <$> arbitrary <*> arbitrary <*>
156
          genListSet Nothing <*> genListSet Nothing <*> arbitrary <*>
157
          genMaybe genNameNE
158 159
      "OP_CLUSTER_VERIFY_CONFIG" ->
        OpCodes.OpClusterVerifyConfig <$> arbitrary <*> arbitrary <*>
160
          genListSet Nothing <*> arbitrary
161
      "OP_CLUSTER_VERIFY_GROUP" ->
162
        OpCodes.OpClusterVerifyGroup <$> genNameNE <*> arbitrary <*>
163
          arbitrary <*> genListSet Nothing <*> genListSet Nothing <*> arbitrary
164 165
      "OP_CLUSTER_VERIFY_DISKS" -> pure OpCodes.OpClusterVerifyDisks
      "OP_GROUP_VERIFY_DISKS" ->
166
        OpCodes.OpGroupVerifyDisks <$> genNameNE
167
      "OP_CLUSTER_REPAIR_DISK_SIZES" ->
168
        OpCodes.OpClusterRepairDiskSizes <$> genNodeNamesNE
169
      "OP_CLUSTER_CONFIG_QUERY" ->
170
        OpCodes.OpClusterConfigQuery <$> genFieldsNE
171
      "OP_CLUSTER_RENAME" ->
172
        OpCodes.OpClusterRename <$> genNameNE
173
      "OP_CLUSTER_SET_PARAMS" ->
174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209
        OpCodes.OpClusterSetParams
          <$> arbitrary                    -- force
          <*> emptyMUD                     -- hv_state
          <*> emptyMUD                     -- disk_state
          <*> arbitrary                    -- vg_name
          <*> genMaybe arbitrary           -- enabled_hypervisors
          <*> genMaybe genEmptyContainer   -- hvparams
          <*> emptyMUD                     -- beparams
          <*> genMaybe genEmptyContainer   -- os_hvp
          <*> genMaybe genEmptyContainer   -- osparams
          <*> genMaybe genEmptyContainer   -- osparams_private_cluster
          <*> genMaybe genEmptyContainer   -- diskparams
          <*> genMaybe arbitrary           -- candidate_pool_size
          <*> genMaybe arbitrary           -- max_running_jobs
          <*> arbitrary                    -- uid_pool
          <*> arbitrary                    -- add_uids
          <*> arbitrary                    -- remove_uids
          <*> arbitrary                    -- maintain_node_health
          <*> arbitrary                    -- prealloc_wipe_disks
          <*> arbitrary                    -- nicparams
          <*> emptyMUD                     -- ndparams
          <*> emptyMUD                     -- ipolicy
          <*> arbitrary                    -- drbd_helper
          <*> arbitrary                    -- default_iallocator
          <*> emptyMUD                     -- default_iallocator_params
          <*> arbitrary                    -- master_netdev
          <*> arbitrary                    -- master_netmask
          <*> arbitrary                    -- reserved_lvs
          <*> arbitrary                    -- hidden_os
          <*> arbitrary                    -- blacklisted_os
          <*> arbitrary                    -- use_external_mip_script
          <*> arbitrary                    -- enabled_disk_templates
          <*> arbitrary                    -- modify_etc_hosts
          <*> genMaybe genName             -- file_storage_dir
          <*> genMaybe genName             -- shared_file_storage_dir
          <*> genMaybe genName             -- gluster_file_storage_dir
210
          <*> arbitrary                    -- instance_communication_network
211 212 213 214 215 216
      "OP_CLUSTER_REDIST_CONF" -> pure OpCodes.OpClusterRedistConf
      "OP_CLUSTER_ACTIVATE_MASTER_IP" ->
        pure OpCodes.OpClusterActivateMasterIp
      "OP_CLUSTER_DEACTIVATE_MASTER_IP" ->
        pure OpCodes.OpClusterDeactivateMasterIp
      "OP_QUERY" ->
217 218
        OpCodes.OpQuery <$> arbitrary <*> arbitrary <*> arbitrary <*>
        pure Nothing
219 220 221
      "OP_QUERY_FIELDS" ->
        OpCodes.OpQueryFields <$> arbitrary <*> arbitrary
      "OP_OOB_COMMAND" ->
Thomas Thrainer's avatar
Thomas Thrainer committed
222 223 224 225 226
        OpCodes.OpOobCommand <$> genNodeNamesNE <*> return Nothing <*>
          arbitrary <*> arbitrary <*> arbitrary <*>
          (arbitrary `suchThat` (>0))
      "OP_NODE_REMOVE" ->
        OpCodes.OpNodeRemove <$> genNodeNameNE <*> return Nothing
227
      "OP_NODE_ADD" ->
228
        OpCodes.OpNodeAdd <$> genNodeNameNE <*> emptyMUD <*> emptyMUD <*>
Jose A. Lopes's avatar
Jose A. Lopes committed
229
          genMaybe genNameNE <*> genMaybe genNameNE <*> arbitrary <*>
230
          genMaybe genNameNE <*> arbitrary <*> arbitrary <*> emptyMUD
231 232 233 234
      "OP_NODE_QUERYVOLS" ->
        OpCodes.OpNodeQueryvols <$> arbitrary <*> genNodeNamesNE
      "OP_NODE_QUERY_STORAGE" ->
        OpCodes.OpNodeQueryStorage <$> arbitrary <*> arbitrary <*>
235
          genNodeNamesNE <*> genMaybe genNameNE
236
      "OP_NODE_MODIFY_STORAGE" ->
Thomas Thrainer's avatar
Thomas Thrainer committed
237
        OpCodes.OpNodeModifyStorage <$> genNodeNameNE <*> return Nothing <*>
238
          arbitrary <*> genMaybe genNameNE <*> pure emptyJSObject
239
      "OP_REPAIR_NODE_STORAGE" ->
Thomas Thrainer's avatar
Thomas Thrainer committed
240
        OpCodes.OpRepairNodeStorage <$> genNodeNameNE <*> return Nothing <*>
241
          arbitrary <*> genMaybe genNameNE <*> arbitrary
242
      "OP_NODE_SET_PARAMS" ->
Thomas Thrainer's avatar
Thomas Thrainer committed
243 244 245 246
        OpCodes.OpNodeSetParams <$> genNodeNameNE <*> return Nothing <*>
          arbitrary <*> emptyMUD <*> emptyMUD <*> arbitrary <*> arbitrary <*>
          arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>
          genMaybe genNameNE <*> emptyMUD <*> arbitrary
247
      "OP_NODE_POWERCYCLE" ->
Thomas Thrainer's avatar
Thomas Thrainer committed
248 249
        OpCodes.OpNodePowercycle <$> genNodeNameNE <*> return Nothing <*>
          arbitrary
250
      "OP_NODE_MIGRATE" ->
Thomas Thrainer's avatar
Thomas Thrainer committed
251 252 253
        OpCodes.OpNodeMigrate <$> genNodeNameNE <*> return Nothing <*>
          arbitrary <*> arbitrary <*> genMaybe genNodeNameNE <*>
          return Nothing <*> arbitrary <*> arbitrary <*> genMaybe genNameNE
254 255
      "OP_NODE_EVACUATE" ->
        OpCodes.OpNodeEvacuate <$> arbitrary <*> genNodeNameNE <*>
Thomas Thrainer's avatar
Thomas Thrainer committed
256 257
          return Nothing <*> genMaybe genNodeNameNE <*> return Nothing <*>
          genMaybe genNameNE <*> arbitrary
258
      "OP_INSTANCE_CREATE" ->
259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298
        OpCodes.OpInstanceCreate
          <$> genFQDN                         -- instance_name
          <*> arbitrary                       -- force_variant
          <*> arbitrary                       -- wait_for_sync
          <*> arbitrary                       -- name_check
          <*> arbitrary                       -- ignore_ipolicy
          <*> arbitrary                       -- opportunistic_locking
          <*> pure emptyJSObject              -- beparams
          <*> arbitrary                       -- disks
          <*> arbitrary                       -- disk_template
          <*> arbitrary                       -- file_driver
          <*> genMaybe genNameNE              -- file_storage_dir
          <*> pure emptyJSObject              -- hvparams
          <*> arbitrary                       -- hypervisor
          <*> genMaybe genNameNE              -- iallocator
          <*> arbitrary                       -- identify_defaults
          <*> arbitrary                       -- ip_check
          <*> arbitrary                       -- conflicts_check
          <*> arbitrary                       -- mode
          <*> arbitrary                       -- nics
          <*> arbitrary                       -- no_install
          <*> pure emptyJSObject              -- osparams
          <*> genMaybe arbitraryPrivateJSObj  -- osparams_private
          <*> genMaybe arbitraryPrivateJSObj  -- osparams_secret
          <*> genMaybe genNameNE              -- os_type
          <*> genMaybe genNodeNameNE          -- pnode
          <*> return Nothing                  -- pnode_uuid
          <*> genMaybe genNodeNameNE          -- snode
          <*> return Nothing                  -- snode_uuid
          <*> genMaybe (pure [])              -- source_handshake
          <*> genMaybe genNodeNameNE          -- source_instance_name
          <*> arbitrary                       -- source_shutdown_timeout
          <*> genMaybe genNodeNameNE          -- source_x509_ca
          <*> return Nothing                  -- src_node
          <*> genMaybe genNodeNameNE          -- src_node_uuid
          <*> genMaybe genNameNE              -- src_path
          <*> arbitrary                       -- compress
          <*> arbitrary                       -- start
          <*> (genTags >>= mapM mkNonEmpty)   -- tags
          <*> arbitrary                       -- instance_communication
299
      "OP_INSTANCE_MULTI_ALLOC" ->
300 301
        OpCodes.OpInstanceMultiAlloc <$> arbitrary <*> genMaybe genNameNE <*>
        pure []
302
      "OP_INSTANCE_REINSTALL" ->
303 304
        OpCodes.OpInstanceReinstall <$> genFQDN <*> return Nothing <*>
          arbitrary <*> genMaybe genNameNE <*> genMaybe (pure emptyJSObject)
305
          <*> genMaybe arbitraryPrivateJSObj <*> genMaybe arbitraryPrivateJSObj
306
      "OP_INSTANCE_REMOVE" ->
307
        OpCodes.OpInstanceRemove <$> genFQDN <*> return Nothing <*>
308
          arbitrary <*> arbitrary
309 310 311
      "OP_INSTANCE_RENAME" ->
        OpCodes.OpInstanceRename <$> genFQDN <*> return Nothing <*>
          genNodeNameNE <*> arbitrary <*> arbitrary
312
      "OP_INSTANCE_STARTUP" ->
313 314 315
        OpCodes.OpInstanceStartup <$> genFQDN <*> return Nothing <*>
          arbitrary <*> arbitrary <*> pure emptyJSObject <*>
          pure emptyJSObject <*> arbitrary <*> arbitrary
316
      "OP_INSTANCE_SHUTDOWN" ->
317 318
        OpCodes.OpInstanceShutdown <$> genFQDN <*> return Nothing <*>
          arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
319
      "OP_INSTANCE_REBOOT" ->
320 321
        OpCodes.OpInstanceReboot <$> genFQDN <*> return Nothing <*>
          arbitrary <*> arbitrary <*> arbitrary
322
      "OP_INSTANCE_MOVE" ->
323 324
        OpCodes.OpInstanceMove <$> genFQDN <*> return Nothing <*>
          arbitrary <*> arbitrary <*> genNodeNameNE <*> return Nothing <*>
325
          arbitrary <*> arbitrary
326 327
      "OP_INSTANCE_CONSOLE" -> OpCodes.OpInstanceConsole <$> genFQDN <*>
          return Nothing
328
      "OP_INSTANCE_ACTIVATE_DISKS" ->
329
        OpCodes.OpInstanceActivateDisks <$> genFQDN <*> return Nothing <*>
330 331
          arbitrary <*> arbitrary
      "OP_INSTANCE_DEACTIVATE_DISKS" ->
332 333
        OpCodes.OpInstanceDeactivateDisks <$> genFQDN <*> return Nothing <*>
          arbitrary
334
      "OP_INSTANCE_RECREATE_DISKS" ->
335 336 337
        OpCodes.OpInstanceRecreateDisks <$> genFQDN <*> return Nothing <*>
          arbitrary <*> genNodeNamesNE <*> return Nothing <*>
          genMaybe genNameNE
338 339 340 341
      "OP_INSTANCE_QUERY_DATA" ->
        OpCodes.OpInstanceQueryData <$> arbitrary <*>
          genNodeNamesNE <*> arbitrary
      "OP_INSTANCE_SET_PARAMS" ->
342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365
        OpCodes.OpInstanceSetParams
          <$> genFQDN                         -- instance_name
          <*> return Nothing                  -- instance_uuid
          <*> arbitrary                       -- force
          <*> arbitrary                       -- force_variant
          <*> arbitrary                       -- ignore_ipolicy
          <*> arbitrary                       -- nics
          <*> arbitrary                       -- disks
          <*> pure emptyJSObject              -- beparams
          <*> arbitrary                       -- runtime_mem
          <*> pure emptyJSObject              -- hvparams
          <*> arbitrary                       -- disk_template
          <*> genMaybe genNodeNameNE          -- pnode
          <*> return Nothing                  -- pnode_uuid
          <*> genMaybe genNodeNameNE          -- remote_node
          <*> return Nothing                  -- remote_node_uuid
          <*> genMaybe genNameNE              -- os_name
          <*> pure emptyJSObject              -- osparams
          <*> genMaybe arbitraryPrivateJSObj  -- osparams_private
          <*> arbitrary                       -- wait_for_sync
          <*> arbitrary                       -- offline
          <*> arbitrary                       -- conflicts_check
          <*> arbitrary                       -- hotplug
          <*> arbitrary                       -- hotplug_if_possible
366
      "OP_INSTANCE_GROW_DISK" ->
367 368
        OpCodes.OpInstanceGrowDisk <$> genFQDN <*> return Nothing <*>
          arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
369
      "OP_INSTANCE_CHANGE_GROUP" ->
370 371 372
        OpCodes.OpInstanceChangeGroup <$> genFQDN <*> return Nothing <*>
          arbitrary <*> genMaybe genNameNE <*>
          genMaybe (resize maxNodes (listOf genNameNE))
Iustin Pop's avatar
Iustin Pop committed
373 374
      "OP_GROUP_ADD" ->
        OpCodes.OpGroupAdd <$> genNameNE <*> arbitrary <*>
375
          emptyMUD <*> genMaybe genEmptyContainer <*>
Iustin Pop's avatar
Iustin Pop committed
376 377 378
          emptyMUD <*> emptyMUD <*> emptyMUD
      "OP_GROUP_ASSIGN_NODES" ->
        OpCodes.OpGroupAssignNodes <$> genNameNE <*> arbitrary <*>
Thomas Thrainer's avatar
Thomas Thrainer committed
379
          genNodeNamesNE <*> return Nothing
Iustin Pop's avatar
Iustin Pop committed
380 381
      "OP_GROUP_SET_PARAMS" ->
        OpCodes.OpGroupSetParams <$> genNameNE <*> arbitrary <*>
382
          emptyMUD <*> genMaybe genEmptyContainer <*>
Iustin Pop's avatar
Iustin Pop committed
383 384 385 386 387 388 389
          emptyMUD <*> emptyMUD <*> emptyMUD
      "OP_GROUP_REMOVE" ->
        OpCodes.OpGroupRemove <$> genNameNE
      "OP_GROUP_RENAME" ->
        OpCodes.OpGroupRename <$> genNameNE <*> genNameNE
      "OP_GROUP_EVACUATE" ->
        OpCodes.OpGroupEvacuate <$> genNameNE <*> arbitrary <*>
390
          genMaybe genNameNE <*> genMaybe genNamesNE
Iustin Pop's avatar
Iustin Pop committed
391 392
      "OP_OS_DIAGNOSE" ->
        OpCodes.OpOsDiagnose <$> genFieldsNE <*> genNamesNE
393 394
      "OP_EXT_STORAGE_DIAGNOSE" ->
        OpCodes.OpOsDiagnose <$> genFieldsNE <*> genNamesNE
Iustin Pop's avatar
Iustin Pop committed
395
      "OP_BACKUP_PREPARE" ->
396
        OpCodes.OpBackupPrepare <$> genFQDN <*> return Nothing <*> arbitrary
Iustin Pop's avatar
Iustin Pop committed
397
      "OP_BACKUP_EXPORT" ->
398
        OpCodes.OpBackupExport <$> genFQDN <*> return Nothing <*>
399 400 401
          arbitrary <*> arbitrary <*> arbitrary <*> return Nothing <*>
          arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>
          genMaybe (pure []) <*> genMaybe genNameNE
Iustin Pop's avatar
Iustin Pop committed
402
      "OP_BACKUP_REMOVE" ->
403
        OpCodes.OpBackupRemove <$> genFQDN <*> return Nothing
Iustin Pop's avatar
Iustin Pop committed
404 405
      "OP_TEST_ALLOCATOR" ->
        OpCodes.OpTestAllocator <$> arbitrary <*> arbitrary <*>
406
          genNameNE <*> genMaybe (pure []) <*> genMaybe (pure []) <*>
407
          arbitrary <*> genMaybe genNameNE <*>
Iustin Pop's avatar
Iustin Pop committed
408
          (genTags >>= mapM mkNonEmpty) <*>
409 410 411
          arbitrary <*> arbitrary <*> genMaybe genNameNE <*>
          arbitrary <*> genMaybe genNodeNamesNE <*> arbitrary <*>
          genMaybe genNamesNE <*> arbitrary <*> arbitrary
Iustin Pop's avatar
Iustin Pop committed
412 413
      "OP_TEST_JQUEUE" ->
        OpCodes.OpTestJqueue <$> arbitrary <*> arbitrary <*>
414
          resize 20 (listOf genFQDN) <*> arbitrary
Iustin Pop's avatar
Iustin Pop committed
415 416 417
      "OP_TEST_DUMMY" ->
        OpCodes.OpTestDummy <$> pure J.JSNull <*> pure J.JSNull <*>
          pure J.JSNull <*> pure J.JSNull
418
      "OP_NETWORK_ADD" ->
419 420 421
        OpCodes.OpNetworkAdd <$> genNameNE <*> genIPv4Network <*>
          genMaybe genIPv4Address <*> pure Nothing <*> pure Nothing <*>
          genMaybe genMacPrefix <*> genMaybe (listOf genIPv4Address) <*>
Iustin Pop's avatar
Iustin Pop committed
422
          arbitrary <*> (genTags >>= mapM mkNonEmpty)
423 424 425
      "OP_NETWORK_REMOVE" ->
        OpCodes.OpNetworkRemove <$> genNameNE <*> arbitrary
      "OP_NETWORK_SET_PARAMS" ->
426
        OpCodes.OpNetworkSetParams <$> genNameNE <*>
427 428 429
          genMaybe genIPv4Address <*> pure Nothing <*> pure Nothing <*>
          genMaybe genMacPrefix <*> genMaybe (listOf genIPv4Address) <*>
          genMaybe (listOf genIPv4Address)
430 431 432 433
      "OP_NETWORK_CONNECT" ->
        OpCodes.OpNetworkConnect <$> genNameNE <*> genNameNE <*>
          arbitrary <*> genNameNE <*> arbitrary
      "OP_NETWORK_DISCONNECT" ->
434
        OpCodes.OpNetworkDisconnect <$> genNameNE <*> genNameNE
Iustin Pop's avatar
Iustin Pop committed
435 436
      "OP_RESTRICTED_COMMAND" ->
        OpCodes.OpRestrictedCommand <$> arbitrary <*> genNodeNamesNE <*>
Thomas Thrainer's avatar
Thomas Thrainer committed
437
          return Nothing <*> genNameNE
438
      _ -> fail $ "Undefined arbitrary for opcode " ++ op_id
439

440 441 442 443 444 445 446 447 448 449
-- | Generates one element of a reason trail
genReasonElem :: Gen ReasonElem
genReasonElem = (,,) <$> genFQDN <*> genFQDN <*> arbitrary

-- | Generates a reason trail
genReasonTrail :: Gen ReasonTrail
genReasonTrail = do
  size <- choose (0, 10)
  vectorOf size genReasonElem

450 451
instance Arbitrary OpCodes.CommonOpParams where
  arbitrary = OpCodes.CommonOpParams <$> arbitrary <*> arbitrary <*>
452 453
                arbitrary <*> resize 5 arbitrary <*> genMaybe genName <*>
                genReasonTrail
454

455 456
-- * Helper functions

457 458 459 460 461 462
-- | Empty JSObject.
emptyJSObject :: J.JSObject J.JSValue
emptyJSObject = J.toJSObject []

-- | Empty maybe unchecked dictionary.
emptyMUD :: Gen (Maybe (J.JSObject J.JSValue))
463
emptyMUD = genMaybe $ pure emptyJSObject
464 465 466 467 468

-- | Generates an empty container.
genEmptyContainer :: (Ord a) => Gen (GenericContainer a b)
genEmptyContainer = pure . GenericContainer $ Map.fromList []

469 470 471 472
-- | Generates list of disk indices.
genDiskIndices :: Gen [DiskIndex]
genDiskIndices = do
  cnt <- choose (0, C.maxDisks)
473
  genUniquesList cnt arbitrary
474 475 476

-- | Generates a list of node names.
genNodeNames :: Gen [String]
477
genNodeNames = resize maxNodes (listOf genFQDN)
478

479 480
-- | Generates a list of node names in non-empty string type.
genNodeNamesNE :: Gen [NonEmptyString]
Iustin Pop's avatar
Iustin Pop committed
481
genNodeNamesNE = genNodeNames >>= mapM mkNonEmpty
482

483 484
-- | Gets a node name in non-empty type.
genNodeNameNE :: Gen NonEmptyString
485
genNodeNameNE = genFQDN >>= mkNonEmpty
486

487 488
-- | Gets a name (non-fqdn) in non-empty type.
genNameNE :: Gen NonEmptyString
489
genNameNE = genName >>= mkNonEmpty
490

Iustin Pop's avatar
Iustin Pop committed
491 492 493 494
-- | Gets a list of names (non-fqdn) in non-empty type.
genNamesNE :: Gen [NonEmptyString]
genNamesNE = resize maxNodes (listOf genNameNE)

495 496
-- | Returns a list of non-empty fields.
genFieldsNE :: Gen [NonEmptyString]
497
genFieldsNE = genFields >>= mapM mkNonEmpty
498

499 500 501 502 503 504
-- | Generate a 3-byte MAC prefix.
genMacPrefix :: Gen NonEmptyString
genMacPrefix = do
  octets <- vectorOf 3 $ choose (0::Int, 255)
  mkNonEmpty . intercalate ":" $ map (printf "%02x") octets

505 506 507 508 509 510 511 512 513 514
-- | JSObject of arbitrary data.
--
-- Since JSValue does not implement Arbitrary, I'll simply generate
-- (String, String) objects.
arbitraryPrivateJSObj :: Gen (J.JSObject (Private J.JSValue))
arbitraryPrivateJSObj =
  constructor <$> (fromNonEmpty <$> genNameNE)
              <*> (fromNonEmpty <$> genNameNE)
    where constructor k v = showPrivateJSObject [(k, v)]

515 516 517
-- | Arbitrary instance for MetaOpCode, defined here due to TH ordering.
$(genArbitrary ''OpCodes.MetaOpCode)

518 519 520 521 522
-- | Small helper to check for a failed JSON deserialisation
isJsonError :: J.Result a -> Bool
isJsonError (J.Error _) = True
isJsonError _           = False

523 524 525
-- * Test cases

-- | Check that opcode serialization is idempotent.
526
prop_serialization :: OpCodes.OpCode -> Property
527
prop_serialization = testSerialisation
528 529

-- | Check that Python and Haskell defined the same opcode list.
530 531
case_AllDefined :: HUnit.Assertion
case_AllDefined = do
532 533 534 535
  py_stdout <-
     runPython "from ganeti import opcodes\n\
               \from ganeti import serializer\n\
               \import sys\n\
536 537
               \print serializer.Dump([opid for opid in opcodes.OP_MAPPING])\n"
               ""
538 539 540 541 542 543 544 545 546
     >>= checkPythonResult
  py_ops <- case J.decode py_stdout::J.Result [String] of
               J.Ok ops -> return ops
               J.Error msg ->
                 HUnit.assertFailure ("Unable to decode opcode names: " ++ msg)
                 -- this already raised an expection, but we need it
                 -- for proper types
                 >> fail "Unable to decode opcode names"
  let hs_ops = sort OpCodes.allOpIDs
547
      extra_py = py_ops \\ hs_ops
548
      extra_hs = hs_ops \\ py_ops
549 550
  HUnit.assertBool ("Missing OpCodes from the Haskell code:\n" ++
                    unlines extra_py) (null extra_py)
551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569
  HUnit.assertBool ("Extra OpCodes in the Haskell code code:\n" ++
                    unlines extra_hs) (null extra_hs)

-- | Custom HUnit test case that forks a Python process and checks
-- correspondence between Haskell-generated OpCodes and their Python
-- decoded, validated and re-encoded version.
--
-- Note that we have a strange beast here: since launching Python is
-- expensive, we don't do this via a usual QuickProperty, since that's
-- slow (I've tested it, and it's indeed quite slow). Rather, we use a
-- single HUnit assertion, and in it we manually use QuickCheck to
-- generate 500 opcodes times the number of defined opcodes, which
-- then we pass in bulk to Python. The drawbacks to this method are
-- two fold: we cannot control the number of generated opcodes, since
-- HUnit assertions don't get access to the test options, and for the
-- same reason we can't run a repeatable seed. We should probably find
-- a better way to do this, for example by having a
-- separately-launched Python process (if not running the tests would
-- be skipped).
570 571
case_py_compat_types :: HUnit.Assertion
case_py_compat_types = do
572
  let num_opcodes = length OpCodes.allOpIDs * 100
573 574 575
  opcodes <- genSample (vectorOf num_opcodes
                                   (arbitrary::Gen OpCodes.MetaOpCode))
  let with_sum = map (\o -> (OpCodes.opSummary $
Iustin Pop's avatar
Iustin Pop committed
576
                             OpCodes.metaOpCode o, o)) opcodes
577
      serialized = J.encode opcodes
578 579 580 581 582
  -- check for non-ASCII fields, usually due to 'arbitrary :: String'
  mapM_ (\op -> when (any (not . isAscii) (J.encode op)) .
                HUnit.assertFailure $
                  "OpCode has non-ASCII fields: " ++ show op
        ) opcodes
583 584 585
  py_stdout <-
     runPython "from ganeti import opcodes\n\
               \from ganeti import serializer\n\
586
               \import sys\n\
587 588 589 590
               \op_data = serializer.Load(sys.stdin.read())\n\
               \decoded = [opcodes.OpCode.LoadOpCode(o) for o in op_data]\n\
               \for op in decoded:\n\
               \  op.Validate(True)\n\
Iustin Pop's avatar
Iustin Pop committed
591 592
               \encoded = [(op.Summary(), op.__getstate__())\n\
               \           for op in decoded]\n\
593 594 595 596
               \print serializer.Dump(\
               \  encoded,\
               \  private_encoder=serializer.EncodeWithPrivateFields)"
               serialized
597
     >>= checkPythonResult
Iustin Pop's avatar
Iustin Pop committed
598 599
  let deserialised =
        J.decode py_stdout::J.Result [(String, OpCodes.MetaOpCode)]
600 601 602 603 604 605 606 607
  decoded <- case deserialised of
               J.Ok ops -> return ops
               J.Error msg ->
                 HUnit.assertFailure ("Unable to decode opcodes: " ++ msg)
                 -- this already raised an expection, but we need it
                 -- for proper types
                 >> fail "Unable to decode opcodes"
  HUnit.assertEqual "Mismatch in number of returned opcodes"
Iustin Pop's avatar
Iustin Pop committed
608
    (length decoded) (length with_sum)
609
  mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
610
        ) $ zip with_sum decoded
611

612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642
-- | Custom HUnit test case that forks a Python process and checks
-- correspondence between Haskell OpCodes fields and their Python
-- equivalent.
case_py_compat_fields :: HUnit.Assertion
case_py_compat_fields = do
  let hs_fields = sort $ map (\op_id -> (op_id, OpCodes.allOpFields op_id))
                         OpCodes.allOpIDs
  py_stdout <-
     runPython "from ganeti import opcodes\n\
               \import sys\n\
               \from ganeti import serializer\n\
               \fields = [(k, sorted([p[0] for p in v.OP_PARAMS]))\n\
               \           for k, v in opcodes.OP_MAPPING.items()]\n\
               \print serializer.Dump(fields)" ""
     >>= checkPythonResult
  let deserialised = J.decode py_stdout::J.Result [(String, [String])]
  py_fields <- case deserialised of
                 J.Ok v -> return $ sort v
                 J.Error msg ->
                   HUnit.assertFailure ("Unable to decode op fields: " ++ msg)
                   -- this already raised an expection, but we need it
                   -- for proper types
                   >> fail "Unable to decode op fields"
  HUnit.assertEqual "Mismatch in number of returned opcodes"
    (length hs_fields) (length py_fields)
  HUnit.assertEqual "Mismatch in defined OP_IDs"
    (map fst hs_fields) (map fst py_fields)
  mapM_ (\((py_id, py_flds), (hs_id, hs_flds)) -> do
           HUnit.assertEqual "Mismatch in OP_ID" py_id hs_id
           HUnit.assertEqual ("Mismatch in fields for " ++ hs_id)
             py_flds hs_flds
643
        ) $ zip hs_fields py_fields
644

645 646 647 648 649 650
-- | Checks that setOpComment works correctly.
prop_setOpComment :: OpCodes.MetaOpCode -> String -> Property
prop_setOpComment op comment =
  let (OpCodes.MetaOpCode common _) = OpCodes.setOpComment comment op
  in OpCodes.opComment common ==? Just comment

651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683
-- | Tests wrong (negative) disk index.
prop_mkDiskIndex_fail :: QuickCheck.Positive Int -> Property
prop_mkDiskIndex_fail (Positive i) =
  case mkDiskIndex (negate i) of
    Bad msg -> printTestCase "error message " $
               "Invalid value" `isPrefixOf` msg
    Ok v -> failTest $ "Succeeded to build disk index '" ++ show v ++
                       "' from negative value " ++ show (negate i)

-- | Tests a few invalid 'readRecreateDisks' cases.
case_readRecreateDisks_fail :: Assertion
case_readRecreateDisks_fail = do
  assertBool "null" $
    isJsonError (J.readJSON J.JSNull::J.Result RecreateDisksInfo)
  assertBool "string" $
    isJsonError (J.readJSON (J.showJSON "abc")::J.Result RecreateDisksInfo)

-- | Tests a few invalid 'readDdmOldChanges' cases.
case_readDdmOldChanges_fail :: Assertion
case_readDdmOldChanges_fail = do
  assertBool "null" $
    isJsonError (J.readJSON J.JSNull::J.Result DdmOldChanges)
  assertBool "string" $
    isJsonError (J.readJSON (J.showJSON "abc")::J.Result DdmOldChanges)

-- | Tests a few invalid 'readExportTarget' cases.
case_readExportTarget_fail :: Assertion
case_readExportTarget_fail = do
  assertBool "null" $
    isJsonError (J.readJSON J.JSNull::J.Result ExportTarget)
  assertBool "int" $
    isJsonError (J.readJSON (J.showJSON (5::Int))::J.Result ExportTarget)

684
testSuite "OpCodes"
685 686
            [ 'prop_serialization
            , 'case_AllDefined
687 688
            , 'case_py_compat_types
            , 'case_py_compat_fields
689
            , 'prop_setOpComment
690 691 692 693
            , 'prop_mkDiskIndex_fail
            , 'case_readRecreateDisks_fail
            , 'case_readDdmOldChanges_fail
            , 'case_readExportTarget_fail
694
            ]