import Ganeti.HTools.Types
-- | Type alias for the result of an IAllocator call.
-type IAllocResult = (String, JSValue, Node.List)
+type IAllocResult = (String, JSValue, Node.List, Instance.List)
-- | Parse the basic specifications of an instance.
--
return (u, Group.create name u apol)
-- | 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
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"
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_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
+ 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)
-- | Formats the result into a valid IAllocator response message.
formatResponse :: Bool -- ^ Whether the request was successful
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
- -- FIXME: head elems is certainly not correct here, since we
- -- don't always concat the elems and lists in the same order;
- -- however, as the old evacuate mode is deprecated, we can leave
- -- it like this for the moment
- (head_nl, _, _, _) = head elems
- return (info, showJSON sols, head_nl)
-
-- | Convert allocation/relocation results into the result format.
-formatAllocate :: Cluster.AllocSolution -> Result IAllocResult
-formatAllocate as = do
+formatAllocate :: Instance.List -> Cluster.AllocSolution -> Result IAllocResult
+formatAllocate il as = do
let info = describeSolution as
case Cluster.asSolutions as of
[] -> fail info
- (nl, _, nodes, _):[] -> return (info, showJSON $ map (Node.name) nodes, nl)
+ (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.
-> Instance.List
-> (Node.List, Instance.List, Cluster.EvacSolution)
-> Result IAllocResult
-formatNodeEvac gl nl il (fin_nl, _, es) =
+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
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)
+ 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
+-- | 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
+ Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate il
Relocate idx reqn exnodes ->
- Cluster.tryMGReloc gl nl il idx reqn exnodes >>= formatAllocate
- Evacuate exnodes ->
- Cluster.tryMGEvac gl nl il exnodes >>= formatEvacuate
+ processRelocate gl nl il idx reqn exnodes >>= formatRelocate
ChangeGroup gdxs idxs ->
Cluster.tryChangeGroup gl nl il idxs gdxs >>=
formatNodeEvac gl nl il
Cluster.tryNodeEvac gl nl il mode xi >>=
formatNodeEvac gl nl il
--- | Reads the request from the data file(s)
+-- | Reads the request from the data file(s).
readRequest :: Options -> [String] -> IO Request
readRequest opts args = do
when (null args) $ do
Bad err -> do
hPutStrLn stderr $ "Error: " ++ err
exitWith $ ExitFailure 1
- Ok rq -> return rq
+ Ok (fix_msgs, rq) -> maybeShowWarnings fix_msgs >> return rq
(if isJust (optDataFile opts) || (not . null . optNodeSim) opts
then do
cdata <- loadExternalData opts
else return r1)
-- | Main iallocator pipeline.
-runIAllocator :: Request -> (Maybe Node.List, String)
+runIAllocator :: Request -> (Maybe (Node.List, Instance.List), String)
runIAllocator request =
- let (ok, info, result, nl) =
+ let (ok, info, result, cdata) =
case processRequest request of
- Ok (msg, r, nl) -> (True, "Request successful: " ++ msg, r,
- Just nl)
+ 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 (nl, rstring)
+ in (cdata, rstring)
projects / ganeti-local / blobdiff