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