1b25933184ffddc856834059547dbd24642ba0cf
[ganeti-github.git] / src / Ganeti / Objects.hs
1 {-# LANGUAGE TemplateHaskell #-}
2
3 {-| Implementation of the Ganeti config objects.
4
5 Some object fields are not implemented yet, and as such they are
6 commented out below.
7
8 -}
9
10 {-
11
12 Copyright (C) 2011, 2012, 2013, 2014 Google Inc.
13 All rights reserved.
14
15 Redistribution and use in source and binary forms, with or without
16 modification, are permitted provided that the following conditions are
17 met:
18
19 1. Redistributions of source code must retain the above copyright notice,
20 this list of conditions and the following disclaimer.
21
22 2. Redistributions in binary form must reproduce the above copyright
23 notice, this list of conditions and the following disclaimer in the
24 documentation and/or other materials provided with the distribution.
25
26 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
27 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
28 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
29 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
30 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
31 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
32 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
33 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
34 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
35 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
36 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
37
38 -}
39
40 module Ganeti.Objects
41 ( HvParams
42 , OsParams
43 , OsParamsPrivate
44 , PartialNicParams(..)
45 , FilledNicParams(..)
46 , fillNicParams
47 , allNicParamFields
48 , PartialNic(..)
49 , FileDriver(..)
50 , DRBDSecret
51 , LogicalVolume(..)
52 , DiskLogicalId(..)
53 , Disk(..)
54 , includesLogicalId
55 , DiskTemplate(..)
56 , PartialBeParams(..)
57 , FilledBeParams(..)
58 , fillBeParams
59 , allBeParamFields
60 , Instance(..)
61 , PartialNDParams(..)
62 , FilledNDParams(..)
63 , fillNDParams
64 , allNDParamFields
65 , Node(..)
66 , AllocPolicy(..)
67 , FilledISpecParams(..)
68 , PartialISpecParams(..)
69 , fillISpecParams
70 , allISpecParamFields
71 , MinMaxISpecs(..)
72 , FilledIPolicy(..)
73 , PartialIPolicy(..)
74 , fillIPolicy
75 , GroupDiskParams
76 , NodeGroup(..)
77 , IpFamily(..)
78 , ipFamilyToRaw
79 , ipFamilyToVersion
80 , fillDict
81 , ClusterHvParams
82 , OsHvParams
83 , ClusterBeParams
84 , ClusterOsParams
85 , ClusterOsParamsPrivate
86 , ClusterNicParams
87 , UidPool
88 , formatUidRange
89 , UidRange
90 , Cluster(..)
91 , ConfigData(..)
92 , TimeStampObject(..)
93 , UuidObject(..)
94 , SerialNoObject(..)
95 , TagsObject(..)
96 , DictObject(..) -- re-exported from THH
97 , TagSet -- re-exported from THH
98 , Network(..)
99 , AddressPool(..)
100 , Ip4Address()
101 , mkIp4Address
102 , Ip4Network()
103 , mkIp4Network
104 , ip4netAddr
105 , ip4netMask
106 , readIp4Address
107 , ip4AddressToList
108 , ip4AddressToNumber
109 , ip4AddressFromNumber
110 , nextIp4Address
111 , IAllocatorParams
112 , MasterNetworkParameters(..)
113 ) where
114
115 import Control.Applicative
116 import Control.Arrow (first)
117 import Control.Monad.State
118 import Data.Char
119 import Data.List (foldl', isPrefixOf, isInfixOf, intercalate)
120 import Data.Maybe
121 import qualified Data.Map as Map
122 import qualified Data.Set as Set
123 import Data.Tuple (swap)
124 import Data.Word
125 import System.Time (ClockTime(..))
126 import Text.JSON (showJSON, readJSON, JSON, JSValue(..), fromJSString)
127 import qualified Text.JSON as J
128
129 import qualified AutoConf
130 import qualified Ganeti.Constants as C
131 import qualified Ganeti.ConstantUtils as ConstantUtils
132 import Ganeti.JSON
133 import Ganeti.Objects.BitArray (BitArray)
134 import Ganeti.Types
135 import Ganeti.THH
136 import Ganeti.THH.Field
137 import Ganeti.Utils (sepSplit, tryRead, parseUnitAssumeBinary)
138 import Ganeti.Utils.Validate
139
140 -- * Generic definitions
141
142 -- | Fills one map with keys from the other map, if not already
143 -- existing. Mirrors objects.py:FillDict.
144 fillDict :: (Ord k) => Map.Map k v -> Map.Map k v -> [k] -> Map.Map k v
145 fillDict defaults custom skip_keys =
146 let updated = Map.union custom defaults
147 in foldl' (flip Map.delete) updated skip_keys
148
149 -- | The hypervisor parameter type. This is currently a simple map,
150 -- without type checking on key/value pairs.
151 type HvParams = Container JSValue
152
153 -- | The OS parameters type. This is, and will remain, a string
154 -- container, since the keys are dynamically declared by the OSes, and
155 -- the values are always strings.
156 type OsParams = Container String
157 type OsParamsPrivate = Container (Private String)
158
159 -- | Class of objects that have timestamps.
160 class TimeStampObject a where
161 cTimeOf :: a -> ClockTime
162 mTimeOf :: a -> ClockTime
163
164 -- | Class of objects that have an UUID.
165 class UuidObject a where
166 uuidOf :: a -> String
167
168 -- | Class of object that have a serial number.
169 class SerialNoObject a where
170 serialOf :: a -> Int
171
172 -- | Class of objects that have tags.
173 class TagsObject a where
174 tagsOf :: a -> Set.Set String
175
176 -- * Network definitions
177
178 -- ** Ipv4 types
179
180 data Ip4Address = Ip4Address Word8 Word8 Word8 Word8
181 deriving (Eq, Ord)
182
183 mkIp4Address :: (Word8, Word8, Word8, Word8) -> Ip4Address
184 mkIp4Address (a, b, c, d) = Ip4Address a b c d
185
186 instance Show Ip4Address where
187 show (Ip4Address a b c d) = intercalate "." $ map show [a, b, c, d]
188
189 readIp4Address :: (Applicative m, Monad m) => String -> m Ip4Address
190 readIp4Address s =
191 case sepSplit '.' s of
192 [a, b, c, d] -> Ip4Address <$>
193 tryRead "first octect" a <*>
194 tryRead "second octet" b <*>
195 tryRead "third octet" c <*>
196 tryRead "fourth octet" d
197 _ -> fail $ "Can't parse IPv4 address from string " ++ s
198
199 instance JSON Ip4Address where
200 showJSON = showJSON . show
201 readJSON (JSString s) = readIp4Address (fromJSString s)
202 readJSON v = fail $ "Invalid JSON value " ++ show v ++ " for an IPv4 address"
203
204 -- Converts an address to a list of numbers
205 ip4AddressToList :: Ip4Address -> [Word8]
206 ip4AddressToList (Ip4Address a b c d) = [a, b, c, d]
207
208 -- | Converts an address into its ordinal number.
209 -- This is needed for indexing IP adresses in reservation pools.
210 ip4AddressToNumber :: Ip4Address -> Integer
211 ip4AddressToNumber = foldl (\n i -> 256 * n + toInteger i) 0 . ip4AddressToList
212
213 -- | Converts a number into an address.
214 -- This is needed for indexing IP adresses in reservation pools.
215 ip4AddressFromNumber :: Integer -> Ip4Address
216 ip4AddressFromNumber n =
217 let s = state $ first fromInteger . swap . (`divMod` 256)
218 (d, c, b, a) = evalState ((,,,) <$> s <*> s <*> s <*> s) n
219 in Ip4Address a b c d
220
221 nextIp4Address :: Ip4Address -> Ip4Address
222 nextIp4Address = ip4AddressFromNumber . (+ 1) . ip4AddressToNumber
223
224 -- | Custom type for an IPv4 network.
225 data Ip4Network = Ip4Network { ip4netAddr :: Ip4Address
226 , ip4netMask :: Word8
227 }
228 deriving (Eq)
229
230 mkIp4Network :: Ip4Address -> Word8 -> Ip4Network
231 mkIp4Network = Ip4Network
232
233 instance Show Ip4Network where
234 show (Ip4Network ip netmask) = show ip ++ "/" ++ show netmask
235
236 -- | JSON instance for 'Ip4Network'.
237 instance JSON Ip4Network where
238 showJSON = showJSON . show
239 readJSON (JSString s) =
240 case sepSplit '/' (fromJSString s) of
241 [ip, nm] -> do
242 ip' <- readIp4Address ip
243 nm' <- tryRead "parsing netmask" nm
244 if nm' >= 0 && nm' <= 32
245 then return $ Ip4Network ip' nm'
246 else fail $ "Invalid netmask " ++ show nm' ++ " from string " ++
247 fromJSString s
248 _ -> fail $ "Can't parse IPv4 network from string " ++ fromJSString s
249 readJSON v = fail $ "Invalid JSON value " ++ show v ++ " for an IPv4 network"
250
251 -- ** Address pools
252
253 -- | Currently address pools just wrap a reservation 'BitArray'.
254 --
255 -- In future, 'Network' might be extended to include several address pools
256 -- and address pools might include their own ranges of addresses.
257 newtype AddressPool = AddressPool { apReservations :: BitArray }
258 deriving (Eq, Ord, Show)
259
260 instance JSON AddressPool where
261 showJSON = showJSON . apReservations
262 readJSON = liftM AddressPool . readJSON
263
264 -- ** Ganeti \"network\" config object.
265
266 -- FIXME: Not all types might be correct here, since they
267 -- haven't been exhaustively deduced from the python code yet.
268 --
269 -- FIXME: When parsing, check that the ext_reservations and reservations
270 -- have the same length
271 $(buildObject "Network" "network" $
272 [ simpleField "name" [t| NonEmptyString |]
273 , optionalField $
274 simpleField "mac_prefix" [t| String |]
275 , simpleField "network" [t| Ip4Network |]
276 , optionalField $
277 simpleField "network6" [t| String |]
278 , optionalField $
279 simpleField "gateway" [t| Ip4Address |]
280 , optionalField $
281 simpleField "gateway6" [t| String |]
282 , optionalField $
283 simpleField "reservations" [t| AddressPool |]
284 , optionalField $
285 simpleField "ext_reservations" [t| AddressPool |]
286 ]
287 ++ uuidFields
288 ++ timeStampFields
289 ++ serialFields
290 ++ tagsFields)
291
292 instance SerialNoObject Network where
293 serialOf = networkSerial
294
295 instance TagsObject Network where
296 tagsOf = networkTags
297
298 instance UuidObject Network where
299 uuidOf = networkUuid
300
301 instance TimeStampObject Network where
302 cTimeOf = networkCtime
303 mTimeOf = networkMtime
304
305 -- * NIC definitions
306
307 $(buildParam "Nic" "nicp"
308 [ simpleField "mode" [t| NICMode |]
309 , simpleField "link" [t| String |]
310 , simpleField "vlan" [t| String |]
311 ])
312
313 $(buildObject "PartialNic" "nic" $
314 [ simpleField "mac" [t| String |]
315 , optionalField $ simpleField "ip" [t| String |]
316 , simpleField "nicparams" [t| PartialNicParams |]
317 , optionalField $ simpleField "network" [t| String |]
318 , optionalField $ simpleField "name" [t| String |]
319 ] ++ uuidFields)
320
321 instance UuidObject PartialNic where
322 uuidOf = nicUuid
323
324 -- * Disk definitions
325
326 -- | Constant for the dev_type key entry in the disk config.
327 devType :: String
328 devType = "dev_type"
329
330 -- | The disk parameters type.
331 type DiskParams = Container JSValue
332
333 -- | An alias for DRBD secrets
334 type DRBDSecret = String
335
336 -- Represents a group name and a volume name.
337 --
338 -- From @man lvm@:
339 --
340 -- The following characters are valid for VG and LV names: a-z A-Z 0-9 + _ . -
341 --
342 -- VG and LV names cannot begin with a hyphen. There are also various reserved
343 -- names that are used internally by lvm that can not be used as LV or VG names.
344 -- A VG cannot be called anything that exists in /dev/ at the time of
345 -- creation, nor can it be called '.' or '..'. A LV cannot be called '.' '..'
346 -- 'snapshot' or 'pvmove'. The LV name may also not contain the strings '_mlog'
347 -- or '_mimage'
348 data LogicalVolume = LogicalVolume { lvGroup :: String
349 , lvVolume :: String
350 }
351 deriving (Eq, Ord)
352
353 instance Show LogicalVolume where
354 showsPrec _ (LogicalVolume g v) =
355 showString g . showString "/" . showString v
356
357 -- | Check the constraints for a VG/LV names (except the @\/dev\/@ check).
358 instance Validatable LogicalVolume where
359 validate (LogicalVolume g v) = do
360 let vgn = "Volume group name"
361 -- Group name checks
362 nonEmpty vgn g
363 validChars vgn g
364 notStartsDash vgn g
365 notIn vgn g [".", ".."]
366 -- Volume name checks
367 let lvn = "Volume name"
368 nonEmpty lvn v
369 validChars lvn v
370 notStartsDash lvn v
371 notIn lvn v [".", "..", "snapshot", "pvmove"]
372 reportIf ("_mlog" `isInfixOf` v) $ lvn ++ " must not contain '_mlog'."
373 reportIf ("_mimage" `isInfixOf` v) $ lvn ++ "must not contain '_mimage'."
374 where
375 nonEmpty prefix x = reportIf (null x) $ prefix ++ " must be non-empty"
376 notIn prefix x =
377 mapM_ (\y -> reportIf (x == y)
378 $ prefix ++ " must not be '" ++ y ++ "'")
379 notStartsDash prefix x = reportIf ("-" `isPrefixOf` x)
380 $ prefix ++ " must not start with '-'"
381 validChars prefix x =
382 reportIf (not . all validChar $ x)
383 $ prefix ++ " must consist only of [a-z][A-Z][0-9][+_.-]"
384 validChar c = isAsciiLower c || isAsciiUpper c || isDigit c
385 || (c `elem` "+_.-")
386
387 instance J.JSON LogicalVolume where
388 showJSON = J.showJSON . show
389 readJSON (J.JSString s) | (g, _ : l) <- break (== '/') (J.fromJSString s) =
390 either fail return . evalValidate . validate' $ LogicalVolume g l
391 readJSON v = fail $ "Invalid JSON value " ++ show v
392 ++ " for a logical volume"
393
394 -- | The disk configuration type. This includes the disk type itself,
395 -- for a more complete consistency. Note that since in the Python
396 -- code-base there's no authoritative place where we document the
397 -- logical id, this is probably a good reference point.
398 data DiskLogicalId
399 = LIDPlain LogicalVolume -- ^ Volume group, logical volume
400 | LIDDrbd8 String String Int Int Int DRBDSecret
401 -- ^ NodeA, NodeB, Port, MinorA, MinorB, Secret
402 | LIDFile FileDriver String -- ^ Driver, path
403 | LIDSharedFile FileDriver String -- ^ Driver, path
404 | LIDGluster FileDriver String -- ^ Driver, path
405 | LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev)
406 | LIDRados String String -- ^ Unused, path
407 | LIDExt String String -- ^ ExtProvider, unique name
408 deriving (Show, Eq)
409
410 -- | Mapping from a logical id to a disk type.
411 lidDiskType :: DiskLogicalId -> DiskTemplate
412 lidDiskType (LIDPlain {}) = DTPlain
413 lidDiskType (LIDDrbd8 {}) = DTDrbd8
414 lidDiskType (LIDFile {}) = DTFile
415 lidDiskType (LIDSharedFile {}) = DTSharedFile
416 lidDiskType (LIDGluster {}) = DTGluster
417 lidDiskType (LIDBlockDev {}) = DTBlock
418 lidDiskType (LIDRados {}) = DTRbd
419 lidDiskType (LIDExt {}) = DTExt
420
421 -- | Builds the extra disk_type field for a given logical id.
422 lidEncodeType :: DiskLogicalId -> [(String, JSValue)]
423 lidEncodeType v = [(devType, showJSON . lidDiskType $ v)]
424
425 -- | Custom encoder for DiskLogicalId (logical id only).
426 encodeDLId :: DiskLogicalId -> JSValue
427 encodeDLId (LIDPlain (LogicalVolume vg lv)) =
428 JSArray [showJSON vg, showJSON lv]
429 encodeDLId (LIDDrbd8 nodeA nodeB port minorA minorB key) =
430 JSArray [ showJSON nodeA, showJSON nodeB, showJSON port
431 , showJSON minorA, showJSON minorB, showJSON key ]
432 encodeDLId (LIDRados pool name) = JSArray [showJSON pool, showJSON name]
433 encodeDLId (LIDFile driver name) = JSArray [showJSON driver, showJSON name]
434 encodeDLId (LIDSharedFile driver name) =
435 JSArray [showJSON driver, showJSON name]
436 encodeDLId (LIDGluster driver name) = JSArray [showJSON driver, showJSON name]
437 encodeDLId (LIDBlockDev driver name) = JSArray [showJSON driver, showJSON name]
438 encodeDLId (LIDExt extprovider name) =
439 JSArray [showJSON extprovider, showJSON name]
440
441 -- | Custom encoder for DiskLogicalId, composing both the logical id
442 -- and the extra disk_type field.
443 encodeFullDLId :: DiskLogicalId -> (JSValue, [(String, JSValue)])
444 encodeFullDLId v = (encodeDLId v, lidEncodeType v)
445
446 -- | Custom decoder for DiskLogicalId. This is manual for now, since
447 -- we don't have yet automation for separate-key style fields.
448 decodeDLId :: [(String, JSValue)] -> JSValue -> J.Result DiskLogicalId
449 decodeDLId obj lid = do
450 dtype <- fromObj obj devType
451 case dtype of
452 DTDrbd8 ->
453 case lid of
454 JSArray [nA, nB, p, mA, mB, k] -> do
455 nA' <- readJSON nA
456 nB' <- readJSON nB
457 p' <- readJSON p
458 mA' <- readJSON mA
459 mB' <- readJSON mB
460 k' <- readJSON k
461 return $ LIDDrbd8 nA' nB' p' mA' mB' k'
462 _ -> fail "Can't read logical_id for DRBD8 type"
463 DTPlain ->
464 case lid of
465 JSArray [vg, lv] -> do
466 vg' <- readJSON vg
467 lv' <- readJSON lv
468 return $ LIDPlain (LogicalVolume vg' lv')
469 _ -> fail "Can't read logical_id for plain type"
470 DTFile ->
471 case lid of
472 JSArray [driver, path] -> do
473 driver' <- readJSON driver
474 path' <- readJSON path
475 return $ LIDFile driver' path'
476 _ -> fail "Can't read logical_id for file type"
477 DTSharedFile ->
478 case lid of
479 JSArray [driver, path] -> do
480 driver' <- readJSON driver
481 path' <- readJSON path
482 return $ LIDSharedFile driver' path'
483 _ -> fail "Can't read logical_id for shared file type"
484 DTGluster ->
485 case lid of
486 JSArray [driver, path] -> do
487 driver' <- readJSON driver
488 path' <- readJSON path
489 return $ LIDGluster driver' path'
490 _ -> fail "Can't read logical_id for shared file type"
491 DTBlock ->
492 case lid of
493 JSArray [driver, path] -> do
494 driver' <- readJSON driver
495 path' <- readJSON path
496 return $ LIDBlockDev driver' path'
497 _ -> fail "Can't read logical_id for blockdev type"
498 DTRbd ->
499 case lid of
500 JSArray [driver, path] -> do
501 driver' <- readJSON driver
502 path' <- readJSON path
503 return $ LIDRados driver' path'
504 _ -> fail "Can't read logical_id for rdb type"
505 DTExt ->
506 case lid of
507 JSArray [extprovider, name] -> do
508 extprovider' <- readJSON extprovider
509 name' <- readJSON name
510 return $ LIDExt extprovider' name'
511 _ -> fail "Can't read logical_id for extstorage type"
512 DTDiskless ->
513 fail "Retrieved 'diskless' disk."
514
515 -- | Disk data structure.
516 --
517 -- This is declared manually as it's a recursive structure, and our TH
518 -- code currently can't build it.
519 data Disk = Disk
520 { diskLogicalId :: DiskLogicalId
521 , diskChildren :: [Disk]
522 , diskIvName :: String
523 , diskSize :: Int
524 , diskMode :: DiskMode
525 , diskName :: Maybe String
526 , diskSpindles :: Maybe Int
527 , diskParams :: Maybe DiskParams
528 , diskUuid :: String
529 , diskSerial :: Int
530 , diskCtime :: ClockTime
531 , diskMtime :: ClockTime
532 } deriving (Show, Eq)
533
534 $(buildObjectSerialisation "Disk" $
535 [ customField 'decodeDLId 'encodeFullDLId ["dev_type"] $
536 simpleField "logical_id" [t| DiskLogicalId |]
537 , defaultField [| [] |] $ simpleField "children" [t| [Disk] |]
538 , defaultField [| "" |] $ simpleField "iv_name" [t| String |]
539 , simpleField "size" [t| Int |]
540 , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
541 , optionalField $ simpleField "name" [t| String |]
542 , optionalField $ simpleField "spindles" [t| Int |]
543 , optionalField $ simpleField "params" [t| DiskParams |]
544 ]
545 ++ uuidFields
546 ++ serialFields
547 ++ timeStampFields)
548
549 instance UuidObject Disk where
550 uuidOf = diskUuid
551
552 -- | Determines whether a disk or one of his children has the given logical id
553 -- (determined by the volume group name and by the logical volume name).
554 -- This can be true only for DRBD or LVM disks.
555 includesLogicalId :: LogicalVolume -> Disk -> Bool
556 includesLogicalId lv disk =
557 case diskLogicalId disk of
558 LIDPlain lv' -> lv' == lv
559 LIDDrbd8 {} ->
560 any (includesLogicalId lv) $ diskChildren disk
561 _ -> False
562
563 -- * Instance definitions
564
565 $(buildParam "Be" "bep"
566 [ specialNumericalField 'parseUnitAssumeBinary
567 $ simpleField "minmem" [t| Int |]
568 , specialNumericalField 'parseUnitAssumeBinary
569 $ simpleField "maxmem" [t| Int |]
570 , simpleField "vcpus" [t| Int |]
571 , simpleField "auto_balance" [t| Bool |]
572 , simpleField "always_failover" [t| Bool |]
573 , simpleField "spindle_use" [t| Int |]
574 ])
575
576 $(buildObject "Instance" "inst" $
577 [ simpleField "name" [t| String |]
578 , simpleField "primary_node" [t| String |]
579 , simpleField "os" [t| String |]
580 , simpleField "hypervisor" [t| Hypervisor |]
581 , simpleField "hvparams" [t| HvParams |]
582 , simpleField "beparams" [t| PartialBeParams |]
583 , simpleField "osparams" [t| OsParams |]
584 , simpleField "osparams_private" [t| OsParamsPrivate |]
585 , simpleField "admin_state" [t| AdminState |]
586 , simpleField "admin_state_source" [t| AdminStateSource |]
587 , simpleField "nics" [t| [PartialNic] |]
588 , simpleField "disks" [t| [String] |]
589 , simpleField "disk_template" [t| DiskTemplate |]
590 , simpleField "disks_active" [t| Bool |]
591 , optionalField $ simpleField "network_port" [t| Int |]
592 ]
593 ++ timeStampFields
594 ++ uuidFields
595 ++ serialFields
596 ++ tagsFields)
597
598 instance TimeStampObject Instance where
599 cTimeOf = instCtime
600 mTimeOf = instMtime
601
602 instance UuidObject Instance where
603 uuidOf = instUuid
604
605 instance SerialNoObject Instance where
606 serialOf = instSerial
607
608 instance TagsObject Instance where
609 tagsOf = instTags
610
611 -- * IPolicy definitions
612
613 $(buildParam "ISpec" "ispec"
614 [ simpleField ConstantUtils.ispecMemSize [t| Int |]
615 , simpleField ConstantUtils.ispecDiskSize [t| Int |]
616 , simpleField ConstantUtils.ispecDiskCount [t| Int |]
617 , simpleField ConstantUtils.ispecCpuCount [t| Int |]
618 , simpleField ConstantUtils.ispecNicCount [t| Int |]
619 , simpleField ConstantUtils.ispecSpindleUse [t| Int |]
620 ])
621
622 $(buildObject "MinMaxISpecs" "mmis"
623 [ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |]
624 , renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |]
625 ])
626
627 -- | Custom partial ipolicy. This is not built via buildParam since it
628 -- has a special 2-level inheritance mode.
629 $(buildObject "PartialIPolicy" "ipolicy"
630 [ optionalField . renameField "MinMaxISpecsP" $
631 simpleField ConstantUtils.ispecsMinmax [t| [MinMaxISpecs] |]
632 , optionalField . renameField "StdSpecP" $
633 simpleField "std" [t| PartialISpecParams |]
634 , optionalField . renameField "SpindleRatioP" $
635 simpleField "spindle-ratio" [t| Double |]
636 , optionalField . renameField "VcpuRatioP" $
637 simpleField "vcpu-ratio" [t| Double |]
638 , optionalField . renameField "DiskTemplatesP" $
639 simpleField "disk-templates" [t| [DiskTemplate] |]
640 ])
641
642 -- | Custom filled ipolicy. This is not built via buildParam since it
643 -- has a special 2-level inheritance mode.
644 $(buildObject "FilledIPolicy" "ipolicy"
645 [ renameField "MinMaxISpecs" $
646 simpleField ConstantUtils.ispecsMinmax [t| [MinMaxISpecs] |]
647 , renameField "StdSpec" $ simpleField "std" [t| FilledISpecParams |]
648 , simpleField "spindle-ratio" [t| Double |]
649 , simpleField "vcpu-ratio" [t| Double |]
650 , simpleField "disk-templates" [t| [DiskTemplate] |]
651 ])
652
653 -- | Custom filler for the ipolicy types.
654 fillIPolicy :: FilledIPolicy -> PartialIPolicy -> FilledIPolicy
655 fillIPolicy (FilledIPolicy { ipolicyMinMaxISpecs = fminmax
656 , ipolicyStdSpec = fstd
657 , ipolicySpindleRatio = fspindleRatio
658 , ipolicyVcpuRatio = fvcpuRatio
659 , ipolicyDiskTemplates = fdiskTemplates})
660 (PartialIPolicy { ipolicyMinMaxISpecsP = pminmax
661 , ipolicyStdSpecP = pstd
662 , ipolicySpindleRatioP = pspindleRatio
663 , ipolicyVcpuRatioP = pvcpuRatio
664 , ipolicyDiskTemplatesP = pdiskTemplates}) =
665 FilledIPolicy { ipolicyMinMaxISpecs = fromMaybe fminmax pminmax
666 , ipolicyStdSpec = case pstd of
667 Nothing -> fstd
668 Just p -> fillISpecParams fstd p
669 , ipolicySpindleRatio = fromMaybe fspindleRatio pspindleRatio
670 , ipolicyVcpuRatio = fromMaybe fvcpuRatio pvcpuRatio
671 , ipolicyDiskTemplates = fromMaybe fdiskTemplates
672 pdiskTemplates
673 }
674 -- * Node definitions
675
676 $(buildParam "ND" "ndp"
677 [ simpleField "oob_program" [t| String |]
678 , simpleField "spindle_count" [t| Int |]
679 , simpleField "exclusive_storage" [t| Bool |]
680 , simpleField "ovs" [t| Bool |]
681 , simpleField "ovs_name" [t| String |]
682 , simpleField "ovs_link" [t| String |]
683 , simpleField "ssh_port" [t| Int |]
684 , simpleField "cpu_speed" [t| Double |]
685 ])
686
687 $(buildObject "Node" "node" $
688 [ simpleField "name" [t| String |]
689 , simpleField "primary_ip" [t| String |]
690 , simpleField "secondary_ip" [t| String |]
691 , simpleField "master_candidate" [t| Bool |]
692 , simpleField "offline" [t| Bool |]
693 , simpleField "drained" [t| Bool |]
694 , simpleField "group" [t| String |]
695 , simpleField "master_capable" [t| Bool |]
696 , simpleField "vm_capable" [t| Bool |]
697 , simpleField "ndparams" [t| PartialNDParams |]
698 , simpleField "powered" [t| Bool |]
699 ]
700 ++ timeStampFields
701 ++ uuidFields
702 ++ serialFields
703 ++ tagsFields)
704
705 instance TimeStampObject Node where
706 cTimeOf = nodeCtime
707 mTimeOf = nodeMtime
708
709 instance UuidObject Node where
710 uuidOf = nodeUuid
711
712 instance SerialNoObject Node where
713 serialOf = nodeSerial
714
715 instance TagsObject Node where
716 tagsOf = nodeTags
717
718 -- * NodeGroup definitions
719
720 -- | The cluster/group disk parameters type.
721 type GroupDiskParams = Container DiskParams
722
723 -- | A mapping from network UUIDs to nic params of the networks.
724 type Networks = Container PartialNicParams
725
726 $(buildObject "NodeGroup" "group" $
727 [ simpleField "name" [t| String |]
728 , defaultField [| [] |] $ simpleField "members" [t| [String] |]
729 , simpleField "ndparams" [t| PartialNDParams |]
730 , simpleField "alloc_policy" [t| AllocPolicy |]
731 , simpleField "ipolicy" [t| PartialIPolicy |]
732 , simpleField "diskparams" [t| GroupDiskParams |]
733 , simpleField "networks" [t| Networks |]
734 ]
735 ++ timeStampFields
736 ++ uuidFields
737 ++ serialFields
738 ++ tagsFields)
739
740 instance TimeStampObject NodeGroup where
741 cTimeOf = groupCtime
742 mTimeOf = groupMtime
743
744 instance UuidObject NodeGroup where
745 uuidOf = groupUuid
746
747 instance SerialNoObject NodeGroup where
748 serialOf = groupSerial
749
750 instance TagsObject NodeGroup where
751 tagsOf = groupTags
752
753 -- | IP family type
754 $(declareIADT "IpFamily"
755 [ ("IpFamilyV4", 'AutoConf.pyAfInet4)
756 , ("IpFamilyV6", 'AutoConf.pyAfInet6)
757 ])
758 $(makeJSONInstance ''IpFamily)
759
760 -- | Conversion from IP family to IP version. This is needed because
761 -- Python uses both, depending on context.
762 ipFamilyToVersion :: IpFamily -> Int
763 ipFamilyToVersion IpFamilyV4 = C.ip4Version
764 ipFamilyToVersion IpFamilyV6 = C.ip6Version
765
766 -- | Cluster HvParams (hvtype to hvparams mapping).
767 type ClusterHvParams = GenericContainer Hypervisor HvParams
768
769 -- | Cluster Os-HvParams (os to hvparams mapping).
770 type OsHvParams = Container ClusterHvParams
771
772 -- | Cluser BeParams.
773 type ClusterBeParams = Container FilledBeParams
774
775 -- | Cluster OsParams.
776 type ClusterOsParams = Container OsParams
777 type ClusterOsParamsPrivate = Container (Private OsParams)
778
779 -- | Cluster NicParams.
780 type ClusterNicParams = Container FilledNicParams
781
782 -- | A low-high UID ranges.
783 type UidRange = (Int, Int)
784
785 formatUidRange :: UidRange -> String
786 formatUidRange (lower, higher)
787 | lower == higher = show lower
788 | otherwise = show lower ++ "-" ++ show higher
789
790 -- | Cluster UID Pool, list (low, high) UID ranges.
791 type UidPool = [UidRange]
792
793 -- | The iallocator parameters type.
794 type IAllocatorParams = Container JSValue
795
796 -- | The master candidate client certificate digests
797 type CandidateCertificates = Container String
798
799 -- | Disk state parameters.
800 --
801 -- As according to the documentation this option is unused by Ganeti,
802 -- the content is just a 'JSValue'.
803 type DiskState = Container JSValue
804
805 -- | Hypervisor state parameters.
806 --
807 -- As according to the documentation this option is unused by Ganeti,
808 -- the content is just a 'JSValue'.
809 type HypervisorState = Container JSValue
810
811 -- * Cluster definitions
812 $(buildObject "Cluster" "cluster" $
813 [ simpleField "rsahostkeypub" [t| String |]
814 , optionalField $
815 simpleField "dsahostkeypub" [t| String |]
816 , simpleField "highest_used_port" [t| Int |]
817 , simpleField "tcpudp_port_pool" [t| [Int] |]
818 , simpleField "mac_prefix" [t| String |]
819 , optionalField $
820 simpleField "volume_group_name" [t| String |]
821 , simpleField "reserved_lvs" [t| [String] |]
822 , optionalField $
823 simpleField "drbd_usermode_helper" [t| String |]
824 , simpleField "master_node" [t| String |]
825 , simpleField "master_ip" [t| String |]
826 , simpleField "master_netdev" [t| String |]
827 , simpleField "master_netmask" [t| Int |]
828 , simpleField "use_external_mip_script" [t| Bool |]
829 , simpleField "cluster_name" [t| String |]
830 , simpleField "file_storage_dir" [t| String |]
831 , simpleField "shared_file_storage_dir" [t| String |]
832 , simpleField "gluster_storage_dir" [t| String |]
833 , simpleField "enabled_hypervisors" [t| [Hypervisor] |]
834 , simpleField "hvparams" [t| ClusterHvParams |]
835 , simpleField "os_hvp" [t| OsHvParams |]
836 , simpleField "beparams" [t| ClusterBeParams |]
837 , simpleField "osparams" [t| ClusterOsParams |]
838 , simpleField "osparams_private_cluster" [t| ClusterOsParamsPrivate |]
839 , simpleField "nicparams" [t| ClusterNicParams |]
840 , simpleField "ndparams" [t| FilledNDParams |]
841 , simpleField "diskparams" [t| GroupDiskParams |]
842 , simpleField "candidate_pool_size" [t| Int |]
843 , simpleField "modify_etc_hosts" [t| Bool |]
844 , simpleField "modify_ssh_setup" [t| Bool |]
845 , simpleField "maintain_node_health" [t| Bool |]
846 , simpleField "uid_pool" [t| UidPool |]
847 , simpleField "default_iallocator" [t| String |]
848 , simpleField "default_iallocator_params" [t| IAllocatorParams |]
849 , simpleField "hidden_os" [t| [String] |]
850 , simpleField "blacklisted_os" [t| [String] |]
851 , simpleField "primary_ip_family" [t| IpFamily |]
852 , simpleField "prealloc_wipe_disks" [t| Bool |]
853 , simpleField "ipolicy" [t| FilledIPolicy |]
854 , defaultField [| emptyContainer |] $
855 simpleField "hv_state_static" [t| HypervisorState |]
856 , defaultField [| emptyContainer |] $
857 simpleField "disk_state_static" [t| DiskState |]
858 , simpleField "enabled_disk_templates" [t| [DiskTemplate] |]
859 , simpleField "candidate_certs" [t| CandidateCertificates |]
860 , simpleField "max_running_jobs" [t| Int |]
861 , simpleField "max_tracked_jobs" [t| Int |]
862 , simpleField "install_image" [t| String |]
863 , simpleField "instance_communication_network" [t| String |]
864 , simpleField "zeroing_image" [t| String |]
865 , simpleField "compression_tools" [t| [String] |]
866 , simpleField "enabled_user_shutdown" [t| Bool |]
867 ]
868 ++ timeStampFields
869 ++ uuidFields
870 ++ serialFields
871 ++ tagsFields)
872
873 instance TimeStampObject Cluster where
874 cTimeOf = clusterCtime
875 mTimeOf = clusterMtime
876
877 instance UuidObject Cluster where
878 uuidOf = clusterUuid
879
880 instance SerialNoObject Cluster where
881 serialOf = clusterSerial
882
883 instance TagsObject Cluster where
884 tagsOf = clusterTags
885
886 -- * ConfigData definitions
887
888 $(buildObject "ConfigData" "config" $
889 -- timeStampFields ++
890 [ simpleField "version" [t| Int |]
891 , simpleField "cluster" [t| Cluster |]
892 , simpleField "nodes" [t| Container Node |]
893 , simpleField "nodegroups" [t| Container NodeGroup |]
894 , simpleField "instances" [t| Container Instance |]
895 , simpleField "networks" [t| Container Network |]
896 , simpleField "disks" [t| Container Disk |]
897 ]
898 ++ timeStampFields
899 ++ serialFields)
900
901 instance SerialNoObject ConfigData where
902 serialOf = configSerial
903
904 instance TimeStampObject ConfigData where
905 cTimeOf = configCtime
906 mTimeOf = configMtime
907
908 -- * Master network parameters
909
910 $(buildObject "MasterNetworkParameters" "masterNetworkParameters"
911 [ simpleField "uuid" [t| String |]
912 , simpleField "ip" [t| String |]
913 , simpleField "netmask" [t| Int |]
914 , simpleField "netdev" [t| String |]
915 , simpleField "ip_family" [t| IpFamily |]
916 ])
917