Renew-crypto: stop daemons on master node first
[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 $(buildObject "Node" "node" $
715 [ simpleField "name" [t| String |]
716 , simpleField "primary_ip" [t| String |]
717 , simpleField "secondary_ip" [t| String |]
718 , simpleField "master_candidate" [t| Bool |]
719 , simpleField "offline" [t| Bool |]
720 , simpleField "drained" [t| Bool |]
721 , simpleField "group" [t| String |]
722 , simpleField "master_capable" [t| Bool |]
723 , simpleField "vm_capable" [t| Bool |]
724 , simpleField "ndparams" [t| PartialNDParams |]
725 , simpleField "powered" [t| Bool |]
726 ]
727 ++ timeStampFields
728 ++ uuidFields
729 ++ serialFields
730 ++ tagsFields)
731
732 instance TimeStampObject Node where
733 cTimeOf = nodeCtime
734 mTimeOf = nodeMtime
735
736 instance UuidObject Node where
737 uuidOf = nodeUuid
738
739 instance SerialNoObject Node where
740 serialOf = nodeSerial
741
742 instance TagsObject Node where
743 tagsOf = nodeTags
744
745 -- * NodeGroup definitions
746
747 -- | The cluster/group disk parameters type.
748 type GroupDiskParams = Container DiskParams
749
750 -- | A mapping from network UUIDs to nic params of the networks.
751 type Networks = Container PartialNicParams
752
753 $(buildObject "NodeGroup" "group" $
754 [ simpleField "name" [t| String |]
755 , defaultField [| [] |] $ simpleField "members" [t| [String] |]
756 , simpleField "ndparams" [t| PartialNDParams |]
757 , simpleField "alloc_policy" [t| AllocPolicy |]
758 , simpleField "ipolicy" [t| PartialIPolicy |]
759 , simpleField "diskparams" [t| GroupDiskParams |]
760 , simpleField "networks" [t| Networks |]
761 ]
762 ++ timeStampFields
763 ++ uuidFields
764 ++ serialFields
765 ++ tagsFields)
766
767 instance TimeStampObject NodeGroup where
768 cTimeOf = groupCtime
769 mTimeOf = groupMtime
770
771 instance UuidObject NodeGroup where
772 uuidOf = groupUuid
773
774 instance SerialNoObject NodeGroup where
775 serialOf = groupSerial
776
777 instance TagsObject NodeGroup where
778 tagsOf = groupTags
779
780 -- * Job scheduler filtering definitions
781
782 -- | Actions that can be performed when a filter matches.
783 data FilterAction
784 = Accept
785 | Pause
786 | Reject
787 | Continue
788 | RateLimit Int
789 deriving (Eq, Ord, Show)
790
791 instance JSON FilterAction where
792 showJSON fa = case fa of
793 Accept -> JSString (toJSString "ACCEPT")
794 Pause -> JSString (toJSString "PAUSE")
795 Reject -> JSString (toJSString "REJECT")
796 Continue -> JSString (toJSString "CONTINUE")
797 RateLimit n -> JSArray [ JSString (toJSString "RATE_LIMIT")
798 , JSRational False (fromIntegral n)
799 ]
800 readJSON v = case v of
801 -- `FilterAction`s are case-sensitive.
802 JSString s | fromJSString s == "ACCEPT" -> return Accept
803 JSString s | fromJSString s == "PAUSE" -> return Pause
804 JSString s | fromJSString s == "REJECT" -> return Reject
805 JSString s | fromJSString s == "CONTINUE" -> return Continue
806 JSArray (JSString s : rest) | fromJSString s == "RATE_LIMIT" ->
807 case rest of
808 [JSRational False n] | denominator n == 1 && numerator n > 0 ->
809 return . RateLimit . fromIntegral $ numerator n
810 _ -> fail "RATE_LIMIT argument must be a positive integer"
811 x -> fail $ "malformed FilterAction JSON: " ++ J.showJSValue x ""
812
813
814 data FilterPredicate
815 = FPJobId (Filter FilterField)
816 | FPOpCode (Filter FilterField)
817 | FPReason (Filter FilterField)
818 deriving (Eq, Ord, Show)
819
820
821 instance JSON FilterPredicate where
822 showJSON fp = case fp of
823 FPJobId expr -> JSArray [string "jobid", showJSON expr]
824 FPOpCode expr -> JSArray [string "opcode", showJSON expr]
825 FPReason expr -> JSArray [string "reason", showJSON expr]
826 where
827 string = JSString . toJSString
828
829 readJSON v = case v of
830 -- Predicate names are case-sensitive.
831 JSArray [JSString name, expr]
832 | name == toJSString "jobid" -> FPJobId <$> readJSON expr
833 | name == toJSString "opcode" -> FPOpCode <$> readJSON expr
834 | name == toJSString "reason" -> FPReason <$> readJSON expr
835 JSArray (JSString name:params) ->
836 fail $ "malformed FilterPredicate: bad parameter list for\
837 \ '" ++ fromJSString name ++ "' predicate: "
838 ++ J.showJSArray params ""
839 _ -> fail "malformed FilterPredicate: must be a list with the first\
840 \ entry being a string describing the predicate type"
841
842
843 $(buildObject "FilterRule" "fr" $
844 [ simpleField "watermark" [t| JobId |]
845 , simpleField "priority" [t| NonNegative Int |]
846 , simpleField "predicates" [t| [FilterPredicate] |]
847 , simpleField "action" [t| FilterAction |]
848 , simpleField "reason_trail" [t| ReasonTrail |]
849 ]
850 ++ uuidFields)
851
852 instance UuidObject FilterRule where
853 uuidOf = frUuid
854
855
856 -- | Order in which filter rules are evaluated, according to
857 -- `doc/design-optables.rst`.
858 -- For `FilterRule` fields not specified as important for the order,
859 -- we choose an arbitrary ordering effect (after the ones from the spec).
860 --
861 -- The `Ord` instance for `FilterRule` agrees with this function.
862 -- Yet it is recommended to use this function instead of `compare` to be
863 -- explicit that the spec order is used.
864 filterRuleOrder :: FilterRule -> FilterRule -> Ordering
865 filterRuleOrder = compare
866
867
868 instance Ord FilterRule where
869 -- It is important that the Ord instance respects the ordering given in
870 -- `doc/design-optables.rst` for the fields defined in there. The other
871 -- fields may be ordered arbitrarily.
872 -- Use `filterRuleOrder` when relying on the spec order.
873 compare =
874 comparing $ \(FilterRule watermark prio predicates action reason uuid) ->
875 ( prio, watermark, uuid -- spec part
876 , predicates, action, reason -- arbitrary part
877 )
878
879
880 -- | IP family type
881 $(declareIADT "IpFamily"
882 [ ("IpFamilyV4", 'AutoConf.pyAfInet4)
883 , ("IpFamilyV6", 'AutoConf.pyAfInet6)
884 ])
885 $(makeJSONInstance ''IpFamily)
886
887 -- | Conversion from IP family to IP version. This is needed because
888 -- Python uses both, depending on context.
889 ipFamilyToVersion :: IpFamily -> Int
890 ipFamilyToVersion IpFamilyV4 = C.ip4Version
891 ipFamilyToVersion IpFamilyV6 = C.ip6Version
892
893 -- | Cluster HvParams (hvtype to hvparams mapping).
894 type ClusterHvParams = GenericContainer Hypervisor HvParams
895
896 -- | Cluster Os-HvParams (os to hvparams mapping).
897 type OsHvParams = Container ClusterHvParams
898
899 -- | Cluser BeParams.
900 type ClusterBeParams = Container FilledBeParams
901
902 -- | Cluster OsParams.
903 type ClusterOsParams = Container OsParams
904 type ClusterOsParamsPrivate = Container (Private OsParams)
905
906 -- | Cluster NicParams.
907 type ClusterNicParams = Container FilledNicParams
908
909 -- | A low-high UID ranges.
910 type UidRange = (Int, Int)
911
912 formatUidRange :: UidRange -> String
913 formatUidRange (lower, higher)
914 | lower == higher = show lower
915 | otherwise = show lower ++ "-" ++ show higher
916
917 -- | Cluster UID Pool, list (low, high) UID ranges.
918 type UidPool = [UidRange]
919
920 -- | The iallocator parameters type.
921 type IAllocatorParams = Container JSValue
922
923 -- | The master candidate client certificate digests
924 type CandidateCertificates = Container String
925
926 -- | Disk state parameters.
927 --
928 -- As according to the documentation this option is unused by Ganeti,
929 -- the content is just a 'JSValue'.
930 type DiskState = Container JSValue
931
932 -- | Hypervisor state parameters.
933 --
934 -- As according to the documentation this option is unused by Ganeti,
935 -- the content is just a 'JSValue'.
936 type HypervisorState = Container JSValue
937
938 -- * Cluster definitions
939 $(buildObject "Cluster" "cluster" $
940 [ simpleField "rsahostkeypub" [t| String |]
941 , optionalField $
942 simpleField "dsahostkeypub" [t| String |]
943 , simpleField "highest_used_port" [t| Int |]
944 , simpleField "tcpudp_port_pool" [t| [Int] |]
945 , simpleField "mac_prefix" [t| String |]
946 , optionalField $
947 simpleField "volume_group_name" [t| String |]
948 , simpleField "reserved_lvs" [t| [String] |]
949 , optionalField $
950 simpleField "drbd_usermode_helper" [t| String |]
951 , simpleField "master_node" [t| String |]
952 , simpleField "master_ip" [t| String |]
953 , simpleField "master_netdev" [t| String |]
954 , simpleField "master_netmask" [t| Int |]
955 , simpleField "use_external_mip_script" [t| Bool |]
956 , simpleField "cluster_name" [t| String |]
957 , simpleField "file_storage_dir" [t| String |]
958 , simpleField "shared_file_storage_dir" [t| String |]
959 , simpleField "gluster_storage_dir" [t| String |]
960 , simpleField "enabled_hypervisors" [t| [Hypervisor] |]
961 , simpleField "hvparams" [t| ClusterHvParams |]
962 , simpleField "os_hvp" [t| OsHvParams |]
963 , simpleField "beparams" [t| ClusterBeParams |]
964 , simpleField "osparams" [t| ClusterOsParams |]
965 , simpleField "osparams_private_cluster" [t| ClusterOsParamsPrivate |]
966 , simpleField "nicparams" [t| ClusterNicParams |]
967 , simpleField "ndparams" [t| FilledNDParams |]
968 , simpleField "diskparams" [t| GroupDiskParams |]
969 , simpleField "candidate_pool_size" [t| Int |]
970 , simpleField "modify_etc_hosts" [t| Bool |]
971 , simpleField "modify_ssh_setup" [t| Bool |]
972 , simpleField "maintain_node_health" [t| Bool |]
973 , simpleField "uid_pool" [t| UidPool |]
974 , simpleField "default_iallocator" [t| String |]
975 , simpleField "default_iallocator_params" [t| IAllocatorParams |]
976 , simpleField "hidden_os" [t| [String] |]
977 , simpleField "blacklisted_os" [t| [String] |]
978 , simpleField "primary_ip_family" [t| IpFamily |]
979 , simpleField "prealloc_wipe_disks" [t| Bool |]
980 , simpleField "ipolicy" [t| FilledIPolicy |]
981 , defaultField [| emptyContainer |] $
982 simpleField "hv_state_static" [t| HypervisorState |]
983 , defaultField [| emptyContainer |] $
984 simpleField "disk_state_static" [t| DiskState |]
985 , simpleField "enabled_disk_templates" [t| [DiskTemplate] |]
986 , simpleField "candidate_certs" [t| CandidateCertificates |]
987 , simpleField "max_running_jobs" [t| Int |]
988 , simpleField "max_tracked_jobs" [t| Int |]
989 , simpleField "install_image" [t| String |]
990 , simpleField "instance_communication_network" [t| String |]
991 , simpleField "zeroing_image" [t| String |]
992 , simpleField "compression_tools" [t| [String] |]
993 , simpleField "enabled_user_shutdown" [t| Bool |]
994 , simpleField "data_collectors" [t| Container DataCollectorConfig |]
995 ]
996 ++ timeStampFields
997 ++ uuidFields
998 ++ serialFields
999 ++ tagsFields)
1000
1001 instance TimeStampObject Cluster where
1002 cTimeOf = clusterCtime
1003 mTimeOf = clusterMtime
1004
1005 instance UuidObject Cluster where
1006 uuidOf = clusterUuid
1007
1008 instance SerialNoObject Cluster where
1009 serialOf = clusterSerial
1010
1011 instance TagsObject Cluster where
1012 tagsOf = clusterTags
1013
1014 -- * ConfigData definitions
1015
1016 $(buildObject "ConfigData" "config" $
1017 -- timeStampFields ++
1018 [ simpleField "version" [t| Int |]
1019 , simpleField "cluster" [t| Cluster |]
1020 , simpleField "nodes" [t| Container Node |]
1021 , simpleField "nodegroups" [t| Container NodeGroup |]
1022 , simpleField "instances" [t| Container Instance |]
1023 , simpleField "networks" [t| Container Network |]
1024 , simpleField "disks" [t| Container Disk |]
1025 , simpleField "filters" [t| Container FilterRule |]
1026 ]
1027 ++ timeStampFields
1028 ++ serialFields)
1029
1030 instance SerialNoObject ConfigData where
1031 serialOf = configSerial
1032
1033 instance TimeStampObject ConfigData where
1034 cTimeOf = configCtime
1035 mTimeOf = configMtime
1036
1037 -- * Master network parameters
1038
1039 $(buildObject "MasterNetworkParameters" "masterNetworkParameters"
1040 [ simpleField "uuid" [t| String |]
1041 , simpleField "ip" [t| String |]
1042 , simpleField "netmask" [t| Int |]
1043 , simpleField "netdev" [t| String |]
1044 , simpleField "ip_family" [t| IpFamily |]
1045 ])
1046