code.grnet.gr Git - ganeti-local/blob - Ganeti/HTools/Cluster.hs

   1 {-| Implementation of cluster-wide logic.
   2
   3 This module holds all pure cluster-logic; I\/O related functionality
   4 goes into the "Main" module for the individual binaries.
   5
   6 -}
   7
   8 module Ganeti.HTools.Cluster
   9     (
  10      -- * Types
  11      NodeList
  12     , InstanceList
  13     , NameList
  14     , Placement
  15     , Solution(..)
  16     , Table(..)
  17     , Removal
  18     , Score
  19     , IMove(..)
  20     -- * Generic functions
  21     , totalResources
  22     -- * First phase functions
  23     , computeBadItems
  24     -- * Second phase functions
  25     , computeSolution
  26     , applySolution
  27     , printSolution
  28     , printSolutionLine
  29     , formatCmds
  30     , printNodes
  31     -- * Balacing functions
  32     , applyMove
  33     , checkMove
  34     , compCV
  35     , printStats
  36     -- * IAllocator functions
  37     , allocateOn
  38     ) where
  39
  40 import Data.List
  41 import Data.Maybe (isNothing, fromJust)
  42 import Text.Printf (printf)
  43 import Data.Function
  44 import Control.Monad
  45
  46 import qualified Ganeti.HTools.Container as Container
  47 import qualified Ganeti.HTools.Instance as Instance
  48 import qualified Ganeti.HTools.Node as Node
  49 import Ganeti.HTools.Types
  50 import Ganeti.HTools.Utils
  51
  52 -- | A separate name for the cluster score type
  53 type Score = Double
  54
  55 -- | The description of an instance placement.
  56 type Placement = (Int, Int, Int, Score)
  57
  58 {- | A cluster solution described as the solution delta and the list
  59 of placements.
  60
  61 -}
  62 data Solution = Solution Int [Placement]
  63                 deriving (Eq, Ord, Show)
  64
  65 -- | Returns the delta of a solution or -1 for Nothing
  66 solutionDelta :: Maybe Solution -> Int
  67 solutionDelta sol = case sol of
  68                       Just (Solution d _) -> d
  69                       _ -> -1
  70
  71 -- | A removal set.
  72 data Removal = Removal NodeList [Instance.Instance]
  73
  74 -- | An instance move definition
  75 data IMove = Failover                -- ^ Failover the instance (f)
  76            | ReplacePrimary Int      -- ^ Replace primary (f, r:np, f)
  77            | ReplaceSecondary Int    -- ^ Replace secondary (r:ns)
  78            | ReplaceAndFailover Int  -- ^ Replace secondary, failover (r:np, f)
  79            | FailoverAndReplace Int  -- ^ Failover, replace secondary (f, r:ns)
  80              deriving (Show)
  81
  82 -- | The complete state for the balancing solution
  83 data Table = Table NodeList InstanceList Score [Placement]
  84              deriving (Show)
  85
  86 -- General functions
  87
  88 -- | Cap the removal list if needed.
  89 capRemovals :: [a] -> Int -> [a]
  90 capRemovals removals max_removals =
  91     if max_removals > 0 then
  92         take max_removals removals
  93     else
  94         removals
  95
  96 -- | Check if the given node list fails the N+1 check.
  97 verifyN1Check :: [Node.Node] -> Bool
  98 verifyN1Check nl = any Node.failN1 nl
  99
 100 -- | Verifies the N+1 status and return the affected nodes.
 101 verifyN1 :: [Node.Node] -> [Node.Node]
 102 verifyN1 nl = filter Node.failN1 nl
 103
 104 {-| Add an instance and return the new node and instance maps. -}
 105 addInstance :: NodeList -> Instance.Instance ->
 106                Node.Node -> Node.Node -> Maybe NodeList
 107 addInstance nl idata pri sec =
 108   let pdx = Node.idx pri
 109       sdx = Node.idx sec
 110   in do
 111       pnode <- Node.addPri pri idata
 112       snode <- Node.addSec sec idata pdx
 113       new_nl <- return $ Container.addTwo sdx snode
 114                          pdx pnode nl
 115       return new_nl
 116
 117 -- | Remove an instance and return the new node and instance maps.
 118 removeInstance :: NodeList -> Instance.Instance -> NodeList
 119 removeInstance nl idata =
 120   let pnode = Instance.pnode idata
 121       snode = Instance.snode idata
 122       pn = Container.find pnode nl
 123       sn = Container.find snode nl
 124       new_nl = Container.addTwo
 125                pnode (Node.removePri pn idata)
 126                snode (Node.removeSec sn idata) nl in
 127   new_nl
 128
 129 -- | Remove an instance and return the new node map.
 130 removeInstances :: NodeList -> [Instance.Instance] -> NodeList
 131 removeInstances = foldl' removeInstance
 132
 133 -- | Compute the total free disk and memory in the cluster.
 134 totalResources :: Container.Container Node.Node -> (Int, Int)
 135 totalResources nl =
 136     foldl'
 137     (\ (mem, dsk) node -> (mem + (Node.f_mem node),
 138                            dsk + (Node.f_dsk node)))
 139     (0, 0) (Container.elems nl)
 140
 141 {- | Compute a new version of a cluster given a solution.
 142
 143 This is not used for computing the solutions, but for applying a
 144 (known-good) solution to the original cluster for final display.
 145
 146 It first removes the relocated instances after which it places them on
 147 their new nodes.
 148
 149  -}
 150 applySolution :: NodeList -> InstanceList -> [Placement] -> NodeList
 151 applySolution nl il sol =
 152     let odxes = map (\ (a, b, c, _) -> (Container.find a il,
 153                                         Node.idx (Container.find b nl),
 154                                         Node.idx (Container.find c nl))
 155                     ) sol
 156         idxes = (\ (x, _, _) -> x) (unzip3 odxes)
 157         nc = removeInstances nl idxes
 158     in
 159       foldl' (\ nz (a, b, c) ->
 160                  let new_p = Container.find b nz
 161                      new_s = Container.find c nz in
 162                  fromJust (addInstance nz a new_p new_s)
 163            ) nc odxes
 164
 165
 166 -- First phase functions
 167
 168 {- | Given a list 1,2,3..n build a list of pairs [(1, [2..n]), (2,
 169     [3..n]), ...]
 170
 171 -}
 172 genParts :: [a] -> Int -> [(a, [a])]
 173 genParts l count =
 174     case l of
 175       [] -> []
 176       x:xs ->
 177           if length l < count then
 178               []
 179           else
 180               (x, xs) : (genParts xs count)
 181
 182 -- | Generates combinations of count items from the names list.
 183 genNames :: Int -> [b] -> [[b]]
 184 genNames count1 names1 =
 185   let aux_fn count names current =
 186           case count of
 187             0 -> [current]
 188             _ ->
 189                 concatMap
 190                 (\ (x, xs) -> aux_fn (count - 1) xs (x:current))
 191                 (genParts names count)
 192   in
 193     aux_fn count1 names1 []
 194
 195 {- | Computes the pair of bad nodes and instances.
 196
 197 The bad node list is computed via a simple 'verifyN1' check, and the
 198 bad instance list is the list of primary and secondary instances of
 199 those nodes.
 200
 201 -}
 202 computeBadItems :: NodeList -> InstanceList ->
 203                    ([Node.Node], [Instance.Instance])
 204 computeBadItems nl il =
 205   let bad_nodes = verifyN1 $ filter (not . Node.offline) $ Container.elems nl
 206       bad_instances = map (\idx -> Container.find idx il) $
 207                       sort $ nub $ concat $
 208                       map (\ n -> (Node.slist n) ++ (Node.plist n)) bad_nodes
 209   in
 210     (bad_nodes, bad_instances)
 211
 212
 213 {- | Checks if removal of instances results in N+1 pass.
 214
 215 Note: the check removal cannot optimize by scanning only the affected
 216 nodes, since the cluster is known to be not healthy; only the check
 217 placement can make this shortcut.
 218
 219 -}
 220 checkRemoval :: NodeList -> [Instance.Instance] -> Maybe Removal
 221 checkRemoval nl victims =
 222   let nx = removeInstances nl victims
 223       failN1 = verifyN1Check (Container.elems nx)
 224   in
 225     if failN1 then
 226       Nothing
 227     else
 228       Just $ Removal nx victims
 229
 230
 231 -- | Computes the removals list for a given depth
 232 computeRemovals :: NodeList
 233                  -> [Instance.Instance]
 234                  -> Int
 235                  -> [Maybe Removal]
 236 computeRemovals nl bad_instances depth =
 237     map (checkRemoval nl) $ genNames depth bad_instances
 238
 239 -- Second phase functions
 240
 241 -- | Single-node relocation cost
 242 nodeDelta :: Int -> Int -> Int -> Int
 243 nodeDelta i p s =
 244     if i == p || i == s then
 245         0
 246     else
 247         1
 248
 249 {-| Compute best solution.
 250
 251     This function compares two solutions, choosing the minimum valid
 252     solution.
 253 -}
 254 compareSolutions :: Maybe Solution -> Maybe Solution -> Maybe Solution
 255 compareSolutions a b = case (a, b) of
 256   (Nothing, x) -> x
 257   (x, Nothing) -> x
 258   (x, y) -> min x y
 259
 260 -- | Compute best table. Note that the ordering of the arguments is important.
 261 compareTables :: Table -> Table -> Table
 262 compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) =
 263     if a_cv > b_cv then b else a
 264
 265 -- | Check if a given delta is worse then an existing solution.
 266 tooHighDelta :: Maybe Solution -> Int -> Int -> Bool
 267 tooHighDelta sol new_delta max_delta =
 268     if new_delta > max_delta && max_delta >=0 then
 269         True
 270     else
 271         case sol of
 272           Nothing -> False
 273           Just (Solution old_delta _) -> old_delta <= new_delta
 274
 275 {-| Check if placement of instances still keeps the cluster N+1 compliant.
 276
 277     This is the workhorse of the allocation algorithm: given the
 278     current node and instance maps, the list of instances to be
 279     placed, and the current solution, this will return all possible
 280     solution by recursing until all target instances are placed.
 281
 282 -}
 283 checkPlacement :: NodeList            -- ^ The current node list
 284                -> [Instance.Instance] -- ^ List of instances still to place
 285                -> [Placement]         -- ^ Partial solution until now
 286                -> Int                 -- ^ The delta of the partial solution
 287                -> Maybe Solution      -- ^ The previous solution
 288                -> Int                 -- ^ Abort if the we go above this delta
 289                -> Maybe Solution      -- ^ The new solution
 290 checkPlacement nl victims current current_delta prev_sol max_delta =
 291   let target = head victims
 292       opdx = Instance.pnode target
 293       osdx = Instance.snode target
 294       vtail = tail victims
 295       have_tail = (length vtail) > 0
 296       nodes = Container.elems nl
 297       iidx = Instance.idx target
 298   in
 299     foldl'
 300     (\ accu_p pri ->
 301          let
 302              pri_idx = Node.idx pri
 303              upri_delta = current_delta + nodeDelta pri_idx opdx osdx
 304              new_pri = Node.addPri pri target
 305              fail_delta1 = tooHighDelta accu_p upri_delta max_delta
 306          in
 307            if fail_delta1 || isNothing(new_pri) then accu_p
 308            else let pri_nl = Container.add pri_idx (fromJust new_pri) nl in
 309                 foldl'
 310                 (\ accu sec ->
 311                      let
 312                          sec_idx = Node.idx sec
 313                          upd_delta = upri_delta +
 314                                      nodeDelta sec_idx opdx osdx
 315                          fail_delta2 = tooHighDelta accu upd_delta max_delta
 316                          new_sec = Node.addSec sec target pri_idx
 317                      in
 318                        if sec_idx == pri_idx || fail_delta2 ||
 319                           isNothing new_sec then accu
 320                        else let
 321                            nx = Container.add sec_idx (fromJust new_sec) pri_nl
 322                            upd_cv = compCV nx
 323                            plc = (iidx, pri_idx, sec_idx, upd_cv)
 324                            c2 = plc:current
 325                            result =
 326                                if have_tail then
 327                                    checkPlacement nx vtail c2 upd_delta
 328                                                   accu max_delta
 329                                else
 330                                    Just (Solution upd_delta c2)
 331                       in compareSolutions accu result
 332                 ) accu_p nodes
 333     ) prev_sol nodes
 334
 335 -- | Apply a move
 336 applyMove :: NodeList -> Instance.Instance
 337           -> IMove -> (Maybe NodeList, Instance.Instance, Int, Int)
 338 -- Failover (f)
 339 applyMove nl inst Failover =
 340     let old_pdx = Instance.pnode inst
 341         old_sdx = Instance.snode inst
 342         old_p = Container.find old_pdx nl
 343         old_s = Container.find old_sdx nl
 344         int_p = Node.removePri old_p inst
 345         int_s = Node.removeSec old_s inst
 346         new_nl = do -- Maybe monad
 347           new_p <- Node.addPri int_s inst
 348           new_s <- Node.addSec int_p inst old_sdx
 349           return $ Container.addTwo old_pdx new_s old_sdx new_p nl
 350     in (new_nl, Instance.setBoth inst old_sdx old_pdx, old_sdx, old_pdx)
 351
 352 -- Replace the primary (f:, r:np, f)
 353 applyMove nl inst (ReplacePrimary new_pdx) =
 354     let old_pdx = Instance.pnode inst
 355         old_sdx = Instance.snode inst
 356         old_p = Container.find old_pdx nl
 357         old_s = Container.find old_sdx nl
 358         tgt_n = Container.find new_pdx nl
 359         int_p = Node.removePri old_p inst
 360         int_s = Node.removeSec old_s inst
 361         new_nl = do -- Maybe monad
 362           new_p <- Node.addPri tgt_n inst
 363           new_s <- Node.addSec int_s inst new_pdx
 364           return $ Container.add new_pdx new_p $
 365                  Container.addTwo old_pdx int_p old_sdx new_s nl
 366     in (new_nl, Instance.setPri inst new_pdx, new_pdx, old_sdx)
 367
 368 -- Replace the secondary (r:ns)
 369 applyMove nl inst (ReplaceSecondary new_sdx) =
 370     let old_pdx = Instance.pnode inst
 371         old_sdx = Instance.snode inst
 372         old_s = Container.find old_sdx nl
 373         tgt_n = Container.find new_sdx nl
 374         int_s = Node.removeSec old_s inst
 375         new_nl = Node.addSec tgt_n inst old_pdx >>=
 376                  \new_s -> return $ Container.addTwo new_sdx
 377                            new_s old_sdx int_s nl
 378     in (new_nl, Instance.setSec inst new_sdx, old_pdx, new_sdx)
 379
 380 -- Replace the secondary and failover (r:np, f)
 381 applyMove nl inst (ReplaceAndFailover new_pdx) =
 382     let old_pdx = Instance.pnode inst
 383         old_sdx = Instance.snode inst
 384         old_p = Container.find old_pdx nl
 385         old_s = Container.find old_sdx nl
 386         tgt_n = Container.find new_pdx nl
 387         int_p = Node.removePri old_p inst
 388         int_s = Node.removeSec old_s inst
 389         new_nl = do -- Maybe monad
 390           new_p <- Node.addPri tgt_n inst
 391           new_s <- Node.addSec int_p inst new_pdx
 392           return $ Container.add new_pdx new_p $
 393                  Container.addTwo old_pdx new_s old_sdx int_s nl
 394     in (new_nl, Instance.setBoth inst new_pdx old_pdx, new_pdx, old_pdx)
 395
 396 -- Failver and replace the secondary (f, r:ns)
 397 applyMove nl inst (FailoverAndReplace new_sdx) =
 398     let old_pdx = Instance.pnode inst
 399         old_sdx = Instance.snode inst
 400         old_p = Container.find old_pdx nl
 401         old_s = Container.find old_sdx nl
 402         tgt_n = Container.find new_sdx nl
 403         int_p = Node.removePri old_p inst
 404         int_s = Node.removeSec old_s inst
 405         new_nl = do -- Maybe monad
 406           new_p <- Node.addPri int_s inst
 407           new_s <- Node.addSec tgt_n inst old_sdx
 408           return $ Container.add new_sdx new_s $
 409                  Container.addTwo old_sdx new_p old_pdx int_p nl
 410     in (new_nl, Instance.setBoth inst old_sdx new_sdx, old_sdx, new_sdx)
 411
 412 allocateOn nl inst new_pdx new_sdx =
 413     let
 414         tgt_p = Container.find new_pdx nl
 415         tgt_s = Container.find new_sdx nl
 416         new_nl = do -- Maybe monad
 417           new_p <- Node.addPri tgt_p inst
 418           new_s <- Node.addSec tgt_s inst new_pdx
 419           return $ Container.addTwo new_pdx new_p new_sdx new_s nl
 420     in (new_nl, Instance.setBoth inst new_pdx new_sdx)
 421
 422 checkSingleStep :: Table -- ^ The original table
 423                 -> Instance.Instance -- ^ The instance to move
 424                 -> Table -- ^ The current best table
 425                 -> IMove -- ^ The move to apply
 426                 -> Table -- ^ The final best table
 427 checkSingleStep ini_tbl target cur_tbl move =
 428     let
 429         Table ini_nl ini_il _ ini_plc = ini_tbl
 430         (tmp_nl, new_inst, pri_idx, sec_idx) = applyMove ini_nl target move
 431     in
 432       if isNothing tmp_nl then cur_tbl
 433       else
 434           let tgt_idx = Instance.idx target
 435               upd_nl = fromJust tmp_nl
 436               upd_cvar = compCV upd_nl
 437               upd_il = Container.add tgt_idx new_inst ini_il
 438               upd_plc = (tgt_idx, pri_idx, sec_idx, upd_cvar):ini_plc
 439               upd_tbl = Table upd_nl upd_il upd_cvar upd_plc
 440           in
 441             compareTables cur_tbl upd_tbl
 442
 443 -- | Given the status of the current secondary as a valid new node
 444 -- and the current candidate target node,
 445 -- generate the possible moves for a instance.
 446 possibleMoves :: Bool -> Int -> [IMove]
 447 possibleMoves True tdx =
 448     [ReplaceSecondary tdx,
 449      ReplaceAndFailover tdx,
 450      ReplacePrimary tdx,
 451      FailoverAndReplace tdx]
 452
 453 possibleMoves False tdx =
 454     [ReplaceSecondary tdx,
 455      ReplaceAndFailover tdx]
 456
 457 -- | Compute the best move for a given instance.
 458 checkInstanceMove :: [Int]             -- Allowed target node indices
 459                   -> Table             -- Original table
 460                   -> Instance.Instance -- Instance to move
 461                   -> Table             -- Best new table for this instance
 462 checkInstanceMove nodes_idx ini_tbl target =
 463     let
 464         opdx = Instance.pnode target
 465         osdx = Instance.snode target
 466         nodes = filter (\idx -> idx /= opdx && idx /= osdx) nodes_idx
 467         use_secondary = elem osdx nodes_idx
 468         aft_failover = if use_secondary -- if allowed to failover
 469                        then checkSingleStep ini_tbl target ini_tbl Failover
 470                        else ini_tbl
 471         all_moves = concatMap (possibleMoves use_secondary) nodes
 472     in
 473       -- iterate over the possible nodes for this instance
 474       foldl' (checkSingleStep ini_tbl target) aft_failover all_moves
 475
 476 -- | Compute the best next move.
 477 checkMove :: [Int]               -- ^ Allowed target node indices
 478           -> Table               -- ^ The current solution
 479           -> [Instance.Instance] -- ^ List of instances still to move
 480           -> Table               -- ^ The new solution
 481 checkMove nodes_idx ini_tbl victims =
 482     let Table _ _ _ ini_plc = ini_tbl
 483         -- iterate over all instances, computing the best move
 484         best_tbl =
 485             foldl'
 486             (\ step_tbl elem ->
 487                  if Instance.snode elem == Node.noSecondary then step_tbl
 488                     else compareTables step_tbl $
 489                          checkInstanceMove nodes_idx ini_tbl elem)
 490             ini_tbl victims
 491         Table _ _ _ best_plc = best_tbl
 492     in
 493       if length best_plc == length ini_plc then -- no advancement
 494           ini_tbl
 495       else
 496           best_tbl
 497
 498 {- | Auxiliary function for solution computation.
 499
 500 We write this in an explicit recursive fashion in order to control
 501 early-abort in case we have met the min delta. We can't use foldr
 502 instead of explicit recursion since we need the accumulator for the
 503 abort decision.
 504
 505 -}
 506 advanceSolution :: [Maybe Removal] -- ^ The removal to process
 507                 -> Int             -- ^ Minimum delta parameter
 508                 -> Int             -- ^ Maximum delta parameter
 509                 -> Maybe Solution  -- ^ Current best solution
 510                 -> Maybe Solution  -- ^ New best solution
 511 advanceSolution [] _ _ sol = sol
 512 advanceSolution (Nothing:xs) m n sol = advanceSolution xs m n sol
 513 advanceSolution ((Just (Removal nx removed)):xs) min_d max_d prev_sol =
 514     let new_sol = checkPlacement nx removed [] 0 prev_sol max_d
 515         new_delta = solutionDelta $! new_sol
 516     in
 517       if new_delta >= 0 && new_delta <= min_d then
 518           new_sol
 519       else
 520           advanceSolution xs min_d max_d new_sol
 521
 522 -- | Computes the placement solution.
 523 solutionFromRemovals :: [Maybe Removal] -- ^ The list of (possible) removals
 524                      -> Int             -- ^ Minimum delta parameter
 525                      -> Int             -- ^ Maximum delta parameter
 526                      -> Maybe Solution  -- ^ The best solution found
 527 solutionFromRemovals removals min_delta max_delta =
 528     advanceSolution removals min_delta max_delta Nothing
 529
 530 {- | Computes the solution at the given depth.
 531
 532 This is a wrapper over both computeRemovals and
 533 solutionFromRemovals. In case we have no solution, we return Nothing.
 534
 535 -}
 536 computeSolution :: NodeList        -- ^ The original node data
 537                 -> [Instance.Instance] -- ^ The list of /bad/ instances
 538                 -> Int             -- ^ The /depth/ of removals
 539                 -> Int             -- ^ Maximum number of removals to process
 540                 -> Int             -- ^ Minimum delta parameter
 541                 -> Int             -- ^ Maximum delta parameter
 542                 -> Maybe Solution  -- ^ The best solution found (or Nothing)
 543 computeSolution nl bad_instances depth max_removals min_delta max_delta =
 544   let
 545       removals = computeRemovals nl bad_instances depth
 546       removals' = capRemovals removals max_removals
 547   in
 548     solutionFromRemovals removals' min_delta max_delta
 549
 550 -- Solution display functions (pure)
 551
 552 -- | Given the original and final nodes, computes the relocation description.
 553 computeMoves :: String -- ^ The instance name
 554              -> String -- ^ Original primary
 555              -> String -- ^ Original secondary
 556              -> String -- ^ New primary
 557              -> String -- ^ New secondary
 558              -> (String, [String])
 559                 -- ^ Tuple of moves and commands list; moves is containing
 560                 -- either @/f/@ for failover or @/r:name/@ for replace
 561                 -- secondary, while the command list holds gnt-instance
 562                 -- commands (without that prefix), e.g \"@failover instance1@\"
 563 computeMoves i a b c d =
 564     if c == a then {- Same primary -}
 565         if d == b then {- Same sec??! -}
 566             ("-", [])
 567         else {- Change of secondary -}
 568             (printf "r:%s" d,
 569              [printf "replace-disks -n %s %s" d i])
 570     else
 571         if c == b then {- Failover and ... -}
 572             if d == a then {- that's all -}
 573                 ("f", [printf "migrate -f %s" i])
 574             else
 575                 (printf "f r:%s" d,
 576                  [printf "migrate -f %s" i,
 577                   printf "replace-disks -n %s %s" d i])
 578         else
 579             if d == a then {- ... and keep primary as secondary -}
 580                 (printf "r:%s f" c,
 581                  [printf "replace-disks -n %s %s" c i,
 582                   printf "migrate -f %s" i])
 583             else
 584                 if d == b then {- ... keep same secondary -}
 585                     (printf "f r:%s f" c,
 586                      [printf "migrate -f %s" i,
 587                       printf "replace-disks -n %s %s" c i,
 588                       printf "migrate -f %s" i])
 589
 590                 else {- Nothing in common -}
 591                     (printf "r:%s f r:%s" c d,
 592                      [printf "replace-disks -n %s %s" c i,
 593                       printf "migrate -f %s" i,
 594                       printf "replace-disks -n %s %s" d i])
 595
 596 {-| Converts a placement to string format -}
 597 printSolutionLine :: NodeList
 598                   -> InstanceList
 599                   -> Int
 600                   -> Int
 601                   -> Placement
 602                   -> Int
 603                   -> (String, [String])
 604 printSolutionLine nl il nmlen imlen plc pos =
 605     let
 606         pmlen = (2*nmlen + 1)
 607         (i, p, s, c) = plc
 608         inst = Container.find i il
 609         inam = Instance.name inst
 610         npri = cNameOf nl p
 611         nsec = cNameOf nl s
 612         opri = cNameOf nl $ Instance.pnode inst
 613         osec = cNameOf nl $ Instance.snode inst
 614         (moves, cmds) =  computeMoves inam opri osec npri nsec
 615         ostr = (printf "%s:%s" opri osec)::String
 616         nstr = (printf "%s:%s" npri nsec)::String
 617     in
 618       (printf "  %3d. %-*s %-*s => %-*s %.8f a=%s"
 619        pos imlen inam pmlen ostr
 620        pmlen nstr c moves,
 621        cmds)
 622
 623 formatCmds :: [[String]] -> String
 624 formatCmds cmd_strs =
 625     unlines $
 626     concat $ map (\(a, b) ->
 627         (printf "echo step %d" (a::Int)):
 628         (printf "check"):
 629         (map ("gnt-instance " ++) b)) $
 630         zip [1..] cmd_strs
 631
 632 {-| Converts a solution to string format -}
 633 printSolution :: NodeList
 634               -> InstanceList
 635               -> [Placement]
 636               -> ([String], [[String]])
 637 printSolution nl il sol =
 638     let
 639         nmlen = cMaxNamelen nl
 640         imlen = cMaxNamelen il
 641     in
 642       unzip $ map (uncurry $ printSolutionLine nl il nmlen imlen) $
 643             zip sol [1..]
 644
 645 -- | Print the node list.
 646 printNodes :: NodeList -> String
 647 printNodes nl =
 648     let snl = sortBy (compare `on` Node.idx) (Container.elems nl)
 649         m_name = maximum . map (length . Node.name) $ snl
 650         helper = Node.list m_name
 651         header = printf
 652                  "%2s %-*s %5s %5s %5s %5s %5s %5s %5s %5s %3s %3s %7s %7s"
 653                  " F" m_name "Name"
 654                  "t_mem" "n_mem" "i_mem" "x_mem" "f_mem" "r_mem"
 655                  "t_dsk" "f_dsk"
 656                  "pri" "sec" "p_fmem" "p_fdsk"
 657     in unlines $ (header:map helper snl)
 658
 659 -- | Compute the mem and disk covariance.
 660 compDetailedCV :: NodeList -> (Double, Double, Double, Double, Double)
 661 compDetailedCV nl =
 662     let
 663         all_nodes = Container.elems nl
 664         (offline, nodes) = partition Node.offline all_nodes
 665         mem_l = map Node.p_mem nodes
 666         dsk_l = map Node.p_dsk nodes
 667         mem_cv = varianceCoeff mem_l
 668         dsk_cv = varianceCoeff dsk_l
 669         n1_l = length $ filter Node.failN1 nodes
 670         n1_score = (fromIntegral n1_l) / (fromIntegral $ length nodes)
 671         res_l = map Node.p_rem nodes
 672         res_cv = varianceCoeff res_l
 673         offline_inst = sum . map (\n -> (length . Node.plist $ n) +
 674                                         (length . Node.slist $ n)) $ offline
 675         online_inst = sum . map (\n -> (length . Node.plist $ n) +
 676                                        (length . Node.slist $ n)) $ nodes
 677         off_score = (fromIntegral offline_inst) /
 678                     (fromIntegral $ online_inst + offline_inst)
 679     in (mem_cv, dsk_cv, n1_score, res_cv, off_score)
 680
 681 -- | Compute the 'total' variance.
 682 compCV :: NodeList -> Double
 683 compCV nl =
 684     let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl
 685     in mem_cv + dsk_cv + n1_score + res_cv + off_score
 686
 687 printStats :: NodeList -> String
 688 printStats nl =
 689     let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl
 690     in printf "f_mem=%.8f, r_mem=%.8f, f_dsk=%.8f, n1=%.3f, uf=%.3f"
 691        mem_cv res_cv dsk_cv n1_score off_score