OpCodes.hs 25.9 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

61
instance Arbitrary OpCodes.TagObject where
62
63
64
  arbitrary = oneof [ OpCodes.TagInstance <$> genFQDN
                    , OpCodes.TagNode     <$> genFQDN
                    , OpCodes.TagGroup    <$> genFQDN
65
66
                    , pure OpCodes.TagCluster
                    ]
67

68
$(genArbitrary ''OpCodes.ReplaceDisksMode)
69

70
71
$(genArbitrary ''DiskAccess)

72
73
74
instance Arbitrary OpCodes.DiskIndex where
  arbitrary = choose (0, C.maxDisks - 1) >>= OpCodes.mkDiskIndex

75
instance Arbitrary INicParams where
76
  arbitrary = INicParams <$> genMaybe genNameNE <*> genMaybe genName <*>
77
              genMaybe genNameNE <*> genMaybe genNameNE <*> genMaybe genNameNE
78
              <*> genMaybe genNameNE
79

80
81
instance Arbitrary IDiskParams where
  arbitrary = IDiskParams <$> arbitrary <*> arbitrary <*>
82
              genMaybe genNameNE <*> genMaybe genNameNE <*>
83
              genMaybe genNameNE <*> genMaybe genNameNE
84

85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
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
102
103
104
105
106
instance Arbitrary ExportTarget where
  arbitrary = oneof [ ExportTargetLocal <$> genNodeNameNE
                    , ExportTargetRemote <$> pure []
                    ]

107
108
109
110
111
instance Arbitrary OpCodes.OpCode where
  arbitrary = do
    op_id <- elements OpCodes.allOpIDs
    case op_id of
      "OP_TEST_DELAY" ->
112
        OpCodes.OpTestDelay <$> arbitrary <*> arbitrary <*>
Thomas Thrainer's avatar
Thomas Thrainer committed
113
          genNodeNamesNE <*> return Nothing <*> arbitrary
114
      "OP_INSTANCE_REPLACE_DISKS" ->
115
116
        OpCodes.OpInstanceReplaceDisks <$> genFQDN <*> return Nothing <*>
          arbitrary <*> arbitrary <*> arbitrary <*> genDiskIndices <*>
Thomas Thrainer's avatar
Thomas Thrainer committed
117
          genMaybe genNodeNameNE <*> return Nothing <*> genMaybe genNameNE
118
      "OP_INSTANCE_FAILOVER" ->
119
120
121
        OpCodes.OpInstanceFailover <$> genFQDN <*> return Nothing <*>
        arbitrary <*> arbitrary <*> genMaybe genNodeNameNE <*>
        return Nothing <*> arbitrary <*> genMaybe genNameNE
122
      "OP_INSTANCE_MIGRATE" ->
123
124
125
126
        OpCodes.OpInstanceMigrate <$> genFQDN <*> return Nothing <*>
          arbitrary <*> arbitrary <*> genMaybe genNodeNameNE <*>
          return Nothing <*> arbitrary <*> arbitrary <*> arbitrary <*>
          genMaybe genNameNE <*> arbitrary
127
128
129
130
      "OP_TAGS_GET" ->
        OpCodes.OpTagsGet <$> arbitrary <*> arbitrary
      "OP_TAGS_SEARCH" ->
        OpCodes.OpTagsSearch <$> genNameNE
131
      "OP_TAGS_SET" ->
132
        OpCodes.OpTagsSet <$> arbitrary <*> genTags
133
      "OP_TAGS_DEL" ->
134
        OpCodes.OpTagsSet <$> arbitrary <*> genTags
135
136
137
138
139
      "OP_CLUSTER_POST_INIT" -> pure OpCodes.OpClusterPostInit
      "OP_CLUSTER_DESTROY" -> pure OpCodes.OpClusterDestroy
      "OP_CLUSTER_QUERY" -> pure OpCodes.OpClusterQuery
      "OP_CLUSTER_VERIFY" ->
        OpCodes.OpClusterVerify <$> arbitrary <*> arbitrary <*>
140
          genSet Nothing <*> genSet Nothing <*> arbitrary <*>
141
          genMaybe genNameNE
142
143
144
145
      "OP_CLUSTER_VERIFY_CONFIG" ->
        OpCodes.OpClusterVerifyConfig <$> arbitrary <*> arbitrary <*>
          genSet Nothing <*> arbitrary
      "OP_CLUSTER_VERIFY_GROUP" ->
146
        OpCodes.OpClusterVerifyGroup <$> genNameNE <*> arbitrary <*>
147
148
149
          arbitrary <*> genSet Nothing <*> genSet Nothing <*> arbitrary
      "OP_CLUSTER_VERIFY_DISKS" -> pure OpCodes.OpClusterVerifyDisks
      "OP_GROUP_VERIFY_DISKS" ->
150
        OpCodes.OpGroupVerifyDisks <$> genNameNE
151
      "OP_CLUSTER_REPAIR_DISK_SIZES" ->
152
        OpCodes.OpClusterRepairDiskSizes <$> genNodeNamesNE
153
      "OP_CLUSTER_CONFIG_QUERY" ->
154
        OpCodes.OpClusterConfigQuery <$> genFieldsNE
155
      "OP_CLUSTER_RENAME" ->
156
        OpCodes.OpClusterRename <$> genNameNE
157
      "OP_CLUSTER_SET_PARAMS" ->
158
        OpCodes.OpClusterSetParams <$> arbitrary <*> emptyMUD <*> emptyMUD <*>
159
160
161
162
          arbitrary <*> genMaybe (listOf1 arbitrary >>= mkNonEmpty) <*>
          genMaybe genEmptyContainer <*> emptyMUD <*>
          genMaybe genEmptyContainer <*> genMaybe genEmptyContainer <*>
          genMaybe genEmptyContainer <*> genMaybe arbitrary <*>
163
164
165
          arbitrary <*> arbitrary <*> arbitrary <*>
          arbitrary <*> arbitrary <*> arbitrary <*>
          emptyMUD <*> emptyMUD <*> arbitrary <*>
166
          arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>
167
168
          arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>
          genMaybe (genName >>= mkNonEmpty)
169
170
171
172
173
174
175
176
177
178
      "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" ->
        OpCodes.OpQuery <$> arbitrary <*> arbitrary <*> arbitrary <*> genFilter
      "OP_QUERY_FIELDS" ->
        OpCodes.OpQueryFields <$> arbitrary <*> arbitrary
      "OP_OOB_COMMAND" ->
Thomas Thrainer's avatar
Thomas Thrainer committed
179
180
181
182
183
        OpCodes.OpOobCommand <$> genNodeNamesNE <*> return Nothing <*>
          arbitrary <*> arbitrary <*> arbitrary <*>
          (arbitrary `suchThat` (>0))
      "OP_NODE_REMOVE" ->
        OpCodes.OpNodeRemove <$> genNodeNameNE <*> return Nothing
184
      "OP_NODE_ADD" ->
185
        OpCodes.OpNodeAdd <$> genNodeNameNE <*> emptyMUD <*> emptyMUD <*>
186
187
          genMaybe genName <*> genMaybe genNameNE <*> arbitrary <*>
          genMaybe genNameNE <*> arbitrary <*> arbitrary <*> emptyMUD
188
      "OP_NODE_QUERY" ->
189
        OpCodes.OpNodeQuery <$> genFieldsNE <*> genNamesNE <*> arbitrary
190
191
192
193
      "OP_NODE_QUERYVOLS" ->
        OpCodes.OpNodeQueryvols <$> arbitrary <*> genNodeNamesNE
      "OP_NODE_QUERY_STORAGE" ->
        OpCodes.OpNodeQueryStorage <$> arbitrary <*> arbitrary <*>
194
          genNodeNamesNE <*> genNameNE
195
      "OP_NODE_MODIFY_STORAGE" ->
Thomas Thrainer's avatar
Thomas Thrainer committed
196
197
        OpCodes.OpNodeModifyStorage <$> genNodeNameNE <*> return Nothing <*>
          arbitrary <*> genNameNE <*> pure emptyJSObject
198
      "OP_REPAIR_NODE_STORAGE" ->
Thomas Thrainer's avatar
Thomas Thrainer committed
199
200
        OpCodes.OpRepairNodeStorage <$> genNodeNameNE <*> return Nothing <*>
          arbitrary <*> genNameNE <*> arbitrary
201
      "OP_NODE_SET_PARAMS" ->
Thomas Thrainer's avatar
Thomas Thrainer committed
202
203
204
205
        OpCodes.OpNodeSetParams <$> genNodeNameNE <*> return Nothing <*>
          arbitrary <*> emptyMUD <*> emptyMUD <*> arbitrary <*> arbitrary <*>
          arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>
          genMaybe genNameNE <*> emptyMUD <*> arbitrary
206
      "OP_NODE_POWERCYCLE" ->
Thomas Thrainer's avatar
Thomas Thrainer committed
207
208
        OpCodes.OpNodePowercycle <$> genNodeNameNE <*> return Nothing <*>
          arbitrary
209
      "OP_NODE_MIGRATE" ->
Thomas Thrainer's avatar
Thomas Thrainer committed
210
211
212
        OpCodes.OpNodeMigrate <$> genNodeNameNE <*> return Nothing <*>
          arbitrary <*> arbitrary <*> genMaybe genNodeNameNE <*>
          return Nothing <*> arbitrary <*> arbitrary <*> genMaybe genNameNE
213
214
      "OP_NODE_EVACUATE" ->
        OpCodes.OpNodeEvacuate <$> arbitrary <*> genNodeNameNE <*>
Thomas Thrainer's avatar
Thomas Thrainer committed
215
216
          return Nothing <*> genMaybe genNodeNameNE <*> return Nothing <*>
          genMaybe genNameNE <*> arbitrary
217
      "OP_INSTANCE_CREATE" ->
218
        OpCodes.OpInstanceCreate <$> genFQDN <*> arbitrary <*>
219
          arbitrary <*> arbitrary <*> arbitrary <*> pure emptyJSObject <*>
220
221
          arbitrary <*> arbitrary <*> arbitrary <*> genMaybe genNameNE <*>
          pure emptyJSObject <*> arbitrary <*> genMaybe genNameNE <*>
222
223
          arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>
          arbitrary <*> arbitrary <*> pure emptyJSObject <*>
224
          genMaybe genNameNE <*>
Thomas Thrainer's avatar
Thomas Thrainer committed
225
226
          genMaybe genNodeNameNE <*> return Nothing <*>
          genMaybe genNodeNameNE <*> return Nothing <*>
227
          genMaybe (pure []) <*> genMaybe genNodeNameNE <*>
Thomas Thrainer's avatar
Thomas Thrainer committed
228
          arbitrary <*> genMaybe genNodeNameNE <*> return Nothing <*>
229
          genMaybe genNodeNameNE <*> genMaybe genNameNE <*>
230
          arbitrary <*> arbitrary <*> (genTags >>= mapM mkNonEmpty)
231
      "OP_INSTANCE_MULTI_ALLOC" ->
232
233
        OpCodes.OpInstanceMultiAlloc <$> genMaybe genNameNE <*> pure [] <*>
          arbitrary
234
      "OP_INSTANCE_REINSTALL" ->
235
236
        OpCodes.OpInstanceReinstall <$> genFQDN <*> return Nothing <*>
          arbitrary <*> genMaybe genNameNE <*> genMaybe (pure emptyJSObject)
237
      "OP_INSTANCE_REMOVE" ->
238
        OpCodes.OpInstanceRemove <$> genFQDN <*> return Nothing <*>
239
          arbitrary <*> arbitrary
240
241
242
      "OP_INSTANCE_RENAME" ->
        OpCodes.OpInstanceRename <$> genFQDN <*> return Nothing <*>
          genNodeNameNE <*> arbitrary <*> arbitrary
243
      "OP_INSTANCE_STARTUP" ->
244
245
246
        OpCodes.OpInstanceStartup <$> genFQDN <*> return Nothing <*>
          arbitrary <*> arbitrary <*> pure emptyJSObject <*>
          pure emptyJSObject <*> arbitrary <*> arbitrary
247
      "OP_INSTANCE_SHUTDOWN" ->
248
249
        OpCodes.OpInstanceShutdown <$> genFQDN <*> return Nothing <*>
          arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
250
      "OP_INSTANCE_REBOOT" ->
251
252
        OpCodes.OpInstanceReboot <$> genFQDN <*> return Nothing <*>
          arbitrary <*> arbitrary <*> arbitrary
253
      "OP_INSTANCE_MOVE" ->
254
255
256
257
258
        OpCodes.OpInstanceMove <$> genFQDN <*> return Nothing <*>
          arbitrary <*> arbitrary <*> genNodeNameNE <*> return Nothing <*>
          arbitrary
      "OP_INSTANCE_CONSOLE" -> OpCodes.OpInstanceConsole <$> genFQDN <*>
          return Nothing
259
      "OP_INSTANCE_ACTIVATE_DISKS" ->
260
        OpCodes.OpInstanceActivateDisks <$> genFQDN <*> return Nothing <*>
261
262
          arbitrary <*> arbitrary
      "OP_INSTANCE_DEACTIVATE_DISKS" ->
263
264
        OpCodes.OpInstanceDeactivateDisks <$> genFQDN <*> return Nothing <*>
          arbitrary
265
      "OP_INSTANCE_RECREATE_DISKS" ->
266
267
268
        OpCodes.OpInstanceRecreateDisks <$> genFQDN <*> return Nothing <*>
          arbitrary <*> genNodeNamesNE <*> return Nothing <*>
          genMaybe genNameNE
Iustin Pop's avatar
Iustin Pop committed
269
270
      "OP_INSTANCE_QUERY" ->
        OpCodes.OpInstanceQuery <$> genFieldsNE <*> genNamesNE <*> arbitrary
271
272
273
274
      "OP_INSTANCE_QUERY_DATA" ->
        OpCodes.OpInstanceQueryData <$> arbitrary <*>
          genNodeNamesNE <*> arbitrary
      "OP_INSTANCE_SET_PARAMS" ->
275
        OpCodes.OpInstanceSetParams <$> genFQDN <*> return Nothing <*>
276
          arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>
277
278
279
          arbitrary <*> pure emptyJSObject <*> arbitrary <*>
          pure emptyJSObject <*> arbitrary <*> genMaybe genNodeNameNE <*>
          return Nothing <*> genMaybe genNodeNameNE <*> return Nothing <*>
280
281
          genMaybe genNameNE <*> pure emptyJSObject <*> arbitrary <*>
          arbitrary <*> arbitrary
282
      "OP_INSTANCE_GROW_DISK" ->
283
284
        OpCodes.OpInstanceGrowDisk <$> genFQDN <*> return Nothing <*>
          arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
285
      "OP_INSTANCE_CHANGE_GROUP" ->
286
287
288
        OpCodes.OpInstanceChangeGroup <$> genFQDN <*> return Nothing <*>
          arbitrary <*> genMaybe genNameNE <*>
          genMaybe (resize maxNodes (listOf genNameNE))
Iustin Pop's avatar
Iustin Pop committed
289
290
      "OP_GROUP_ADD" ->
        OpCodes.OpGroupAdd <$> genNameNE <*> arbitrary <*>
291
          emptyMUD <*> genMaybe genEmptyContainer <*>
Iustin Pop's avatar
Iustin Pop committed
292
293
294
          emptyMUD <*> emptyMUD <*> emptyMUD
      "OP_GROUP_ASSIGN_NODES" ->
        OpCodes.OpGroupAssignNodes <$> genNameNE <*> arbitrary <*>
Thomas Thrainer's avatar
Thomas Thrainer committed
295
          genNodeNamesNE <*> return Nothing
Iustin Pop's avatar
Iustin Pop committed
296
297
298
299
      "OP_GROUP_QUERY" ->
        OpCodes.OpGroupQuery <$> genFieldsNE <*> genNamesNE
      "OP_GROUP_SET_PARAMS" ->
        OpCodes.OpGroupSetParams <$> genNameNE <*> arbitrary <*>
300
          emptyMUD <*> genMaybe genEmptyContainer <*>
Iustin Pop's avatar
Iustin Pop committed
301
302
303
304
305
306
307
          emptyMUD <*> emptyMUD <*> emptyMUD
      "OP_GROUP_REMOVE" ->
        OpCodes.OpGroupRemove <$> genNameNE
      "OP_GROUP_RENAME" ->
        OpCodes.OpGroupRename <$> genNameNE <*> genNameNE
      "OP_GROUP_EVACUATE" ->
        OpCodes.OpGroupEvacuate <$> genNameNE <*> arbitrary <*>
308
          genMaybe genNameNE <*> genMaybe genNamesNE
Iustin Pop's avatar
Iustin Pop committed
309
310
      "OP_OS_DIAGNOSE" ->
        OpCodes.OpOsDiagnose <$> genFieldsNE <*> genNamesNE
311
312
      "OP_EXT_STORAGE_DIAGNOSE" ->
        OpCodes.OpOsDiagnose <$> genFieldsNE <*> genNamesNE
Iustin Pop's avatar
Iustin Pop committed
313
314
315
      "OP_BACKUP_QUERY" ->
        OpCodes.OpBackupQuery <$> arbitrary <*> genNodeNamesNE
      "OP_BACKUP_PREPARE" ->
316
        OpCodes.OpBackupPrepare <$> genFQDN <*> return Nothing <*> arbitrary
Iustin Pop's avatar
Iustin Pop committed
317
      "OP_BACKUP_EXPORT" ->
318
319
320
        OpCodes.OpBackupExport <$> genFQDN <*> return Nothing <*>
          arbitrary <*> arbitrary <*> return Nothing <*> arbitrary <*>
          arbitrary <*> arbitrary <*> arbitrary <*> genMaybe (pure []) <*>
Thomas Thrainer's avatar
Thomas Thrainer committed
321
          genMaybe genNameNE
Iustin Pop's avatar
Iustin Pop committed
322
      "OP_BACKUP_REMOVE" ->
323
        OpCodes.OpBackupRemove <$> genFQDN <*> return Nothing
Iustin Pop's avatar
Iustin Pop committed
324
325
326
      "OP_TEST_ALLOCATOR" ->
        OpCodes.OpTestAllocator <$> arbitrary <*> arbitrary <*>
          genNameNE <*> pure [] <*> pure [] <*>
327
          arbitrary <*> genMaybe genNameNE <*>
Iustin Pop's avatar
Iustin Pop committed
328
          (genTags >>= mapM mkNonEmpty) <*>
329
330
331
          arbitrary <*> arbitrary <*> genMaybe genNameNE <*>
          arbitrary <*> genMaybe genNodeNamesNE <*> arbitrary <*>
          genMaybe genNamesNE <*> arbitrary <*> arbitrary
Iustin Pop's avatar
Iustin Pop committed
332
333
      "OP_TEST_JQUEUE" ->
        OpCodes.OpTestJqueue <$> arbitrary <*> arbitrary <*>
334
          resize 20 (listOf genFQDN) <*> arbitrary
Iustin Pop's avatar
Iustin Pop committed
335
336
337
      "OP_TEST_DUMMY" ->
        OpCodes.OpTestDummy <$> pure J.JSNull <*> pure J.JSNull <*>
          pure J.JSNull <*> pure J.JSNull
338
      "OP_NETWORK_ADD" ->
339
        OpCodes.OpNetworkAdd <$> genNameNE <*> genIp4Net <*>
340
341
          genMaybe genIp4Addr <*> pure Nothing <*> pure Nothing <*>
          genMaybe genMacPrefix <*> genMaybe (listOf genIp4Addr) <*>
Iustin Pop's avatar
Iustin Pop committed
342
          arbitrary <*> (genTags >>= mapM mkNonEmpty)
343
344
345
      "OP_NETWORK_REMOVE" ->
        OpCodes.OpNetworkRemove <$> genNameNE <*> arbitrary
      "OP_NETWORK_SET_PARAMS" ->
346
        OpCodes.OpNetworkSetParams <$> genNameNE <*>
347
348
349
          genMaybe genIp4Addr <*> pure Nothing <*> pure Nothing <*>
          genMaybe genMacPrefix <*> genMaybe (listOf genIp4Addr) <*>
          genMaybe (listOf genIp4Addr)
350
351
352
353
      "OP_NETWORK_CONNECT" ->
        OpCodes.OpNetworkConnect <$> genNameNE <*> genNameNE <*>
          arbitrary <*> genNameNE <*> arbitrary
      "OP_NETWORK_DISCONNECT" ->
354
        OpCodes.OpNetworkDisconnect <$> genNameNE <*> genNameNE
355
      "OP_NETWORK_QUERY" ->
356
        OpCodes.OpNetworkQuery <$> genFieldsNE <*> genNamesNE <*> arbitrary
Iustin Pop's avatar
Iustin Pop committed
357
358
      "OP_RESTRICTED_COMMAND" ->
        OpCodes.OpRestrictedCommand <$> arbitrary <*> genNodeNamesNE <*>
Thomas Thrainer's avatar
Thomas Thrainer committed
359
          return Nothing <*> genNameNE
360
      _ -> fail $ "Undefined arbitrary for opcode " ++ op_id
361

362
363
364
365
366
367
368
369
370
371
-- | 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

372
373
instance Arbitrary OpCodes.CommonOpParams where
  arbitrary = OpCodes.CommonOpParams <$> arbitrary <*> arbitrary <*>
374
375
                arbitrary <*> resize 5 arbitrary <*> genMaybe genName <*>
                genReasonTrail
376

377
378
-- * Helper functions

379
380
381
382
383
384
-- | Empty JSObject.
emptyJSObject :: J.JSObject J.JSValue
emptyJSObject = J.toJSObject []

-- | Empty maybe unchecked dictionary.
emptyMUD :: Gen (Maybe (J.JSObject J.JSValue))
385
emptyMUD = genMaybe $ pure emptyJSObject
386
387
388
389
390

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

391
392
393
394
-- | Generates list of disk indices.
genDiskIndices :: Gen [DiskIndex]
genDiskIndices = do
  cnt <- choose (0, C.maxDisks)
395
  genUniquesList cnt arbitrary
396
397
398

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

401
402
-- | Generates a list of node names in non-empty string type.
genNodeNamesNE :: Gen [NonEmptyString]
Iustin Pop's avatar
Iustin Pop committed
403
genNodeNamesNE = genNodeNames >>= mapM mkNonEmpty
404

405
406
-- | Gets a node name in non-empty type.
genNodeNameNE :: Gen NonEmptyString
407
genNodeNameNE = genFQDN >>= mkNonEmpty
408

409
410
-- | Gets a name (non-fqdn) in non-empty type.
genNameNE :: Gen NonEmptyString
411
genNameNE = genName >>= mkNonEmpty
412

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

417
418
-- | Returns a list of non-empty fields.
genFieldsNE :: Gen [NonEmptyString]
419
genFieldsNE = genFields >>= mapM mkNonEmpty
420

421
422
423
424
425
426
-- | Generate a 3-byte MAC prefix.
genMacPrefix :: Gen NonEmptyString
genMacPrefix = do
  octets <- vectorOf 3 $ choose (0::Int, 255)
  mkNonEmpty . intercalate ":" $ map (printf "%02x") octets

427
428
429
-- | Arbitrary instance for MetaOpCode, defined here due to TH ordering.
$(genArbitrary ''OpCodes.MetaOpCode)

430
431
432
433
434
-- | Small helper to check for a failed JSON deserialisation
isJsonError :: J.Result a -> Bool
isJsonError (J.Error _) = True
isJsonError _           = False

435
436
437
-- * Test cases

-- | Check that opcode serialization is idempotent.
438
prop_serialization :: OpCodes.OpCode -> Property
439
prop_serialization = testSerialisation
440
441

-- | Check that Python and Haskell defined the same opcode list.
442
443
case_AllDefined :: HUnit.Assertion
case_AllDefined = do
444
445
446
447
448
449
450
451
452
453
454
455
456
457
  py_stdout <-
     runPython "from ganeti import opcodes\n\
               \from ganeti import serializer\n\
               \import sys\n\
               \print serializer.Dump([opid for opid in opcodes.OP_MAPPING])\n" ""
     >>= 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
458
      extra_py = py_ops \\ hs_ops
459
      extra_hs = hs_ops \\ py_ops
460
461
  HUnit.assertBool ("Missing OpCodes from the Haskell code:\n" ++
                    unlines extra_py) (null extra_py)
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
  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).
481
482
case_py_compat_types :: HUnit.Assertion
case_py_compat_types = do
483
  let num_opcodes = length OpCodes.allOpIDs * 100
484
485
486
  opcodes <- genSample (vectorOf num_opcodes
                                   (arbitrary::Gen OpCodes.MetaOpCode))
  let with_sum = map (\o -> (OpCodes.opSummary $
Iustin Pop's avatar
Iustin Pop committed
487
                             OpCodes.metaOpCode o, o)) opcodes
488
      serialized = J.encode opcodes
489
490
491
492
493
  -- 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
494
495
496
497
498
499
500
501
  py_stdout <-
     runPython "from ganeti import opcodes\n\
               \import sys\n\
               \from ganeti import serializer\n\
               \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
502
503
               \encoded = [(op.Summary(), op.__getstate__())\n\
               \           for op in decoded]\n\
504
505
               \print serializer.Dump(encoded)" serialized
     >>= checkPythonResult
Iustin Pop's avatar
Iustin Pop committed
506
507
  let deserialised =
        J.decode py_stdout::J.Result [(String, OpCodes.MetaOpCode)]
508
509
510
511
512
513
514
515
  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
516
    (length decoded) (length with_sum)
517
  mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
Iustin Pop's avatar
Iustin Pop committed
518
        ) $ zip decoded with_sum
519

520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
-- | 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
        ) $ zip py_fields hs_fields

553
554
555
556
557
558
-- | 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

559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
-- | Tests wrong tag object building (cluster takes only jsnull, the
-- other take a string, so we test the opposites).
case_TagObject_fail :: Assertion
case_TagObject_fail =
  mapM_ (\(t, j) -> assertEqual (show t ++ "/" ++ J.encode j) Nothing $
                    tagObjectFrom t j)
    [ (TagTypeCluster,  J.showJSON "abc")
    , (TagTypeInstance, J.JSNull)
    , (TagTypeNode,     J.JSNull)
    , (TagTypeGroup,    J.JSNull)
    ]

-- | 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)

604
testSuite "OpCodes"
605
606
            [ 'prop_serialization
            , 'case_AllDefined
607
608
            , 'case_py_compat_types
            , 'case_py_compat_fields
609
            , 'prop_setOpComment
610
611
612
613
614
            , 'case_TagObject_fail
            , 'prop_mkDiskIndex_fail
            , 'case_readRecreateDisks_fail
            , 'case_readDdmOldChanges_fail
            , 'case_readExportTarget_fail
615
            ]