Statistics
| Branch: | Tag: | Revision:

root / test / hs / Test / Ganeti / OpCodes.hs @ 560ef132

History | View | Annotate | Download (26.1 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 <$> arbitrary <*> emptyMUD <*> emptyMUD <*>
175
          arbitrary <*> genMaybe arbitrary <*>
176
          genMaybe genEmptyContainer <*> emptyMUD <*>
177
          genMaybe genEmptyContainer <*> genMaybe genEmptyContainer <*>
178
          genMaybe genEmptyContainer <*> genMaybe arbitrary <*>
179
          genMaybe arbitrary <*>
180
          arbitrary <*> arbitrary <*> arbitrary <*>
181
          arbitrary <*> arbitrary <*> arbitrary <*>
182
          emptyMUD <*> emptyMUD <*> arbitrary <*>
183
          arbitrary  <*> emptyMUD <*> arbitrary <*> arbitrary <*> arbitrary <*>
184
          arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>
185
          arbitrary <*> genMaybe genName <*> genMaybe genName
186
      "OP_CLUSTER_REDIST_CONF" -> pure OpCodes.OpClusterRedistConf
187
      "OP_CLUSTER_ACTIVATE_MASTER_IP" ->
188
        pure OpCodes.OpClusterActivateMasterIp
189
      "OP_CLUSTER_DEACTIVATE_MASTER_IP" ->
190
        pure OpCodes.OpClusterDeactivateMasterIp
191
      "OP_QUERY" ->
192
        OpCodes.OpQuery <$> arbitrary <*> arbitrary <*> arbitrary <*>
193
        pure Nothing
194
      "OP_QUERY_FIELDS" ->
195
        OpCodes.OpQueryFields <$> arbitrary <*> arbitrary
196
      "OP_OOB_COMMAND" ->
197
        OpCodes.OpOobCommand <$> genNodeNamesNE <*> return Nothing <*>
198
          arbitrary <*> arbitrary <*> arbitrary <*>
199
          (arbitrary `suchThat` (>0))
200
      "OP_NODE_REMOVE" ->
201
        OpCodes.OpNodeRemove <$> genNodeNameNE <*> return Nothing
202
      "OP_NODE_ADD" ->
203
        OpCodes.OpNodeAdd <$> genNodeNameNE <*> emptyMUD <*> emptyMUD <*>
204
          genMaybe genNameNE <*> genMaybe genNameNE <*> arbitrary <*>
205
          genMaybe genNameNE <*> arbitrary <*> arbitrary <*> emptyMUD
206
      "OP_NODE_QUERYVOLS" ->
207
        OpCodes.OpNodeQueryvols <$> arbitrary <*> genNodeNamesNE
208
      "OP_NODE_QUERY_STORAGE" ->
209
        OpCodes.OpNodeQueryStorage <$> arbitrary <*> arbitrary <*>
210
          genNodeNamesNE <*> genMaybe genNameNE
211
      "OP_NODE_MODIFY_STORAGE" ->
212
        OpCodes.OpNodeModifyStorage <$> genNodeNameNE <*> return Nothing <*>
213
          arbitrary <*> genMaybe genNameNE <*> pure emptyJSObject
214
      "OP_REPAIR_NODE_STORAGE" ->
215
        OpCodes.OpRepairNodeStorage <$> genNodeNameNE <*> return Nothing <*>
216
          arbitrary <*> genMaybe genNameNE <*> arbitrary
217
      "OP_NODE_SET_PARAMS" ->
218
        OpCodes.OpNodeSetParams <$> genNodeNameNE <*> return Nothing <*>
219
          arbitrary <*> emptyMUD <*> emptyMUD <*> arbitrary <*> arbitrary <*>
220
          arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>
221
          genMaybe genNameNE <*> emptyMUD <*> arbitrary
222
      "OP_NODE_POWERCYCLE" ->
223
        OpCodes.OpNodePowercycle <$> genNodeNameNE <*> return Nothing <*>
224
          arbitrary
225
      "OP_NODE_MIGRATE" ->
226
        OpCodes.OpNodeMigrate <$> genNodeNameNE <*> return Nothing <*>
227
          arbitrary <*> arbitrary <*> genMaybe genNodeNameNE <*>
228
          return Nothing <*> arbitrary <*> arbitrary <*> genMaybe genNameNE
229
      "OP_NODE_EVACUATE" ->
230
        OpCodes.OpNodeEvacuate <$> arbitrary <*> genNodeNameNE <*>
231
          return Nothing <*> genMaybe genNodeNameNE <*> return Nothing <*>
232
          genMaybe genNameNE <*> arbitrary
233
      "OP_INSTANCE_CREATE" ->
234
        OpCodes.OpInstanceCreate <$> genFQDN <*> arbitrary <*>
235
          arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>
236
          pure emptyJSObject <*> arbitrary <*> arbitrary <*> arbitrary <*>
237
          genMaybe genNameNE <*> pure emptyJSObject <*> arbitrary <*>
238
          genMaybe genNameNE <*> arbitrary <*> arbitrary <*> arbitrary <*>
239
          arbitrary <*> arbitrary <*> arbitrary <*> pure emptyJSObject <*>
240
          genMaybe genNameNE <*> genMaybe genNodeNameNE <*> return Nothing <*>
241
          genMaybe genNodeNameNE <*> return Nothing <*> genMaybe (pure []) <*>
242
          genMaybe genNodeNameNE <*> arbitrary <*> genMaybe genNodeNameNE <*>
243
          return Nothing <*> genMaybe genNodeNameNE <*> genMaybe genNameNE <*>
244
          arbitrary <*> arbitrary <*> (genTags >>= mapM mkNonEmpty) <*>
245
          arbitrary
246
      "OP_INSTANCE_MULTI_ALLOC" ->
247
        OpCodes.OpInstanceMultiAlloc <$> arbitrary <*> genMaybe genNameNE <*>
248
        pure []
249
      "OP_INSTANCE_REINSTALL" ->
250
        OpCodes.OpInstanceReinstall <$> genFQDN <*> return Nothing <*>
251
          arbitrary <*> genMaybe genNameNE <*> genMaybe (pure emptyJSObject)
252
      "OP_INSTANCE_REMOVE" ->
253
        OpCodes.OpInstanceRemove <$> genFQDN <*> return Nothing <*>
254
          arbitrary <*> arbitrary
255
      "OP_INSTANCE_RENAME" ->
256
        OpCodes.OpInstanceRename <$> genFQDN <*> return Nothing <*>
257
          genNodeNameNE <*> arbitrary <*> arbitrary
258
      "OP_INSTANCE_STARTUP" ->
259
        OpCodes.OpInstanceStartup <$> genFQDN <*> return Nothing <*>
260
          arbitrary <*> arbitrary <*> pure emptyJSObject <*>
261
          pure emptyJSObject <*> arbitrary <*> arbitrary
262
      "OP_INSTANCE_SHUTDOWN" ->
263
        OpCodes.OpInstanceShutdown <$> genFQDN <*> return Nothing <*>
264
          arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
265
      "OP_INSTANCE_REBOOT" ->
266
        OpCodes.OpInstanceReboot <$> genFQDN <*> return Nothing <*>
267
          arbitrary <*> arbitrary <*> arbitrary
268
      "OP_INSTANCE_MOVE" ->
269
        OpCodes.OpInstanceMove <$> genFQDN <*> return Nothing <*>
270
          arbitrary <*> arbitrary <*> genNodeNameNE <*> return Nothing <*>
271
          arbitrary <*> arbitrary
272
      "OP_INSTANCE_CONSOLE" -> OpCodes.OpInstanceConsole <$> genFQDN <*>
273
          return Nothing
274
      "OP_INSTANCE_ACTIVATE_DISKS" ->
275
        OpCodes.OpInstanceActivateDisks <$> genFQDN <*> return Nothing <*>
276
          arbitrary <*> arbitrary
277
      "OP_INSTANCE_DEACTIVATE_DISKS" ->
278
        OpCodes.OpInstanceDeactivateDisks <$> genFQDN <*> return Nothing <*>
279
          arbitrary
280
      "OP_INSTANCE_RECREATE_DISKS" ->
281
        OpCodes.OpInstanceRecreateDisks <$> genFQDN <*> return Nothing <*>
282
          arbitrary <*> genNodeNamesNE <*> return Nothing <*>
283
          genMaybe genNameNE
284
      "OP_INSTANCE_QUERY_DATA" ->
285
        OpCodes.OpInstanceQueryData <$> arbitrary <*>
286
          genNodeNamesNE <*> arbitrary
287
      "OP_INSTANCE_SET_PARAMS" ->
288
        OpCodes.OpInstanceSetParams <$> genFQDN <*> return Nothing <*>
289
          arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>
290
          arbitrary <*> pure emptyJSObject <*> arbitrary <*>
291
          pure emptyJSObject <*> arbitrary <*> genMaybe genNodeNameNE <*>
292
          return Nothing <*> genMaybe genNodeNameNE <*> return Nothing <*>
293
          genMaybe genNameNE <*> pure emptyJSObject <*> arbitrary <*>
294
          arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
295
      "OP_INSTANCE_GROW_DISK" ->
296
        OpCodes.OpInstanceGrowDisk <$> genFQDN <*> return Nothing <*>
297
          arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
298
      "OP_INSTANCE_CHANGE_GROUP" ->
299
        OpCodes.OpInstanceChangeGroup <$> genFQDN <*> return Nothing <*>
300
          arbitrary <*> genMaybe genNameNE <*>
301
          genMaybe (resize maxNodes (listOf genNameNE))
302
      "OP_GROUP_ADD" ->
303
        OpCodes.OpGroupAdd <$> genNameNE <*> arbitrary <*>
304
          emptyMUD <*> genMaybe genEmptyContainer <*>
305
          emptyMUD <*> emptyMUD <*> emptyMUD
306
      "OP_GROUP_ASSIGN_NODES" ->
307
        OpCodes.OpGroupAssignNodes <$> genNameNE <*> arbitrary <*>
308
          genNodeNamesNE <*> return Nothing
309
      "OP_GROUP_SET_PARAMS" ->
310
        OpCodes.OpGroupSetParams <$> genNameNE <*> arbitrary <*>
311
          emptyMUD <*> genMaybe genEmptyContainer <*>
312
          emptyMUD <*> emptyMUD <*> emptyMUD
313
      "OP_GROUP_REMOVE" ->
314
        OpCodes.OpGroupRemove <$> genNameNE
315
      "OP_GROUP_RENAME" ->
316
        OpCodes.OpGroupRename <$> genNameNE <*> genNameNE
317
      "OP_GROUP_EVACUATE" ->
318
        OpCodes.OpGroupEvacuate <$> genNameNE <*> arbitrary <*>
319
          genMaybe genNameNE <*> genMaybe genNamesNE
320
      "OP_OS_DIAGNOSE" ->
321
        OpCodes.OpOsDiagnose <$> genFieldsNE <*> genNamesNE
322
      "OP_EXT_STORAGE_DIAGNOSE" ->
323
        OpCodes.OpOsDiagnose <$> genFieldsNE <*> genNamesNE
324
      "OP_BACKUP_PREPARE" ->
325
        OpCodes.OpBackupPrepare <$> genFQDN <*> return Nothing <*> arbitrary
326
      "OP_BACKUP_EXPORT" ->
327
        OpCodes.OpBackupExport <$> genFQDN <*> return Nothing <*>
328
          arbitrary <*> arbitrary <*> arbitrary <*> return Nothing <*>
329
          arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>
330
          genMaybe (pure []) <*> genMaybe genNameNE
331
      "OP_BACKUP_REMOVE" ->
332
        OpCodes.OpBackupRemove <$> genFQDN <*> return Nothing
333
      "OP_TEST_ALLOCATOR" ->
334
        OpCodes.OpTestAllocator <$> arbitrary <*> arbitrary <*>
335
          genNameNE <*> genMaybe (pure []) <*> genMaybe (pure []) <*>
336
          arbitrary <*> genMaybe genNameNE <*>
337
          (genTags >>= mapM mkNonEmpty) <*>
338
          arbitrary <*> arbitrary <*> genMaybe genNameNE <*>
339
          arbitrary <*> genMaybe genNodeNamesNE <*> arbitrary <*>
340
          genMaybe genNamesNE <*> arbitrary <*> arbitrary
341
      "OP_TEST_JQUEUE" ->
342
        OpCodes.OpTestJqueue <$> arbitrary <*> arbitrary <*>
343
          resize 20 (listOf genFQDN) <*> arbitrary
344
      "OP_TEST_DUMMY" ->
345
        OpCodes.OpTestDummy <$> pure J.JSNull <*> pure J.JSNull <*>
346
          pure J.JSNull <*> pure J.JSNull
347
      "OP_NETWORK_ADD" ->
348
        OpCodes.OpNetworkAdd <$> genNameNE <*> genIPv4Network <*>
349
          genMaybe genIPv4Address <*> pure Nothing <*> pure Nothing <*>
350
          genMaybe genMacPrefix <*> genMaybe (listOf genIPv4Address) <*>
351
          arbitrary <*> (genTags >>= mapM mkNonEmpty)
352
      "OP_NETWORK_REMOVE" ->
353
        OpCodes.OpNetworkRemove <$> genNameNE <*> arbitrary
354
      "OP_NETWORK_SET_PARAMS" ->
355
        OpCodes.OpNetworkSetParams <$> genNameNE <*>
356
          genMaybe genIPv4Address <*> pure Nothing <*> pure Nothing <*>
357
          genMaybe genMacPrefix <*> genMaybe (listOf genIPv4Address) <*>
358
          genMaybe (listOf genIPv4Address)
359
      "OP_NETWORK_CONNECT" ->
360
        OpCodes.OpNetworkConnect <$> genNameNE <*> genNameNE <*>
361
          arbitrary <*> genNameNE <*> arbitrary
362
      "OP_NETWORK_DISCONNECT" ->
363
        OpCodes.OpNetworkDisconnect <$> genNameNE <*> genNameNE
364
      "OP_RESTRICTED_COMMAND" ->
365
        OpCodes.OpRestrictedCommand <$> arbitrary <*> genNodeNamesNE <*>
366
          return Nothing <*> genNameNE
367
      _ -> fail $ "Undefined arbitrary for opcode " ++ op_id
368

    
369
-- | Generates one element of a reason trail
370
genReasonElem :: Gen ReasonElem
371
genReasonElem = (,,) <$> genFQDN <*> genFQDN <*> arbitrary
372

    
373
-- | Generates a reason trail
374
genReasonTrail :: Gen ReasonTrail
375
genReasonTrail = do
376
  size <- choose (0, 10)
377
  vectorOf size genReasonElem
378

    
379
instance Arbitrary OpCodes.CommonOpParams where
380
  arbitrary = OpCodes.CommonOpParams <$> arbitrary <*> arbitrary <*>
381
                arbitrary <*> resize 5 arbitrary <*> genMaybe genName <*>
382
                genReasonTrail
383

    
384
-- * Helper functions
385

    
386
-- | Empty JSObject.
387
emptyJSObject :: J.JSObject J.JSValue
388
emptyJSObject = J.toJSObject []
389

    
390
-- | Empty maybe unchecked dictionary.
391
emptyMUD :: Gen (Maybe (J.JSObject J.JSValue))
392
emptyMUD = genMaybe $ pure emptyJSObject
393

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

    
398
-- | Generates list of disk indices.
399
genDiskIndices :: Gen [DiskIndex]
400
genDiskIndices = do
401
  cnt <- choose (0, C.maxDisks)
402
  genUniquesList cnt arbitrary
403

    
404
-- | Generates a list of node names.
405
genNodeNames :: Gen [String]
406
genNodeNames = resize maxNodes (listOf genFQDN)
407

    
408
-- | Generates a list of node names in non-empty string type.
409
genNodeNamesNE :: Gen [NonEmptyString]
410
genNodeNamesNE = genNodeNames >>= mapM mkNonEmpty
411

    
412
-- | Gets a node name in non-empty type.
413
genNodeNameNE :: Gen NonEmptyString
414
genNodeNameNE = genFQDN >>= mkNonEmpty
415

    
416
-- | Gets a name (non-fqdn) in non-empty type.
417
genNameNE :: Gen NonEmptyString
418
genNameNE = genName >>= mkNonEmpty
419

    
420
-- | Gets a list of names (non-fqdn) in non-empty type.
421
genNamesNE :: Gen [NonEmptyString]
422
genNamesNE = resize maxNodes (listOf genNameNE)
423

    
424
-- | Returns a list of non-empty fields.
425
genFieldsNE :: Gen [NonEmptyString]
426
genFieldsNE = genFields >>= mapM mkNonEmpty
427

    
428
-- | Generate a 3-byte MAC prefix.
429
genMacPrefix :: Gen NonEmptyString
430
genMacPrefix = do
431
  octets <- vectorOf 3 $ choose (0::Int, 255)
432
  mkNonEmpty . intercalate ":" $ map (printf "%02x") octets
433

    
434
-- | JSObject of arbitrary data.
435
--
436
-- Since JSValue does not implement Arbitrary, I'll simply generate
437
-- (String, String) objects.
438
arbitraryPrivateJSObj :: Gen (J.JSObject (Private J.JSValue))
439
arbitraryPrivateJSObj =
440
  constructor <$> (fromNonEmpty <$> genNameNE)
441
              <*> (fromNonEmpty <$> genNameNE)
442
    where constructor k v = showPrivateJSObject [(k, v)]
443

    
444
-- | Arbitrary instance for MetaOpCode, defined here due to TH ordering.
445
$(genArbitrary ''OpCodes.MetaOpCode)
446

    
447
-- | Small helper to check for a failed JSON deserialisation
448
isJsonError :: J.Result a -> Bool
449
isJsonError (J.Error _) = True
450
isJsonError _           = False
451

    
452
-- * Test cases
453

    
454
-- | Check that opcode serialization is idempotent.
455
prop_serialization :: OpCodes.OpCode -> Property
456
prop_serialization = testSerialisation
457

    
458
-- | Check that Python and Haskell defined the same opcode list.
459
case_AllDefined :: HUnit.Assertion
460
case_AllDefined = do
461
  py_stdout <-
462
     runPython "from ganeti import opcodes\n\
463
               \from ganeti import serializer\n\
464
               \import sys\n\
465
               \print serializer.Dump([opid for opid in opcodes.OP_MAPPING])\n"
466
               ""
467
     >>= checkPythonResult
468
  py_ops <- case J.decode py_stdout::J.Result [String] of
469
               J.Ok ops -> return ops
470
               J.Error msg ->
471
                 HUnit.assertFailure ("Unable to decode opcode names: " ++ msg)
472
                 -- this already raised an expection, but we need it
473
                 -- for proper types
474
                 >> fail "Unable to decode opcode names"
475
  let hs_ops = sort OpCodes.allOpIDs
476
      extra_py = py_ops \\ hs_ops
477
      extra_hs = hs_ops \\ py_ops
478
  HUnit.assertBool ("Missing OpCodes from the Haskell code:\n" ++
479
                    unlines extra_py) (null extra_py)
480
  HUnit.assertBool ("Extra OpCodes in the Haskell code code:\n" ++
481
                    unlines extra_hs) (null extra_hs)
482

    
483
-- | Custom HUnit test case that forks a Python process and checks
484
-- correspondence between Haskell-generated OpCodes and their Python
485
-- decoded, validated and re-encoded version.
486
--
487
-- Note that we have a strange beast here: since launching Python is
488
-- expensive, we don't do this via a usual QuickProperty, since that's
489
-- slow (I've tested it, and it's indeed quite slow). Rather, we use a
490
-- single HUnit assertion, and in it we manually use QuickCheck to
491
-- generate 500 opcodes times the number of defined opcodes, which
492
-- then we pass in bulk to Python. The drawbacks to this method are
493
-- two fold: we cannot control the number of generated opcodes, since
494
-- HUnit assertions don't get access to the test options, and for the
495
-- same reason we can't run a repeatable seed. We should probably find
496
-- a better way to do this, for example by having a
497
-- separately-launched Python process (if not running the tests would
498
-- be skipped).
499
case_py_compat_types :: HUnit.Assertion
500
case_py_compat_types = do
501
  let num_opcodes = length OpCodes.allOpIDs * 100
502
  opcodes <- genSample (vectorOf num_opcodes
503
                                   (arbitrary::Gen OpCodes.MetaOpCode))
504
  let with_sum = map (\o -> (OpCodes.opSummary $
505
                             OpCodes.metaOpCode o, o)) opcodes
506
      serialized = J.encode opcodes
507
  -- check for non-ASCII fields, usually due to 'arbitrary :: String'
508
  mapM_ (\op -> when (any (not . isAscii) (J.encode op)) .
509
                HUnit.assertFailure $
510
                  "OpCode has non-ASCII fields: " ++ show op
511
        ) opcodes
512
  py_stdout <-
513
     runPython "from ganeti import opcodes\n\
514
               \from ganeti import serializer\n\
515
               \import sys\n\
516
               \op_data = serializer.Load(sys.stdin.read())\n\
517
               \decoded = [opcodes.OpCode.LoadOpCode(o) for o in op_data]\n\
518
               \for op in decoded:\n\
519
               \  op.Validate(True)\n\
520
               \encoded = [(op.Summary(), op.__getstate__())\n\
521
               \           for op in decoded]\n\
522
               \print serializer.Dump(\
523
               \  encoded,\
524
               \  private_encoder=serializer.EncodeWithPrivateFields)"
525
               serialized
526
     >>= checkPythonResult
527
  let deserialised =
528
        J.decode py_stdout::J.Result [(String, OpCodes.MetaOpCode)]
529
  decoded <- case deserialised of
530
               J.Ok ops -> return ops
531
               J.Error msg ->
532
                 HUnit.assertFailure ("Unable to decode opcodes: " ++ msg)
533
                 -- this already raised an expection, but we need it
534
                 -- for proper types
535
                 >> fail "Unable to decode opcodes"
536
  HUnit.assertEqual "Mismatch in number of returned opcodes"
537
    (length decoded) (length with_sum)
538
  mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
539
        ) $ zip with_sum decoded
540

    
541
-- | Custom HUnit test case that forks a Python process and checks
542
-- correspondence between Haskell OpCodes fields and their Python
543
-- equivalent.
544
case_py_compat_fields :: HUnit.Assertion
545
case_py_compat_fields = do
546
  let hs_fields = sort $ map (\op_id -> (op_id, OpCodes.allOpFields op_id))
547
                         OpCodes.allOpIDs
548
  py_stdout <-
549
     runPython "from ganeti import opcodes\n\
550
               \import sys\n\
551
               \from ganeti import serializer\n\
552
               \fields = [(k, sorted([p[0] for p in v.OP_PARAMS]))\n\
553
               \           for k, v in opcodes.OP_MAPPING.items()]\n\
554
               \print serializer.Dump(fields)" ""
555
     >>= checkPythonResult
556
  let deserialised = J.decode py_stdout::J.Result [(String, [String])]
557
  py_fields <- case deserialised of
558
                 J.Ok v -> return $ sort v
559
                 J.Error msg ->
560
                   HUnit.assertFailure ("Unable to decode op fields: " ++ msg)
561
                   -- this already raised an expection, but we need it
562
                   -- for proper types
563
                   >> fail "Unable to decode op fields"
564
  HUnit.assertEqual "Mismatch in number of returned opcodes"
565
    (length hs_fields) (length py_fields)
566
  HUnit.assertEqual "Mismatch in defined OP_IDs"
567
    (map fst hs_fields) (map fst py_fields)
568
  mapM_ (\((py_id, py_flds), (hs_id, hs_flds)) -> do
569
           HUnit.assertEqual "Mismatch in OP_ID" py_id hs_id
570
           HUnit.assertEqual ("Mismatch in fields for " ++ hs_id)
571
             py_flds hs_flds
572
        ) $ zip hs_fields py_fields
573

    
574
-- | Checks that setOpComment works correctly.
575
prop_setOpComment :: OpCodes.MetaOpCode -> String -> Property
576
prop_setOpComment op comment =
577
  let (OpCodes.MetaOpCode common _) = OpCodes.setOpComment comment op
578
  in OpCodes.opComment common ==? Just comment
579

    
580
-- | Tests wrong (negative) disk index.
581
prop_mkDiskIndex_fail :: QuickCheck.Positive Int -> Property
582
prop_mkDiskIndex_fail (Positive i) =
583
  case mkDiskIndex (negate i) of
584
    Bad msg -> printTestCase "error message " $
585
               "Invalid value" `isPrefixOf` msg
586
    Ok v -> failTest $ "Succeeded to build disk index '" ++ show v ++
587
                       "' from negative value " ++ show (negate i)
588

    
589
-- | Tests a few invalid 'readRecreateDisks' cases.
590
case_readRecreateDisks_fail :: Assertion
591
case_readRecreateDisks_fail = do
592
  assertBool "null" $
593
    isJsonError (J.readJSON J.JSNull::J.Result RecreateDisksInfo)
594
  assertBool "string" $
595
    isJsonError (J.readJSON (J.showJSON "abc")::J.Result RecreateDisksInfo)
596

    
597
-- | Tests a few invalid 'readDdmOldChanges' cases.
598
case_readDdmOldChanges_fail :: Assertion
599
case_readDdmOldChanges_fail = do
600
  assertBool "null" $
601
    isJsonError (J.readJSON J.JSNull::J.Result DdmOldChanges)
602
  assertBool "string" $
603
    isJsonError (J.readJSON (J.showJSON "abc")::J.Result DdmOldChanges)
604

    
605
-- | Tests a few invalid 'readExportTarget' cases.
606
case_readExportTarget_fail :: Assertion
607
case_readExportTarget_fail = do
608
  assertBool "null" $
609
    isJsonError (J.readJSON J.JSNull::J.Result ExportTarget)
610
  assertBool "int" $
611
    isJsonError (J.readJSON (J.showJSON (5::Int))::J.Result ExportTarget)
612

    
613
testSuite "OpCodes"
614
            [ 'prop_serialization
615
            , 'case_AllDefined
616
            , 'case_py_compat_types
617
            , 'case_py_compat_fields
618
            , 'prop_setOpComment
619
            , 'prop_mkDiskIndex_fail
620
            , 'case_readRecreateDisks_fail
621
            , 'case_readDdmOldChanges_fail
622
            , 'case_readExportTarget_fail
623
            ]