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