Statistics
| Branch: | Tag: | Revision:

root / Ganeti / HTools / Cluster.hs @ 9b8fac3d

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

    
64
import Data.List
65
import Data.Ord (comparing)
66
import Text.Printf (printf)
67
import Control.Monad
68

    
69
import qualified Ganeti.HTools.Container as Container
70
import qualified Ganeti.HTools.Instance as Instance
71
import qualified Ganeti.HTools.Node as Node
72
import Ganeti.HTools.Types
73
import Ganeti.HTools.Utils
74
import qualified Ganeti.OpCodes as OpCodes
75

    
76
-- * Types
77

    
78
-- | Allocation\/relocation solution.
79
type AllocSolution = ([FailMode], Int, [(Score, Node.AllocElement)])
80

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

    
85
data CStats = CStats { csFmem :: Int    -- ^ Cluster free mem
86
                     , csFdsk :: Int    -- ^ Cluster free disk
87
                     , csAmem :: Int    -- ^ Cluster allocatable mem
88
                     , csAdsk :: Int    -- ^ Cluster allocatable disk
89
                     , csAcpu :: Int    -- ^ Cluster allocatable cpus
90
                     , csMmem :: Int    -- ^ Max node allocatable mem
91
                     , csMdsk :: Int    -- ^ Max node allocatable disk
92
                     , csMcpu :: Int    -- ^ Max node allocatable cpu
93
                     , csImem :: Int    -- ^ Instance used mem
94
                     , csIdsk :: Int    -- ^ Instance used disk
95
                     , csIcpu :: Int    -- ^ Instance used cpu
96
                     , csTmem :: Double -- ^ Cluster total mem
97
                     , csTdsk :: Double -- ^ Cluster total disk
98
                     , csTcpu :: Double -- ^ Cluster total cpus
99
                     , csVcpu :: Int    -- ^ Cluster virtual cpus (if
100
                                        -- node pCpu has been set,
101
                                        -- otherwise -1)
102
                     , csXmem :: Int    -- ^ Unnacounted for mem
103
                     , csNmem :: Int    -- ^ Node own memory
104
                     , csScore :: Score -- ^ The cluster score
105
                     , csNinst :: Int   -- ^ The total number of instances
106
                     }
107

    
108
-- | Currently used, possibly to allocate, unallocable
109
type AllocStats = (RSpec, RSpec, RSpec)
110

    
111
-- * Utility functions
112

    
113
-- | Verifies the N+1 status and return the affected nodes.
114
verifyN1 :: [Node.Node] -> [Node.Node]
115
verifyN1 = filter Node.failN1
116

    
117
{-| Computes the pair of bad nodes and instances.
118

    
119
The bad node list is computed via a simple 'verifyN1' check, and the
120
bad instance list is the list of primary and secondary instances of
121
those nodes.
122

    
123
-}
124
computeBadItems :: Node.List -> Instance.List ->
125
                   ([Node.Node], [Instance.Instance])
126
computeBadItems nl il =
127
  let bad_nodes = verifyN1 $ getOnline nl
128
      bad_instances = map (`Container.find` il) .
129
                      sort . nub $
130
                      concatMap (\ n -> Node.sList n ++ Node.pList n) bad_nodes
131
  in
132
    (bad_nodes, bad_instances)
133

    
134
-- | Zero-initializer for the CStats type
135
emptyCStats :: CStats
136
emptyCStats = CStats 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
137

    
138
-- | Update stats with data from a new node
139
updateCStats :: CStats -> Node.Node -> CStats
140
updateCStats cs node =
141
    let CStats { csFmem = x_fmem, csFdsk = x_fdsk,
142
                 csAmem = x_amem, csAcpu = x_acpu, csAdsk = x_adsk,
143
                 csMmem = x_mmem, csMdsk = x_mdsk, csMcpu = x_mcpu,
144
                 csImem = x_imem, csIdsk = x_idsk, csIcpu = x_icpu,
145
                 csTmem = x_tmem, csTdsk = x_tdsk, csTcpu = x_tcpu,
146
                 csVcpu = x_vcpu,
147
                 csXmem = x_xmem, csNmem = x_nmem, csNinst = x_ninst
148
               }
149
            = cs
150
        inc_amem = Node.fMem node - Node.rMem node
151
        inc_amem' = if inc_amem > 0 then inc_amem else 0
152
        inc_adsk = Node.availDisk node
153
        inc_imem = truncate (Node.tMem node) - Node.nMem node
154
                   - Node.xMem node - Node.fMem node
155
        inc_icpu = Node.uCpu node
156
        inc_idsk = truncate (Node.tDsk node) - Node.fDsk node
157
        inc_vcpu = Node.hiCpu node
158

    
159
    in cs { csFmem = x_fmem + Node.fMem node
160
          , csFdsk = x_fdsk + Node.fDsk node
161
          , csAmem = x_amem + inc_amem'
162
          , csAdsk = x_adsk + inc_adsk
163
          , csAcpu = x_acpu
164
          , csMmem = max x_mmem inc_amem'
165
          , csMdsk = max x_mdsk inc_adsk
166
          , csMcpu = x_mcpu
167
          , csImem = x_imem + inc_imem
168
          , csIdsk = x_idsk + inc_idsk
169
          , csIcpu = x_icpu + inc_icpu
170
          , csTmem = x_tmem + Node.tMem node
171
          , csTdsk = x_tdsk + Node.tDsk node
172
          , csTcpu = x_tcpu + Node.tCpu node
173
          , csVcpu = if inc_vcpu == Node.noLimitInt
174
                     then Node.noLimitInt
175
                     else x_vcpu + inc_vcpu
176
          , csXmem = x_xmem + Node.xMem node
177
          , csNmem = x_nmem + Node.nMem node
178
          , csNinst = x_ninst + length (Node.pList node)
179
          }
180

    
181
-- | Compute the total free disk and memory in the cluster.
182
totalResources :: Node.List -> CStats
183
totalResources nl =
184
    let cs = foldl' updateCStats emptyCStats . Container.elems $ nl
185
    in cs { csScore = compCV nl }
186

    
187
-- | Compute the delta between two cluster state.
188
--
189
-- This is used when doing allocations, to understand better the
190
-- available cluster resources.
191
computeAllocationDelta :: CStats -> CStats -> AllocStats
192
computeAllocationDelta cini cfin =
193
    let CStats {csImem = i_imem, csIdsk = i_idsk, csIcpu = i_icpu} = cini
194
        CStats {csImem = f_imem, csIdsk = f_idsk, csIcpu = f_icpu,
195
                csTmem = t_mem, csTdsk = t_dsk, csVcpu = v_cpu } = cfin
196
        rini = RSpec i_icpu i_imem i_idsk
197
        rfin = RSpec f_icpu f_imem f_idsk
198
        un_cpu = if v_cpu == Node.noLimitInt
199
                 then Node.noLimitInt
200
                 else v_cpu - f_icpu
201
        runa = RSpec un_cpu (truncate t_mem - f_imem) (truncate t_dsk - f_idsk)
202
    in (rini, rfin, runa)
203

    
204
-- | The names of the individual elements in the CV list
205
detailedCVNames :: [String]
206
detailedCVNames = [ "free_mem_cv"
207
                  , "free_disk_cv"
208
                  , "n1_cnt"
209
                  , "reserved_mem_cv"
210
                  , "offline_all_cnt"
211
                  , "offline_pri_cnt"
212
                  , "vcpu_ratio_cv"
213
                  , "cpu_load_cv"
214
                  , "mem_load_cv"
215
                  , "disk_load_cv"
216
                  , "net_load_cv"
217
                  , "pri_tags_score"
218
                  ]
219

    
220
-- | Compute the mem and disk covariance.
221
compDetailedCV :: Node.List -> [Double]
222
compDetailedCV nl =
223
    let
224
        all_nodes = Container.elems nl
225
        (offline, nodes) = partition Node.offline all_nodes
226
        mem_l = map Node.pMem nodes
227
        dsk_l = map Node.pDsk nodes
228
        -- metric: memory covariance
229
        mem_cv = varianceCoeff mem_l
230
        -- metric: disk covariance
231
        dsk_cv = varianceCoeff dsk_l
232
        n1_l = length $ filter Node.failN1 nodes
233
        -- metric: count of failN1 nodes
234
        n1_score = fromIntegral n1_l::Double
235
        res_l = map Node.pRem nodes
236
        -- metric: reserved memory covariance
237
        res_cv = varianceCoeff res_l
238
        -- offline instances metrics
239
        offline_ipri = sum . map (length . Node.pList) $ offline
240
        offline_isec = sum . map (length . Node.sList) $ offline
241
        -- metric: count of instances on offline nodes
242
        off_score = fromIntegral (offline_ipri + offline_isec)::Double
243
        -- metric: count of primary instances on offline nodes (this
244
        -- helps with evacuation/failover of primary instances on
245
        -- 2-node clusters with one node offline)
246
        off_pri_score = fromIntegral offline_ipri::Double
247
        cpu_l = map Node.pCpu nodes
248
        -- metric: covariance of vcpu/pcpu ratio
249
        cpu_cv = varianceCoeff cpu_l
250
        -- metrics: covariance of cpu, memory, disk and network load
251
        (c_load, m_load, d_load, n_load) = unzip4 $
252
            map (\n ->
253
                     let DynUtil c1 m1 d1 n1 = Node.utilLoad n
254
                         DynUtil c2 m2 d2 n2 = Node.utilPool n
255
                     in (c1/c2, m1/m2, d1/d2, n1/n2)
256
                ) nodes
257
        -- metric: conflicting instance count
258
        pri_tags_inst = sum $ map Node.conflictingPrimaries nodes
259
        pri_tags_score = fromIntegral pri_tags_inst::Double
260
    in [ mem_cv, dsk_cv, n1_score, res_cv, off_score, off_pri_score, cpu_cv
261
       , varianceCoeff c_load, varianceCoeff m_load
262
       , varianceCoeff d_load, varianceCoeff n_load
263
       , pri_tags_score ]
264

    
265
-- | Compute the /total/ variance.
266
compCV :: Node.List -> Double
267
compCV = sum . compDetailedCV
268

    
269
-- | Compute online nodes from a Node.List
270
getOnline :: Node.List -> [Node.Node]
271
getOnline = filter (not . Node.offline) . Container.elems
272

    
273
-- * hbal functions
274

    
275
-- | Compute best table. Note that the ordering of the arguments is important.
276
compareTables :: Table -> Table -> Table
277
compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) =
278
    if a_cv > b_cv then b else a
279

    
280
-- | Applies an instance move to a given node list and instance.
281
applyMove :: Node.List -> Instance.Instance
282
          -> IMove -> OpResult (Node.List, Instance.Instance, Ndx, Ndx)
283
-- Failover (f)
284
applyMove nl inst Failover =
285
    let old_pdx = Instance.pNode inst
286
        old_sdx = Instance.sNode inst
287
        old_p = Container.find old_pdx nl
288
        old_s = Container.find old_sdx nl
289
        int_p = Node.removePri old_p inst
290
        int_s = Node.removeSec old_s inst
291
        new_nl = do -- Maybe monad
292
          new_p <- Node.addPri int_s inst
293
          new_s <- Node.addSec int_p inst old_sdx
294
          let new_inst = Instance.setBoth inst old_sdx old_pdx
295
          return (Container.addTwo old_pdx new_s old_sdx new_p nl,
296
                  new_inst, old_sdx, old_pdx)
297
    in new_nl
298

    
299
-- Replace the primary (f:, r:np, f)
300
applyMove nl inst (ReplacePrimary new_pdx) =
301
    let old_pdx = Instance.pNode inst
302
        old_sdx = Instance.sNode inst
303
        old_p = Container.find old_pdx nl
304
        old_s = Container.find old_sdx nl
305
        tgt_n = Container.find new_pdx nl
306
        int_p = Node.removePri old_p inst
307
        int_s = Node.removeSec old_s inst
308
        new_nl = do -- Maybe monad
309
          -- check that the current secondary can host the instance
310
          -- during the migration
311
          tmp_s <- Node.addPri int_s inst
312
          let tmp_s' = Node.removePri tmp_s inst
313
          new_p <- Node.addPri tgt_n inst
314
          new_s <- Node.addSec tmp_s' inst new_pdx
315
          let new_inst = Instance.setPri inst new_pdx
316
          return (Container.add new_pdx new_p $
317
                  Container.addTwo old_pdx int_p old_sdx new_s nl,
318
                  new_inst, new_pdx, old_sdx)
319
    in new_nl
320

    
321
-- Replace the secondary (r:ns)
322
applyMove nl inst (ReplaceSecondary new_sdx) =
323
    let old_pdx = Instance.pNode inst
324
        old_sdx = Instance.sNode inst
325
        old_s = Container.find old_sdx nl
326
        tgt_n = Container.find new_sdx nl
327
        int_s = Node.removeSec old_s inst
328
        new_inst = Instance.setSec inst new_sdx
329
        new_nl = Node.addSec tgt_n inst old_pdx >>=
330
                 \new_s -> return (Container.addTwo new_sdx
331
                                   new_s old_sdx int_s nl,
332
                                   new_inst, old_pdx, new_sdx)
333
    in new_nl
334

    
335
-- Replace the secondary and failover (r:np, f)
336
applyMove nl inst (ReplaceAndFailover new_pdx) =
337
    let old_pdx = Instance.pNode inst
338
        old_sdx = Instance.sNode inst
339
        old_p = Container.find old_pdx nl
340
        old_s = Container.find old_sdx nl
341
        tgt_n = Container.find new_pdx nl
342
        int_p = Node.removePri old_p inst
343
        int_s = Node.removeSec old_s inst
344
        new_nl = do -- Maybe monad
345
          new_p <- Node.addPri tgt_n inst
346
          new_s <- Node.addSec int_p inst new_pdx
347
          let new_inst = Instance.setBoth inst new_pdx old_pdx
348
          return (Container.add new_pdx new_p $
349
                  Container.addTwo old_pdx new_s old_sdx int_s nl,
350
                  new_inst, new_pdx, old_pdx)
351
    in new_nl
352

    
353
-- Failver and replace the secondary (f, r:ns)
354
applyMove nl inst (FailoverAndReplace new_sdx) =
355
    let old_pdx = Instance.pNode inst
356
        old_sdx = Instance.sNode inst
357
        old_p = Container.find old_pdx nl
358
        old_s = Container.find old_sdx nl
359
        tgt_n = Container.find new_sdx nl
360
        int_p = Node.removePri old_p inst
361
        int_s = Node.removeSec old_s inst
362
        new_nl = do -- Maybe monad
363
          new_p <- Node.addPri int_s inst
364
          new_s <- Node.addSec tgt_n inst old_sdx
365
          let new_inst = Instance.setBoth inst old_sdx new_sdx
366
          return (Container.add new_sdx new_s $
367
                  Container.addTwo old_sdx new_p old_pdx int_p nl,
368
                  new_inst, old_sdx, new_sdx)
369
    in new_nl
370

    
371
-- | Tries to allocate an instance on one given node.
372
allocateOnSingle :: Node.List -> Instance.Instance -> Node.Node
373
                 -> OpResult Node.AllocElement
374
allocateOnSingle nl inst p =
375
    let new_pdx = Node.idx p
376
        new_inst = Instance.setBoth inst new_pdx Node.noSecondary
377
        new_nl = Node.addPri p inst >>= \new_p ->
378
                 return (Container.add new_pdx new_p nl, new_inst, [new_p])
379
    in new_nl
380

    
381
-- | Tries to allocate an instance on a given pair of nodes.
382
allocateOnPair :: Node.List -> Instance.Instance -> Node.Node -> Node.Node
383
               -> OpResult Node.AllocElement
384
allocateOnPair nl inst tgt_p tgt_s =
385
    let new_pdx = Node.idx tgt_p
386
        new_sdx = Node.idx tgt_s
387
        new_nl = do -- Maybe monad
388
          new_p <- Node.addPri tgt_p inst
389
          new_s <- Node.addSec tgt_s inst new_pdx
390
          let new_inst = Instance.setBoth inst new_pdx new_sdx
391
          return (Container.addTwo new_pdx new_p new_sdx new_s nl, new_inst,
392
                 [new_p, new_s])
393
    in new_nl
394

    
395
-- | Tries to perform an instance move and returns the best table
396
-- between the original one and the new one.
397
checkSingleStep :: Table -- ^ The original table
398
                -> Instance.Instance -- ^ The instance to move
399
                -> Table -- ^ The current best table
400
                -> IMove -- ^ The move to apply
401
                -> Table -- ^ The final best table
402
checkSingleStep ini_tbl target cur_tbl move =
403
    let
404
        Table ini_nl ini_il _ ini_plc = ini_tbl
405
        tmp_resu = applyMove ini_nl target move
406
    in
407
      case tmp_resu of
408
        OpFail _ -> cur_tbl
409
        OpGood (upd_nl, new_inst, pri_idx, sec_idx) ->
410
            let tgt_idx = Instance.idx target
411
                upd_cvar = compCV upd_nl
412
                upd_il = Container.add tgt_idx new_inst ini_il
413
                upd_plc = (tgt_idx, pri_idx, sec_idx, move, upd_cvar):ini_plc
414
                upd_tbl = Table upd_nl upd_il upd_cvar upd_plc
415
            in
416
              compareTables cur_tbl upd_tbl
417

    
418
-- | Given the status of the current secondary as a valid new node and
419
-- the current candidate target node, generate the possible moves for
420
-- a instance.
421
possibleMoves :: Bool      -- ^ Whether the secondary node is a valid new node
422
              -> Ndx       -- ^ Target node candidate
423
              -> [IMove]   -- ^ List of valid result moves
424
possibleMoves True tdx =
425
    [ReplaceSecondary tdx,
426
     ReplaceAndFailover tdx,
427
     ReplacePrimary tdx,
428
     FailoverAndReplace tdx]
429

    
430
possibleMoves False tdx =
431
    [ReplaceSecondary tdx,
432
     ReplaceAndFailover tdx]
433

    
434
-- | Compute the best move for a given instance.
435
checkInstanceMove :: [Ndx]             -- ^ Allowed target node indices
436
                  -> Bool              -- ^ Whether disk moves are allowed
437
                  -> Table             -- ^ Original table
438
                  -> Instance.Instance -- ^ Instance to move
439
                  -> Table             -- ^ Best new table for this instance
440
checkInstanceMove nodes_idx disk_moves ini_tbl target =
441
    let
442
        opdx = Instance.pNode target
443
        osdx = Instance.sNode target
444
        nodes = filter (\idx -> idx /= opdx && idx /= osdx) nodes_idx
445
        use_secondary = elem osdx nodes_idx
446
        aft_failover = if use_secondary -- if allowed to failover
447
                       then checkSingleStep ini_tbl target ini_tbl Failover
448
                       else ini_tbl
449
        all_moves = if disk_moves
450
                    then concatMap (possibleMoves use_secondary) nodes
451
                    else []
452
    in
453
      -- iterate over the possible nodes for this instance
454
      foldl' (checkSingleStep ini_tbl target) aft_failover all_moves
455

    
456
-- | Compute the best next move.
457
checkMove :: [Ndx]               -- ^ Allowed target node indices
458
          -> Bool                -- ^ Whether disk moves are allowed
459
          -> Table               -- ^ The current solution
460
          -> [Instance.Instance] -- ^ List of instances still to move
461
          -> Table               -- ^ The new solution
462
checkMove nodes_idx disk_moves ini_tbl victims =
463
    let Table _ _ _ ini_plc = ini_tbl
464
        -- iterate over all instances, computing the best move
465
        best_tbl =
466
            foldl'
467
            (\ step_tbl em ->
468
                 compareTables step_tbl $
469
                 checkInstanceMove nodes_idx disk_moves ini_tbl em)
470
            ini_tbl victims
471
        Table _ _ _ best_plc = best_tbl
472
    in if length best_plc == length ini_plc
473
       then ini_tbl -- no advancement
474
       else best_tbl
475

    
476
-- | Check if we are allowed to go deeper in the balancing
477

    
478
doNextBalance :: Table       -- ^ The starting table
479
              -> Int         -- ^ Remaining length
480
              -> Score       -- ^ Score at which to stop
481
              -> Bool -- ^ The resulting table and commands
482
doNextBalance ini_tbl max_rounds min_score =
483
    let Table _ _ ini_cv ini_plc = ini_tbl
484
        ini_plc_len = length ini_plc
485
    in (max_rounds < 0 || ini_plc_len < max_rounds) && ini_cv > min_score
486

    
487
-- | Run a balance move
488

    
489
tryBalance :: Table       -- ^ The starting table
490
           -> Bool        -- ^ Allow disk moves
491
           -> Bool        -- ^ Only evacuate moves
492
           -> Maybe Table -- ^ The resulting table and commands
493
tryBalance ini_tbl disk_moves evac_mode =
494
    let Table ini_nl ini_il ini_cv _ = ini_tbl
495
        all_inst = Container.elems ini_il
496
        all_inst' = if evac_mode
497
                    then let bad_nodes = map Node.idx . filter Node.offline $
498
                                         Container.elems ini_nl
499
                         in filter (\e -> Instance.sNode e `elem` bad_nodes ||
500
                                          Instance.pNode e `elem` bad_nodes)
501
                            all_inst
502
                    else all_inst
503
        reloc_inst = filter Instance.movable all_inst'
504
        node_idx = map Node.idx . filter (not . Node.offline) $
505
                   Container.elems ini_nl
506
        fin_tbl = checkMove node_idx disk_moves ini_tbl reloc_inst
507
        (Table _ _ fin_cv _) = fin_tbl
508
    in
509
      if fin_cv < ini_cv
510
      then Just fin_tbl -- this round made success, return the new table
511
      else Nothing
512

    
513
-- * Allocation functions
514

    
515
-- | Build failure stats out of a list of failures
516
collapseFailures :: [FailMode] -> FailStats
517
collapseFailures flst =
518
    map (\k -> (k, length $ filter (k ==) flst)) [minBound..maxBound]
519

    
520
-- | Update current Allocation solution and failure stats with new
521
-- elements
522
concatAllocs :: AllocSolution -> OpResult Node.AllocElement -> AllocSolution
523
concatAllocs (flst, cntok, sols) (OpFail reason) = (reason:flst, cntok, sols)
524

    
525
concatAllocs (flst, cntok, osols) (OpGood ns@(nl, _, _)) =
526
    let nscore = compCV nl
527
        -- Choose the old or new solution, based on the cluster score
528
        nsols = case osols of
529
                  [] -> [(nscore, ns)]
530
                  (oscore, _):[] ->
531
                      if oscore < nscore
532
                      then osols
533
                      else [(nscore, ns)]
534
                  -- FIXME: here we simply concat to lists with more
535
                  -- than one element; we should instead abort, since
536
                  -- this is not a valid usage of this function
537
                  xs -> (nscore, ns):xs
538
        nsuc = cntok + 1
539
    -- Note: we force evaluation of nsols here in order to keep the
540
    -- memory profile low - we know that we will need nsols for sure
541
    -- in the next cycle, so we force evaluation of nsols, since the
542
    -- foldl' in the caller will only evaluate the tuple, but not the
543
    -- elements of the tuple
544
    in nsols `seq` nsuc `seq` (flst, nsuc, nsols)
545

    
546
-- | Try to allocate an instance on the cluster.
547
tryAlloc :: (Monad m) =>
548
            Node.List         -- ^ The node list
549
         -> Instance.List     -- ^ The instance list
550
         -> Instance.Instance -- ^ The instance to allocate
551
         -> Int               -- ^ Required number of nodes
552
         -> m AllocSolution   -- ^ Possible solution list
553
tryAlloc nl _ inst 2 =
554
    let all_nodes = getOnline nl
555
        all_pairs = liftM2 (,) all_nodes all_nodes
556
        ok_pairs = filter (\(x, y) -> Node.idx x /= Node.idx y) all_pairs
557
        sols = foldl' (\cstate (p, s) ->
558
                           concatAllocs cstate $ allocateOnPair nl inst p s
559
                      ) ([], 0, []) ok_pairs
560
    in return sols
561

    
562
tryAlloc nl _ inst 1 =
563
    let all_nodes = getOnline nl
564
        sols = foldl' (\cstate ->
565
                           concatAllocs cstate . allocateOnSingle nl inst
566
                      ) ([], 0, []) all_nodes
567
    in return sols
568

    
569
tryAlloc _ _ _ reqn = fail $ "Unsupported number of allocation \
570
                             \destinations required (" ++ show reqn ++
571
                                               "), only two supported"
572

    
573
-- | Try to allocate an instance on the cluster.
574
tryReloc :: (Monad m) =>
575
            Node.List       -- ^ The node list
576
         -> Instance.List   -- ^ The instance list
577
         -> Idx             -- ^ The index of the instance to move
578
         -> Int             -- ^ The number of nodes required
579
         -> [Ndx]           -- ^ Nodes which should not be used
580
         -> m AllocSolution -- ^ Solution list
581
tryReloc nl il xid 1 ex_idx =
582
    let all_nodes = getOnline nl
583
        inst = Container.find xid il
584
        ex_idx' = Instance.pNode inst:ex_idx
585
        valid_nodes = filter (not . flip elem ex_idx' . Node.idx) all_nodes
586
        valid_idxes = map Node.idx valid_nodes
587
        sols1 = foldl' (\cstate x ->
588
                            let em = do
589
                                  (mnl, i, _, _) <-
590
                                      applyMove nl inst (ReplaceSecondary x)
591
                                  return (mnl, i, [Container.find x mnl])
592
                            in concatAllocs cstate em
593
                       ) ([], 0, []) valid_idxes
594
    in return sols1
595

    
596
tryReloc _ _ _ reqn _  = fail $ "Unsupported number of relocation \
597
                                \destinations required (" ++ show reqn ++
598
                                                  "), only one supported"
599

    
600
-- | Try to allocate an instance on the cluster.
601
tryEvac :: (Monad m) =>
602
            Node.List       -- ^ The node list
603
         -> Instance.List   -- ^ The instance list
604
         -> [Ndx]           -- ^ Nodes to be evacuated
605
         -> m AllocSolution -- ^ Solution list
606
tryEvac nl il ex_ndx =
607
    let ex_nodes = map (`Container.find` nl) ex_ndx
608
        all_insts = nub . concatMap Node.sList $ ex_nodes
609
    in do
610
      (_, sol) <- foldM (\(nl', (_, _, rsols)) idx -> do
611
                           -- FIXME: hardcoded one node here
612
                           (fm, cs, aes) <- tryReloc nl' il idx 1 ex_ndx
613
                           case aes of
614
                             csol@(_, (nl'', _, _)):_ ->
615
                                 return (nl'', (fm, cs, csol:rsols))
616
                             _ -> fail $ "Can't evacuate instance " ++
617
                                  show idx
618
                        ) (nl, ([], 0, [])) all_insts
619
      return sol
620

    
621
-- * Formatting functions
622

    
623
-- | Given the original and final nodes, computes the relocation description.
624
computeMoves :: Instance.Instance -- ^ The instance to be moved
625
             -> String -- ^ The instance name
626
             -> IMove  -- ^ The move being performed
627
             -> String -- ^ New primary
628
             -> String -- ^ New secondary
629
             -> (String, [String])
630
                -- ^ Tuple of moves and commands list; moves is containing
631
                -- either @/f/@ for failover or @/r:name/@ for replace
632
                -- secondary, while the command list holds gnt-instance
633
                -- commands (without that prefix), e.g \"@failover instance1@\"
634
computeMoves i inam mv c d =
635
    case mv of
636
      Failover -> ("f", [mig])
637
      FailoverAndReplace _ -> (printf "f r:%s" d, [mig, rep d])
638
      ReplaceSecondary _ -> (printf "r:%s" d, [rep d])
639
      ReplaceAndFailover _ -> (printf "r:%s f" c, [rep c, mig])
640
      ReplacePrimary _ -> (printf "f r:%s f" c, [mig, rep c, mig])
641
    where morf = if Instance.running i then "migrate" else "failover"
642
          mig = printf "%s -f %s" morf inam::String
643
          rep n = printf "replace-disks -n %s %s" n inam
644

    
645
-- | Converts a placement to string format.
646
printSolutionLine :: Node.List     -- ^ The node list
647
                  -> Instance.List -- ^ The instance list
648
                  -> Int           -- ^ Maximum node name length
649
                  -> Int           -- ^ Maximum instance name length
650
                  -> Placement     -- ^ The current placement
651
                  -> Int           -- ^ The index of the placement in
652
                                   -- the solution
653
                  -> (String, [String])
654
printSolutionLine nl il nmlen imlen plc pos =
655
    let
656
        pmlen = (2*nmlen + 1)
657
        (i, p, s, mv, c) = plc
658
        inst = Container.find i il
659
        inam = Instance.name inst
660
        npri = Container.nameOf nl p
661
        nsec = Container.nameOf nl s
662
        opri = Container.nameOf nl $ Instance.pNode inst
663
        osec = Container.nameOf nl $ Instance.sNode inst
664
        (moves, cmds) =  computeMoves inst inam mv npri nsec
665
        ostr = printf "%s:%s" opri osec::String
666
        nstr = printf "%s:%s" npri nsec::String
667
    in
668
      (printf "  %3d. %-*s %-*s => %-*s %.8f a=%s"
669
       pos imlen inam pmlen ostr
670
       pmlen nstr c moves,
671
       cmds)
672

    
673
-- | Return the instance and involved nodes in an instance move.
674
involvedNodes :: Instance.List -> Placement -> [Ndx]
675
involvedNodes il plc =
676
    let (i, np, ns, _, _) = plc
677
        inst = Container.find i il
678
        op = Instance.pNode inst
679
        os = Instance.sNode inst
680
    in nub [np, ns, op, os]
681

    
682
-- | Inner function for splitJobs, that either appends the next job to
683
-- the current jobset, or starts a new jobset.
684
mergeJobs :: ([JobSet], [Ndx]) -> MoveJob -> ([JobSet], [Ndx])
685
mergeJobs ([], _) n@(ndx, _, _, _) = ([[n]], ndx)
686
mergeJobs (cjs@(j:js), nbuf) n@(ndx, _, _, _)
687
    | null (ndx `intersect` nbuf) = ((n:j):js, ndx ++ nbuf)
688
    | otherwise = ([n]:cjs, ndx)
689

    
690
-- | Break a list of moves into independent groups. Note that this
691
-- will reverse the order of jobs.
692
splitJobs :: [MoveJob] -> [JobSet]
693
splitJobs = fst . foldl mergeJobs ([], [])
694

    
695
-- | Given a list of commands, prefix them with @gnt-instance@ and
696
-- also beautify the display a little.
697
formatJob :: Int -> Int -> (Int, MoveJob) -> [String]
698
formatJob jsn jsl (sn, (_, _, _, cmds)) =
699
    let out =
700
            printf "  echo job %d/%d" jsn sn:
701
            printf "  check":
702
            map ("  gnt-instance " ++) cmds
703
    in if sn == 1
704
       then ["", printf "echo jobset %d, %d jobs" jsn jsl] ++ out
705
       else out
706

    
707
-- | Given a list of commands, prefix them with @gnt-instance@ and
708
-- also beautify the display a little.
709
formatCmds :: [JobSet] -> String
710
formatCmds =
711
    unlines .
712
    concatMap (\(jsn, js) -> concatMap (formatJob jsn (length js))
713
                             (zip [1..] js)) .
714
    zip [1..]
715

    
716
-- | Converts a solution to string format.
717
printSolution :: Node.List
718
              -> Instance.List
719
              -> [Placement]
720
              -> ([String], [[String]])
721
printSolution nl il sol =
722
    let
723
        nmlen = Container.maxNameLen nl
724
        imlen = Container.maxNameLen il
725
    in
726
      unzip $ zipWith (printSolutionLine nl il nmlen imlen) sol [1..]
727

    
728
-- | Print the node list.
729
printNodes :: Node.List -> [String] -> String
730
printNodes nl fs =
731
    let fields = if null fs
732
                 then Node.defaultFields
733
                 else fs
734
        snl = sortBy (comparing Node.idx) (Container.elems nl)
735
        (header, isnum) = unzip $ map Node.showHeader fields
736
    in unlines . map ((:) ' ' .  intercalate " ") $
737
       formatTable (header:map (Node.list fields) snl) isnum
738

    
739
-- | Print the instance list.
740
printInsts :: Node.List -> Instance.List -> String
741
printInsts nl il =
742
    let sil = sortBy (comparing Instance.idx) (Container.elems il)
743
        helper inst = [ if Instance.running inst then "R" else " "
744
                      , Instance.name inst
745
                      , Container.nameOf nl (Instance.pNode inst)
746
                      , let sdx = Instance.sNode inst
747
                        in if sdx == Node.noSecondary
748
                           then  ""
749
                           else Container.nameOf nl sdx
750
                      , printf "%3d" $ Instance.vcpus inst
751
                      , printf "%5d" $ Instance.mem inst
752
                      , printf "%5d" $ Instance.dsk inst `div` 1024
753
                      , printf "%5.3f" lC
754
                      , printf "%5.3f" lM
755
                      , printf "%5.3f" lD
756
                      , printf "%5.3f" lN
757
                      ]
758
            where DynUtil lC lM lD lN = Instance.util inst
759
        header = [ "F", "Name", "Pri_node", "Sec_node", "vcpu", "mem"
760
                 , "dsk", "lCpu", "lMem", "lDsk", "lNet" ]
761
        isnum = False:False:False:False:repeat True
762
    in unlines . map ((:) ' ' . intercalate " ") $
763
       formatTable (header:map helper sil) isnum
764

    
765
-- | Shows statistics for a given node list.
766
printStats :: Node.List -> String
767
printStats nl =
768
    let dcvs = compDetailedCV nl
769
        hd = zip (detailedCVNames ++ repeat "unknown") dcvs
770
        formatted = map (\(header, val) ->
771
                             printf "%s=%.8f" header val::String) hd
772
    in intercalate ", " formatted
773

    
774
-- | Convert a placement into a list of OpCodes (basically a job).
775
iMoveToJob :: String -> Node.List -> Instance.List
776
          -> Idx -> IMove -> [OpCodes.OpCode]
777
iMoveToJob csf nl il idx move =
778
    let inst = Container.find idx il
779
        iname = Instance.name inst ++ csf
780
        lookNode n = Just (Container.nameOf nl n ++ csf)
781
        opF = if Instance.running inst
782
              then OpCodes.OpMigrateInstance iname True False
783
              else OpCodes.OpFailoverInstance iname False
784
        opR n = OpCodes.OpReplaceDisks iname (lookNode n)
785
                OpCodes.ReplaceNewSecondary [] Nothing
786
    in case move of
787
         Failover -> [ opF ]
788
         ReplacePrimary np -> [ opF, opR np, opF ]
789
         ReplaceSecondary ns -> [ opR ns ]
790
         ReplaceAndFailover np -> [ opR np, opF ]
791
         FailoverAndReplace ns -> [ opF, opR ns ]