1 {-# LANGUAGE TemplateHaskell #-}
3 {-| Implementation of the Ganeti config objects.
5 Some object fields are not implemented yet, and as such they are
12 Copyright (C) 2011, 2012 Google Inc.
14 This program is free software; you can redistribute it and/or modify
15 it under the terms of the GNU General Public License as published by
16 the Free Software Foundation; either version 2 of the License, or
17 (at your option) any later version.
19 This program is distributed in the hope that it will be useful, but
20 WITHOUT ANY WARRANTY; without even the implied warranty of
21 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
22 General Public License for more details.
24 You should have received a copy of the GNU General Public License
25 along with this program; if not, write to the Free Software
26 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
37 , PartialNicParams(..)
67 , FilledISpecParams(..)
68 , PartialISpecParams(..)
90 , DictObject(..) -- re-exported from THH
91 , TagSet -- re-exported from THH
94 import Data.List (foldl')
96 import qualified Data.Map as Map
97 import qualified Data.Set as Set
98 import Text.JSON (makeObj, showJSON, readJSON, JSON, JSValue(..))
99 import qualified Text.JSON as J
101 import qualified Ganeti.Constants as C
106 -- * Generic definitions
108 -- | Fills one map with keys from the other map, if not already
109 -- existing. Mirrors objects.py:FillDict.
110 fillDict :: (Ord k) => Map.Map k v -> Map.Map k v -> [k] -> Map.Map k v
111 fillDict defaults custom skip_keys =
112 let updated = Map.union custom defaults
113 in foldl' (flip Map.delete) updated skip_keys
115 -- | The VTYPES, a mini-type system in Python.
116 $(declareSADT "VType"
117 [ ("VTypeString", 'C.vtypeString)
118 , ("VTypeMaybeString", 'C.vtypeMaybeString)
119 , ("VTypeBool", 'C.vtypeBool)
120 , ("VTypeSize", 'C.vtypeSize)
121 , ("VTypeInt", 'C.vtypeInt)
123 $(makeJSONInstance ''VType)
125 -- | The hypervisor parameter type. This is currently a simple map,
126 -- without type checking on key/value pairs.
127 type HvParams = Container JSValue
129 -- | The OS parameters type. This is, and will remain, a string
130 -- container, since the keys are dynamically declared by the OSes, and
131 -- the values are always strings.
132 type OsParams = Container String
134 -- | Class of objects that have timestamps.
135 class TimeStampObject a where
136 cTimeOf :: a -> Double
137 mTimeOf :: a -> Double
139 -- | Class of objects that have an UUID.
140 class UuidObject a where
141 uuidOf :: a -> String
143 -- | Class of object that have a serial number.
144 class SerialNoObject a where
147 -- | Class of objects that have tags.
148 class TagsObject a where
149 tagsOf :: a -> Set.Set String
151 -- * Node role object
153 $(declareSADT "NodeRole"
154 [ ("NROffline", 'C.nrOffline)
155 , ("NRDrained", 'C.nrDrained)
156 , ("NRRegular", 'C.nrRegular)
157 , ("NRCandidate", 'C.nrMcandidate)
158 , ("NRMaster", 'C.nrMaster)
160 $(makeJSONInstance ''NodeRole)
162 -- | The description of the node role.
163 roleDescription :: NodeRole -> String
164 roleDescription NROffline = "offline"
165 roleDescription NRDrained = "drained"
166 roleDescription NRRegular = "regular"
167 roleDescription NRCandidate = "master candidate"
168 roleDescription NRMaster = "master"
172 $(declareSADT "NICMode"
173 [ ("NMBridged", 'C.nicModeBridged)
174 , ("NMRouted", 'C.nicModeRouted)
176 $(makeJSONInstance ''NICMode)
178 $(buildParam "Nic" "nicp"
179 [ simpleField "mode" [t| NICMode |]
180 , simpleField "link" [t| String |]
183 $(buildObject "PartialNic" "nic"
184 [ simpleField "mac" [t| String |]
185 , optionalField $ simpleField "ip" [t| String |]
186 , simpleField "nicparams" [t| PartialNicParams |]
189 -- * Disk definitions
191 $(declareSADT "DiskMode"
192 [ ("DiskRdOnly", 'C.diskRdonly)
193 , ("DiskRdWr", 'C.diskRdwr)
195 $(makeJSONInstance ''DiskMode)
197 $(declareSADT "DiskType"
199 , ("LD_DRBD8", 'C.ldDrbd8)
200 , ("LD_FILE", 'C.ldFile)
201 , ("LD_BLOCKDEV", 'C.ldBlockdev)
202 , ("LD_RADOS", 'C.ldRbd)
204 $(makeJSONInstance ''DiskType)
206 -- | The file driver type.
207 $(declareSADT "FileDriver"
208 [ ("FileLoop", 'C.fdLoop)
209 , ("FileBlktap", 'C.fdBlktap)
211 $(makeJSONInstance ''FileDriver)
213 -- | The persistent block driver type. Currently only one type is allowed.
214 $(declareSADT "BlockDriver"
215 [ ("BlockDrvManual", 'C.blockdevDriverManual)
217 $(makeJSONInstance ''BlockDriver)
219 -- | Constant for the dev_type key entry in the disk config.
223 -- | The disk configuration type. This includes the disk type itself,
224 -- for a more complete consistency. Note that since in the Python
225 -- code-base there's no authoritative place where we document the
226 -- logical id, this is probably a good reference point.
228 = LIDPlain String String -- ^ Volume group, logical volume
229 | LIDDrbd8 String String Int Int Int String
230 -- ^ NodeA, NodeB, Port, MinorA, MinorB, Secret
231 | LIDFile FileDriver String -- ^ Driver, path
232 | LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev)
233 | LIDRados String String -- ^ Unused, path
234 deriving (Read, Show, Eq)
236 -- | Mapping from a logical id to a disk type.
237 lidDiskType :: DiskLogicalId -> DiskType
238 lidDiskType (LIDPlain {}) = LD_LV
239 lidDiskType (LIDDrbd8 {}) = LD_DRBD8
240 lidDiskType (LIDFile {}) = LD_FILE
241 lidDiskType (LIDBlockDev {}) = LD_BLOCKDEV
242 lidDiskType (LIDRados {}) = LD_RADOS
244 -- | Builds the extra disk_type field for a given logical id.
245 lidEncodeType :: DiskLogicalId -> [(String, JSValue)]
246 lidEncodeType v = [(devType, showJSON . lidDiskType $ v)]
248 -- | Custom encoder for DiskLogicalId (logical id only).
249 encodeDLId :: DiskLogicalId -> JSValue
250 encodeDLId (LIDPlain vg lv) = JSArray [showJSON vg, showJSON lv]
251 encodeDLId (LIDDrbd8 nodeA nodeB port minorA minorB key) =
252 JSArray [ showJSON nodeA, showJSON nodeB, showJSON port
253 , showJSON minorA, showJSON minorB, showJSON key ]
254 encodeDLId (LIDRados pool name) = JSArray [showJSON pool, showJSON name]
255 encodeDLId (LIDFile driver name) = JSArray [showJSON driver, showJSON name]
256 encodeDLId (LIDBlockDev driver name) = JSArray [showJSON driver, showJSON name]
258 -- | Custom encoder for DiskLogicalId, composing both the logical id
259 -- and the extra disk_type field.
260 encodeFullDLId :: DiskLogicalId -> (JSValue, [(String, JSValue)])
261 encodeFullDLId v = (encodeDLId v, lidEncodeType v)
263 -- | Custom decoder for DiskLogicalId. This is manual for now, since
264 -- we don't have yet automation for separate-key style fields.
265 decodeDLId :: [(String, JSValue)] -> JSValue -> J.Result DiskLogicalId
266 decodeDLId obj lid = do
267 dtype <- fromObj obj devType
271 JSArray [nA, nB, p, mA, mB, k] -> do
278 return $ LIDDrbd8 nA' nB' p' mA' mB' k'
279 _ -> fail "Can't read logical_id for DRBD8 type"
282 JSArray [vg, lv] -> do
285 return $ LIDPlain vg' lv'
286 _ -> fail "Can't read logical_id for plain type"
289 JSArray [driver, path] -> do
290 driver' <- readJSON driver
291 path' <- readJSON path
292 return $ LIDFile driver' path'
293 _ -> fail "Can't read logical_id for file type"
296 JSArray [driver, path] -> do
297 driver' <- readJSON driver
298 path' <- readJSON path
299 return $ LIDBlockDev driver' path'
300 _ -> fail "Can't read logical_id for blockdev type"
303 JSArray [driver, path] -> do
304 driver' <- readJSON driver
305 path' <- readJSON path
306 return $ LIDRados driver' path'
307 _ -> fail "Can't read logical_id for rdb type"
309 -- | Disk data structure.
311 -- This is declared manually as it's a recursive structure, and our TH
312 -- code currently can't build it.
314 { diskLogicalId :: DiskLogicalId
315 -- , diskPhysicalId :: String
316 , diskChildren :: [Disk]
317 , diskIvName :: String
319 , diskMode :: DiskMode
320 } deriving (Read, Show, Eq)
322 $(buildObjectSerialisation "Disk"
323 [ customField 'decodeDLId 'encodeFullDLId $
324 simpleField "logical_id" [t| DiskLogicalId |]
325 -- , simpleField "physical_id" [t| String |]
326 , defaultField [| [] |] $ simpleField "children" [t| [Disk] |]
327 , defaultField [| "" |] $ simpleField "iv_name" [t| String |]
328 , simpleField "size" [t| Int |]
329 , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
332 -- * Hypervisor definitions
334 -- | This may be due to change when we add hypervisor parameters.
335 $(declareSADT "Hypervisor"
336 [ ( "Kvm", 'C.htKvm )
337 , ( "XenPvm", 'C.htXenPvm )
338 , ( "Chroot", 'C.htChroot )
339 , ( "XenHvm", 'C.htXenHvm )
340 , ( "Lxc", 'C.htLxc )
341 , ( "Fake", 'C.htFake )
343 $(makeJSONInstance ''Hypervisor)
345 -- * Instance definitions
347 -- | Instance disk template type. **Copied from HTools/Types.hs**
348 $(declareSADT "DiskTemplate"
349 [ ("DTDiskless", 'C.dtDiskless)
350 , ("DTFile", 'C.dtFile)
351 , ("DTSharedFile", 'C.dtSharedFile)
352 , ("DTPlain", 'C.dtPlain)
353 , ("DTBlock", 'C.dtBlock)
354 , ("DTDrbd8", 'C.dtDrbd8)
355 , ("DTRados", 'C.dtRbd)
357 $(makeJSONInstance ''DiskTemplate)
359 $(declareSADT "AdminState"
360 [ ("AdminOffline", 'C.adminstOffline)
361 , ("AdminDown", 'C.adminstDown)
362 , ("AdminUp", 'C.adminstUp)
364 $(makeJSONInstance ''AdminState)
366 $(buildParam "Be" "bep"
367 [ simpleField "minmem" [t| Int |]
368 , simpleField "maxmem" [t| Int |]
369 , simpleField "vcpus" [t| Int |]
370 , simpleField "auto_balance" [t| Bool |]
373 $(buildObject "Instance" "inst" $
374 [ simpleField "name" [t| String |]
375 , simpleField "primary_node" [t| String |]
376 , simpleField "os" [t| String |]
377 , simpleField "hypervisor" [t| Hypervisor |]
378 , simpleField "hvparams" [t| HvParams |]
379 , simpleField "beparams" [t| PartialBeParams |]
380 , simpleField "osparams" [t| OsParams |]
381 , simpleField "admin_state" [t| AdminState |]
382 , simpleField "nics" [t| [PartialNic] |]
383 , simpleField "disks" [t| [Disk] |]
384 , simpleField "disk_template" [t| DiskTemplate |]
385 , optionalField $ simpleField "network_port" [t| Int |]
392 instance TimeStampObject Instance where
396 instance UuidObject Instance where
399 instance SerialNoObject Instance where
400 serialOf = instSerial
402 instance TagsObject Instance where
405 -- * IPolicy definitions
407 $(buildParam "ISpec" "ispec"
408 [ simpleField C.ispecMemSize [t| Int |]
409 , simpleField C.ispecDiskSize [t| Int |]
410 , simpleField C.ispecDiskCount [t| Int |]
411 , simpleField C.ispecCpuCount [t| Int |]
412 , simpleField C.ispecSpindleUse [t| Int |]
415 -- | Custom partial ipolicy. This is not built via buildParam since it
416 -- has a special 2-level inheritance mode.
417 $(buildObject "PartialIPolicy" "ipolicy"
418 [ renameField "MinSpecP" $ simpleField "min" [t| PartialISpecParams |]
419 , renameField "MaxSpecP" $ simpleField "max" [t| PartialISpecParams |]
420 , renameField "StdSpecP" $ simpleField "std" [t| PartialISpecParams |]
421 , optionalField . renameField "SpindleRatioP"
422 $ simpleField "spindle-ratio" [t| Double |]
423 , optionalField . renameField "VcpuRatioP"
424 $ simpleField "vcpu-ratio" [t| Double |]
425 , optionalField . renameField "DiskTemplatesP"
426 $ simpleField "disk-templates" [t| [DiskTemplate] |]
429 -- | Custom filled ipolicy. This is not built via buildParam since it
430 -- has a special 2-level inheritance mode.
431 $(buildObject "FilledIPolicy" "ipolicy"
432 [ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |]
433 , renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |]
434 , renameField "StdSpec" $ simpleField "std" [t| FilledISpecParams |]
435 , simpleField "spindle-ratio" [t| Double |]
436 , simpleField "vcpu-ratio" [t| Double |]
437 , simpleField "disk-templates" [t| [DiskTemplate] |]
440 -- | Custom filler for the ipolicy types.
441 fillIPolicy :: FilledIPolicy -> PartialIPolicy -> FilledIPolicy
442 fillIPolicy (FilledIPolicy { ipolicyMinSpec = fmin
443 , ipolicyMaxSpec = fmax
444 , ipolicyStdSpec = fstd
445 , ipolicySpindleRatio = fspindleRatio
446 , ipolicyVcpuRatio = fvcpuRatio
447 , ipolicyDiskTemplates = fdiskTemplates})
448 (PartialIPolicy { ipolicyMinSpecP = pmin
449 , ipolicyMaxSpecP = pmax
450 , ipolicyStdSpecP = pstd
451 , ipolicySpindleRatioP = pspindleRatio
452 , ipolicyVcpuRatioP = pvcpuRatio
453 , ipolicyDiskTemplatesP = pdiskTemplates}) =
454 FilledIPolicy { ipolicyMinSpec = fillISpecParams fmin pmin
455 , ipolicyMaxSpec = fillISpecParams fmax pmax
456 , ipolicyStdSpec = fillISpecParams fstd pstd
457 , ipolicySpindleRatio = fromMaybe fspindleRatio pspindleRatio
458 , ipolicyVcpuRatio = fromMaybe fvcpuRatio pvcpuRatio
459 , ipolicyDiskTemplates = fromMaybe fdiskTemplates
462 -- * Node definitions
464 $(buildParam "ND" "ndp"
465 [ simpleField "oob_program" [t| String |]
466 , simpleField "spindle_count" [t| Int |]
469 $(buildObject "Node" "node" $
470 [ simpleField "name" [t| String |]
471 , simpleField "primary_ip" [t| String |]
472 , simpleField "secondary_ip" [t| String |]
473 , simpleField "master_candidate" [t| Bool |]
474 , simpleField "offline" [t| Bool |]
475 , simpleField "drained" [t| Bool |]
476 , simpleField "group" [t| String |]
477 , simpleField "master_capable" [t| Bool |]
478 , simpleField "vm_capable" [t| Bool |]
479 , simpleField "ndparams" [t| PartialNDParams |]
480 , simpleField "powered" [t| Bool |]
487 instance TimeStampObject Node where
491 instance UuidObject Node where
494 instance SerialNoObject Node where
495 serialOf = nodeSerial
497 instance TagsObject Node where
500 -- * NodeGroup definitions
502 -- | The Group allocation policy type.
504 -- Note that the order of constructors is important as the automatic
505 -- Ord instance will order them in the order they are defined, so when
506 -- changing this data type be careful about the interaction with the
507 -- desired sorting order.
509 -- FIXME: COPIED from Types.hs; we need to eliminate this duplication later
510 $(declareSADT "AllocPolicy"
511 [ ("AllocPreferred", 'C.allocPolicyPreferred)
512 , ("AllocLastResort", 'C.allocPolicyLastResort)
513 , ("AllocUnallocable", 'C.allocPolicyUnallocable)
515 $(makeJSONInstance ''AllocPolicy)
517 -- | The disk parameters type.
518 type DiskParams = Container (Container JSValue)
520 $(buildObject "NodeGroup" "group" $
521 [ simpleField "name" [t| String |]
522 , defaultField [| [] |] $ simpleField "members" [t| [String] |]
523 , simpleField "ndparams" [t| PartialNDParams |]
524 , simpleField "alloc_policy" [t| AllocPolicy |]
525 , simpleField "ipolicy" [t| PartialIPolicy |]
526 , simpleField "diskparams" [t| DiskParams |]
533 instance TimeStampObject NodeGroup where
537 instance UuidObject NodeGroup where
540 instance SerialNoObject NodeGroup where
541 serialOf = groupSerial
543 instance TagsObject NodeGroup where
547 $(declareIADT "IpFamily"
548 [ ("IpFamilyV4", 'C.ip4Family)
549 , ("IpFamilyV6", 'C.ip6Family)
551 $(makeJSONInstance ''IpFamily)
553 -- | Conversion from IP family to IP version. This is needed because
554 -- Python uses both, depending on context.
555 ipFamilyToVersion :: IpFamily -> Int
556 ipFamilyToVersion IpFamilyV4 = C.ip4Version
557 ipFamilyToVersion IpFamilyV6 = C.ip6Version
559 -- | Cluster HvParams (hvtype to hvparams mapping).
560 type ClusterHvParams = Container HvParams
562 -- | Cluster Os-HvParams (os to hvparams mapping).
563 type OsHvParams = Container ClusterHvParams
565 -- | Cluser BeParams.
566 type ClusterBeParams = Container FilledBeParams
568 -- | Cluster OsParams.
569 type ClusterOsParams = Container OsParams
571 -- | Cluster NicParams.
572 type ClusterNicParams = Container FilledNicParams
574 -- | Cluster UID Pool, list (low, high) UID ranges.
575 type UidPool = [(Int, Int)]
577 -- * Cluster definitions
578 $(buildObject "Cluster" "cluster" $
579 [ simpleField "rsahostkeypub" [t| String |]
580 , simpleField "highest_used_port" [t| Int |]
581 , simpleField "tcpudp_port_pool" [t| [Int] |]
582 , simpleField "mac_prefix" [t| String |]
583 , simpleField "volume_group_name" [t| String |]
584 , simpleField "reserved_lvs" [t| [String] |]
586 simpleField "drbd_usermode_helper" [t| String |]
587 , simpleField "master_node" [t| String |]
588 , simpleField "master_ip" [t| String |]
589 , simpleField "master_netdev" [t| String |]
590 , simpleField "master_netmask" [t| Int |]
591 , simpleField "use_external_mip_script" [t| Bool |]
592 , simpleField "cluster_name" [t| String |]
593 , simpleField "file_storage_dir" [t| String |]
594 , simpleField "shared_file_storage_dir" [t| String |]
595 , simpleField "enabled_hypervisors" [t| [Hypervisor] |]
596 , simpleField "hvparams" [t| ClusterHvParams |]
597 , simpleField "os_hvp" [t| OsHvParams |]
598 , simpleField "beparams" [t| ClusterBeParams |]
599 , simpleField "osparams" [t| ClusterOsParams |]
600 , simpleField "nicparams" [t| ClusterNicParams |]
601 , simpleField "ndparams" [t| FilledNDParams |]
602 , simpleField "diskparams" [t| DiskParams |]
603 , simpleField "candidate_pool_size" [t| Int |]
604 , simpleField "modify_etc_hosts" [t| Bool |]
605 , simpleField "modify_ssh_setup" [t| Bool |]
606 , simpleField "maintain_node_health" [t| Bool |]
607 , simpleField "uid_pool" [t| UidPool |]
608 , simpleField "default_iallocator" [t| String |]
609 , simpleField "hidden_os" [t| [String] |]
610 , simpleField "blacklisted_os" [t| [String] |]
611 , simpleField "primary_ip_family" [t| IpFamily |]
612 , simpleField "prealloc_wipe_disks" [t| Bool |]
613 , simpleField "ipolicy" [t| FilledIPolicy |]
620 instance TimeStampObject Cluster where
621 cTimeOf = clusterCtime
622 mTimeOf = clusterMtime
624 instance UuidObject Cluster where
627 instance SerialNoObject Cluster where
628 serialOf = clusterSerial
630 instance TagsObject Cluster where
633 -- * ConfigData definitions
635 $(buildObject "ConfigData" "config" $
636 -- timeStampFields ++
637 [ simpleField "version" [t| Int |]
638 , simpleField "cluster" [t| Cluster |]
639 , simpleField "nodes" [t| Container Node |]
640 , simpleField "nodegroups" [t| Container NodeGroup |]
641 , simpleField "instances" [t| Container Instance |]
645 instance SerialNoObject ConfigData where
646 serialOf = configSerial