-}
module Ganeti.HTools.IAlloc
- ( parseData
- , formatResponse
+ ( readRequest
+ , runIAllocator
) where
import Data.Either ()
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isJust)
+import Data.List
import Control.Monad
-import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray),
- makeObj, encodeStrict, decodeStrict,
- fromJSObject, toJSString)
+import Text.JSON (JSObject, JSValue(JSArray),
+ makeObj, encodeStrict, decodeStrict, fromJSObject, showJSON)
+import System (exitWith, ExitCode(..))
+import System.IO
+
+import qualified Ganeti.HTools.Cluster as Cluster
import qualified Ganeti.HTools.Container as Container
import qualified Ganeti.HTools.Group as Group
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Instance as Instance
+import qualified Ganeti.Constants as C
+import Ganeti.HTools.CLI
import Ganeti.HTools.Loader
+import Ganeti.HTools.ExtLoader (loadExternalData)
import Ganeti.HTools.Utils
import Ganeti.HTools.Types
+-- | Type alias for the result of an IAllocator call.
+type IAllocResult = (String, JSValue)
+
-- | Parse the basic specifications of an instance.
--
-- Instances in the cluster instance list and the instance in an
-- 'Allocate' request share some common properties, which are read by
-- this function.
parseBaseInstance :: String
- -> [(String, JSValue)]
+ -> JSRecord
-> Result (String, Instance.Instance)
parseBaseInstance n a = do
let extract x = tryFromObj ("invalid data for instance '" ++ n ++ "'") a x
mem <- extract "memory"
vcpus <- extract "vcpus"
tags <- extract "tags"
+ dt <- extract "disk_template"
let running = "running"
- return (n, Instance.create n mem disk vcpus running tags True 0 0)
+ return (n, Instance.create n mem disk vcpus running tags True 0 0 dt)
--- | Parses an instance as found in the cluster instance listg.
-parseInstance :: NameAssoc -- ^ The node name-to-index association list
- -> String -- ^ The name of the instance
- -> [(String, JSValue)] -- ^ The JSON object
+-- | Parses an instance as found in the cluster instance list.
+parseInstance :: NameAssoc -- ^ The node name-to-index association list
+ -> String -- ^ The name of the instance
+ -> JSRecord -- ^ The JSON object
-> Result (String, Instance.Instance)
parseInstance ktn n a = do
base <- parseBaseInstance n a
return (n, Instance.setBoth (snd base) pidx sidx)
-- | Parses a node as found in the cluster node list.
-parseNode :: NameAssoc -- ^ The group association
- -> String -- ^ The node's name
- -> [(String, JSValue)] -- ^ The JSON object
+parseNode :: NameAssoc -- ^ The group association
+ -> String -- ^ The node's name
+ -> JSRecord -- ^ The JSON object
-> Result (String, Node.Node)
parseNode ktg n a = do
let desc = "invalid data for node '" ++ n ++ "'"
return (n, node)
-- | Parses a group as found in the cluster group list.
-parseGroup :: String -- ^ The group UUID
- -> [(String, JSValue)] -- ^ The JSON object
+parseGroup :: String -- ^ The group UUID
+ -> JSRecord -- ^ The JSON object
-> Result (String, Group.Group)
parseGroup u a = do
let extract x = tryFromObj ("invalid data for group '" ++ u ++ "'") a x
let (kti, il) = assignIndices iobj
-- cluster tags
ctags <- extrObj "cluster_tags"
- cdata <- mergeData [] [] [] (ClusterData gl nl il ctags)
+ cdata <- mergeData [] [] [] [] (ClusterData gl nl il ctags)
let map_n = cdNodes cdata
+ map_i = cdInstances cdata
+ map_g = cdGroups cdata
optype <- extrReq "type"
rqtype <-
- case optype of
- "allocate" ->
- do
- rname <- extrReq "name"
- req_nodes <- extrReq "required_nodes"
- inew <- parseBaseInstance rname request
- let io = snd inew
- return $ Allocate io req_nodes
- "relocate" ->
- do
- rname <- extrReq "name"
- ridx <- lookupInstance kti rname
- req_nodes <- extrReq "required_nodes"
- ex_nodes <- extrReq "relocate_from"
- ex_idex <- mapM (Container.findByName map_n) ex_nodes
- return $ Relocate ridx req_nodes (map Node.idx ex_idex)
- "multi-evacuate" ->
- do
- ex_names <- extrReq "evac_nodes"
- ex_nodes <- mapM (Container.findByName map_n) ex_names
- let ex_ndx = map Node.idx ex_nodes
- return $ Evacuate ex_ndx
- other -> fail ("Invalid request type '" ++ other ++ "'")
- return $ Request rqtype cdata
-
--- | Format the result
-formatRVal :: RqType -> [Node.AllocElement] -> JSValue
-formatRVal _ [] = JSArray []
+ case () of
+ _ | optype == C.iallocatorModeAlloc ->
+ do
+ rname <- extrReq "name"
+ req_nodes <- extrReq "required_nodes"
+ inew <- parseBaseInstance rname request
+ let io = snd inew
+ return $ Allocate io req_nodes
+ | optype == C.iallocatorModeReloc ->
+ do
+ rname <- extrReq "name"
+ ridx <- lookupInstance kti rname
+ req_nodes <- extrReq "required_nodes"
+ ex_nodes <- extrReq "relocate_from"
+ ex_idex <- mapM (Container.findByName map_n) ex_nodes
+ return $ Relocate ridx req_nodes (map Node.idx ex_idex)
+ | optype == C.iallocatorModeMevac ->
+ do
+ ex_names <- extrReq "evac_nodes"
+ ex_nodes <- mapM (Container.findByName map_n) ex_names
+ let ex_ndx = map Node.idx ex_nodes
+ return $ Evacuate ex_ndx
+ | optype == C.iallocatorModeChgGroup ->
+ do
+ rl_names <- extrReq "instances"
+ rl_insts <- mapM (liftM Instance.idx .
+ Container.findByName map_i) rl_names
+ gr_uuids <- extrReq "target_groups"
+ gr_idxes <- mapM (liftM Group.idx .
+ Container.findByName map_g) gr_uuids
+ return $ ChangeGroup rl_insts gr_idxes
+ | optype == C.iallocatorModeNodeEvac ->
+ do
+ rl_names <- extrReq "instances"
+ rl_insts <- mapM (Container.findByName map_i) rl_names
+ let rl_idx = map Instance.idx rl_insts
+ rl_mode <-
+ case extrReq "evac_mode" of
+ Ok s | s == C.iallocatorNevacAll -> return ChangeAll
+ | s == C.iallocatorNevacPri -> return ChangePrimary
+ | s == C.iallocatorNevacSec -> return ChangeSecondary
+ | otherwise -> Bad $ "Invalid evacuate mode " ++ s
+ Bad x -> Bad x
+ return $ NodeEvacuate rl_idx rl_mode
-formatRVal (Evacuate _) elems =
- let sols = map (\(_, inst, nl, _) -> Instance.name inst : map Node.name nl)
- elems
- jsols = map (JSArray . map (JSString . toJSString)) sols
- in JSArray jsols
-
-formatRVal _ elems =
- let (_, _, nodes, _) = head elems
- nodes' = map Node.name nodes
- in JSArray $ map (JSString . toJSString) nodes'
+ | otherwise -> fail ("Invalid request type '" ++ optype ++ "'")
+ return $ Request rqtype cdata
--- | Formats the response into a valid IAllocator response message.
+-- | Formats the result into a valid IAllocator response message.
formatResponse :: Bool -- ^ Whether the request was successful
-> String -- ^ Information text
- -> RqType -- ^ Request type
- -> [Node.AllocElement] -- ^ The resulting allocations
- -> String -- ^ The JSON-formatted message
-formatResponse success info rq elems =
+ -> JSValue -- ^ The JSON encoded result
+ -> String -- ^ The full JSON-formatted message
+formatResponse success info result =
let
- e_success = ("success", JSBool success)
- e_info = ("info", JSString . toJSString $ info)
- e_nodes = ("nodes", formatRVal rq elems)
- in encodeStrict $ makeObj [e_success, e_info, e_nodes]
+ e_success = ("success", showJSON success)
+ e_info = ("info", showJSON info)
+ e_result = ("result", result)
+ in encodeStrict $ makeObj [e_success, e_info, e_result]
+
+-- | Flatten the log of a solution into a string.
+describeSolution :: Cluster.AllocSolution -> String
+describeSolution = intercalate ", " . Cluster.asLog
+
+-- | Convert evacuation results into the result format.
+formatEvacuate :: Cluster.AllocSolution -> Result IAllocResult
+formatEvacuate as = do
+ let info = describeSolution as
+ elems = Cluster.asSolutions as
+ when (null elems) $ fail info
+ let sols = map (\(_, inst, nl, _) -> Instance.name inst : map Node.name nl)
+ elems
+ return (info, showJSON sols)
+
+-- | Convert allocation/relocation results into the result format.
+formatAllocate :: Cluster.AllocSolution -> Result IAllocResult
+formatAllocate as = do
+ let info = describeSolution as
+ case Cluster.asSolutions as of
+ [] -> fail info
+ (_, _, nodes, _):[] -> return (info, showJSON $ map (Node.name) nodes)
+ _ -> fail "Internal error: multiple allocation solutions"
+
+-- | Convert a node-evacuation/change group result.
+formatNodeEvac :: Group.List
+ -> Node.List
+ -> Instance.List
+ -> (Node.List, Instance.List, Cluster.EvacSolution)
+ -> Result IAllocResult
+formatNodeEvac gl nl il (_, _, es) =
+ let iname = Instance.name . flip Container.find il
+ nname = Node.name . flip Container.find nl
+ gname = Group.name . flip Container.find gl
+ fes = map (\(idx, msg) -> (iname idx, msg)) $ Cluster.esFailed es
+ mes = map (\(idx, gdx, ndxs) -> (iname idx, gname gdx, map nname ndxs))
+ $ Cluster.esMoved es
+ failed = length fes
+ moved = length mes
+ info = show failed ++ " instances failed to move and " ++ show moved ++
+ " were moved successfully"
+ in Ok (info, showJSON (mes, fes, Cluster.esOpCodes es))
+
+-- | Process a request and return new node lists
+processRequest :: Request -> Result IAllocResult
+processRequest request =
+ let Request rqtype (ClusterData gl nl il _) = request
+ in case rqtype of
+ Allocate xi reqn ->
+ Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate
+ Relocate idx reqn exnodes ->
+ Cluster.tryMGReloc gl nl il idx reqn exnodes >>= formatAllocate
+ Evacuate exnodes ->
+ Cluster.tryMGEvac gl nl il exnodes >>= formatEvacuate
+ ChangeGroup gdxs idxs ->
+ Cluster.tryChangeGroup gl nl il idxs gdxs >>=
+ formatNodeEvac gl nl il
+ NodeEvacuate xi mode ->
+ Cluster.tryNodeEvac gl nl il mode xi >>=
+ formatNodeEvac gl nl il
+
+-- | Reads the request from the data file(s)
+readRequest :: Options -> [String] -> IO Request
+readRequest opts args = do
+ when (null args) $ do
+ hPutStrLn stderr "Error: this program needs an input file."
+ exitWith $ ExitFailure 1
+
+ input_data <- readFile (head args)
+ r1 <- case parseData input_data of
+ Bad err -> do
+ hPutStrLn stderr $ "Error: " ++ err
+ exitWith $ ExitFailure 1
+ Ok rq -> return rq
+ (if isJust (optDataFile opts) || (not . null . optNodeSim) opts
+ then do
+ cdata <- loadExternalData opts
+ let Request rqt _ = r1
+ return $ Request rqt cdata
+ else return r1)
+
+-- | Main iallocator pipeline.
+runIAllocator :: Request -> String
+runIAllocator request =
+ let (ok, info, result) =
+ case processRequest request of
+ Ok (msg, r) -> (True, "Request successful: " ++ msg, r)
+ Bad msg -> (False, "Request failed: " ++ msg, JSArray [])
+ in formatResponse ok info result
projects / ganeti-local / blobdiff