content: {-| Implementation of handling of Allocation Solutions
  
  -}
  
  {-
  
  Copyright (C) 2009, 2010, 2011, 2012, 2013, 2015 Google Inc.
  All rights reserved.
  
  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions are
  met:
  
  1. Redistributions of source code must retain the above copyright notice,
  this list of conditions and the following disclaimer.
  
  2. Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.
  
  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
  IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  
  -}
  
  module Ganeti.HTools.Cluster.AllocationSolution
    ( GenericAllocElement
    , AllocElement
    , GenericAllocSolution(..)
    , AllocSolution
    , emptyAllocSolution
    , sumAllocs
    , concatAllocs
    , updateIl
    , extractNl
    , collapseFailures
    , genericAnnotateSolution
    , annotateSolution
    , solutionDescription
    , AllocSolutionCollection
    , emptyAllocCollection
    , concatAllocCollections
    , collectionToSolution
    ) where
  
  import Data.Ord (comparing)
  import Data.List (intercalate, foldl', sortBy)
  import Data.Maybe (listToMaybe)
  import Text.Printf (printf)
  
  import Ganeti.BasicTypes (GenericResult(..), Result)
  import qualified Ganeti.HTools.Container as Container
  import qualified Ganeti.HTools.Group as Group
  import qualified Ganeti.HTools.Instance as Instance
  import qualified Ganeti.HTools.Node as Node
  import qualified Ganeti.HTools.Types as T
  
  -- | A simple name for an allocation element (here just for logistic
  -- reasons), generic in the type of the metric.
  type GenericAllocElement a = (Node.List, Instance.Instance, [Node.Node], a)
  
  -- | Obtain the metric of a GenericAllocElement.
  allocMetric :: GenericAllocElement a -> a
  allocMetric (_, _, _, a) = a
  
  -- | A simple name for an allocation element (here just for logistic
  -- reasons).
  type AllocElement = GenericAllocElement T.Score
  
  -- | Allocation\/relocation solution.
  data GenericAllocSolution a = AllocSolution
    { asFailures :: [T.FailMode]            -- ^ Failure counts
    , asAllocs   :: Int                     -- ^ Good allocation count
    , asSolution :: Maybe (GenericAllocElement a) -- ^ The actual allocation
                                            -- result
    , asLog      :: [String]                -- ^ Informational messages
    }
  type AllocSolution = GenericAllocSolution T.Score
  
  -- | The empty solution we start with when computing allocations.
  emptyAllocSolution :: GenericAllocSolution a
  emptyAllocSolution = AllocSolution { asFailures = [], asAllocs = 0
                                     , asSolution = Nothing, asLog = [] }
  
  
  -- | Calculate the new instance list after allocation solution.
  updateIl :: Instance.List           -- ^ The original instance list
           -> Maybe (GenericAllocElement a) -- ^ The result of
                                            -- the allocation attempt
           -> Instance.List           -- ^ The updated instance list
  updateIl il Nothing = il
  updateIl il (Just (_, xi, _, _)) = Container.add (Container.size il) xi il
  
  -- | Extract the the new node list from the allocation solution.
  extractNl :: Node.List               -- ^ The original node list
            -> Instance.List           -- ^ The original instance list
            -> Maybe (GenericAllocElement a) -- ^ The result of the
                                             -- allocation attempt
            -> Node.List               -- ^ The new node list
  extractNl nl _ Nothing = nl
  extractNl _ il (Just (xnl, _, ns, _)) =
    let newIndex = Container.size il
        fixIndex = map (\i -> if i < 0 then newIndex else i)
        fixIndices nodes node =
          let nidx = Node.idx node
              n = Container.find nidx nodes
              n' = n { Node.pList = fixIndex $ Node.pList n
                     , Node.sList = fixIndex $ Node.sList n
                     }
          in Container.add nidx n' nodes
    in foldl fixIndices xnl ns
  
  -- | Compares two Maybe AllocElement and chooses the best score.
  bestAllocElement :: Ord a
                   => Maybe (GenericAllocElement a)
                   -> Maybe (GenericAllocElement a)
                   -> Maybe (GenericAllocElement a)
  bestAllocElement a Nothing = a
  bestAllocElement Nothing b = b
  bestAllocElement a@(Just (_, _, _, ascore)) b@(Just (_, _, _, bscore)) =
    if ascore < bscore then a else b
  
  -- | Update current Allocation solution and failure stats with new
  -- elements.
  concatAllocs :: Ord a
               => GenericAllocSolution a
               -> T.OpResult (GenericAllocElement a)
               -> GenericAllocSolution a
  concatAllocs as (Bad reason) = as { asFailures = reason : asFailures as }
  
  concatAllocs as (Ok ns) =
    let -- Choose the old or new solution, based on the cluster score
      cntok = asAllocs as
      osols = asSolution as
      nsols = bestAllocElement osols (Just ns)
      nsuc = cntok + 1
      -- 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
      -- elements of the tuple
    in nsols `seq` nsuc `seq` as { asAllocs = nsuc, asSolution = nsols }
  
  -- | Sums two 'AllocSolution' structures.
  sumAllocs :: Ord a
            => GenericAllocSolution a
            -> GenericAllocSolution a
            -> GenericAllocSolution a
  sumAllocs (AllocSolution aFails aAllocs aSols aLog)
            (AllocSolution bFails bAllocs bSols bLog) =
    -- note: we add b first, since usually it will be smaller; when
    -- fold'ing, a will grow and grow whereas b is the per-group
    -- result, hence smaller
    let nFails  = bFails ++ aFails
        nAllocs = aAllocs + bAllocs
        nSols   = bestAllocElement aSols bSols
        nLog    = bLog ++ aLog
    in AllocSolution nFails nAllocs nSols nLog
  
  -- | Build failure stats out of a list of failures.
  collapseFailures :: [T.FailMode] -> T.FailStats
  collapseFailures flst =
      map (\k -> (k, foldl' (\a e -> if e == k then a + 1 else a) 0 flst))
              [minBound..maxBound]
  
  
  -- | Given a solution, generates a reasonable description for it.
  genericDescribeSolution :: (a -> String) -> GenericAllocSolution a -> String
  genericDescribeSolution formatMetrics as =
    let fcnt = asFailures as
        sols = asSolution as
        freasons =
          intercalate ", " . map (\(a, b) -> printf "%s: %d" (show a) b) .
          filter ((> 0) . snd) . collapseFailures $ fcnt
    in case sols of
       Nothing -> "No valid allocation solutions, failure reasons: " ++
                  (if null fcnt then "unknown reasons" else freasons)
       Just (_, _, nodes, cv) ->
           printf ("score: %s, successes %d, failures %d (%s)" ++
                   " for node(s) %s") (formatMetrics cv) (asAllocs as)
                 (length fcnt) freasons
                 (intercalate "/" . map Node.name $ nodes)
  
  -- | Annotates a solution with the appropriate string.
  genericAnnotateSolution :: (a -> String)
                          ->GenericAllocSolution a -> GenericAllocSolution a
  genericAnnotateSolution formatMetrics as =
    as { asLog = genericDescribeSolution formatMetrics as : asLog as }
  
  -- | Annotate a solution based on the standard metrics
  annotateSolution :: AllocSolution -> AllocSolution
  annotateSolution = genericAnnotateSolution (printf "%.8f")
  
  
  -- | Given a group/result, describe it as a nice (list of) messages.
  solutionDescription :: (Group.Group, Result (GenericAllocSolution a))
                      -> [String]
  solutionDescription (grp, result) =
    case result of
      Ok solution -> map (printf "Group %s (%s): %s" gname pol) (asLog solution)
      Bad message -> [printf "Group %s: error %s" gname message]
    where gname = Group.name grp
          pol = T.allocPolicyToRaw (Group.allocPolicy grp)
  
  -- * Collection of Allocation Solutions for later filtering
  
  -- | Collection of Allocation Solution
  data AllocSolutionCollection a = AllocSolutionCollection
    { ascFailures  :: [T.FailMode]            -- ^ Failure counts
    , ascAllocs    :: Int                     -- ^ Good allocation count
    , ascSolutions :: [GenericAllocElement a] -- ^ The actual allocation results
    , ascLog       :: [String]                -- ^ Informational messages
    }
  
  -- | Empty collection of allocation solutions.
  emptyAllocCollection :: AllocSolutionCollection a
  emptyAllocCollection = AllocSolutionCollection
                           { ascFailures = []
                           , ascAllocs = 0
                           , ascSolutions = []
                           , ascLog = []
                           }
  
  -- | Update current collection of solution and failure stats with new
  -- elements.
  concatAllocCollections :: Ord a
                         => AllocSolutionCollection a
                         -> T.OpResult (GenericAllocElement a)
                         -> AllocSolutionCollection a
  concatAllocCollections asc (Bad reason) =
    asc { ascFailures = reason : ascFailures asc }
  
  concatAllocCollections asc (Ok ns) =
    asc { ascAllocs = ascAllocs asc + 1, ascSolutions = ns : ascSolutions asc }
  
  -- | From a collection of solutions collapse to a single one by chosing the best
  -- that fulfills a given predicate.
  collectionToSolution :: Ord a
                       => T.FailMode -- ^ Failure mode to assign to solutions
                                     -- filtered out in this step
                       -> (GenericAllocElement a -> Bool) -- ^ predicate
                                                          -- to restrict to
                       -> AllocSolutionCollection a
                       -> GenericAllocSolution a
  collectionToSolution failmode isgood asc =
    let sols = sortBy (comparing allocMetric) $ ascSolutions asc
        (dropped, good) = break isgood sols
        dropcount = length dropped
        nsols = ascAllocs asc - dropcount
        failures = replicate dropcount failmode ++ ascFailures asc
        sol = listToMaybe good
    in AllocSolution { asFailures = failures
                     , asAllocs = nsols
                     , asSolution = sol
                     , asLog = ascLog asc
                     }
  