Implement predictive queue cluster parameter
[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 <*> arbitrary -- enabled_predictive_queue
269 "OP_CLUSTER_REDIST_CONF" -> pure OpCodes.OpClusterRedistConf
270 "OP_CLUSTER_ACTIVATE_MASTER_IP" ->
271 pure OpCodes.OpClusterActivateMasterIp
272 "OP_CLUSTER_DEACTIVATE_MASTER_IP" ->
273 pure OpCodes.OpClusterDeactivateMasterIp
274 "OP_QUERY" ->
275 OpCodes.OpQuery <$> arbitrary <*> arbitrary <*> genNamesNE <*>
276 pure Nothing
277 "OP_QUERY_FIELDS" ->
278 OpCodes.OpQueryFields <$> arbitrary <*> genMaybe genNamesNE
279 "OP_OOB_COMMAND" ->
280 OpCodes.OpOobCommand <$> getNodeNames <*> return Nothing <*>
281 arbitrary <*> arbitrary <*> arbitrary <*> (arbitrary `suchThat` (>0))
282 "OP_NODE_REMOVE" ->
283 OpCodes.OpNodeRemove <$> getNodeName <*> return Nothing <*>
284 arbitrary <*> arbitrary
285 "OP_NODE_ADD" ->
286 OpCodes.OpNodeAdd <$> getNodeName <*> emptyMUD <*> emptyMUD <*>
287 genMaybe genNameNE <*> genMaybe genNameNE <*> arbitrary <*>
288 genMaybe genNameNE <*> arbitrary <*> arbitrary <*> emptyMUD <*>
289 arbitrary <*> arbitrary <*> arbitrary
290 "OP_NODE_QUERYVOLS" ->
291 OpCodes.OpNodeQueryvols <$> genNamesNE <*> genNodeNamesNE
292 "OP_NODE_QUERY_STORAGE" ->
293 OpCodes.OpNodeQueryStorage <$> genNamesNE <*> arbitrary <*>
294 getNodeNames <*> genMaybe genNameNE
295 "OP_NODE_MODIFY_STORAGE" ->
296 OpCodes.OpNodeModifyStorage <$> getNodeName <*> return Nothing <*>
297 arbitrary <*> genMaybe genNameNE <*> pure emptyJSObject
298 "OP_REPAIR_NODE_STORAGE" ->
299 OpCodes.OpRepairNodeStorage <$> getNodeName <*> return Nothing <*>
300 arbitrary <*> genMaybe genNameNE <*> arbitrary
301 "OP_NODE_SET_PARAMS" ->
302 OpCodes.OpNodeSetParams <$> getNodeName <*> return Nothing <*>
303 arbitrary <*> emptyMUD <*> emptyMUD <*> arbitrary <*> arbitrary <*>
304 arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>
305 genMaybe genNameNE <*> emptyMUD <*> arbitrary <*> arbitrary <*>
306 arbitrary
307 "OP_NODE_POWERCYCLE" ->
308 OpCodes.OpNodePowercycle <$> getNodeName <*> return Nothing <*> arbitrary
309 "OP_NODE_MIGRATE" ->
310 OpCodes.OpNodeMigrate <$> getNodeName <*> return Nothing <*>
311 arbitrary <*> arbitrary <*> genMaybe getNodeName <*> return Nothing <*>
312 arbitrary <*> arbitrary <*> genMaybe genNameNE
313 "OP_NODE_EVACUATE" ->
314 OpCodes.OpNodeEvacuate <$> arbitrary <*> getNodeName <*>
315 return Nothing <*> genMaybe getNodeName <*> return Nothing <*>
316 genMaybe genNameNE <*> arbitrary <*> arbitrary
317 "OP_INSTANCE_CREATE" ->
318 OpCodes.OpInstanceCreate
319 <$> genFQDN -- instance_name
320 <*> arbitrary -- force_variant
321 <*> arbitrary -- wait_for_sync
322 <*> arbitrary -- name_check
323 <*> arbitrary -- ignore_ipolicy
324 <*> arbitrary -- opportunistic_locking
325 <*> pure emptyJSObject -- beparams
326 <*> arbitrary -- disks
327 <*> arbitrary -- disk_template
328 <*> genMaybe getGroupName -- group_name
329 <*> arbitrary -- file_driver
330 <*> genMaybe genNameNE -- file_storage_dir
331 <*> pure emptyJSObject -- hvparams
332 <*> arbitrary -- hypervisor
333 <*> genMaybe genNameNE -- iallocator
334 <*> arbitrary -- identify_defaults
335 <*> arbitrary -- ip_check
336 <*> arbitrary -- conflicts_check
337 <*> arbitrary -- mode
338 <*> arbitrary -- nics
339 <*> arbitrary -- no_install
340 <*> pure emptyJSObject -- osparams
341 <*> genMaybe arbitraryPrivateJSObj -- osparams_private
342 <*> genMaybe arbitrarySecretJSObj -- osparams_secret
343 <*> genMaybe genNameNE -- os_type
344 <*> genMaybe getNodeName -- pnode
345 <*> return Nothing -- pnode_uuid
346 <*> genMaybe getNodeName -- snode
347 <*> return Nothing -- snode_uuid
348 <*> genMaybe (pure []) -- source_handshake
349 <*> genMaybe genNodeNameNE -- source_instance_name
350 <*> arbitrary -- source_shutdown_timeout
351 <*> genMaybe genNodeNameNE -- source_x509_ca
352 <*> return Nothing -- src_node
353 <*> genMaybe genNodeNameNE -- src_node_uuid
354 <*> genMaybe genNameNE -- src_path
355 <*> genPrintableAsciiString -- compress
356 <*> arbitrary -- start
357 <*> arbitrary -- forthcoming
358 <*> arbitrary -- commit
359 <*> (genTags >>= mapM mkNonEmpty) -- tags
360 <*> arbitrary -- instance_communication
361 <*> arbitrary -- helper_startup_timeout
362 <*> arbitrary -- helper_shutdown_timeout
363 "OP_INSTANCE_MULTI_ALLOC" ->
364 OpCodes.OpInstanceMultiAlloc <$> arbitrary <*> genMaybe genNameNE <*>
365 pure []
366 "OP_INSTANCE_REINSTALL" ->
367 OpCodes.OpInstanceReinstall <$> getInstanceName <*> return Nothing <*>
368 arbitrary <*> genMaybe genNameNE <*> genMaybe (pure emptyJSObject)
369 <*> genMaybe arbitraryPrivateJSObj <*> genMaybe arbitrarySecretJSObj
370 <*> arbitrary <*> arbitrary
371 <*> genMaybe (listOf genPrintableAsciiString)
372 <*> genMaybe (listOf genPrintableAsciiString)
373 "OP_INSTANCE_REMOVE" ->
374 OpCodes.OpInstanceRemove <$> getInstanceName <*> return Nothing <*>
375 arbitrary <*> arbitrary
376 "OP_INSTANCE_RENAME" ->
377 OpCodes.OpInstanceRename <$> getInstanceName <*> return Nothing <*>
378 (genFQDN >>= mkNonEmpty) <*> arbitrary <*> arbitrary
379 "OP_INSTANCE_STARTUP" ->
380 OpCodes.OpInstanceStartup <$>
381 getInstanceName <*> -- instance_name
382 return Nothing <*> -- instance_uuid
383 arbitrary <*> -- force
384 arbitrary <*> -- ignore_offline_nodes
385 pure emptyJSObject <*> -- hvparams
386 pure emptyJSObject <*> -- beparams
387 arbitrary <*> -- no_remember
388 arbitrary <*> -- startup_paused
389 arbitrary -- shutdown_timeout
390 "OP_INSTANCE_SHUTDOWN" ->
391 OpCodes.OpInstanceShutdown <$> getInstanceName <*> return Nothing <*>
392 arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
393 "OP_INSTANCE_REBOOT" ->
394 OpCodes.OpInstanceReboot <$> getInstanceName <*> return Nothing <*>
395 arbitrary <*> arbitrary <*> arbitrary
396 "OP_INSTANCE_MOVE" ->
397 OpCodes.OpInstanceMove <$> getInstanceName <*> return Nothing <*>
398 arbitrary <*> arbitrary <*> getNodeName <*>
399 return Nothing <*> genPrintableAsciiString <*> arbitrary
400 "OP_INSTANCE_CONSOLE" -> OpCodes.OpInstanceConsole <$> getInstanceName <*>
401 return Nothing
402 "OP_INSTANCE_ACTIVATE_DISKS" ->
403 OpCodes.OpInstanceActivateDisks <$> getInstanceName <*> return Nothing <*>
404 arbitrary <*> arbitrary
405 "OP_INSTANCE_DEACTIVATE_DISKS" ->
406 OpCodes.OpInstanceDeactivateDisks <$> genFQDN <*> return Nothing <*>
407 arbitrary
408 "OP_INSTANCE_RECREATE_DISKS" ->
409 OpCodes.OpInstanceRecreateDisks <$> getInstanceName <*> return Nothing <*>
410 arbitrary <*> genNodeNamesNE <*> return Nothing <*> genMaybe getNodeName
411 "OP_INSTANCE_QUERY_DATA" ->
412 OpCodes.OpInstanceQueryData <$> arbitrary <*>
413 getInstanceNames <*> arbitrary
414 "OP_INSTANCE_SET_PARAMS" ->
415 OpCodes.OpInstanceSetParams
416 <$> getInstanceName -- instance_name
417 <*> return Nothing -- instance_uuid
418 <*> arbitrary -- force
419 <*> arbitrary -- force_variant
420 <*> arbitrary -- ignore_ipolicy
421 <*> arbitrary -- nics
422 <*> arbitrary -- disks
423 <*> pure emptyJSObject -- beparams
424 <*> arbitrary -- runtime_mem
425 <*> pure emptyJSObject -- hvparams
426 <*> arbitrary -- disk_template
427 <*> pure emptyJSObject -- ext_params
428 <*> arbitrary -- file_driver
429 <*> genMaybe genNameNE -- file_storage_dir
430 <*> genMaybe getNodeName -- pnode
431 <*> return Nothing -- pnode_uuid
432 <*> genMaybe getNodeName -- remote_node
433 <*> return Nothing -- remote_node_uuid
434 <*> genMaybe genNameNE -- iallocator
435 <*> genMaybe genNameNE -- os_name
436 <*> pure emptyJSObject -- osparams
437 <*> genMaybe arbitraryPrivateJSObj -- osparams_private
438 <*> arbitrary -- clear_osparams
439 <*> arbitrary -- clear_osparams_private
440 <*> genMaybe (listOf genPrintableAsciiString) -- remove_osparams
441 <*> genMaybe (listOf genPrintableAsciiString) -- remove_osparams_private
442 <*> arbitrary -- wait_for_sync
443 <*> arbitrary -- offline
444 <*> arbitrary -- conflicts_check
445 <*> arbitrary -- hotplug
446 <*> arbitrary -- hotplug_if_possible
447 <*> arbitrary -- instance_communication
448 "OP_INSTANCE_GROW_DISK" ->
449 OpCodes.OpInstanceGrowDisk <$> getInstanceName <*> return Nothing <*>
450 arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
451 "OP_INSTANCE_CHANGE_GROUP" ->
452 OpCodes.OpInstanceChangeGroup <$> getInstanceName <*> return Nothing <*>
453 arbitrary <*> genMaybe genNameNE <*>
454 genMaybe (resize maxNodes (listOf genNameNE))
455 "OP_GROUP_ADD" ->
456 OpCodes.OpGroupAdd <$> genNameNE <*> arbitrary <*>
457 emptyMUD <*> genMaybe genEmptyContainer <*>
458 emptyMUD <*> emptyMUD <*> emptyMUD
459 "OP_GROUP_ASSIGN_NODES" ->
460 OpCodes.OpGroupAssignNodes <$> getGroupName <*>
461 arbitrary <*> getNodeNames <*> return Nothing
462 "OP_GROUP_SET_PARAMS" ->
463 OpCodes.OpGroupSetParams <$> getGroupName <*>
464 arbitrary <*> emptyMUD <*> genMaybe genEmptyContainer <*>
465 emptyMUD <*> emptyMUD <*> emptyMUD
466 "OP_GROUP_REMOVE" ->
467 OpCodes.OpGroupRemove <$> getGroupName
468 "OP_GROUP_RENAME" ->
469 OpCodes.OpGroupRename <$> getGroupName <*> genNameNE
470 "OP_GROUP_EVACUATE" ->
471 OpCodes.OpGroupEvacuate <$> getGroupName <*>
472 arbitrary <*> genMaybe genNameNE <*> genMaybe genNamesNE <*>
473 arbitrary <*> arbitrary
474 "OP_OS_DIAGNOSE" ->
475 OpCodes.OpOsDiagnose <$> genFieldsNE <*> genNamesNE
476 "OP_EXT_STORAGE_DIAGNOSE" ->
477 OpCodes.OpOsDiagnose <$> genFieldsNE <*> genNamesNE
478 "OP_BACKUP_PREPARE" ->
479 OpCodes.OpBackupPrepare <$> getInstanceName <*>
480 return Nothing <*> arbitrary
481 "OP_BACKUP_EXPORT" ->
482 OpCodes.OpBackupExport
483 <$> getInstanceName -- instance_name
484 <*> return Nothing -- instance_uuid
485 <*> genPrintableAsciiString -- compress
486 <*> arbitrary -- shutdown_timeout
487 <*> arbitrary -- target_node
488 <*> return Nothing -- target_node_uuid
489 <*> arbitrary -- shutdown
490 <*> arbitrary -- remove_instance
491 <*> arbitrary -- ignore_remove_failures
492 <*> arbitrary -- mode
493 <*> genMaybe (pure []) -- x509_key_name
494 <*> genMaybe genNameNE -- destination_x509_ca
495 <*> arbitrary -- zero_free_space
496 <*> arbitrary -- zeroing_timeout_fixed
497 <*> arbitrary -- zeroing_timeout_per_mib
498 <*> arbitrary -- long_sleep
499 "OP_BACKUP_REMOVE" ->
500 OpCodes.OpBackupRemove <$> getInstanceName <*> return Nothing
501 "OP_TEST_ALLOCATOR" ->
502 OpCodes.OpTestAllocator <$> arbitrary <*> arbitrary <*>
503 genNameNE <*> genMaybe (pure []) <*> genMaybe (pure []) <*>
504 arbitrary <*> genMaybe genNameNE <*>
505 (genTags >>= mapM mkNonEmpty) <*>
506 arbitrary <*> arbitrary <*> genMaybe genNameNE <*>
507 arbitrary <*> genMaybe genNodeNamesNE <*> arbitrary <*>
508 genMaybe genNamesNE <*> arbitrary <*> arbitrary <*>
509 genMaybe getGroupName
510 "OP_TEST_JQUEUE" ->
511 OpCodes.OpTestJqueue <$> arbitrary <*> arbitrary <*>
512 resize 20 (listOf genFQDN) <*> arbitrary
513 "OP_TEST_OS_PARAMS" ->
514 OpCodes.OpTestOsParams <$> genMaybe arbitrarySecretJSObj
515 "OP_TEST_DUMMY" ->
516 OpCodes.OpTestDummy <$> pure J.JSNull <*> pure J.JSNull <*>
517 pure J.JSNull <*> pure J.JSNull
518 "OP_NETWORK_ADD" ->
519 OpCodes.OpNetworkAdd <$> genNameNE <*> genIPv4Network <*>
520 genMaybe genIPv4Address <*> pure Nothing <*> pure Nothing <*>
521 genMaybe genMacPrefix <*> genMaybe (listOf genIPv4Address) <*>
522 arbitrary <*> (genTags >>= mapM mkNonEmpty)
523 "OP_NETWORK_REMOVE" ->
524 OpCodes.OpNetworkRemove <$> genNameNE <*> arbitrary
525 "OP_NETWORK_SET_PARAMS" ->
526 OpCodes.OpNetworkSetParams <$> genNameNE <*>
527 genMaybe genIPv4Address <*> pure Nothing <*> pure Nothing <*>
528 genMaybe genMacPrefix <*> genMaybe (listOf genIPv4Address) <*>
529 genMaybe (listOf genIPv4Address)
530 "OP_NETWORK_CONNECT" ->
531 OpCodes.OpNetworkConnect <$> getGroupName <*>
532 genNameNE <*> arbitrary <*> genNameNE <*> genPrintableAsciiString <*>
533 arbitrary
534 "OP_NETWORK_DISCONNECT" ->
535 OpCodes.OpNetworkDisconnect <$> getGroupName <*>
536 genNameNE
537 "OP_RESTRICTED_COMMAND" ->
538 OpCodes.OpRestrictedCommand <$> arbitrary <*> getNodeNames <*>
539 return Nothing <*> genNameNE
540 "OP_REPAIR_COMMAND" ->
541 OpCodes.OpRepairCommand <$> getNodeName <*> genNameNE <*>
542 genMaybe genPrintableAsciiStringNE
543 _ -> fail $ "Undefined arbitrary for opcode " ++ op_id
544 where getInstanceName =
545 case cfg of
546 Just c -> fmap (fromMaybe "") . genValidInstanceName $ c
547 Nothing -> genFQDN
548 getNodeName = maybe genFQDN genValidNodeName cfg >>= mkNonEmpty
549 getGroupName = maybe genName genValidGroupName cfg >>= mkNonEmpty
550 getInstanceNames = resize maxNodes (listOf getInstanceName) >>=
551 mapM mkNonEmpty
552 getNodeNames = resize maxNodes (listOf getNodeName)
553
554 instance Arbitrary OpCodes.OpCode where
555 arbitrary = do
556 op_id <- elements OpCodes.allOpIDs
557 genOpCodeFromId op_id Nothing
558
559 instance Arbitrary OpCodes.CommonOpParams where
560 arbitrary = OpCodes.CommonOpParams <$> arbitrary <*> arbitrary <*>
561 arbitrary <*> resize 5 arbitrary <*> genMaybe genName <*>
562 genReasonTrail
563
564 -- * Helper functions
565
566 -- | Empty JSObject.
567 emptyJSObject :: J.JSObject J.JSValue
568 emptyJSObject = J.toJSObject []
569
570 -- | Empty maybe unchecked dictionary.
571 emptyMUD :: Gen (Maybe (J.JSObject J.JSValue))
572 emptyMUD = genMaybe $ pure emptyJSObject
573
574 -- | Generates an empty container.
575 genEmptyContainer :: (Ord a) => Gen (GenericContainer a b)
576 genEmptyContainer = pure . GenericContainer $ Map.fromList []
577
578 -- | Generates list of disk indices.
579 genDiskIndices :: Gen [DiskIndex]
580 genDiskIndices = do
581 cnt <- choose (0, C.maxDisks)
582 genUniquesList cnt arbitrary
583
584 -- | Generates a list of node names.
585 genNodeNames :: Gen [String]
586 genNodeNames = resize maxNodes (listOf genFQDN)
587
588 -- | Generates a list of node names in non-empty string type.
589 genNodeNamesNE :: Gen [NonEmptyString]
590 genNodeNamesNE = genNodeNames >>= mapM mkNonEmpty
591
592 -- | Gets a node name in non-empty type.
593 genNodeNameNE :: Gen NonEmptyString
594 genNodeNameNE = genFQDN >>= mkNonEmpty
595
596 -- | Gets a name (non-fqdn) in non-empty type.
597 genNameNE :: Gen NonEmptyString
598 genNameNE = genName >>= mkNonEmpty
599
600 -- | Gets a list of names (non-fqdn) in non-empty type.
601 genNamesNE :: Gen [NonEmptyString]
602 genNamesNE = resize maxNodes (listOf genNameNE)
603
604 -- | Returns a list of non-empty fields.
605 genFieldsNE :: Gen [NonEmptyString]
606 genFieldsNE = genFields >>= mapM mkNonEmpty
607
608 -- | Generate a 3-byte MAC prefix.
609 genMacPrefix :: Gen NonEmptyString
610 genMacPrefix = do
611 octets <- vectorOf 3 $ choose (0::Int, 255)
612 mkNonEmpty . intercalate ":" $ map (printf "%02x") octets
613
614 -- | JSObject of arbitrary data.
615 --
616 -- Since JSValue does not implement Arbitrary, I'll simply generate
617 -- (String, String) objects.
618 arbitraryPrivateJSObj :: Gen (J.JSObject (Private J.JSValue))
619 arbitraryPrivateJSObj =
620 constructor <$> (fromNonEmpty <$> genNameNE)
621 <*> (fromNonEmpty <$> genNameNE)
622 where constructor k v = showPrivateJSObject [(k, v)]
623
624 -- | JSObject of arbitrary secret data.
625 arbitrarySecretJSObj :: Gen (J.JSObject (Secret J.JSValue))
626 arbitrarySecretJSObj =
627 constructor <$> (fromNonEmpty <$> genNameNE)
628 <*> (fromNonEmpty <$> genNameNE)
629 where constructor k v = showSecretJSObject [(k, v)]
630
631 -- | Arbitrary instance for MetaOpCode, defined here due to TH ordering.
632 $(genArbitrary ''OpCodes.MetaOpCode)
633
634 -- | Small helper to check for a failed JSON deserialisation
635 isJsonError :: J.Result a -> Bool
636 isJsonError (J.Error _) = True
637 isJsonError _ = False
638
639 -- * Test cases
640
641 -- | Check that opcode serialization is idempotent.
642 prop_serialization :: OpCodes.OpCode -> Property
643 prop_serialization = testSerialisation
644
645 -- | Check that Python and Haskell defined the same opcode list.
646 case_AllDefined :: HUnit.Assertion
647 case_AllDefined = do
648 py_stdout <-
649 runPython "from ganeti import opcodes\n\
650 \from ganeti import serializer\n\
651 \import sys\n\
652 \print serializer.Dump([opid for opid in opcodes.OP_MAPPING])\n"
653 ""
654 >>= checkPythonResult
655 py_ops <- case J.decode py_stdout::J.Result [String] of
656 J.Ok ops -> return ops
657 J.Error msg ->
658 HUnit.assertFailure ("Unable to decode opcode names: " ++ msg)
659 -- this already raised an expection, but we need it
660 -- for proper types
661 >> fail "Unable to decode opcode names"
662 let hs_ops = sort OpCodes.allOpIDs
663 extra_py = py_ops \\ hs_ops
664 extra_hs = hs_ops \\ py_ops
665 HUnit.assertBool ("Missing OpCodes from the Haskell code:\n" ++
666 unlines extra_py) (null extra_py)
667 HUnit.assertBool ("Extra OpCodes in the Haskell code:\n" ++
668 unlines extra_hs) (null extra_hs)
669
670 -- | Custom HUnit test case that forks a Python process and checks
671 -- correspondence between Haskell-generated OpCodes and their Python
672 -- decoded, validated and re-encoded version.
673 --
674 -- Note that we have a strange beast here: since launching Python is
675 -- expensive, we don't do this via a usual QuickProperty, since that's
676 -- slow (I've tested it, and it's indeed quite slow). Rather, we use a
677 -- single HUnit assertion, and in it we manually use QuickCheck to
678 -- generate 500 opcodes times the number of defined opcodes, which
679 -- then we pass in bulk to Python. The drawbacks to this method are
680 -- two fold: we cannot control the number of generated opcodes, since
681 -- HUnit assertions don't get access to the test options, and for the
682 -- same reason we can't run a repeatable seed. We should probably find
683 -- a better way to do this, for example by having a
684 -- separately-launched Python process (if not running the tests would
685 -- be skipped).
686 case_py_compat_types :: HUnit.Assertion
687 case_py_compat_types = do
688 let num_opcodes = length OpCodes.allOpIDs * 100
689 opcodes <- genSample (vectorOf num_opcodes
690 (arbitrary::Gen OpCodes.MetaOpCode))
691 let with_sum = map (\o -> (OpCodes.opSummary $
692 OpCodes.metaOpCode o, o)) opcodes
693 serialized = J.encode opcodes
694 -- check for non-ASCII fields, usually due to 'arbitrary :: String'
695 mapM_ (\op -> when (any (not . isAscii) (J.encode op)) .
696 HUnit.assertFailure $
697 "OpCode has non-ASCII fields: " ++ show op
698 ) opcodes
699 py_stdout <-
700 runPython "from ganeti import opcodes\n\
701 \from ganeti import serializer\n\
702 \import sys\n\
703 \op_data = serializer.Load(sys.stdin.read())\n\
704 \decoded = [opcodes.OpCode.LoadOpCode(o) for o in op_data]\n\
705 \for op in decoded:\n\
706 \ op.Validate(True)\n\
707 \encoded = [(op.Summary(), op.__getstate__())\n\
708 \ for op in decoded]\n\
709 \print serializer.Dump(\
710 \ encoded,\
711 \ private_encoder=serializer.EncodeWithPrivateFields)"
712 serialized
713 >>= checkPythonResult
714 let deserialised =
715 J.decode py_stdout::J.Result [(String, OpCodes.MetaOpCode)]
716 decoded <- case deserialised of
717 J.Ok ops -> return ops
718 J.Error msg ->
719 HUnit.assertFailure ("Unable to decode opcodes: " ++ msg)
720 -- this already raised an expection, but we need it
721 -- for proper types
722 >> fail "Unable to decode opcodes"
723 HUnit.assertEqual "Mismatch in number of returned opcodes"
724 (length decoded) (length with_sum)
725 mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
726 ) $ zip with_sum decoded
727
728 -- | Custom HUnit test case that forks a Python process and checks
729 -- correspondence between Haskell OpCodes fields and their Python
730 -- equivalent.
731 case_py_compat_fields :: HUnit.Assertion
732 case_py_compat_fields = do
733 let hs_fields = sort $ map (\op_id -> (op_id, OpCodes.allOpFields op_id))
734 OpCodes.allOpIDs
735 py_stdout <-
736 runPython "from ganeti import opcodes\n\
737 \import sys\n\
738 \from ganeti import serializer\n\
739 \fields = [(k, sorted([p[0] for p in v.OP_PARAMS]))\n\
740 \ for k, v in opcodes.OP_MAPPING.items()]\n\
741 \print serializer.Dump(fields)" ""
742 >>= checkPythonResult
743 let deserialised = J.decode py_stdout::J.Result [(String, [String])]
744 py_fields <- case deserialised of
745 J.Ok v -> return $ sort v
746 J.Error msg ->
747 HUnit.assertFailure ("Unable to decode op fields: " ++ msg)
748 -- this already raised an expection, but we need it
749 -- for proper types
750 >> fail "Unable to decode op fields"
751 HUnit.assertEqual "Mismatch in number of returned opcodes"
752 (length hs_fields) (length py_fields)
753 HUnit.assertEqual "Mismatch in defined OP_IDs"
754 (map fst hs_fields) (map fst py_fields)
755 mapM_ (\((py_id, py_flds), (hs_id, hs_flds)) -> do
756 HUnit.assertEqual "Mismatch in OP_ID" py_id hs_id
757 HUnit.assertEqual ("Mismatch in fields for " ++ hs_id)
758 py_flds hs_flds
759 ) $ zip hs_fields py_fields
760
761 -- | Checks that setOpComment works correctly.
762 prop_setOpComment :: OpCodes.MetaOpCode -> String -> Property
763 prop_setOpComment op comment =
764 let (OpCodes.MetaOpCode common _) = OpCodes.setOpComment comment op
765 in OpCodes.opComment common ==? Just comment
766
767 -- | Tests wrong (negative) disk index.
768 prop_mkDiskIndex_fail :: QuickCheck.Positive Int -> Property
769 prop_mkDiskIndex_fail (Positive i) =
770 case mkDiskIndex (negate i) of
771 Bad msg -> counterexample "error message " $
772 "Invalid value" `isPrefixOf` msg
773 Ok v -> failTest $ "Succeeded to build disk index '" ++ show v ++
774 "' from negative value " ++ show (negate i)
775
776 -- | Tests a few invalid 'readRecreateDisks' cases.
777 case_readRecreateDisks_fail :: Assertion
778 case_readRecreateDisks_fail = do
779 assertBool "null" $
780 isJsonError (J.readJSON J.JSNull::J.Result RecreateDisksInfo)
781 assertBool "string" $
782 isJsonError (J.readJSON (J.showJSON "abc")::J.Result RecreateDisksInfo)
783
784 -- | Tests a few invalid 'readDdmOldChanges' cases.
785 case_readDdmOldChanges_fail :: Assertion
786 case_readDdmOldChanges_fail = do
787 assertBool "null" $
788 isJsonError (J.readJSON J.JSNull::J.Result DdmOldChanges)
789 assertBool "string" $
790 isJsonError (J.readJSON (J.showJSON "abc")::J.Result DdmOldChanges)
791
792 -- | Tests a few invalid 'readExportTarget' cases.
793 case_readExportTarget_fail :: Assertion
794 case_readExportTarget_fail = do
795 assertBool "null" $
796 isJsonError (J.readJSON J.JSNull::J.Result ExportTarget)
797 assertBool "int" $
798 isJsonError (J.readJSON (J.showJSON (5::Int))::J.Result ExportTarget)
799
800 testSuite "OpCodes"
801 [ 'prop_serialization
802 , 'case_AllDefined
803 , 'case_py_compat_types
804 , 'case_py_compat_fields
805 , 'prop_setOpComment
806 , 'prop_mkDiskIndex_fail
807 , 'case_readRecreateDisks_fail
808 , 'case_readDdmOldChanges_fail
809 , 'case_readExportTarget_fail
810 ]