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
92 import Data.List (foldl')
94 import qualified Data.Map as Map
95 import qualified Data.Set as Set
96 import Text.JSON (showJSON, readJSON, JSON, JSValue(..))
97 import qualified Text.JSON as J
99 import qualified Ganeti.Constants as C
104 -- * Generic definitions
106 -- | Fills one map with keys from the other map, if not already
107 -- existing. Mirrors objects.py:FillDict.
108 fillDict :: (Ord k) => Map.Map k v -> Map.Map k v -> [k] -> Map.Map k v
109 fillDict defaults custom skip_keys =
110 let updated = Map.union custom defaults
111 in foldl' (flip Map.delete) updated skip_keys
113 -- | The VTYPES, a mini-type system in Python.
114 $(declareSADT "VType"
115 [ ("VTypeString", 'C.vtypeString)
116 , ("VTypeMaybeString", 'C.vtypeMaybeString)
117 , ("VTypeBool", 'C.vtypeBool)
118 , ("VTypeSize", 'C.vtypeSize)
119 , ("VTypeInt", 'C.vtypeInt)
121 $(makeJSONInstance ''VType)
123 -- | The hypervisor parameter type. This is currently a simple map,
124 -- without type checking on key/value pairs.
125 type HvParams = Container JSValue
127 -- | The OS parameters type. This is, and will remain, a string
128 -- container, since the keys are dynamically declared by the OSes, and
129 -- the values are always strings.
130 type OsParams = Container String
132 -- | Class of objects that have timestamps.
133 class TimeStampObject a where
134 cTimeOf :: a -> Double
135 mTimeOf :: a -> Double
137 -- | Class of objects that have an UUID.
138 class UuidObject a where
139 uuidOf :: a -> String
141 -- | Class of object that have a serial number.
142 class SerialNoObject a where
145 -- | Class of objects that have tags.
146 class TagsObject a where
147 tagsOf :: a -> Set.Set String
149 -- * Node role object
151 $(declareSADT "NodeRole"
152 [ ("NROffline", 'C.nrOffline)
153 , ("NRDrained", 'C.nrDrained)
154 , ("NRRegular", 'C.nrRegular)
155 , ("NRCandidate", 'C.nrMcandidate)
156 , ("NRMaster", 'C.nrMaster)
158 $(makeJSONInstance ''NodeRole)
160 -- | The description of the node role.
161 roleDescription :: NodeRole -> String
162 roleDescription NROffline = "offline"
163 roleDescription NRDrained = "drained"
164 roleDescription NRRegular = "regular"
165 roleDescription NRCandidate = "master candidate"
166 roleDescription NRMaster = "master"
170 $(buildParam "Nic" "nicp"
171 [ simpleField "mode" [t| NICMode |]
172 , simpleField "link" [t| String |]
175 $(buildObject "PartialNic" "nic"
176 [ simpleField "mac" [t| String |]
177 , optionalField $ simpleField "ip" [t| String |]
178 , simpleField "nicparams" [t| PartialNicParams |]
181 -- * Disk definitions
183 $(declareSADT "DiskMode"
184 [ ("DiskRdOnly", 'C.diskRdonly)
185 , ("DiskRdWr", 'C.diskRdwr)
187 $(makeJSONInstance ''DiskMode)
189 $(declareSADT "DiskType"
191 , ("LD_DRBD8", 'C.ldDrbd8)
192 , ("LD_FILE", 'C.ldFile)
193 , ("LD_BLOCKDEV", 'C.ldBlockdev)
194 , ("LD_RADOS", 'C.ldRbd)
196 $(makeJSONInstance ''DiskType)
198 -- | The persistent block driver type. Currently only one type is allowed.
199 $(declareSADT "BlockDriver"
200 [ ("BlockDrvManual", 'C.blockdevDriverManual)
202 $(makeJSONInstance ''BlockDriver)
204 -- | Constant for the dev_type key entry in the disk config.
208 -- | The disk configuration type. This includes the disk type itself,
209 -- for a more complete consistency. Note that since in the Python
210 -- code-base there's no authoritative place where we document the
211 -- logical id, this is probably a good reference point.
213 = LIDPlain String String -- ^ Volume group, logical volume
214 | LIDDrbd8 String String Int Int Int String
215 -- ^ NodeA, NodeB, Port, MinorA, MinorB, Secret
216 | LIDFile FileDriver String -- ^ Driver, path
217 | LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev)
218 | LIDRados String String -- ^ Unused, path
219 deriving (Read, Show, Eq)
221 -- | Mapping from a logical id to a disk type.
222 lidDiskType :: DiskLogicalId -> DiskType
223 lidDiskType (LIDPlain {}) = LD_LV
224 lidDiskType (LIDDrbd8 {}) = LD_DRBD8
225 lidDiskType (LIDFile {}) = LD_FILE
226 lidDiskType (LIDBlockDev {}) = LD_BLOCKDEV
227 lidDiskType (LIDRados {}) = LD_RADOS
229 -- | Builds the extra disk_type field for a given logical id.
230 lidEncodeType :: DiskLogicalId -> [(String, JSValue)]
231 lidEncodeType v = [(devType, showJSON . lidDiskType $ v)]
233 -- | Custom encoder for DiskLogicalId (logical id only).
234 encodeDLId :: DiskLogicalId -> JSValue
235 encodeDLId (LIDPlain vg lv) = JSArray [showJSON vg, showJSON lv]
236 encodeDLId (LIDDrbd8 nodeA nodeB port minorA minorB key) =
237 JSArray [ showJSON nodeA, showJSON nodeB, showJSON port
238 , showJSON minorA, showJSON minorB, showJSON key ]
239 encodeDLId (LIDRados pool name) = JSArray [showJSON pool, showJSON name]
240 encodeDLId (LIDFile driver name) = JSArray [showJSON driver, showJSON name]
241 encodeDLId (LIDBlockDev driver name) = JSArray [showJSON driver, showJSON name]
243 -- | Custom encoder for DiskLogicalId, composing both the logical id
244 -- and the extra disk_type field.
245 encodeFullDLId :: DiskLogicalId -> (JSValue, [(String, JSValue)])
246 encodeFullDLId v = (encodeDLId v, lidEncodeType v)
248 -- | Custom decoder for DiskLogicalId. This is manual for now, since
249 -- we don't have yet automation for separate-key style fields.
250 decodeDLId :: [(String, JSValue)] -> JSValue -> J.Result DiskLogicalId
251 decodeDLId obj lid = do
252 dtype <- fromObj obj devType
256 JSArray [nA, nB, p, mA, mB, k] -> do
263 return $ LIDDrbd8 nA' nB' p' mA' mB' k'
264 _ -> fail "Can't read logical_id for DRBD8 type"
267 JSArray [vg, lv] -> do
270 return $ LIDPlain vg' lv'
271 _ -> fail "Can't read logical_id for plain type"
274 JSArray [driver, path] -> do
275 driver' <- readJSON driver
276 path' <- readJSON path
277 return $ LIDFile driver' path'
278 _ -> fail "Can't read logical_id for file type"
281 JSArray [driver, path] -> do
282 driver' <- readJSON driver
283 path' <- readJSON path
284 return $ LIDBlockDev driver' path'
285 _ -> fail "Can't read logical_id for blockdev type"
288 JSArray [driver, path] -> do
289 driver' <- readJSON driver
290 path' <- readJSON path
291 return $ LIDRados driver' path'
292 _ -> fail "Can't read logical_id for rdb type"
294 -- | Disk data structure.
296 -- This is declared manually as it's a recursive structure, and our TH
297 -- code currently can't build it.
299 { diskLogicalId :: DiskLogicalId
300 -- , diskPhysicalId :: String
301 , diskChildren :: [Disk]
302 , diskIvName :: String
304 , diskMode :: DiskMode
305 } deriving (Read, Show, Eq)
307 $(buildObjectSerialisation "Disk"
308 [ customField 'decodeDLId 'encodeFullDLId $
309 simpleField "logical_id" [t| DiskLogicalId |]
310 -- , simpleField "physical_id" [t| String |]
311 , defaultField [| [] |] $ simpleField "children" [t| [Disk] |]
312 , defaultField [| "" |] $ simpleField "iv_name" [t| String |]
313 , simpleField "size" [t| Int |]
314 , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
317 -- * Instance definitions
319 $(declareSADT "AdminState"
320 [ ("AdminOffline", 'C.adminstOffline)
321 , ("AdminDown", 'C.adminstDown)
322 , ("AdminUp", 'C.adminstUp)
324 $(makeJSONInstance ''AdminState)
326 $(buildParam "Be" "bep"
327 [ simpleField "minmem" [t| Int |]
328 , simpleField "maxmem" [t| Int |]
329 , simpleField "vcpus" [t| Int |]
330 , simpleField "auto_balance" [t| Bool |]
333 $(buildObject "Instance" "inst" $
334 [ simpleField "name" [t| String |]
335 , simpleField "primary_node" [t| String |]
336 , simpleField "os" [t| String |]
337 , simpleField "hypervisor" [t| Hypervisor |]
338 , simpleField "hvparams" [t| HvParams |]
339 , simpleField "beparams" [t| PartialBeParams |]
340 , simpleField "osparams" [t| OsParams |]
341 , simpleField "admin_state" [t| AdminState |]
342 , simpleField "nics" [t| [PartialNic] |]
343 , simpleField "disks" [t| [Disk] |]
344 , simpleField "disk_template" [t| DiskTemplate |]
345 , optionalField $ simpleField "network_port" [t| Int |]
352 instance TimeStampObject Instance where
356 instance UuidObject Instance where
359 instance SerialNoObject Instance where
360 serialOf = instSerial
362 instance TagsObject Instance where
365 -- * IPolicy definitions
367 $(buildParam "ISpec" "ispec"
368 [ simpleField C.ispecMemSize [t| Int |]
369 , simpleField C.ispecDiskSize [t| Int |]
370 , simpleField C.ispecDiskCount [t| Int |]
371 , simpleField C.ispecCpuCount [t| Int |]
372 , simpleField C.ispecNicCount [t| Int |]
373 , simpleField C.ispecSpindleUse [t| Int |]
376 -- | Custom partial ipolicy. This is not built via buildParam since it
377 -- has a special 2-level inheritance mode.
378 $(buildObject "PartialIPolicy" "ipolicy"
379 [ renameField "MinSpecP" $ simpleField "min" [t| PartialISpecParams |]
380 , renameField "MaxSpecP" $ simpleField "max" [t| PartialISpecParams |]
381 , renameField "StdSpecP" $ simpleField "std" [t| PartialISpecParams |]
382 , optionalField . renameField "SpindleRatioP"
383 $ simpleField "spindle-ratio" [t| Double |]
384 , optionalField . renameField "VcpuRatioP"
385 $ simpleField "vcpu-ratio" [t| Double |]
386 , optionalField . renameField "DiskTemplatesP"
387 $ simpleField "disk-templates" [t| [DiskTemplate] |]
390 -- | Custom filled ipolicy. This is not built via buildParam since it
391 -- has a special 2-level inheritance mode.
392 $(buildObject "FilledIPolicy" "ipolicy"
393 [ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |]
394 , renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |]
395 , renameField "StdSpec" $ simpleField "std" [t| FilledISpecParams |]
396 , simpleField "spindle-ratio" [t| Double |]
397 , simpleField "vcpu-ratio" [t| Double |]
398 , simpleField "disk-templates" [t| [DiskTemplate] |]
401 -- | Custom filler for the ipolicy types.
402 fillIPolicy :: FilledIPolicy -> PartialIPolicy -> FilledIPolicy
403 fillIPolicy (FilledIPolicy { ipolicyMinSpec = fmin
404 , ipolicyMaxSpec = fmax
405 , ipolicyStdSpec = fstd
406 , ipolicySpindleRatio = fspindleRatio
407 , ipolicyVcpuRatio = fvcpuRatio
408 , ipolicyDiskTemplates = fdiskTemplates})
409 (PartialIPolicy { ipolicyMinSpecP = pmin
410 , ipolicyMaxSpecP = pmax
411 , ipolicyStdSpecP = pstd
412 , ipolicySpindleRatioP = pspindleRatio
413 , ipolicyVcpuRatioP = pvcpuRatio
414 , ipolicyDiskTemplatesP = pdiskTemplates}) =
415 FilledIPolicy { ipolicyMinSpec = fillISpecParams fmin pmin
416 , ipolicyMaxSpec = fillISpecParams fmax pmax
417 , ipolicyStdSpec = fillISpecParams fstd pstd
418 , ipolicySpindleRatio = fromMaybe fspindleRatio pspindleRatio
419 , ipolicyVcpuRatio = fromMaybe fvcpuRatio pvcpuRatio
420 , ipolicyDiskTemplates = fromMaybe fdiskTemplates
423 -- * Node definitions
425 $(buildParam "ND" "ndp"
426 [ simpleField "oob_program" [t| String |]
427 , simpleField "spindle_count" [t| Int |]
430 $(buildObject "Node" "node" $
431 [ simpleField "name" [t| String |]
432 , simpleField "primary_ip" [t| String |]
433 , simpleField "secondary_ip" [t| String |]
434 , simpleField "master_candidate" [t| Bool |]
435 , simpleField "offline" [t| Bool |]
436 , simpleField "drained" [t| Bool |]
437 , simpleField "group" [t| String |]
438 , simpleField "master_capable" [t| Bool |]
439 , simpleField "vm_capable" [t| Bool |]
440 , simpleField "ndparams" [t| PartialNDParams |]
441 , simpleField "powered" [t| Bool |]
448 instance TimeStampObject Node where
452 instance UuidObject Node where
455 instance SerialNoObject Node where
456 serialOf = nodeSerial
458 instance TagsObject Node where
461 -- * NodeGroup definitions
463 -- | The disk parameters type.
464 type DiskParams = Container (Container JSValue)
466 $(buildObject "NodeGroup" "group" $
467 [ simpleField "name" [t| String |]
468 , defaultField [| [] |] $ simpleField "members" [t| [String] |]
469 , simpleField "ndparams" [t| PartialNDParams |]
470 , simpleField "alloc_policy" [t| AllocPolicy |]
471 , simpleField "ipolicy" [t| PartialIPolicy |]
472 , simpleField "diskparams" [t| DiskParams |]
479 instance TimeStampObject NodeGroup where
483 instance UuidObject NodeGroup where
486 instance SerialNoObject NodeGroup where
487 serialOf = groupSerial
489 instance TagsObject NodeGroup where
493 $(declareIADT "IpFamily"
494 [ ("IpFamilyV4", 'C.ip4Family)
495 , ("IpFamilyV6", 'C.ip6Family)
497 $(makeJSONInstance ''IpFamily)
499 -- | Conversion from IP family to IP version. This is needed because
500 -- Python uses both, depending on context.
501 ipFamilyToVersion :: IpFamily -> Int
502 ipFamilyToVersion IpFamilyV4 = C.ip4Version
503 ipFamilyToVersion IpFamilyV6 = C.ip6Version
505 -- | Cluster HvParams (hvtype to hvparams mapping).
506 type ClusterHvParams = Container HvParams
508 -- | Cluster Os-HvParams (os to hvparams mapping).
509 type OsHvParams = Container ClusterHvParams
511 -- | Cluser BeParams.
512 type ClusterBeParams = Container FilledBeParams
514 -- | Cluster OsParams.
515 type ClusterOsParams = Container OsParams
517 -- | Cluster NicParams.
518 type ClusterNicParams = Container FilledNicParams
520 -- | Cluster UID Pool, list (low, high) UID ranges.
521 type UidPool = [(Int, Int)]
523 -- * Cluster definitions
524 $(buildObject "Cluster" "cluster" $
525 [ simpleField "rsahostkeypub" [t| String |]
526 , simpleField "highest_used_port" [t| Int |]
527 , simpleField "tcpudp_port_pool" [t| [Int] |]
528 , simpleField "mac_prefix" [t| String |]
529 , simpleField "volume_group_name" [t| String |]
530 , simpleField "reserved_lvs" [t| [String] |]
532 simpleField "drbd_usermode_helper" [t| String |]
533 , simpleField "master_node" [t| String |]
534 , simpleField "master_ip" [t| String |]
535 , simpleField "master_netdev" [t| String |]
536 , simpleField "master_netmask" [t| Int |]
537 , simpleField "use_external_mip_script" [t| Bool |]
538 , simpleField "cluster_name" [t| String |]
539 , simpleField "file_storage_dir" [t| String |]
540 , simpleField "shared_file_storage_dir" [t| String |]
541 , simpleField "enabled_hypervisors" [t| [Hypervisor] |]
542 , simpleField "hvparams" [t| ClusterHvParams |]
543 , simpleField "os_hvp" [t| OsHvParams |]
544 , simpleField "beparams" [t| ClusterBeParams |]
545 , simpleField "osparams" [t| ClusterOsParams |]
546 , simpleField "nicparams" [t| ClusterNicParams |]
547 , simpleField "ndparams" [t| FilledNDParams |]
548 , simpleField "diskparams" [t| DiskParams |]
549 , simpleField "candidate_pool_size" [t| Int |]
550 , simpleField "modify_etc_hosts" [t| Bool |]
551 , simpleField "modify_ssh_setup" [t| Bool |]
552 , simpleField "maintain_node_health" [t| Bool |]
553 , simpleField "uid_pool" [t| UidPool |]
554 , simpleField "default_iallocator" [t| String |]
555 , simpleField "hidden_os" [t| [String] |]
556 , simpleField "blacklisted_os" [t| [String] |]
557 , simpleField "primary_ip_family" [t| IpFamily |]
558 , simpleField "prealloc_wipe_disks" [t| Bool |]
559 , simpleField "ipolicy" [t| FilledIPolicy |]
566 instance TimeStampObject Cluster where
567 cTimeOf = clusterCtime
568 mTimeOf = clusterMtime
570 instance UuidObject Cluster where
573 instance SerialNoObject Cluster where
574 serialOf = clusterSerial
576 instance TagsObject Cluster where
579 -- * ConfigData definitions
581 $(buildObject "ConfigData" "config" $
582 -- timeStampFields ++
583 [ simpleField "version" [t| Int |]
584 , simpleField "cluster" [t| Cluster |]
585 , simpleField "nodes" [t| Container Node |]
586 , simpleField "nodegroups" [t| Container NodeGroup |]
587 , simpleField "instances" [t| Container Instance |]
591 instance SerialNoObject ConfigData where
592 serialOf = configSerial