Revision 54365762
| b/Ganeti/HTools/IAlloc.hs | ||
|---|---|---|
| 131 | 131 |
let ex_nodes' = map (stripSuffix $ length csf) ex_nodes |
| 132 | 132 |
ex_idex <- mapM (Container.findByName map_n) ex_nodes' |
| 133 | 133 |
return $ Relocate ridx req_nodes (map Node.idx ex_idex) |
| 134 |
"multi-evacuate" -> |
|
| 135 |
do |
|
| 136 |
ex_names <- fromObj "evac_nodes" request |
|
| 137 |
ex_nodes <- mapM (Container.findByName map_n) ex_names |
|
| 138 |
let ex_ndx = map Node.idx ex_nodes |
|
| 139 |
return $ Evacuate ex_ndx |
|
| 134 | 140 |
other -> fail ("Invalid request type '" ++ other ++ "'")
|
| 135 | 141 |
return $ Request rqtype map_n map_i ptags csf |
| 136 | 142 |
|
| 143 |
formatRVal :: String -> RqType |
|
| 144 |
-> [Node.AllocElement] -> JSValue |
|
| 145 |
formatRVal csf (Evacuate _) elems = |
|
| 146 |
let sols = map (\(_, inst, nl) -> |
|
| 147 |
let names = Instance.name inst : map Node.name nl |
|
| 148 |
in map (++ csf) names) elems |
|
| 149 |
jsols = map (JSArray . map (JSString . toJSString)) sols |
|
| 150 |
in JSArray jsols |
|
| 151 |
|
|
| 152 |
formatRVal csf _ elems = |
|
| 153 |
let (_, _, nodes) = head elems |
|
| 154 |
nodes' = map ((++ csf) . Node.name) nodes |
|
| 155 |
in JSArray $ map (JSString . toJSString) nodes' |
|
| 156 |
|
|
| 157 |
|
|
| 137 | 158 |
-- | Formats the response into a valid IAllocator response message. |
| 138 | 159 |
formatResponse :: Bool -- ^ Whether the request was successful |
| 139 | 160 |
-> String -- ^ Information text |
| 140 |
-> [String] -- ^ The list of chosen nodes |
|
| 161 |
-> String -- ^ Suffix for nodes/instances |
|
| 162 |
-> RqType -- ^ Request type |
|
| 163 |
-> [Node.AllocElement] -- ^ The resulting allocations |
|
| 141 | 164 |
-> String -- ^ The JSON-formatted message |
| 142 |
formatResponse success info nodes =
|
|
| 165 |
formatResponse success info csf rq elems =
|
|
| 143 | 166 |
let |
| 144 | 167 |
e_success = ("success", JSBool success)
|
| 145 | 168 |
e_info = ("info", JSString . toJSString $ info)
|
| 146 |
e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes)
|
|
| 169 |
e_nodes = ("nodes", formatRVal csf rq elems)
|
|
| 147 | 170 |
in encodeStrict $ makeObj [e_success, e_info, e_nodes] |
| b/Ganeti/HTools/Loader.hs | ||
|---|---|---|
| 56 | 56 |
|
| 57 | 57 |
-- * Types |
| 58 | 58 |
|
| 59 |
{-| The request type.
|
|
| 59 |
{-| The iallocator request type.
|
|
| 60 | 60 |
|
| 61 | 61 |
This type denotes what request we got from Ganeti and also holds |
| 62 | 62 |
request-specific fields. |
| ... | ... | |
| 66 | 66 |
= Allocate Instance.Instance Int -- ^ A new instance allocation |
| 67 | 67 |
| Relocate Idx Int [Ndx] -- ^ Move an instance to a new |
| 68 | 68 |
-- secondary node |
| 69 |
| Evacuate [Ndx] -- ^ Evacuate nodes |
|
| 69 | 70 |
deriving (Show) |
| 70 | 71 |
|
| 71 | 72 |
-- | A complete request, as received from Ganeti. |
| b/hail.hs | ||
|---|---|---|
| 47 | 47 |
options :: [OptType] |
| 48 | 48 |
options = [oPrintNodes, oShowVer, oShowHelp] |
| 49 | 49 |
|
| 50 |
processResults :: (Monad m) => Cluster.AllocSolution -> m (String, [Node.Node]) |
|
| 51 |
processResults (fstats, successes, sols) = |
|
| 50 |
processResults :: (Monad m) => |
|
| 51 |
RqType -> Cluster.AllocSolution |
|
| 52 |
-> m (String, Cluster.AllocSolution) |
|
| 53 |
processResults _ (_, _, []) = fail "No valid allocation solutions" |
|
| 54 |
processResults (Evacuate _) as@(fstats, successes, sols) = |
|
| 55 |
let best = fst $ head sols |
|
| 56 |
tfails = length fstats |
|
| 57 |
info = printf "for last allocation, successes %d, failures %d,\ |
|
| 58 |
\ best score: %.8f" successes tfails best::String |
|
| 59 |
in return (info, as) |
|
| 60 |
|
|
| 61 |
processResults _ as@(fstats, successes, sols) = |
|
| 52 | 62 |
case sols of |
| 53 |
[] -> fail "No valid allocation solutions" |
|
| 54 | 63 |
(best, (_, _, w)):[] -> |
| 55 | 64 |
let tfails = length fstats |
| 56 | 65 |
info = printf "successes %d, failures %d,\ |
| 57 | 66 |
\ best score: %.8f for node(s) %s" |
| 58 | 67 |
successes tfails |
| 59 | 68 |
best (intercalate "/" . map Node.name $ w)::String |
| 60 |
in return (info, w)
|
|
| 69 |
in return (info, as)
|
|
| 61 | 70 |
_ -> fail "Internal error: multiple allocation solutions" |
| 62 | 71 |
|
| 63 | 72 |
-- | Process a request and return new node lists |
| ... | ... | |
| 68 | 77 |
in case rqtype of |
| 69 | 78 |
Allocate xi reqn -> Cluster.tryAlloc nl il xi reqn |
| 70 | 79 |
Relocate idx reqn exnodes -> Cluster.tryReloc nl il idx reqn exnodes |
| 80 |
Evacuate exnodes -> Cluster.tryEvac nl il exnodes |
|
| 71 | 81 |
|
| 72 | 82 |
-- | Main function. |
| 73 | 83 |
main :: IO () |
| ... | ... | |
| 89 | 99 |
exitWith $ ExitFailure 1 |
| 90 | 100 |
Ok rq -> return rq |
| 91 | 101 |
|
| 92 |
let Request _ nl _ _ csf = request
|
|
| 102 |
let Request rq nl _ _ csf = request
|
|
| 93 | 103 |
|
| 94 | 104 |
when (isJust shownodes) $ do |
| 95 | 105 |
hPutStrLn stderr "Initial cluster status:" |
| 96 | 106 |
hPutStrLn stderr $ Cluster.printNodes nl (fromJust shownodes) |
| 97 | 107 |
|
| 98 |
let sols = processRequest request >>= processResults |
|
| 108 |
let sols = processRequest request >>= processResults rq
|
|
| 99 | 109 |
let (ok, info, rn) = |
| 100 | 110 |
case sols of |
| 101 |
Ok (ginfo, sn) -> (True, "Request successful: " ++ ginfo,
|
|
| 102 |
map ((++ csf) . Node.name) sn)
|
|
| 111 |
Ok (ginfo, (_, _, sn)) -> (True, "Request successful: " ++ ginfo,
|
|
| 112 |
map snd sn)
|
|
| 103 | 113 |
Bad s -> (False, "Request failed: " ++ s, []) |
| 104 |
resp = formatResponse ok info rn |
|
| 114 |
resp = formatResponse ok info csf rq rn
|
|
| 105 | 115 |
putStrLn resp |
Also available in: Unified diff