X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/b09cce6429a36523e37b902023d037f9258b7296..b9612abb7e31ea1bddfd390c52a5eb6db2f74c97:/htools/Ganeti/Objects.hs diff --git a/htools/Ganeti/Objects.hs b/htools/Ganeti/Objects.hs index d20edb4..dfc6480 100644 --- a/htools/Ganeti/Objects.hs +++ b/htools/Ganeti/Objects.hs @@ -29,13 +29,18 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA -} module Ganeti.Objects - ( HvParams + ( VType(..) + , vTypeFromRaw + , HvParams , OsParams , NICMode(..) , PartialNicParams(..) , FilledNicParams(..) , fillNicParams + , allNicParamFields , PartialNic(..) + , FileDriver(..) + , BlockDriver(..) , DiskMode(..) , DiskType(..) , DiskLogicalId(..) @@ -44,6 +49,7 @@ module Ganeti.Objects , PartialBeParams(..) , FilledBeParams(..) , fillBeParams + , allBeParamFields , Hypervisor(..) , AdminState(..) , adminStateFromRaw @@ -52,11 +58,16 @@ module Ganeti.Objects , PartialNDParams(..) , FilledNDParams(..) , fillNDParams + , allNDParamFields , Node(..) + , NodeRole(..) + , nodeRoleToRaw + , roleDescription , AllocPolicy(..) , FilledISpecParams(..) , PartialISpecParams(..) , fillISpecParams + , allISpecParamFields , FilledIPolicy(..) , PartialIPolicy(..) , fillIPolicy @@ -72,16 +83,23 @@ module Ganeti.Objects , ClusterNicParams , Cluster(..) , ConfigData(..) + , TimeStampObject(..) + , UuidObject(..) + , SerialNoObject(..) + , TagsObject(..) + , DictObject(..) -- re-exported from THH + , TagSet -- re-exported from THH ) where import Data.List (foldl') import Data.Maybe import qualified Data.Map as Map +import qualified Data.Set as Set import Text.JSON (makeObj, 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.THH @@ -94,6 +112,16 @@ 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 @@ -103,6 +131,42 @@ type HvParams = Container JSValue -- 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 ''NodeRole) + +-- | 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 $(declareSADT "NICMode" @@ -212,35 +276,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. -- @@ -299,7 +363,7 @@ $(declareSADT "AdminState" ]) $(makeJSONInstance ''AdminState) -$(buildParam "Be" "bep" $ +$(buildParam "Be" "bep" [ simpleField "minmem" [t| Int |] , simpleField "maxmem" [t| Int |] , simpleField "vcpus" [t| Int |] @@ -325,19 +389,33 @@ $(buildObject "Instance" "inst" $ ++ 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" $ +$(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" $ +$(buildObject "PartialIPolicy" "ipolicy" [ renameField "MinSpecP" $ simpleField "min" [t| PartialISpecParams |] , renameField "MaxSpecP" $ simpleField "max" [t| PartialISpecParams |] , renameField "StdSpecP" $ simpleField "std" [t| PartialISpecParams |] @@ -351,7 +429,7 @@ $(buildObject "PartialIPolicy" "ipolicy" $ -- | Custom filled ipolicy. This is not built via buildParam since it -- has a special 2-level inheritance mode. -$(buildObject "FilledIPolicy" "ipolicy" $ +$(buildObject "FilledIPolicy" "ipolicy" [ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |] , renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |] , renameField "StdSpec" $ simpleField "std" [t| FilledISpecParams |] @@ -384,7 +462,7 @@ fillIPolicy (FilledIPolicy { ipolicyMinSpec = fmin } -- * Node definitions -$(buildParam "ND" "ndp" $ +$(buildParam "ND" "ndp" [ simpleField "oob_program" [t| String |] , simpleField "spindle_count" [t| Int |] ]) @@ -407,6 +485,19 @@ $(buildObject "Node" "node" $ ++ 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. @@ -440,6 +531,19 @@ $(buildObject "NodeGroup" "group" $ ++ 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) @@ -489,7 +593,7 @@ $(buildObject "Cluster" "cluster" $ , simpleField "cluster_name" [t| String |] , simpleField "file_storage_dir" [t| String |] , simpleField "shared_file_storage_dir" [t| String |] - , simpleField "enabled_hypervisors" [t| [String] |] + , simpleField "enabled_hypervisors" [t| [Hypervisor] |] , simpleField "hvparams" [t| ClusterHvParams |] , simpleField "os_hvp" [t| OsHvParams |] , simpleField "beparams" [t| ClusterBeParams |] @@ -509,11 +613,24 @@ $(buildObject "Cluster" "cluster" $ , 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" $ @@ -525,3 +642,6 @@ $(buildObject "ConfigData" "config" $ , simpleField "instances" [t| Container Instance |] ] ++ serialFields) + +instance SerialNoObject ConfigData where + serialOf = configSerial