Statistics
| Branch: | Tag: | Revision:

root / Ganeti / HTools / Cluster.hs @ 0a8dd21d

History | View | Annotate | Download (29.6 kB)

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
{-
9

    
10
Copyright (C) 2009 Google Inc.
11

    
12
This program is free software; you can redistribute it and/or modify
13
it under the terms of the GNU General Public License as published by
14
the Free Software Foundation; either version 2 of the License, or
15
(at your option) any later version.
16

    
17
This program is distributed in the hope that it will be useful, but
18
WITHOUT ANY WARRANTY; without even the implied warranty of
19
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
20
General Public License for more details.
21

    
22
You should have received a copy of the GNU General Public License
23
along with this program; if not, write to the Free Software
24
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
25
02110-1301, USA.
26

    
27
-}
28

    
29
module Ganeti.HTools.Cluster
30
    (
31
     -- * Types
32
      Placement
33
    , Solution(..)
34
    , Table(..)
35
    , Removal
36
    , Score
37
    , IMove(..)
38
    -- * Generic functions
39
    , totalResources
40
    -- * First phase functions
41
    , computeBadItems
42
    -- * Second phase functions
43
    , computeSolution
44
    , applySolution
45
    , printSolution
46
    , printSolutionLine
47
    , formatCmds
48
    , printNodes
49
    -- * Balacing functions
50
    , applyMove
51
    , checkMove
52
    , compCV
53
    , printStats
54
    -- * IAllocator functions
55
    , allocateOnSingle
56
    , allocateOnPair
57
    , tryAlloc
58
    , tryReloc
59
    ) where
60

    
61
import Data.List
62
import Data.Maybe (isNothing, fromJust)
63
import Text.Printf (printf)
64
import Data.Function
65
import Control.Monad
66

    
67
import qualified Ganeti.HTools.Container as Container
68
import qualified Ganeti.HTools.Instance as Instance
69
import qualified Ganeti.HTools.Node as Node
70
import Ganeti.HTools.Types
71
import Ganeti.HTools.Utils
72

    
73
-- * Types
74

    
75
-- | A separate name for the cluster score type.
76
type Score = Double
77

    
78
-- | The description of an instance placement.
79
type Placement = (Idx, Ndx, Ndx, Score)
80

    
81
-- | A cluster solution described as the solution delta and the list
82
-- of placements.
83
data Solution = Solution Int [Placement]
84
                deriving (Eq, Ord, Show)
85

    
86
-- | A removal set.
87
data Removal = Removal Node.List [Instance.Instance]
88

    
89
-- | An instance move definition
90
data IMove = Failover                -- ^ Failover the instance (f)
91
           | ReplacePrimary Ndx      -- ^ Replace primary (f, r:np, f)
92
           | ReplaceSecondary Ndx    -- ^ Replace secondary (r:ns)
93
           | ReplaceAndFailover Ndx  -- ^ Replace secondary, failover (r:np, f)
94
           | FailoverAndReplace Ndx  -- ^ Failover, replace secondary (f, r:ns)
95
             deriving (Show)
96

    
97
-- | The complete state for the balancing solution
98
data Table = Table Node.List Instance.List Score [Placement]
99
             deriving (Show)
100

    
101
-- * Utility functions
102

    
103
-- | Returns the delta of a solution or -1 for Nothing.
104
solutionDelta :: Maybe Solution -> Int
105
solutionDelta sol = case sol of
106
                      Just (Solution d _) -> d
107
                      _ -> -1
108

    
109
-- | Cap the removal list if needed.
110
capRemovals :: [a] -> Int -> [a]
111
capRemovals removals max_removals =
112
    if max_removals > 0 then
113
        take max_removals removals
114
    else
115
        removals
116

    
117
-- | Check if the given node list fails the N+1 check.
118
verifyN1Check :: [Node.Node] -> Bool
119
verifyN1Check nl = any Node.failN1 nl
120

    
121
-- | Verifies the N+1 status and return the affected nodes.
122
verifyN1 :: [Node.Node] -> [Node.Node]
123
verifyN1 nl = filter Node.failN1 nl
124

    
125
{-| Computes the pair of bad nodes and instances.
126

    
127
The bad node list is computed via a simple 'verifyN1' check, and the
128
bad instance list is the list of primary and secondary instances of
129
those nodes.
130

    
131
-}
132
computeBadItems :: Node.List -> Instance.List ->
133
                   ([Node.Node], [Instance.Instance])
134
computeBadItems nl il =
135
  let bad_nodes = verifyN1 $ getOnline nl
136
      bad_instances = map (\idx -> Container.find idx il) $
137
                      sort $ nub $ concat $
138
                      map (\ n -> (Node.slist n) ++ (Node.plist n)) bad_nodes
139
  in
140
    (bad_nodes, bad_instances)
141

    
142
-- | Compute the total free disk and memory in the cluster.
143
totalResources :: Node.List -> (Int, Int)
144
totalResources nl =
145
    foldl'
146
    (\ (mem, dsk) node -> (mem + (Node.f_mem node),
147
                           dsk + (Node.f_dsk node)))
148
    (0, 0) (Container.elems nl)
149

    
150
-- | Compute the mem and disk covariance.
151
compDetailedCV :: Node.List -> (Double, Double, Double, Double, Double, Double)
152
compDetailedCV nl =
153
    let
154
        all_nodes = Container.elems nl
155
        (offline, nodes) = partition Node.offline all_nodes
156
        mem_l = map Node.p_mem nodes
157
        dsk_l = map Node.p_dsk nodes
158
        mem_cv = varianceCoeff mem_l
159
        dsk_cv = varianceCoeff dsk_l
160
        n1_l = length $ filter Node.failN1 nodes
161
        n1_score = (fromIntegral n1_l) / (fromIntegral $ length nodes)
162
        res_l = map Node.p_rem nodes
163
        res_cv = varianceCoeff res_l
164
        offline_inst = sum . map (\n -> (length . Node.plist $ n) +
165
                                        (length . Node.slist $ n)) $ offline
166
        online_inst = sum . map (\n -> (length . Node.plist $ n) +
167
                                       (length . Node.slist $ n)) $ nodes
168
        off_score = (fromIntegral offline_inst) /
169
                    (fromIntegral $ online_inst + offline_inst)
170
        cpu_l = map Node.p_cpu nodes
171
        cpu_cv = varianceCoeff cpu_l
172
    in (mem_cv, dsk_cv, n1_score, res_cv, off_score, cpu_cv)
173

    
174
-- | Compute the /total/ variance.
175
compCV :: Node.List -> Double
176
compCV nl =
177
    let (mem_cv, dsk_cv, n1_score, res_cv, off_score, cpu_cv) =
178
            compDetailedCV nl
179
    in mem_cv + dsk_cv + n1_score + res_cv + off_score + cpu_cv
180

    
181
-- | Compute online nodes from a Node.List
182
getOnline :: Node.List -> [Node.Node]
183
getOnline = filter (not . Node.offline) . Container.elems
184

    
185
-- * hn1 functions
186

    
187
-- | Add an instance and return the new node and instance maps.
188
addInstance :: Node.List -> Instance.Instance ->
189
               Node.Node -> Node.Node -> Maybe Node.List
190
addInstance nl idata pri sec =
191
  let pdx = Node.idx pri
192
      sdx = Node.idx sec
193
  in do
194
      pnode <- Node.addPri pri idata
195
      snode <- Node.addSec sec idata pdx
196
      new_nl <- return $ Container.addTwo sdx snode
197
                         pdx pnode nl
198
      return new_nl
199

    
200
-- | Remove an instance and return the new node and instance maps.
201
removeInstance :: Node.List -> Instance.Instance -> Node.List
202
removeInstance nl idata =
203
  let pnode = Instance.pnode idata
204
      snode = Instance.snode idata
205
      pn = Container.find pnode nl
206
      sn = Container.find snode nl
207
      new_nl = Container.addTwo
208
               pnode (Node.removePri pn idata)
209
               snode (Node.removeSec sn idata) nl in
210
  new_nl
211

    
212
-- | Remove an instance and return the new node map.
213
removeInstances :: Node.List -> [Instance.Instance] -> Node.List
214
removeInstances = foldl' removeInstance
215

    
216

    
217
{-| Compute a new version of a cluster given a solution.
218

    
219
This is not used for computing the solutions, but for applying a
220
(known-good) solution to the original cluster for final display.
221

    
222
It first removes the relocated instances after which it places them on
223
their new nodes.
224

    
225
 -}
226
applySolution :: Node.List -> Instance.List -> [Placement] -> Node.List
227
applySolution nl il sol =
228
    let odxes = map (\ (a, b, c, _) -> (Container.find a il,
229
                                        Node.idx (Container.find b nl),
230
                                        Node.idx (Container.find c nl))
231
                    ) sol
232
        idxes = (\ (x, _, _) -> x) (unzip3 odxes)
233
        nc = removeInstances nl idxes
234
    in
235
      foldl' (\ nz (a, b, c) ->
236
                 let new_p = Container.find b nz
237
                     new_s = Container.find c nz in
238
                 fromJust (addInstance nz a new_p new_s)
239
           ) nc odxes
240

    
241

    
242
-- ** First phase functions
243

    
244
{-| Given a list 1,2,3..n build a list of pairs [(1, [2..n]), (2,
245
    [3..n]), ...]
246

    
247
-}
248
genParts :: [a] -> Int -> [(a, [a])]
249
genParts l count =
250
    case l of
251
      [] -> []
252
      x:xs ->
253
          if length l < count then
254
              []
255
          else
256
              (x, xs) : (genParts xs count)
257

    
258
-- | Generates combinations of count items from the names list.
259
genNames :: Int -> [b] -> [[b]]
260
genNames count1 names1 =
261
  let aux_fn count names current =
262
          case count of
263
            0 -> [current]
264
            _ ->
265
                concatMap
266
                (\ (x, xs) -> aux_fn (count - 1) xs (x:current))
267
                (genParts names count)
268
  in
269
    aux_fn count1 names1 []
270

    
271
{-| Checks if removal of instances results in N+1 pass.
272

    
273
Note: the check removal cannot optimize by scanning only the affected
274
nodes, since the cluster is known to be not healthy; only the check
275
placement can make this shortcut.
276

    
277
-}
278
checkRemoval :: Node.List -> [Instance.Instance] -> Maybe Removal
279
checkRemoval nl victims =
280
  let nx = removeInstances nl victims
281
      failN1 = verifyN1Check (Container.elems nx)
282
  in
283
    if failN1 then
284
      Nothing
285
    else
286
      Just $ Removal nx victims
287

    
288

    
289
-- | Computes the removals list for a given depth.
290
computeRemovals :: Node.List
291
                 -> [Instance.Instance]
292
                 -> Int
293
                 -> [Maybe Removal]
294
computeRemovals nl bad_instances depth =
295
    map (checkRemoval nl) $ genNames depth bad_instances
296

    
297
-- ** Second phase functions
298

    
299
-- | Single-node relocation cost.
300
nodeDelta :: Ndx -> Ndx -> Ndx -> Int
301
nodeDelta i p s =
302
    if i == p || i == s then
303
        0
304
    else
305
        1
306

    
307
-- | Compute best solution.
308
--
309
-- This function compares two solutions, choosing the minimum valid
310
-- solution.
311
compareSolutions :: Maybe Solution -> Maybe Solution -> Maybe Solution
312
compareSolutions a b = case (a, b) of
313
  (Nothing, x) -> x
314
  (x, Nothing) -> x
315
  (x, y) -> min x y
316

    
317
-- | Check if a given delta is worse then an existing solution.
318
tooHighDelta :: Maybe Solution -> Int -> Int -> Bool
319
tooHighDelta sol new_delta max_delta =
320
    if new_delta > max_delta && max_delta >=0 then
321
        True
322
    else
323
        case sol of
324
          Nothing -> False
325
          Just (Solution old_delta _) -> old_delta <= new_delta
326

    
327
{-| Check if placement of instances still keeps the cluster N+1 compliant.
328

    
329
    This is the workhorse of the allocation algorithm: given the
330
    current node and instance maps, the list of instances to be
331
    placed, and the current solution, this will return all possible
332
    solution by recursing until all target instances are placed.
333

    
334
-}
335
checkPlacement :: Node.List            -- ^ The current node list
336
               -> [Instance.Instance] -- ^ List of instances still to place
337
               -> [Placement]         -- ^ Partial solution until now
338
               -> Int                 -- ^ The delta of the partial solution
339
               -> Maybe Solution      -- ^ The previous solution
340
               -> Int                 -- ^ Abort if the we go above this delta
341
               -> Maybe Solution      -- ^ The new solution
342
checkPlacement nl victims current current_delta prev_sol max_delta =
343
  let target = head victims
344
      opdx = Instance.pnode target
345
      osdx = Instance.snode target
346
      vtail = tail victims
347
      have_tail = (length vtail) > 0
348
      nodes = Container.elems nl
349
      iidx = Instance.idx target
350
  in
351
    foldl'
352
    (\ accu_p pri ->
353
         let
354
             pri_idx = Node.idx pri
355
             upri_delta = current_delta + nodeDelta pri_idx opdx osdx
356
             new_pri = Node.addPri pri target
357
             fail_delta1 = tooHighDelta accu_p upri_delta max_delta
358
         in
359
           if fail_delta1 || isNothing(new_pri) then accu_p
360
           else let pri_nl = Container.add pri_idx (fromJust new_pri) nl in
361
                foldl'
362
                (\ accu sec ->
363
                     let
364
                         sec_idx = Node.idx sec
365
                         upd_delta = upri_delta +
366
                                     nodeDelta sec_idx opdx osdx
367
                         fail_delta2 = tooHighDelta accu upd_delta max_delta
368
                         new_sec = Node.addSec sec target pri_idx
369
                     in
370
                       if sec_idx == pri_idx || fail_delta2 ||
371
                          isNothing new_sec then accu
372
                       else let
373
                           nx = Container.add sec_idx (fromJust new_sec) pri_nl
374
                           upd_cv = compCV nx
375
                           plc = (iidx, pri_idx, sec_idx, upd_cv)
376
                           c2 = plc:current
377
                           result =
378
                               if have_tail then
379
                                   checkPlacement nx vtail c2 upd_delta
380
                                                  accu max_delta
381
                               else
382
                                   Just (Solution upd_delta c2)
383
                      in compareSolutions accu result
384
                ) accu_p nodes
385
    ) prev_sol nodes
386

    
387
{-| Auxiliary function for solution computation.
388

    
389
We write this in an explicit recursive fashion in order to control
390
early-abort in case we have met the min delta. We can't use foldr
391
instead of explicit recursion since we need the accumulator for the
392
abort decision.
393

    
394
-}
395
advanceSolution :: [Maybe Removal] -- ^ The removal to process
396
                -> Int             -- ^ Minimum delta parameter
397
                -> Int             -- ^ Maximum delta parameter
398
                -> Maybe Solution  -- ^ Current best solution
399
                -> Maybe Solution  -- ^ New best solution
400
advanceSolution [] _ _ sol = sol
401
advanceSolution (Nothing:xs) m n sol = advanceSolution xs m n sol
402
advanceSolution ((Just (Removal nx removed)):xs) min_d max_d prev_sol =
403
    let new_sol = checkPlacement nx removed [] 0 prev_sol max_d
404
        new_delta = solutionDelta $! new_sol
405
    in
406
      if new_delta >= 0 && new_delta <= min_d then
407
          new_sol
408
      else
409
          advanceSolution xs min_d max_d new_sol
410

    
411
-- | Computes the placement solution.
412
solutionFromRemovals :: [Maybe Removal] -- ^ The list of (possible) removals
413
                     -> Int             -- ^ Minimum delta parameter
414
                     -> Int             -- ^ Maximum delta parameter
415
                     -> Maybe Solution  -- ^ The best solution found
416
solutionFromRemovals removals min_delta max_delta =
417
    advanceSolution removals min_delta max_delta Nothing
418

    
419
{-| Computes the solution at the given depth.
420

    
421
This is a wrapper over both computeRemovals and
422
solutionFromRemovals. In case we have no solution, we return Nothing.
423

    
424
-}
425
computeSolution :: Node.List        -- ^ The original node data
426
                -> [Instance.Instance] -- ^ The list of /bad/ instances
427
                -> Int             -- ^ The /depth/ of removals
428
                -> Int             -- ^ Maximum number of removals to process
429
                -> Int             -- ^ Minimum delta parameter
430
                -> Int             -- ^ Maximum delta parameter
431
                -> Maybe Solution  -- ^ The best solution found (or Nothing)
432
computeSolution nl bad_instances depth max_removals min_delta max_delta =
433
  let
434
      removals = computeRemovals nl bad_instances depth
435
      removals' = capRemovals removals max_removals
436
  in
437
    solutionFromRemovals removals' min_delta max_delta
438

    
439
-- * hbal functions
440

    
441
-- | Compute best table. Note that the ordering of the arguments is important.
442
compareTables :: Table -> Table -> Table
443
compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) =
444
    if a_cv > b_cv then b else a
445

    
446
-- | Applies an instance move to a given node list and instance.
447
applyMove :: Node.List -> Instance.Instance
448
          -> IMove -> (Maybe Node.List, Instance.Instance, Ndx, Ndx)
449
-- Failover (f)
450
applyMove nl inst Failover =
451
    let old_pdx = Instance.pnode inst
452
        old_sdx = Instance.snode inst
453
        old_p = Container.find old_pdx nl
454
        old_s = Container.find old_sdx nl
455
        int_p = Node.removePri old_p inst
456
        int_s = Node.removeSec old_s inst
457
        new_nl = do -- Maybe monad
458
          new_p <- Node.addPri int_s inst
459
          new_s <- Node.addSec int_p inst old_sdx
460
          return $ Container.addTwo old_pdx new_s old_sdx new_p nl
461
    in (new_nl, Instance.setBoth inst old_sdx old_pdx, old_sdx, old_pdx)
462

    
463
-- Replace the primary (f:, r:np, f)
464
applyMove nl inst (ReplacePrimary new_pdx) =
465
    let old_pdx = Instance.pnode inst
466
        old_sdx = Instance.snode inst
467
        old_p = Container.find old_pdx nl
468
        old_s = Container.find old_sdx nl
469
        tgt_n = Container.find new_pdx nl
470
        int_p = Node.removePri old_p inst
471
        int_s = Node.removeSec old_s inst
472
        new_nl = do -- Maybe monad
473
          -- check that the current secondary can host the instance
474
          -- during the migration
475
          tmp_s <- Node.addPri int_s inst
476
          let tmp_s' = Node.removePri tmp_s inst
477
          new_p <- Node.addPri tgt_n inst
478
          new_s <- Node.addSec tmp_s' inst new_pdx
479
          return $ Container.add new_pdx new_p $
480
                 Container.addTwo old_pdx int_p old_sdx new_s nl
481
    in (new_nl, Instance.setPri inst new_pdx, new_pdx, old_sdx)
482

    
483
-- Replace the secondary (r:ns)
484
applyMove nl inst (ReplaceSecondary new_sdx) =
485
    let old_pdx = Instance.pnode inst
486
        old_sdx = Instance.snode inst
487
        old_s = Container.find old_sdx nl
488
        tgt_n = Container.find new_sdx nl
489
        int_s = Node.removeSec old_s inst
490
        new_nl = Node.addSec tgt_n inst old_pdx >>=
491
                 \new_s -> return $ Container.addTwo new_sdx
492
                           new_s old_sdx int_s nl
493
    in (new_nl, Instance.setSec inst new_sdx, old_pdx, new_sdx)
494

    
495
-- Replace the secondary and failover (r:np, f)
496
applyMove nl inst (ReplaceAndFailover new_pdx) =
497
    let old_pdx = Instance.pnode inst
498
        old_sdx = Instance.snode inst
499
        old_p = Container.find old_pdx nl
500
        old_s = Container.find old_sdx nl
501
        tgt_n = Container.find new_pdx nl
502
        int_p = Node.removePri old_p inst
503
        int_s = Node.removeSec old_s inst
504
        new_nl = do -- Maybe monad
505
          new_p <- Node.addPri tgt_n inst
506
          new_s <- Node.addSec int_p inst new_pdx
507
          return $ Container.add new_pdx new_p $
508
                 Container.addTwo old_pdx new_s old_sdx int_s nl
509
    in (new_nl, Instance.setBoth inst new_pdx old_pdx, new_pdx, old_pdx)
510

    
511
-- Failver and replace the secondary (f, r:ns)
512
applyMove nl inst (FailoverAndReplace new_sdx) =
513
    let old_pdx = Instance.pnode inst
514
        old_sdx = Instance.snode inst
515
        old_p = Container.find old_pdx nl
516
        old_s = Container.find old_sdx nl
517
        tgt_n = Container.find new_sdx nl
518
        int_p = Node.removePri old_p inst
519
        int_s = Node.removeSec old_s inst
520
        new_nl = do -- Maybe monad
521
          new_p <- Node.addPri int_s inst
522
          new_s <- Node.addSec tgt_n inst old_sdx
523
          return $ Container.add new_sdx new_s $
524
                 Container.addTwo old_sdx new_p old_pdx int_p nl
525
    in (new_nl, Instance.setBoth inst old_sdx new_sdx, old_sdx, new_sdx)
526

    
527
-- | Tries to allocate an instance on one given node.
528
allocateOnSingle :: Node.List -> Instance.Instance -> Node.Node
529
                 -> (Maybe Node.List, Instance.Instance)
530
allocateOnSingle nl inst p =
531
    let new_pdx = Node.idx p
532
        new_nl = Node.addPri p inst >>= \new_p ->
533
                 return $ Container.add new_pdx new_p nl
534
    in (new_nl, Instance.setBoth inst new_pdx Node.noSecondary)
535

    
536
-- | Tries to allocate an instance on a given pair of nodes.
537
allocateOnPair :: Node.List -> Instance.Instance -> Node.Node -> Node.Node
538
               -> (Maybe Node.List, Instance.Instance)
539
allocateOnPair nl inst tgt_p tgt_s =
540
    let new_pdx = Node.idx tgt_p
541
        new_sdx = Node.idx tgt_s
542
        new_nl = do -- Maybe monad
543
          new_p <- Node.addPri tgt_p inst
544
          new_s <- Node.addSec tgt_s inst new_pdx
545
          return $ Container.addTwo new_pdx new_p new_sdx new_s nl
546
    in (new_nl, Instance.setBoth inst new_pdx new_sdx)
547

    
548
-- | Tries to perform an instance move and returns the best table
549
-- between the original one and the new one.
550
checkSingleStep :: Table -- ^ The original table
551
                -> Instance.Instance -- ^ The instance to move
552
                -> Table -- ^ The current best table
553
                -> IMove -- ^ The move to apply
554
                -> Table -- ^ The final best table
555
checkSingleStep ini_tbl target cur_tbl move =
556
    let
557
        Table ini_nl ini_il _ ini_plc = ini_tbl
558
        (tmp_nl, new_inst, pri_idx, sec_idx) = applyMove ini_nl target move
559
    in
560
      if isNothing tmp_nl then cur_tbl
561
      else
562
          let tgt_idx = Instance.idx target
563
              upd_nl = fromJust tmp_nl
564
              upd_cvar = compCV upd_nl
565
              upd_il = Container.add tgt_idx new_inst ini_il
566
              upd_plc = (tgt_idx, pri_idx, sec_idx, upd_cvar):ini_plc
567
              upd_tbl = Table upd_nl upd_il upd_cvar upd_plc
568
          in
569
            compareTables cur_tbl upd_tbl
570

    
571
-- | Given the status of the current secondary as a valid new node
572
-- and the current candidate target node,
573
-- generate the possible moves for a instance.
574
possibleMoves :: Bool -> Ndx -> [IMove]
575
possibleMoves True tdx =
576
    [ReplaceSecondary tdx,
577
     ReplaceAndFailover tdx,
578
     ReplacePrimary tdx,
579
     FailoverAndReplace tdx]
580

    
581
possibleMoves False tdx =
582
    [ReplaceSecondary tdx,
583
     ReplaceAndFailover tdx]
584

    
585
-- | Compute the best move for a given instance.
586
checkInstanceMove :: [Ndx]             -- Allowed target node indices
587
                  -> Table             -- Original table
588
                  -> Instance.Instance -- Instance to move
589
                  -> Table             -- Best new table for this instance
590
checkInstanceMove nodes_idx ini_tbl target =
591
    let
592
        opdx = Instance.pnode target
593
        osdx = Instance.snode target
594
        nodes = filter (\idx -> idx /= opdx && idx /= osdx) nodes_idx
595
        use_secondary = elem osdx nodes_idx
596
        aft_failover = if use_secondary -- if allowed to failover
597
                       then checkSingleStep ini_tbl target ini_tbl Failover
598
                       else ini_tbl
599
        all_moves = concatMap (possibleMoves use_secondary) nodes
600
    in
601
      -- iterate over the possible nodes for this instance
602
      foldl' (checkSingleStep ini_tbl target) aft_failover all_moves
603

    
604
-- | Compute the best next move.
605
checkMove :: [Ndx]               -- ^ Allowed target node indices
606
          -> Table               -- ^ The current solution
607
          -> [Instance.Instance] -- ^ List of instances still to move
608
          -> Table               -- ^ The new solution
609
checkMove nodes_idx ini_tbl victims =
610
    let Table _ _ _ ini_plc = ini_tbl
611
        -- iterate over all instances, computing the best move
612
        best_tbl =
613
            foldl'
614
            (\ step_tbl elem ->
615
                 if Instance.snode elem == Node.noSecondary then step_tbl
616
                    else compareTables step_tbl $
617
                         checkInstanceMove nodes_idx ini_tbl elem)
618
            ini_tbl victims
619
        Table _ _ _ best_plc = best_tbl
620
    in
621
      if length best_plc == length ini_plc then -- no advancement
622
          ini_tbl
623
      else
624
          best_tbl
625

    
626
-- * Alocation functions
627

    
628
-- | Try to allocate an instance on the cluster.
629
tryAlloc :: (Monad m) =>
630
            Node.List         -- ^ The node list
631
         -> Instance.List     -- ^ The instance list
632
         -> Instance.Instance -- ^ The instance to allocate
633
         -> Int               -- ^ Required number of nodes
634
         -> m [(Maybe Node.List, Instance.Instance, [Node.Node])]
635
                              -- ^ Possible solution list
636
tryAlloc nl _ inst 2 =
637
    let all_nodes = getOnline nl
638
        all_pairs = liftM2 (,) all_nodes all_nodes
639
        ok_pairs = filter (\(x, y) -> Node.idx x /= Node.idx y) all_pairs
640
        sols = map (\(p, s) -> let (mnl, i) = allocateOnPair nl inst p s
641
                               in (mnl, i, [p, s]))
642
               ok_pairs
643
    in return sols
644

    
645
tryAlloc nl _ inst 1 =
646
    let all_nodes = getOnline nl
647
        sols = map (\p -> let (mnl, i) = allocateOnSingle nl inst p
648
                          in (mnl, i, [p]))
649
               all_nodes
650
    in return sols
651

    
652
tryAlloc _ _ _ reqn = fail $ "Unsupported number of alllocation \
653
                             \destinations required (" ++ (show reqn) ++
654
                                               "), only two supported"
655

    
656
-- | Try to allocate an instance on the cluster.
657
tryReloc :: (Monad m) =>
658
            Node.List     -- ^ The node list
659
         -> Instance.List -- ^ The instance list
660
         -> Idx           -- ^ The index of the instance to move
661
         -> Int           -- ^ The numver of nodes required
662
         -> [Ndx]         -- ^ Nodes which should not be used
663
         -> m [(Maybe Node.List, Instance.Instance, [Node.Node])]
664
                          -- ^ Solution list
665
tryReloc nl il xid 1 ex_idx =
666
    let all_nodes = getOnline nl
667
        inst = Container.find xid il
668
        ex_idx' = (Instance.pnode inst):ex_idx
669
        valid_nodes = filter (not . flip elem ex_idx' . Node.idx) all_nodes
670
        valid_idxes = map Node.idx valid_nodes
671
        sols1 = map (\x -> let (mnl, i, _, _) =
672
                                   applyMove nl inst (ReplaceSecondary x)
673
                           in (mnl, i, [Container.find x nl])
674
                     ) valid_idxes
675
    in return sols1
676

    
677
tryReloc _ _ _ reqn _  = fail $ "Unsupported number of relocation \
678
                                \destinations required (" ++ (show reqn) ++
679
                                                  "), only one supported"
680

    
681
-- * Formatting functions
682

    
683
-- | Given the original and final nodes, computes the relocation description.
684
computeMoves :: String -- ^ The instance name
685
             -> String -- ^ Original primary
686
             -> String -- ^ Original secondary
687
             -> String -- ^ New primary
688
             -> String -- ^ New secondary
689
             -> (String, [String])
690
                -- ^ Tuple of moves and commands list; moves is containing
691
                -- either @/f/@ for failover or @/r:name/@ for replace
692
                -- secondary, while the command list holds gnt-instance
693
                -- commands (without that prefix), e.g \"@failover instance1@\"
694
computeMoves i a b c d =
695
    if c == a then {- Same primary -}
696
        if d == b then {- Same sec??! -}
697
            ("-", [])
698
        else {- Change of secondary -}
699
            (printf "r:%s" d,
700
             [printf "replace-disks -n %s %s" d i])
701
    else
702
        if c == b then {- Failover and ... -}
703
            if d == a then {- that's all -}
704
                ("f", [printf "migrate -f %s" i])
705
            else
706
                (printf "f r:%s" d,
707
                 [printf "migrate -f %s" i,
708
                  printf "replace-disks -n %s %s" d i])
709
        else
710
            if d == a then {- ... and keep primary as secondary -}
711
                (printf "r:%s f" c,
712
                 [printf "replace-disks -n %s %s" c i,
713
                  printf "migrate -f %s" i])
714
            else
715
                if d == b then {- ... keep same secondary -}
716
                    (printf "f r:%s f" c,
717
                     [printf "migrate -f %s" i,
718
                      printf "replace-disks -n %s %s" c i,
719
                      printf "migrate -f %s" i])
720

    
721
                else {- Nothing in common -}
722
                    (printf "r:%s f r:%s" c d,
723
                     [printf "replace-disks -n %s %s" c i,
724
                      printf "migrate -f %s" i,
725
                      printf "replace-disks -n %s %s" d i])
726

    
727
-- | Converts a placement to string format.
728
printSolutionLine :: Node.List     -- ^ The node list
729
                  -> Instance.List -- ^ The instance list
730
                  -> Int           -- ^ Maximum node name length
731
                  -> Int           -- ^ Maximum instance name length
732
                  -> Placement     -- ^ The current placement
733
                  -> Int           -- ^ The index of the placement in
734
                                   -- the solution
735
                  -> (String, [String])
736
printSolutionLine nl il nmlen imlen plc pos =
737
    let
738
        pmlen = (2*nmlen + 1)
739
        (i, p, s, c) = plc
740
        inst = Container.find i il
741
        inam = Instance.name inst
742
        npri = Container.nameOf nl p
743
        nsec = Container.nameOf nl s
744
        opri = Container.nameOf nl $ Instance.pnode inst
745
        osec = Container.nameOf nl $ Instance.snode inst
746
        (moves, cmds) =  computeMoves inam opri osec npri nsec
747
        ostr = (printf "%s:%s" opri osec)::String
748
        nstr = (printf "%s:%s" npri nsec)::String
749
    in
750
      (printf "  %3d. %-*s %-*s => %-*s %.8f a=%s"
751
       pos imlen inam pmlen ostr
752
       pmlen nstr c moves,
753
       cmds)
754

    
755
-- | Given a list of commands, prefix them with @gnt-instance@ and
756
-- also beautify the display a little.
757
formatCmds :: [[String]] -> String
758
formatCmds cmd_strs =
759
    unlines $
760
    concat $ map (\(a, b) ->
761
        (printf "echo step %d" (a::Int)):
762
        (printf "check"):
763
        (map ("gnt-instance " ++) b)) $
764
        zip [1..] cmd_strs
765

    
766
-- | Converts a solution to string format.
767
printSolution :: Node.List
768
              -> Instance.List
769
              -> [Placement]
770
              -> ([String], [[String]])
771
printSolution nl il sol =
772
    let
773
        nmlen = Container.maxNameLen nl
774
        imlen = Container.maxNameLen il
775
    in
776
      unzip $ map (uncurry $ printSolutionLine nl il nmlen imlen) $
777
            zip sol [1..]
778

    
779
-- | Print the node list.
780
printNodes :: Node.List -> String
781
printNodes nl =
782
    let snl = sortBy (compare `on` Node.idx) (Container.elems nl)
783
        m_name = maximum . map (length . Node.name) $ snl
784
        helper = Node.list m_name
785
        header = printf
786
                 "%2s %-*s %5s %5s %5s %5s %5s %5s %5s %5s %3s %3s %7s %7s %7s"
787
                 " F" m_name "Name"
788
                 "t_mem" "n_mem" "i_mem" "x_mem" "f_mem" "r_mem"
789
                 "t_dsk" "f_dsk"
790
                 "pri" "sec" "p_fmem" "p_fdsk" "r_cpu"
791
    in unlines $ (header:map helper snl)
792

    
793
-- | Shows statistics for a given node list.
794
printStats :: Node.List -> String
795
printStats nl =
796
    let (mem_cv, dsk_cv, n1_score, res_cv, off_score, cpu_cv) =
797
            compDetailedCV nl
798
    in printf "f_mem=%.8f, r_mem=%.8f, f_dsk=%.8f, n1=%.3f, \
799
              \uf=%.3f, r_cpu=%.3f"
800
       mem_cv res_cv dsk_cv n1_score off_score cpu_cv