Revision 58709f92 hail.hs
| b/hail.hs | ||
|---|---|---|
| 118 | 118 |
-> InstanceList |
| 119 | 119 |
-> Instance.Instance |
| 120 | 120 |
-> Int |
| 121 |
-> Result [Node.Node]
|
|
| 121 |
-> Result (String, [Node.Node])
|
|
| 122 | 122 |
tryAlloc nl il xi _ = Bad "alloc not implemented" |
| 123 | 123 |
|
| 124 | 124 |
-- | Try to allocate an instance on the cluster |
| ... | ... | |
| 127 | 127 |
-> Int |
| 128 | 128 |
-> Int |
| 129 | 129 |
-> [Int] |
| 130 |
-> Result [Node.Node]
|
|
| 131 |
tryReloc nl il xid reqn ex_idx =
|
|
| 130 |
-> Result (String, [Node.Node])
|
|
| 131 |
tryReloc nl il xid 1 ex_idx =
|
|
| 132 | 132 |
let all_nodes = Container.elems nl |
| 133 |
inst = Container.find xid il |
|
| 133 | 134 |
valid_nodes = filter (not . flip elem ex_idx . idx) all_nodes |
| 134 |
in Ok (take reqn valid_nodes) |
|
| 135 |
valid_idxes = map Node.idx valid_nodes |
|
| 136 |
nl' = Container.map (\n -> if elem (Node.idx n) ex_idx then |
|
| 137 |
Node.setOffline n True |
|
| 138 |
else n) nl |
|
| 139 |
sols1 = map (\x -> let (mnl, _, _, _) = |
|
| 140 |
Cluster.applyMove nl' inst |
|
| 141 |
(Cluster.ReplaceSecondary x) |
|
| 142 |
in (mnl, x) |
|
| 143 |
) valid_idxes |
|
| 144 |
sols2 = filter (isJust . fst) sols1 |
|
| 145 |
in if null sols1 then |
|
| 146 |
Bad "No nodes onto which to relocate at all" |
|
| 147 |
else if null sols2 then |
|
| 148 |
Bad "No valid solutions" |
|
| 149 |
else |
|
| 150 |
let sols3 = map (\(x, y) -> |
|
| 151 |
(Cluster.compCV $ fromJust x, |
|
| 152 |
(fromJust x, y))) |
|
| 153 |
sols2 |
|
| 154 |
sols4 = sortBy (compare `on` fst) sols3 |
|
| 155 |
(best, (final_nl, winner)) = head sols4 |
|
| 156 |
(worst, (_, loser)) = last sols4 |
|
| 157 |
wnode = Container.find winner final_nl |
|
| 158 |
lnode = Container.find loser nl |
|
| 159 |
info = printf "Valid results: %d, best score: %.8f \ |
|
| 160 |
\(node %s), worst score: %.8f (node %s)" |
|
| 161 |
(length sols3) best (Node.name wnode) |
|
| 162 |
worst (Node.name lnode) |
|
| 163 |
in Ok (info, [wnode]) |
|
| 164 |
|
|
| 165 |
tryReloc _ _ _ reqn _ = Bad $ "Unsupported number of relocation \ |
|
| 166 |
\destinations required (" ++ (show reqn) ++
|
|
| 167 |
"), only one supported" |
|
| 135 | 168 |
|
| 136 | 169 |
-- | Main function. |
| 137 | 170 |
main :: IO () |
| ... | ... | |
| 159 | 192 |
Relocate idx reqn exnodes -> |
| 160 | 193 |
tryReloc nl il idx reqn exnodes |
| 161 | 194 |
let (ok, info, rn) = case new_nodes of |
| 162 |
Ok sn -> (True, "Request successfull", map name sn) |
|
| 195 |
Ok (info, sn) -> (True, "Request successful: " ++ info, |
|
| 196 |
map name sn) |
|
| 163 | 197 |
Bad s -> (False, "Request failed: " ++ s, []) |
| 164 | 198 |
resp = formatResponse ok info rn |
| 165 | 199 |
putStrLn resp |
Also available in: Unified diff