Commit 212b66c3 authored by Helga Velroyen's avatar Helga Velroyen
Browse files

Turn 'exclusive_storage' into storage parameter (hs)



This is the haskell implementation of my patch "Extend RPC call
'node_info' by storage parameters". It turns the 'exclusive
storage' flag into a storage parameter of the LVM storage types.
Besides that, this patch moves some types into the Types.hs.
Signed-off-by: default avatarHelga Velroyen <helgav@google.com>
Reviewed-by: default avatarKlaus Aehlig <aehlig@google.com>
parent a59c31ca
......@@ -45,6 +45,9 @@ module Ganeti.Common
, parseOptsInner
, parseOptsCmds
, genericMainCmds
, fillUpList
, fillPairFromMaybe
, pickPairUnique
) where
import Control.Monad (foldM)
......@@ -341,3 +344,28 @@ genericMainCmds defaults personalities genopts = do
(opts, args, fn) <-
parseOptsCmds defaults cmd_args prog personalities genopts
fn opts args
-- | Order a list of pairs in the order of the given list and fill up
-- the list for elements that don't have a matching pair
fillUpList :: ([(a, b)] -> a -> (a, b)) -> [a] -> [(a, b)] -> [(a, b)]
fillUpList fill_fn inputs pairs =
map (fill_fn pairs) inputs
-- | Fill up a pair with fillup element if no matching pair is present
fillPairFromMaybe :: (a -> (a, b)) -> (a -> [(a, b)] -> Maybe (a, b))
-> [(a, b)] -> a -> (a, b)
fillPairFromMaybe fill_fn pick_fn pairs element = fromMaybe (fill_fn element)
(pick_fn element pairs)
-- | Check if the given element matches the given pair
isMatchingPair :: (Eq a) => a -> (a, b) -> Bool
isMatchingPair element (pair_element, _) = element == pair_element
-- | Pick a specific element's pair from the list
pickPairUnique :: (Eq a) => a -> [(a, b)] -> Maybe (a, b)
pickPairUnique element pairs =
let res = filter (isMatchingPair element) pairs
in case res of
[x] -> Just x
-- if we have more than one result, we should get suspcious
_ -> Nothing
......@@ -36,6 +36,7 @@ import qualified Data.Map as Map
import qualified Text.JSON as J
import Ganeti.Config
import Ganeti.Common
import Ganeti.Objects
import Ganeti.JSON
import Ganeti.Rpc
......@@ -228,6 +229,10 @@ fieldsMap :: FieldMap Node Runtime
fieldsMap =
Map.fromList $ map (\v@(f, _, _) -> (fdefName f, v)) nodeFields
-- | Create an RPC result for a broken node
rpcResultNodeBroken :: Node -> (Node, Runtime)
rpcResultNodeBroken node = (node, Left (RpcResultError "Broken configuration"))
-- | Collect live data from RPC query if enabled.
--
-- FIXME: Check which fields we actually need and possibly send empty
......@@ -237,20 +242,12 @@ collectLiveData:: Bool -> ConfigData -> [Node] -> IO [(Node, Runtime)]
collectLiveData False _ nodes =
return $ zip nodes (repeat $ Left (RpcResultError "Live data disabled"))
collectLiveData True cfg nodes = do
let storage_units = getClusterStorageUnits cfg
hvs = [getDefaultHypervisorSpec cfg]
step n (bn, gn, em) =
let ndp' = getNodeNdParams cfg n
in case ndp' of
Just ndp -> (bn, n : gn,
(nodeName n, ndpExclusiveStorage ndp) : em)
Nothing -> (n : bn, gn, em)
(bnodes, gnodes, emap) = foldr step ([], [], []) nodes
rpcres <- executeRpcCall gnodes (RpcCallNodeInfo storage_units hvs
(Map.fromList emap))
-- FIXME: The order of nodes in the result could be different from the input
return $ zip bnodes (repeat $ Left (RpcResultError "Broken configuration"))
++ rpcres
let hvs = [getDefaultHypervisorSpec cfg]
good_nodes = nodesWithValidConfig cfg nodes
storage_units = getStorageUnitsOfNodes cfg good_nodes
rpcres <- executeRpcCall good_nodes (RpcCallNodeInfo storage_units hvs)
return $ fillUpList (fillPairFromMaybe rpcResultNodeBroken pickPairUnique)
nodes rpcres
-- | Looks up the default hypervisor and it's hvparams
getDefaultHypervisorSpec :: ConfigData -> (Hypervisor, HvParams)
......
......@@ -337,9 +337,8 @@ instance Rpc RpcCallInstanceList RpcResultInstanceList where
-- | NodeInfo
-- Return node information.
$(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo"
[ simpleField "storage_units" [t| [ (StorageType, String) ] |]
[ simpleField "storage_units" [t| Map.Map String [StorageUnit] |]
, simpleField "hypervisors" [t| [ (Hypervisor, HvParams) ] |]
, simpleField "exclusive_storage" [t| Map.Map String Bool |]
])
$(buildObject "StorageInfo" "storageInfo"
......@@ -371,11 +370,10 @@ instance RpcCall RpcCallNodeInfo where
rpcCallTimeout _ = rpcTimeoutToRaw Urgent
rpcCallAcceptOffline _ = False
rpcCallData n call = J.encode
( rpcCallNodeInfoStorageUnits call
, rpcCallNodeInfoHypervisors call
, fromMaybe (error $ "Programmer error: missing parameter for node named "
( fromMaybe (error $ "Programmer error: missing parameter for node named "
++ nodeName n)
$ Map.lookup (nodeName n) (rpcCallNodeInfoExclusiveStorage call)
$ Map.lookup (nodeUuid n) (rpcCallNodeInfoStorageUnits call)
, rpcCallNodeInfoHypervisors call
)
instance Rpc RpcCallNodeInfo RpcResultNodeInfo where
......
......@@ -24,17 +24,21 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module Ganeti.Storage.Utils
( getClusterStorageUnits
( getStorageUnitsOfNodes
, nodesWithValidConfig
) where
import Ganeti.Config
import Ganeti.Objects
import Ganeti.Types
import qualified Ganeti.Types as T
type StorageUnit = (StorageType, String)
import Control.Monad
import Data.Maybe
import qualified Data.Map as M
-- | Get the cluster's default storage unit for a given disk template
getDefaultStorageKey :: ConfigData -> DiskTemplate -> Maybe String
getDefaultStorageKey :: ConfigData -> DiskTemplate -> Maybe StorageKey
getDefaultStorageKey cfg T.DTDrbd8 = clusterVolumeGroupName $ configCluster cfg
getDefaultStorageKey cfg T.DTPlain = clusterVolumeGroupName $ configCluster cfg
getDefaultStorageKey cfg T.DTFile =
......@@ -44,13 +48,13 @@ getDefaultStorageKey cfg T.DTSharedFile =
getDefaultStorageKey _ _ = Nothing
-- | Get the cluster's default spindle storage unit
getDefaultSpindleSU :: ConfigData -> (StorageType, Maybe String)
getDefaultSpindleSU :: ConfigData -> (StorageType, Maybe StorageKey)
getDefaultSpindleSU cfg =
(T.StorageLvmPv, clusterVolumeGroupName $ configCluster cfg)
-- | Get the cluster's storage units from the configuration
getClusterStorageUnits :: ConfigData -> [StorageUnit]
getClusterStorageUnits cfg = foldSUs (maybe_units ++ [spindle_unit])
getClusterStorageUnitRaws :: ConfigData -> [StorageUnitRaw]
getClusterStorageUnitRaws cfg = foldSUs (maybe_units ++ [spindle_unit])
where disk_templates = clusterEnabledDiskTemplates $ configCluster cfg
storage_types = map diskTemplateToStorageType disk_templates
maybe_units = zip storage_types (map (getDefaultStorageKey cfg)
......@@ -58,20 +62,31 @@ getClusterStorageUnits cfg = foldSUs (maybe_units ++ [spindle_unit])
spindle_unit = getDefaultSpindleSU cfg
-- | fold the storage unit list by sorting out the ones without keys
foldSUs :: [(StorageType, Maybe String)] -> [StorageUnit]
foldSUs :: [(StorageType, Maybe StorageKey)] -> [StorageUnitRaw]
foldSUs = foldr ff []
where ff (st, Just sk) acc = (st, sk) : acc
where ff (st, Just sk) acc = SURaw st sk : acc
ff (_, Nothing) acc = acc
-- | Mapping fo disk templates to storage type
-- FIXME: This is semantically the same as the constant
-- C.diskTemplatesStorageType
diskTemplateToStorageType :: DiskTemplate -> StorageType
diskTemplateToStorageType T.DTExt = T.StorageExt
diskTemplateToStorageType T.DTFile = T.StorageFile
diskTemplateToStorageType T.DTSharedFile = T.StorageFile
diskTemplateToStorageType T.DTDrbd8 = T.StorageLvmVg
diskTemplateToStorageType T.DTPlain = T.StorageLvmVg
diskTemplateToStorageType T.DTRbd = T.StorageRados
diskTemplateToStorageType T.DTDiskless = T.StorageDiskless
diskTemplateToStorageType T.DTBlock = T.StorageBlock
-- | Gets the value of the 'exclusive storage' flag of the node
getExclusiveStorage :: ConfigData -> Node -> Maybe Bool
getExclusiveStorage cfg n = liftM ndpExclusiveStorage (getNodeNdParams cfg n)
-- | Determines whether a node's config contains an 'exclusive storage' flag
hasExclusiveStorageFlag :: ConfigData -> Node -> Bool
hasExclusiveStorageFlag cfg = isJust . getExclusiveStorage cfg
-- | Filter for nodes with a valid config
nodesWithValidConfig :: ConfigData -> [Node] -> [Node]
nodesWithValidConfig cfg = filter (hasExclusiveStorageFlag cfg)
-- | Get the storage units of the node
getStorageUnitsOfNode :: ConfigData -> Node -> [StorageUnit]
getStorageUnitsOfNode cfg n =
let clusterSUs = getClusterStorageUnitRaws cfg
es = fromJust (getExclusiveStorage cfg n)
in map (addParamsToStorageUnit es) clusterSUs
-- | Get the storage unit map for all nodes
getStorageUnitsOfNodes :: ConfigData -> [Node] -> M.Map String [StorageUnit]
getStorageUnitsOfNodes cfg ns =
M.fromList (map (\n -> (nodeUuid n, getStorageUnitsOfNode cfg n)) ns)
......@@ -63,6 +63,7 @@ module Ganeti.Types
, hypervisorToRaw
, OobCommand(..)
, StorageType(..)
, storageTypeToRaw
, NodeEvacMode(..)
, FileDriver(..)
, InstCreateMode(..)
......@@ -95,6 +96,11 @@ module Ganeti.Types
, ELogType(..)
, ReasonElem
, ReasonTrail
, StorageUnit(..)
, StorageUnitRaw(..)
, StorageKey
, addParamsToStorageUnit
, diskTemplateToStorageType
) where
import Control.Monad (liftM)
......@@ -311,6 +317,80 @@ $(THH.declareSADT "StorageType"
])
$(THH.makeJSONInstance ''StorageType)
-- | Storage keys are identifiers for storage units. Their content varies
-- depending on the storage type, for example a storage key for LVM storage
-- is the volume group name.
type StorageKey = String
-- | Storage parameters
type SPExclusiveStorage = Bool
-- | Storage units without storage-type-specific parameters
data StorageUnitRaw = SURaw StorageType StorageKey
-- | Full storage unit with storage-type-specific parameters
data StorageUnit = SUFile StorageKey
| SULvmPv StorageKey SPExclusiveStorage
| SULvmVg StorageKey SPExclusiveStorage
| SUDiskless StorageKey
| SUBlock StorageKey
| SURados StorageKey
| SUExt StorageKey
deriving (Eq)
instance Show StorageUnit where
show (SUFile key) = showSUSimple StorageFile key
show (SULvmPv key es) = showSULvm StorageLvmPv key es
show (SULvmVg key es) = showSULvm StorageLvmVg key es
show (SUDiskless key) = showSUSimple StorageDiskless key
show (SUBlock key) = showSUSimple StorageBlock key
show (SURados key) = showSUSimple StorageRados key
show (SUExt key) = showSUSimple StorageExt key
instance JSON StorageUnit where
showJSON (SUFile key) = showJSON (StorageFile, key, []::[String])
showJSON (SULvmPv key es) = showJSON (StorageLvmPv, key, [es])
showJSON (SULvmVg key es) = showJSON (StorageLvmVg, key, [es])
showJSON (SUDiskless key) = showJSON (StorageDiskless, key, []::[String])
showJSON (SUBlock key) = showJSON (StorageBlock, key, []::[String])
showJSON (SURados key) = showJSON (StorageRados, key, []::[String])
showJSON (SUExt key) = showJSON (StorageExt, key, []::[String])
-- FIXME: add readJSON implementation
readJSON = fail "Not implemented"
-- | Composes a string representation of storage types without
-- storage parameters
showSUSimple :: StorageType -> StorageKey -> String
showSUSimple st sk = show (storageTypeToRaw st, sk, []::[String])
-- | Composes a string representation of the LVM storage types
showSULvm :: StorageType -> StorageKey -> SPExclusiveStorage -> String
showSULvm st sk es = show (storageTypeToRaw st, sk, [es])
-- | Mapping fo disk templates to storage type
-- FIXME: This is semantically the same as the constant
-- C.diskTemplatesStorageType, remove this when python constants
-- are generated from haskell constants
diskTemplateToStorageType :: DiskTemplate -> StorageType
diskTemplateToStorageType DTExt = StorageExt
diskTemplateToStorageType DTFile = StorageFile
diskTemplateToStorageType DTSharedFile = StorageFile
diskTemplateToStorageType DTDrbd8 = StorageLvmVg
diskTemplateToStorageType DTPlain = StorageLvmVg
diskTemplateToStorageType DTRbd = StorageRados
diskTemplateToStorageType DTDiskless = StorageDiskless
diskTemplateToStorageType DTBlock = StorageBlock
-- | Equips a raw storage unit with its parameters
addParamsToStorageUnit :: SPExclusiveStorage -> StorageUnitRaw -> StorageUnit
addParamsToStorageUnit _ (SURaw StorageBlock key) = SUBlock key
addParamsToStorageUnit _ (SURaw StorageDiskless key) = SUDiskless key
addParamsToStorageUnit _ (SURaw StorageExt key) = SUExt key
addParamsToStorageUnit _ (SURaw StorageFile key) = SUFile key
addParamsToStorageUnit es (SURaw StorageLvmPv key) = SULvmPv key es
addParamsToStorageUnit es (SURaw StorageLvmVg key) = SULvmVg key es
addParamsToStorageUnit _ (SURaw StorageRados key) = SURados key
-- | Node evac modes.
$(THH.declareSADT "NodeEvacMode"
[ ("NEvacPrimary", 'C.iallocatorNevacPri)
......
......@@ -42,6 +42,7 @@ import qualified Ganeti.Rpc as Rpc
import qualified Ganeti.Objects as Objects
import qualified Ganeti.Types as Types
import qualified Ganeti.JSON as JSON
import Ganeti.Types
instance Arbitrary Rpc.RpcCallAllInstancesInfo where
arbitrary = Rpc.RpcCallAllInstancesInfo <$> arbitrary
......@@ -50,8 +51,26 @@ instance Arbitrary Rpc.RpcCallInstanceList where
arbitrary = Rpc.RpcCallInstanceList <$> arbitrary
instance Arbitrary Rpc.RpcCallNodeInfo where
arbitrary = Rpc.RpcCallNodeInfo <$> arbitrary <*> genHvSpecs <*>
pure Map.empty
arbitrary = Rpc.RpcCallNodeInfo <$> genStorageUnitMap <*> genHvSpecs
genStorageUnit :: Gen StorageUnit
genStorageUnit = do
storage_type <- arbitrary
storage_key <- genName
storage_es <- arbitrary
return $ addParamsToStorageUnit storage_es (SURaw storage_type storage_key)
genStorageUnits :: Gen [StorageUnit]
genStorageUnits = do
num_storage_units <- choose (0, 5)
vectorOf num_storage_units genStorageUnit
genStorageUnitMap :: Gen (Map.Map String [StorageUnit])
genStorageUnitMap = do
num_nodes <- choose (0,5)
node_uuids <- vectorOf num_nodes genName
storage_units_list <- vectorOf num_nodes genStorageUnits
return $ Map.fromList (zip node_uuids storage_units_list)
-- | Generate hypervisor specifications to be used for the NodeInfo call
genHvSpecs :: Gen [ (Types.Hypervisor, Objects.HvParams) ]
......
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