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
36 , PartialNicParams(..)
65 , FilledISpecParams(..)
66 , PartialISpecParams(..)
88 , DictObject(..) -- re-exported from THH
89 , TagSet -- re-exported from THH
93 import Data.List (foldl')
95 import qualified Data.Map as Map
96 import qualified Data.Set as Set
97 import Text.JSON (showJSON, readJSON, JSON, JSValue(..))
98 import qualified Text.JSON as J
100 import qualified Ganeti.Constants as C
105 -- * Generic definitions
107 -- | Fills one map with keys from the other map, if not already
108 -- existing. Mirrors objects.py:FillDict.
109 fillDict :: (Ord k) => Map.Map k v -> Map.Map k v -> [k] -> Map.Map k v
110 fillDict defaults custom skip_keys =
111 let updated = Map.union custom defaults
112 in foldl' (flip Map.delete) updated skip_keys
114 -- | The VTYPES, a mini-type system in Python.
115 $(declareSADT "VType"
116 [ ("VTypeString", 'C.vtypeString)
117 , ("VTypeMaybeString", 'C.vtypeMaybeString)
118 , ("VTypeBool", 'C.vtypeBool)
119 , ("VTypeSize", 'C.vtypeSize)
120 , ("VTypeInt", 'C.vtypeInt)
122 $(makeJSONInstance ''VType)
124 -- | The hypervisor parameter type. This is currently a simple map,
125 -- without type checking on key/value pairs.
126 type HvParams = Container JSValue
128 -- | The OS parameters type. This is, and will remain, a string
129 -- container, since the keys are dynamically declared by the OSes, and
130 -- the values are always strings.
131 type OsParams = Container String
133 -- | Class of objects that have timestamps.
134 class TimeStampObject a where
135 cTimeOf :: a -> Double
136 mTimeOf :: a -> Double
138 -- | Class of objects that have an UUID.
139 class UuidObject a where
140 uuidOf :: a -> String
142 -- | Class of object that have a serial number.
143 class SerialNoObject a where
146 -- | Class of objects that have tags.
147 class TagsObject a where
148 tagsOf :: a -> Set.Set String
150 -- * Node role object
152 $(declareSADT "NodeRole"
153 [ ("NROffline", 'C.nrOffline)
154 , ("NRDrained", 'C.nrDrained)
155 , ("NRRegular", 'C.nrRegular)
156 , ("NRCandidate", 'C.nrMcandidate)
157 , ("NRMaster", 'C.nrMaster)
159 $(makeJSONInstance ''NodeRole)
161 -- | The description of the node role.
162 roleDescription :: NodeRole -> String
163 roleDescription NROffline = "offline"
164 roleDescription NRDrained = "drained"
165 roleDescription NRRegular = "regular"
166 roleDescription NRCandidate = "master candidate"
167 roleDescription NRMaster = "master"
169 -- * Network definitions
171 -- FIXME: Not all types might be correct here, since they
172 -- haven't been exhaustively deduced from the python code yet.
173 $(buildObject "Network" "network" $
174 [ simpleField "name" [t| NonEmptyString |]
176 simpleField "mac_prefix" [t| String |]
178 simpleField "family" [t| Int |]
179 , simpleField "network" [t| NonEmptyString |]
181 simpleField "network6" [t| String |]
183 simpleField "gateway" [t| String |]
185 simpleField "gateway6" [t| String |]
187 simpleField "size" [t| J.JSValue |]
189 simpleField "reservations" [t| String |]
191 simpleField "ext_reservations" [t| String |]
196 instance SerialNoObject Network where
197 serialOf = networkSerial
199 instance TagsObject Network where
204 $(buildParam "Nic" "nicp"
205 [ simpleField "mode" [t| NICMode |]
206 , simpleField "link" [t| String |]
209 $(buildObject "PartialNic" "nic"
210 [ simpleField "mac" [t| String |]
211 , optionalField $ simpleField "ip" [t| String |]
212 , simpleField "nicparams" [t| PartialNicParams |]
213 , optionalField $ simpleField "network" [t| String |]
216 -- * Disk definitions
218 $(declareSADT "DiskMode"
219 [ ("DiskRdOnly", 'C.diskRdonly)
220 , ("DiskRdWr", 'C.diskRdwr)
222 $(makeJSONInstance ''DiskMode)
224 $(declareSADT "DiskType"
226 , ("LD_DRBD8", 'C.ldDrbd8)
227 , ("LD_FILE", 'C.ldFile)
228 , ("LD_BLOCKDEV", 'C.ldBlockdev)
229 , ("LD_RADOS", 'C.ldRbd)
230 , ("LD_EXT", 'C.ldExt)
232 $(makeJSONInstance ''DiskType)
234 -- | The persistent block driver type. Currently only one type is allowed.
235 $(declareSADT "BlockDriver"
236 [ ("BlockDrvManual", 'C.blockdevDriverManual)
238 $(makeJSONInstance ''BlockDriver)
240 -- | Constant for the dev_type key entry in the disk config.
244 -- | The disk configuration type. This includes the disk type itself,
245 -- for a more complete consistency. Note that since in the Python
246 -- code-base there's no authoritative place where we document the
247 -- logical id, this is probably a good reference point.
249 = LIDPlain String String -- ^ Volume group, logical volume
250 | LIDDrbd8 String String Int Int Int String
251 -- ^ NodeA, NodeB, Port, MinorA, MinorB, Secret
252 | LIDFile FileDriver String -- ^ Driver, path
253 | LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev)
254 | LIDRados String String -- ^ Unused, path
255 | LIDExt String String -- ^ ExtProvider, unique name
258 -- | Mapping from a logical id to a disk type.
259 lidDiskType :: DiskLogicalId -> DiskType
260 lidDiskType (LIDPlain {}) = LD_LV
261 lidDiskType (LIDDrbd8 {}) = LD_DRBD8
262 lidDiskType (LIDFile {}) = LD_FILE
263 lidDiskType (LIDBlockDev {}) = LD_BLOCKDEV
264 lidDiskType (LIDRados {}) = LD_RADOS
265 lidDiskType (LIDExt {}) = LD_EXT
267 -- | Builds the extra disk_type field for a given logical id.
268 lidEncodeType :: DiskLogicalId -> [(String, JSValue)]
269 lidEncodeType v = [(devType, showJSON . lidDiskType $ v)]
271 -- | Custom encoder for DiskLogicalId (logical id only).
272 encodeDLId :: DiskLogicalId -> JSValue
273 encodeDLId (LIDPlain vg lv) = JSArray [showJSON vg, showJSON lv]
274 encodeDLId (LIDDrbd8 nodeA nodeB port minorA minorB key) =
275 JSArray [ showJSON nodeA, showJSON nodeB, showJSON port
276 , showJSON minorA, showJSON minorB, showJSON key ]
277 encodeDLId (LIDRados pool name) = JSArray [showJSON pool, showJSON name]
278 encodeDLId (LIDFile driver name) = JSArray [showJSON driver, showJSON name]
279 encodeDLId (LIDBlockDev driver name) = JSArray [showJSON driver, showJSON name]
280 encodeDLId (LIDExt extprovider name) =
281 JSArray [showJSON extprovider, showJSON name]
283 -- | Custom encoder for DiskLogicalId, composing both the logical id
284 -- and the extra disk_type field.
285 encodeFullDLId :: DiskLogicalId -> (JSValue, [(String, JSValue)])
286 encodeFullDLId v = (encodeDLId v, lidEncodeType v)
288 -- | Custom decoder for DiskLogicalId. This is manual for now, since
289 -- we don't have yet automation for separate-key style fields.
290 decodeDLId :: [(String, JSValue)] -> JSValue -> J.Result DiskLogicalId
291 decodeDLId obj lid = do
292 dtype <- fromObj obj devType
296 JSArray [nA, nB, p, mA, mB, k] -> do
303 return $ LIDDrbd8 nA' nB' p' mA' mB' k'
304 _ -> fail "Can't read logical_id for DRBD8 type"
307 JSArray [vg, lv] -> do
310 return $ LIDPlain vg' lv'
311 _ -> fail "Can't read logical_id for plain type"
314 JSArray [driver, path] -> do
315 driver' <- readJSON driver
316 path' <- readJSON path
317 return $ LIDFile driver' path'
318 _ -> fail "Can't read logical_id for file type"
321 JSArray [driver, path] -> do
322 driver' <- readJSON driver
323 path' <- readJSON path
324 return $ LIDBlockDev driver' path'
325 _ -> fail "Can't read logical_id for blockdev type"
328 JSArray [driver, path] -> do
329 driver' <- readJSON driver
330 path' <- readJSON path
331 return $ LIDRados driver' path'
332 _ -> fail "Can't read logical_id for rdb type"
335 JSArray [extprovider, name] -> do
336 extprovider' <- readJSON extprovider
337 name' <- readJSON name
338 return $ LIDExt extprovider' name'
339 _ -> fail "Can't read logical_id for extstorage type"
341 -- | Disk data structure.
343 -- This is declared manually as it's a recursive structure, and our TH
344 -- code currently can't build it.
346 { diskLogicalId :: DiskLogicalId
347 -- , diskPhysicalId :: String
348 , diskChildren :: [Disk]
349 , diskIvName :: String
351 , diskMode :: DiskMode
352 } deriving (Show, Eq)
354 $(buildObjectSerialisation "Disk"
355 [ customField 'decodeDLId 'encodeFullDLId ["dev_type"] $
356 simpleField "logical_id" [t| DiskLogicalId |]
357 -- , simpleField "physical_id" [t| String |]
358 , defaultField [| [] |] $ simpleField "children" [t| [Disk] |]
359 , defaultField [| "" |] $ simpleField "iv_name" [t| String |]
360 , simpleField "size" [t| Int |]
361 , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
364 -- * Instance definitions
366 $(declareSADT "AdminState"
367 [ ("AdminOffline", 'C.adminstOffline)
368 , ("AdminDown", 'C.adminstDown)
369 , ("AdminUp", 'C.adminstUp)
371 $(makeJSONInstance ''AdminState)
373 $(buildParam "Be" "bep"
374 [ simpleField "minmem" [t| Int |]
375 , simpleField "maxmem" [t| Int |]
376 , simpleField "vcpus" [t| Int |]
377 , simpleField "auto_balance" [t| Bool |]
380 $(buildObject "Instance" "inst" $
381 [ simpleField "name" [t| String |]
382 , simpleField "primary_node" [t| String |]
383 , simpleField "os" [t| String |]
384 , simpleField "hypervisor" [t| Hypervisor |]
385 , simpleField "hvparams" [t| HvParams |]
386 , simpleField "beparams" [t| PartialBeParams |]
387 , simpleField "osparams" [t| OsParams |]
388 , simpleField "admin_state" [t| AdminState |]
389 , simpleField "nics" [t| [PartialNic] |]
390 , simpleField "disks" [t| [Disk] |]
391 , simpleField "disk_template" [t| DiskTemplate |]
392 , optionalField $ simpleField "network_port" [t| Int |]
399 instance TimeStampObject Instance where
403 instance UuidObject Instance where
406 instance SerialNoObject Instance where
407 serialOf = instSerial
409 instance TagsObject Instance where
412 -- * IPolicy definitions
414 $(buildParam "ISpec" "ispec"
415 [ simpleField C.ispecMemSize [t| Int |]
416 , simpleField C.ispecDiskSize [t| Int |]
417 , simpleField C.ispecDiskCount [t| Int |]
418 , simpleField C.ispecCpuCount [t| Int |]
419 , simpleField C.ispecNicCount [t| Int |]
420 , simpleField C.ispecSpindleUse [t| Int |]
423 -- | Custom partial ipolicy. This is not built via buildParam since it
424 -- has a special 2-level inheritance mode.
425 $(buildObject "PartialIPolicy" "ipolicy"
426 [ renameField "MinSpecP" $ simpleField "min" [t| PartialISpecParams |]
427 , renameField "MaxSpecP" $ simpleField "max" [t| PartialISpecParams |]
428 , renameField "StdSpecP" $ simpleField "std" [t| PartialISpecParams |]
429 , optionalField . renameField "SpindleRatioP"
430 $ simpleField "spindle-ratio" [t| Double |]
431 , optionalField . renameField "VcpuRatioP"
432 $ simpleField "vcpu-ratio" [t| Double |]
433 , optionalField . renameField "DiskTemplatesP"
434 $ simpleField "disk-templates" [t| [DiskTemplate] |]
437 -- | Custom filled ipolicy. This is not built via buildParam since it
438 -- has a special 2-level inheritance mode.
439 $(buildObject "FilledIPolicy" "ipolicy"
440 [ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |]
441 , renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |]
442 , renameField "StdSpec" $ simpleField "std" [t| FilledISpecParams |]
443 , simpleField "spindle-ratio" [t| Double |]
444 , simpleField "vcpu-ratio" [t| Double |]
445 , simpleField "disk-templates" [t| [DiskTemplate] |]
448 -- | Custom filler for the ipolicy types.
449 fillIPolicy :: FilledIPolicy -> PartialIPolicy -> FilledIPolicy
450 fillIPolicy (FilledIPolicy { ipolicyMinSpec = fmin
451 , ipolicyMaxSpec = fmax
452 , ipolicyStdSpec = fstd
453 , ipolicySpindleRatio = fspindleRatio
454 , ipolicyVcpuRatio = fvcpuRatio
455 , ipolicyDiskTemplates = fdiskTemplates})
456 (PartialIPolicy { ipolicyMinSpecP = pmin
457 , ipolicyMaxSpecP = pmax
458 , ipolicyStdSpecP = pstd
459 , ipolicySpindleRatioP = pspindleRatio
460 , ipolicyVcpuRatioP = pvcpuRatio
461 , ipolicyDiskTemplatesP = pdiskTemplates}) =
462 FilledIPolicy { ipolicyMinSpec = fillISpecParams fmin pmin
463 , ipolicyMaxSpec = fillISpecParams fmax pmax
464 , ipolicyStdSpec = fillISpecParams fstd pstd
465 , ipolicySpindleRatio = fromMaybe fspindleRatio pspindleRatio
466 , ipolicyVcpuRatio = fromMaybe fvcpuRatio pvcpuRatio
467 , ipolicyDiskTemplates = fromMaybe fdiskTemplates
470 -- * Node definitions
472 $(buildParam "ND" "ndp"
473 [ simpleField "oob_program" [t| String |]
474 , simpleField "spindle_count" [t| Int |]
475 , simpleField "exclusive_storage" [t| Bool |]
478 $(buildObject "Node" "node" $
479 [ simpleField "name" [t| String |]
480 , simpleField "primary_ip" [t| String |]
481 , simpleField "secondary_ip" [t| String |]
482 , simpleField "master_candidate" [t| Bool |]
483 , simpleField "offline" [t| Bool |]
484 , simpleField "drained" [t| Bool |]
485 , simpleField "group" [t| String |]
486 , simpleField "master_capable" [t| Bool |]
487 , simpleField "vm_capable" [t| Bool |]
488 , simpleField "ndparams" [t| PartialNDParams |]
489 , simpleField "powered" [t| Bool |]
496 instance TimeStampObject Node where
500 instance UuidObject Node where
503 instance SerialNoObject Node where
504 serialOf = nodeSerial
506 instance TagsObject Node where
509 -- * NodeGroup definitions
511 -- | The disk parameters type.
512 type DiskParams = Container (Container JSValue)
514 -- | A mapping from network UUIDs to nic params of the networks.
515 type Networks = Container PartialNicParams
517 $(buildObject "NodeGroup" "group" $
518 [ simpleField "name" [t| String |]
519 , defaultField [| [] |] $ simpleField "members" [t| [String] |]
520 , simpleField "ndparams" [t| PartialNDParams |]
521 , simpleField "alloc_policy" [t| AllocPolicy |]
522 , simpleField "ipolicy" [t| PartialIPolicy |]
523 , simpleField "diskparams" [t| DiskParams |]
524 , simpleField "networks" [t| Networks |]
531 instance TimeStampObject NodeGroup where
535 instance UuidObject NodeGroup where
538 instance SerialNoObject NodeGroup where
539 serialOf = groupSerial
541 instance TagsObject NodeGroup where
545 $(declareIADT "IpFamily"
546 [ ("IpFamilyV4", 'C.ip4Family)
547 , ("IpFamilyV6", 'C.ip6Family)
549 $(makeJSONInstance ''IpFamily)
551 -- | Conversion from IP family to IP version. This is needed because
552 -- Python uses both, depending on context.
553 ipFamilyToVersion :: IpFamily -> Int
554 ipFamilyToVersion IpFamilyV4 = C.ip4Version
555 ipFamilyToVersion IpFamilyV6 = C.ip6Version
557 -- | Cluster HvParams (hvtype to hvparams mapping).
558 type ClusterHvParams = Container HvParams
560 -- | Cluster Os-HvParams (os to hvparams mapping).
561 type OsHvParams = Container ClusterHvParams
563 -- | Cluser BeParams.
564 type ClusterBeParams = Container FilledBeParams
566 -- | Cluster OsParams.
567 type ClusterOsParams = Container OsParams
569 -- | Cluster NicParams.
570 type ClusterNicParams = Container FilledNicParams
572 -- | Cluster UID Pool, list (low, high) UID ranges.
573 type UidPool = [(Int, Int)]
575 -- * Cluster definitions
576 $(buildObject "Cluster" "cluster" $
577 [ simpleField "rsahostkeypub" [t| String |]
578 , simpleField "highest_used_port" [t| Int |]
579 , simpleField "tcpudp_port_pool" [t| [Int] |]
580 , simpleField "mac_prefix" [t| String |]
581 , simpleField "volume_group_name" [t| String |]
582 , simpleField "reserved_lvs" [t| [String] |]
584 simpleField "drbd_usermode_helper" [t| String |]
585 , simpleField "master_node" [t| String |]
586 , simpleField "master_ip" [t| String |]
587 , simpleField "master_netdev" [t| String |]
588 , simpleField "master_netmask" [t| Int |]
589 , simpleField "use_external_mip_script" [t| Bool |]
590 , simpleField "cluster_name" [t| String |]
591 , simpleField "file_storage_dir" [t| String |]
592 , simpleField "shared_file_storage_dir" [t| String |]
593 , simpleField "enabled_hypervisors" [t| [Hypervisor] |]
594 , simpleField "hvparams" [t| ClusterHvParams |]
595 , simpleField "os_hvp" [t| OsHvParams |]
596 , simpleField "beparams" [t| ClusterBeParams |]
597 , simpleField "osparams" [t| ClusterOsParams |]
598 , simpleField "nicparams" [t| ClusterNicParams |]
599 , simpleField "ndparams" [t| FilledNDParams |]
600 , simpleField "diskparams" [t| DiskParams |]
601 , simpleField "candidate_pool_size" [t| Int |]
602 , simpleField "modify_etc_hosts" [t| Bool |]
603 , simpleField "modify_ssh_setup" [t| Bool |]
604 , simpleField "maintain_node_health" [t| Bool |]
605 , simpleField "uid_pool" [t| UidPool |]
606 , simpleField "default_iallocator" [t| String |]
607 , simpleField "hidden_os" [t| [String] |]
608 , simpleField "blacklisted_os" [t| [String] |]
609 , simpleField "primary_ip_family" [t| IpFamily |]
610 , simpleField "prealloc_wipe_disks" [t| Bool |]
611 , simpleField "ipolicy" [t| FilledIPolicy |]
618 instance TimeStampObject Cluster where
619 cTimeOf = clusterCtime
620 mTimeOf = clusterMtime
622 instance UuidObject Cluster where
625 instance SerialNoObject Cluster where
626 serialOf = clusterSerial
628 instance TagsObject Cluster where
631 -- * ConfigData definitions
633 $(buildObject "ConfigData" "config" $
634 -- timeStampFields ++
635 [ simpleField "version" [t| Int |]
636 , simpleField "cluster" [t| Cluster |]
637 , simpleField "nodes" [t| Container Node |]
638 , simpleField "nodegroups" [t| Container NodeGroup |]
639 , simpleField "instances" [t| Container Instance |]
643 instance SerialNoObject ConfigData where
644 serialOf = configSerial