, PartialNIC(..)
, DiskMode(..)
, DiskType(..)
+ , DiskLogicalId(..)
, Disk(..)
, DiskTemplate(..)
, PartialBEParams(..)
, FilledBEParams(..)
, fillBEParams
+ , Hypervisor(..)
+ , AdminState(..)
+ , adminStateFromRaw
, Instance(..)
, toDictInstance
, PartialNDParams(..)
, fillNDParams
, Node(..)
, AllocPolicy(..)
+ , FilledISpecParams(..)
+ , PartialISpecParams(..)
+ , fillISpecParams
+ , FilledIPolicy(..)
+ , PartialIPolicy(..)
+ , fillIPolicy
, NodeGroup(..)
+ , IpFamily(..)
+ , ipFamilyToVersion
, Cluster(..)
, ConfigData(..)
) 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
, ("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
} 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 |]
, defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
])
+-- * Hypervisor definitions
+
+-- | This may be due to change when we add hypervisor parameters.
+$(declareSADT "Hypervisor"
+ [ ( "Kvm", 'C.htKvm )
+ , ( "XenPvm", 'C.htXenPvm )
+ , ( "Chroot", 'C.htChroot )
+ , ( "XenHvm", 'C.htXenHvm )
+ , ( "Lxc", 'C.htLxc )
+ , ( "Fake", 'C.htFake )
+ ])
+$(makeJSONInstance ''Hypervisor)
+
-- * Instance definitions
-- | Instance disk template type. **Copied from HTools/Types.hs**
, ("DTPlain", 'C.dtPlain)
, ("DTBlock", 'C.dtBlock)
, ("DTDrbd8", 'C.dtDrbd8)
+ , ("DTRados", 'C.dtRbd)
])
$(makeJSONInstance ''DiskTemplate)
++ uuidFields
++ serialFields)
+-- * IPolicy definitions
+
+$(buildParam "ISpec" "ispec" $
+ [ simpleField C.ispecMemSize [t| Int |]
+ , simpleField C.ispecDiskSize [t| Int |]
+ , simpleField C.ispecDiskCount [t| Int |]
+ , simpleField C.ispecCpuCount [t| Int |]
+ , simpleField C.ispecSpindleUse [t| Int |]
+ ])
+
+-- | Custom partial ipolicy. This is not built via buildParam since it
+-- has a special 2-level inheritance mode.
+$(buildObject "PartialIPolicy" "ipolicy" $
+ [ renameField "MinSpecP" $ simpleField "min" [t| PartialISpecParams |]
+ , renameField "MaxSpecP" $ simpleField "max" [t| PartialISpecParams |]
+ , renameField "StdSpecP" $ simpleField "std" [t| PartialISpecParams |]
+ , optionalField . renameField "SpindleRatioP"
+ $ simpleField "spindle-ratio" [t| Double |]
+ , optionalField . renameField "VcpuRatioP"
+ $ simpleField "vcpu-ratio" [t| Double |]
+ , optionalField . renameField "DiskTemplatesP"
+ $ simpleField "disk-templates" [t| [DiskTemplate] |]
+ ])
+
+-- | Custom filled ipolicy. This is not built via buildParam since it
+-- has a special 2-level inheritance mode.
+$(buildObject "FilledIPolicy" "ipolicy" $
+ [ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |]
+ , renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |]
+ , renameField "StdSpec" $ simpleField "std" [t| FilledISpecParams |]
+ , simpleField "spindle-ratio" [t| Double |]
+ , simpleField "vcpu-ratio" [t| Double |]
+ , simpleField "disk-templates" [t| [DiskTemplate] |]
+ ])
+
+-- | Custom filler for the ipolicy types.
+fillIPolicy :: FilledIPolicy -> PartialIPolicy -> FilledIPolicy
+fillIPolicy (FilledIPolicy { ipolicyMinSpec = fmin
+ , ipolicyMaxSpec = fmax
+ , ipolicyStdSpec = fstd
+ , ipolicySpindleRatio = fspindleRatio
+ , ipolicyVcpuRatio = fvcpuRatio
+ , ipolicyDiskTemplates = fdiskTemplates})
+ (PartialIPolicy { ipolicyMinSpecP = pmin
+ , ipolicyMaxSpecP = pmax
+ , ipolicyStdSpecP = pstd
+ , ipolicySpindleRatioP = pspindleRatio
+ , ipolicyVcpuRatioP = pvcpuRatio
+ , ipolicyDiskTemplatesP = pdiskTemplates}) =
+ FilledIPolicy { ipolicyMinSpec = fillISpecParams fmin pmin
+ , ipolicyMaxSpec = fillISpecParams fmax pmax
+ , ipolicyStdSpec = fillISpecParams fstd pstd
+ , ipolicySpindleRatio = fromMaybe fspindleRatio pspindleRatio
+ , ipolicyVcpuRatio = fromMaybe fvcpuRatio pvcpuRatio
+ , ipolicyDiskTemplates = fromMaybe fdiskTemplates
+ pdiskTemplates
+ }
-- * Node definitions
$(buildParam "ND" "ndp" $
- [ simpleField "oob_program" [t| String |]
+ [ simpleField "oob_program" [t| String |]
+ , simpleField "spindle_count" [t| Int |]
])
$(buildObject "Node" "node" $
, simpleField "group" [t| String |]
, simpleField "master_capable" [t| Bool |]
, simpleField "vm_capable" [t| Bool |]
--- , simpleField "ndparams" [t| PartialNDParams |]
+ , simpleField "ndparams" [t| PartialNDParams |]
, simpleField "powered" [t| Bool |]
]
++ timeStampFields
$(buildObject "NodeGroup" "group" $
[ simpleField "name" [t| String |]
, defaultField [| [] |] $ simpleField "members" [t| [String] |]
--- , simpleField "ndparams" [t| PartialNDParams |]
- , simpleField "alloc_policy" [t| AllocPolicy |]
+ , simpleField "ndparams" [t| PartialNDParams |]
+ , simpleField "alloc_policy" [t| AllocPolicy |]
+ , simpleField "ipolicy" [t| PartialIPolicy |]
]
++ timeStampFields
++ uuidFields
++ serialFields)
+-- | IP family type
+$(declareIADT "IpFamily"
+ [ ("IpFamilyV4", 'C.ip4Family)
+ , ("IpFamilyV6", 'C.ip6Family)
+ ])
+$(makeJSONInstance ''IpFamily)
+
+-- | Conversion from IP family to IP version. This is needed because
+-- Python uses both, depending on context.
+ipFamilyToVersion :: IpFamily -> Int
+ipFamilyToVersion IpFamilyV4 = C.ip4Version
+ipFamilyToVersion IpFamilyV6 = C.ip6Version
+
-- * Cluster definitions
$(buildObject "Cluster" "cluster" $
[ simpleField "rsahostkeypub" [t| String |]
, simpleField "mac_prefix" [t| String |]
, simpleField "volume_group_name" [t| String |]
, simpleField "reserved_lvs" [t| [String] |]
--- , simpleField "drbd_usermode_helper" [t| String |]
+ , optionalField $ simpleField "drbd_usermode_helper" [t| String |]
-- , simpleField "default_bridge" [t| String |]
-- , simpleField "default_hypervisor" [t| String |]
, simpleField "master_node" [t| String |]
, simpleField "master_ip" [t| String |]
, simpleField "master_netdev" [t| String |]
--- , simpleField "master_netmask" [t| String |]
+ , simpleField "master_netmask" [t| Int |]
+ , simpleField "use_external_mip_script" [t| Bool |]
, simpleField "cluster_name" [t| String |]
, simpleField "file_storage_dir" [t| String |]
--- , simpleField "shared_file_storage_dir" [t| String |]
+ , simpleField "shared_file_storage_dir" [t| String |]
, simpleField "enabled_hypervisors" [t| [String] |]
-- , simpleField "hvparams" [t| [(String, [(String, String)])] |]
-- , simpleField "os_hvp" [t| [(String, String)] |]
- , containerField $ simpleField "beparams" [t| FilledBEParams |]
--- , simpleField "osparams" [t| [(String, String)] |]
- , containerField $ simpleField "nicparams" [t| FilledNICParams |]
--- , simpleField "ndparams" [t| FilledNDParams |]
+ , simpleField "beparams" [t| Container FilledBEParams |]
+ , simpleField "osparams" [t| Container (Container String) |]
+ , simpleField "nicparams" [t| Container FilledNICParams |]
+ , simpleField "ndparams" [t| FilledNDParams |]
, simpleField "candidate_pool_size" [t| Int |]
, simpleField "modify_etc_hosts" [t| Bool |]
, simpleField "modify_ssh_setup" [t| Bool |]
, simpleField "maintain_node_health" [t| Bool |]
- , simpleField "uid_pool" [t| [Int] |]
+ , simpleField "uid_pool" [t| [(Int, Int)] |]
, simpleField "default_iallocator" [t| String |]
, simpleField "hidden_os" [t| [String] |]
, simpleField "blacklisted_os" [t| [String] |]
- , simpleField "primary_ip_family" [t| Int |]
+ , simpleField "primary_ip_family" [t| IpFamily |]
, simpleField "prealloc_wipe_disks" [t| Bool |]
+ , simpleField "ipolicy" [t| FilledIPolicy |]
]
- ++ serialFields)
+ ++ serialFields
+ ++ timeStampFields
+ ++ uuidFields
+ ++ tagsFields)
-- * ConfigData definitions
$(buildObject "ConfigData" "config" $
-- timeStampFields ++
- [ simpleField "version" [t| Int |]
- , simpleField "cluster" [t| Cluster |]
- , containerField $ simpleField "nodes" [t| Node |]
- , containerField $ simpleField "nodegroups" [t| NodeGroup |]
- , containerField $ simpleField "instances" [t| Instance |]
+ [ simpleField "version" [t| Int |]
+ , simpleField "cluster" [t| Cluster |]
+ , simpleField "nodes" [t| Container Node |]
+ , simpleField "nodegroups" [t| Container NodeGroup |]
+ , simpleField "instances" [t| Container Instance |]
]
++ serialFields)
projects / ganeti-local / blobdiff