Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / Objects.hs @ 6ece11be

History | View | Annotate | Download (13.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
  , Instance(..)
46
  , toDictInstance
47
  , PartialNDParams(..)
48
  , FilledNDParams(..)
49
  , fillNDParams
50
  , Node(..)
51
  , AllocPolicy(..)
52
  , NodeGroup(..)
53
  , Cluster(..)
54
  , ConfigData(..)
55
  ) where
56

    
57
import Data.Maybe
58
import Text.JSON (makeObj, showJSON, readJSON, JSON, JSValue(..))
59
import qualified Text.JSON as J
60

    
61
import qualified Ganeti.Constants as C
62
import Ganeti.HTools.JSON
63

    
64
import Ganeti.THH
65

    
66
-- * NIC definitions
67

    
68
$(declareSADT "NICMode"
69
  [ ("NMBridged", 'C.nicModeBridged)
70
  , ("NMRouted",  'C.nicModeRouted)
71
  ])
72
$(makeJSONInstance ''NICMode)
73

    
74
$(buildParam "NIC" "nicp"
75
  [ simpleField "mode" [t| NICMode |]
76
  , simpleField "link" [t| String  |]
77
  ])
78

    
79
$(buildObject "PartialNIC" "nic"
80
  [ simpleField "mac" [t| String |]
81
  , optionalField $ simpleField "ip" [t| String |]
82
  , simpleField "nicparams" [t| PartialNICParams |]
83
  ])
84

    
85
-- * Disk definitions
86

    
87
$(declareSADT "DiskMode"
88
  [ ("DiskRdOnly", 'C.diskRdonly)
89
  , ("DiskRdWr",   'C.diskRdwr)
90
  ])
91
$(makeJSONInstance ''DiskMode)
92

    
93
$(declareSADT "DiskType"
94
  [ ("LD_LV",       'C.ldLv)
95
  , ("LD_DRBD8",    'C.ldDrbd8)
96
  , ("LD_FILE",     'C.ldFile)
97
  , ("LD_BLOCKDEV", 'C.ldBlockdev)
98
  , ("LD_RADOS",    'C.ldRbd)
99
  , ("LD_EXT",      'C.ldExt)
100
  ])
101
$(makeJSONInstance ''DiskType)
102

    
103
-- | The file driver type.
104
$(declareSADT "FileDriver"
105
  [ ("FileLoop",   'C.fdLoop)
106
  , ("FileBlktap", 'C.fdBlktap)
107
  ])
108
$(makeJSONInstance ''FileDriver)
109

    
110
-- | The persistent block driver type. Currently only one type is allowed.
111
$(declareSADT "BlockDriver"
112
  [ ("BlockDrvManual", 'C.blockdevDriverManual)
113
  ])
114
$(makeJSONInstance ''BlockDriver)
115

    
116
-- | Constant for the dev_type key entry in the disk config.
117
devType :: String
118
devType = "dev_type"
119

    
120
-- | The disk configuration type. This includes the disk type itself,
121
-- for a more complete consistency. Note that since in the Python
122
-- code-base there's no authoritative place where we document the
123
-- logical id, this is probably a good reference point.
124
data DiskLogicalId
125
  = LIDPlain String String  -- ^ Volume group, logical volume
126
  | LIDDrbd8 String String Int Int Int String
127
  -- ^ NodeA, NodeB, Port, MinorA, MinorB, Secret
128
  | LIDFile FileDriver String -- ^ Driver, path
129
  | LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev)
130
  | LIDRados String String -- ^ Unused, path
131
  | LIDExt String String -- ^ ExtProvider, unique name
132
    deriving (Read, Show, Eq)
133

    
134
-- | Mapping from a logical id to a disk type.
135
lidDiskType :: DiskLogicalId -> DiskType
136
lidDiskType (LIDPlain {}) = LD_LV
137
lidDiskType (LIDDrbd8 {}) = LD_DRBD8
138
lidDiskType (LIDFile  {}) = LD_FILE
139
lidDiskType (LIDBlockDev {}) = LD_BLOCKDEV
140
lidDiskType (LIDRados {}) = LD_RADOS
141
lidDiskType (LIDExt {}) = LD_EXT
142

    
143
-- | Builds the extra disk_type field for a given logical id.
144
lidEncodeType :: DiskLogicalId -> [(String, JSValue)]
145
lidEncodeType v = [(devType, showJSON . lidDiskType $ v)]
146

    
147
-- | Custom encoder for DiskLogicalId (logical id only).
148
encodeDLId :: DiskLogicalId -> JSValue
149
encodeDLId (LIDPlain vg lv) = JSArray [showJSON vg, showJSON lv]
150
encodeDLId (LIDDrbd8 nodeA nodeB port minorA minorB key) =
151
  JSArray [ showJSON nodeA, showJSON nodeB, showJSON port
152
          , showJSON minorA, showJSON minorB, showJSON key ]
153
encodeDLId (LIDRados pool name) = JSArray [showJSON pool, showJSON name]
154
encodeDLId (LIDFile driver name) = JSArray [showJSON driver, showJSON name]
155
encodeDLId (LIDBlockDev driver name) = JSArray [showJSON driver, showJSON name]
156
encodeDLId (LIDExt extprovider name) = JSArray [showJSON extprovider, showJSON name]
157

    
158
-- | Custom encoder for DiskLogicalId, composing both the logical id
159
-- and the extra disk_type field.
160
encodeFullDLId :: DiskLogicalId -> (JSValue, [(String, JSValue)])
161
encodeFullDLId v = (encodeDLId v, lidEncodeType v)
162

    
163
-- | Custom decoder for DiskLogicalId. This is manual for now, since
164
-- we don't have yet automation for separate-key style fields.
165
decodeDLId :: [(String, JSValue)] -> JSValue -> J.Result DiskLogicalId
166
decodeDLId obj lid = do
167
  dtype <- fromObj obj devType
168
  case dtype of
169
    LD_DRBD8 ->
170
      case lid of
171
        JSArray [nA, nB, p, mA, mB, k] -> do
172
          nA' <- readJSON nA
173
          nB' <- readJSON nB
174
          p'  <- readJSON p
175
          mA' <- readJSON mA
176
          mB' <- readJSON mB
177
          k'  <- readJSON k
178
          return $ LIDDrbd8 nA' nB' p' mA' mB' k'
179
        _ -> fail $ "Can't read logical_id for DRBD8 type"
180
    LD_LV ->
181
      case lid of
182
        JSArray [vg, lv] -> do
183
          vg' <- readJSON vg
184
          lv' <- readJSON lv
185
          return $ LIDPlain vg' lv'
186
        _ -> fail $ "Can't read logical_id for plain type"
187
    LD_FILE ->
188
      case lid of
189
        JSArray [driver, path] -> do
190
          driver' <- readJSON driver
191
          path'   <- readJSON path
192
          return $ LIDFile driver' path'
193
        _ -> fail $ "Can't read logical_id for file type"
194
    LD_BLOCKDEV ->
195
      case lid of
196
        JSArray [driver, path] -> do
197
          driver' <- readJSON driver
198
          path'   <- readJSON path
199
          return $ LIDBlockDev driver' path'
200
        _ -> fail $ "Can't read logical_id for blockdev type"
201
    LD_RADOS ->
202
      case lid of
203
        JSArray [driver, path] -> do
204
          driver' <- readJSON driver
205
          path'   <- readJSON path
206
          return $ LIDRados driver' path'
207
        _ -> fail $ "Can't read logical_id for rdb type"
208
    LD_EXT ->
209
      case lid of
210
        JSArray [extprovider, name] -> do
211
          extprovider' <- readJSON extprovider
212
          name'   <- readJSON name
213
          return $ LIDExt extprovider' name'
214
        _ -> fail $ "Can't read logical_id for extstorage type"
215

    
216
-- | Disk data structure.
217
--
218
-- This is declared manually as it's a recursive structure, and our TH
219
-- code currently can't build it.
220
data Disk = Disk
221
  { diskLogicalId  :: DiskLogicalId
222
--  , diskPhysicalId :: String
223
  , diskChildren   :: [Disk]
224
  , diskIvName     :: String
225
  , diskSize       :: Int
226
  , diskMode       :: DiskMode
227
  } deriving (Read, Show, Eq)
228

    
229
$(buildObjectSerialisation "Disk"
230
  [ customField 'decodeDLId 'encodeFullDLId $
231
      simpleField "logical_id"    [t| DiskLogicalId   |]
232
--  , simpleField "physical_id" [t| String   |]
233
  , defaultField  [| [] |] $ simpleField "children" [t| [Disk] |]
234
  , defaultField [| "" |] $ simpleField "iv_name" [t| String |]
235
  , simpleField "size" [t| Int |]
236
  , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
237
  ])
238

    
239
-- * Instance definitions
240

    
241
-- | Instance disk template type. **Copied from HTools/Types.hs**
242
$(declareSADT "DiskTemplate"
243
  [ ("DTDiskless",   'C.dtDiskless)
244
  , ("DTFile",       'C.dtFile)
245
  , ("DTSharedFile", 'C.dtSharedFile)
246
  , ("DTPlain",      'C.dtPlain)
247
  , ("DTBlock",      'C.dtBlock)
248
  , ("DTDrbd8",      'C.dtDrbd8)
249
  , ("DTExt",        'C.dtExt)
250
  ])
251
$(makeJSONInstance ''DiskTemplate)
252

    
253
$(declareSADT "AdminState"
254
  [ ("AdminOffline", 'C.adminstOffline)
255
  , ("AdminDown",    'C.adminstDown)
256
  , ("AdminUp",      'C.adminstUp)
257
  ])
258
$(makeJSONInstance ''AdminState)
259

    
260
$(buildParam "BE" "bep" $
261
  [ simpleField "minmem"       [t| Int  |]
262
  , simpleField "maxmem"       [t| Int  |]
263
  , simpleField "vcpus"        [t| Int  |]
264
  , simpleField "auto_balance" [t| Bool |]
265
  ])
266

    
267
$(buildObject "Instance" "inst" $
268
  [ simpleField "name"           [t| String             |]
269
  , simpleField "primary_node"   [t| String             |]
270
  , simpleField "os"             [t| String             |]
271
  , simpleField "hypervisor"     [t| String             |]
272
--  , simpleField "hvparams"     [t| [(String, String)] |]
273
  , simpleField "beparams"       [t| PartialBEParams |]
274
--  , simpleField "osparams"     [t| [(String, String)] |]
275
  , simpleField "admin_state"    [t| AdminState         |]
276
  , simpleField "nics"           [t| [PartialNIC]              |]
277
  , simpleField "disks"          [t| [Disk]             |]
278
  , simpleField "disk_template"  [t| DiskTemplate       |]
279
  , optionalField $ simpleField "network_port" [t| Int |]
280
  ]
281
  ++ timeStampFields
282
  ++ uuidFields
283
  ++ serialFields)
284

    
285
-- * Node definitions
286

    
287
$(buildParam "ND" "ndp" $
288
  [ simpleField "oob_program" [t| String |]
289
  ])
290

    
291
$(buildObject "Node" "node" $
292
  [ simpleField "name"             [t| String |]
293
  , simpleField "primary_ip"       [t| String |]
294
  , simpleField "secondary_ip"     [t| String |]
295
  , simpleField "master_candidate" [t| Bool   |]
296
  , simpleField "offline"          [t| Bool   |]
297
  , simpleField "drained"          [t| Bool   |]
298
  , simpleField "group"            [t| String |]
299
  , simpleField "master_capable"   [t| Bool   |]
300
  , simpleField "vm_capable"       [t| Bool   |]
301
--  , simpleField "ndparams"       [t| PartialNDParams |]
302
  , simpleField "powered"          [t| Bool   |]
303
  ]
304
  ++ timeStampFields
305
  ++ uuidFields
306
  ++ serialFields)
307

    
308
-- * NodeGroup definitions
309

    
310
-- | The Group allocation policy type.
311
--
312
-- Note that the order of constructors is important as the automatic
313
-- Ord instance will order them in the order they are defined, so when
314
-- changing this data type be careful about the interaction with the
315
-- desired sorting order.
316
--
317
-- FIXME: COPIED from Types.hs; we need to eliminate this duplication later
318
$(declareSADT "AllocPolicy"
319
  [ ("AllocPreferred",   'C.allocPolicyPreferred)
320
  , ("AllocLastResort",  'C.allocPolicyLastResort)
321
  , ("AllocUnallocable", 'C.allocPolicyUnallocable)
322
  ])
323
$(makeJSONInstance ''AllocPolicy)
324

    
325
$(buildObject "NodeGroup" "group" $
326
  [ simpleField "name"         [t| String |]
327
  , defaultField  [| [] |] $ simpleField "members" [t| [String] |]
328
--  , simpleField "ndparams"   [t| PartialNDParams |]
329
  , simpleField "alloc_policy" [t| AllocPolicy |]
330
  ]
331
  ++ timeStampFields
332
  ++ uuidFields
333
  ++ serialFields)
334

    
335
-- * Cluster definitions
336
$(buildObject "Cluster" "cluster" $
337
  [ simpleField "rsahostkeypub"             [t| String   |]
338
  , simpleField "highest_used_port"         [t| Int      |]
339
  , simpleField "tcpudp_port_pool"          [t| [Int]    |]
340
  , simpleField "mac_prefix"                [t| String   |]
341
  , optionalField $ simpleField "volume_group_name"         [t| String   |]
342
  , simpleField "reserved_lvs"              [t| [String] |]
343
--  , simpleField "drbd_usermode_helper"      [t| String   |]
344
-- , simpleField "default_bridge"          [t| String   |]
345
-- , simpleField "default_hypervisor"      [t| String   |]
346
  , simpleField "master_node"               [t| String   |]
347
  , simpleField "master_ip"                 [t| String   |]
348
  , simpleField "master_netdev"             [t| String   |]
349
-- , simpleField "master_netmask"          [t| String   |]
350
  , simpleField "cluster_name"              [t| String   |]
351
  , simpleField "file_storage_dir"          [t| String   |]
352
-- , simpleField "shared_file_storage_dir" [t| String   |]
353
  , simpleField "enabled_hypervisors"       [t| [String] |]
354
-- , simpleField "hvparams"                [t| [(String, [(String, String)])] |]
355
-- , simpleField "os_hvp"                  [t| [(String, String)] |]
356
  , containerField $ simpleField "beparams" [t| FilledBEParams |]
357
-- , simpleField "osparams"                [t| [(String, String)] |]
358
  , containerField $ simpleField "nicparams" [t| FilledNICParams    |]
359
--  , simpleField "ndparams"                  [t| FilledNDParams |]
360
  , simpleField "candidate_pool_size"       [t| Int                |]
361
  , simpleField "modify_etc_hosts"          [t| Bool               |]
362
  , simpleField "modify_ssh_setup"          [t| Bool               |]
363
  , simpleField "maintain_node_health"      [t| Bool               |]
364
  , simpleField "uid_pool"                  [t| [Int]              |]
365
  , simpleField "default_iallocator"        [t| String             |]
366
  , simpleField "hidden_os"                 [t| [String]           |]
367
  , simpleField "blacklisted_os"            [t| [String]           |]
368
  , simpleField "primary_ip_family"         [t| Int                |]
369
  , simpleField "prealloc_wipe_disks"       [t| Bool               |]
370
 ]
371
 ++ serialFields)
372

    
373
-- * ConfigData definitions
374

    
375
$(buildObject "ConfigData" "config" $
376
--  timeStampFields ++
377
  [ simpleField "version"       [t| Int                |]
378
  , simpleField "cluster"       [t| Cluster            |]
379
  , containerField $ simpleField "nodes"      [t| Node     |]
380
  , containerField $ simpleField "nodegroups" [t| NodeGroup |]
381
  , containerField $ simpleField "instances"  [t| Instance |]
382
  ]
383
  ++ serialFields)