Revision 418a9d72 src/Ganeti/HTools/Cluster.hs
| b/src/Ganeti/HTools/Cluster.hs | ||
|---|---|---|
| 77 | 77 |
) where |
| 78 | 78 |
|
| 79 | 79 |
import Control.Applicative (liftA2) |
| 80 |
import Control.Arrow ((&&&)) |
|
| 80 | 81 |
import qualified Data.IntSet as IntSet |
| 81 | 82 |
import Data.List |
| 82 | 83 |
import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) |
| ... | ... | |
| 1283 | 1284 |
-- | Predicate whether shrinking a single resource can lead to a valid |
| 1284 | 1285 |
-- allocation. |
| 1285 | 1286 |
sufficesShrinking :: (Instance.Instance -> AllocSolution) -> Instance.Instance |
| 1286 |
-> FailMode -> Bool
|
|
| 1287 |
-> FailMode -> Maybe Instance.Instance
|
|
| 1287 | 1288 |
sufficesShrinking allocFn inst fm = |
| 1288 |
any isJust |
|
| 1289 |
. map asSolution |
|
| 1290 |
. takeWhile (liftA2 (||) (elem fm . asFailures) (isJust . asSolution)) |
|
| 1291 |
. map allocFn $ |
|
| 1292 |
iterateOk (`Instance.shrinkByType` fm) inst |
|
| 1289 |
case dropWhile (isNothing . asSolution . fst) |
|
| 1290 |
. takeWhile (liftA2 (||) (elem fm . asFailures . fst) |
|
| 1291 |
(isJust . asSolution . fst)) |
|
| 1292 |
. map (allocFn &&& id) $ |
|
| 1293 |
iterateOk (`Instance.shrinkByType` fm) inst |
|
| 1294 |
of x:_ -> Just . snd $ x |
|
| 1295 |
_ -> Nothing |
|
| 1293 | 1296 |
|
| 1294 | 1297 |
-- | Tiered allocation method. |
| 1295 | 1298 |
-- |
| ... | ... | |
| 1311 | 1314 |
suffShrink = sufficesShrinking (fromMaybe emptyAllocSolution |
| 1312 | 1315 |
. flip (tryAlloc nl' il') allocnodes) |
| 1313 | 1316 |
newinst |
| 1317 |
bigSteps = filter isJust . map suffShrink . reverse $ sortedErrs |
|
| 1314 | 1318 |
in if stop then newsol else |
| 1315 |
case Instance.shrinkByType newinst . last $ |
|
| 1316 |
sortedErrs ++ filter suffShrink sortedErrs of |
|
| 1317 |
Bad _ -> newsol |
|
| 1318 |
Ok newinst' -> tieredAlloc nl' il' newlimit |
|
| 1319 |
newinst' allocnodes ixes' cstats' |
|
| 1319 |
case bigSteps of |
|
| 1320 |
Just newinst':_ -> tieredAlloc nl' il' newlimit |
|
| 1321 |
newinst' allocnodes ixes' cstats' |
|
| 1322 |
_ -> case Instance.shrinkByType newinst . last $ sortedErrs of |
|
| 1323 |
Bad _ -> newsol |
|
| 1324 |
Ok newinst' -> tieredAlloc nl' il' newlimit |
|
| 1325 |
newinst' allocnodes ixes' cstats' |
|
| 1320 | 1326 |
|
| 1321 | 1327 |
-- * Formatting functions |
| 1322 | 1328 |
|
Also available in: Unified diff