X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/c4f65a0e581edd93ad6ac1a03911b20fdef7b75d..77d43564742d2cc6dd80a062c4cf01059b58580c:/htools/Ganeti/Objects.hs diff --git a/htools/Ganeti/Objects.hs b/htools/Ganeti/Objects.hs index 0272801..18ca6df 100644 --- a/htools/Ganeti/Objects.hs +++ b/htools/Ganeti/Objects.hs @@ -29,20 +29,26 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA -} module Ganeti.Objects - ( NICMode(..) - , PartialNICParams(..) - , FilledNICParams(..) - , fillNICParams - , PartialNIC(..) + ( VType(..) + , vTypeFromRaw + , HvParams + , OsParams + , PartialNicParams(..) + , FilledNicParams(..) + , fillNicParams + , allNicParamFields + , PartialNic(..) + , FileDriver(..) + , BlockDriver(..) , DiskMode(..) , DiskType(..) , DiskLogicalId(..) , Disk(..) , DiskTemplate(..) - , PartialBEParams(..) - , FilledBEParams(..) - , fillBEParams - , Hypervisor(..) + , PartialBeParams(..) + , FilledBeParams(..) + , fillBeParams + , allBeParamFields , AdminState(..) , adminStateFromRaw , Instance(..) @@ -50,39 +56,127 @@ module Ganeti.Objects , PartialNDParams(..) , FilledNDParams(..) , fillNDParams + , allNDParamFields , Node(..) + , NodeRole(..) + , nodeRoleToRaw + , roleDescription , AllocPolicy(..) + , FilledISpecParams(..) + , PartialISpecParams(..) + , fillISpecParams + , allISpecParamFields + , FilledIPolicy(..) + , PartialIPolicy(..) + , fillIPolicy + , DiskParams , NodeGroup(..) + , IpFamily(..) + , ipFamilyToVersion + , fillDict + , ClusterHvParams + , OsHvParams + , ClusterBeParams + , ClusterOsParams + , ClusterNicParams , Cluster(..) , ConfigData(..) + , TimeStampObject(..) + , UuidObject(..) + , SerialNoObject(..) + , TagsObject(..) + , DictObject(..) -- re-exported from THH + , TagSet -- re-exported from THH + , Network(..) ) where +import Data.List (foldl') import Data.Maybe -import Text.JSON (makeObj, showJSON, readJSON, JSON, JSValue(..)) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Text.JSON (showJSON, readJSON, JSON, JSValue(..)) import qualified Text.JSON as J import qualified Ganeti.Constants as C -import Ganeti.HTools.JSON - +import Ganeti.JSON +import Ganeti.Types import Ganeti.THH --- * NIC definitions - -$(declareSADT "NICMode" - [ ("NMBridged", 'C.nicModeBridged) - , ("NMRouted", 'C.nicModeRouted) +-- * Generic definitions + +-- | Fills one map with keys from the other map, if not already +-- existing. Mirrors objects.py:FillDict. +fillDict :: (Ord k) => Map.Map k v -> Map.Map k v -> [k] -> Map.Map k v +fillDict defaults custom skip_keys = + let updated = Map.union custom defaults + in foldl' (flip Map.delete) updated skip_keys + +-- | The VTYPES, a mini-type system in Python. +$(declareSADT "VType" + [ ("VTypeString", 'C.vtypeString) + , ("VTypeMaybeString", 'C.vtypeMaybeString) + , ("VTypeBool", 'C.vtypeBool) + , ("VTypeSize", 'C.vtypeSize) + , ("VTypeInt", 'C.vtypeInt) + ]) +$(makeJSONInstance ''VType) + +-- | The hypervisor parameter type. This is currently a simple map, +-- without type checking on key/value pairs. +type HvParams = Container JSValue + +-- | The OS parameters type. This is, and will remain, a string +-- container, since the keys are dynamically declared by the OSes, and +-- the values are always strings. +type OsParams = Container String + +-- | Class of objects that have timestamps. +class TimeStampObject a where + cTimeOf :: a -> Double + mTimeOf :: a -> Double + +-- | Class of objects that have an UUID. +class UuidObject a where + uuidOf :: a -> String + +-- | Class of object that have a serial number. +class SerialNoObject a where + serialOf :: a -> Int + +-- | Class of objects that have tags. +class TagsObject a where + tagsOf :: a -> Set.Set String + +-- * Node role object + +$(declareSADT "NodeRole" + [ ("NROffline", 'C.nrOffline) + , ("NRDrained", 'C.nrDrained) + , ("NRRegular", 'C.nrRegular) + , ("NRCandidate", 'C.nrMcandidate) + , ("NRMaster", 'C.nrMaster) ]) -$(makeJSONInstance ''NICMode) +$(makeJSONInstance ''NodeRole) -$(buildParam "NIC" "nicp" +-- | The description of the node role. +roleDescription :: NodeRole -> String +roleDescription NROffline = "offline" +roleDescription NRDrained = "drained" +roleDescription NRRegular = "regular" +roleDescription NRCandidate = "master candidate" +roleDescription NRMaster = "master" + +-- * NIC definitions + +$(buildParam "Nic" "nicp" [ simpleField "mode" [t| NICMode |] , simpleField "link" [t| String |] ]) -$(buildObject "PartialNIC" "nic" +$(buildObject "PartialNic" "nic" [ simpleField "mac" [t| String |] , optionalField $ simpleField "ip" [t| String |] - , simpleField "nicparams" [t| PartialNICParams |] + , simpleField "nicparams" [t| PartialNicParams |] ]) -- * Disk definitions @@ -102,13 +196,6 @@ $(declareSADT "DiskType" ]) $(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) @@ -130,7 +217,7 @@ data DiskLogicalId | LIDFile FileDriver String -- ^ Driver, path | LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev) | LIDRados String String -- ^ Unused, path - deriving (Read, Show, Eq) + deriving (Show, Eq) -- | Mapping from a logical id to a disk type. lidDiskType :: DiskLogicalId -> DiskType @@ -175,35 +262,35 @@ decodeDLId obj lid = do mB' <- readJSON mB k' <- readJSON k return $ LIDDrbd8 nA' nB' p' mA' mB' k' - _ -> fail $ "Can't read logical_id for DRBD8 type" + _ -> 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" + _ -> 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" + _ -> 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" + _ -> 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" + _ -> fail "Can't read logical_id for rdb type" -- | Disk data structure. -- @@ -216,10 +303,10 @@ data Disk = Disk , diskIvName :: String , diskSize :: Int , diskMode :: DiskMode - } deriving (Read, Show, Eq) + } deriving (Show, Eq) $(buildObjectSerialisation "Disk" - [ customField 'decodeDLId 'encodeFullDLId $ + [ customField 'decodeDLId 'encodeFullDLId ["dev_type"] $ simpleField "logical_id" [t| DiskLogicalId |] -- , simpleField "physical_id" [t| String |] , defaultField [| [] |] $ simpleField "children" [t| [Disk] |] @@ -228,32 +315,8 @@ $(buildObjectSerialisation "Disk" , 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** -$(declareSADT "DiskTemplate" - [ ("DTDiskless", 'C.dtDiskless) - , ("DTFile", 'C.dtFile) - , ("DTSharedFile", 'C.dtSharedFile) - , ("DTPlain", 'C.dtPlain) - , ("DTBlock", 'C.dtBlock) - , ("DTDrbd8", 'C.dtDrbd8) - ]) -$(makeJSONInstance ''DiskTemplate) - $(declareSADT "AdminState" [ ("AdminOffline", 'C.adminstOffline) , ("AdminDown", 'C.adminstDown) @@ -261,7 +324,7 @@ $(declareSADT "AdminState" ]) $(makeJSONInstance ''AdminState) -$(buildParam "BE" "bep" $ +$(buildParam "Be" "bep" [ simpleField "minmem" [t| Int |] , simpleField "maxmem" [t| Int |] , simpleField "vcpus" [t| Int |] @@ -272,24 +335,97 @@ $(buildObject "Instance" "inst" $ [ simpleField "name" [t| String |] , simpleField "primary_node" [t| String |] , simpleField "os" [t| String |] - , simpleField "hypervisor" [t| String |] --- , simpleField "hvparams" [t| [(String, String)] |] - , simpleField "beparams" [t| PartialBEParams |] --- , simpleField "osparams" [t| [(String, String)] |] + , simpleField "hypervisor" [t| Hypervisor |] + , simpleField "hvparams" [t| HvParams |] + , simpleField "beparams" [t| PartialBeParams |] + , simpleField "osparams" [t| OsParams |] , simpleField "admin_state" [t| AdminState |] - , simpleField "nics" [t| [PartialNIC] |] + , simpleField "nics" [t| [PartialNic] |] , simpleField "disks" [t| [Disk] |] , simpleField "disk_template" [t| DiskTemplate |] - , optionalField $ simpleField "network_port" [t| Int |] + , optionalField $ simpleField "network_port" [t| Int |] ] ++ timeStampFields ++ uuidFields - ++ serialFields) + ++ serialFields + ++ tagsFields) +instance TimeStampObject Instance where + cTimeOf = instCtime + mTimeOf = instMtime + +instance UuidObject Instance where + uuidOf = instUuid + +instance SerialNoObject Instance where + serialOf = instSerial + +instance TagsObject Instance where + tagsOf = instTags + +-- * 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.ispecNicCount [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 |] +$(buildParam "ND" "ndp" + [ simpleField "oob_program" [t| String |] + , simpleField "spindle_count" [t| Int |] ]) $(buildObject "Node" "node" $ @@ -302,86 +438,192 @@ $(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 ++ uuidFields - ++ serialFields) + ++ serialFields + ++ tagsFields) + +instance TimeStampObject Node where + cTimeOf = nodeCtime + mTimeOf = nodeMtime + +instance UuidObject Node where + uuidOf = nodeUuid + +instance SerialNoObject Node where + serialOf = nodeSerial + +instance TagsObject Node where + tagsOf = nodeTags -- * NodeGroup definitions --- | The Group allocation policy type. --- --- Note that the order of constructors is important as the automatic --- Ord instance will order them in the order they are defined, so when --- changing this data type be careful about the interaction with the --- desired sorting order. --- --- FIXME: COPIED from Types.hs; we need to eliminate this duplication later -$(declareSADT "AllocPolicy" - [ ("AllocPreferred", 'C.allocPolicyPreferred) - , ("AllocLastResort", 'C.allocPolicyLastResort) - , ("AllocUnallocable", 'C.allocPolicyUnallocable) - ]) -$(makeJSONInstance ''AllocPolicy) +-- | The disk parameters type. +type DiskParams = Container (Container JSValue) $(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 |] + , simpleField "diskparams" [t| DiskParams |] ] ++ timeStampFields ++ uuidFields - ++ serialFields) + ++ serialFields + ++ tagsFields) + +instance TimeStampObject NodeGroup where + cTimeOf = groupCtime + mTimeOf = groupMtime + +instance UuidObject NodeGroup where + uuidOf = groupUuid + +instance SerialNoObject NodeGroup where + serialOf = groupSerial + +instance TagsObject NodeGroup where + tagsOf = groupTags + +-- | 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 HvParams (hvtype to hvparams mapping). +type ClusterHvParams = Container HvParams + +-- | Cluster Os-HvParams (os to hvparams mapping). +type OsHvParams = Container ClusterHvParams + +-- | Cluser BeParams. +type ClusterBeParams = Container FilledBeParams + +-- | Cluster OsParams. +type ClusterOsParams = Container OsParams + +-- | Cluster NicParams. +type ClusterNicParams = Container FilledNicParams + +-- | Cluster UID Pool, list (low, high) UID ranges. +type UidPool = [(Int, Int)] -- * Cluster definitions $(buildObject "Cluster" "cluster" $ - [ simpleField "rsahostkeypub" [t| String |] - , simpleField "highest_used_port" [t| Int |] - , simpleField "tcpudp_port_pool" [t| [Int] |] - , simpleField "mac_prefix" [t| String |] - , simpleField "volume_group_name" [t| String |] - , simpleField "reserved_lvs" [t| [String] |] --- , 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 "cluster_name" [t| String |] - , simpleField "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 "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 "default_iallocator" [t| String |] - , simpleField "hidden_os" [t| [String] |] - , simpleField "blacklisted_os" [t| [String] |] - , simpleField "primary_ip_family" [t| Int |] - , simpleField "prealloc_wipe_disks" [t| Bool |] + [ simpleField "rsahostkeypub" [t| String |] + , simpleField "highest_used_port" [t| Int |] + , simpleField "tcpudp_port_pool" [t| [Int] |] + , simpleField "mac_prefix" [t| String |] + , simpleField "volume_group_name" [t| String |] + , simpleField "reserved_lvs" [t| [String] |] + , optionalField $ + simpleField "drbd_usermode_helper" [t| String |] + , simpleField "master_node" [t| String |] + , simpleField "master_ip" [t| String |] + , simpleField "master_netdev" [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 "enabled_hypervisors" [t| [Hypervisor] |] + , simpleField "hvparams" [t| ClusterHvParams |] + , simpleField "os_hvp" [t| OsHvParams |] + , simpleField "beparams" [t| ClusterBeParams |] + , simpleField "osparams" [t| ClusterOsParams |] + , simpleField "nicparams" [t| ClusterNicParams |] + , simpleField "ndparams" [t| FilledNDParams |] + , simpleField "diskparams" [t| DiskParams |] + , 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| UidPool |] + , simpleField "default_iallocator" [t| String |] + , simpleField "hidden_os" [t| [String] |] + , simpleField "blacklisted_os" [t| [String] |] + , simpleField "primary_ip_family" [t| IpFamily |] + , simpleField "prealloc_wipe_disks" [t| Bool |] + , simpleField "ipolicy" [t| FilledIPolicy |] ] - ++ serialFields) + ++ timeStampFields + ++ uuidFields + ++ serialFields + ++ tagsFields) + +instance TimeStampObject Cluster where + cTimeOf = clusterCtime + mTimeOf = clusterMtime + +instance UuidObject Cluster where + uuidOf = clusterUuid + +instance SerialNoObject Cluster where + serialOf = clusterSerial + +instance TagsObject Cluster where + tagsOf = clusterTags -- * 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) + +instance SerialNoObject ConfigData where + serialOf = configSerial + +-- * Network definitions + +-- FIXME: Not all types might be correct here, since they +-- haven't been exhaustively deduced from the python code yet. +$(buildObject "Network" "network" $ + [ simpleField "name" [t| NonEmptyString |] + , optionalField $ + simpleField "network_type" [t| NetworkType |] + , optionalField $ + simpleField "mac_prefix" [t| String |] + , optionalField $ + simpleField "family" [t| Int |] + , simpleField "network" [t| NonEmptyString |] + , optionalField $ + simpleField "network6" [t| String |] + , optionalField $ + simpleField "gateway" [t| String |] + , optionalField $ + simpleField "gateway6" [t| String |] + , optionalField $ + simpleField "size" [t| J.JSValue |] + , optionalField $ + simpleField "reservations" [t| String |] + , optionalField $ + simpleField "ext_reservations" [t| String |] + ] + ++ serialFields + ++ tagsFields) + +instance SerialNoObject Network where + serialOf = networkSerial + +instance TagsObject Network where + tagsOf = networkTags +