Revision 2e12944a htools/Ganeti/Objects.hs
b/htools/Ganeti/Objects.hs | ||
---|---|---|
36 | 36 |
, PartialNIC(..) |
37 | 37 |
, DiskMode(..) |
38 | 38 |
, DiskType(..) |
39 |
, DiskLogicalId(..) |
|
39 | 40 |
, Disk(..) |
40 | 41 |
, DiskTemplate(..) |
41 | 42 |
, PartialBEParams(..) |
... | ... | |
54 | 55 |
) where |
55 | 56 |
|
56 | 57 |
import Data.Maybe |
57 |
import Text.JSON (makeObj, showJSON, readJSON) |
|
58 |
import Text.JSON (makeObj, showJSON, readJSON, JSON, JSValue(..)) |
|
59 |
import qualified Text.JSON as J |
|
58 | 60 |
|
59 | 61 |
import qualified Ganeti.Constants as C |
60 | 62 |
import Ganeti.HTools.JSON |
... | ... | |
93 | 95 |
, ("LD_DRBD8", 'C.ldDrbd8) |
94 | 96 |
, ("LD_FILE", 'C.ldFile) |
95 | 97 |
, ("LD_BLOCKDEV", 'C.ldBlockdev) |
98 |
, ("LD_RADOS", 'C.ldRbd) |
|
96 | 99 |
]) |
97 | 100 |
$(makeJSONInstance ''DiskType) |
98 | 101 |
|
102 |
-- | The file driver type. |
|
103 |
$(declareSADT "FileDriver" |
|
104 |
[ ("FileLoop", 'C.fdLoop) |
|
105 |
, ("FileBlktap", 'C.fdBlktap) |
|
106 |
]) |
|
107 |
$(makeJSONInstance ''FileDriver) |
|
108 |
|
|
109 |
-- | The persistent block driver type. Currently only one type is allowed. |
|
110 |
$(declareSADT "BlockDriver" |
|
111 |
[ ("BlockDrvManual", 'C.blockdevDriverManual) |
|
112 |
]) |
|
113 |
$(makeJSONInstance ''BlockDriver) |
|
114 |
|
|
115 |
-- | Constant for the dev_type key entry in the disk config. |
|
116 |
devType :: String |
|
117 |
devType = "dev_type" |
|
118 |
|
|
119 |
-- | The disk configuration type. This includes the disk type itself, |
|
120 |
-- for a more complete consistency. Note that since in the Python |
|
121 |
-- code-base there's no authoritative place where we document the |
|
122 |
-- logical id, this is probably a good reference point. |
|
123 |
data DiskLogicalId |
|
124 |
= LIDPlain String String -- ^ Volume group, logical volume |
|
125 |
| LIDDrbd8 String String Int Int Int String |
|
126 |
-- ^ NodeA, NodeB, Port, MinorA, MinorB, Secret |
|
127 |
| LIDFile FileDriver String -- ^ Driver, path |
|
128 |
| LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev) |
|
129 |
| LIDRados String String -- ^ Unused, path |
|
130 |
deriving (Read, Show, Eq) |
|
131 |
|
|
132 |
-- | Mapping from a logical id to a disk type. |
|
133 |
lidDiskType :: DiskLogicalId -> DiskType |
|
134 |
lidDiskType (LIDPlain {}) = LD_LV |
|
135 |
lidDiskType (LIDDrbd8 {}) = LD_DRBD8 |
|
136 |
lidDiskType (LIDFile {}) = LD_FILE |
|
137 |
lidDiskType (LIDBlockDev {}) = LD_BLOCKDEV |
|
138 |
lidDiskType (LIDRados {}) = LD_RADOS |
|
139 |
|
|
140 |
-- | Builds the extra disk_type field for a given logical id. |
|
141 |
lidEncodeType :: DiskLogicalId -> [(String, JSValue)] |
|
142 |
lidEncodeType v = [(devType, showJSON . lidDiskType $ v)] |
|
143 |
|
|
144 |
-- | Custom encoder for DiskLogicalId (logical id only). |
|
145 |
encodeDLId :: DiskLogicalId -> JSValue |
|
146 |
encodeDLId (LIDPlain vg lv) = JSArray [showJSON vg, showJSON lv] |
|
147 |
encodeDLId (LIDDrbd8 nodeA nodeB port minorA minorB key) = |
|
148 |
JSArray [ showJSON nodeA, showJSON nodeB, showJSON port |
|
149 |
, showJSON minorA, showJSON minorB, showJSON key ] |
|
150 |
encodeDLId (LIDRados pool name) = JSArray [showJSON pool, showJSON name] |
|
151 |
encodeDLId (LIDFile driver name) = JSArray [showJSON driver, showJSON name] |
|
152 |
encodeDLId (LIDBlockDev driver name) = JSArray [showJSON driver, showJSON name] |
|
153 |
|
|
154 |
-- | Custom encoder for DiskLogicalId, composing both the logical id |
|
155 |
-- and the extra disk_type field. |
|
156 |
encodeFullDLId :: DiskLogicalId -> (JSValue, [(String, JSValue)]) |
|
157 |
encodeFullDLId v = (encodeDLId v, lidEncodeType v) |
|
158 |
|
|
159 |
-- | Custom decoder for DiskLogicalId. This is manual for now, since |
|
160 |
-- we don't have yet automation for separate-key style fields. |
|
161 |
decodeDLId :: [(String, JSValue)] -> JSValue -> J.Result DiskLogicalId |
|
162 |
decodeDLId obj lid = do |
|
163 |
dtype <- fromObj obj devType |
|
164 |
case dtype of |
|
165 |
LD_DRBD8 -> |
|
166 |
case lid of |
|
167 |
JSArray [nA, nB, p, mA, mB, k] -> do |
|
168 |
nA' <- readJSON nA |
|
169 |
nB' <- readJSON nB |
|
170 |
p' <- readJSON p |
|
171 |
mA' <- readJSON mA |
|
172 |
mB' <- readJSON mB |
|
173 |
k' <- readJSON k |
|
174 |
return $ LIDDrbd8 nA' nB' p' mA' mB' k' |
|
175 |
_ -> fail $ "Can't read logical_id for DRBD8 type" |
|
176 |
LD_LV -> |
|
177 |
case lid of |
|
178 |
JSArray [vg, lv] -> do |
|
179 |
vg' <- readJSON vg |
|
180 |
lv' <- readJSON lv |
|
181 |
return $ LIDPlain vg' lv' |
|
182 |
_ -> fail $ "Can't read logical_id for plain type" |
|
183 |
LD_FILE -> |
|
184 |
case lid of |
|
185 |
JSArray [driver, path] -> do |
|
186 |
driver' <- readJSON driver |
|
187 |
path' <- readJSON path |
|
188 |
return $ LIDFile driver' path' |
|
189 |
_ -> fail $ "Can't read logical_id for file type" |
|
190 |
LD_BLOCKDEV -> |
|
191 |
case lid of |
|
192 |
JSArray [driver, path] -> do |
|
193 |
driver' <- readJSON driver |
|
194 |
path' <- readJSON path |
|
195 |
return $ LIDBlockDev driver' path' |
|
196 |
_ -> fail $ "Can't read logical_id for blockdev type" |
|
197 |
LD_RADOS -> |
|
198 |
case lid of |
|
199 |
JSArray [driver, path] -> do |
|
200 |
driver' <- readJSON driver |
|
201 |
path' <- readJSON path |
|
202 |
return $ LIDRados driver' path' |
|
203 |
_ -> fail $ "Can't read logical_id for rdb type" |
|
204 |
|
|
99 | 205 |
-- | Disk data structure. |
100 | 206 |
-- |
101 | 207 |
-- This is declared manually as it's a recursive structure, and our TH |
102 | 208 |
-- code currently can't build it. |
103 | 209 |
data Disk = Disk |
104 |
{ diskDevType :: DiskType |
|
105 |
-- , diskLogicalId :: String |
|
210 |
{ diskLogicalId :: DiskLogicalId |
|
106 | 211 |
-- , diskPhysicalId :: String |
107 | 212 |
, diskChildren :: [Disk] |
108 | 213 |
, diskIvName :: String |
... | ... | |
111 | 216 |
} deriving (Read, Show, Eq) |
112 | 217 |
|
113 | 218 |
$(buildObjectSerialisation "Disk" |
114 |
[ simpleField "dev_type" [t| DiskMode |]
|
|
115 |
-- , simpleField "logical_id" [t| String |]
|
|
219 |
[ customField 'decodeDLId 'encodeFullDLId $
|
|
220 |
simpleField "logical_id" [t| DiskLogicalId |]
|
|
116 | 221 |
-- , simpleField "physical_id" [t| String |] |
117 | 222 |
, defaultField [| [] |] $ simpleField "children" [t| [Disk] |] |
118 | 223 |
, defaultField [| "" |] $ simpleField "iv_name" [t| String |] |
Also available in: Unified diff