## 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