Cluster.hs 39.3 KB
Newer Older
Iustin Pop's avatar
Iustin Pop committed
1
2
3
{-| Implementation of cluster-wide logic.

This module holds all pure cluster-logic; I\/O related functionality
Iustin Pop's avatar
Iustin Pop committed
4
goes into the "Main" module for the individual binaries.
Iustin Pop's avatar
Iustin Pop committed
5
6
7

-}

Iustin Pop's avatar
Iustin Pop committed
8
9
{-

10
Copyright (C) 2009, 2010 Google Inc.
Iustin Pop's avatar
Iustin Pop committed
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28

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

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

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

-}

29
module Ganeti.HTools.Cluster
Iustin Pop's avatar
Iustin Pop committed
30
31
    (
     -- * Types
32
      AllocSolution(..)
Iustin Pop's avatar
Iustin Pop committed
33
    , Table(..)
34
    , CStats(..)
35
    , AllocStats
Iustin Pop's avatar
Iustin Pop committed
36
37
    -- * Generic functions
    , totalResources
38
    , computeAllocationDelta
Iustin Pop's avatar
Iustin Pop committed
39
40
41
    -- * First phase functions
    , computeBadItems
    -- * Second phase functions
42
    , printSolutionLine
43
    , formatCmds
44
45
    , involvedNodes
    , splitJobs
46
47
48
    -- * Display functions
    , printNodes
    , printInsts
Iustin Pop's avatar
Iustin Pop committed
49
50
    -- * Balacing functions
    , checkMove
51
    , doNextBalance
52
    , tryBalance
Iustin Pop's avatar
Iustin Pop committed
53
54
    , compCV
    , printStats
55
    , iMoveToJob
56
    -- * IAllocator functions
57
    , tryAlloc
58
    , tryMGAlloc
59
    , tryReloc
Iustin Pop's avatar
Iustin Pop committed
60
    , tryEvac
61
    , collapseFailures
62
63
64
    -- * Allocation functions
    , iterateAlloc
    , tieredAlloc
65
66
    , instanceGroup
    , findSplitInstances
67
    , splitCluster
Iustin Pop's avatar
Iustin Pop committed
68
69
70
    ) where

import Data.List
71
import Data.Ord (comparing)
Iustin Pop's avatar
Iustin Pop committed
72
import Text.Printf (printf)
73
import Control.Monad
Iustin Pop's avatar
Iustin Pop committed
74

75
76
77
import qualified Ganeti.HTools.Container as Container
import qualified Ganeti.HTools.Instance as Instance
import qualified Ganeti.HTools.Node as Node
Iustin Pop's avatar
Iustin Pop committed
78
import Ganeti.HTools.Types
79
import Ganeti.HTools.Utils
80
import qualified Ganeti.OpCodes as OpCodes
Iustin Pop's avatar
Iustin Pop committed
81

Iustin Pop's avatar
Iustin Pop committed
82
83
-- * Types

Iustin Pop's avatar
Iustin Pop committed
84
-- | Allocation\/relocation solution.
85
86
87
88
89
90
data AllocSolution = AllocSolution
  { asFailures  :: [FailMode]          -- ^ Failure counts
  , asAllocs    :: Int                 -- ^ Good allocation count
  , asSolutions :: [Node.AllocElement] -- ^ The actual result, length
                                       -- of the list depends on the
                                       -- allocation/relocation mode
91
  , asLog       :: [String]            -- ^ A list of informational messages
92
93
94
95
96
  }

-- | The empty solution we start with when computing allocations
emptySolution :: AllocSolution
emptySolution = AllocSolution { asFailures = [], asAllocs = 0
97
                              , asSolutions = [], asLog = [] }
98

Iustin Pop's avatar
Iustin Pop committed
99
-- | The complete state for the balancing solution
100
data Table = Table Node.List Instance.List Score [Placement]
Iustin Pop's avatar
Iustin Pop committed
101
102
             deriving (Show)

103
104
105
106
107
108
109
110
111
112
113
114
115
116
data CStats = CStats { csFmem :: Int    -- ^ Cluster free mem
                     , csFdsk :: Int    -- ^ Cluster free disk
                     , csAmem :: Int    -- ^ Cluster allocatable mem
                     , csAdsk :: Int    -- ^ Cluster allocatable disk
                     , csAcpu :: Int    -- ^ Cluster allocatable cpus
                     , csMmem :: Int    -- ^ Max node allocatable mem
                     , csMdsk :: Int    -- ^ Max node allocatable disk
                     , csMcpu :: Int    -- ^ Max node allocatable cpu
                     , csImem :: Int    -- ^ Instance used mem
                     , csIdsk :: Int    -- ^ Instance used disk
                     , csIcpu :: Int    -- ^ Instance used cpu
                     , csTmem :: Double -- ^ Cluster total mem
                     , csTdsk :: Double -- ^ Cluster total disk
                     , csTcpu :: Double -- ^ Cluster total cpus
117
118
119
                     , csVcpu :: Int    -- ^ Cluster virtual cpus (if
                                        -- node pCpu has been set,
                                        -- otherwise -1)
120
121
122
123
                     , csXmem :: Int    -- ^ Unnacounted for mem
                     , csNmem :: Int    -- ^ Node own memory
                     , csScore :: Score -- ^ The cluster score
                     , csNinst :: Int   -- ^ The total number of instances
124
                     }
Iustin Pop's avatar
Iustin Pop committed
125
            deriving (Show)
126

127
128
129
-- | Currently used, possibly to allocate, unallocable
type AllocStats = (RSpec, RSpec, RSpec)

Iustin Pop's avatar
Iustin Pop committed
130
131
-- * Utility functions

Iustin Pop's avatar
Iustin Pop committed
132
133
-- | Verifies the N+1 status and return the affected nodes.
verifyN1 :: [Node.Node] -> [Node.Node]
Iustin Pop's avatar
Iustin Pop committed
134
verifyN1 = filter Node.failN1
Iustin Pop's avatar
Iustin Pop committed
135

Iustin Pop's avatar
Iustin Pop committed
136
137
138
139
140
141
142
143
144
145
{-| Computes the pair of bad nodes and instances.

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

-}
computeBadItems :: Node.List -> Instance.List ->
                   ([Node.Node], [Instance.Instance])
computeBadItems nl il =
146
  let bad_nodes = verifyN1 $ getOnline nl
147
      bad_instances = map (`Container.find` il) .
Iustin Pop's avatar
Iustin Pop committed
148
                      sort . nub $
149
                      concatMap (\ n -> Node.sList n ++ Node.pList n) bad_nodes
Iustin Pop's avatar
Iustin Pop committed
150
151
152
  in
    (bad_nodes, bad_instances)

Iustin Pop's avatar
Iustin Pop committed
153
-- | Zero-initializer for the CStats type
154
emptyCStats :: CStats
155
emptyCStats = CStats 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
156

Iustin Pop's avatar
Iustin Pop committed
157
-- | Update stats with data from a new node
158
159
updateCStats :: CStats -> Node.Node -> CStats
updateCStats cs node =
160
161
162
163
164
    let CStats { csFmem = x_fmem, csFdsk = x_fdsk,
                 csAmem = x_amem, csAcpu = x_acpu, csAdsk = x_adsk,
                 csMmem = x_mmem, csMdsk = x_mdsk, csMcpu = x_mcpu,
                 csImem = x_imem, csIdsk = x_idsk, csIcpu = x_icpu,
                 csTmem = x_tmem, csTdsk = x_tdsk, csTcpu = x_tcpu,
165
                 csVcpu = x_vcpu,
166
                 csXmem = x_xmem, csNmem = x_nmem, csNinst = x_ninst
Iustin Pop's avatar
Iustin Pop committed
167
               }
168
            = cs
169
        inc_amem = Node.fMem node - Node.rMem node
170
        inc_amem' = if inc_amem > 0 then inc_amem else 0
171
        inc_adsk = Node.availDisk node
172
173
174
175
        inc_imem = truncate (Node.tMem node) - Node.nMem node
                   - Node.xMem node - Node.fMem node
        inc_icpu = Node.uCpu node
        inc_idsk = truncate (Node.tDsk node) - Node.fDsk node
176
        inc_vcpu = Node.hiCpu node
Iustin Pop's avatar
Iustin Pop committed
177

178
179
180
181
182
183
184
185
186
187
188
189
190
191
    in cs { csFmem = x_fmem + Node.fMem node
          , csFdsk = x_fdsk + Node.fDsk node
          , csAmem = x_amem + inc_amem'
          , csAdsk = x_adsk + inc_adsk
          , csAcpu = x_acpu
          , csMmem = max x_mmem inc_amem'
          , csMdsk = max x_mdsk inc_adsk
          , csMcpu = x_mcpu
          , csImem = x_imem + inc_imem
          , csIdsk = x_idsk + inc_idsk
          , csIcpu = x_icpu + inc_icpu
          , csTmem = x_tmem + Node.tMem node
          , csTdsk = x_tdsk + Node.tDsk node
          , csTcpu = x_tcpu + Node.tCpu node
192
          , csVcpu = x_vcpu + inc_vcpu
193
194
195
          , csXmem = x_xmem + Node.xMem node
          , csNmem = x_nmem + Node.nMem node
          , csNinst = x_ninst + length (Node.pList node)
196
          }
197

Iustin Pop's avatar
Iustin Pop committed
198
-- | Compute the total free disk and memory in the cluster.
199
totalResources :: Node.List -> CStats
200
201
totalResources nl =
    let cs = foldl' updateCStats emptyCStats . Container.elems $ nl
202
    in cs { csScore = compCV nl }
Iustin Pop's avatar
Iustin Pop committed
203

204
205
206
-- | Compute the delta between two cluster state.
--
-- This is used when doing allocations, to understand better the
Iustin Pop's avatar
Iustin Pop committed
207
208
209
-- available cluster resources. The return value is a triple of the
-- current used values, the delta that was still allocated, and what
-- was left unallocated.
210
211
212
213
214
215
computeAllocationDelta :: CStats -> CStats -> AllocStats
computeAllocationDelta cini cfin =
    let CStats {csImem = i_imem, csIdsk = i_idsk, csIcpu = i_icpu} = cini
        CStats {csImem = f_imem, csIdsk = f_idsk, csIcpu = f_icpu,
                csTmem = t_mem, csTdsk = t_dsk, csVcpu = v_cpu } = cfin
        rini = RSpec i_icpu i_imem i_idsk
Iustin Pop's avatar
Iustin Pop committed
216
        rfin = RSpec (f_icpu - i_icpu) (f_imem - i_imem) (f_idsk - i_idsk)
217
        un_cpu = v_cpu - f_icpu
218
219
220
        runa = RSpec un_cpu (truncate t_mem - f_imem) (truncate t_dsk - f_idsk)
    in (rini, rfin, runa)

Iustin Pop's avatar
Iustin Pop committed
221
222
223
224
225
226
227
228
229
230
231
232
233
-- | The names and weights of the individual elements in the CV list
detailedCVInfo :: [(Double, String)]
detailedCVInfo = [ (1,  "free_mem_cv")
                 , (1,  "free_disk_cv")
                 , (1,  "n1_cnt")
                 , (1,  "reserved_mem_cv")
                 , (4,  "offline_all_cnt")
                 , (16, "offline_pri_cnt")
                 , (1,  "vcpu_ratio_cv")
                 , (1,  "cpu_load_cv")
                 , (1,  "mem_load_cv")
                 , (1,  "disk_load_cv")
                 , (1,  "net_load_cv")
Iustin Pop's avatar
Iustin Pop committed
234
                 , (2,  "pri_tags_score")
Iustin Pop's avatar
Iustin Pop committed
235
236
237
238
                 ]

detailedCVWeights :: [Double]
detailedCVWeights = map fst detailedCVInfo
239

Iustin Pop's avatar
Iustin Pop committed
240
-- | Compute the mem and disk covariance.
241
compDetailedCV :: Node.List -> [Double]
Iustin Pop's avatar
Iustin Pop committed
242
243
244
245
compDetailedCV nl =
    let
        all_nodes = Container.elems nl
        (offline, nodes) = partition Node.offline all_nodes
246
247
        mem_l = map Node.pMem nodes
        dsk_l = map Node.pDsk nodes
248
        -- metric: memory covariance
Iustin Pop's avatar
Iustin Pop committed
249
        mem_cv = varianceCoeff mem_l
250
        -- metric: disk covariance
Iustin Pop's avatar
Iustin Pop committed
251
        dsk_cv = varianceCoeff dsk_l
252
253
254
255
        -- metric: count of instances living on N1 failing nodes
        n1_score = fromIntegral . sum . map (\n -> length (Node.sList n) +
                                                   length (Node.pList n)) .
                   filter Node.failN1 $ nodes :: Double
256
        res_l = map Node.pRem nodes
257
        -- metric: reserved memory covariance
Iustin Pop's avatar
Iustin Pop committed
258
        res_cv = varianceCoeff res_l
259
260
261
262
263
        -- offline instances metrics
        offline_ipri = sum . map (length . Node.pList) $ offline
        offline_isec = sum . map (length . Node.sList) $ offline
        -- metric: count of instances on offline nodes
        off_score = fromIntegral (offline_ipri + offline_isec)::Double
264
265
266
267
        -- metric: count of primary instances on offline nodes (this
        -- helps with evacuation/failover of primary instances on
        -- 2-node clusters with one node offline)
        off_pri_score = fromIntegral offline_ipri::Double
268
        cpu_l = map Node.pCpu nodes
269
        -- metric: covariance of vcpu/pcpu ratio
270
        cpu_cv = varianceCoeff cpu_l
271
        -- metrics: covariance of cpu, memory, disk and network load
272
273
274
275
276
277
        (c_load, m_load, d_load, n_load) = unzip4 $
            map (\n ->
                     let DynUtil c1 m1 d1 n1 = Node.utilLoad n
                         DynUtil c2 m2 d2 n2 = Node.utilPool n
                     in (c1/c2, m1/m2, d1/d2, n1/n2)
                ) nodes
278
279
280
        -- metric: conflicting instance count
        pri_tags_inst = sum $ map Node.conflictingPrimaries nodes
        pri_tags_score = fromIntegral pri_tags_inst::Double
281
    in [ mem_cv, dsk_cv, n1_score, res_cv, off_score, off_pri_score, cpu_cv
282
       , varianceCoeff c_load, varianceCoeff m_load
283
284
       , varianceCoeff d_load, varianceCoeff n_load
       , pri_tags_score ]
Iustin Pop's avatar
Iustin Pop committed
285
286
287

-- | Compute the /total/ variance.
compCV :: Node.List -> Double
Iustin Pop's avatar
Iustin Pop committed
288
compCV = sum . zipWith (*) detailedCVWeights . compDetailedCV
Iustin Pop's avatar
Iustin Pop committed
289

290
291
292
293
-- | Compute online nodes from a Node.List
getOnline :: Node.List -> [Node.Node]
getOnline = filter (not . Node.offline) . Container.elems

Iustin Pop's avatar
Iustin Pop committed
294
295
296
297
298
299
300
301
-- * hbal functions

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

-- | Applies an instance move to a given node list and instance.
302
applyMove :: Node.List -> Instance.Instance
303
          -> IMove -> OpResult (Node.List, Instance.Instance, Ndx, Ndx)
Iustin Pop's avatar
Iustin Pop committed
304
-- Failover (f)
Iustin Pop's avatar
Iustin Pop committed
305
applyMove nl inst Failover =
306
307
    let old_pdx = Instance.pNode inst
        old_sdx = Instance.sNode inst
Iustin Pop's avatar
Iustin Pop committed
308
309
310
311
        old_p = Container.find old_pdx nl
        old_s = Container.find old_sdx nl
        int_p = Node.removePri old_p inst
        int_s = Node.removeSec old_s inst
312
        force_p = Node.offline old_p
313
        new_nl = do -- Maybe monad
314
          new_p <- Node.addPriEx force_p int_s inst
315
          new_s <- Node.addSec int_p inst old_sdx
316
317
318
319
          let new_inst = Instance.setBoth inst old_sdx old_pdx
          return (Container.addTwo old_pdx new_s old_sdx new_p nl,
                  new_inst, old_sdx, old_pdx)
    in new_nl
Iustin Pop's avatar
Iustin Pop committed
320

Iustin Pop's avatar
Iustin Pop committed
321
-- Replace the primary (f:, r:np, f)
Iustin Pop's avatar
Iustin Pop committed
322
applyMove nl inst (ReplacePrimary new_pdx) =
323
324
    let old_pdx = Instance.pNode inst
        old_sdx = Instance.sNode inst
Iustin Pop's avatar
Iustin Pop committed
325
326
327
328
329
        old_p = Container.find old_pdx nl
        old_s = Container.find old_sdx nl
        tgt_n = Container.find new_pdx nl
        int_p = Node.removePri old_p inst
        int_s = Node.removeSec old_s inst
330
        force_p = Node.offline old_p
331
        new_nl = do -- Maybe monad
332
333
          -- check that the current secondary can host the instance
          -- during the migration
334
          tmp_s <- Node.addPriEx force_p int_s inst
335
          let tmp_s' = Node.removePri tmp_s inst
336
337
          new_p <- Node.addPriEx force_p tgt_n inst
          new_s <- Node.addSecEx force_p tmp_s' inst new_pdx
338
339
340
341
342
          let new_inst = Instance.setPri inst new_pdx
          return (Container.add new_pdx new_p $
                  Container.addTwo old_pdx int_p old_sdx new_s nl,
                  new_inst, new_pdx, old_sdx)
    in new_nl
Iustin Pop's avatar
Iustin Pop committed
343

Iustin Pop's avatar
Iustin Pop committed
344
-- Replace the secondary (r:ns)
Iustin Pop's avatar
Iustin Pop committed
345
applyMove nl inst (ReplaceSecondary new_sdx) =
346
347
    let old_pdx = Instance.pNode inst
        old_sdx = Instance.sNode inst
Iustin Pop's avatar
Iustin Pop committed
348
349
350
        old_s = Container.find old_sdx nl
        tgt_n = Container.find new_sdx nl
        int_s = Node.removeSec old_s inst
351
        force_s = Node.offline old_s
352
        new_inst = Instance.setSec inst new_sdx
353
        new_nl = Node.addSecEx force_s tgt_n inst old_pdx >>=
354
355
356
357
                 \new_s -> return (Container.addTwo new_sdx
                                   new_s old_sdx int_s nl,
                                   new_inst, old_pdx, new_sdx)
    in new_nl
Iustin Pop's avatar
Iustin Pop committed
358

Iustin Pop's avatar
Iustin Pop committed
359
-- Replace the secondary and failover (r:np, f)
Iustin Pop's avatar
Iustin Pop committed
360
applyMove nl inst (ReplaceAndFailover new_pdx) =
361
362
    let old_pdx = Instance.pNode inst
        old_sdx = Instance.sNode inst
Iustin Pop's avatar
Iustin Pop committed
363
364
365
366
367
        old_p = Container.find old_pdx nl
        old_s = Container.find old_sdx nl
        tgt_n = Container.find new_pdx nl
        int_p = Node.removePri old_p inst
        int_s = Node.removeSec old_s inst
368
        force_s = Node.offline old_s
369
370
        new_nl = do -- Maybe monad
          new_p <- Node.addPri tgt_n inst
371
          new_s <- Node.addSecEx force_s int_p inst new_pdx
372
373
374
375
376
          let new_inst = Instance.setBoth inst new_pdx old_pdx
          return (Container.add new_pdx new_p $
                  Container.addTwo old_pdx new_s old_sdx int_s nl,
                  new_inst, new_pdx, old_pdx)
    in new_nl
Iustin Pop's avatar
Iustin Pop committed
377

Iustin Pop's avatar
Iustin Pop committed
378
379
-- Failver and replace the secondary (f, r:ns)
applyMove nl inst (FailoverAndReplace new_sdx) =
380
381
    let old_pdx = Instance.pNode inst
        old_sdx = Instance.sNode inst
Iustin Pop's avatar
Iustin Pop committed
382
383
384
385
386
        old_p = Container.find old_pdx nl
        old_s = Container.find old_sdx nl
        tgt_n = Container.find new_sdx nl
        int_p = Node.removePri old_p inst
        int_s = Node.removeSec old_s inst
387
        force_p = Node.offline old_p
388
        new_nl = do -- Maybe monad
389
390
          new_p <- Node.addPriEx force_p int_s inst
          new_s <- Node.addSecEx force_p tgt_n inst old_sdx
391
392
393
394
395
          let new_inst = Instance.setBoth inst old_sdx new_sdx
          return (Container.add new_sdx new_s $
                  Container.addTwo old_sdx new_p old_pdx int_p nl,
                  new_inst, old_sdx, new_sdx)
    in new_nl
Iustin Pop's avatar
Iustin Pop committed
396

Iustin Pop's avatar
Iustin Pop committed
397
-- | Tries to allocate an instance on one given node.
398
allocateOnSingle :: Node.List -> Instance.Instance -> Node.Node
399
                 -> OpResult Node.AllocElement
400
401
allocateOnSingle nl inst p =
    let new_pdx = Node.idx p
402
        new_inst = Instance.setBoth inst new_pdx Node.noSecondary
403
404
405
406
    in  Node.addPri p inst >>= \new_p -> do
      let new_nl = Container.add new_pdx new_p nl
          new_score = compCV nl
      return (new_nl, new_inst, [new_p], new_score)
407

Iustin Pop's avatar
Iustin Pop committed
408
-- | Tries to allocate an instance on a given pair of nodes.
409
allocateOnPair :: Node.List -> Instance.Instance -> Node.Node -> Node.Node
410
               -> OpResult Node.AllocElement
411
412
413
allocateOnPair nl inst tgt_p tgt_s =
    let new_pdx = Node.idx tgt_p
        new_sdx = Node.idx tgt_s
414
415
416
417
418
419
    in do
      new_p <- Node.addPri tgt_p inst
      new_s <- Node.addSec tgt_s inst new_pdx
      let new_inst = Instance.setBoth inst new_pdx new_sdx
          new_nl = Container.addTwo new_pdx new_p new_sdx new_s nl
      return (new_nl, new_inst, [new_p, new_s], compCV new_nl)
420

Iustin Pop's avatar
Iustin Pop committed
421
422
-- | Tries to perform an instance move and returns the best table
-- between the original one and the new one.
Iustin Pop's avatar
Iustin Pop committed
423
424
425
426
427
428
429
430
checkSingleStep :: Table -- ^ The original table
                -> Instance.Instance -- ^ The instance to move
                -> Table -- ^ The current best table
                -> IMove -- ^ The move to apply
                -> Table -- ^ The final best table
checkSingleStep ini_tbl target cur_tbl move =
    let
        Table ini_nl ini_il _ ini_plc = ini_tbl
431
        tmp_resu = applyMove ini_nl target move
Iustin Pop's avatar
Iustin Pop committed
432
    in
433
      case tmp_resu of
434
        OpFail _ -> cur_tbl
435
        OpGood (upd_nl, new_inst, pri_idx, sec_idx) ->
436
437
438
            let tgt_idx = Instance.idx target
                upd_cvar = compCV upd_nl
                upd_il = Container.add tgt_idx new_inst ini_il
439
                upd_plc = (tgt_idx, pri_idx, sec_idx, move, upd_cvar):ini_plc
440
441
442
                upd_tbl = Table upd_nl upd_il upd_cvar upd_plc
            in
              compareTables cur_tbl upd_tbl
Iustin Pop's avatar
Iustin Pop committed
443

444
445
446
447
448
449
-- | Given the status of the current secondary as a valid new node and
-- the current candidate target node, generate the possible moves for
-- a instance.
possibleMoves :: Bool      -- ^ Whether the secondary node is a valid new node
              -> Ndx       -- ^ Target node candidate
              -> [IMove]   -- ^ List of valid result moves
450
451
452
453
454
455
456
457
458
459
460
possibleMoves True tdx =
    [ReplaceSecondary tdx,
     ReplaceAndFailover tdx,
     ReplacePrimary tdx,
     FailoverAndReplace tdx]

possibleMoves False tdx =
    [ReplaceSecondary tdx,
     ReplaceAndFailover tdx]

-- | Compute the best move for a given instance.
461
462
463
464
465
466
checkInstanceMove :: [Ndx]             -- ^ Allowed target node indices
                  -> Bool              -- ^ Whether disk moves are allowed
                  -> Table             -- ^ Original table
                  -> Instance.Instance -- ^ Instance to move
                  -> Table             -- ^ Best new table for this instance
checkInstanceMove nodes_idx disk_moves ini_tbl target =
Iustin Pop's avatar
Iustin Pop committed
467
    let
468
469
        opdx = Instance.pNode target
        osdx = Instance.sNode target
470
        nodes = filter (\idx -> idx /= opdx && idx /= osdx) nodes_idx
471
472
473
474
        use_secondary = elem osdx nodes_idx
        aft_failover = if use_secondary -- if allowed to failover
                       then checkSingleStep ini_tbl target ini_tbl Failover
                       else ini_tbl
475
476
477
        all_moves = if disk_moves
                    then concatMap (possibleMoves use_secondary) nodes
                    else []
Iustin Pop's avatar
Iustin Pop committed
478
479
    in
      -- iterate over the possible nodes for this instance
480
      foldl' (checkSingleStep ini_tbl target) aft_failover all_moves
Iustin Pop's avatar
Iustin Pop committed
481

Iustin Pop's avatar
Iustin Pop committed
482
-- | Compute the best next move.
483
checkMove :: [Ndx]               -- ^ Allowed target node indices
484
          -> Bool                -- ^ Whether disk moves are allowed
485
          -> Table               -- ^ The current solution
Iustin Pop's avatar
Iustin Pop committed
486
          -> [Instance.Instance] -- ^ List of instances still to move
487
          -> Table               -- ^ The new solution
488
checkMove nodes_idx disk_moves ini_tbl victims =
Iustin Pop's avatar
Iustin Pop committed
489
490
    let Table _ _ _ ini_plc = ini_tbl
        -- iterate over all instances, computing the best move
491
492
        best_tbl =
            foldl'
Iustin Pop's avatar
Iustin Pop committed
493
            (\ step_tbl em ->
494
495
                 compareTables step_tbl $
                 checkInstanceMove nodes_idx disk_moves ini_tbl em)
496
            ini_tbl victims
Iustin Pop's avatar
Iustin Pop committed
497
        Table _ _ _ best_plc = best_tbl
498
499
500
    in if length best_plc == length ini_plc
       then ini_tbl -- no advancement
       else best_tbl
Iustin Pop's avatar
Iustin Pop committed
501

502
-- | Check if we are allowed to go deeper in the balancing
503
504
505
506
doNextBalance :: Table     -- ^ The starting table
              -> Int       -- ^ Remaining length
              -> Score     -- ^ Score at which to stop
              -> Bool      -- ^ The resulting table and commands
507
508
509
510
511
doNextBalance ini_tbl max_rounds min_score =
    let Table _ _ ini_cv ini_plc = ini_tbl
        ini_plc_len = length ini_plc
    in (max_rounds < 0 || ini_plc_len < max_rounds) && ini_cv > min_score

512
513
514
-- | Run a balance move
tryBalance :: Table       -- ^ The starting table
           -> Bool        -- ^ Allow disk moves
Iustin Pop's avatar
Iustin Pop committed
515
           -> Bool        -- ^ Only evacuate moves
516
517
           -> Score       -- ^ Min gain threshold
           -> Score       -- ^ Min gain
518
           -> Maybe Table -- ^ The resulting table and commands
519
tryBalance ini_tbl disk_moves evac_mode mg_limit min_gain =
520
521
    let Table ini_nl ini_il ini_cv _ = ini_tbl
        all_inst = Container.elems ini_il
Iustin Pop's avatar
Iustin Pop committed
522
523
524
525
526
527
528
        all_inst' = if evac_mode
                    then let bad_nodes = map Node.idx . filter Node.offline $
                                         Container.elems ini_nl
                         in filter (\e -> Instance.sNode e `elem` bad_nodes ||
                                          Instance.pNode e `elem` bad_nodes)
                            all_inst
                    else all_inst
529
        reloc_inst = filter Instance.movable all_inst'
530
531
        node_idx = map Node.idx . filter (not . Node.offline) $
                   Container.elems ini_nl
532
        fin_tbl = checkMove node_idx disk_moves ini_tbl reloc_inst
533
        (Table _ _ fin_cv _) = fin_tbl
534
    in
535
      if fin_cv < ini_cv && (ini_cv > mg_limit || ini_cv - fin_cv >= min_gain)
536
      then Just fin_tbl -- this round made success, return the new table
537
538
      else Nothing

539
540
541
542
543
-- * Allocation functions

-- | Build failure stats out of a list of failures
collapseFailures :: [FailMode] -> FailStats
collapseFailures flst =
544
    map (\k -> (k, length $ filter (k ==) flst)) [minBound..maxBound]
545
546
547

-- | Update current Allocation solution and failure stats with new
-- elements
548
concatAllocs :: AllocSolution -> OpResult Node.AllocElement -> AllocSolution
549
concatAllocs as (OpFail reason) = as { asFailures = reason : asFailures as }
550

551
concatAllocs as (OpGood ns@(_, _, _, nscore)) =
552
    let -- Choose the old or new solution, based on the cluster score
553
554
        cntok = asAllocs as
        osols = asSolutions as
555
        nsols = case osols of
556
557
                  [] -> [ns]
                  (_, _, _, oscore):[] ->
558
559
                      if oscore < nscore
                      then osols
560
                      else [ns]
561
562
563
                  -- FIXME: here we simply concat to lists with more
                  -- than one element; we should instead abort, since
                  -- this is not a valid usage of this function
564
                  xs -> ns:xs
Iustin Pop's avatar
Iustin Pop committed
565
        nsuc = cntok + 1
566
567
568
569
    -- Note: we force evaluation of nsols here in order to keep the
    -- memory profile low - we know that we will need nsols for sure
    -- in the next cycle, so we force evaluation of nsols, since the
    -- foldl' in the caller will only evaluate the tuple, but not the
Iustin Pop's avatar
Iustin Pop committed
570
    -- elements of the tuple
571
    in nsols `seq` nsuc `seq` as { asAllocs = nsuc, asSolutions = nsols }
572

573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
-- | Given a solution, generates a reasonable description for it
describeSolution :: AllocSolution -> String
describeSolution as =
  let fcnt = asFailures as
      sols = asSolutions as
      freasons =
        intercalate ", " . map (\(a, b) -> printf "%s: %d" (show a) b) .
        filter ((> 0) . snd) . collapseFailures $ fcnt
  in if null sols
     then "No valid allocation solutions, failure reasons: " ++
          (if null fcnt
           then "unknown reasons"
           else freasons)
     else let (_, _, nodes, cv) = head sols
          in printf ("score: %.8f, successes %d, failures %d (%s)" ++
                     " for node(s) %s") cv (asAllocs as) (length fcnt) freasons
             (intercalate "/" . map Node.name $ nodes)

-- | Annotates a solution with the appropriate string
annotateSolution :: AllocSolution -> AllocSolution
annotateSolution as = as { asLog = describeSolution as : asLog as }

595
596
597
598
599
600
-- | Try to allocate an instance on the cluster.
tryAlloc :: (Monad m) =>
            Node.List         -- ^ The node list
         -> Instance.List     -- ^ The instance list
         -> Instance.Instance -- ^ The instance to allocate
         -> Int               -- ^ Required number of nodes
601
         -> m AllocSolution   -- ^ Possible solution list
602
603
604
605
tryAlloc nl _ inst 2 =
    let all_nodes = getOnline nl
        all_pairs = liftM2 (,) all_nodes all_nodes
        ok_pairs = filter (\(x, y) -> Node.idx x /= Node.idx y) all_pairs
606
607
        sols = foldl' (\cstate (p, s) ->
                           concatAllocs cstate $ allocateOnPair nl inst p s
608
                      ) emptySolution ok_pairs
609

610
611
612
    in if null ok_pairs -- means we have just one node
       then fail "Not enough online nodes"
       else return $ annotateSolution sols
613
614
615

tryAlloc nl _ inst 1 =
    let all_nodes = getOnline nl
Iustin Pop's avatar
Iustin Pop committed
616
617
        sols = foldl' (\cstate ->
                           concatAllocs cstate . allocateOnSingle nl inst
618
                      ) emptySolution all_nodes
619
620
621
    in if null all_nodes
       then fail "No online nodes"
       else return $ annotateSolution sols
622

623
tryAlloc _ _ _ reqn = fail $ "Unsupported number of allocation \
Iustin Pop's avatar
Iustin Pop committed
624
                             \destinations required (" ++ show reqn ++
625
626
                                               "), only two supported"

627
-- | Given a group/result, describe it as a nice (list of) messages
Iustin Pop's avatar
Iustin Pop committed
628
solutionDescription :: (Gdx, Result AllocSolution) -> [String]
629
630
solutionDescription (groupId, result) =
  case result of
Iustin Pop's avatar
Iustin Pop committed
631
632
    Ok solution -> map (printf "Group %d: %s" groupId) (asLog solution)
    Bad message -> [printf "Group %d: error %s" groupId message]
633
634
635

-- | From a list of possibly bad and possibly empty solutions, filter
-- only the groups with a valid result
Iustin Pop's avatar
Iustin Pop committed
636
637
filterMGResults :: [(Gdx, Result AllocSolution)] ->
                   [(Gdx, AllocSolution)]
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
filterMGResults =
  filter (not . null . asSolutions . snd) .
  map (\(y, Ok x) -> (y, x)) .
  filter (isOk . snd)

-- | Try to allocate an instance on a multi-group cluster.
tryMGAlloc :: Node.List         -- ^ The node list
              -> Instance.List     -- ^ The instance list
              -> Instance.Instance -- ^ The instance to allocate
              -> Int               -- ^ Required number of nodes
              -> Result AllocSolution   -- ^ Possible solution list
tryMGAlloc mgnl mgil inst cnt =
  let groups = splitCluster mgnl mgil
      -- TODO: currently we consider all groups preferred
      sols = map (\(gid, (nl, il)) ->
                   (gid, tryAlloc nl il inst cnt)) groups::
Iustin Pop's avatar
Iustin Pop committed
654
        [(Gdx, Result AllocSolution)]
655
656
657
658
659
660
661
662
      all_msgs = concatMap solutionDescription sols
      goodSols = filterMGResults sols
      extractScore = \(_, _, _, x) -> x
      solScore = extractScore . head . asSolutions . snd
      sortedSols = sortBy (comparing solScore) goodSols
  in if null sortedSols
     then Bad $ intercalate ", " all_msgs
     else let (final_group, final_sol) = head sortedSols
Iustin Pop's avatar
Iustin Pop committed
663
              selmsg = "Selected group: " ++ show final_group
664
665
666
          in Ok $ final_sol { asLog = selmsg:all_msgs }

-- | Try to relocate an instance on the cluster.
667
tryReloc :: (Monad m) =>
668
669
670
            Node.List       -- ^ The node list
         -> Instance.List   -- ^ The instance list
         -> Idx             -- ^ The index of the instance to move
671
         -> Int             -- ^ The number of nodes required
672
673
         -> [Ndx]           -- ^ Nodes which should not be used
         -> m AllocSolution -- ^ Solution list
674
675
676
tryReloc nl il xid 1 ex_idx =
    let all_nodes = getOnline nl
        inst = Container.find xid il
677
        ex_idx' = Instance.pNode inst:ex_idx
678
679
        valid_nodes = filter (not . flip elem ex_idx' . Node.idx) all_nodes
        valid_idxes = map Node.idx valid_nodes
680
        sols1 = foldl' (\cstate x ->
Iustin Pop's avatar
Iustin Pop committed
681
                            let em = do
682
683
                                  (mnl, i, _, _) <-
                                      applyMove nl inst (ReplaceSecondary x)
684
685
                                  return (mnl, i, [Container.find x mnl],
                                          compCV mnl)
Iustin Pop's avatar
Iustin Pop committed
686
                            in concatAllocs cstate em
687
                       ) emptySolution valid_idxes
688
689
690
    in return sols1

tryReloc _ _ _ reqn _  = fail $ "Unsupported number of relocation \
Iustin Pop's avatar
Iustin Pop committed
691
                                \destinations required (" ++ show reqn ++
692
                                                  "), only one supported"
Iustin Pop's avatar
Iustin Pop committed
693

694
-- | Try to evacuate a list of nodes.
Iustin Pop's avatar
Iustin Pop committed
695
696
697
698
699
700
tryEvac :: (Monad m) =>
            Node.List       -- ^ The node list
         -> Instance.List   -- ^ The instance list
         -> [Ndx]           -- ^ Nodes to be evacuated
         -> m AllocSolution -- ^ Solution list
tryEvac nl il ex_ndx =
701
702
    let ex_nodes = map (`Container.find` nl) ex_ndx
        all_insts = nub . concatMap Node.sList $ ex_nodes
Iustin Pop's avatar
Iustin Pop committed
703
    in do
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
      (_, sol) <- foldM (\(nl', old_as) idx -> do
                            -- FIXME: hardcoded one node here
                            -- (fm, cs, aes)
                            new_as <- tryReloc nl' il idx 1 ex_ndx
                            case asSolutions new_as of
                              csol@(nl'', _, _, _):_ ->
                                -- an individual relocation succeeded,
                                -- we kind of compose the data from
                                -- the two solutions
                                return (nl'',
                                        new_as { asSolutions =
                                                    csol:asSolutions old_as })
                              -- this relocation failed, so we fail
                              -- the entire evac
                              _ -> fail $ "Can't evacuate instance " ++
719
720
                                   Instance.name (Container.find idx il) ++
                                   ": " ++ describeSolution new_as
721
                        ) (nl, emptySolution) all_insts
722
      return $ annotateSolution sol
Iustin Pop's avatar
Iustin Pop committed
723

724
725
726
727
728
729
-- | Recursively place instances on the cluster until we're out of space
iterateAlloc :: Node.List
             -> Instance.List
             -> Instance.Instance
             -> Int
             -> [Instance.Instance]
730
731
             -> Result (FailStats, Node.List, Instance.List,
                        [Instance.Instance])
732
733
734
735
736
737
738
iterateAlloc nl il newinst nreq ixes =
      let depth = length ixes
          newname = printf "new-%d" depth::String
          newidx = length (Container.elems il) + depth
          newi2 = Instance.setIdx (Instance.setName newinst newname) newidx
      in case tryAlloc nl il newi2 nreq of
           Bad s -> Bad s
739
           Ok (AllocSolution { asFailures = errs, asSolutions = sols3 }) ->
740
               case sols3 of
741
                 [] -> Ok (collapseFailures errs, nl, il, ixes)
742
                 (xnl, xi, _, _):[] ->
743
744
                     iterateAlloc xnl (Container.add newidx xi il)
                                  newinst nreq $! (xi:ixes)
745
746
747
748
749
750
751
752
                 _ -> Bad "Internal error: multiple solutions for single\
                          \ allocation"

tieredAlloc :: Node.List
            -> Instance.List
            -> Instance.Instance
            -> Int
            -> [Instance.Instance]
753
754
            -> Result (FailStats, Node.List, Instance.List,
                       [Instance.Instance])
755
756
757
tieredAlloc nl il newinst nreq ixes =
    case iterateAlloc nl il newinst nreq ixes of
      Bad s -> Bad s
758
      Ok (errs, nl', il', ixes') ->
759
760
          case Instance.shrinkByType newinst . fst . last $
               sortBy (comparing snd) errs of
761
            Bad _ -> Ok (errs, nl', il', ixes')
762
            Ok newinst' ->
763
                tieredAlloc nl' il' newinst' nreq ixes'
764

Iustin Pop's avatar
Iustin Pop committed
765
-- * Formatting functions
Iustin Pop's avatar
Iustin Pop committed
766
767

-- | Given the original and final nodes, computes the relocation description.
768
769
computeMoves :: Instance.Instance -- ^ The instance to be moved
             -> String -- ^ The instance name
Iustin Pop's avatar
Iustin Pop committed
770
             -> IMove  -- ^ The move being performed
Iustin Pop's avatar
Iustin Pop committed
771
772
773
774
775
776
777
             -> String -- ^ New primary
             -> String -- ^ New secondary
             -> (String, [String])
                -- ^ Tuple of moves and commands list; moves is containing
                -- either @/f/@ for failover or @/r:name/@ for replace
                -- secondary, while the command list holds gnt-instance
                -- commands (without that prefix), e.g \"@failover instance1@\"
Iustin Pop's avatar
Iustin Pop committed
778
779
780
781
782
783
784
computeMoves i inam mv c d =
    case mv of
      Failover -> ("f", [mig])
      FailoverAndReplace _ -> (printf "f r:%s" d, [mig, rep d])
      ReplaceSecondary _ -> (printf "r:%s" d, [rep d])
      ReplaceAndFailover _ -> (printf "r:%s f" c, [rep c, mig])
      ReplacePrimary _ -> (printf "f r:%s f" c, [mig, rep c, mig])
785
786
787
    where morf = if Instance.running i then "migrate" else "failover"
          mig = printf "%s -f %s" morf inam::String
          rep n = printf "replace-disks -n %s %s" n inam
Iustin Pop's avatar
Iustin Pop committed
788

Iustin Pop's avatar
Iustin Pop committed
789
790
791
792
793
794
795
796
-- | Converts a placement to string format.
printSolutionLine :: Node.List     -- ^ The node list
                  -> Instance.List -- ^ The instance list
                  -> Int           -- ^ Maximum node name length
                  -> Int           -- ^ Maximum instance name length
                  -> Placement     -- ^ The current placement
                  -> Int           -- ^ The index of the placement in
                                   -- the solution
Iustin Pop's avatar
Iustin Pop committed
797
798
                  -> (String, [String])
printSolutionLine nl il nmlen imlen plc pos =
799
800
    let
        pmlen = (2*nmlen + 1)
Iustin Pop's avatar
Iustin Pop committed
801
        (i, p, s, mv, c) = plc
802
        inst = Container.find i il
803
804
805
806
807
        inam = Instance.alias inst
        npri = Node.alias $ Container.find p nl
        nsec = Node.alias $ Container.find s nl
        opri = Node.alias $ Container.find (Instance.pNode inst) nl
        osec = Node.alias $ Container.find (Instance.sNode inst) nl
Iustin Pop's avatar
Iustin Pop committed
808
        (moves, cmds) =  computeMoves inst inam mv npri nsec
Iustin Pop's avatar
Iustin Pop committed
809
810
        ostr = printf "%s:%s" opri osec::String
        nstr = printf "%s:%s" npri nsec::String
811
    in
812
813
      (printf "  %3d. %-*s %-*s => %-*s %.8f a=%s"
       pos imlen inam pmlen ostr
814
815
816
       pmlen nstr c moves,
       cmds)

817
818
819
-- | Return the instance and involved nodes in an instance move.
involvedNodes :: Instance.List -> Placement -> [Ndx]
involvedNodes il plc =
820
    let (i, np, ns, _, _) = plc
821
        inst = Container.find i il
822
823
        op = Instance.pNode inst
        os = Instance.sNode inst
824
825
826
827
828
    in nub [np, ns, op, os]

-- | Inner function for splitJobs, that either appends the next job to
-- the current jobset, or starts a new jobset.
mergeJobs :: ([JobSet], [Ndx]) -> MoveJob -> ([JobSet], [Ndx])
829
830
mergeJobs ([], _) n@(ndx, _, _, _) = ([[n]], ndx)
mergeJobs (cjs@(j:js), nbuf) n@(ndx, _, _, _)
831
832
833
834
835
836
837
838
839
840
841
    | null (ndx `intersect` nbuf) = ((n:j):js, ndx ++ nbuf)
    | otherwise = ([n]:cjs, ndx)

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

-- | Given a list of commands, prefix them with @gnt-instance@ and
-- also beautify the display a little.
formatJob :: Int -> Int -> (Int, MoveJob) -> [String]
842
formatJob jsn jsl (sn, (_, _, _, cmds)) =
843
844
845
846
847
848
849
850
    let out =
            printf "  echo job %d/%d" jsn sn:
            printf "  check":
            map ("  gnt-instance " ++) cmds
    in if sn == 1
       then ["", printf "echo jobset %d, %d jobs" jsn jsl] ++ out
       else out

Iustin Pop's avatar
Iustin Pop committed
851
852
-- | Given a list of commands, prefix them with @gnt-instance@ and
-- also beautify the display a little.
853
formatCmds :: [JobSet] -> String
Iustin Pop's avatar
Iustin Pop committed
854
855
formatCmds =
    unlines .
856
857
    concatMap (\(jsn, js) -> concatMap (formatJob jsn (length js))
                             (zip [1..] js)) .
Iustin Pop's avatar
Iustin Pop committed
858
    zip [1..]
859

Iustin Pop's avatar
Iustin Pop committed
860
-- | Print the node list.
861
862
printNodes :: Node.List -> [String] -> String
printNodes nl fs =
Iustin Pop's avatar
Iustin Pop committed
863
864
865
866
    let fields = case fs of
          [] -> Node.defaultFields
          "+":rest -> Node.defaultFields ++ rest
          _ -> fs
867
        snl = sortBy (comparing Node.idx) (Container.elems nl)
868
        (header, isnum) = unzip $ map Node.showHeader fields
869
    in unlines . map ((:) ' ' .  intercalate " ") $
870
       formatTable (header:map (Node.list fields) snl) isnum
Iustin Pop's avatar
Iustin Pop committed
871

872
873
874
-- | Print the instance list.
printInsts :: Node.List -> Instance.List -> String
printInsts nl il =
875
    let sil = sortBy (comparing Instance.idx) (Container.elems il)
876
877
878
        helper inst = [ if Instance.running inst then "R" else " "
                      , Instance.name inst
                      , Container.nameOf nl (Instance.pNode inst)
879
880
881
882
                      , let sdx = Instance.sNode inst
                        in if sdx == Node.noSecondary
                           then  ""
                           else Container.nameOf nl sdx
883
884
885
886
887
888
889
890
891
892
893
894
                      , printf "%3d" $ Instance.vcpus inst
                      , printf "%5d" $ Instance.mem inst
                      , printf "%5d" $ Instance.dsk inst `div` 1024
                      , printf "%5.3f" lC
                      , printf "%5.3f" lM
                      , printf "%5.3f" lD
                      , printf "%5.3f" lN
                      ]
            where DynUtil lC lM lD lN = Instance.util inst
        header = [ "F", "Name", "Pri_node", "Sec_node", "vcpu", "mem"
                 , "dsk", "lCpu", "lMem", "lDsk", "lNet" ]
        isnum = False:False:False:False:repeat True
895
896
    in unlines . map ((:) ' ' . intercalate " ") $
       formatTable (header:map helper sil) isnum
897

Iustin Pop's avatar
Iustin Pop committed
898
-- | Shows statistics for a given node list.
899
printStats :: Node.List -> String
Iustin Pop's avatar
Iustin Pop committed
900
printStats nl =
901
    let dcvs = compDetailedCV nl
Iustin Pop's avatar
Iustin Pop committed
902
903
904
905
        (weights, names) = unzip detailedCVInfo
        hd = zip3 (weights ++ repeat 1) (names ++ repeat "unknown") dcvs
        formatted = map (\(w, header, val) ->
                             printf "%s=%.8f(x%.2f)" header val w::String) hd
906
    in intercalate ", " formatted
907
908

-- | Convert a placement into a list of OpCodes (basically a job).
909
iMoveToJob :: Node.List -> Instance.List
910
          -> Idx -> IMove -> [OpCodes.OpCode]
911
iMoveToJob nl il idx move =
912
    let inst = Container.find idx il
913
914
        iname = Instance.name inst
        lookNode  = Just . Container.nameOf nl
915
916
917
        opF = if Instance.running inst
              then OpCodes.OpMigrateInstance iname True False
              else OpCodes.OpFailoverInstance iname False
918
919
920
921
922
923
924
925
        opR n = OpCodes.OpReplaceDisks iname (lookNode n)
                OpCodes.ReplaceNewSecondary [] Nothing
    in case move of
         Failover -> [ opF ]
         ReplacePrimary np -> [ opF, opR np, opF ]
         ReplaceSecondary ns -> [ opR ns ]
         ReplaceAndFailover np -> [ opR np, opF ]
         FailoverAndReplace ns -> [ opF, opR ns ]
926
927

-- | Computes the group of an instance
Iustin Pop's avatar
Iustin Pop committed
928
instanceGroup :: Node.List -> Instance.Instance -> Result Gdx
929
930
931
932
933
934
instanceGroup nl i =
  let sidx = Instance.sNode i
      pnode = Container.find (Instance.pNode i) nl
      snode = if sidx == Node.noSecondary
              then pnode
              else Container.find sidx nl
Iustin Pop's avatar
Iustin Pop committed
935
936
937
938
939
940
      pgroup = Node.group pnode
      sgroup = Node.group snode
  in if pgroup /= sgroup
     then fail ("Instance placed accross two node groups, primary " ++
                show pgroup ++ ", secondary " ++ show sgroup)
     else return pgroup
941
942
943
944
945
946

-- | Compute the list of badly allocated instances (split across node
-- groups)
findSplitInstances :: Node.List -> Instance.List -> [Instance.Instance]
findSplitInstances nl il =
  filter (not . isOk . instanceGroup nl) (Container.elems il)
947
948
949

-- | Splits a cluster into the component node groups
splitCluster :: Node.List -> Instance.List ->
Iustin Pop's avatar
Iustin Pop committed
950
                [(Gdx, (Node.List, Instance.List))]
951
952
953
954
955
956
957
splitCluster nl il =
  let ngroups = Node.computeGroups (Container.elems nl)
  in map (\(guuid, nodes) ->
           let nidxs = map Node.idx nodes
               nodes' = zip nidxs nodes
               instances = Container.filter ((`elem` nidxs) . Instance.pNode) il
           in (guuid, (Container.fromAssocList nodes', instances))) ngroups