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

Jose A. Lopes's avatar
Jose A. Lopes committed
61 62
instance (Ord k, Arbitrary k, Arbitrary a) => Arbitrary (Map.Map k a) where
  arbitrary = Map.fromList <$> arbitrary
63

64 65 66 67 68 69 70 71 72 73 74 75 76 77 78
arbitraryOpTagsGet :: Gen OpCodes.OpCode
arbitraryOpTagsGet = do
  kind <- arbitrary
  OpCodes.OpTagsSet kind <$> arbitrary <*> genOpCodesTagName kind

arbitraryOpTagsSet :: Gen OpCodes.OpCode
arbitraryOpTagsSet = do
  kind <- arbitrary
  OpCodes.OpTagsSet kind <$> genTags <*> genOpCodesTagName kind

arbitraryOpTagsDel :: Gen OpCodes.OpCode
arbitraryOpTagsDel = do
  kind <- arbitrary
  OpCodes.OpTagsDel kind <$> genTags <*> genOpCodesTagName kind

79
$(genArbitrary ''OpCodes.ReplaceDisksMode)
80

81 82
$(genArbitrary ''DiskAccess)

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

86
instance Arbitrary INicParams where
87
  arbitrary = INicParams <$> genMaybe genNameNE <*> genMaybe genName <*>
88 89 90
              genMaybe genNameNE <*> genMaybe genNameNE <*>
              genMaybe genNameNE <*> genMaybe genNameNE <*>
              genMaybe genNameNE
91

92 93
instance Arbitrary IDiskParams where
  arbitrary = IDiskParams <$> arbitrary <*> arbitrary <*>
94
              genMaybe genNameNE <*> genMaybe genNameNE <*>
95
              genMaybe genNameNE <*> genMaybe genNameNE
96

97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113
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
114 115 116 117 118
instance Arbitrary ExportTarget where
  arbitrary = oneof [ ExportTargetLocal <$> genNodeNameNE
                    , ExportTargetRemote <$> pure []
                    ]

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

374 375 376 377 378 379 380 381 382 383
-- | 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

384 385
instance Arbitrary OpCodes.CommonOpParams where
  arbitrary = OpCodes.CommonOpParams <$> arbitrary <*> arbitrary <*>
386 387
                arbitrary <*> resize 5 arbitrary <*> genMaybe genName <*>
                genReasonTrail
388

389 390
-- * Helper functions

391 392 393 394 395 396
-- | Empty JSObject.
emptyJSObject :: J.JSObject J.JSValue
emptyJSObject = J.toJSObject []

-- | Empty maybe unchecked dictionary.
emptyMUD :: Gen (Maybe (J.JSObject J.JSValue))
397
emptyMUD = genMaybe $ pure emptyJSObject
398 399 400 401 402

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

403 404 405 406
-- | Generates list of disk indices.
genDiskIndices :: Gen [DiskIndex]
genDiskIndices = do
  cnt <- choose (0, C.maxDisks)
407
  genUniquesList cnt arbitrary
408 409 410

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

413 414
-- | Generates a list of node names in non-empty string type.
genNodeNamesNE :: Gen [NonEmptyString]
Iustin Pop's avatar
Iustin Pop committed
415
genNodeNamesNE = genNodeNames >>= mapM mkNonEmpty
416

417 418
-- | Gets a node name in non-empty type.
genNodeNameNE :: Gen NonEmptyString
419
genNodeNameNE = genFQDN >>= mkNonEmpty
420

421 422
-- | Gets a name (non-fqdn) in non-empty type.
genNameNE :: Gen NonEmptyString
423
genNameNE = genName >>= mkNonEmpty
424

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

429 430
-- | Returns a list of non-empty fields.
genFieldsNE :: Gen [NonEmptyString]
431
genFieldsNE = genFields >>= mapM mkNonEmpty
432

433 434 435 436 437 438
-- | Generate a 3-byte MAC prefix.
genMacPrefix :: Gen NonEmptyString
genMacPrefix = do
  octets <- vectorOf 3 $ choose (0::Int, 255)
  mkNonEmpty . intercalate ":" $ map (printf "%02x") octets

439 440 441
-- | Arbitrary instance for MetaOpCode, defined here due to TH ordering.
$(genArbitrary ''OpCodes.MetaOpCode)

442 443 444 445 446
-- | Small helper to check for a failed JSON deserialisation
isJsonError :: J.Result a -> Bool
isJsonError (J.Error _) = True
isJsonError _           = False

447 448 449
-- * Test cases

-- | Check that opcode serialization is idempotent.
450
prop_serialization :: OpCodes.OpCode -> Property
451
prop_serialization = testSerialisation
452 453

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

533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565
-- | 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

566 567 568 569 570 571
-- | 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

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

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