Revision dbba5246 hail.hs
b/hail.hs | ||
---|---|---|
52 | 52 |
"show help" |
53 | 53 |
] |
54 | 54 |
|
55 |
-- | Compute online nodes from a Node.List |
|
56 |
getOnline :: Node.List -> [Node.Node] |
|
57 |
getOnline = filter (not . Node.offline) . Container.elems |
|
58 |
|
|
59 |
-- | Try to allocate an instance on the cluster |
|
60 |
tryAlloc :: (Monad m) => |
|
61 |
Node.List |
|
62 |
-> Instance.List |
|
63 |
-> Instance.Instance |
|
64 |
-> Int |
|
65 |
-> m [(Maybe Node.List, [Node.Node])] |
|
66 |
tryAlloc nl _ inst 2 = |
|
67 |
let all_nodes = getOnline nl |
|
68 |
all_pairs = liftM2 (,) all_nodes all_nodes |
|
69 |
ok_pairs = filter (\(x, y) -> Node.idx x /= Node.idx y) all_pairs |
|
70 |
sols = map (\(p, s) -> |
|
71 |
(fst $ Cluster.allocateOnPair nl inst p s, [p, s])) |
|
72 |
ok_pairs |
|
73 |
in return sols |
|
74 |
|
|
75 |
tryAlloc nl _ inst 1 = |
|
76 |
let all_nodes = getOnline nl |
|
77 |
sols = map (\p -> (fst $ Cluster.allocateOnSingle nl inst p, [p])) |
|
78 |
all_nodes |
|
79 |
in return sols |
|
80 |
|
|
81 |
tryAlloc _ _ _ reqn = fail $ "Unsupported number of alllocation \ |
|
82 |
\destinations required (" ++ (show reqn) ++ |
|
83 |
"), only two supported" |
|
84 |
|
|
85 |
-- | Try to allocate an instance on the cluster |
|
86 |
tryReloc :: (Monad m) => |
|
87 |
Node.List |
|
88 |
-> Instance.List |
|
89 |
-> Idx |
|
90 |
-> Int |
|
91 |
-> [Ndx] |
|
92 |
-> m [(Maybe Node.List, [Node.Node])] |
|
93 |
tryReloc nl il xid 1 ex_idx = |
|
94 |
let all_nodes = getOnline nl |
|
95 |
inst = Container.find xid il |
|
96 |
ex_idx' = (Instance.pnode inst):ex_idx |
|
97 |
valid_nodes = filter (not . flip elem ex_idx' . Node.idx) all_nodes |
|
98 |
valid_idxes = map Node.idx valid_nodes |
|
99 |
sols1 = map (\x -> let (mnl, _, _, _) = |
|
100 |
Cluster.applyMove nl inst |
|
101 |
(Cluster.ReplaceSecondary x) |
|
102 |
in (mnl, [Container.find x nl]) |
|
103 |
) valid_idxes |
|
104 |
in return sols1 |
|
105 |
|
|
106 |
tryReloc _ _ _ reqn _ = fail $ "Unsupported number of relocation \ |
|
107 |
\destinations required (" ++ (show reqn) ++ |
|
108 |
"), only one supported" |
|
109 | 55 |
|
110 | 56 |
filterFails :: (Monad m) => [(Maybe Node.List, [Node.Node])] |
111 | 57 |
-> m [(Node.List, [Node.Node])] |
... | ... | |
151 | 97 |
|
152 | 98 |
let Request rqtype nl il csf = request |
153 | 99 |
new_nodes = case rqtype of |
154 |
Allocate xi reqn -> tryAlloc nl il xi reqn |
|
100 |
Allocate xi reqn -> Cluster.tryAlloc nl il xi reqn
|
|
155 | 101 |
Relocate idx reqn exnodes -> |
156 |
tryReloc nl il idx reqn exnodes |
|
102 |
Cluster.tryReloc nl il idx reqn exnodes
|
|
157 | 103 |
let sols = new_nodes >>= filterFails >>= processResults |
158 | 104 |
let (ok, info, rn) = case sols of |
159 | 105 |
Ok (info, sn) -> (True, "Request successful: " ++ info, |
Also available in: Unified diff