src/Ganeti/HTools/Cluster/AllocationSolution.hs - ganeti - Git at Google

 {-| 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
                    }
	{-\| 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
	}