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