X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/c352b0a9c78e2bd6e2def4fc090e3533c2cb5191..4036f63a1a2907cdc258e84a7589d4b62dfe6a36:/htools/Ganeti/HTools/IAlloc.hs diff --git a/htools/Ganeti/HTools/IAlloc.hs b/htools/Ganeti/HTools/IAlloc.hs index dab1369..1212946 100644 --- a/htools/Ganeti/HTools/IAlloc.hs +++ b/htools/Ganeti/HTools/IAlloc.hs @@ -24,31 +24,41 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA -} 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 @@ -56,13 +66,14 @@ parseBaseInstance n a = do 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 @@ -77,9 +88,9 @@ parseInstance ktn n a = do 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 ++ "'" @@ -104,8 +115,8 @@ parseNode ktg n a = do 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 @@ -140,59 +151,157 @@ parseData body = do 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