module Ganeti.Config
( LinkIpMap
, NdParamObject(..)
, loadConfig
, saveConfig
, getNodeInstances
, getNodeRole
, getNodeNdParams
, getDefaultNicLink
, getDefaultHypervisor
, getInstancesIpByLink
, getMasterNodes
, getMasterCandidates
, getMasterOrCandidates
, getMasterNetworkParameters
, getOnlineNodes
, getNode
, getInstance
, getDisk
, getFilterRule
, getGroup
, getGroupNdParams
, getGroupIpolicy
, getGroupDiskParams
, getGroupNodes
, getGroupInstances
, getGroupOfNode
, getInstPrimaryNode
, getInstMinorsForNode
, getInstAllNodes
, getInstDisks
, getInstDisksFromObj
, getDrbdMinorsForDisk
, getDrbdMinorsForInstance
, getFilledInstHvParams
, getFilledInstBeParams
, getFilledInstOsParams
, getNetwork
, MAC
, getAllMACs
, getAllDrbdSecrets
, NodeLVsMap
, getInstanceLVsByNode
, getAllLVs
, buildLinkIpInstnameMap
, instNodes
) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Monad
import Control.Monad.State
import qualified Data.ByteString as BS
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Foldable as F
import Data.List (foldl', nub)
import Data.Maybe (fromMaybe)
import Data.Monoid
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Text.JSON as J
import System.IO
import Ganeti.BasicTypes
import qualified Ganeti.Constants as C
import Ganeti.Errors
import Ganeti.JSON
import Ganeti.Objects
import Ganeti.Types
import qualified Ganeti.Utils.MultiMap as MM
type LinkIpMap = M.Map String (M.Map String String)
readConfig :: FilePath -> IO (Result String)
readConfig = runResultT . liftIO . readFile
parseConfig :: String -> Result ConfigData
parseConfig = fromJResult "parsing configuration" . J.decodeStrict
encodeConfig :: ConfigData -> String
encodeConfig = J.encodeStrict
loadConfig :: FilePath -> IO (Result ConfigData)
loadConfig = fmap (>>= parseConfig) . readConfig
saveConfig :: Handle -> ConfigData -> IO ()
saveConfig fh = hPutStr fh . encodeConfig
withMissingParam :: String -> (a -> ErrorResult b) -> Maybe a -> ErrorResult b
withMissingParam = maybe . Bad . ParameterError
computeDiskNodes :: Disk -> S.Set String
computeDiskNodes dsk =
case diskLogicalId dsk of
Just (LIDDrbd8 nodeA nodeB _ _ _ _) -> S.fromList [nodeA, nodeB]
_ -> S.empty
instDiskNodes :: ConfigData -> Instance -> S.Set String
instDiskNodes cfg inst =
case getInstDisksFromObj cfg inst of
Ok disks -> S.unions $ map computeDiskNodes disks
Bad _ -> S.empty
instNodes :: ConfigData -> Instance -> S.Set String
instNodes cfg inst = maybe id S.insert (instPrimaryNode inst)
$ instDiskNodes cfg inst
instSecondaryNodes :: ConfigData -> Instance -> S.Set String
instSecondaryNodes cfg inst =
maybe id S.delete (instPrimaryNode inst) $ instDiskNodes cfg inst
getNodeInstances :: ConfigData -> String -> ([Instance], [Instance])
getNodeInstances cfg nname =
let all_inst = M.elems . fromContainer . configInstances $ cfg
pri_inst = filter ((== Just nname) . instPrimaryNode) all_inst
sec_inst = filter ((nname `S.member`) . instSecondaryNodes cfg) all_inst
in (pri_inst, sec_inst)
getNodeRole :: ConfigData -> Node -> NodeRole
getNodeRole cfg node
| uuidOf node == clusterMasterNode (configCluster cfg) = NRMaster
| nodeMasterCandidate node = NRCandidate
| nodeDrained node = NRDrained
| nodeOffline node = NROffline
| otherwise = NRRegular
getMasterNodes :: ConfigData -> [Node]
getMasterNodes cfg =
filter ((==) NRMaster . getNodeRole cfg) . F.toList . configNodes $ cfg
getMasterCandidates :: ConfigData -> [Node]
getMasterCandidates cfg =
filter ((==) NRCandidate . getNodeRole cfg) . F.toList . configNodes $ cfg
getMasterOrCandidates :: ConfigData -> [Node]
getMasterOrCandidates cfg =
let isMC r = (r == NRCandidate) || (r == NRMaster)
in filter (isMC . getNodeRole cfg) . F.toList . configNodes $ cfg
getMasterNetworkParameters :: ConfigData -> MasterNetworkParameters
getMasterNetworkParameters cfg =
let cluster = configCluster cfg
in MasterNetworkParameters
{ masterNetworkParametersUuid = clusterMasterNode cluster
, masterNetworkParametersIp = clusterMasterIp cluster
, masterNetworkParametersNetmask = clusterMasterNetmask cluster
, masterNetworkParametersNetdev = clusterMasterNetdev cluster
, masterNetworkParametersIpFamily = clusterPrimaryIpFamily cluster
}
getOnlineNodes :: ConfigData -> [Node]
getOnlineNodes = filter (not . nodeOffline) . F.toList . configNodes
getDefaultNicLink :: ConfigData -> String
getDefaultNicLink =
let ppDefault = UTF8.fromString C.ppDefault
in nicpLink . (M.! ppDefault) . fromContainer
. clusterNicparams . configCluster
getDefaultHypervisor :: ConfigData -> Hypervisor
getDefaultHypervisor cfg =
case clusterEnabledHypervisors $ configCluster cfg of
[] -> XenPvm
x:_ -> x
getInstancesIpByLink :: LinkIpMap -> String -> [String]
getInstancesIpByLink linkipmap link =
M.keys $ M.findWithDefault M.empty link linkipmap
getItem :: String -> String -> M.Map String a -> ErrorResult a
getItem kind name allitems = do
let lresult = lookupName (M.keys allitems) name
err msg = Bad $ OpPrereqError (kind ++ " name " ++ name ++ " " ++ msg)
ECodeNoEnt
fullname <- case lrMatchPriority lresult of
PartialMatch -> Ok $ lrContent lresult
ExactMatch -> Ok $ lrContent lresult
MultipleMatch -> err "has multiple matches"
FailMatch -> err "not found"
maybe (err "not found after successfull match?!") Ok $
M.lookup fullname allitems
getItem' :: String -> String -> M.Map BS.ByteString a -> ErrorResult a
getItem' kind name allitems =
let name' = UTF8.fromString name
err = Bad $ OpPrereqError (kind ++ " uuid " ++ name ++ " not found")
ECodeNoEnt
in maybe err Ok $ M.lookup name' allitems
getNode :: ConfigData -> String -> ErrorResult Node
getNode cfg name =
let nodes = fromContainer (configNodes cfg)
in case getItem' "Node" name nodes of
Ok node -> Ok node
Bad _ -> let by_name = M.mapKeys
(nodeName . (M.!) nodes) nodes
in getItem "Node" name by_name
getInstance :: ConfigData -> String -> ErrorResult Instance
getInstance cfg name =
let instances = fromContainer (configInstances cfg)
in case getItem' "Instance" name instances of
Ok inst -> Ok inst
Bad _ -> let by_name =
M.delete ""
. M.mapKeys (fromMaybe "" . instName . (M.!) instances)
$ instances
in getItem "Instance" name by_name
getInstanceByName :: ConfigData -> String -> ErrorResult Instance
getInstanceByName cfg name =
let instances = M.elems . fromContainer . configInstances $ cfg
matching = F.find (maybe False (== name) . instName) instances
in case matching of
Just inst -> Ok inst
Nothing -> Bad $ OpPrereqError
("Instance name " ++ name ++ " not found")
ECodeNoEnt
getDisk :: ConfigData -> String -> ErrorResult Disk
getDisk cfg name =
let disks = fromContainer (configDisks cfg)
in getItem' "Disk" name disks
getFilterRule :: ConfigData -> String -> ErrorResult FilterRule
getFilterRule cfg name =
let filters = fromContainer (configFilters cfg)
in getItem' "Filter" name filters
getGroup :: ConfigData -> String -> ErrorResult NodeGroup
getGroup cfg name =
let groups = fromContainer (configNodegroups cfg)
in case getItem' "NodeGroup" name groups of
Ok grp -> Ok grp
Bad _ -> let by_name = M.mapKeys
(groupName . (M.!) groups) groups
in getItem "NodeGroup" name by_name
getGroupNdParams :: ConfigData -> NodeGroup -> FilledNDParams
getGroupNdParams cfg ng =
fillParams (clusterNdparams $ configCluster cfg) (groupNdparams ng)
getGroupIpolicy :: ConfigData -> NodeGroup -> FilledIPolicy
getGroupIpolicy cfg ng =
fillParams (clusterIpolicy $ configCluster cfg) (groupIpolicy ng)
getGroupDiskParams :: ConfigData -> NodeGroup -> GroupDiskParams
getGroupDiskParams cfg ng =
GenericContainer $
fillDict (fromContainer . clusterDiskparams $ configCluster cfg)
(fromContainer $ groupDiskparams ng) []
getGroupNodes :: ConfigData -> String -> [Node]
getGroupNodes cfg gname =
let all_nodes = M.elems . fromContainer . configNodes $ cfg in
filter ((==gname) . nodeGroup) all_nodes
getGroupInstances :: ConfigData -> String -> ([Instance], [Instance])
getGroupInstances cfg gname =
let gnodes = map uuidOf (getGroupNodes cfg gname)
ginsts = map (getNodeInstances cfg) gnodes in
(concatMap fst ginsts, concatMap snd ginsts)
getFilledInstHvParams :: [String] -> ConfigData -> Instance -> HvParams
getFilledInstHvParams globals cfg inst =
let maybeHvName = instHypervisor inst
hvParamMap = fromContainer . clusterHvparams $ configCluster cfg
parentHvParams =
maybe M.empty fromContainer (maybeHvName >>= flip M.lookup hvParamMap)
maybeOsName = UTF8.fromString <$> instOs inst
osParamMap = fromContainer . clusterOsHvp $ configCluster cfg
osHvParamMap =
maybe M.empty (maybe M.empty fromContainer . flip M.lookup osParamMap)
maybeOsName
osHvParams =
maybe M.empty (maybe M.empty fromContainer . flip M.lookup osHvParamMap)
maybeHvName
childHvParams = fromContainer . instHvparams $ inst
fillFn con val = fillDict con val $ fmap UTF8.fromString globals
in GenericContainer $ fillFn (fillFn parentHvParams osHvParams) childHvParams
getFilledInstBeParams :: ConfigData -> Instance -> ErrorResult FilledBeParams
getFilledInstBeParams cfg inst = do
let beParamMap = fromContainer . clusterBeparams . configCluster $ cfg
parentParams <- getItem' "FilledBeParams" C.ppDefault beParamMap
return $ fillParams parentParams (instBeparams inst)
getFilledInstOsParams :: ConfigData -> Instance -> OsParams
getFilledInstOsParams cfg inst =
let maybeOsLookupName = liftM (takeWhile (/= '+')) (instOs inst)
osParamMap = fromContainer . clusterOsparams $ configCluster cfg
childOsParams = instOsparams inst
in case withMissingParam "Instance without OS"
(flip (getItem' "OsParams") osParamMap)
maybeOsLookupName of
Ok parentOsParams -> GenericContainer $
fillDict (fromContainer parentOsParams)
(fromContainer childOsParams) []
Bad _ -> childOsParams
getInstPrimaryNode :: ConfigData -> String -> ErrorResult Node
getInstPrimaryNode cfg name =
getInstanceByName cfg name
>>= withMissingParam "Instance without primary node" return . instPrimaryNode
>>= getNode cfg
getDrbdDiskNodes :: ConfigData -> Disk -> [Node]
getDrbdDiskNodes cfg disk =
let retrieved = case diskLogicalId disk of
Just (LIDDrbd8 nodeA nodeB _ _ _ _) ->
justOk [getNode cfg nodeA, getNode cfg nodeB]
_ -> []
in retrieved ++ concatMap (getDrbdDiskNodes cfg) (diskChildren disk)
getInstAllNodes :: ConfigData -> String -> ErrorResult [Node]
getInstAllNodes cfg name = do
inst <- getInstanceByName cfg name
inst_disks <- getInstDisksFromObj cfg inst
let disk_nodes = concatMap (getDrbdDiskNodes cfg) inst_disks
pNode <- getInstPrimaryNode cfg name
return . nub $ pNode:disk_nodes
getInstDisks :: ConfigData -> String -> ErrorResult [Disk]
getInstDisks cfg iname =
getInstance cfg iname >>= mapM (getDisk cfg) . instDisks
getInstDisksFromObj :: ConfigData -> Instance -> ErrorResult [Disk]
getInstDisksFromObj cfg =
getInstDisks cfg . uuidOf
collectFromDrbdDisks
:: (Monoid a)
=> (String -> String -> Int -> Int -> Int -> Private DRBDSecret -> a)
-> Disk -> a
collectFromDrbdDisks f = col
where
col (diskLogicalId &&& diskChildren ->
(Just (LIDDrbd8 nA nB port mA mB secret), ch)) =
f nA nB port mA mB secret <> F.foldMap col ch
col d = F.foldMap col (diskChildren d)
getDrbdSecretsForDisk :: Disk -> [DRBDSecret]
getDrbdSecretsForDisk = collectFromDrbdDisks
(\_ _ _ _ _ (Private secret) -> [secret])
getDrbdMinorsForDisk :: Disk -> [(Int, String)]
getDrbdMinorsForDisk =
collectFromDrbdDisks (\nA nB _ mnA mnB _ -> [(mnA, nA), (mnB, nB)])
getDrbdMinorsForNode :: String -> Disk -> [(Int, String)]
getDrbdMinorsForNode node disk =
let child_minors = concatMap (getDrbdMinorsForNode node) (diskChildren disk)
this_minors =
case diskLogicalId disk of
Just (LIDDrbd8 nodeA nodeB _ minorA minorB _)
| nodeA == node -> [(minorA, nodeB)]
| nodeB == node -> [(minorB, nodeA)]
_ -> []
in this_minors ++ child_minors
getDrbdMinorsForInstance :: ConfigData -> Instance
-> ErrorResult [(Int, String)]
getDrbdMinorsForInstance cfg =
liftM (concatMap getDrbdMinorsForDisk) . getInstDisksFromObj cfg
rolePrimary :: String
rolePrimary = "primary"
roleSecondary :: String
roleSecondary = "secondary"
getInstMinorsForNode :: ConfigData
-> String
-> Instance
-> [(String, Int, String, String, String, String)]
getInstMinorsForNode cfg node inst =
let nrole = if Just node == instPrimaryNode inst
then rolePrimary
else roleSecondary
iname = fromMaybe "" $ instName inst
inst_disks = case getInstDisksFromObj cfg inst of
Ok disks -> disks
Bad _ -> []
in concatMap (\(idx, dsk) ->
[(node, minor, iname, "disk/" ++ show idx, nrole, peer)
| (minor, peer) <- getDrbdMinorsForNode node dsk]) .
zip [(0::Int)..] $ inst_disks
buildLinkIpInstnameMap :: ConfigData -> LinkIpMap
buildLinkIpInstnameMap cfg =
let cluster = configCluster cfg
instances = M.elems . fromContainer . configInstances $ cfg
defparams = (M.!) (fromContainer $ clusterNicparams cluster)
$ UTF8.fromString C.ppDefault
nics = concatMap (\i -> [(fromMaybe (uuidOf i) $ instName i, nic)
| nic <- instNics i])
instances
in foldl' (\accum (iname, nic) ->
let pparams = nicNicparams nic
fparams = fillParams defparams pparams
link = nicpLink fparams
in case nicIp nic of
Nothing -> accum
Just ip -> let oldipmap = M.findWithDefault M.empty
link accum
newipmap = M.insert ip iname oldipmap
in M.insert link newipmap accum
) M.empty nics
getGroupOfNode :: ConfigData -> Node -> Maybe NodeGroup
getGroupOfNode cfg node =
M.lookup (UTF8.fromString $ nodeGroup node)
(fromContainer . configNodegroups $ cfg)
getNodeNdParams :: ConfigData -> Node -> Maybe FilledNDParams
getNodeNdParams cfg node = do
group <- getGroupOfNode cfg node
let gparams = getGroupNdParams cfg group
return $ fillParams gparams (nodeNdparams node)
getNetwork :: ConfigData -> String -> ErrorResult Network
getNetwork cfg name =
let networks = fromContainer (configNetworks cfg)
in case getItem' "Network" name networks of
Ok net -> Ok net
Bad _ -> let by_name = M.mapKeys
(fromNonEmpty . networkName . (M.!) networks)
networks
in getItem "Network" name by_name
type MAC = String
getAllMACs :: ConfigData -> [MAC]
getAllMACs = F.foldMap (map nicMac . instNics) . configInstances
getAllDrbdSecrets :: ConfigData -> [DRBDSecret]
getAllDrbdSecrets = F.foldMap getDrbdSecretsForDisk . configDisks
type NodeLVsMap = MM.MultiMap String LogicalVolume
getInstanceLVsByNode :: ConfigData -> Instance -> ErrorResult NodeLVsMap
getInstanceLVsByNode cd inst =
withMissingParam "Instance without Primary Node"
(\i -> return $ MM.fromList . lvsByNode i)
(instPrimaryNode inst)
<*> getInstDisksFromObj cd inst
where
lvsByNode :: String -> [Disk] -> [(String, LogicalVolume)]
lvsByNode node = concatMap (lvsByNode1 node)
lvsByNode1 :: String -> Disk -> [(String, LogicalVolume)]
lvsByNode1 _ (diskLogicalId &&& diskChildren
-> (Just (LIDDrbd8 nA nB _ _ _ _), ch)) =
lvsByNode nA ch ++ lvsByNode nB ch
lvsByNode1 node (diskLogicalId -> (Just (LIDPlain lv))) =
[(node, lv)]
lvsByNode1 node (diskChildren -> ch) = lvsByNode node ch
getAllLVs :: ConfigData -> ErrorResult (S.Set LogicalVolume)
getAllLVs cd = mconcat <$> mapM (liftM MM.values . getInstanceLVsByNode cd)
(F.toList $ configInstances cd)
class NdParamObject a where
getNdParamsOf :: ConfigData -> a -> Maybe FilledNDParams
instance NdParamObject Node where
getNdParamsOf = getNodeNdParams
instance NdParamObject NodeGroup where
getNdParamsOf cfg = Just . getGroupNdParams cfg
instance NdParamObject Cluster where
getNdParamsOf _ = Just . clusterNdparams