Since we added the score to AllocElement, we don't need to wrap
AllocElement in yet another tuple, just to attach the cluster score. So
we simplify the AllocSolution type.
---
Ganeti/HTools/Cluster.hs | 14 +++++++-------
Ganeti/HTools/QC.hs | 4 ++--
hail.hs | 8 ++++----
3 files changed, 13 insertions(+), 13 deletions(-)
diff --git a/Ganeti/HTools/Cluster.hs b/Ganeti/HTools/Cluster.hs
index c52093d..8ba4edc 100644
--- a/Ganeti/HTools/Cluster.hs
+++ b/Ganeti/HTools/Cluster.hs
@@ -81,7 +81,7 @@ import qualified Ganeti.OpCodes as OpCodes
-- * Types
-- | Allocation\/relocation solution.
-type AllocSolution = ([FailMode], Int, [(Score, Node.AllocElement)])
+type AllocSolution = ([FailMode], Int, [Node.AllocElement])
-- | The complete state for the balancing solution
data Table = Table Node.List Instance.List Score [Placement]
@@ -538,15 +538,15 @@ concatAllocs (flst, cntok, sols) (OpFail reason) =
(reason:flst, cntok, sols)
concatAllocs (flst, cntok, osols) (OpGood ns@(_, _, _, nscore)) =
let -- Choose the old or new solution, based on the cluster score
nsols = case osols of
- [] -> [(nscore, ns)]
- (oscore, _):[] ->
+ [] -> [ns]
+ (_, _, _, oscore):[] ->
if oscore < nscore
then osols
- else [(nscore, ns)]
+ else [ns]
-- FIXME: here we simply concat to lists with more
-- than one element; we should instead abort, since
-- this is not a valid usage of this function
- xs -> (nscore, ns):xs
+ xs -> ns:xs
nsuc = cntok + 1
-- Note: we force evaluation of nsols here in order to keep the
-- memory profile low - we know that we will need nsols for sure
@@ -624,7 +624,7 @@ tryEvac nl il ex_ndx =
-- FIXME: hardcoded one node here
(fm, cs, aes) <- tryReloc nl' il idx 1 ex_ndx
case aes of
- csol@(_, (nl'', _, _, _)):_ ->
+ csol@(nl'', _, _, _):_ ->
return (nl'', (fm, cs, csol:rsols))
_ -> fail $ "Can't evacuate instance " ++
Instance.name (Container.find idx il)
@@ -649,7 +649,7 @@ iterateAlloc nl il newinst nreq ixes =
Ok (errs, _, sols3) ->
case sols3 of
[] -> Ok (collapseFailures errs, nl, il, ixes)
- (_, (xnl, xi, _, _)):[] ->
+ (xnl, xi, _, _):[] ->
iterateAlloc xnl (Container.add newidx xi il)
newinst nreq $! (xi:ixes)
_ -> Bad "Internal error: multiple solutions for single\
diff --git a/Ganeti/HTools/QC.hs b/Ganeti/HTools/QC.hs
index f411a8e..9f471ce 100644
--- a/Ganeti/HTools/QC.hs
+++ b/Ganeti/HTools/QC.hs
@@ -676,7 +676,7 @@ prop_ClusterAlloc_sane node inst =
Types.Ok (_, _, sols3) ->
case sols3 of
[] -> False
- (_, (xnl, xi, _, cv)):[] ->
+ (xnl, xi, _, cv):[] ->
let il' = Container.add (Instance.idx xi) xi il
tbl = Cluster.Table xnl il' cv []
in not (canBalance tbl True False)
@@ -716,7 +716,7 @@ prop_ClusterAllocEvac node inst =
Types.Ok (_, _, sols3) ->
case sols3 of
[] -> False
- (_, (xnl, xi, _, _)):[] ->
+ (xnl, xi, _, _):[] ->
let sdx = Instance.sNode xi
il' = Container.add (Instance.idx xi) xi il
in case Cluster.tryEvac xnl il' [sdx] of
diff --git a/hail.hs b/hail.hs
index 2f00da2..90902e6 100644
--- a/hail.hs
+++ b/hail.hs
@@ -4,7 +4,7 @@
{-
-Copyright (C) 2009 Google Inc.
+Copyright (C) 2009, 2010 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -51,7 +51,7 @@ processResults :: (Monad m) =>
-> m (String, Cluster.AllocSolution)
processResults _ (_, _, []) = fail "No valid allocation solutions"
processResults (Evacuate _) as@(fstats, successes, sols) =
- let best = fst $ head sols
+ let (_, _, _, best) = head sols
tfails = length fstats
info = printf "for last allocation, successes %d, failures %d,\
\ best score: %.8f" successes tfails best::String
@@ -59,7 +59,7 @@ processResults (Evacuate _) as@(fstats, successes, sols) =
processResults _ as@(fstats, successes, sols) =
case sols of
- (best, (_, _, w, _)):[] ->
+ (_, _, w, best):[] ->
let tfails = length fstats
info = printf "successes %d, failures %d,\
\ best score: %.8f for node(s) %s"
@@ -108,7 +108,7 @@ main = do
let (ok, info, rn) =
case sols of
Ok (ginfo, (_, _, sn)) -> (True, "Request successful: " ++ ginfo,
- map snd sn)
+ sn)
Bad s -> (False, "Request failed: " ++ s, [])
resp = formatResponse ok info rq rn
putStrLn resp
--
1.7.2.3
