Statistics
| Branch: | Tag: | Revision:

root / test / hs / Test / Ganeti / OpCodes.hs @ 0cffcdb1

History | View | Annotate | Download (30.2 kB)

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 (Ord k, Arbitrary k, Arbitrary a) => Arbitrary (Map.Map k a) where
62
  arbitrary = Map.fromList <$> arbitrary
63

    
64
arbitraryOpTagsGet :: Gen OpCodes.OpCode
65
arbitraryOpTagsGet = do
66
  kind <- arbitrary
67
  OpCodes.OpTagsSet kind <$> arbitrary <*> genOpCodesTagName kind
68

    
69
arbitraryOpTagsSet :: Gen OpCodes.OpCode
70
arbitraryOpTagsSet = do
71
  kind <- arbitrary
72
  OpCodes.OpTagsSet kind <$> genTags <*> genOpCodesTagName kind
73

    
74
arbitraryOpTagsDel :: Gen OpCodes.OpCode
75
arbitraryOpTagsDel = do
76
  kind <- arbitrary
77
  OpCodes.OpTagsDel kind <$> genTags <*> genOpCodesTagName kind
78

    
79
$(genArbitrary ''OpCodes.ReplaceDisksMode)
80

    
81
$(genArbitrary ''DiskAccess)
82

    
83
$(genArbitrary ''ImportExportCompression)
84

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

    
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
instance Arbitrary IDiskParams where
95
  arbitrary = IDiskParams <$> arbitrary <*> arbitrary <*>
96
              genMaybe genNameNE <*> genMaybe genNameNE <*>
97
              genMaybe genNameNE <*> genMaybe genNameNE <*>
98
              genMaybe genNameNE <*> arbitrary <*> genAndRestArguments
99

    
100
instance Arbitrary RecreateDisksInfo where
101
  arbitrary = oneof [ pure RecreateDisksAll
102
                    , RecreateDisksIndices <$> arbitrary
103
                    , RecreateDisksParams <$> arbitrary
104
                    ]
105

    
106
instance Arbitrary DdmOldChanges where
107
  arbitrary = oneof [ DdmOldIndex <$> arbitrary
108
                    , DdmOldMod   <$> arbitrary
109
                    ]
110

    
111
instance (Arbitrary a) => Arbitrary (SetParamsMods a) where
112
  arbitrary = oneof [ pure SetParamsEmpty
113
                    , SetParamsDeprecated <$> arbitrary
114
                    , SetParamsNew        <$> arbitrary
115
                    ]
116

    
117
instance Arbitrary ExportTarget where
118
  arbitrary = oneof [ ExportTargetLocal <$> genNodeNameNE
119
                    , ExportTargetRemote <$> pure []
120
                    ]
121

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

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

    
446
-- | Generates a reason trail
447
genReasonTrail :: Gen ReasonTrail
448
genReasonTrail = do
449
  size <- choose (0, 10)
450
  vectorOf size genReasonElem
451

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

    
457
-- * Helper functions
458

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

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

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

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

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

    
481
-- | Generates a list of node names in non-empty string type.
482
genNodeNamesNE :: Gen [NonEmptyString]
483
genNodeNamesNE = genNodeNames >>= mapM mkNonEmpty
484

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

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

    
493
-- | Gets a list of names (non-fqdn) in non-empty type.
494
genNamesNE :: Gen [NonEmptyString]
495
genNamesNE = resize maxNodes (listOf genNameNE)
496

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

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

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

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

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

    
525
-- * Test cases
526

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

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

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

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

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

    
653
-- | Tests wrong (negative) disk index.
654
prop_mkDiskIndex_fail :: QuickCheck.Positive Int -> Property
655
prop_mkDiskIndex_fail (Positive i) =
656
  case mkDiskIndex (negate i) of
657
    Bad msg -> printTestCase "error message " $
658
               "Invalid value" `isPrefixOf` msg
659
    Ok v -> failTest $ "Succeeded to build disk index '" ++ show v ++
660
                       "' from negative value " ++ show (negate i)
661

    
662
-- | Tests a few invalid 'readRecreateDisks' cases.
663
case_readRecreateDisks_fail :: Assertion
664
case_readRecreateDisks_fail = do
665
  assertBool "null" $
666
    isJsonError (J.readJSON J.JSNull::J.Result RecreateDisksInfo)
667
  assertBool "string" $
668
    isJsonError (J.readJSON (J.showJSON "abc")::J.Result RecreateDisksInfo)
669

    
670
-- | Tests a few invalid 'readDdmOldChanges' cases.
671
case_readDdmOldChanges_fail :: Assertion
672
case_readDdmOldChanges_fail = do
673
  assertBool "null" $
674
    isJsonError (J.readJSON J.JSNull::J.Result DdmOldChanges)
675
  assertBool "string" $
676
    isJsonError (J.readJSON (J.showJSON "abc")::J.Result DdmOldChanges)
677

    
678
-- | Tests a few invalid 'readExportTarget' cases.
679
case_readExportTarget_fail :: Assertion
680
case_readExportTarget_fail = do
681
  assertBool "null" $
682
    isJsonError (J.readJSON J.JSNull::J.Result ExportTarget)
683
  assertBool "int" $
684
    isJsonError (J.readJSON (J.showJSON (5::Int))::J.Result ExportTarget)
685

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