X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/b5cec17a2953d2a102eb6b1ed492c3031c3ea97e..e0baa26f300c3609cccba52bd8f8a41e72e64581:/htools/Ganeti/HTools/IAlloc.hs diff --git a/htools/Ganeti/HTools/IAlloc.hs b/htools/Ganeti/HTools/IAlloc.hs index 6e55e0d..91b3706 100644 --- a/htools/Ganeti/HTools/IAlloc.hs +++ b/htools/Ganeti/HTools/IAlloc.hs @@ -24,32 +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, Node.List, Instance.List) + -- | 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 @@ -57,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 @@ -78,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 ++ "'" @@ -105,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 @@ -114,16 +124,13 @@ parseGroup u a = do apol <- extract "alloc_policy" return (u, Group.create name u apol) -parseTargetGroups :: [(String, JSValue)] -- ^ The JSON object (request dict) - -> Group.List -- ^ The existing groups - -> Result [Gdx] -parseTargetGroups req map_g = do - group_uuids <- fromObjWithDefault req "target_groups" [] - mapM (liftM Group.idx . Container.findByName map_g) group_uuids - -- | Top-level parser. -parseData :: String -- ^ The JSON message as received from Ganeti - -> Result Request -- ^ A (possible valid) request +-- +-- The result is a tuple of eventual warning messages and the parsed +-- request; if parsing the input data fails, we'll return a 'Bad' +-- value. +parseData :: String -- ^ The JSON message as received from Ganeti + -> Result ([String], Request) -- ^ Result tuple parseData body = do decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body) let obj = fromJSObject decoded @@ -148,8 +155,10 @@ parseData body = do let (kti, il) = assignIndices iobj -- cluster tags ctags <- extrObj "cluster_tags" - cdata <- mergeData [] [] [] (ClusterData gl nl il ctags) - let map_n = cdNodes cdata + cdata1 <- mergeData [] [] [] [] (ClusterData gl nl il ctags) + let (msgs, fix_nl) = checkData (cdNodes cdata1) (cdInstances cdata1) + cdata = cdata1 { cdNodes = fix_nl } + map_n = cdNodes cdata map_i = cdInstances cdata map_g = cdGroups cdata optype <- extrReq "type" @@ -170,56 +179,173 @@ parseData body = do 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 -> + | optype == C.iallocatorModeChgGroup -> 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.iallocatorModeMreloc -> + 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 <- do - case extrReq "reloc_mode" of - Ok s | s == C.iallocatorMrelocKeep -> return KeepGroup - | s == C.iallocatorMrelocChange -> - do - tg_groups <- parseTargetGroups request map_g - return $ ChangeGroup tg_groups - | s == C.iallocatorMrelocAny -> return AnyGroup - | otherwise -> Bad $ "Invalid relocate mode " ++ s - Bad x -> Bad x - return $ MultiReloc rl_idx rl_mode + rl_mode <- extrReq "evac_mode" + return $ NodeEvacuate rl_idx rl_mode | otherwise -> fail ("Invalid request type '" ++ optype ++ "'") - return $ Request rqtype cdata + return (msgs, Request rqtype cdata) --- | Format the result -formatRVal :: RqType -> [Node.AllocElement] -> JSValue -formatRVal _ [] = JSArray [] - -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' - --- | 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_result = ("result", formatRVal rq elems) + 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 allocation/relocation results into the result format. +formatAllocate :: Instance.List -> Cluster.AllocSolution -> Result IAllocResult +formatAllocate il as = do + let info = describeSolution as + case Cluster.asSolutions as of + [] -> fail info + (nl, inst, nodes, _):[] -> + do + let il' = Container.add (Instance.idx inst) inst il + return (info, showJSON $ map Node.name nodes, nl, il') + _ -> 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 (fin_nl, fin_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), fin_nl, fin_il) + +-- | Runs relocate for a single instance. +-- +-- This is wrapper over the 'Cluster.tryNodeEvac' function that is run +-- with a single instance (ours), and further it checks that the +-- result it got (in the nodes field) is actually consistent, as +-- tryNodeEvac is designed to output primarily an opcode list, not a +-- node list. +processRelocate :: Group.List -- ^ The group list + -> Node.List -- ^ The node list + -> Instance.List -- ^ The instance list + -> Idx -- ^ The index of the instance to move + -> Int -- ^ The number of nodes required + -> [Ndx] -- ^ Nodes which should not be used + -> Result (Node.List, Instance.List, [Ndx]) -- ^ Solution list +processRelocate gl nl il idx 1 exndx = do + let orig = Container.find idx il + sorig = Instance.sNode orig + when (exndx /= [sorig]) $ + -- FIXME: we can't use the excluded nodes here; the logic is + -- already _but only partially_ implemented in tryNodeEvac... + fail $ "Unsupported request: excluded nodes not equal to\ + \ instance's secondary node (" ++ show sorig ++ " versus " ++ + show exndx ++ ")" + (nl', il', esol) <- Cluster.tryNodeEvac gl nl il ChangeSecondary [idx] + nodes <- case lookup idx (Cluster.esFailed esol) of + Just msg -> fail msg + Nothing -> + case lookup idx (map (\(a, _, b) -> (a, b)) + (Cluster.esMoved esol)) of + Nothing -> + fail "Internal error: lost instance idx during move" + Just n -> return n + let inst = Container.find idx il' + pnode = Instance.pNode inst + snode = Instance.sNode inst + when (snode == sorig) $ + fail "Internal error: instance didn't change secondary node?!" + when (snode == pnode) $ + fail "Internal error: selected primary as new secondary?!" + + nodes' <- if (nodes == [pnode, snode]) + then return [snode] -- only the new secondary is needed + else fail $ "Internal error: inconsistent node list (" ++ + show nodes ++ ") versus instance nodes (" ++ show pnode ++ + "," ++ show snode ++ ")" + return (nl', il', nodes') + +processRelocate _ _ _ _ reqn _ = + fail $ "Exchange " ++ show reqn ++ " nodes mode is not implemented" + +formatRelocate :: (Node.List, Instance.List, [Ndx]) + -> Result IAllocResult +formatRelocate (nl, il, ndxs) = + let nodes = map (`Container.find` nl) ndxs + names = map Node.name nodes + in Ok ("success", showJSON names, nl, il) + +-- | 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 il + Relocate idx reqn exnodes -> + processRelocate gl nl il idx reqn exnodes >>= formatRelocate + 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 (fix_msgs, rq) -> maybeShowWarnings fix_msgs >> 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 -> (Maybe (Node.List, Instance.List), String) +runIAllocator request = + let (ok, info, result, cdata) = + case processRequest request of + Ok (msg, r, nl, il) -> (True, "Request successful: " ++ msg, r, + Just (nl, il)) + Bad msg -> (False, "Request failed: " ++ msg, JSArray [], Nothing) + rstring = formatResponse ok info result + in (cdata, rstring)