Fix inconsistency in python and haskell objects
[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 -- | Disk state parameters.
688 --
689 -- As according to the documentation this option is unused by Ganeti,
690 -- the content is just a 'JSValue'.
691 type DiskState = Container JSValue
692
693 -- | Hypervisor state parameters.
694 --
695 -- As according to the documentation this option is unused by Ganeti,
696 -- the content is just a 'JSValue'.
697 type HypervisorState = Container JSValue
698
699 $(buildObject "Node" "node" $
700 [ simpleField "name" [t| String |]
701 , simpleField "primary_ip" [t| String |]
702 , simpleField "secondary_ip" [t| String |]
703 , simpleField "master_candidate" [t| Bool |]
704 , simpleField "offline" [t| Bool |]
705 , simpleField "drained" [t| Bool |]
706 , simpleField "group" [t| String |]
707 , simpleField "master_capable" [t| Bool |]
708 , simpleField "vm_capable" [t| Bool |]
709 , simpleField "ndparams" [t| PartialNDParams |]
710 , simpleField "powered" [t| Bool |]
711 , notSerializeDefaultField [| emptyContainer |] $
712 simpleField "hv_state_static" [t| HypervisorState |]
713 , notSerializeDefaultField [| emptyContainer |] $
714 simpleField "disk_state_static" [t| DiskState |]
715 ]
716 ++ timeStampFields
717 ++ uuidFields
718 ++ serialFields
719 ++ tagsFields)
720
721 instance TimeStampObject Node where
722 cTimeOf = nodeCtime
723 mTimeOf = nodeMtime
724
725 instance UuidObject Node where
726 uuidOf = nodeUuid
727
728 instance SerialNoObject Node where
729 serialOf = nodeSerial
730
731 instance TagsObject Node where
732 tagsOf = nodeTags
733
734 -- * NodeGroup definitions
735
736 -- | The cluster/group disk parameters type.
737 type GroupDiskParams = Container DiskParams
738
739 -- | A mapping from network UUIDs to nic params of the networks.
740 type Networks = Container PartialNicParams
741
742 $(buildObject "NodeGroup" "group" $
743 [ simpleField "name" [t| String |]
744 , defaultField [| [] |] $ simpleField "members" [t| [String] |]
745 , simpleField "ndparams" [t| PartialNDParams |]
746 , simpleField "alloc_policy" [t| AllocPolicy |]
747 , simpleField "ipolicy" [t| PartialIPolicy |]
748 , simpleField "diskparams" [t| GroupDiskParams |]
749 , simpleField "networks" [t| Networks |]
750 , notSerializeDefaultField [| emptyContainer |] $
751 simpleField "hv_state_static" [t| HypervisorState |]
752 , notSerializeDefaultField [| emptyContainer |] $
753 simpleField "disk_state_static" [t| DiskState |]
754 ]
755 ++ timeStampFields
756 ++ uuidFields
757 ++ serialFields
758 ++ tagsFields)
759
760 instance TimeStampObject NodeGroup where
761 cTimeOf = groupCtime
762 mTimeOf = groupMtime
763
764 instance UuidObject NodeGroup where
765 uuidOf = groupUuid
766
767 instance SerialNoObject NodeGroup where
768 serialOf = groupSerial
769
770 instance TagsObject NodeGroup where
771 tagsOf = groupTags
772
773 -- | IP family type
774 $(declareIADT "IpFamily"
775 [ ("IpFamilyV4", 'AutoConf.pyAfInet4)
776 , ("IpFamilyV6", 'AutoConf.pyAfInet6)
777 ])
778 $(makeJSONInstance ''IpFamily)
779
780 -- | Conversion from IP family to IP version. This is needed because
781 -- Python uses both, depending on context.
782 ipFamilyToVersion :: IpFamily -> Int
783 ipFamilyToVersion IpFamilyV4 = C.ip4Version
784 ipFamilyToVersion IpFamilyV6 = C.ip6Version
785
786 -- | Cluster HvParams (hvtype to hvparams mapping).
787 type ClusterHvParams = GenericContainer Hypervisor HvParams
788
789 -- | Cluster Os-HvParams (os to hvparams mapping).
790 type OsHvParams = Container ClusterHvParams
791
792 -- | Cluser BeParams.
793 type ClusterBeParams = Container FilledBeParams
794
795 -- | Cluster OsParams.
796 type ClusterOsParams = Container OsParams
797 type ClusterOsParamsPrivate = Container (Private OsParams)
798
799 -- | Cluster NicParams.
800 type ClusterNicParams = Container FilledNicParams
801
802 -- | A low-high UID ranges.
803 type UidRange = (Int, Int)
804
805 formatUidRange :: UidRange -> String
806 formatUidRange (lower, higher)
807 | lower == higher = show lower
808 | otherwise = show lower ++ "-" ++ show higher
809
810 -- | Cluster UID Pool, list (low, high) UID ranges.
811 type UidPool = [UidRange]
812
813 -- | The iallocator parameters type.
814 type IAllocatorParams = Container JSValue
815
816 -- | The master candidate client certificate digests
817 type CandidateCertificates = Container String
818
819 -- * Cluster definitions
820 $(buildObject "Cluster" "cluster" $
821 [ simpleField "rsahostkeypub" [t| String |]
822 , optionalField $
823 simpleField "dsahostkeypub" [t| String |]
824 , simpleField "highest_used_port" [t| Int |]
825 , simpleField "tcpudp_port_pool" [t| [Int] |]
826 , simpleField "mac_prefix" [t| String |]
827 , optionalField $
828 simpleField "volume_group_name" [t| String |]
829 , simpleField "reserved_lvs" [t| [String] |]
830 , optionalField $
831 simpleField "drbd_usermode_helper" [t| String |]
832 , simpleField "master_node" [t| String |]
833 , simpleField "master_ip" [t| String |]
834 , simpleField "master_netdev" [t| String |]
835 , simpleField "master_netmask" [t| Int |]
836 , simpleField "use_external_mip_script" [t| Bool |]
837 , simpleField "cluster_name" [t| String |]
838 , simpleField "file_storage_dir" [t| String |]
839 , simpleField "shared_file_storage_dir" [t| String |]
840 , simpleField "gluster_storage_dir" [t| String |]
841 , simpleField "enabled_hypervisors" [t| [Hypervisor] |]
842 , simpleField "hvparams" [t| ClusterHvParams |]
843 , simpleField "os_hvp" [t| OsHvParams |]
844 , simpleField "beparams" [t| ClusterBeParams |]
845 , simpleField "osparams" [t| ClusterOsParams |]
846 , simpleField "osparams_private_cluster" [t| ClusterOsParamsPrivate |]
847 , simpleField "nicparams" [t| ClusterNicParams |]
848 , simpleField "ndparams" [t| FilledNDParams |]
849 , simpleField "diskparams" [t| GroupDiskParams |]
850 , simpleField "candidate_pool_size" [t| Int |]
851 , simpleField "modify_etc_hosts" [t| Bool |]
852 , simpleField "modify_ssh_setup" [t| Bool |]
853 , simpleField "maintain_node_health" [t| Bool |]
854 , simpleField "uid_pool" [t| UidPool |]
855 , simpleField "default_iallocator" [t| String |]
856 , simpleField "default_iallocator_params" [t| IAllocatorParams |]
857 , simpleField "hidden_os" [t| [String] |]
858 , simpleField "blacklisted_os" [t| [String] |]
859 , simpleField "primary_ip_family" [t| IpFamily |]
860 , simpleField "prealloc_wipe_disks" [t| Bool |]
861 , simpleField "ipolicy" [t| FilledIPolicy |]
862 , defaultField [| emptyContainer |] $
863 simpleField "hv_state_static" [t| HypervisorState |]
864 , defaultField [| emptyContainer |] $
865 simpleField "disk_state_static" [t| DiskState |]
866 , simpleField "enabled_disk_templates" [t| [DiskTemplate] |]
867 , simpleField "candidate_certs" [t| CandidateCertificates |]
868 , simpleField "max_running_jobs" [t| Int |]
869 , simpleField "max_tracked_jobs" [t| Int |]
870 , simpleField "install_image" [t| String |]
871 , simpleField "instance_communication_network" [t| String |]
872 , simpleField "zeroing_image" [t| String |]
873 , simpleField "compression_tools" [t| [String] |]
874 , simpleField "enabled_user_shutdown" [t| Bool |]
875 ]
876 ++ timeStampFields
877 ++ uuidFields
878 ++ serialFields
879 ++ tagsFields)
880
881 instance TimeStampObject Cluster where
882 cTimeOf = clusterCtime
883 mTimeOf = clusterMtime
884
885 instance UuidObject Cluster where
886 uuidOf = clusterUuid
887
888 instance SerialNoObject Cluster where
889 serialOf = clusterSerial
890
891 instance TagsObject Cluster where
892 tagsOf = clusterTags
893
894 -- * ConfigData definitions
895
896 $(buildObject "ConfigData" "config" $
897 -- timeStampFields ++
898 [ simpleField "version" [t| Int |]
899 , simpleField "cluster" [t| Cluster |]
900 , simpleField "nodes" [t| Container Node |]
901 , simpleField "nodegroups" [t| Container NodeGroup |]
902 , simpleField "instances" [t| Container Instance |]
903 , simpleField "networks" [t| Container Network |]
904 , simpleField "disks" [t| Container Disk |]
905 ]
906 ++ timeStampFields
907 ++ serialFields)
908
909 instance SerialNoObject ConfigData where
910 serialOf = configSerial
911
912 instance TimeStampObject ConfigData where
913 cTimeOf = configCtime
914 mTimeOf = configMtime
915
916 -- * Master network parameters
917
918 $(buildObject "MasterNetworkParameters" "masterNetworkParameters"
919 [ simpleField "uuid" [t| String |]
920 , simpleField "ip" [t| String |]
921 , simpleField "netmask" [t| Int |]
922 , simpleField "netdev" [t| String |]
923 , simpleField "ip_family" [t| IpFamily |]
924 ])
925