Revision 3ce8009a

b/Ganeti/HTools/Cluster.hs
59 59
    , tryReloc
60 60
    , tryEvac
61 61
    , collapseFailures
62
    -- * Allocation functions
63
    , iterateAlloc
64
    , tieredAlloc
62 65
    ) where
63 66

  
64 67
import Data.List
......
617 620
                        ) (nl, ([], 0, [])) all_insts
618 621
      return sol
619 622

  
623
-- | Recursively place instances on the cluster until we're out of space
624
iterateAlloc :: Node.List
625
             -> Instance.List
626
             -> Instance.Instance
627
             -> Int
628
             -> [Instance.Instance]
629
             -> Result (FailStats, Node.List, [Instance.Instance])
630
iterateAlloc nl il newinst nreq ixes =
631
      let depth = length ixes
632
          newname = printf "new-%d" depth::String
633
          newidx = length (Container.elems il) + depth
634
          newi2 = Instance.setIdx (Instance.setName newinst newname) newidx
635
      in case tryAlloc nl il newi2 nreq of
636
           Bad s -> Bad s
637
           Ok (errs, _, sols3) ->
638
               case sols3 of
639
                 [] -> Ok (collapseFailures errs, nl, ixes)
640
                 (_, (xnl, xi, _)):[] ->
641
                     iterateAlloc xnl il newinst nreq $! (xi:ixes)
642
                 _ -> Bad "Internal error: multiple solutions for single\
643
                          \ allocation"
644

  
645
tieredAlloc :: Node.List
646
            -> Instance.List
647
            -> Instance.Instance
648
            -> Int
649
            -> [Instance.Instance]
650
            -> Result (FailStats, Node.List, [Instance.Instance])
651
tieredAlloc nl il newinst nreq ixes =
652
    case iterateAlloc nl il newinst nreq ixes of
653
      Bad s -> Bad s
654
      Ok (errs, nl', ixes') ->
655
          case Instance.shrinkByType newinst . fst . last $
656
               sortBy (comparing snd) errs of
657
            Bad _ -> Ok (errs, nl', ixes')
658
            Ok newinst' ->
659
                tieredAlloc nl' il newinst' nreq ixes'
660

  
620 661
-- * Formatting functions
621 662

  
622 663
-- | Given the original and final nodes, computes the relocation description.
b/hspace.hs
117 117
              , ("VCPU", printf "%d" . Cluster.csVcpu)
118 118
              ]
119 119

  
120
-- | Recursively place instances on the cluster until we're out of space
121
iterateDepth :: Node.List
122
             -> Instance.List
123
             -> Instance.Instance
124
             -> Int
125
             -> [Instance.Instance]
126
             -> Result (FailStats, Node.List, [Instance.Instance])
127
iterateDepth nl il newinst nreq ixes =
128
      let depth = length ixes
129
          newname = printf "new-%d" depth::String
130
          newidx = length (Container.elems il) + depth
131
          newi2 = Instance.setIdx (Instance.setName newinst newname) newidx
132
      in case Cluster.tryAlloc nl il newi2 nreq of
133
           Bad s -> Bad s
134
           Ok (errs, _, sols3) ->
135
               case sols3 of
136
                 [] -> Ok (Cluster.collapseFailures errs, nl, ixes)
137
                 (_, (xnl, xi, _)):[] ->
138
                     iterateDepth xnl il newinst nreq $! (xi:ixes)
139
                 _ -> Bad "Internal error: multiple solutions for single\
140
                          \ allocation"
141

  
142
tieredAlloc :: Node.List
143
            -> Instance.List
144
            -> Instance.Instance
145
            -> Int
146
            -> [Instance.Instance]
147
            -> Result (FailStats, Node.List, [Instance.Instance])
148
tieredAlloc nl il newinst nreq ixes =
149
    case iterateDepth nl il newinst nreq ixes of
150
      Bad s -> Bad s
151
      Ok (errs, nl', ixes') ->
152
          case Instance.shrinkByType newinst . fst . last $
153
               sortBy (comparing snd) errs of
154
            Bad _ -> Ok (errs, nl', ixes')
155
            Ok newinst' ->
156
                tieredAlloc nl' il newinst' nreq ixes'
157

  
158

  
159 120
-- | Function to print stats for a given phase
160 121
printStats :: Phase -> Cluster.CStats -> [(String, String)]
161 122
printStats ph cs =
......
320 281
       (_, trl_nl, trl_ixes) <-
321 282
           if stop_allocation
322 283
           then return result_noalloc
323
           else exitifbad (tieredAlloc nl il (iofspec tspec) req_nodes [])
284
           else exitifbad (Cluster.tieredAlloc nl il (iofspec tspec)
285
                                  req_nodes [])
324 286
       let fin_trl_ixes = reverse trl_ixes
325 287
           ix_byspec = groupBy ((==) `on` Instance.specOf) fin_trl_ixes
326 288
           spec_map = map (\ixs -> (Instance.specOf $ head ixs, length ixs))
......
350 312
  (ereason, fin_nl, ixes) <-
351 313
      if stop_allocation
352 314
      then return result_noalloc
353
      else exitifbad (iterateDepth nl il reqinst req_nodes [])
315
      else exitifbad (Cluster.iterateAlloc nl il reqinst req_nodes [])
354 316

  
355 317
  let allocs = length ixes
356 318
      fin_ixes = reverse ixes

Also available in: Unified diff