48a468345fc127c85bc808d34a105926bdbc2289
[ganeti-github.git] / test / hs / Test / Ganeti / OpCodes.hs
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 All rights reserved.
12
13 Redistribution and use in source and binary forms, with or without
14 modification, are permitted provided that the following conditions are
15 met:
16
17 1. Redistributions of source code must retain the above copyright notice,
18 this list of conditions and the following disclaimer.
19
20 2. Redistributions in binary form must reproduce the above copyright
21 notice, this list of conditions and the following disclaimer in the
22 documentation and/or other materials provided with the distribution.
23
24 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
25 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
26 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
27 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
28 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
29 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
30 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
31 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
32 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
33 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
34 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
35
36 -}
37
38 module Test.Ganeti.OpCodes
39 ( testOpCodes
40 , genOpCodeFromId
41 , OpCodes.OpCode(..)
42 ) where
43
44 import Prelude ()
45 import Ganeti.Prelude
46
47 import Test.HUnit as HUnit
48 import Test.QuickCheck as QuickCheck
49
50 import Control.Monad (when)
51 import Data.Char
52 import Data.List
53 import Data.Maybe
54 import qualified Data.Map as Map
55 import qualified Text.JSON as J
56 import Text.Printf (printf)
57
58 import Test.Ganeti.Objects
59 import Test.Ganeti.Query.Language ()
60 import Test.Ganeti.TestHelper
61 import Test.Ganeti.TestCommon
62 import Test.Ganeti.Types (genReasonTrail)
63
64 import Ganeti.BasicTypes
65 import qualified Ganeti.Constants as C
66 import qualified Ganeti.ConstantUtils as CU
67 import qualified Ganeti.OpCodes as OpCodes
68 import Ganeti.Types
69 import Ganeti.OpParams
70 import Ganeti.Objects
71 import Ganeti.JSON
72
73 {-# ANN module "HLint: ignore Use camelCase" #-}
74
75 -- * Arbitrary instances
76
77 arbitraryOpTagsGet :: Gen OpCodes.OpCode
78 arbitraryOpTagsGet = do
79 kind <- arbitrary
80 OpCodes.OpTagsSet kind <$> genTags <*> genOpCodesTagName kind
81
82 arbitraryOpTagsSet :: Gen OpCodes.OpCode
83 arbitraryOpTagsSet = do
84 kind <- arbitrary
85 OpCodes.OpTagsSet kind <$> genTags <*> genOpCodesTagName kind
86
87 arbitraryOpTagsDel :: Gen OpCodes.OpCode
88 arbitraryOpTagsDel = do
89 kind <- arbitrary
90 OpCodes.OpTagsDel kind <$> genTags <*> genOpCodesTagName kind
91
92 $(genArbitrary ''OpCodes.ReplaceDisksMode)
93
94 $(genArbitrary ''DiskAccess)
95
96 instance Arbitrary OpCodes.DiskIndex where
97 arbitrary = choose (0, C.maxDisks - 1) >>= OpCodes.mkDiskIndex
98
99 instance Arbitrary INicParams where
100 arbitrary = INicParams <$> genMaybe genNameNE <*> genMaybe genName <*>
101 genMaybe genNameNE <*> genMaybe genNameNE <*>
102 genMaybe genNameNE <*> genMaybe genName <*>
103 genMaybe genNameNE <*> genMaybe genNameNE
104
105 instance Arbitrary IDiskParams where
106 arbitrary = IDiskParams <$> arbitrary <*> arbitrary <*>
107 genMaybe genNameNE <*> genMaybe genNameNE <*>
108 genMaybe genNameNE <*> genMaybe genNameNE <*>
109 genMaybe genNameNE <*> arbitrary <*>
110 genMaybe genNameNE <*> genAndRestArguments
111
112 instance Arbitrary RecreateDisksInfo where
113 arbitrary = oneof [ pure RecreateDisksAll
114 , RecreateDisksIndices <$> arbitrary
115 , RecreateDisksParams <$> arbitrary
116 ]
117
118 instance Arbitrary DdmOldChanges where
119 arbitrary = oneof [ DdmOldIndex <$> arbitrary
120 , DdmOldMod <$> arbitrary
121 ]
122
123 instance (Arbitrary a) => Arbitrary (SetParamsMods a) where
124 arbitrary = oneof [ pure SetParamsEmpty
125 , SetParamsDeprecated <$> arbitrary
126 , SetParamsNew <$> arbitrary
127 ]
128
129 instance Arbitrary ExportTarget where
130 arbitrary = oneof [ ExportTargetLocal <$> genNodeNameNE
131 , ExportTargetRemote <$> pure []
132 ]
133
134 arbitraryDataCollector :: Gen (GenericContainer String Bool)
135 arbitraryDataCollector = do
136 els <- listOf . elements $ CU.toList C.dataCollectorNames
137 activation <- vector $ length els
138 return . GenericContainer . Map.fromList $ zip els activation
139
140 arbitraryDataCollectorInterval :: Gen (Maybe (GenericContainer String Int))
141 arbitraryDataCollectorInterval = do
142 els <- listOf . elements $ CU.toList C.dataCollectorNames
143 intervals <- vector $ length els
144 genMaybe . return . containerFromList $ zip els intervals
145
146 genOpCodeFromId :: String -> Maybe ConfigData -> Gen OpCodes.OpCode
147 genOpCodeFromId op_id cfg =
148 case op_id of
149 "OP_TEST_DELAY" ->
150 OpCodes.OpTestDelay <$> arbitrary <*> arbitrary <*>
151 genNodeNamesNE <*> return Nothing <*> arbitrary <*> arbitrary <*>
152 arbitrary
153 "OP_INSTANCE_REPLACE_DISKS" ->
154 OpCodes.OpInstanceReplaceDisks <$> getInstanceName <*> return Nothing <*>
155 arbitrary <*> arbitrary <*> arbitrary <*> genDiskIndices <*>
156 genMaybe genNodeNameNE <*> return Nothing <*> genMaybe genNameNE
157 "OP_INSTANCE_FAILOVER" ->
158 OpCodes.OpInstanceFailover <$> getInstanceName <*> return Nothing <*>
159 arbitrary <*> arbitrary <*> genMaybe genNodeNameNE <*>
160 return Nothing <*> arbitrary <*> arbitrary <*> genMaybe genNameNE
161 "OP_INSTANCE_MIGRATE" ->
162 OpCodes.OpInstanceMigrate <$> getInstanceName <*> return Nothing <*>
163 arbitrary <*> arbitrary <*> genMaybe getNodeName <*> return Nothing <*>
164 arbitrary <*> arbitrary <*> arbitrary <*> genMaybe genNameNE <*>
165 arbitrary <*> arbitrary
166 "OP_TAGS_GET" ->
167 arbitraryOpTagsGet
168 "OP_TAGS_SEARCH" ->
169 OpCodes.OpTagsSearch <$> genNameNE
170 "OP_TAGS_SET" ->
171 arbitraryOpTagsSet
172 "OP_TAGS_DEL" ->
173 arbitraryOpTagsDel
174 "OP_CLUSTER_POST_INIT" -> pure OpCodes.OpClusterPostInit
175 "OP_CLUSTER_RENEW_CRYPTO" -> OpCodes.OpClusterRenewCrypto
176 <$> arbitrary -- Node SSL certificates
177 <*> arbitrary -- renew_ssh_keys
178 <*> arbitrary -- ssh_key_type
179 <*> arbitrary -- ssh_key_bits
180 <*> arbitrary -- verbose
181 <*> arbitrary -- debug
182 "OP_CLUSTER_DESTROY" -> pure OpCodes.OpClusterDestroy
183 "OP_CLUSTER_QUERY" -> pure OpCodes.OpClusterQuery
184 "OP_CLUSTER_VERIFY" ->
185 OpCodes.OpClusterVerify <$> arbitrary <*> arbitrary <*>
186 genListSet Nothing <*> genListSet Nothing <*> arbitrary <*>
187 genMaybe getGroupName <*> arbitrary
188 "OP_CLUSTER_VERIFY_CONFIG" ->
189 OpCodes.OpClusterVerifyConfig <$> arbitrary <*> arbitrary <*>
190 genListSet Nothing <*> arbitrary
191 "OP_CLUSTER_VERIFY_GROUP" ->
192 OpCodes.OpClusterVerifyGroup <$> getGroupName <*> arbitrary <*>
193 arbitrary <*> genListSet Nothing <*> genListSet Nothing <*>
194 arbitrary <*> arbitrary
195 "OP_CLUSTER_VERIFY_DISKS" ->
196 OpCodes.OpClusterVerifyDisks <$> genMaybe getGroupName <*> arbitrary
197 "OP_GROUP_VERIFY_DISKS" ->
198 OpCodes.OpGroupVerifyDisks <$> getGroupName <*> arbitrary
199 "OP_CLUSTER_REPAIR_DISK_SIZES" ->
200 OpCodes.OpClusterRepairDiskSizes <$> getInstanceNames
201 "OP_CLUSTER_CONFIG_QUERY" ->
202 OpCodes.OpClusterConfigQuery <$> genFieldsNE
203 "OP_CLUSTER_RENAME" ->
204 OpCodes.OpClusterRename <$> genNameNE
205 "OP_CLUSTER_SET_PARAMS" ->
206 OpCodes.OpClusterSetParams
207 <$> arbitrary -- force
208 <*> emptyMUD -- hv_state
209 <*> emptyMUD -- disk_state
210 <*> genMaybe genName -- vg_name
211 <*> genMaybe arbitrary -- enabled_hypervisors
212 <*> genMaybe genEmptyContainer -- hvparams
213 <*> emptyMUD -- beparams
214 <*> genMaybe genEmptyContainer -- os_hvp
215 <*> genMaybe genEmptyContainer -- osparams
216 <*> genMaybe genEmptyContainer -- osparams_private_cluster
217 <*> genMaybe genEmptyContainer -- diskparams
218 <*> genMaybe arbitrary -- candidate_pool_size
219 <*> genMaybe arbitrary -- max_running_jobs
220 <*> genMaybe arbitrary -- max_tracked_jobs
221 <*> arbitrary -- uid_pool
222 <*> arbitrary -- add_uids
223 <*> arbitrary -- remove_uids
224 <*> arbitrary -- maintain_node_health
225 <*> arbitrary -- prealloc_wipe_disks
226 <*> arbitrary -- nicparams
227 <*> emptyMUD -- ndparams
228 <*> emptyMUD -- ipolicy
229 <*> genMaybe genPrintableAsciiString
230 -- drbd_helper
231 <*> genMaybe genPrintableAsciiString
232 -- default_iallocator
233 <*> emptyMUD -- default_iallocator_params
234 <*> genMaybe genMacPrefix -- mac_prefix
235 <*> genMaybe genPrintableAsciiString
236 -- master_netdev
237 <*> arbitrary -- master_netmask
238 <*> genMaybe (listOf genPrintableAsciiStringNE)
239 -- reserved_lvs
240 <*> genMaybe (listOf ((,) <$> arbitrary
241 <*> genPrintableAsciiStringNE))
242 -- hidden_os
243 <*> genMaybe (listOf ((,) <$> arbitrary
244 <*> genPrintableAsciiStringNE))
245 -- blacklisted_os
246 <*> arbitrary -- use_external_mip_script
247 <*> arbitrary -- enabled_disk_templates
248 <*> arbitrary -- modify_etc_hosts
249 <*> arbitrary -- modify_ssh_config
250 <*> genMaybe genName -- file_storage_dir
251 <*> genMaybe genName -- shared_file_storage_dir
252 <*> genMaybe genName -- gluster_file_storage_dir
253 <*> genMaybe genPrintableAsciiString
254 -- install_image
255 <*> genMaybe genPrintableAsciiString
256 -- instance_communication_network
257 <*> genMaybe genPrintableAsciiString
258 -- zeroing_image
259 <*> genMaybe (listOf genPrintableAsciiStringNE)
260 -- compression_tools
261 <*> arbitrary -- enabled_user_shutdown
262 <*> genMaybe arbitraryDataCollector -- enabled_data_collectors
263 <*> arbitraryDataCollectorInterval -- data_collector_interval
264 <*> genMaybe genName -- diagnose_data_collector_filename
265 <*> genMaybe (fromPositive <$> arbitrary) -- maintd round interval
266 <*> genMaybe arbitrary -- enable maintd balancing
267 <*> genMaybe arbitrary -- maintd balancing threshold
268 "OP_CLUSTER_REDIST_CONF" -> pure OpCodes.OpClusterRedistConf
269 "OP_CLUSTER_ACTIVATE_MASTER_IP" ->
270 pure OpCodes.OpClusterActivateMasterIp
271 "OP_CLUSTER_DEACTIVATE_MASTER_IP" ->
272 pure OpCodes.OpClusterDeactivateMasterIp
273 "OP_QUERY" ->
274 OpCodes.OpQuery <$> arbitrary <*> arbitrary <*> genNamesNE <*>
275 pure Nothing
276 "OP_QUERY_FIELDS" ->
277 OpCodes.OpQueryFields <$> arbitrary <*> genMaybe genNamesNE
278 "OP_OOB_COMMAND" ->
279 OpCodes.OpOobCommand <$> getNodeNames <*> return Nothing <*>
280 arbitrary <*> arbitrary <*> arbitrary <*> (arbitrary `suchThat` (>0))
281 "OP_NODE_REMOVE" ->
282 OpCodes.OpNodeRemove <$> getNodeName <*> return Nothing <*>
283 arbitrary <*> arbitrary
284 "OP_NODE_ADD" ->
285 OpCodes.OpNodeAdd <$> getNodeName <*> emptyMUD <*> emptyMUD <*>
286 genMaybe genNameNE <*> genMaybe genNameNE <*> arbitrary <*>
287 genMaybe genNameNE <*> arbitrary <*> arbitrary <*> emptyMUD <*>
288 arbitrary <*> arbitrary <*> arbitrary
289 "OP_NODE_QUERYVOLS" ->
290 OpCodes.OpNodeQueryvols <$> genNamesNE <*> genNodeNamesNE
291 "OP_NODE_QUERY_STORAGE" ->
292 OpCodes.OpNodeQueryStorage <$> genNamesNE <*> arbitrary <*>
293 getNodeNames <*> genMaybe genNameNE
294 "OP_NODE_MODIFY_STORAGE" ->
295 OpCodes.OpNodeModifyStorage <$> getNodeName <*> return Nothing <*>
296 arbitrary <*> genMaybe genNameNE <*> pure emptyJSObject
297 "OP_REPAIR_NODE_STORAGE" ->
298 OpCodes.OpRepairNodeStorage <$> getNodeName <*> return Nothing <*>
299 arbitrary <*> genMaybe genNameNE <*> arbitrary
300 "OP_NODE_SET_PARAMS" ->
301 OpCodes.OpNodeSetParams <$> getNodeName <*> return Nothing <*>
302 arbitrary <*> emptyMUD <*> emptyMUD <*> arbitrary <*> arbitrary <*>
303 arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>
304 genMaybe genNameNE <*> emptyMUD <*> arbitrary <*> arbitrary <*>
305 arbitrary
306 "OP_NODE_POWERCYCLE" ->
307 OpCodes.OpNodePowercycle <$> getNodeName <*> return Nothing <*> arbitrary
308 "OP_NODE_MIGRATE" ->
309 OpCodes.OpNodeMigrate <$> getNodeName <*> return Nothing <*>
310 arbitrary <*> arbitrary <*> genMaybe getNodeName <*> return Nothing <*>
311 arbitrary <*> arbitrary <*> genMaybe genNameNE
312 "OP_NODE_EVACUATE" ->
313 OpCodes.OpNodeEvacuate <$> arbitrary <*> getNodeName <*>
314 return Nothing <*> genMaybe getNodeName <*> return Nothing <*>
315 genMaybe genNameNE <*> arbitrary <*> arbitrary
316 "OP_INSTANCE_CREATE" ->
317 OpCodes.OpInstanceCreate
318 <$> genFQDN -- instance_name
319 <*> arbitrary -- force_variant
320 <*> arbitrary -- wait_for_sync
321 <*> arbitrary -- name_check
322 <*> arbitrary -- ignore_ipolicy
323 <*> arbitrary -- opportunistic_locking
324 <*> pure emptyJSObject -- beparams
325 <*> arbitrary -- disks
326 <*> arbitrary -- disk_template
327 <*> genMaybe getGroupName -- group_name
328 <*> arbitrary -- file_driver
329 <*> genMaybe genNameNE -- file_storage_dir
330 <*> pure emptyJSObject -- hvparams
331 <*> arbitrary -- hypervisor
332 <*> genMaybe genNameNE -- iallocator
333 <*> arbitrary -- identify_defaults
334 <*> arbitrary -- ip_check
335 <*> arbitrary -- conflicts_check
336 <*> arbitrary -- mode
337 <*> arbitrary -- nics
338 <*> arbitrary -- no_install
339 <*> pure emptyJSObject -- osparams
340 <*> genMaybe arbitraryPrivateJSObj -- osparams_private
341 <*> genMaybe arbitrarySecretJSObj -- osparams_secret
342 <*> genMaybe genNameNE -- os_type
343 <*> genMaybe getNodeName -- pnode
344 <*> return Nothing -- pnode_uuid
345 <*> genMaybe getNodeName -- snode
346 <*> return Nothing -- snode_uuid
347 <*> genMaybe (pure []) -- source_handshake
348 <*> genMaybe genNodeNameNE -- source_instance_name
349 <*> arbitrary -- source_shutdown_timeout
350 <*> genMaybe genNodeNameNE -- source_x509_ca
351 <*> return Nothing -- src_node
352 <*> genMaybe genNodeNameNE -- src_node_uuid
353 <*> genMaybe genNameNE -- src_path
354 <*> genPrintableAsciiString -- compress
355 <*> arbitrary -- start
356 <*> arbitrary -- forthcoming
357 <*> arbitrary -- commit
358 <*> (genTags >>= mapM mkNonEmpty) -- tags
359 <*> arbitrary -- instance_communication
360 <*> arbitrary -- helper_startup_timeout
361 <*> arbitrary -- helper_shutdown_timeout
362 "OP_INSTANCE_MULTI_ALLOC" ->
363 OpCodes.OpInstanceMultiAlloc <$> arbitrary <*> genMaybe genNameNE <*>
364 pure []
365 "OP_INSTANCE_REINSTALL" ->
366 OpCodes.OpInstanceReinstall <$> getInstanceName <*> return Nothing <*>
367 arbitrary <*> genMaybe genNameNE <*> genMaybe (pure emptyJSObject)
368 <*> genMaybe arbitraryPrivateJSObj <*> genMaybe arbitrarySecretJSObj
369 <*> arbitrary <*> arbitrary
370 <*> genMaybe (listOf genPrintableAsciiString)
371 <*> genMaybe (listOf genPrintableAsciiString)
372 "OP_INSTANCE_REMOVE" ->
373 OpCodes.OpInstanceRemove <$> getInstanceName <*> return Nothing <*>
374 arbitrary <*> arbitrary
375 "OP_INSTANCE_RENAME" ->
376 OpCodes.OpInstanceRename <$> getInstanceName <*> return Nothing <*>
377 (genFQDN >>= mkNonEmpty) <*> arbitrary <*> arbitrary
378 "OP_INSTANCE_STARTUP" ->
379 OpCodes.OpInstanceStartup <$>
380 getInstanceName <*> -- instance_name
381 return Nothing <*> -- instance_uuid
382 arbitrary <*> -- force
383 arbitrary <*> -- ignore_offline_nodes
384 pure emptyJSObject <*> -- hvparams
385 pure emptyJSObject <*> -- beparams
386 arbitrary <*> -- no_remember
387 arbitrary <*> -- startup_paused
388 arbitrary -- shutdown_timeout
389 "OP_INSTANCE_SHUTDOWN" ->
390 OpCodes.OpInstanceShutdown <$> getInstanceName <*> return Nothing <*>
391 arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
392 "OP_INSTANCE_REBOOT" ->
393 OpCodes.OpInstanceReboot <$> getInstanceName <*> return Nothing <*>
394 arbitrary <*> arbitrary <*> arbitrary
395 "OP_INSTANCE_MOVE" ->
396 OpCodes.OpInstanceMove <$> getInstanceName <*> return Nothing <*>
397 arbitrary <*> arbitrary <*> getNodeName <*>
398 return Nothing <*> genPrintableAsciiString <*> arbitrary
399 "OP_INSTANCE_CONSOLE" -> OpCodes.OpInstanceConsole <$> getInstanceName <*>
400 return Nothing
401 "OP_INSTANCE_ACTIVATE_DISKS" ->
402 OpCodes.OpInstanceActivateDisks <$> getInstanceName <*> return Nothing <*>
403 arbitrary <*> arbitrary
404 "OP_INSTANCE_DEACTIVATE_DISKS" ->
405 OpCodes.OpInstanceDeactivateDisks <$> genFQDN <*> return Nothing <*>
406 arbitrary
407 "OP_INSTANCE_RECREATE_DISKS" ->
408 OpCodes.OpInstanceRecreateDisks <$> getInstanceName <*> return Nothing <*>
409 arbitrary <*> genNodeNamesNE <*> return Nothing <*> genMaybe getNodeName
410 "OP_INSTANCE_QUERY_DATA" ->
411 OpCodes.OpInstanceQueryData <$> arbitrary <*>
412 getInstanceNames <*> arbitrary
413 "OP_INSTANCE_SET_PARAMS" ->
414 OpCodes.OpInstanceSetParams
415 <$> getInstanceName -- instance_name
416 <*> return Nothing -- instance_uuid
417 <*> arbitrary -- force
418 <*> arbitrary -- force_variant
419 <*> arbitrary -- ignore_ipolicy
420 <*> arbitrary -- nics
421 <*> arbitrary -- disks
422 <*> pure emptyJSObject -- beparams
423 <*> arbitrary -- runtime_mem
424 <*> pure emptyJSObject -- hvparams
425 <*> arbitrary -- disk_template
426 <*> pure emptyJSObject -- ext_params
427 <*> arbitrary -- file_driver
428 <*> genMaybe genNameNE -- file_storage_dir
429 <*> genMaybe getNodeName -- pnode
430 <*> return Nothing -- pnode_uuid
431 <*> genMaybe getNodeName -- remote_node
432 <*> return Nothing -- remote_node_uuid
433 <*> genMaybe genNameNE -- iallocator
434 <*> genMaybe genNameNE -- os_name
435 <*> pure emptyJSObject -- osparams
436 <*> genMaybe arbitraryPrivateJSObj -- osparams_private
437 <*> arbitrary -- clear_osparams
438 <*> arbitrary -- clear_osparams_private
439 <*> genMaybe (listOf genPrintableAsciiString) -- remove_osparams
440 <*> genMaybe (listOf genPrintableAsciiString) -- remove_osparams_private
441 <*> arbitrary -- wait_for_sync
442 <*> arbitrary -- offline
443 <*> arbitrary -- conflicts_check
444 <*> arbitrary -- hotplug
445 <*> arbitrary -- hotplug_if_possible
446 <*> arbitrary -- instance_communication
447 "OP_INSTANCE_GROW_DISK" ->
448 OpCodes.OpInstanceGrowDisk <$> getInstanceName <*> return Nothing <*>
449 arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
450 "OP_INSTANCE_CHANGE_GROUP" ->
451 OpCodes.OpInstanceChangeGroup <$> getInstanceName <*> return Nothing <*>
452 arbitrary <*> genMaybe genNameNE <*>
453 genMaybe (resize maxNodes (listOf genNameNE))
454 "OP_GROUP_ADD" ->
455 OpCodes.OpGroupAdd <$> genNameNE <*> arbitrary <*>
456 emptyMUD <*> genMaybe genEmptyContainer <*>
457 emptyMUD <*> emptyMUD <*> emptyMUD
458 "OP_GROUP_ASSIGN_NODES" ->
459 OpCodes.OpGroupAssignNodes <$> getGroupName <*>
460 arbitrary <*> getNodeNames <*> return Nothing
461 "OP_GROUP_SET_PARAMS" ->
462 OpCodes.OpGroupSetParams <$> getGroupName <*>
463 arbitrary <*> emptyMUD <*> genMaybe genEmptyContainer <*>
464 emptyMUD <*> emptyMUD <*> emptyMUD
465 "OP_GROUP_REMOVE" ->
466 OpCodes.OpGroupRemove <$> getGroupName
467 "OP_GROUP_RENAME" ->
468 OpCodes.OpGroupRename <$> getGroupName <*> genNameNE
469 "OP_GROUP_EVACUATE" ->
470 OpCodes.OpGroupEvacuate <$> getGroupName <*>
471 arbitrary <*> genMaybe genNameNE <*> genMaybe genNamesNE <*>
472 arbitrary <*> arbitrary
473 "OP_OS_DIAGNOSE" ->
474 OpCodes.OpOsDiagnose <$> genFieldsNE <*> genNamesNE
475 "OP_EXT_STORAGE_DIAGNOSE" ->
476 OpCodes.OpOsDiagnose <$> genFieldsNE <*> genNamesNE
477 "OP_BACKUP_PREPARE" ->
478 OpCodes.OpBackupPrepare <$> getInstanceName <*>
479 return Nothing <*> arbitrary
480 "OP_BACKUP_EXPORT" ->
481 OpCodes.OpBackupExport
482 <$> getInstanceName -- instance_name
483 <*> return Nothing -- instance_uuid
484 <*> genPrintableAsciiString -- compress
485 <*> arbitrary -- shutdown_timeout
486 <*> arbitrary -- target_node
487 <*> return Nothing -- target_node_uuid
488 <*> arbitrary -- shutdown
489 <*> arbitrary -- remove_instance
490 <*> arbitrary -- ignore_remove_failures
491 <*> arbitrary -- mode
492 <*> genMaybe (pure []) -- x509_key_name
493 <*> genMaybe genNameNE -- destination_x509_ca
494 <*> arbitrary -- zero_free_space
495 <*> arbitrary -- zeroing_timeout_fixed
496 <*> arbitrary -- zeroing_timeout_per_mib
497 <*> arbitrary -- long_sleep
498 "OP_BACKUP_REMOVE" ->
499 OpCodes.OpBackupRemove <$> getInstanceName <*> return Nothing
500 "OP_TEST_ALLOCATOR" ->
501 OpCodes.OpTestAllocator <$> arbitrary <*> arbitrary <*>
502 genNameNE <*> genMaybe (pure []) <*> genMaybe (pure []) <*>
503 arbitrary <*> genMaybe genNameNE <*>
504 (genTags >>= mapM mkNonEmpty) <*>
505 arbitrary <*> arbitrary <*> genMaybe genNameNE <*>
506 arbitrary <*> genMaybe genNodeNamesNE <*> arbitrary <*>
507 genMaybe genNamesNE <*> arbitrary <*> arbitrary <*>
508 genMaybe getGroupName
509 "OP_TEST_JQUEUE" ->
510 OpCodes.OpTestJqueue <$> arbitrary <*> arbitrary <*>
511 resize 20 (listOf genFQDN) <*> arbitrary
512 "OP_TEST_OS_PARAMS" ->
513 OpCodes.OpTestOsParams <$> genMaybe arbitrarySecretJSObj
514 "OP_TEST_DUMMY" ->
515 OpCodes.OpTestDummy <$> pure J.JSNull <*> pure J.JSNull <*>
516 pure J.JSNull <*> pure J.JSNull
517 "OP_NETWORK_ADD" ->
518 OpCodes.OpNetworkAdd <$> genNameNE <*> genIPv4Network <*>
519 genMaybe genIPv4Address <*> pure Nothing <*> pure Nothing <*>
520 genMaybe genMacPrefix <*> genMaybe (listOf genIPv4Address) <*>
521 arbitrary <*> (genTags >>= mapM mkNonEmpty)
522 "OP_NETWORK_REMOVE" ->
523 OpCodes.OpNetworkRemove <$> genNameNE <*> arbitrary
524 "OP_NETWORK_SET_PARAMS" ->
525 OpCodes.OpNetworkSetParams <$> genNameNE <*>
526 genMaybe genIPv4Address <*> pure Nothing <*> pure Nothing <*>
527 genMaybe genMacPrefix <*> genMaybe (listOf genIPv4Address) <*>
528 genMaybe (listOf genIPv4Address)
529 "OP_NETWORK_CONNECT" ->
530 OpCodes.OpNetworkConnect <$> getGroupName <*>
531 genNameNE <*> arbitrary <*> genNameNE <*> genPrintableAsciiString <*>
532 arbitrary
533 "OP_NETWORK_DISCONNECT" ->
534 OpCodes.OpNetworkDisconnect <$> getGroupName <*>
535 genNameNE
536 "OP_RESTRICTED_COMMAND" ->
537 OpCodes.OpRestrictedCommand <$> arbitrary <*> getNodeNames <*>
538 return Nothing <*> genNameNE
539 "OP_REPAIR_COMMAND" ->
540 OpCodes.OpRepairCommand <$> getNodeName <*> genNameNE <*>
541 genMaybe genPrintableAsciiStringNE
542 _ -> fail $ "Undefined arbitrary for opcode " ++ op_id
543 where getInstanceName =
544 case cfg of
545 Just c -> fmap (fromMaybe "") . genValidInstanceName $ c
546 Nothing -> genFQDN
547 getNodeName = maybe genFQDN genValidNodeName cfg >>= mkNonEmpty
548 getGroupName = maybe genName genValidGroupName cfg >>= mkNonEmpty
549 getInstanceNames = resize maxNodes (listOf getInstanceName) >>=
550 mapM mkNonEmpty
551 getNodeNames = resize maxNodes (listOf getNodeName)
552
553 instance Arbitrary OpCodes.OpCode where
554 arbitrary = do
555 op_id <- elements OpCodes.allOpIDs
556 genOpCodeFromId op_id Nothing
557
558 instance Arbitrary OpCodes.CommonOpParams where
559 arbitrary = OpCodes.CommonOpParams <$> arbitrary <*> arbitrary <*>
560 arbitrary <*> resize 5 arbitrary <*> genMaybe genName <*>
561 genReasonTrail
562
563 -- * Helper functions
564
565 -- | Empty JSObject.
566 emptyJSObject :: J.JSObject J.JSValue
567 emptyJSObject = J.toJSObject []
568
569 -- | Empty maybe unchecked dictionary.
570 emptyMUD :: Gen (Maybe (J.JSObject J.JSValue))
571 emptyMUD = genMaybe $ pure emptyJSObject
572
573 -- | Generates an empty container.
574 genEmptyContainer :: (Ord a) => Gen (GenericContainer a b)
575 genEmptyContainer = pure . GenericContainer $ Map.fromList []
576
577 -- | Generates list of disk indices.
578 genDiskIndices :: Gen [DiskIndex]
579 genDiskIndices = do
580 cnt <- choose (0, C.maxDisks)
581 genUniquesList cnt arbitrary
582
583 -- | Generates a list of node names.
584 genNodeNames :: Gen [String]
585 genNodeNames = resize maxNodes (listOf genFQDN)
586
587 -- | Generates a list of node names in non-empty string type.
588 genNodeNamesNE :: Gen [NonEmptyString]
589 genNodeNamesNE = genNodeNames >>= mapM mkNonEmpty
590
591 -- | Gets a node name in non-empty type.
592 genNodeNameNE :: Gen NonEmptyString
593 genNodeNameNE = genFQDN >>= mkNonEmpty
594
595 -- | Gets a name (non-fqdn) in non-empty type.
596 genNameNE :: Gen NonEmptyString
597 genNameNE = genName >>= mkNonEmpty
598
599 -- | Gets a list of names (non-fqdn) in non-empty type.
600 genNamesNE :: Gen [NonEmptyString]
601 genNamesNE = resize maxNodes (listOf genNameNE)
602
603 -- | Returns a list of non-empty fields.
604 genFieldsNE :: Gen [NonEmptyString]
605 genFieldsNE = genFields >>= mapM mkNonEmpty
606
607 -- | Generate a 3-byte MAC prefix.
608 genMacPrefix :: Gen NonEmptyString
609 genMacPrefix = do
610 octets <- vectorOf 3 $ choose (0::Int, 255)
611 mkNonEmpty . intercalate ":" $ map (printf "%02x") octets
612
613 -- | JSObject of arbitrary data.
614 --
615 -- Since JSValue does not implement Arbitrary, I'll simply generate
616 -- (String, String) objects.
617 arbitraryPrivateJSObj :: Gen (J.JSObject (Private J.JSValue))
618 arbitraryPrivateJSObj =
619 constructor <$> (fromNonEmpty <$> genNameNE)
620 <*> (fromNonEmpty <$> genNameNE)
621 where constructor k v = showPrivateJSObject [(k, v)]
622
623 -- | JSObject of arbitrary secret data.
624 arbitrarySecretJSObj :: Gen (J.JSObject (Secret J.JSValue))
625 arbitrarySecretJSObj =
626 constructor <$> (fromNonEmpty <$> genNameNE)
627 <*> (fromNonEmpty <$> genNameNE)
628 where constructor k v = showSecretJSObject [(k, v)]
629
630 -- | Arbitrary instance for MetaOpCode, defined here due to TH ordering.
631 $(genArbitrary ''OpCodes.MetaOpCode)
632
633 -- | Small helper to check for a failed JSON deserialisation
634 isJsonError :: J.Result a -> Bool
635 isJsonError (J.Error _) = True
636 isJsonError _ = False
637
638 -- * Test cases
639
640 -- | Check that opcode serialization is idempotent.
641 prop_serialization :: OpCodes.OpCode -> Property
642 prop_serialization = testSerialisation
643
644 -- | Check that Python and Haskell defined the same opcode list.
645 case_AllDefined :: HUnit.Assertion
646 case_AllDefined = do
647 py_stdout <-
648 runPython "from ganeti import opcodes\n\
649 \from ganeti import serializer\n\
650 \import sys\n\
651 \print serializer.Dump([opid for opid in opcodes.OP_MAPPING])\n"
652 ""
653 >>= checkPythonResult
654 py_ops <- case J.decode py_stdout::J.Result [String] of
655 J.Ok ops -> return ops
656 J.Error msg ->
657 HUnit.assertFailure ("Unable to decode opcode names: " ++ msg)
658 -- this already raised an expection, but we need it
659 -- for proper types
660 >> fail "Unable to decode opcode names"
661 let hs_ops = sort OpCodes.allOpIDs
662 extra_py = py_ops \\ hs_ops
663 extra_hs = hs_ops \\ py_ops
664 HUnit.assertBool ("Missing OpCodes from the Haskell code:\n" ++
665 unlines extra_py) (null extra_py)
666 HUnit.assertBool ("Extra OpCodes in the Haskell code:\n" ++
667 unlines extra_hs) (null extra_hs)
668
669 -- | Custom HUnit test case that forks a Python process and checks
670 -- correspondence between Haskell-generated OpCodes and their Python
671 -- decoded, validated and re-encoded version.
672 --
673 -- Note that we have a strange beast here: since launching Python is
674 -- expensive, we don't do this via a usual QuickProperty, since that's
675 -- slow (I've tested it, and it's indeed quite slow). Rather, we use a
676 -- single HUnit assertion, and in it we manually use QuickCheck to
677 -- generate 500 opcodes times the number of defined opcodes, which
678 -- then we pass in bulk to Python. The drawbacks to this method are
679 -- two fold: we cannot control the number of generated opcodes, since
680 -- HUnit assertions don't get access to the test options, and for the
681 -- same reason we can't run a repeatable seed. We should probably find
682 -- a better way to do this, for example by having a
683 -- separately-launched Python process (if not running the tests would
684 -- be skipped).
685 case_py_compat_types :: HUnit.Assertion
686 case_py_compat_types = do
687 let num_opcodes = length OpCodes.allOpIDs * 100
688 opcodes <- genSample (vectorOf num_opcodes
689 (arbitrary::Gen OpCodes.MetaOpCode))
690 let with_sum = map (\o -> (OpCodes.opSummary $
691 OpCodes.metaOpCode o, o)) opcodes
692 serialized = J.encode opcodes
693 -- check for non-ASCII fields, usually due to 'arbitrary :: String'
694 mapM_ (\op -> when (any (not . isAscii) (J.encode op)) .
695 HUnit.assertFailure $
696 "OpCode has non-ASCII fields: " ++ show op
697 ) opcodes
698 py_stdout <-
699 runPython "from ganeti import opcodes\n\
700 \from ganeti import serializer\n\
701 \import sys\n\
702 \op_data = serializer.Load(sys.stdin.read())\n\
703 \decoded = [opcodes.OpCode.LoadOpCode(o) for o in op_data]\n\
704 \for op in decoded:\n\
705 \ op.Validate(True)\n\
706 \encoded = [(op.Summary(), op.__getstate__())\n\
707 \ for op in decoded]\n\
708 \print serializer.Dump(\
709 \ encoded,\
710 \ private_encoder=serializer.EncodeWithPrivateFields)"
711 serialized
712 >>= checkPythonResult
713 let deserialised =
714 J.decode py_stdout::J.Result [(String, OpCodes.MetaOpCode)]
715 decoded <- case deserialised of
716 J.Ok ops -> return ops
717 J.Error msg ->
718 HUnit.assertFailure ("Unable to decode opcodes: " ++ msg)
719 -- this already raised an expection, but we need it
720 -- for proper types
721 >> fail "Unable to decode opcodes"
722 HUnit.assertEqual "Mismatch in number of returned opcodes"
723 (length decoded) (length with_sum)
724 mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
725 ) $ zip with_sum decoded
726
727 -- | Custom HUnit test case that forks a Python process and checks
728 -- correspondence between Haskell OpCodes fields and their Python
729 -- equivalent.
730 case_py_compat_fields :: HUnit.Assertion
731 case_py_compat_fields = do
732 let hs_fields = sort $ map (\op_id -> (op_id, OpCodes.allOpFields op_id))
733 OpCodes.allOpIDs
734 py_stdout <-
735 runPython "from ganeti import opcodes\n\
736 \import sys\n\
737 \from ganeti import serializer\n\
738 \fields = [(k, sorted([p[0] for p in v.OP_PARAMS]))\n\
739 \ for k, v in opcodes.OP_MAPPING.items()]\n\
740 \print serializer.Dump(fields)" ""
741 >>= checkPythonResult
742 let deserialised = J.decode py_stdout::J.Result [(String, [String])]
743 py_fields <- case deserialised of
744 J.Ok v -> return $ sort v
745 J.Error msg ->
746 HUnit.assertFailure ("Unable to decode op fields: " ++ msg)
747 -- this already raised an expection, but we need it
748 -- for proper types
749 >> fail "Unable to decode op fields"
750 HUnit.assertEqual "Mismatch in number of returned opcodes"
751 (length hs_fields) (length py_fields)
752 HUnit.assertEqual "Mismatch in defined OP_IDs"
753 (map fst hs_fields) (map fst py_fields)
754 mapM_ (\((py_id, py_flds), (hs_id, hs_flds)) -> do
755 HUnit.assertEqual "Mismatch in OP_ID" py_id hs_id
756 HUnit.assertEqual ("Mismatch in fields for " ++ hs_id)
757 py_flds hs_flds
758 ) $ zip hs_fields py_fields
759
760 -- | Checks that setOpComment works correctly.
761 prop_setOpComment :: OpCodes.MetaOpCode -> String -> Property
762 prop_setOpComment op comment =
763 let (OpCodes.MetaOpCode common _) = OpCodes.setOpComment comment op
764 in OpCodes.opComment common ==? Just comment
765
766 -- | Tests wrong (negative) disk index.
767 prop_mkDiskIndex_fail :: QuickCheck.Positive Int -> Property
768 prop_mkDiskIndex_fail (Positive i) =
769 case mkDiskIndex (negate i) of
770 Bad msg -> counterexample "error message " $
771 "Invalid value" `isPrefixOf` msg
772 Ok v -> failTest $ "Succeeded to build disk index '" ++ show v ++
773 "' from negative value " ++ show (negate i)
774
775 -- | Tests a few invalid 'readRecreateDisks' cases.
776 case_readRecreateDisks_fail :: Assertion
777 case_readRecreateDisks_fail = do
778 assertBool "null" $
779 isJsonError (J.readJSON J.JSNull::J.Result RecreateDisksInfo)
780 assertBool "string" $
781 isJsonError (J.readJSON (J.showJSON "abc")::J.Result RecreateDisksInfo)
782
783 -- | Tests a few invalid 'readDdmOldChanges' cases.
784 case_readDdmOldChanges_fail :: Assertion
785 case_readDdmOldChanges_fail = do
786 assertBool "null" $
787 isJsonError (J.readJSON J.JSNull::J.Result DdmOldChanges)
788 assertBool "string" $
789 isJsonError (J.readJSON (J.showJSON "abc")::J.Result DdmOldChanges)
790
791 -- | Tests a few invalid 'readExportTarget' cases.
792 case_readExportTarget_fail :: Assertion
793 case_readExportTarget_fail = do
794 assertBool "null" $
795 isJsonError (J.readJSON J.JSNull::J.Result ExportTarget)
796 assertBool "int" $
797 isJsonError (J.readJSON (J.showJSON (5::Int))::J.Result ExportTarget)
798
799 testSuite "OpCodes"
800 [ 'prop_serialization
801 , 'case_AllDefined
802 , 'case_py_compat_types
803 , 'case_py_compat_fields
804 , 'prop_setOpComment
805 , 'prop_mkDiskIndex_fail
806 , 'case_readRecreateDisks_fail
807 , 'case_readDdmOldChanges_fail
808 , 'case_readExportTarget_fail
809 ]