Revision f826c5e0
| b/hail.hs | ||
|---|---|---|
| 114 | 114 |
] |
| 115 | 115 |
|
| 116 | 116 |
-- | Try to allocate an instance on the cluster |
| 117 |
tryAlloc :: NodeList |
|
| 117 |
tryAlloc :: (Monad m) => |
|
| 118 |
NodeList |
|
| 118 | 119 |
-> InstanceList |
| 119 | 120 |
-> Instance.Instance |
| 120 | 121 |
-> Int |
| 121 |
-> Result (String, [Node.Node])
|
|
| 122 |
-> m [(Maybe NodeList, [Node.Node])]
|
|
| 122 | 123 |
tryAlloc nl il inst 2 = |
| 123 | 124 |
let all_nodes = Container.elems nl |
| 124 |
all_nidx = map Node.idx all_nodes |
|
| 125 | 125 |
all_pairs = liftM2 (,) all_nodes all_nodes |
| 126 | 126 |
ok_pairs = filter (\(x, y) -> Node.idx x /= Node.idx y) all_pairs |
| 127 | 127 |
sols1 = map (\(p, s) -> let pdx = Node.idx p |
| 128 | 128 |
sdx = Node.idx s |
| 129 | 129 |
(mnl, _) = Cluster.allocateOn nl |
| 130 | 130 |
inst pdx sdx |
| 131 |
in (mnl, (p, s))
|
|
| 131 |
in (mnl, [p, s])
|
|
| 132 | 132 |
) ok_pairs |
| 133 |
sols2 = filter (isJust . fst) sols1 |
|
| 134 |
in if null sols1 then |
|
| 135 |
Bad "No pairs onto which to allocate at all" |
|
| 136 |
else if null sols2 then |
|
| 137 |
Bad "No valid allocation solutions" |
|
| 138 |
else |
|
| 139 |
let sols3 = map (\(x, (y, z)) -> |
|
| 140 |
(Cluster.compCV $ fromJust x, |
|
| 141 |
(fromJust x, y, z))) |
|
| 142 |
sols2 |
|
| 143 |
sols4 = sortBy (compare `on` fst) sols3 |
|
| 144 |
(best, (final_nl, w1, w2)) = head sols4 |
|
| 145 |
(worst, (_, l1, l2)) = last sols4 |
|
| 146 |
info = printf "Valid results: %d, best score: %.8f \ |
|
| 147 |
\(nodes %s/%s), worst score: %.8f (nodes \ |
|
| 148 |
\%s/%s)" |
|
| 149 |
(length sols3) |
|
| 150 |
best (Node.name w1) (Node.name w2) |
|
| 151 |
worst (Node.name l1) (Node.name w2) |
|
| 152 |
in Ok (info, [w1, w2]) |
|
| 153 |
|
|
| 154 |
|
|
| 155 |
tryAlloc _ _ _ reqn = Bad $ "Unsupported number of alllocation \ |
|
| 156 |
\destinations required (" ++ (show reqn) ++
|
|
| 157 |
"), only two supported" |
|
| 133 |
in return sols1 |
|
| 134 |
|
|
| 135 |
tryAlloc _ _ _ reqn = fail $ "Unsupported number of alllocation \ |
|
| 136 |
\destinations required (" ++ (show reqn) ++
|
|
| 137 |
"), only two supported" |
|
| 158 | 138 |
|
| 159 | 139 |
-- | Try to allocate an instance on the cluster |
| 160 |
tryReloc :: NodeList |
|
| 140 |
tryReloc :: (Monad m) => |
|
| 141 |
NodeList |
|
| 161 | 142 |
-> InstanceList |
| 162 | 143 |
-> Int |
| 163 | 144 |
-> Int |
| 164 | 145 |
-> [Int] |
| 165 |
-> Result (String, [Node.Node])
|
|
| 146 |
-> m [(Maybe NodeList, [Node.Node])]
|
|
| 166 | 147 |
tryReloc nl il xid 1 ex_idx = |
| 167 | 148 |
let all_nodes = Container.elems nl |
| 168 | 149 |
inst = Container.find xid il |
| ... | ... | |
| 174 | 155 |
sols1 = map (\x -> let (mnl, _, _, _) = |
| 175 | 156 |
Cluster.applyMove nl' inst |
| 176 | 157 |
(Cluster.ReplaceSecondary x) |
| 177 |
in (mnl, x)
|
|
| 158 |
in (mnl, [Container.find x nl'])
|
|
| 178 | 159 |
) valid_idxes |
| 179 |
sols2 = filter (isJust . fst) sols1 |
|
| 180 |
in if null sols1 then |
|
| 181 |
Bad "No nodes onto which to relocate at all" |
|
| 182 |
else if null sols2 then |
|
| 183 |
Bad "No valid solutions" |
|
| 160 |
in return sols1 |
|
| 161 |
|
|
| 162 |
tryReloc _ _ _ reqn _ = fail $ "Unsupported number of relocation \ |
|
| 163 |
\destinations required (" ++ (show reqn) ++
|
|
| 164 |
"), only one supported" |
|
| 165 |
|
|
| 166 |
filterFails :: (Monad m) => [(Maybe NodeList, [Node.Node])] |
|
| 167 |
-> m [(NodeList, [Node.Node])] |
|
| 168 |
filterFails sols = |
|
| 169 |
if null sols then fail "No nodes onto which to allocate at all" |
|
| 170 |
else let sols' = filter (isJust . fst) sols |
|
| 171 |
in if null sols' then |
|
| 172 |
fail "No valid allocation solutions" |
|
| 184 | 173 |
else |
| 185 |
let sols3 = map (\(x, y) -> |
|
| 186 |
(Cluster.compCV $ fromJust x, |
|
| 187 |
(fromJust x, y))) |
|
| 188 |
sols2 |
|
| 189 |
sols4 = sortBy (compare `on` fst) sols3 |
|
| 190 |
(best, (final_nl, winner)) = head sols4 |
|
| 191 |
(worst, (_, loser)) = last sols4 |
|
| 192 |
wnode = Container.find winner final_nl |
|
| 193 |
lnode = Container.find loser nl |
|
| 194 |
info = printf "Valid results: %d, best score: %.8f \ |
|
| 195 |
\(node %s), worst score: %.8f (node %s)" |
|
| 196 |
(length sols3) best (Node.name wnode) |
|
| 197 |
worst (Node.name lnode) |
|
| 198 |
in Ok (info, [wnode]) |
|
| 199 |
|
|
| 200 |
tryReloc _ _ _ reqn _ = Bad $ "Unsupported number of relocation \ |
|
| 201 |
\destinations required (" ++ (show reqn) ++
|
|
| 202 |
"), only one supported" |
|
| 174 |
return $ map (\(x, y) -> (fromJust x, y)) sols' |
|
| 175 |
|
|
| 176 |
processResults :: (Monad m) => [(NodeList, [Node.Node])] |
|
| 177 |
-> m (String, [Node.Node]) |
|
| 178 |
processResults sols = |
|
| 179 |
let sols' = map (\(nl', ns) -> (Cluster.compCV nl', ns)) sols |
|
| 180 |
sols'' = sortBy (compare `on` fst) sols' |
|
| 181 |
(best, w) = head sols'' |
|
| 182 |
(worst, l) = last sols'' |
|
| 183 |
info = printf "Valid results: %d, best score: %.8f (nodes %s), \ |
|
| 184 |
\worst score: %.8f (nodes %s)" (length sols'') |
|
| 185 |
best (intercalate "/" . map Node.name $ w) |
|
| 186 |
worst (intercalate "/" . map Node.name $ l) |
|
| 187 |
in return (info, w) |
|
| 203 | 188 |
|
| 204 | 189 |
-- | Main function. |
| 205 | 190 |
main :: IO () |
| ... | ... | |
| 226 | 211 |
Allocate xi reqn -> tryAlloc nl il xi reqn |
| 227 | 212 |
Relocate idx reqn exnodes -> |
| 228 | 213 |
tryReloc nl il idx reqn exnodes |
| 229 |
let (ok, info, rn) = case new_nodes of |
|
| 214 |
let sols = new_nodes >>= filterFails >>= processResults |
|
| 215 |
let (ok, info, rn) = case sols of |
|
| 230 | 216 |
Ok (info, sn) -> (True, "Request successful: " ++ info, |
| 231 |
map name sn)
|
|
| 217 |
map ((++ csf) . name) sn)
|
|
| 232 | 218 |
Bad s -> (False, "Request failed: " ++ s, []) |
| 233 | 219 |
resp = formatResponse ok info rn |
| 234 | 220 |
putStrLn resp |
Also available in: Unified diff