Commit 2e12944a authored by Iustin Pop's avatar Iustin Pop
Browse files

Add disk logical ID support in Objects.hs



This is a complex field, so we have to do a lot of manual work for now.

The complexity arises from the fact that the contents of the field,
and the way to parse it, depends on the disk type field, so we don't
have a single, static way of parsing it. Hence we needed the
extensions to the Template Haskell code.

Since we now can both load and save the disk type, we can remove the
in-memory (duplicate) disk type from the disk objects, relying only on
the logical ID to hold the type information.
Signed-off-by: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarRené Nussbaumer <rn@google.com>
parent 5c755a4d
......@@ -36,6 +36,7 @@ module Ganeti.Objects
, PartialNIC(..)
, DiskMode(..)
, DiskType(..)
, DiskLogicalId(..)
, Disk(..)
, DiskTemplate(..)
, PartialBEParams(..)
......@@ -54,7 +55,8 @@ module Ganeti.Objects
) where
import Data.Maybe
import Text.JSON (makeObj, showJSON, readJSON)
import Text.JSON (makeObj, showJSON, readJSON, JSON, JSValue(..))
import qualified Text.JSON as J
import qualified Ganeti.Constants as C
import Ganeti.HTools.JSON
......@@ -93,16 +95,119 @@ $(declareSADT "DiskType"
, ("LD_DRBD8", 'C.ldDrbd8)
, ("LD_FILE", 'C.ldFile)
, ("LD_BLOCKDEV", 'C.ldBlockdev)
, ("LD_RADOS", 'C.ldRbd)
])
$(makeJSONInstance ''DiskType)
-- | The file driver type.
$(declareSADT "FileDriver"
[ ("FileLoop", 'C.fdLoop)
, ("FileBlktap", 'C.fdBlktap)
])
$(makeJSONInstance ''FileDriver)
-- | The persistent block driver type. Currently only one type is allowed.
$(declareSADT "BlockDriver"
[ ("BlockDrvManual", 'C.blockdevDriverManual)
])
$(makeJSONInstance ''BlockDriver)
-- | Constant for the dev_type key entry in the disk config.
devType :: String
devType = "dev_type"
-- | The disk configuration type. This includes the disk type itself,
-- for a more complete consistency. Note that since in the Python
-- code-base there's no authoritative place where we document the
-- logical id, this is probably a good reference point.
data DiskLogicalId
= LIDPlain String String -- ^ Volume group, logical volume
| LIDDrbd8 String String Int Int Int String
-- ^ NodeA, NodeB, Port, MinorA, MinorB, Secret
| LIDFile FileDriver String -- ^ Driver, path
| LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev)
| LIDRados String String -- ^ Unused, path
deriving (Read, Show, Eq)
-- | Mapping from a logical id to a disk type.
lidDiskType :: DiskLogicalId -> DiskType
lidDiskType (LIDPlain {}) = LD_LV
lidDiskType (LIDDrbd8 {}) = LD_DRBD8
lidDiskType (LIDFile {}) = LD_FILE
lidDiskType (LIDBlockDev {}) = LD_BLOCKDEV
lidDiskType (LIDRados {}) = LD_RADOS
-- | Builds the extra disk_type field for a given logical id.
lidEncodeType :: DiskLogicalId -> [(String, JSValue)]
lidEncodeType v = [(devType, showJSON . lidDiskType $ v)]
-- | Custom encoder for DiskLogicalId (logical id only).
encodeDLId :: DiskLogicalId -> JSValue
encodeDLId (LIDPlain vg lv) = JSArray [showJSON vg, showJSON lv]
encodeDLId (LIDDrbd8 nodeA nodeB port minorA minorB key) =
JSArray [ showJSON nodeA, showJSON nodeB, showJSON port
, showJSON minorA, showJSON minorB, showJSON key ]
encodeDLId (LIDRados pool name) = JSArray [showJSON pool, showJSON name]
encodeDLId (LIDFile driver name) = JSArray [showJSON driver, showJSON name]
encodeDLId (LIDBlockDev driver name) = JSArray [showJSON driver, showJSON name]
-- | Custom encoder for DiskLogicalId, composing both the logical id
-- and the extra disk_type field.
encodeFullDLId :: DiskLogicalId -> (JSValue, [(String, JSValue)])
encodeFullDLId v = (encodeDLId v, lidEncodeType v)
-- | Custom decoder for DiskLogicalId. This is manual for now, since
-- we don't have yet automation for separate-key style fields.
decodeDLId :: [(String, JSValue)] -> JSValue -> J.Result DiskLogicalId
decodeDLId obj lid = do
dtype <- fromObj obj devType
case dtype of
LD_DRBD8 ->
case lid of
JSArray [nA, nB, p, mA, mB, k] -> do
nA' <- readJSON nA
nB' <- readJSON nB
p' <- readJSON p
mA' <- readJSON mA
mB' <- readJSON mB
k' <- readJSON k
return $ LIDDrbd8 nA' nB' p' mA' mB' k'
_ -> fail $ "Can't read logical_id for DRBD8 type"
LD_LV ->
case lid of
JSArray [vg, lv] -> do
vg' <- readJSON vg
lv' <- readJSON lv
return $ LIDPlain vg' lv'
_ -> fail $ "Can't read logical_id for plain type"
LD_FILE ->
case lid of
JSArray [driver, path] -> do
driver' <- readJSON driver
path' <- readJSON path
return $ LIDFile driver' path'
_ -> fail $ "Can't read logical_id for file type"
LD_BLOCKDEV ->
case lid of
JSArray [driver, path] -> do
driver' <- readJSON driver
path' <- readJSON path
return $ LIDBlockDev driver' path'
_ -> fail $ "Can't read logical_id for blockdev type"
LD_RADOS ->
case lid of
JSArray [driver, path] -> do
driver' <- readJSON driver
path' <- readJSON path
return $ LIDRados driver' path'
_ -> fail $ "Can't read logical_id for rdb type"
-- | Disk data structure.
--
-- This is declared manually as it's a recursive structure, and our TH
-- code currently can't build it.
data Disk = Disk
{ diskDevType :: DiskType
-- , diskLogicalId :: String
{ diskLogicalId :: DiskLogicalId
-- , diskPhysicalId :: String
, diskChildren :: [Disk]
, diskIvName :: String
......@@ -111,8 +216,8 @@ data Disk = Disk
} deriving (Read, Show, Eq)
$(buildObjectSerialisation "Disk"
[ simpleField "dev_type" [t| DiskMode |]
-- , simpleField "logical_id" [t| String |]
[ customField 'decodeDLId 'encodeFullDLId $
simpleField "logical_id" [t| DiskLogicalId |]
-- , simpleField "physical_id" [t| String |]
, defaultField [| [] |] $ simpleField "children" [t| [Disk] |]
, defaultField [| "" |] $ simpleField "iv_name" [t| String |]
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment