Commit 54365762 authored by Iustin Pop's avatar Iustin Pop
Browse files

Implement IAllocator node evacuate request



This patch adds the new request loading/execution (trivial), but the
actual response formatting becomes more difficult as now the response
type differs by request.
Signed-off-by: default avatarIustin Pop <iustin@google.com>
parent 12b0511d
......@@ -131,17 +131,40 @@ parseData body = do
let ex_nodes' = map (stripSuffix $ length csf) ex_nodes
ex_idex <- mapM (Container.findByName map_n) ex_nodes'
return $ Relocate ridx req_nodes (map Node.idx ex_idex)
"multi-evacuate" ->
do
ex_names <- fromObj "evac_nodes" request
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 map_n map_i ptags csf
formatRVal :: String -> RqType
-> [Node.AllocElement] -> JSValue
formatRVal csf (Evacuate _) elems =
let sols = map (\(_, inst, nl) ->
let names = Instance.name inst : map Node.name nl
in map (++ csf) names) elems
jsols = map (JSArray . map (JSString . toJSString)) sols
in JSArray jsols
formatRVal csf _ elems =
let (_, _, nodes) = head elems
nodes' = map ((++ csf) . Node.name) nodes
in JSArray $ map (JSString . toJSString) nodes'
-- | Formats the response into a valid IAllocator response message.
formatResponse :: Bool -- ^ Whether the request was successful
-> String -- ^ Information text
-> [String] -- ^ The list of chosen nodes
-> String -- ^ Suffix for nodes/instances
-> RqType -- ^ Request type
-> [Node.AllocElement] -- ^ The resulting allocations
-> String -- ^ The JSON-formatted message
formatResponse success info nodes =
formatResponse success info csf rq elems =
let
e_success = ("success", JSBool success)
e_info = ("info", JSString . toJSString $ info)
e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes)
e_nodes = ("nodes", formatRVal csf rq elems)
in encodeStrict $ makeObj [e_success, e_info, e_nodes]
......@@ -56,7 +56,7 @@ exTagsPrefix = "htools:iextags:"
-- * Types
{-| The request type.
{-| The iallocator request type.
This type denotes what request we got from Ganeti and also holds
request-specific fields.
......@@ -66,6 +66,7 @@ data RqType
= Allocate Instance.Instance Int -- ^ A new instance allocation
| Relocate Idx Int [Ndx] -- ^ Move an instance to a new
-- secondary node
| Evacuate [Ndx] -- ^ Evacuate nodes
deriving (Show)
-- | A complete request, as received from Ganeti.
......
......@@ -47,17 +47,26 @@ import Ganeti.HTools.Loader (RqType(..), Request(..))
options :: [OptType]
options = [oPrintNodes, oShowVer, oShowHelp]
processResults :: (Monad m) => Cluster.AllocSolution -> m (String, [Node.Node])
processResults (fstats, successes, sols) =
processResults :: (Monad m) =>
RqType -> Cluster.AllocSolution
-> m (String, Cluster.AllocSolution)
processResults _ (_, _, []) = fail "No valid allocation solutions"
processResults (Evacuate _) as@(fstats, successes, sols) =
let best = fst $ head sols
tfails = length fstats
info = printf "for last allocation, successes %d, failures %d,\
\ best score: %.8f" successes tfails best::String
in return (info, as)
processResults _ as@(fstats, successes, sols) =
case sols of
[] -> fail "No valid allocation solutions"
(best, (_, _, w)):[] ->
let tfails = length fstats
info = printf "successes %d, failures %d,\
\ best score: %.8f for node(s) %s"
successes tfails
best (intercalate "/" . map Node.name $ w)::String
in return (info, w)
in return (info, as)
_ -> fail "Internal error: multiple allocation solutions"
-- | Process a request and return new node lists
......@@ -68,6 +77,7 @@ processRequest request =
in case rqtype of
Allocate xi reqn -> Cluster.tryAlloc nl il xi reqn
Relocate idx reqn exnodes -> Cluster.tryReloc nl il idx reqn exnodes
Evacuate exnodes -> Cluster.tryEvac nl il exnodes
-- | Main function.
main :: IO ()
......@@ -89,17 +99,17 @@ main = do
exitWith $ ExitFailure 1
Ok rq -> return rq
let Request _ nl _ _ csf = request
let Request rq nl _ _ csf = request
when (isJust shownodes) $ do
hPutStrLn stderr "Initial cluster status:"
hPutStrLn stderr $ Cluster.printNodes nl (fromJust shownodes)
let sols = processRequest request >>= processResults
let sols = processRequest request >>= processResults rq
let (ok, info, rn) =
case sols of
Ok (ginfo, sn) -> (True, "Request successful: " ++ ginfo,
map ((++ csf) . Node.name) sn)
Ok (ginfo, (_, _, sn)) -> (True, "Request successful: " ++ ginfo,
map snd sn)
Bad s -> (False, "Request failed: " ++ s, [])
resp = formatResponse ok info rn
resp = formatResponse ok info csf rq rn
putStrLn resp
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment