Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / Objects.hs @ adb77e3a

History | View | Annotate | Download (17.1 kB)

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 Google Inc.
13

    
14
This program is free software; you can redistribute it and/or modify
15
it under the terms of the GNU General Public License as published by
16
the Free Software Foundation; either version 2 of the License, or
17
(at your option) any later version.
18

    
19
This program is distributed in the hope that it will be useful, but
20
WITHOUT ANY WARRANTY; without even the implied warranty of
21
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
22
General Public License for more details.
23

    
24
You should have received a copy of the GNU General Public License
25
along with this program; if not, write to the Free Software
26
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
27
02110-1301, USA.
28

    
29
-}
30

    
31
module Ganeti.Objects
32
  ( NICMode(..)
33
  , PartialNICParams(..)
34
  , FilledNICParams(..)
35
  , fillNICParams
36
  , PartialNIC(..)
37
  , DiskMode(..)
38
  , DiskType(..)
39
  , DiskLogicalId(..)
40
  , Disk(..)
41
  , DiskTemplate(..)
42
  , PartialBEParams(..)
43
  , FilledBEParams(..)
44
  , fillBEParams
45
  , Hypervisor(..)
46
  , AdminState(..)
47
  , adminStateFromRaw
48
  , Instance(..)
49
  , toDictInstance
50
  , PartialNDParams(..)
51
  , FilledNDParams(..)
52
  , fillNDParams
53
  , Node(..)
54
  , AllocPolicy(..)
55
  , FilledISpecParams(..)
56
  , PartialISpecParams(..)
57
  , fillISpecParams
58
  , FilledIPolicy(..)
59
  , PartialIPolicy(..)
60
  , fillIPolicy
61
  , NodeGroup(..)
62
  , IpFamily(..)
63
  , ipFamilyToVersion
64
  , fillDict
65
  , Cluster(..)
66
  , ConfigData(..)
67
  ) where
68

    
69
import Data.List (foldl')
70
import Data.Maybe
71
import qualified Data.Map as Map
72
import Text.JSON (makeObj, showJSON, readJSON, JSON, JSValue(..))
73
import qualified Text.JSON as J
74

    
75
import qualified Ganeti.Constants as C
76
import Ganeti.HTools.JSON
77

    
78
import Ganeti.THH
79

    
80
-- * Generic definitions
81

    
82
-- | Fills one map with keys from the other map, if not already
83
-- existing. Mirrors objects.py:FillDict.
84
fillDict :: (Ord k) => Map.Map k v -> Map.Map k v -> [k] -> Map.Map k v
85
fillDict defaults custom skip_keys =
86
  let updated = Map.union custom defaults
87
  in foldl' (flip Map.delete) updated skip_keys
88

    
89
-- * NIC definitions
90

    
91
$(declareSADT "NICMode"
92
  [ ("NMBridged", 'C.nicModeBridged)
93
  , ("NMRouted",  'C.nicModeRouted)
94
  ])
95
$(makeJSONInstance ''NICMode)
96

    
97
$(buildParam "NIC" "nicp"
98
  [ simpleField "mode" [t| NICMode |]
99
  , simpleField "link" [t| String  |]
100
  ])
101

    
102
$(buildObject "PartialNIC" "nic"
103
  [ simpleField "mac" [t| String |]
104
  , optionalField $ simpleField "ip" [t| String |]
105
  , simpleField "nicparams" [t| PartialNICParams |]
106
  ])
107

    
108
-- * Disk definitions
109

    
110
$(declareSADT "DiskMode"
111
  [ ("DiskRdOnly", 'C.diskRdonly)
112
  , ("DiskRdWr",   'C.diskRdwr)
113
  ])
114
$(makeJSONInstance ''DiskMode)
115

    
116
$(declareSADT "DiskType"
117
  [ ("LD_LV",       'C.ldLv)
118
  , ("LD_DRBD8",    'C.ldDrbd8)
119
  , ("LD_FILE",     'C.ldFile)
120
  , ("LD_BLOCKDEV", 'C.ldBlockdev)
121
  , ("LD_RADOS",    'C.ldRbd)
122
  ])
123
$(makeJSONInstance ''DiskType)
124

    
125
-- | The file driver type.
126
$(declareSADT "FileDriver"
127
  [ ("FileLoop",   'C.fdLoop)
128
  , ("FileBlktap", 'C.fdBlktap)
129
  ])
130
$(makeJSONInstance ''FileDriver)
131

    
132
-- | The persistent block driver type. Currently only one type is allowed.
133
$(declareSADT "BlockDriver"
134
  [ ("BlockDrvManual", 'C.blockdevDriverManual)
135
  ])
136
$(makeJSONInstance ''BlockDriver)
137

    
138
-- | Constant for the dev_type key entry in the disk config.
139
devType :: String
140
devType = "dev_type"
141

    
142
-- | The disk configuration type. This includes the disk type itself,
143
-- for a more complete consistency. Note that since in the Python
144
-- code-base there's no authoritative place where we document the
145
-- logical id, this is probably a good reference point.
146
data DiskLogicalId
147
  = LIDPlain String String  -- ^ Volume group, logical volume
148
  | LIDDrbd8 String String Int Int Int String
149
  -- ^ NodeA, NodeB, Port, MinorA, MinorB, Secret
150
  | LIDFile FileDriver String -- ^ Driver, path
151
  | LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev)
152
  | LIDRados String String -- ^ Unused, path
153
    deriving (Read, Show, Eq)
154

    
155
-- | Mapping from a logical id to a disk type.
156
lidDiskType :: DiskLogicalId -> DiskType
157
lidDiskType (LIDPlain {}) = LD_LV
158
lidDiskType (LIDDrbd8 {}) = LD_DRBD8
159
lidDiskType (LIDFile  {}) = LD_FILE
160
lidDiskType (LIDBlockDev {}) = LD_BLOCKDEV
161
lidDiskType (LIDRados {}) = LD_RADOS
162

    
163
-- | Builds the extra disk_type field for a given logical id.
164
lidEncodeType :: DiskLogicalId -> [(String, JSValue)]
165
lidEncodeType v = [(devType, showJSON . lidDiskType $ v)]
166

    
167
-- | Custom encoder for DiskLogicalId (logical id only).
168
encodeDLId :: DiskLogicalId -> JSValue
169
encodeDLId (LIDPlain vg lv) = JSArray [showJSON vg, showJSON lv]
170
encodeDLId (LIDDrbd8 nodeA nodeB port minorA minorB key) =
171
  JSArray [ showJSON nodeA, showJSON nodeB, showJSON port
172
          , showJSON minorA, showJSON minorB, showJSON key ]
173
encodeDLId (LIDRados pool name) = JSArray [showJSON pool, showJSON name]
174
encodeDLId (LIDFile driver name) = JSArray [showJSON driver, showJSON name]
175
encodeDLId (LIDBlockDev driver name) = JSArray [showJSON driver, showJSON name]
176

    
177
-- | Custom encoder for DiskLogicalId, composing both the logical id
178
-- and the extra disk_type field.
179
encodeFullDLId :: DiskLogicalId -> (JSValue, [(String, JSValue)])
180
encodeFullDLId v = (encodeDLId v, lidEncodeType v)
181

    
182
-- | Custom decoder for DiskLogicalId. This is manual for now, since
183
-- we don't have yet automation for separate-key style fields.
184
decodeDLId :: [(String, JSValue)] -> JSValue -> J.Result DiskLogicalId
185
decodeDLId obj lid = do
186
  dtype <- fromObj obj devType
187
  case dtype of
188
    LD_DRBD8 ->
189
      case lid of
190
        JSArray [nA, nB, p, mA, mB, k] -> do
191
          nA' <- readJSON nA
192
          nB' <- readJSON nB
193
          p'  <- readJSON p
194
          mA' <- readJSON mA
195
          mB' <- readJSON mB
196
          k'  <- readJSON k
197
          return $ LIDDrbd8 nA' nB' p' mA' mB' k'
198
        _ -> fail $ "Can't read logical_id for DRBD8 type"
199
    LD_LV ->
200
      case lid of
201
        JSArray [vg, lv] -> do
202
          vg' <- readJSON vg
203
          lv' <- readJSON lv
204
          return $ LIDPlain vg' lv'
205
        _ -> fail $ "Can't read logical_id for plain type"
206
    LD_FILE ->
207
      case lid of
208
        JSArray [driver, path] -> do
209
          driver' <- readJSON driver
210
          path'   <- readJSON path
211
          return $ LIDFile driver' path'
212
        _ -> fail $ "Can't read logical_id for file type"
213
    LD_BLOCKDEV ->
214
      case lid of
215
        JSArray [driver, path] -> do
216
          driver' <- readJSON driver
217
          path'   <- readJSON path
218
          return $ LIDBlockDev driver' path'
219
        _ -> fail $ "Can't read logical_id for blockdev type"
220
    LD_RADOS ->
221
      case lid of
222
        JSArray [driver, path] -> do
223
          driver' <- readJSON driver
224
          path'   <- readJSON path
225
          return $ LIDRados driver' path'
226
        _ -> fail $ "Can't read logical_id for rdb type"
227

    
228
-- | Disk data structure.
229
--
230
-- This is declared manually as it's a recursive structure, and our TH
231
-- code currently can't build it.
232
data Disk = Disk
233
  { diskLogicalId  :: DiskLogicalId
234
--  , diskPhysicalId :: String
235
  , diskChildren   :: [Disk]
236
  , diskIvName     :: String
237
  , diskSize       :: Int
238
  , diskMode       :: DiskMode
239
  } deriving (Read, Show, Eq)
240

    
241
$(buildObjectSerialisation "Disk"
242
  [ customField 'decodeDLId 'encodeFullDLId $
243
      simpleField "logical_id"    [t| DiskLogicalId   |]
244
--  , simpleField "physical_id" [t| String   |]
245
  , defaultField  [| [] |] $ simpleField "children" [t| [Disk] |]
246
  , defaultField [| "" |] $ simpleField "iv_name" [t| String |]
247
  , simpleField "size" [t| Int |]
248
  , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
249
  ])
250

    
251
-- * Hypervisor definitions
252

    
253
-- | This may be due to change when we add hypervisor parameters.
254
$(declareSADT "Hypervisor"
255
  [ ( "Kvm",    'C.htKvm )
256
  , ( "XenPvm", 'C.htXenPvm )
257
  , ( "Chroot", 'C.htChroot )
258
  , ( "XenHvm", 'C.htXenHvm )
259
  , ( "Lxc",    'C.htLxc )
260
  , ( "Fake",   'C.htFake )
261
  ])
262
$(makeJSONInstance ''Hypervisor)
263

    
264
-- * Instance definitions
265

    
266
-- | Instance disk template type. **Copied from HTools/Types.hs**
267
$(declareSADT "DiskTemplate"
268
  [ ("DTDiskless",   'C.dtDiskless)
269
  , ("DTFile",       'C.dtFile)
270
  , ("DTSharedFile", 'C.dtSharedFile)
271
  , ("DTPlain",      'C.dtPlain)
272
  , ("DTBlock",      'C.dtBlock)
273
  , ("DTDrbd8",      'C.dtDrbd8)
274
  , ("DTRados",      'C.dtRbd)
275
  ])
276
$(makeJSONInstance ''DiskTemplate)
277

    
278
$(declareSADT "AdminState"
279
  [ ("AdminOffline", 'C.adminstOffline)
280
  , ("AdminDown",    'C.adminstDown)
281
  , ("AdminUp",      'C.adminstUp)
282
  ])
283
$(makeJSONInstance ''AdminState)
284

    
285
$(buildParam "BE" "bep" $
286
  [ simpleField "minmem"       [t| Int  |]
287
  , simpleField "maxmem"       [t| Int  |]
288
  , simpleField "vcpus"        [t| Int  |]
289
  , simpleField "auto_balance" [t| Bool |]
290
  ])
291

    
292
$(buildObject "Instance" "inst" $
293
  [ simpleField "name"           [t| String             |]
294
  , simpleField "primary_node"   [t| String             |]
295
  , simpleField "os"             [t| String             |]
296
  , simpleField "hypervisor"     [t| String             |]
297
--  , simpleField "hvparams"     [t| [(String, String)] |]
298
  , simpleField "beparams"       [t| PartialBEParams |]
299
--  , simpleField "osparams"     [t| [(String, String)] |]
300
  , simpleField "admin_state"    [t| AdminState         |]
301
  , simpleField "nics"           [t| [PartialNIC]              |]
302
  , simpleField "disks"          [t| [Disk]             |]
303
  , simpleField "disk_template"  [t| DiskTemplate       |]
304
  , optionalField $ simpleField "network_port" [t| Int |]
305
  ]
306
  ++ timeStampFields
307
  ++ uuidFields
308
  ++ serialFields
309
  ++ tagsFields)
310

    
311
-- * IPolicy definitions
312

    
313
$(buildParam "ISpec" "ispec" $
314
  [ simpleField C.ispecMemSize     [t| Int |]
315
  , simpleField C.ispecDiskSize    [t| Int |]
316
  , simpleField C.ispecDiskCount   [t| Int |]
317
  , simpleField C.ispecCpuCount    [t| Int |]
318
  , simpleField C.ispecSpindleUse  [t| Int |]
319
  ])
320

    
321
-- | Custom partial ipolicy. This is not built via buildParam since it
322
-- has a special 2-level inheritance mode.
323
$(buildObject "PartialIPolicy" "ipolicy" $
324
  [ renameField "MinSpecP" $ simpleField "min" [t| PartialISpecParams |]
325
  , renameField "MaxSpecP" $ simpleField "max" [t| PartialISpecParams |]
326
  , renameField "StdSpecP" $ simpleField "std" [t| PartialISpecParams |]
327
  , optionalField . renameField "SpindleRatioP"
328
                    $ simpleField "spindle-ratio"  [t| Double |]
329
  , optionalField . renameField "VcpuRatioP"
330
                    $ simpleField "vcpu-ratio"     [t| Double |]
331
  , optionalField . renameField "DiskTemplatesP"
332
                    $ simpleField "disk-templates" [t| [DiskTemplate] |]
333
  ])
334

    
335
-- | Custom filled ipolicy. This is not built via buildParam since it
336
-- has a special 2-level inheritance mode.
337
$(buildObject "FilledIPolicy" "ipolicy" $
338
  [ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |]
339
  , renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |]
340
  , renameField "StdSpec" $ simpleField "std" [t| FilledISpecParams |]
341
  , simpleField "spindle-ratio"  [t| Double |]
342
  , simpleField "vcpu-ratio"     [t| Double |]
343
  , simpleField "disk-templates" [t| [DiskTemplate] |]
344
  ])
345

    
346
-- | Custom filler for the ipolicy types.
347
fillIPolicy :: FilledIPolicy -> PartialIPolicy -> FilledIPolicy
348
fillIPolicy (FilledIPolicy { ipolicyMinSpec       = fmin
349
                           , ipolicyMaxSpec       = fmax
350
                           , ipolicyStdSpec       = fstd
351
                           , ipolicySpindleRatio  = fspindleRatio
352
                           , ipolicyVcpuRatio     = fvcpuRatio
353
                           , ipolicyDiskTemplates = fdiskTemplates})
354
            (PartialIPolicy { ipolicyMinSpecP       = pmin
355
                            , ipolicyMaxSpecP       = pmax
356
                            , ipolicyStdSpecP       = pstd
357
                            , ipolicySpindleRatioP  = pspindleRatio
358
                            , ipolicyVcpuRatioP     = pvcpuRatio
359
                            , ipolicyDiskTemplatesP = pdiskTemplates}) =
360
  FilledIPolicy { ipolicyMinSpec       = fillISpecParams fmin pmin
361
                , ipolicyMaxSpec       = fillISpecParams fmax pmax
362
                , ipolicyStdSpec       = fillISpecParams fstd pstd
363
                , ipolicySpindleRatio  = fromMaybe fspindleRatio pspindleRatio
364
                , ipolicyVcpuRatio     = fromMaybe fvcpuRatio pvcpuRatio
365
                , ipolicyDiskTemplates = fromMaybe fdiskTemplates
366
                                         pdiskTemplates
367
                }
368
-- * Node definitions
369

    
370
$(buildParam "ND" "ndp" $
371
  [ simpleField "oob_program"   [t| String |]
372
  , simpleField "spindle_count" [t| Int    |]
373
  ])
374

    
375
$(buildObject "Node" "node" $
376
  [ simpleField "name"             [t| String |]
377
  , simpleField "primary_ip"       [t| String |]
378
  , simpleField "secondary_ip"     [t| String |]
379
  , simpleField "master_candidate" [t| Bool   |]
380
  , simpleField "offline"          [t| Bool   |]
381
  , simpleField "drained"          [t| Bool   |]
382
  , simpleField "group"            [t| String |]
383
  , simpleField "master_capable"   [t| Bool   |]
384
  , simpleField "vm_capable"       [t| Bool   |]
385
  , simpleField "ndparams"         [t| PartialNDParams |]
386
  , simpleField "powered"          [t| Bool   |]
387
  ]
388
  ++ timeStampFields
389
  ++ uuidFields
390
  ++ serialFields
391
  ++ tagsFields)
392

    
393
-- * NodeGroup definitions
394

    
395
-- | The Group allocation policy type.
396
--
397
-- Note that the order of constructors is important as the automatic
398
-- Ord instance will order them in the order they are defined, so when
399
-- changing this data type be careful about the interaction with the
400
-- desired sorting order.
401
--
402
-- FIXME: COPIED from Types.hs; we need to eliminate this duplication later
403
$(declareSADT "AllocPolicy"
404
  [ ("AllocPreferred",   'C.allocPolicyPreferred)
405
  , ("AllocLastResort",  'C.allocPolicyLastResort)
406
  , ("AllocUnallocable", 'C.allocPolicyUnallocable)
407
  ])
408
$(makeJSONInstance ''AllocPolicy)
409

    
410
$(buildObject "NodeGroup" "group" $
411
  [ simpleField "name"         [t| String |]
412
  , defaultField  [| [] |] $ simpleField "members" [t| [String] |]
413
  , simpleField "ndparams"     [t| PartialNDParams |]
414
  , simpleField "alloc_policy" [t| AllocPolicy     |]
415
  , simpleField "ipolicy"      [t| PartialIPolicy  |]
416
  ]
417
  ++ timeStampFields
418
  ++ uuidFields
419
  ++ serialFields
420
  ++ tagsFields)
421

    
422
-- | IP family type
423
$(declareIADT "IpFamily"
424
  [ ("IpFamilyV4", 'C.ip4Family)
425
  , ("IpFamilyV6", 'C.ip6Family)
426
  ])
427
$(makeJSONInstance ''IpFamily)
428

    
429
-- | Conversion from IP family to IP version. This is needed because
430
-- Python uses both, depending on context.
431
ipFamilyToVersion :: IpFamily -> Int
432
ipFamilyToVersion IpFamilyV4 = C.ip4Version
433
ipFamilyToVersion IpFamilyV6 = C.ip6Version
434

    
435
-- * Cluster definitions
436
$(buildObject "Cluster" "cluster" $
437
  [ simpleField "rsahostkeypub"             [t| String   |]
438
  , simpleField "highest_used_port"         [t| Int      |]
439
  , simpleField "tcpudp_port_pool"          [t| [Int]    |]
440
  , simpleField "mac_prefix"                [t| String   |]
441
  , simpleField "volume_group_name"         [t| String   |]
442
  , simpleField "reserved_lvs"              [t| [String] |]
443
  , optionalField $ simpleField "drbd_usermode_helper" [t| String |]
444
-- , simpleField "default_bridge"          [t| String   |]
445
-- , simpleField "default_hypervisor"      [t| String   |]
446
  , simpleField "master_node"               [t| String   |]
447
  , simpleField "master_ip"                 [t| String   |]
448
  , simpleField "master_netdev"             [t| String   |]
449
  , simpleField "master_netmask"            [t| Int   |]
450
  , simpleField "use_external_mip_script"   [t| Bool |]
451
  , simpleField "cluster_name"              [t| String   |]
452
  , simpleField "file_storage_dir"          [t| String   |]
453
  , simpleField "shared_file_storage_dir"   [t| String   |]
454
  , simpleField "enabled_hypervisors"       [t| [String] |]
455
-- , simpleField "hvparams"                [t| [(String, [(String, String)])] |]
456
-- , simpleField "os_hvp"                  [t| [(String, String)] |]
457
  , simpleField "beparams" [t| Container FilledBEParams |]
458
  , simpleField "osparams"                  [t| Container (Container String) |]
459
  , simpleField "nicparams" [t| Container FilledNICParams    |]
460
  , simpleField "ndparams"                  [t| FilledNDParams |]
461
  , simpleField "candidate_pool_size"       [t| Int                |]
462
  , simpleField "modify_etc_hosts"          [t| Bool               |]
463
  , simpleField "modify_ssh_setup"          [t| Bool               |]
464
  , simpleField "maintain_node_health"      [t| Bool               |]
465
  , simpleField "uid_pool"                  [t| [(Int, Int)]       |]
466
  , simpleField "default_iallocator"        [t| String             |]
467
  , simpleField "hidden_os"                 [t| [String]           |]
468
  , simpleField "blacklisted_os"            [t| [String]           |]
469
  , simpleField "primary_ip_family"         [t| IpFamily           |]
470
  , simpleField "prealloc_wipe_disks"       [t| Bool               |]
471
  , simpleField "ipolicy"                   [t| FilledIPolicy      |]
472
 ]
473
 ++ serialFields
474
 ++ timeStampFields
475
 ++ uuidFields
476
 ++ tagsFields)
477

    
478
-- * ConfigData definitions
479

    
480
$(buildObject "ConfigData" "config" $
481
--  timeStampFields ++
482
  [ simpleField "version"    [t| Int                 |]
483
  , simpleField "cluster"    [t| Cluster             |]
484
  , simpleField "nodes"      [t| Container Node      |]
485
  , simpleField "nodegroups" [t| Container NodeGroup |]
486
  , simpleField "instances"  [t| Container Instance  |]
487
  ]
488
  ++ serialFields)