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

hail: unify the post-processing of results

Both allocate and relocate compute new node lists, whose score must be
ranked and the best option chosen. This means we can convert the code to
a generic function.
parent 4a340313
...@@ -114,55 +114,36 @@ options = ...@@ -114,55 +114,36 @@ options =
] ]
-- | Try to allocate an instance on the cluster -- | Try to allocate an instance on the cluster
tryAlloc :: NodeList tryAlloc :: (Monad m) =>
NodeList
-> InstanceList -> InstanceList
-> Instance.Instance -> Instance.Instance
-> Int -> Int
-> Result (String, [Node.Node]) -> m [(Maybe NodeList, [Node.Node])]
tryAlloc nl il inst 2 = tryAlloc nl il inst 2 =
let all_nodes = Container.elems nl let all_nodes = Container.elems nl
all_nidx = map Node.idx all_nodes
all_pairs = liftM2 (,) all_nodes all_nodes all_pairs = liftM2 (,) all_nodes all_nodes
ok_pairs = filter (\(x, y) -> Node.idx x /= Node.idx y) all_pairs ok_pairs = filter (\(x, y) -> Node.idx x /= Node.idx y) all_pairs
sols1 = map (\(p, s) -> let pdx = Node.idx p sols1 = map (\(p, s) -> let pdx = Node.idx p
sdx = Node.idx s sdx = Node.idx s
(mnl, _) = Cluster.allocateOn nl (mnl, _) = Cluster.allocateOn nl
inst pdx sdx inst pdx sdx
in (mnl, (p, s)) in (mnl, [p, s])
) ok_pairs ) ok_pairs
sols2 = filter (isJust . fst) sols1 in return sols1
in if null sols1 then
Bad "No pairs onto which to allocate at all" tryAlloc _ _ _ reqn = fail $ "Unsupported number of alllocation \
else if null sols2 then \destinations required (" ++ (show reqn) ++
Bad "No valid allocation solutions" "), only two supported"
else
let sols3 = map (\(x, (y, z)) ->
(Cluster.compCV $ fromJust x,
(fromJust x, y, z)))
sols2
sols4 = sortBy (compare `on` fst) sols3
(best, (final_nl, w1, w2)) = head sols4
(worst, (_, l1, l2)) = last sols4
info = printf "Valid results: %d, best score: %.8f \
\(nodes %s/%s), worst score: %.8f (nodes \
\%s/%s)"
(length sols3)
best (Node.name w1) (Node.name w2)
worst (Node.name l1) (Node.name w2)
in Ok (info, [w1, w2])
tryAlloc _ _ _ reqn = Bad $ "Unsupported number of alllocation \
\destinations required (" ++ (show reqn) ++
"), only two supported"
-- | Try to allocate an instance on the cluster -- | Try to allocate an instance on the cluster
tryReloc :: NodeList tryReloc :: (Monad m) =>
NodeList
-> InstanceList -> InstanceList
-> Int -> Int
-> Int -> Int
-> [Int] -> [Int]
-> Result (String, [Node.Node]) -> m [(Maybe NodeList, [Node.Node])]
tryReloc nl il xid 1 ex_idx = tryReloc nl il xid 1 ex_idx =
let all_nodes = Container.elems nl let all_nodes = Container.elems nl
inst = Container.find xid il inst = Container.find xid il
...@@ -174,32 +155,36 @@ tryReloc nl il xid 1 ex_idx = ...@@ -174,32 +155,36 @@ tryReloc nl il xid 1 ex_idx =
sols1 = map (\x -> let (mnl, _, _, _) = sols1 = map (\x -> let (mnl, _, _, _) =
Cluster.applyMove nl' inst Cluster.applyMove nl' inst
(Cluster.ReplaceSecondary x) (Cluster.ReplaceSecondary x)
in (mnl, x) in (mnl, [Container.find x nl'])
) valid_idxes ) valid_idxes
sols2 = filter (isJust . fst) sols1 in return sols1
in if null sols1 then
Bad "No nodes onto which to relocate at all" tryReloc _ _ _ reqn _ = fail $ "Unsupported number of relocation \
else if null sols2 then \destinations required (" ++ (show reqn) ++
Bad "No valid solutions" "), only one supported"
filterFails :: (Monad m) => [(Maybe NodeList, [Node.Node])]
-> m [(NodeList, [Node.Node])]
filterFails sols =
if null sols then fail "No nodes onto which to allocate at all"
else let sols' = filter (isJust . fst) sols
in if null sols' then
fail "No valid allocation solutions"
else else
let sols3 = map (\(x, y) -> return $ map (\(x, y) -> (fromJust x, y)) sols'
(Cluster.compCV $ fromJust x,
(fromJust x, y))) processResults :: (Monad m) => [(NodeList, [Node.Node])]
sols2 -> m (String, [Node.Node])
sols4 = sortBy (compare `on` fst) sols3 processResults sols =
(best, (final_nl, winner)) = head sols4 let sols' = map (\(nl', ns) -> (Cluster.compCV nl', ns)) sols
(worst, (_, loser)) = last sols4 sols'' = sortBy (compare `on` fst) sols'
wnode = Container.find winner final_nl (best, w) = head sols''
lnode = Container.find loser nl (worst, l) = last sols''
info = printf "Valid results: %d, best score: %.8f \ info = printf "Valid results: %d, best score: %.8f (nodes %s), \
\(node %s), worst score: %.8f (node %s)" \worst score: %.8f (nodes %s)" (length sols'')
(length sols3) best (Node.name wnode) best (intercalate "/" . map Node.name $ w)
worst (Node.name lnode) worst (intercalate "/" . map Node.name $ l)
in Ok (info, [wnode]) in return (info, w)
tryReloc _ _ _ reqn _ = Bad $ "Unsupported number of relocation \
\destinations required (" ++ (show reqn) ++
"), only one supported"
-- | Main function. -- | Main function.
main :: IO () main :: IO ()
...@@ -226,9 +211,10 @@ main = do ...@@ -226,9 +211,10 @@ main = do
Allocate xi reqn -> tryAlloc nl il xi reqn Allocate xi reqn -> tryAlloc nl il xi reqn
Relocate idx reqn exnodes -> Relocate idx reqn exnodes ->
tryReloc nl il idx reqn exnodes tryReloc nl il idx reqn exnodes
let (ok, info, rn) = case new_nodes of let sols = new_nodes >>= filterFails >>= processResults
let (ok, info, rn) = case sols of
Ok (info, sn) -> (True, "Request successful: " ++ info, Ok (info, sn) -> (True, "Request successful: " ++ info,
map name sn) map ((++ csf) . name) sn)
Bad s -> (False, "Request failed: " ++ s, []) Bad s -> (False, "Request failed: " ++ s, [])
resp = formatResponse ok info rn resp = formatResponse ok info rn
putStrLn resp 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