Statistics
| Branch: | Tag: | Revision:

root / htest / Test / Ganeti / OpCodes.hs @ f56013fd

History | View | Annotate | Download (23.8 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 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
instance Arbitrary OpCodes.DiskIndex where
73
  arbitrary = choose (0, C.maxDisks - 1) >>= OpCodes.mkDiskIndex
74

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

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

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

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

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

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

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

    
342
instance Arbitrary OpCodes.CommonOpParams where
343
  arbitrary = OpCodes.CommonOpParams <$> arbitrary <*> arbitrary <*>
344
                arbitrary <*> resize 5 arbitrary <*> genMaybe genName
345

    
346
-- * Helper functions
347

    
348
-- | Empty JSObject.
349
emptyJSObject :: J.JSObject J.JSValue
350
emptyJSObject = J.toJSObject []
351

    
352
-- | Empty maybe unchecked dictionary.
353
emptyMUD :: Gen (Maybe (J.JSObject J.JSValue))
354
emptyMUD = genMaybe $ pure emptyJSObject
355

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

    
360
-- | Generates list of disk indices.
361
genDiskIndices :: Gen [DiskIndex]
362
genDiskIndices = do
363
  cnt <- choose (0, C.maxDisks)
364
  genUniquesList cnt arbitrary
365

    
366
-- | Generates a list of node names.
367
genNodeNames :: Gen [String]
368
genNodeNames = resize maxNodes (listOf genFQDN)
369

    
370
-- | Generates a list of node names in non-empty string type.
371
genNodeNamesNE :: Gen [NonEmptyString]
372
genNodeNamesNE = genNodeNames >>= mapM mkNonEmpty
373

    
374
-- | Gets a node name in non-empty type.
375
genNodeNameNE :: Gen NonEmptyString
376
genNodeNameNE = genFQDN >>= mkNonEmpty
377

    
378
-- | Gets a name (non-fqdn) in non-empty type.
379
genNameNE :: Gen NonEmptyString
380
genNameNE = genName >>= mkNonEmpty
381

    
382
-- | Gets a list of names (non-fqdn) in non-empty type.
383
genNamesNE :: Gen [NonEmptyString]
384
genNamesNE = resize maxNodes (listOf genNameNE)
385

    
386
-- | Returns a list of non-empty fields.
387
genFieldsNE :: Gen [NonEmptyString]
388
genFieldsNE = genFields >>= mapM mkNonEmpty
389

    
390
-- | Generate a 3-byte MAC prefix.
391
genMacPrefix :: Gen NonEmptyString
392
genMacPrefix = do
393
  octets <- vectorOf 3 $ choose (0::Int, 255)
394
  mkNonEmpty . intercalate ":" $ map (printf "%02x") octets
395

    
396
-- | Arbitrary instance for MetaOpCode, defined here due to TH ordering.
397
$(genArbitrary ''OpCodes.MetaOpCode)
398

    
399
-- | Small helper to check for a failed JSON deserialisation
400
isJsonError :: J.Result a -> Bool
401
isJsonError (J.Error _) = True
402
isJsonError _           = False
403

    
404
-- * Test cases
405

    
406
-- | Check that opcode serialization is idempotent.
407
prop_serialization :: OpCodes.OpCode -> Property
408
prop_serialization = testSerialisation
409

    
410
-- | Check that Python and Haskell defined the same opcode list.
411
case_AllDefined :: HUnit.Assertion
412
case_AllDefined = do
413
  let py_ops = sort C.opcodesOpIds
414
      hs_ops = sort OpCodes.allOpIDs
415
      extra_py = py_ops \\ hs_ops
416
      extra_hs = hs_ops \\ py_ops
417
  HUnit.assertBool ("Missing OpCodes from the Haskell code:\n" ++
418
                    unlines extra_py) (null extra_py)
419
  HUnit.assertBool ("Extra OpCodes in the Haskell code code:\n" ++
420
                    unlines extra_hs) (null extra_hs)
421

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

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

    
511
-- | Checks that setOpComment works correctly.
512
prop_setOpComment :: OpCodes.MetaOpCode -> String -> Property
513
prop_setOpComment op comment =
514
  let (OpCodes.MetaOpCode common _) = OpCodes.setOpComment comment op
515
  in OpCodes.opComment common ==? Just comment
516

    
517
-- | Tests wrong tag object building (cluster takes only jsnull, the
518
-- other take a string, so we test the opposites).
519
case_TagObject_fail :: Assertion
520
case_TagObject_fail =
521
  mapM_ (\(t, j) -> assertEqual (show t ++ "/" ++ J.encode j) Nothing $
522
                    tagObjectFrom t j)
523
    [ (TagTypeCluster,  J.showJSON "abc")
524
    , (TagTypeInstance, J.JSNull)
525
    , (TagTypeNode,     J.JSNull)
526
    , (TagTypeGroup,    J.JSNull)
527
    ]
528

    
529
-- | Tests wrong (negative) disk index.
530
prop_mkDiskIndex_fail :: QuickCheck.Positive Int -> Property
531
prop_mkDiskIndex_fail (Positive i) =
532
  case mkDiskIndex (negate i) of
533
    Bad msg -> printTestCase "error message " $
534
               "Invalid value" `isPrefixOf` msg
535
    Ok v -> failTest $ "Succeeded to build disk index '" ++ show v ++
536
                       "' from negative value " ++ show (negate i)
537

    
538
-- | Tests a few invalid 'readRecreateDisks' cases.
539
case_readRecreateDisks_fail :: Assertion
540
case_readRecreateDisks_fail = do
541
  assertBool "null" $
542
    isJsonError (J.readJSON J.JSNull::J.Result RecreateDisksInfo)
543
  assertBool "string" $
544
    isJsonError (J.readJSON (J.showJSON "abc")::J.Result RecreateDisksInfo)
545

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

    
554
-- | Tests a few invalid 'readExportTarget' cases.
555
case_readExportTarget_fail :: Assertion
556
case_readExportTarget_fail = do
557
  assertBool "null" $
558
    isJsonError (J.readJSON J.JSNull::J.Result ExportTarget)
559
  assertBool "int" $
560
    isJsonError (J.readJSON (J.showJSON (5::Int))::J.Result ExportTarget)
561

    
562
testSuite "OpCodes"
563
            [ 'prop_serialization
564
            , 'case_AllDefined
565
            , 'case_py_compat_types
566
            , 'case_py_compat_fields
567
            , 'prop_setOpComment
568
            , 'case_TagObject_fail
569
            , 'prop_mkDiskIndex_fail
570
            , 'case_readRecreateDisks_fail
571
            , 'case_readDdmOldChanges_fail
572
            , 'case_readExportTarget_fail
573
            ]