Statistics
| Branch: | Tag: | Revision:

root / Ganeti / HTools / Cluster.hs @ 00b15752

History | View | Annotate | Download (30.4 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
module Ganeti.HTools.Cluster
9
    (
10
     -- * Types
11
     NodeList
12
    , InstanceList
13
    , NameList
14
    , Placement
15
    , Solution(..)
16
    , Table(..)
17
    , Removal
18
    , Score
19
    -- * Generic functions
20
    , totalResources
21
    -- * First phase functions
22
    , computeBadItems
23
    -- * Second phase functions
24
    , computeSolution
25
    , applySolution
26
    , printSolution
27
    , printSolutionLine
28
    , formatCmds
29
    , printNodes
30
    -- * Balacing functions
31
    , checkMove
32
    , compCV
33
    , printStats
34
    -- * Loading functions
35
    , loadData
36
    , checkData
37
    ) where
38

    
39
import Data.List
40
import Data.Maybe (isNothing, fromJust)
41
import Text.Printf (printf)
42
import Data.Function
43

    
44
import qualified Ganeti.HTools.Container as Container
45
import qualified Ganeti.HTools.Instance as Instance
46
import qualified Ganeti.HTools.Node as Node
47
import Ganeti.HTools.Utils
48

    
49
type NodeList = Container.Container Node.Node
50
type InstanceList = Container.Container Instance.Instance
51
-- | The type used to hold idx-to-name mappings
52
type NameList = [(Int, String)]
53
-- | A separate name for the cluster score type
54
type Score = Double
55

    
56
-- | The description of an instance placement.
57
type Placement = (Int, Int, Int, Score)
58

    
59
{- | A cluster solution described as the solution delta and the list
60
of placements.
61

    
62
-}
63
data Solution = Solution Int [Placement]
64
                deriving (Eq, Ord, Show)
65

    
66
-- | Returns the delta of a solution or -1 for Nothing
67
solutionDelta :: Maybe Solution -> Int
68
solutionDelta sol = case sol of
69
                      Just (Solution d _) -> d
70
                      _ -> -1
71

    
72
-- | A removal set.
73
data Removal = Removal NodeList [Instance.Instance]
74

    
75
-- | An instance move definition
76
data IMove = Failover                -- ^ Failover the instance (f)
77
           | ReplacePrimary Int      -- ^ Replace primary (f, r:np, f)
78
           | ReplaceSecondary Int    -- ^ Replace secondary (r:ns)
79
           | ReplaceAndFailover Int  -- ^ Replace secondary, failover (r:np, f)
80
           | FailoverAndReplace Int  -- ^ Failover, replace secondary (f, r:ns)
81
             deriving (Show)
82

    
83
-- | The complete state for the balancing solution
84
data Table = Table NodeList InstanceList Score [Placement]
85
             deriving (Show)
86

    
87
-- General functions
88

    
89
-- | Cap the removal list if needed.
90
capRemovals :: [a] -> Int -> [a]
91
capRemovals removals max_removals =
92
    if max_removals > 0 then
93
        take max_removals removals
94
    else
95
        removals
96

    
97
-- | Check if the given node list fails the N+1 check.
98
verifyN1Check :: [Node.Node] -> Bool
99
verifyN1Check nl = any Node.failN1 nl
100

    
101
-- | Verifies the N+1 status and return the affected nodes.
102
verifyN1 :: [Node.Node] -> [Node.Node]
103
verifyN1 nl = filter Node.failN1 nl
104

    
105
{-| Add an instance and return the new node and instance maps. -}
106
addInstance :: NodeList -> Instance.Instance ->
107
               Node.Node -> Node.Node -> Maybe NodeList
108
addInstance nl idata pri sec =
109
  let pdx = Node.idx pri
110
      sdx = Node.idx sec
111
  in do
112
      pnode <- Node.addPri pri idata
113
      snode <- Node.addSec sec idata pdx
114
      new_nl <- return $ Container.addTwo sdx snode
115
                         pdx pnode nl
116
      return new_nl
117

    
118
-- | Remove an instance and return the new node and instance maps.
119
removeInstance :: NodeList -> Instance.Instance -> NodeList
120
removeInstance nl idata =
121
  let pnode = Instance.pnode idata
122
      snode = Instance.snode idata
123
      pn = Container.find pnode nl
124
      sn = Container.find snode nl
125
      new_nl = Container.addTwo
126
               pnode (Node.removePri pn idata)
127
               snode (Node.removeSec sn idata) nl in
128
  new_nl
129

    
130
-- | Remove an instance and return the new node map.
131
removeInstances :: NodeList -> [Instance.Instance] -> NodeList
132
removeInstances = foldl' removeInstance
133

    
134
-- | Compute the total free disk and memory in the cluster.
135
totalResources :: Container.Container Node.Node -> (Int, Int)
136
totalResources nl =
137
    foldl'
138
    (\ (mem, dsk) node -> (mem + (Node.f_mem node),
139
                           dsk + (Node.f_dsk node)))
140
    (0, 0) (Container.elems nl)
141

    
142
{- | Compute a new version of a cluster given a solution.
143

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

    
147
It first removes the relocated instances after which it places them on
148
their new nodes.
149

    
150
 -}
151
applySolution :: NodeList -> InstanceList -> [Placement] -> NodeList
152
applySolution nl il sol =
153
    let odxes = map (\ (a, b, c, _) -> (Container.find a il,
154
                                        Node.idx (Container.find b nl),
155
                                        Node.idx (Container.find c nl))
156
                    ) sol
157
        idxes = (\ (x, _, _) -> x) (unzip3 odxes)
158
        nc = removeInstances nl idxes
159
    in
160
      foldl' (\ nz (a, b, c) ->
161
                 let new_p = Container.find b nz
162
                     new_s = Container.find c nz in
163
                 fromJust (addInstance nz a new_p new_s)
164
           ) nc odxes
165

    
166

    
167
-- First phase functions
168

    
169
{- | Given a list 1,2,3..n build a list of pairs [(1, [2..n]), (2,
170
    [3..n]), ...]
171

    
172
-}
173
genParts :: [a] -> Int -> [(a, [a])]
174
genParts l count =
175
    case l of
176
      [] -> []
177
      x:xs ->
178
          if length l < count then
179
              []
180
          else
181
              (x, xs) : (genParts xs count)
182

    
183
-- | Generates combinations of count items from the names list.
184
genNames :: Int -> [b] -> [[b]]
185
genNames count1 names1 =
186
  let aux_fn count names current =
187
          case count of
188
            0 -> [current]
189
            _ ->
190
                concatMap
191
                (\ (x, xs) -> aux_fn (count - 1) xs (x:current))
192
                (genParts names count)
193
  in
194
    aux_fn count1 names1 []
195

    
196
{- | Computes the pair of bad nodes and instances.
197

    
198
The bad node list is computed via a simple 'verifyN1' check, and the
199
bad instance list is the list of primary and secondary instances of
200
those nodes.
201

    
202
-}
203
computeBadItems :: NodeList -> InstanceList ->
204
                   ([Node.Node], [Instance.Instance])
205
computeBadItems nl il =
206
  let bad_nodes = verifyN1 $ Container.elems nl
207
      bad_instances = map (\idx -> Container.find idx il) $
208
                      sort $ nub $ concat $
209
                      map (\ n -> (Node.slist n) ++ (Node.plist n)) bad_nodes
210
  in
211
    (bad_nodes, bad_instances)
212

    
213

    
214
{- | Checks if removal of instances results in N+1 pass.
215

    
216
Note: the check removal cannot optimize by scanning only the affected
217
nodes, since the cluster is known to be not healthy; only the check
218
placement can make this shortcut.
219

    
220
-}
221
checkRemoval :: NodeList -> [Instance.Instance] -> Maybe Removal
222
checkRemoval nl victims =
223
  let nx = removeInstances nl victims
224
      failN1 = verifyN1Check (Container.elems nx)
225
  in
226
    if failN1 then
227
      Nothing
228
    else
229
      Just $ Removal nx victims
230

    
231

    
232
-- | Computes the removals list for a given depth
233
computeRemovals :: NodeList
234
                 -> [Instance.Instance]
235
                 -> Int
236
                 -> [Maybe Removal]
237
computeRemovals nl bad_instances depth =
238
    map (checkRemoval nl) $ genNames depth bad_instances
239

    
240
-- Second phase functions
241

    
242
-- | Single-node relocation cost
243
nodeDelta :: Int -> Int -> Int -> Int
244
nodeDelta i p s =
245
    if i == p || i == s then
246
        0
247
    else
248
        1
249

    
250
{-| Compute best solution.
251

    
252
    This function compares two solutions, choosing the minimum valid
253
    solution.
254
-}
255
compareSolutions :: Maybe Solution -> Maybe Solution -> Maybe Solution
256
compareSolutions a b = case (a, b) of
257
  (Nothing, x) -> x
258
  (x, Nothing) -> x
259
  (x, y) -> min x y
260

    
261
-- | Compute best table. Note that the ordering of the arguments is important.
262
compareTables :: Table -> Table -> Table
263
compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) =
264
    if a_cv > b_cv then b else a
265

    
266
-- | Check if a given delta is worse then an existing solution.
267
tooHighDelta :: Maybe Solution -> Int -> Int -> Bool
268
tooHighDelta sol new_delta max_delta =
269
    if new_delta > max_delta && max_delta >=0 then
270
        True
271
    else
272
        case sol of
273
          Nothing -> False
274
          Just (Solution old_delta _) -> old_delta <= new_delta
275

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

    
278
    This is the workhorse of the allocation algorithm: given the
279
    current node and instance maps, the list of instances to be
280
    placed, and the current solution, this will return all possible
281
    solution by recursing until all target instances are placed.
282

    
283
-}
284
checkPlacement :: NodeList            -- ^ The current node list
285
               -> [Instance.Instance] -- ^ List of instances still to place
286
               -> [Placement]         -- ^ Partial solution until now
287
               -> Int                 -- ^ The delta of the partial solution
288
               -> Maybe Solution      -- ^ The previous solution
289
               -> Int                 -- ^ Abort if the we go above this delta
290
               -> Maybe Solution      -- ^ The new solution
291
checkPlacement nl victims current current_delta prev_sol max_delta =
292
  let target = head victims
293
      opdx = Instance.pnode target
294
      osdx = Instance.snode target
295
      vtail = tail victims
296
      have_tail = (length vtail) > 0
297
      nodes = Container.elems nl
298
      iidx = Instance.idx target
299
  in
300
    foldl'
301
    (\ accu_p pri ->
302
         let
303
             pri_idx = Node.idx pri
304
             upri_delta = current_delta + nodeDelta pri_idx opdx osdx
305
             new_pri = Node.addPri pri target
306
             fail_delta1 = tooHighDelta accu_p upri_delta max_delta
307
         in
308
           if fail_delta1 || isNothing(new_pri) then accu_p
309
           else let pri_nl = Container.add pri_idx (fromJust new_pri) nl in
310
                foldl'
311
                (\ accu sec ->
312
                     let
313
                         sec_idx = Node.idx sec
314
                         upd_delta = upri_delta +
315
                                     nodeDelta sec_idx opdx osdx
316
                         fail_delta2 = tooHighDelta accu upd_delta max_delta
317
                         new_sec = Node.addSec sec target pri_idx
318
                     in
319
                       if sec_idx == pri_idx || fail_delta2 ||
320
                          isNothing new_sec then accu
321
                       else let
322
                           nx = Container.add sec_idx (fromJust new_sec) pri_nl
323
                           upd_cv = compCV nx
324
                           plc = (iidx, pri_idx, sec_idx, upd_cv)
325
                           c2 = plc:current
326
                           result =
327
                               if have_tail then
328
                                   checkPlacement nx vtail c2 upd_delta
329
                                                  accu max_delta
330
                               else
331
                                   Just (Solution upd_delta c2)
332
                      in compareSolutions accu result
333
                ) accu_p nodes
334
    ) prev_sol nodes
335

    
336
-- | Apply a move
337
applyMove :: NodeList -> Instance.Instance
338
          -> IMove -> (Maybe NodeList, Instance.Instance, Int, Int)
339
-- Failover (f)
340
applyMove nl inst Failover =
341
    let old_pdx = Instance.pnode inst
342
        old_sdx = Instance.snode inst
343
        old_p = Container.find old_pdx nl
344
        old_s = Container.find old_sdx nl
345
        int_p = Node.removePri old_p inst
346
        int_s = Node.removeSec old_s inst
347
        new_nl = do -- Maybe monad
348
          new_p <- Node.addPri int_s inst
349
          new_s <- Node.addSec int_p inst old_sdx
350
          return $ Container.addTwo old_pdx new_s old_sdx new_p nl
351
    in (new_nl, Instance.setBoth inst old_sdx old_pdx, old_sdx, old_pdx)
352

    
353
-- Replace the primary (f:, r:np, f)
354
applyMove nl inst (ReplacePrimary new_pdx) =
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_pdx 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 tgt_n inst
364
          new_s <- Node.addSec int_s inst new_pdx
365
          return $ Container.add new_pdx new_p $
366
                 Container.addTwo old_pdx int_p old_sdx new_s nl
367
    in (new_nl, Instance.setPri inst new_pdx, new_pdx, old_sdx)
368

    
369
-- Replace the secondary (r:ns)
370
applyMove nl inst (ReplaceSecondary new_sdx) =
371
    let old_pdx = Instance.pnode inst
372
        old_sdx = Instance.snode inst
373
        old_s = Container.find old_sdx nl
374
        tgt_n = Container.find new_sdx nl
375
        int_s = Node.removeSec old_s inst
376
        new_nl = Node.addSec tgt_n inst old_pdx >>=
377
                 \new_s -> return $ Container.addTwo new_sdx
378
                           new_s old_sdx int_s nl
379
    in (new_nl, Instance.setSec inst new_sdx, old_pdx, new_sdx)
380

    
381
-- Replace the secondary and failover (r:np, f)
382
applyMove nl inst (ReplaceAndFailover new_pdx) =
383
    let old_pdx = Instance.pnode inst
384
        old_sdx = Instance.snode inst
385
        old_p = Container.find old_pdx nl
386
        old_s = Container.find old_sdx nl
387
        tgt_n = Container.find new_pdx nl
388
        int_p = Node.removePri old_p inst
389
        int_s = Node.removeSec old_s inst
390
        new_nl = do -- Maybe monad
391
          new_p <- Node.addPri tgt_n inst
392
          new_s <- Node.addSec int_p inst new_pdx
393
          return $ Container.add new_pdx new_p $
394
                 Container.addTwo old_pdx new_s old_sdx int_s nl
395
    in (new_nl, Instance.setBoth inst new_pdx old_pdx, new_pdx, old_pdx)
396

    
397
-- Failver and replace the secondary (f, r:ns)
398
applyMove nl inst (FailoverAndReplace new_sdx) =
399
    let old_pdx = Instance.pnode inst
400
        old_sdx = Instance.snode inst
401
        old_p = Container.find old_pdx nl
402
        old_s = Container.find old_sdx nl
403
        tgt_n = Container.find new_sdx nl
404
        int_p = Node.removePri old_p inst
405
        int_s = Node.removeSec old_s inst
406
        new_nl = do -- Maybe monad
407
          new_p <- Node.addPri int_s inst
408
          new_s <- Node.addSec tgt_n inst old_sdx
409
          return $ Container.add new_sdx new_s $
410
                 Container.addTwo old_sdx new_p old_pdx int_p nl
411
    in (new_nl, Instance.setBoth inst old_sdx new_sdx, old_sdx, new_sdx)
412

    
413
checkSingleStep :: Table -- ^ The original table
414
                -> Instance.Instance -- ^ The instance to move
415
                -> Table -- ^ The current best table
416
                -> IMove -- ^ The move to apply
417
                -> Table -- ^ The final best table
418
checkSingleStep ini_tbl target cur_tbl move =
419
    let
420
        Table ini_nl ini_il _ ini_plc = ini_tbl
421
        (tmp_nl, new_inst, pri_idx, sec_idx) = applyMove ini_nl target move
422
    in
423
      if isNothing tmp_nl then cur_tbl
424
      else
425
          let tgt_idx = Instance.idx target
426
              upd_nl = fromJust tmp_nl
427
              upd_cvar = compCV upd_nl
428
              upd_il = Container.add tgt_idx new_inst ini_il
429
              upd_plc = (tgt_idx, pri_idx, sec_idx, upd_cvar):ini_plc
430
              upd_tbl = Table upd_nl upd_il upd_cvar upd_plc
431
          in
432
            compareTables cur_tbl upd_tbl
433

    
434
-- | Given the status of the current secondary as a valid new node
435
-- and the current candidate target node,
436
-- generate the possible moves for a instance.
437
possibleMoves :: Bool -> Int -> [IMove]
438
possibleMoves True tdx =
439
    [ReplaceSecondary tdx,
440
     ReplaceAndFailover tdx,
441
     ReplacePrimary tdx,
442
     FailoverAndReplace tdx]
443

    
444
possibleMoves False tdx =
445
    [ReplaceSecondary tdx,
446
     ReplaceAndFailover tdx]
447

    
448
-- | Compute the best move for a given instance.
449
checkInstanceMove :: [Int]             -- Allowed target node indices
450
                  -> Table             -- Original table
451
                  -> Instance.Instance -- Instance to move
452
                  -> Table             -- Best new table for this instance
453
checkInstanceMove nodes_idx ini_tbl target =
454
    let
455
        opdx = Instance.pnode target
456
        osdx = Instance.snode target
457
        nodes = filter (\idx -> idx /= opdx && idx /= osdx) nodes_idx
458
        use_secondary = elem osdx nodes_idx
459
        aft_failover = if use_secondary -- if allowed to failover
460
                       then checkSingleStep ini_tbl target ini_tbl Failover
461
                       else ini_tbl
462
        all_moves = concatMap (possibleMoves use_secondary) nodes
463
    in
464
      -- iterate over the possible nodes for this instance
465
      foldl' (checkSingleStep ini_tbl target) aft_failover all_moves
466

    
467
-- | Compute the best next move.
468
checkMove :: [Int]               -- ^ Allowed target node indices
469
          -> Table               -- ^ The current solution
470
          -> [Instance.Instance] -- ^ List of instances still to move
471
          -> Table               -- ^ The new solution
472
checkMove nodes_idx ini_tbl victims =
473
    let Table _ _ _ ini_plc = ini_tbl
474
        -- iterate over all instances, computing the best move
475
        best_tbl =
476
            foldl'
477
            (\ step_tbl elem -> compareTables step_tbl $
478
                                checkInstanceMove nodes_idx ini_tbl elem)
479
            ini_tbl victims
480
        Table _ _ _ best_plc = best_tbl
481
    in
482
      if length best_plc == length ini_plc then -- no advancement
483
          ini_tbl
484
      else
485
          best_tbl
486

    
487
{- | Auxiliary function for solution computation.
488

    
489
We write this in an explicit recursive fashion in order to control
490
early-abort in case we have met the min delta. We can't use foldr
491
instead of explicit recursion since we need the accumulator for the
492
abort decision.
493

    
494
-}
495
advanceSolution :: [Maybe Removal] -- ^ The removal to process
496
                -> Int             -- ^ Minimum delta parameter
497
                -> Int             -- ^ Maximum delta parameter
498
                -> Maybe Solution  -- ^ Current best solution
499
                -> Maybe Solution  -- ^ New best solution
500
advanceSolution [] _ _ sol = sol
501
advanceSolution (Nothing:xs) m n sol = advanceSolution xs m n sol
502
advanceSolution ((Just (Removal nx removed)):xs) min_d max_d prev_sol =
503
    let new_sol = checkPlacement nx removed [] 0 prev_sol max_d
504
        new_delta = solutionDelta $! new_sol
505
    in
506
      if new_delta >= 0 && new_delta <= min_d then
507
          new_sol
508
      else
509
          advanceSolution xs min_d max_d new_sol
510

    
511
-- | Computes the placement solution.
512
solutionFromRemovals :: [Maybe Removal] -- ^ The list of (possible) removals
513
                     -> Int             -- ^ Minimum delta parameter
514
                     -> Int             -- ^ Maximum delta parameter
515
                     -> Maybe Solution  -- ^ The best solution found
516
solutionFromRemovals removals min_delta max_delta =
517
    advanceSolution removals min_delta max_delta Nothing
518

    
519
{- | Computes the solution at the given depth.
520

    
521
This is a wrapper over both computeRemovals and
522
solutionFromRemovals. In case we have no solution, we return Nothing.
523

    
524
-}
525
computeSolution :: NodeList        -- ^ The original node data
526
                -> [Instance.Instance] -- ^ The list of /bad/ instances
527
                -> Int             -- ^ The /depth/ of removals
528
                -> Int             -- ^ Maximum number of removals to process
529
                -> Int             -- ^ Minimum delta parameter
530
                -> Int             -- ^ Maximum delta parameter
531
                -> Maybe Solution  -- ^ The best solution found (or Nothing)
532
computeSolution nl bad_instances depth max_removals min_delta max_delta =
533
  let
534
      removals = computeRemovals nl bad_instances depth
535
      removals' = capRemovals removals max_removals
536
  in
537
    solutionFromRemovals removals' min_delta max_delta
538

    
539
-- Solution display functions (pure)
540

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

    
579
                else {- Nothing in common -}
580
                    (printf "r:%s f r:%s" c d,
581
                     [printf "replace-disks -n %s %s" c i,
582
                      printf "migrate -f %s" i,
583
                      printf "replace-disks -n %s %s" d i])
584

    
585
{-| Converts a placement to string format -}
586
printSolutionLine :: InstanceList
587
              -> NameList
588
              -> NameList
589
              -> Int
590
              -> Int
591
              -> Placement
592
              -> Int
593
              -> (String, [String])
594
printSolutionLine il ktn kti nmlen imlen plc pos =
595
    let
596
        pmlen = (2*nmlen + 1)
597
        (i, p, s, c) = plc
598
        inst = Container.find i il
599
        inam = fromJust $ lookup (Instance.idx inst) kti
600
        npri = fromJust $ lookup p ktn
601
        nsec = fromJust $ lookup s ktn
602
        opri = fromJust $ lookup (Instance.pnode inst) ktn
603
        osec = fromJust $ lookup (Instance.snode inst) ktn
604
        (moves, cmds) =  computeMoves inam opri osec npri nsec
605
        ostr = (printf "%s:%s" opri osec)::String
606
        nstr = (printf "%s:%s" npri nsec)::String
607
    in
608
      (printf "  %3d. %-*s %-*s => %-*s %.8f a=%s"
609
       pos imlen inam pmlen ostr
610
       pmlen nstr c moves,
611
       cmds)
612

    
613
formatCmds :: [[String]] -> String
614
formatCmds cmd_strs =
615
    unlines $
616
    concat $ map (\(a, b) ->
617
        (printf "echo step %d" (a::Int)):
618
        (printf "check"):
619
        (map ("gnt-instance " ++) b)) $
620
        zip [1..] cmd_strs
621

    
622
{-| Converts a solution to string format -}
623
printSolution :: InstanceList
624
              -> NameList
625
              -> NameList
626
              -> [Placement]
627
              -> ([String], [[String]])
628
printSolution il ktn kti sol =
629
    let
630
        mlen_fn = maximum . (map length) . snd . unzip
631
        imlen = mlen_fn kti
632
        nmlen = mlen_fn ktn
633
    in
634
      unzip $ map (uncurry $ printSolutionLine il ktn kti nmlen imlen) $
635
            zip sol [1..]
636

    
637
-- | Print the node list.
638
printNodes :: NameList -> NodeList -> String
639
printNodes ktn nl =
640
    let snl = sortBy (compare `on` Node.idx) (Container.elems nl)
641
        snl' = map (\ n -> ((fromJust $ lookup (Node.idx n) ktn), n)) snl
642
        m_name = maximum . (map length) . fst . unzip $ snl'
643
        helper = Node.list m_name
644
        header = printf
645
                 "%2s %-*s %5s %5s %5s %5s %5s %5s %5s %5s %3s %3s %7s %7s"
646
                 " F" m_name "Name"
647
                 "t_mem" "n_mem" "i_mem" "x_mem" "f_mem" "r_mem"
648
                 "t_dsk" "f_dsk"
649
                 "pri" "sec" "p_fmem" "p_fdsk"
650
    in unlines $ (header:map (uncurry helper) snl')
651

    
652
-- | Compute the mem and disk covariance.
653
compDetailedCV :: NodeList -> (Double, Double, Double, Double, Double)
654
compDetailedCV nl =
655
    let
656
        all_nodes = Container.elems nl
657
        (offline, nodes) = partition Node.offline all_nodes
658
        mem_l = map Node.p_mem nodes
659
        dsk_l = map Node.p_dsk nodes
660
        mem_cv = varianceCoeff mem_l
661
        dsk_cv = varianceCoeff dsk_l
662
        n1_l = length $ filter Node.failN1 nodes
663
        n1_score = (fromIntegral n1_l) / (fromIntegral $ length nodes)
664
        res_l = map Node.p_rem nodes
665
        res_cv = varianceCoeff res_l
666
        offline_inst = sum . map (\n -> (length . Node.plist $ n) +
667
                                        (length . Node.slist $ n)) $ offline
668
        online_inst = sum . map (\n -> (length . Node.plist $ n) +
669
                                       (length . Node.slist $ n)) $ nodes
670
        off_score = (fromIntegral offline_inst) /
671
                    (fromIntegral $ online_inst + offline_inst)
672
    in (mem_cv, dsk_cv, n1_score, res_cv, off_score)
673

    
674
-- | Compute the 'total' variance.
675
compCV :: NodeList -> Double
676
compCV nl =
677
    let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl
678
    in mem_cv + dsk_cv + n1_score + res_cv + off_score
679

    
680
printStats :: NodeList -> String
681
printStats nl =
682
    let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl
683
    in printf "f_mem=%.8f, r_mem=%.8f, f_dsk=%.8f, n1=%.3f, uf=%.3f"
684
       mem_cv res_cv dsk_cv n1_score off_score
685

    
686
-- Balancing functions
687

    
688
-- Loading functions
689

    
690
{- | Convert newline and delimiter-separated text.
691

    
692
This function converts a text in tabular format as generated by
693
@gnt-instance list@ and @gnt-node list@ to a list of objects using a
694
supplied conversion function.
695

    
696
-}
697
loadTabular :: String -> ([String] -> (String, a))
698
            -> (a -> Int -> a) -> ([(String, Int)], [(Int, a)])
699
loadTabular text_data convert_fn set_fn =
700
    let lines_data = lines text_data
701
        rows = map (sepSplit '|') lines_data
702
        kerows = (map convert_fn rows)
703
        idxrows = map (\ (idx, (k, v)) -> ((k, idx), (idx, set_fn v idx)))
704
                  (zip [0..] kerows)
705
    in unzip idxrows
706

    
707
-- | For each instance, add its index to its primary and secondary nodes
708
fixNodes :: [(Int, Node.Node)]
709
         -> [(Int, Instance.Instance)]
710
         -> [(Int, Node.Node)]
711
fixNodes nl il =
712
    foldl' (\accu (idx, inst) ->
713
                let
714
                    assocEqual = (\ (i, _) (j, _) -> i == j)
715
                    pdx = Instance.pnode inst
716
                    sdx = Instance.snode inst
717
                    pold = fromJust $ lookup pdx accu
718
                    sold = fromJust $ lookup sdx accu
719
                    pnew = Node.setPri pold idx
720
                    snew = Node.setSec sold idx
721
                    ac1 = deleteBy assocEqual (pdx, pold) accu
722
                    ac2 = deleteBy assocEqual (sdx, sold) ac1
723
                    ac3 = (pdx, pnew):(sdx, snew):ac2
724
                in ac3) nl il
725

    
726
-- | Compute the longest common suffix of a NameList list that
727
-- | starts with a dot
728
longestDomain :: NameList -> String
729
longestDomain [] = ""
730
longestDomain ((_,x):xs) =
731
    let
732
        onlyStrings = snd $ unzip xs
733
    in
734
      foldr (\ suffix accu -> if all (isSuffixOf suffix) onlyStrings
735
                              then suffix
736
                              else accu)
737
      "" $ filter (isPrefixOf ".") (tails x)
738

    
739
-- | Remove tails from the (Int, String) lists
740
stripSuffix :: String -> NameList -> NameList
741
stripSuffix suffix lst =
742
    let sflen = length suffix in
743
    map (\ (key, name) -> (key, take ((length name) - sflen) name)) lst
744

    
745
{-| Initializer function that loads the data from a node and list file
746
    and massages it into the correct format. -}
747
loadData :: String -- ^ Node data in text format
748
         -> String -- ^ Instance data in text format
749
         -> (Container.Container Node.Node,
750
             Container.Container Instance.Instance,
751
             String, NameList, NameList)
752
loadData ndata idata =
753
    let
754
    {- node file: name t_mem n_mem f_mem t_disk f_disk -}
755
        (ktn, nl) = loadTabular ndata
756
                    (\ (name:tm:nm:fm:td:fd:fo:[]) ->
757
                         (name,
758
                          if any (== "?") [tm,nm,fm,td,fd] || fo == "Y" then
759
                              Node.create 0 0 0 0 0 True
760
                          else
761
                              Node.create (read tm) (read nm) (read fm)
762
                                      (read td) (read fd) False
763
                         ))
764
                    Node.setIdx
765
    {- instance file: name mem disk status pnode snode -}
766
        (kti, il) = loadTabular idata
767
                    (\ (name:mem:dsk:status:pnode:snode:[]) ->
768
                         (name,
769
                          Instance.create (read mem) (read dsk)
770
                              status
771
                              (fromJust $ lookup pnode ktn)
772
                              (fromJust $ lookup snode ktn)))
773
                    Instance.setIdx
774
        nl2 = fixNodes nl il
775
        il3 = Container.fromAssocList il
776
        nl3 = Container.fromAssocList
777
             (map (\ (k, v) -> (k, Node.buildPeers v il3 (length nl2))) nl2)
778
        xtn = swapPairs ktn
779
        xti = swapPairs kti
780
        common_suffix = longestDomain (xti ++ xtn)
781
        stn = stripSuffix common_suffix xtn
782
        sti = stripSuffix common_suffix xti
783
    in
784
      (nl3, il3, common_suffix, stn, sti)
785

    
786
-- | Compute the amount of memory used by primary instances on a node.
787
nodeImem :: Node.Node -> InstanceList -> Int
788
nodeImem node il =
789
    let rfind = flip Container.find $ il
790
    in sum . map Instance.mem .
791
       map rfind $ Node.plist node
792

    
793
-- | Compute the amount of disk used by instances on a node (either primary
794
-- or secondary).
795
nodeIdsk :: Node.Node -> InstanceList -> Int
796
nodeIdsk node il =
797
    let rfind = flip Container.find $ il
798
    in sum . map Instance.dsk .
799
       map rfind $ (Node.plist node) ++ (Node.slist node)
800

    
801

    
802
-- | Check cluster data for consistency
803
checkData :: NodeList -> InstanceList -> NameList -> NameList
804
          -> ([String], NodeList)
805
checkData nl il ktn _ =
806
    Container.mapAccum
807
        (\ msgs node ->
808
             let nname = fromJust $ lookup (Node.idx node) ktn
809
                 nilst = map (flip Container.find $ il) (Node.plist node)
810
                 dilst = filter (not . Instance.running) nilst
811
                 adj_mem = sum . map Instance.mem $ dilst
812
                 delta_mem = (truncate $ Node.t_mem node)
813
                             - (Node.n_mem node)
814
                             - (Node.f_mem node)
815
                             - (nodeImem node il)
816
                             + adj_mem
817
                 delta_dsk = (truncate $ Node.t_dsk node)
818
                             - (Node.f_dsk node)
819
                             - (nodeIdsk node il)
820
                 newn = Node.setFmem (Node.setXmem node delta_mem)
821
                        (Node.f_mem node - adj_mem)
822
                 umsg1 = if delta_mem > 512 || delta_dsk > 1024
823
                         then [printf "node %s is missing %d MB ram \
824
                                     \and %d GB disk"
825
                                     nname delta_mem (delta_dsk `div` 1024)]
826
                         else []
827
             in (msgs ++ umsg1, newn)
828
        ) [] nl