Statistics
| Branch: | Tag: | Revision:

root / Ganeti / HTools / Cluster.hs @ a2e90275

History | View | Annotate | Download (27.3 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
    , AllocSolution
34
    , Table(..)
35
    , CStats(..)
36
    -- * Generic functions
37
    , totalResources
38
    -- * First phase functions
39
    , computeBadItems
40
    -- * Second phase functions
41
    , printSolution
42
    , printSolutionLine
43
    , formatCmds
44
    , printNodes
45
    , involvedNodes
46
    , splitJobs
47
    -- * Balacing functions
48
    , checkMove
49
    , tryBalance
50
    , compCV
51
    , printStats
52
    , iMoveToJob
53
    -- * IAllocator functions
54
    , tryAlloc
55
    , tryReloc
56
    , collapseFailures
57
    ) where
58

    
59
import Data.List
60
import Text.Printf (printf)
61
import Data.Function
62
import Control.Monad
63

    
64
import qualified Ganeti.HTools.Container as Container
65
import qualified Ganeti.HTools.Instance as Instance
66
import qualified Ganeti.HTools.Node as Node
67
import Ganeti.HTools.Types
68
import Ganeti.HTools.Utils
69
import qualified Ganeti.OpCodes as OpCodes
70

    
71
-- * Types
72

    
73
-- | Allocation\/relocation solution.
74
type AllocSolution = ([FailMode], Int, Maybe (Score, AllocElement))
75

    
76
-- | Allocation\/relocation element.
77
type AllocElement = (Node.List, Instance.Instance, [Node.Node])
78

    
79

    
80
-- | The complete state for the balancing solution
81
data Table = Table Node.List Instance.List Score [Placement]
82
             deriving (Show)
83

    
84
data CStats = CStats { cs_fmem :: Int    -- ^ Cluster free mem
85
                     , cs_fdsk :: Int    -- ^ Cluster free disk
86
                     , cs_amem :: Int    -- ^ Cluster allocatable mem
87
                     , cs_adsk :: Int    -- ^ Cluster allocatable disk
88
                     , cs_acpu :: Int    -- ^ Cluster allocatable cpus
89
                     , cs_mmem :: Int    -- ^ Max node allocatable mem
90
                     , cs_mdsk :: Int    -- ^ Max node allocatable disk
91
                     , cs_mcpu :: Int    -- ^ Max node allocatable cpu
92
                     , cs_imem :: Int    -- ^ Instance used mem
93
                     , cs_idsk :: Int    -- ^ Instance used disk
94
                     , cs_icpu :: Int    -- ^ Instance used cpu
95
                     , cs_tmem :: Double -- ^ Cluster total mem
96
                     , cs_tdsk :: Double -- ^ Cluster total disk
97
                     , cs_tcpu :: Double -- ^ Cluster total cpus
98
                     , cs_xmem :: Int    -- ^ Unnacounted for mem
99
                     , cs_nmem :: Int    -- ^ Node own memory
100
                     , cs_score :: Score -- ^ The cluster score
101
                     , cs_ninst :: Int   -- ^ The total number of instances
102
                     }
103

    
104
-- * Utility functions
105

    
106
-- | Verifies the N+1 status and return the affected nodes.
107
verifyN1 :: [Node.Node] -> [Node.Node]
108
verifyN1 = filter Node.failN1
109

    
110
{-| Computes the pair of bad nodes and instances.
111

    
112
The bad node list is computed via a simple 'verifyN1' check, and the
113
bad instance list is the list of primary and secondary instances of
114
those nodes.
115

    
116
-}
117
computeBadItems :: Node.List -> Instance.List ->
118
                   ([Node.Node], [Instance.Instance])
119
computeBadItems nl il =
120
  let bad_nodes = verifyN1 $ getOnline nl
121
      bad_instances = map (\idx -> Container.find idx il) .
122
                      sort . nub $
123
                      concatMap (\ n -> Node.slist n ++ Node.plist n) bad_nodes
124
  in
125
    (bad_nodes, bad_instances)
126

    
127
emptyCStats :: CStats
128
emptyCStats = CStats { cs_fmem = 0
129
                     , cs_fdsk = 0
130
                     , cs_amem = 0
131
                     , cs_adsk = 0
132
                     , cs_acpu = 0
133
                     , cs_mmem = 0
134
                     , cs_mdsk = 0
135
                     , cs_mcpu = 0
136
                     , cs_imem = 0
137
                     , cs_idsk = 0
138
                     , cs_icpu = 0
139
                     , cs_tmem = 0
140
                     , cs_tdsk = 0
141
                     , cs_tcpu = 0
142
                     , cs_xmem = 0
143
                     , cs_nmem = 0
144
                     , cs_score = 0
145
                     , cs_ninst = 0
146
                     }
147

    
148
updateCStats :: CStats -> Node.Node -> CStats
149
updateCStats cs node =
150
    let CStats { cs_fmem = x_fmem, cs_fdsk = x_fdsk,
151
                 cs_amem = x_amem, cs_acpu = x_acpu, cs_adsk = x_adsk,
152
                 cs_mmem = x_mmem, cs_mdsk = x_mdsk, cs_mcpu = x_mcpu,
153
                 cs_imem = x_imem, cs_idsk = x_idsk, cs_icpu = x_icpu,
154
                 cs_tmem = x_tmem, cs_tdsk = x_tdsk, cs_tcpu = x_tcpu,
155
                 cs_xmem = x_xmem, cs_nmem = x_nmem, cs_ninst = x_ninst
156
               }
157
            = cs
158
        inc_amem = Node.f_mem node - Node.r_mem node
159
        inc_amem' = if inc_amem > 0 then inc_amem else 0
160
        inc_adsk = Node.availDisk node
161
        inc_imem = truncate (Node.t_mem node) - Node.n_mem node
162
                   - Node.x_mem node - Node.f_mem node
163
        inc_icpu = Node.u_cpu node
164
        inc_idsk = truncate (Node.t_dsk node) - Node.f_dsk node
165

    
166
    in cs { cs_fmem = x_fmem + Node.f_mem node
167
          , cs_fdsk = x_fdsk + Node.f_dsk node
168
          , cs_amem = x_amem + inc_amem'
169
          , cs_adsk = x_adsk + inc_adsk
170
          , cs_acpu = x_acpu
171
          , cs_mmem = max x_mmem inc_amem'
172
          , cs_mdsk = max x_mdsk inc_adsk
173
          , cs_mcpu = x_mcpu
174
          , cs_imem = x_imem + inc_imem
175
          , cs_idsk = x_idsk + inc_idsk
176
          , cs_icpu = x_icpu + inc_icpu
177
          , cs_tmem = x_tmem + Node.t_mem node
178
          , cs_tdsk = x_tdsk + Node.t_dsk node
179
          , cs_tcpu = x_tcpu + Node.t_cpu node
180
          , cs_xmem = x_xmem + Node.x_mem node
181
          , cs_nmem = x_nmem + Node.n_mem node
182
          , cs_ninst = x_ninst + length (Node.plist node)
183
          }
184

    
185
-- | Compute the total free disk and memory in the cluster.
186
totalResources :: Node.List -> CStats
187
totalResources nl =
188
    let cs = foldl' updateCStats emptyCStats . Container.elems $ nl
189
    in cs { cs_score = compCV nl }
190

    
191
-- | Compute the mem and disk covariance.
192
compDetailedCV :: Node.List -> (Double, Double, Double, Double, Double, Double)
193
compDetailedCV nl =
194
    let
195
        all_nodes = Container.elems nl
196
        (offline, nodes) = partition Node.offline all_nodes
197
        mem_l = map Node.p_mem nodes
198
        dsk_l = map Node.p_dsk nodes
199
        mem_cv = varianceCoeff mem_l
200
        dsk_cv = varianceCoeff dsk_l
201
        n1_l = length $ filter Node.failN1 nodes
202
        n1_score = fromIntegral n1_l /
203
                   fromIntegral (length nodes)::Double
204
        res_l = map Node.p_rem nodes
205
        res_cv = varianceCoeff res_l
206
        offline_inst = sum . map (\n -> (length . Node.plist $ n) +
207
                                        (length . Node.slist $ n)) $ offline
208
        online_inst = sum . map (\n -> (length . Node.plist $ n) +
209
                                       (length . Node.slist $ n)) $ nodes
210
        off_score = if offline_inst == 0
211
                    then 0::Double
212
                    else fromIntegral offline_inst /
213
                         fromIntegral (offline_inst + online_inst)::Double
214
        cpu_l = map Node.p_cpu nodes
215
        cpu_cv = varianceCoeff cpu_l
216
    in (mem_cv, dsk_cv, n1_score, res_cv, off_score, cpu_cv)
217

    
218
-- | Compute the /total/ variance.
219
compCV :: Node.List -> Double
220
compCV nl =
221
    let (mem_cv, dsk_cv, n1_score, res_cv, off_score, cpu_cv) =
222
            compDetailedCV nl
223
    in mem_cv + dsk_cv + n1_score + res_cv + off_score + cpu_cv
224

    
225
-- | Compute online nodes from a Node.List
226
getOnline :: Node.List -> [Node.Node]
227
getOnline = filter (not . Node.offline) . Container.elems
228

    
229
-- * hbal functions
230

    
231
-- | Compute best table. Note that the ordering of the arguments is important.
232
compareTables :: Table -> Table -> Table
233
compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) =
234
    if a_cv > b_cv then b else a
235

    
236
-- | Applies an instance move to a given node list and instance.
237
applyMove :: Node.List -> Instance.Instance
238
          -> IMove -> OpResult (Node.List, Instance.Instance, Ndx, Ndx)
239
-- Failover (f)
240
applyMove nl inst Failover =
241
    let old_pdx = Instance.pnode inst
242
        old_sdx = Instance.snode inst
243
        old_p = Container.find old_pdx nl
244
        old_s = Container.find old_sdx nl
245
        int_p = Node.removePri old_p inst
246
        int_s = Node.removeSec old_s inst
247
        new_nl = do -- Maybe monad
248
          new_p <- Node.addPri int_s inst
249
          new_s <- Node.addSec int_p inst old_sdx
250
          let new_inst = Instance.setBoth inst old_sdx old_pdx
251
          return (Container.addTwo old_pdx new_s old_sdx new_p nl,
252
                  new_inst, old_sdx, old_pdx)
253
    in new_nl
254

    
255
-- Replace the primary (f:, r:np, f)
256
applyMove nl inst (ReplacePrimary new_pdx) =
257
    let old_pdx = Instance.pnode inst
258
        old_sdx = Instance.snode inst
259
        old_p = Container.find old_pdx nl
260
        old_s = Container.find old_sdx nl
261
        tgt_n = Container.find new_pdx nl
262
        int_p = Node.removePri old_p inst
263
        int_s = Node.removeSec old_s inst
264
        new_nl = do -- Maybe monad
265
          -- check that the current secondary can host the instance
266
          -- during the migration
267
          tmp_s <- Node.addPri int_s inst
268
          let tmp_s' = Node.removePri tmp_s inst
269
          new_p <- Node.addPri tgt_n inst
270
          new_s <- Node.addSec tmp_s' inst new_pdx
271
          let new_inst = Instance.setPri inst new_pdx
272
          return (Container.add new_pdx new_p $
273
                  Container.addTwo old_pdx int_p old_sdx new_s nl,
274
                  new_inst, new_pdx, old_sdx)
275
    in new_nl
276

    
277
-- Replace the secondary (r:ns)
278
applyMove nl inst (ReplaceSecondary new_sdx) =
279
    let old_pdx = Instance.pnode inst
280
        old_sdx = Instance.snode inst
281
        old_s = Container.find old_sdx nl
282
        tgt_n = Container.find new_sdx nl
283
        int_s = Node.removeSec old_s inst
284
        new_inst = Instance.setSec inst new_sdx
285
        new_nl = Node.addSec tgt_n inst old_pdx >>=
286
                 \new_s -> return (Container.addTwo new_sdx
287
                                   new_s old_sdx int_s nl,
288
                                   new_inst, old_pdx, new_sdx)
289
    in new_nl
290

    
291
-- Replace the secondary and failover (r:np, f)
292
applyMove nl inst (ReplaceAndFailover new_pdx) =
293
    let old_pdx = Instance.pnode inst
294
        old_sdx = Instance.snode inst
295
        old_p = Container.find old_pdx nl
296
        old_s = Container.find old_sdx nl
297
        tgt_n = Container.find new_pdx nl
298
        int_p = Node.removePri old_p inst
299
        int_s = Node.removeSec old_s inst
300
        new_nl = do -- Maybe monad
301
          new_p <- Node.addPri tgt_n inst
302
          new_s <- Node.addSec int_p inst new_pdx
303
          let new_inst = Instance.setBoth inst new_pdx old_pdx
304
          return (Container.add new_pdx new_p $
305
                  Container.addTwo old_pdx new_s old_sdx int_s nl,
306
                  new_inst, new_pdx, old_pdx)
307
    in new_nl
308

    
309
-- Failver and replace the secondary (f, r:ns)
310
applyMove nl inst (FailoverAndReplace new_sdx) =
311
    let old_pdx = Instance.pnode inst
312
        old_sdx = Instance.snode inst
313
        old_p = Container.find old_pdx nl
314
        old_s = Container.find old_sdx nl
315
        tgt_n = Container.find new_sdx nl
316
        int_p = Node.removePri old_p inst
317
        int_s = Node.removeSec old_s inst
318
        new_nl = do -- Maybe monad
319
          new_p <- Node.addPri int_s inst
320
          new_s <- Node.addSec tgt_n inst old_sdx
321
          let new_inst = Instance.setBoth inst old_sdx new_sdx
322
          return (Container.add new_sdx new_s $
323
                  Container.addTwo old_sdx new_p old_pdx int_p nl,
324
                  new_inst, old_sdx, new_sdx)
325
    in new_nl
326

    
327
-- | Tries to allocate an instance on one given node.
328
allocateOnSingle :: Node.List -> Instance.Instance -> Node.Node
329
                 -> OpResult AllocElement
330
allocateOnSingle nl inst p =
331
    let new_pdx = Node.idx p
332
        new_inst = Instance.setBoth inst new_pdx Node.noSecondary
333
        new_nl = Node.addPri p inst >>= \new_p ->
334
                 return (Container.add new_pdx new_p nl, new_inst, [new_p])
335
    in new_nl
336

    
337
-- | Tries to allocate an instance on a given pair of nodes.
338
allocateOnPair :: Node.List -> Instance.Instance -> Node.Node -> Node.Node
339
               -> OpResult AllocElement
340
allocateOnPair nl inst tgt_p tgt_s =
341
    let new_pdx = Node.idx tgt_p
342
        new_sdx = Node.idx tgt_s
343
        new_nl = do -- Maybe monad
344
          new_p <- Node.addPri tgt_p inst
345
          new_s <- Node.addSec tgt_s inst new_pdx
346
          let new_inst = Instance.setBoth inst new_pdx new_sdx
347
          return (Container.addTwo new_pdx new_p new_sdx new_s nl, new_inst,
348
                 [new_p, new_s])
349
    in new_nl
350

    
351
-- | Tries to perform an instance move and returns the best table
352
-- between the original one and the new one.
353
checkSingleStep :: Table -- ^ The original table
354
                -> Instance.Instance -- ^ The instance to move
355
                -> Table -- ^ The current best table
356
                -> IMove -- ^ The move to apply
357
                -> Table -- ^ The final best table
358
checkSingleStep ini_tbl target cur_tbl move =
359
    let
360
        Table ini_nl ini_il _ ini_plc = ini_tbl
361
        tmp_resu = applyMove ini_nl target move
362
    in
363
      case tmp_resu of
364
        OpFail _ -> cur_tbl
365
        OpGood (upd_nl, new_inst, pri_idx, sec_idx) ->
366
            let tgt_idx = Instance.idx target
367
                upd_cvar = compCV upd_nl
368
                upd_il = Container.add tgt_idx new_inst ini_il
369
                upd_plc = (tgt_idx, pri_idx, sec_idx, move, upd_cvar):ini_plc
370
                upd_tbl = Table upd_nl upd_il upd_cvar upd_plc
371
            in
372
              compareTables cur_tbl upd_tbl
373

    
374
-- | Given the status of the current secondary as a valid new node and
375
-- the current candidate target node, generate the possible moves for
376
-- a instance.
377
possibleMoves :: Bool      -- ^ Whether the secondary node is a valid new node
378
              -> Ndx       -- ^ Target node candidate
379
              -> [IMove]   -- ^ List of valid result moves
380
possibleMoves True tdx =
381
    [ReplaceSecondary tdx,
382
     ReplaceAndFailover tdx,
383
     ReplacePrimary tdx,
384
     FailoverAndReplace tdx]
385

    
386
possibleMoves False tdx =
387
    [ReplaceSecondary tdx,
388
     ReplaceAndFailover tdx]
389

    
390
-- | Compute the best move for a given instance.
391
checkInstanceMove :: [Ndx]             -- ^ Allowed target node indices
392
                  -> Bool              -- ^ Whether disk moves are allowed
393
                  -> Table             -- ^ Original table
394
                  -> Instance.Instance -- ^ Instance to move
395
                  -> Table             -- ^ Best new table for this instance
396
checkInstanceMove nodes_idx disk_moves ini_tbl target =
397
    let
398
        opdx = Instance.pnode target
399
        osdx = Instance.snode target
400
        nodes = filter (\idx -> idx /= opdx && idx /= osdx) nodes_idx
401
        use_secondary = elem osdx nodes_idx
402
        aft_failover = if use_secondary -- if allowed to failover
403
                       then checkSingleStep ini_tbl target ini_tbl Failover
404
                       else ini_tbl
405
        all_moves = if disk_moves
406
                    then concatMap (possibleMoves use_secondary) nodes
407
                    else []
408
    in
409
      -- iterate over the possible nodes for this instance
410
      foldl' (checkSingleStep ini_tbl target) aft_failover all_moves
411

    
412
-- | Compute the best next move.
413
checkMove :: [Ndx]               -- ^ Allowed target node indices
414
          -> Bool                -- ^ Whether disk moves are allowed
415
          -> Table               -- ^ The current solution
416
          -> [Instance.Instance] -- ^ List of instances still to move
417
          -> Table               -- ^ The new solution
418
checkMove nodes_idx disk_moves ini_tbl victims =
419
    let Table _ _ _ ini_plc = ini_tbl
420
        -- iterate over all instances, computing the best move
421
        best_tbl =
422
            foldl'
423
            (\ step_tbl em ->
424
                 if Instance.snode em == Node.noSecondary then step_tbl
425
                    else compareTables step_tbl $
426
                         checkInstanceMove nodes_idx disk_moves ini_tbl em)
427
            ini_tbl victims
428
        Table _ _ _ best_plc = best_tbl
429
    in
430
      if length best_plc == length ini_plc then -- no advancement
431
          ini_tbl
432
      else
433
          best_tbl
434

    
435
-- | Run a balance move
436

    
437
tryBalance :: Table       -- ^ The starting table
438
           -> Int         -- ^ Remaining length
439
           -> Bool        -- ^ Allow disk moves
440
           -> Score       -- ^ Score at which to stop
441
           -> Maybe Table -- ^ The resulting table and commands
442
tryBalance ini_tbl max_rounds disk_moves min_score =
443
    let Table ini_nl ini_il ini_cv ini_plc = ini_tbl
444
        ini_plc_len = length ini_plc
445
        allowed_next = (max_rounds < 0 || ini_plc_len < max_rounds) &&
446
                       ini_cv > min_score
447
    in
448
      if allowed_next
449
      then let all_inst = Container.elems ini_il
450
               node_idx = map Node.idx . filter (not . Node.offline) $
451
                          Container.elems ini_nl
452
               fin_tbl = checkMove node_idx disk_moves ini_tbl all_inst
453
               (Table _ _ fin_cv _) = fin_tbl
454
           in
455
             if fin_cv < ini_cv
456
             then Just fin_tbl -- this round made success, try deeper
457
             else Nothing
458
      else Nothing
459

    
460
-- * Allocation functions
461

    
462
-- | Build failure stats out of a list of failures
463
collapseFailures :: [FailMode] -> FailStats
464
collapseFailures flst =
465
    map (\k -> (k, length $ filter ((==) k) flst)) [minBound..maxBound]
466

    
467
-- | Update current Allocation solution and failure stats with new
468
-- elements
469
concatAllocs :: AllocSolution -> OpResult AllocElement -> AllocSolution
470
concatAllocs (flst, cntok, sols) (OpFail reason) = (reason:flst, cntok, sols)
471

    
472
concatAllocs (flst, cntok, osols) (OpGood ns@(nl, _, _)) =
473
    let nscore = compCV nl
474
        -- Choose the old or new solution, based on the cluster score
475
        nsols = case osols of
476
                  Nothing -> Just (nscore, ns)
477
                  Just (oscore, _) ->
478
                      if oscore < nscore
479
                      then osols
480
                      else Just (nscore, ns)
481
        nsuc = cntok + 1
482
    -- Note: we force evaluation of nsols here in order to keep the
483
    -- memory profile low - we know that we will need nsols for sure
484
    -- in the next cycle, so we force evaluation of nsols, since the
485
    -- foldl' in the caller will only evaluate the tuple, but not the
486
    -- elements of the tuple
487
    in nsols `seq` nsuc `seq` (flst, nsuc, nsols)
488

    
489
-- | Try to allocate an instance on the cluster.
490
tryAlloc :: (Monad m) =>
491
            Node.List         -- ^ The node list
492
         -> Instance.List     -- ^ The instance list
493
         -> Instance.Instance -- ^ The instance to allocate
494
         -> Int               -- ^ Required number of nodes
495
         -> m AllocSolution   -- ^ Possible solution list
496
tryAlloc nl _ inst 2 =
497
    let all_nodes = getOnline nl
498
        all_pairs = liftM2 (,) all_nodes all_nodes
499
        ok_pairs = filter (\(x, y) -> Node.idx x /= Node.idx y) all_pairs
500
        sols = foldl' (\cstate (p, s) ->
501
                           concatAllocs cstate $ allocateOnPair nl inst p s
502
                      ) ([], 0, Nothing) ok_pairs
503
    in return sols
504

    
505
tryAlloc nl _ inst 1 =
506
    let all_nodes = getOnline nl
507
        sols = foldl' (\cstate ->
508
                           concatAllocs cstate . allocateOnSingle nl inst
509
                      ) ([], 0, Nothing) all_nodes
510
    in return sols
511

    
512
tryAlloc _ _ _ reqn = fail $ "Unsupported number of allocation \
513
                             \destinations required (" ++ show reqn ++
514
                                               "), only two supported"
515

    
516
-- | Try to allocate an instance on the cluster.
517
tryReloc :: (Monad m) =>
518
            Node.List       -- ^ The node list
519
         -> Instance.List   -- ^ The instance list
520
         -> Idx             -- ^ The index of the instance to move
521
         -> Int             -- ^ The number of nodes required
522
         -> [Ndx]           -- ^ Nodes which should not be used
523
         -> m AllocSolution -- ^ Solution list
524
tryReloc nl il xid 1 ex_idx =
525
    let all_nodes = getOnline nl
526
        inst = Container.find xid il
527
        ex_idx' = Instance.pnode inst:ex_idx
528
        valid_nodes = filter (not . flip elem ex_idx' . Node.idx) all_nodes
529
        valid_idxes = map Node.idx valid_nodes
530
        sols1 = foldl' (\cstate x ->
531
                            let em = do
532
                                  (mnl, i, _, _) <-
533
                                      applyMove nl inst (ReplaceSecondary x)
534
                                  return (mnl, i, [Container.find x mnl])
535
                            in concatAllocs cstate em
536
                       ) ([], 0, Nothing) valid_idxes
537
    in return sols1
538

    
539
tryReloc _ _ _ reqn _  = fail $ "Unsupported number of relocation \
540
                                \destinations required (" ++ show reqn ++
541
                                                  "), only one supported"
542

    
543
-- * Formatting functions
544

    
545
-- | Given the original and final nodes, computes the relocation description.
546
computeMoves :: Instance.Instance -- ^ The instance to be moved
547
             -> String -- ^ The instance name
548
             -> String -- ^ Original primary
549
             -> String -- ^ Original secondary
550
             -> String -- ^ New primary
551
             -> String -- ^ New secondary
552
             -> (String, [String])
553
                -- ^ Tuple of moves and commands list; moves is containing
554
                -- either @/f/@ for failover or @/r:name/@ for replace
555
                -- secondary, while the command list holds gnt-instance
556
                -- commands (without that prefix), e.g \"@failover instance1@\"
557
computeMoves i inam a b c d
558
    -- same primary
559
    | c == a =
560
        if d == b
561
        then {- Same sec??! -} ("-", [])
562
        else {- Change of secondary -}
563
            (printf "r:%s" d, [rep d])
564
    -- failover and ...
565
    | c == b =
566
        if d == a
567
        then {- that's all -} ("f", [mig])
568
        else (printf "f r:%s" d, [mig, rep d])
569
    -- ... and keep primary as secondary
570
    | d == a =
571
        (printf "r:%s f" c, [rep c, mig])
572
    -- ... keep same secondary
573
    | d == b =
574
        (printf "f r:%s f" c, [mig, rep c, mig])
575
    -- nothing in common -
576
    | otherwise =
577
        (printf "r:%s f r:%s" c d, [rep c, mig, rep d])
578
    where morf = if Instance.running i then "migrate" else "failover"
579
          mig = printf "%s -f %s" morf inam::String
580
          rep n = printf "replace-disks -n %s %s" n inam
581

    
582
-- | Converts a placement to string format.
583
printSolutionLine :: Node.List     -- ^ The node list
584
                  -> Instance.List -- ^ The instance list
585
                  -> Int           -- ^ Maximum node name length
586
                  -> Int           -- ^ Maximum instance name length
587
                  -> Placement     -- ^ The current placement
588
                  -> Int           -- ^ The index of the placement in
589
                                   -- the solution
590
                  -> (String, [String])
591
printSolutionLine nl il nmlen imlen plc pos =
592
    let
593
        pmlen = (2*nmlen + 1)
594
        (i, p, s, _, c) = plc
595
        inst = Container.find i il
596
        inam = Instance.name inst
597
        npri = Container.nameOf nl p
598
        nsec = Container.nameOf nl s
599
        opri = Container.nameOf nl $ Instance.pnode inst
600
        osec = Container.nameOf nl $ Instance.snode inst
601
        (moves, cmds) =  computeMoves inst inam opri osec npri nsec
602
        ostr = printf "%s:%s" opri osec::String
603
        nstr = printf "%s:%s" npri nsec::String
604
    in
605
      (printf "  %3d. %-*s %-*s => %-*s %.8f a=%s"
606
       pos imlen inam pmlen ostr
607
       pmlen nstr c moves,
608
       cmds)
609

    
610
-- | Return the instance and involved nodes in an instance move.
611
involvedNodes :: Instance.List -> Placement -> [Ndx]
612
involvedNodes il plc =
613
    let (i, np, ns, _, _) = plc
614
        inst = Container.find i il
615
        op = Instance.pnode inst
616
        os = Instance.snode inst
617
    in nub [np, ns, op, os]
618

    
619
-- | Inner function for splitJobs, that either appends the next job to
620
-- the current jobset, or starts a new jobset.
621
mergeJobs :: ([JobSet], [Ndx]) -> MoveJob -> ([JobSet], [Ndx])
622
mergeJobs ([], _) n@(ndx, _, _) = ([[n]], ndx)
623
mergeJobs (cjs@(j:js), nbuf) n@(ndx, _, _)
624
    | null (ndx `intersect` nbuf) = ((n:j):js, ndx ++ nbuf)
625
    | otherwise = ([n]:cjs, ndx)
626

    
627
-- | Break a list of moves into independent groups. Note that this
628
-- will reverse the order of jobs.
629
splitJobs :: [MoveJob] -> [JobSet]
630
splitJobs = fst . foldl mergeJobs ([], [])
631

    
632
-- | Given a list of commands, prefix them with @gnt-instance@ and
633
-- also beautify the display a little.
634
formatJob :: Int -> Int -> (Int, MoveJob) -> [String]
635
formatJob jsn jsl (sn, (_, _, cmds)) =
636
    let out =
637
            printf "  echo job %d/%d" jsn sn:
638
            printf "  check":
639
            map ("  gnt-instance " ++) cmds
640
    in if sn == 1
641
       then ["", printf "echo jobset %d, %d jobs" jsn jsl] ++ out
642
       else out
643

    
644
-- | Given a list of commands, prefix them with @gnt-instance@ and
645
-- also beautify the display a little.
646
formatCmds :: [JobSet] -> String
647
formatCmds =
648
    unlines .
649
    concatMap (\(jsn, js) -> concatMap (formatJob jsn (length js))
650
                             (zip [1..] js)) .
651
    zip [1..]
652

    
653
-- | Converts a solution to string format.
654
printSolution :: Node.List
655
              -> Instance.List
656
              -> [Placement]
657
              -> ([String], [[String]])
658
printSolution nl il sol =
659
    let
660
        nmlen = Container.maxNameLen nl
661
        imlen = Container.maxNameLen il
662
    in
663
      unzip $ zipWith (printSolutionLine nl il nmlen imlen) sol [1..]
664

    
665
-- | Print the node list.
666
printNodes :: Node.List -> String
667
printNodes nl =
668
    let snl = sortBy (compare `on` Node.idx) (Container.elems nl)
669
        m_name = maximum . map (length . Node.name) $ snl
670
        helper = Node.list m_name
671
        header = printf
672
                 "%2s %-*s %5s %5s %5s %5s %5s %5s %5s %5s %4s %4s \
673
                 \%3s %3s %6s %6s %5s"
674
                 " F" m_name "Name"
675
                 "t_mem" "n_mem" "i_mem" "x_mem" "f_mem" "r_mem"
676
                 "t_dsk" "f_dsk" "pcpu" "vcpu"
677
                 "pri" "sec" "p_fmem" "p_fdsk" "r_cpu"::String
678
    in unlines (header:map helper snl)
679

    
680
-- | Shows statistics for a given node list.
681
printStats :: Node.List -> String
682
printStats nl =
683
    let (mem_cv, dsk_cv, n1_score, res_cv, off_score, cpu_cv) =
684
            compDetailedCV nl
685
    in printf "f_mem=%.8f, r_mem=%.8f, f_dsk=%.8f, n1=%.3f, \
686
              \uf=%.3f, r_cpu=%.3f"
687
       mem_cv res_cv dsk_cv n1_score off_score cpu_cv
688

    
689
-- | Convert a placement into a list of OpCodes (basically a job).
690
iMoveToJob :: String -> Node.List -> Instance.List
691
          -> Idx -> IMove -> [OpCodes.OpCode]
692
iMoveToJob csf nl il idx move =
693
    let iname = Container.nameOf il idx ++ csf
694
        lookNode n = Just (Container.nameOf nl n ++ csf)
695
        opF = OpCodes.OpFailoverInstance iname False
696
        opR n = OpCodes.OpReplaceDisks iname (lookNode n)
697
                OpCodes.ReplaceNewSecondary [] Nothing
698
    in case move of
699
         Failover -> [ opF ]
700
         ReplacePrimary np -> [ opF, opR np, opF ]
701
         ReplaceSecondary ns -> [ opR ns ]
702
         ReplaceAndFailover np -> [ opR np, opF ]
703
         FailoverAndReplace ns -> [ opF, opR ns ]