Statistics
| Branch: | Tag: | Revision:

root / test / hs / Test / Ganeti / OpCodes.hs @ 4e4433e8

History | View | Annotate | Download (24.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 Arbitrary OpCodes.TagObject where
62
  arbitrary = oneof [ OpCodes.TagInstance <$> genFQDN
63
                    , OpCodes.TagNode     <$> genFQDN
64
                    , OpCodes.TagGroup    <$> genFQDN
65
                    , pure OpCodes.TagCluster
66
                    ]
67

    
68
$(genArbitrary ''OpCodes.ReplaceDisksMode)
69

    
70
$(genArbitrary ''DiskAccess)
71

    
72
$(genArbitrary ''InstReasonSrc)
73

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

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

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

    
86
instance Arbitrary RecreateDisksInfo where
87
  arbitrary = oneof [ pure RecreateDisksAll
88
                    , RecreateDisksIndices <$> arbitrary
89
                    , RecreateDisksParams <$> arbitrary
90
                    ]
91

    
92
instance Arbitrary DdmOldChanges where
93
  arbitrary = oneof [ DdmOldIndex <$> arbitrary
94
                    , DdmOldMod   <$> arbitrary
95
                    ]
96

    
97
instance (Arbitrary a) => Arbitrary (SetParamsMods a) where
98
  arbitrary = oneof [ pure SetParamsEmpty
99
                    , SetParamsDeprecated <$> arbitrary
100
                    , SetParamsNew        <$> arbitrary
101
                    ]
102

    
103
instance Arbitrary ExportTarget where
104
  arbitrary = oneof [ ExportTargetLocal <$> genNodeNameNE
105
                    , ExportTargetRemote <$> pure []
106
                    ]
107

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

    
347
instance Arbitrary OpCodes.CommonOpParams where
348
  arbitrary = OpCodes.CommonOpParams <$> arbitrary <*> arbitrary <*>
349
                arbitrary <*> resize 5 arbitrary <*> genMaybe genName
350

    
351
-- * Helper functions
352

    
353
-- | Empty JSObject.
354
emptyJSObject :: J.JSObject J.JSValue
355
emptyJSObject = J.toJSObject []
356

    
357
-- | Empty maybe unchecked dictionary.
358
emptyMUD :: Gen (Maybe (J.JSObject J.JSValue))
359
emptyMUD = genMaybe $ pure emptyJSObject
360

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

    
365
-- | Generates list of disk indices.
366
genDiskIndices :: Gen [DiskIndex]
367
genDiskIndices = do
368
  cnt <- choose (0, C.maxDisks)
369
  genUniquesList cnt arbitrary
370

    
371
-- | Generates a list of node names.
372
genNodeNames :: Gen [String]
373
genNodeNames = resize maxNodes (listOf genFQDN)
374

    
375
-- | Generates a list of node names in non-empty string type.
376
genNodeNamesNE :: Gen [NonEmptyString]
377
genNodeNamesNE = genNodeNames >>= mapM mkNonEmpty
378

    
379
-- | Gets a node name in non-empty type.
380
genNodeNameNE :: Gen NonEmptyString
381
genNodeNameNE = genFQDN >>= mkNonEmpty
382

    
383
-- | Gets a name (non-fqdn) in non-empty type.
384
genNameNE :: Gen NonEmptyString
385
genNameNE = genName >>= mkNonEmpty
386

    
387
-- | Gets a list of names (non-fqdn) in non-empty type.
388
genNamesNE :: Gen [NonEmptyString]
389
genNamesNE = resize maxNodes (listOf genNameNE)
390

    
391
-- | Returns a list of non-empty fields.
392
genFieldsNE :: Gen [NonEmptyString]
393
genFieldsNE = genFields >>= mapM mkNonEmpty
394

    
395
-- | Generate a 3-byte MAC prefix.
396
genMacPrefix :: Gen NonEmptyString
397
genMacPrefix = do
398
  octets <- vectorOf 3 $ choose (0::Int, 255)
399
  mkNonEmpty . intercalate ":" $ map (printf "%02x") octets
400

    
401
-- | Generate a non empty string
402
genStringNE :: Gen NonEmptyString
403
genStringNE = genName >>= mkNonEmpty
404

    
405
-- | Arbitrary instance for MetaOpCode, defined here due to TH ordering.
406
$(genArbitrary ''OpCodes.MetaOpCode)
407

    
408
-- | Small helper to check for a failed JSON deserialisation
409
isJsonError :: J.Result a -> Bool
410
isJsonError (J.Error _) = True
411
isJsonError _           = False
412

    
413
-- * Test cases
414

    
415
-- | Check that opcode serialization is idempotent.
416
prop_serialization :: OpCodes.OpCode -> Property
417
prop_serialization = testSerialisation
418

    
419
-- | Check that Python and Haskell defined the same opcode list.
420
case_AllDefined :: HUnit.Assertion
421
case_AllDefined = do
422
  let py_ops = sort C.opcodesOpIds
423
      hs_ops = sort OpCodes.allOpIDs
424
      extra_py = py_ops \\ hs_ops
425
      extra_hs = hs_ops \\ py_ops
426
  HUnit.assertBool ("Missing OpCodes from the Haskell code:\n" ++
427
                    unlines extra_py) (null extra_py)
428
  HUnit.assertBool ("Extra OpCodes in the Haskell code code:\n" ++
429
                    unlines extra_hs) (null extra_hs)
430

    
431
-- | Custom HUnit test case that forks a Python process and checks
432
-- correspondence between Haskell-generated OpCodes and their Python
433
-- decoded, validated and re-encoded version.
434
--
435
-- Note that we have a strange beast here: since launching Python is
436
-- expensive, we don't do this via a usual QuickProperty, since that's
437
-- slow (I've tested it, and it's indeed quite slow). Rather, we use a
438
-- single HUnit assertion, and in it we manually use QuickCheck to
439
-- generate 500 opcodes times the number of defined opcodes, which
440
-- then we pass in bulk to Python. The drawbacks to this method are
441
-- two fold: we cannot control the number of generated opcodes, since
442
-- HUnit assertions don't get access to the test options, and for the
443
-- same reason we can't run a repeatable seed. We should probably find
444
-- a better way to do this, for example by having a
445
-- separately-launched Python process (if not running the tests would
446
-- be skipped).
447
case_py_compat_types :: HUnit.Assertion
448
case_py_compat_types = do
449
  let num_opcodes = length OpCodes.allOpIDs * 100
450
  opcodes <- genSample (vectorOf num_opcodes
451
                                   (arbitrary::Gen OpCodes.MetaOpCode))
452
  let with_sum = map (\o -> (OpCodes.opSummary $
453
                             OpCodes.metaOpCode o, o)) opcodes
454
      serialized = J.encode opcodes
455
  -- check for non-ASCII fields, usually due to 'arbitrary :: String'
456
  mapM_ (\op -> when (any (not . isAscii) (J.encode op)) .
457
                HUnit.assertFailure $
458
                  "OpCode has non-ASCII fields: " ++ show op
459
        ) opcodes
460
  py_stdout <-
461
     runPython "from ganeti import opcodes\n\
462
               \import sys\n\
463
               \from ganeti import serializer\n\
464
               \op_data = serializer.Load(sys.stdin.read())\n\
465
               \decoded = [opcodes.OpCode.LoadOpCode(o) for o in op_data]\n\
466
               \for op in decoded:\n\
467
               \  op.Validate(True)\n\
468
               \encoded = [(op.Summary(), op.__getstate__())\n\
469
               \           for op in decoded]\n\
470
               \print serializer.Dump(encoded)" serialized
471
     >>= checkPythonResult
472
  let deserialised =
473
        J.decode py_stdout::J.Result [(String, OpCodes.MetaOpCode)]
474
  decoded <- case deserialised of
475
               J.Ok ops -> return ops
476
               J.Error msg ->
477
                 HUnit.assertFailure ("Unable to decode opcodes: " ++ msg)
478
                 -- this already raised an expection, but we need it
479
                 -- for proper types
480
                 >> fail "Unable to decode opcodes"
481
  HUnit.assertEqual "Mismatch in number of returned opcodes"
482
    (length decoded) (length with_sum)
483
  mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
484
        ) $ zip decoded with_sum
485

    
486
-- | Custom HUnit test case that forks a Python process and checks
487
-- correspondence between Haskell OpCodes fields and their Python
488
-- equivalent.
489
case_py_compat_fields :: HUnit.Assertion
490
case_py_compat_fields = do
491
  let hs_fields = sort $ map (\op_id -> (op_id, OpCodes.allOpFields op_id))
492
                         OpCodes.allOpIDs
493
  py_stdout <-
494
     runPython "from ganeti import opcodes\n\
495
               \import sys\n\
496
               \from ganeti import serializer\n\
497
               \fields = [(k, sorted([p[0] for p in v.OP_PARAMS]))\n\
498
               \           for k, v in opcodes.OP_MAPPING.items()]\n\
499
               \print serializer.Dump(fields)" ""
500
     >>= checkPythonResult
501
  let deserialised = J.decode py_stdout::J.Result [(String, [String])]
502
  py_fields <- case deserialised of
503
                 J.Ok v -> return $ sort v
504
                 J.Error msg ->
505
                   HUnit.assertFailure ("Unable to decode op fields: " ++ msg)
506
                   -- this already raised an expection, but we need it
507
                   -- for proper types
508
                   >> fail "Unable to decode op fields"
509
  HUnit.assertEqual "Mismatch in number of returned opcodes"
510
    (length hs_fields) (length py_fields)
511
  HUnit.assertEqual "Mismatch in defined OP_IDs"
512
    (map fst hs_fields) (map fst py_fields)
513
  mapM_ (\((py_id, py_flds), (hs_id, hs_flds)) -> do
514
           HUnit.assertEqual "Mismatch in OP_ID" py_id hs_id
515
           HUnit.assertEqual ("Mismatch in fields for " ++ hs_id)
516
             py_flds hs_flds
517
        ) $ zip py_fields hs_fields
518

    
519
-- | Checks that setOpComment works correctly.
520
prop_setOpComment :: OpCodes.MetaOpCode -> String -> Property
521
prop_setOpComment op comment =
522
  let (OpCodes.MetaOpCode common _) = OpCodes.setOpComment comment op
523
  in OpCodes.opComment common ==? Just comment
524

    
525
-- | Tests wrong tag object building (cluster takes only jsnull, the
526
-- other take a string, so we test the opposites).
527
case_TagObject_fail :: Assertion
528
case_TagObject_fail =
529
  mapM_ (\(t, j) -> assertEqual (show t ++ "/" ++ J.encode j) Nothing $
530
                    tagObjectFrom t j)
531
    [ (TagTypeCluster,  J.showJSON "abc")
532
    , (TagTypeInstance, J.JSNull)
533
    , (TagTypeNode,     J.JSNull)
534
    , (TagTypeGroup,    J.JSNull)
535
    ]
536

    
537
-- | Tests wrong (negative) disk index.
538
prop_mkDiskIndex_fail :: QuickCheck.Positive Int -> Property
539
prop_mkDiskIndex_fail (Positive i) =
540
  case mkDiskIndex (negate i) of
541
    Bad msg -> printTestCase "error message " $
542
               "Invalid value" `isPrefixOf` msg
543
    Ok v -> failTest $ "Succeeded to build disk index '" ++ show v ++
544
                       "' from negative value " ++ show (negate i)
545

    
546
-- | Tests a few invalid 'readRecreateDisks' cases.
547
case_readRecreateDisks_fail :: Assertion
548
case_readRecreateDisks_fail = do
549
  assertBool "null" $
550
    isJsonError (J.readJSON J.JSNull::J.Result RecreateDisksInfo)
551
  assertBool "string" $
552
    isJsonError (J.readJSON (J.showJSON "abc")::J.Result RecreateDisksInfo)
553

    
554
-- | Tests a few invalid 'readDdmOldChanges' cases.
555
case_readDdmOldChanges_fail :: Assertion
556
case_readDdmOldChanges_fail = do
557
  assertBool "null" $
558
    isJsonError (J.readJSON J.JSNull::J.Result DdmOldChanges)
559
  assertBool "string" $
560
    isJsonError (J.readJSON (J.showJSON "abc")::J.Result DdmOldChanges)
561

    
562
-- | Tests a few invalid 'readExportTarget' cases.
563
case_readExportTarget_fail :: Assertion
564
case_readExportTarget_fail = do
565
  assertBool "null" $
566
    isJsonError (J.readJSON J.JSNull::J.Result ExportTarget)
567
  assertBool "int" $
568
    isJsonError (J.readJSON (J.showJSON (5::Int))::J.Result ExportTarget)
569

    
570
testSuite "OpCodes"
571
            [ 'prop_serialization
572
            , 'case_AllDefined
573
            , 'case_py_compat_types
574
            , 'case_py_compat_fields
575
            , 'prop_setOpComment
576
            , 'case_TagObject_fail
577
            , 'prop_mkDiskIndex_fail
578
            , 'case_readRecreateDisks_fail
579
            , 'case_readDdmOldChanges_fail
580
            , 'case_readExportTarget_fail
581
            ]