{-| Implementation of special handling of dedicated clusters.

-}

{-

Copyright (C) 2014 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.Dedicated
  ( isDedicated
  , testInstances
  , allocationVector
  , Metric
  , lostAllocationsMetric
  , allocateOnSingle
  , allocateOnPair
  , findAllocation
  , runDedicatedAllocation
  ) where

import Prelude ()
import Ganeti.Prelude

import Control.Applicative (liftA2)
import Control.Arrow ((&&&))
import Control.Monad (unless, liftM, foldM, mplus)
import qualified Data.Foldable as F
import Data.Function (on)
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import Data.List (sortBy, intercalate)

import Ganeti.BasicTypes (iterateOk, Result, failError)
import qualified Ganeti.HTools.AlgorithmParams as Alg
import qualified Ganeti.HTools.Backend.IAlloc as IAlloc
import qualified Ganeti.HTools.Cluster as Cluster
import qualified Ganeti.HTools.Cluster.AllocationSolution as AllocSol
import qualified Ganeti.HTools.Cluster.Utils as ClusterUtils
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.Loader as Loader
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Types as T

-- | Given a cluster description and maybe a group name, decide
-- if that group, or all allocatable groups if no group is given,
-- is dedicated.
isDedicated :: Loader.ClusterData -> Maybe String -> Bool
isDedicated cdata maybeGroup =
  let groups =
        IntMap.keysSet
        . IntMap.filter (maybe ((/=) T.AllocUnallocable . Group.allocPolicy)
                               (\name -> (==) name . Group.name) maybeGroup)
        $ Loader.cdGroups cdata
  in F.all (liftA2 (||) Node.exclStorage
            $ not  . (`IntSet.member` groups) . Node.group)
     $ Loader.cdNodes cdata

-- | Given a specification interval, create an instance minimally fitting
-- into that interval. In other words create an instance from the lower bounds
-- of the specified interval.
minimallyCompliantInstance :: T.ISpec -> Instance.Instance
minimallyCompliantInstance spec =
  Instance.create "minimalspecinstance"
    (T.iSpecMemorySize spec)
    (T.iSpecDiskSize spec)
    []
    (T.iSpecCpuCount spec)
    T.Running [] False Node.noSecondary Node.noSecondary T.DTPlain
    (T.iSpecSpindleUse spec)
    [] False

-- | From an instance policy get the list of test instances, in correct order,
-- for which the allocation count has to be determined for the lost allocations
-- metrics.
testInstances :: T.IPolicy -> [Instance.Instance]
testInstances =
  map minimallyCompliantInstance
  . sortBy (flip compare `on` T.iSpecDiskSize)
  . map T.minMaxISpecsMinSpec
  . T.iPolicyMinMaxISpecs

-- | Given the test instances, compute the allocations vector of a node
allocationVector :: [Instance.Instance] -> Node.Node -> [Int]
allocationVector insts node =
  map (\ inst -> length $ iterateOk (`Node.addPri` inst) node) insts

-- | The metric do be used in dedicated allocation.
type Metric = ([Int], Int)

-- | Given the test instances and an instance to be placed, compute
-- the lost allocations metrics for that node, together with the
-- modified node. Return Bad if it is not possible to place the
-- instance on that node.
lostAllocationsMetric :: Alg.AlgorithmOptions
                      -> [Instance.Instance]
                      -> Instance.Instance
                      -> Node.Node
                      -> T.OpResult (Metric, Node.Node)
lostAllocationsMetric opts insts inst node = do
  let allocVec = allocationVector insts
      before = allocVec node
      force = Alg.algIgnoreSoftErrors opts
  node' <- Node.addPriEx force node inst
  let after = allocVec node'
      disk = Node.fDsk node'
  return ((zipWith (-) before after, disk), node')

-- | Allocate an instance on a given node.
allocateOnSingle :: Alg.AlgorithmOptions
                 -> Node.List -> Instance.Instance -> T.Ndx
                 -> T.OpResult (AllocSol.GenericAllocElement Metric)
allocateOnSingle opts nl inst new_pdx = do
  let primary = Container.find new_pdx nl
      policy = Node.iPolicy primary
      testInst = testInstances policy
      excl = Node.exclStorage primary
      new_inst = Instance.setBoth inst new_pdx Node.noSecondary
  Instance.instMatchesPolicy inst policy excl
  (metrics, new_p) <- lostAllocationsMetric opts testInst inst primary
  let new_nl = Container.add new_pdx new_p nl
  return (new_nl, new_inst, [new_p], metrics)

-- | Allocate an instance on a given pair of nodes.
allocateOnPair :: Alg.AlgorithmOptions
               -> Node.List
               -> Instance.Instance
               -> T.Ndx
               -> T.Ndx
               -> T.OpResult (AllocSol.GenericAllocElement Metric)
allocateOnPair opts nl inst pdx sdx = do
  let primary = Container.find pdx nl
      secondary = Container.find sdx nl
      policy = Node.iPolicy primary
      testInst = testInstances policy
      inst' = Instance.setBoth inst pdx sdx
  Instance.instMatchesPolicy inst policy (Node.exclStorage primary)
  ((lAllP, dskP), primary') <- lostAllocationsMetric opts testInst inst' primary
  secondary' <- Node.addSec secondary inst' pdx
  let lAllS =  zipWith (-) (allocationVector testInst secondary)
                           (allocationVector testInst secondary')
      dskS = Node.fDsk secondary'
      metric = (zipWith (+) lAllP lAllS, dskP + dskS)
      nl' = Container.addTwo pdx primary' sdx secondary' nl
  return (nl', inst', [primary', secondary'], metric)

-- | Find an allocation for an instance on a group.
findAllocation :: Alg.AlgorithmOptions
               -> Group.List
               -> Node.List
               -> T.Gdx
               -> Instance.Instance
               -> Int
               -> Result (AllocSol.GenericAllocSolution Metric, [String])
findAllocation opts mggl mgnl gdx inst count = do
  let nl = Container.filter ((== gdx) . Node.group) mgnl
      group = Container.find gdx mggl
  unless (Cluster.hasRequiredNetworks group inst) . failError
         $ "The group " ++ Group.name group ++ " is not connected to\
           \ a network required by instance " ++ Instance.name inst
  allocNodes <- Cluster.genAllocNodes opts mggl nl count False
  solution <- case allocNodes of
    (Right []) -> fail "Not enough online nodes"
    (Right pairs) ->
      let sols = foldl AllocSol.sumAllocs AllocSol.emptyAllocSolution
                   $ map (\(p, ss) -> foldl
                           (\cstate ->
                             AllocSol.concatAllocs cstate
                             . allocateOnPair opts nl inst p)
                           AllocSol.emptyAllocSolution ss)
                     pairs
       in return $ AllocSol.genericAnnotateSolution show sols
    (Left []) -> fail "No online nodes"
    (Left nodes) ->
      let sols = foldl (\cstate ->
                          AllocSol.concatAllocs cstate
                          . allocateOnSingle opts nl inst)
                       AllocSol.emptyAllocSolution nodes
      in return $ AllocSol.genericAnnotateSolution show sols
  return (solution, AllocSol.solutionDescription (group, return solution))

-- | Find an allocation in a suitable group.
findMGAllocation :: Alg.AlgorithmOptions
                 -> Group.List
                 -> Node.List
                 -> Instance.List
                 -> Instance.Instance
                 -> Int
                 -> Result (AllocSol.GenericAllocSolution Metric)
findMGAllocation opts gl nl il inst count = do
  let groups_by_idx = ClusterUtils.splitCluster nl il
      genSol (gdx, (nl', _)) =
        liftM fst $ findAllocation opts gl nl' gdx inst count
      sols = map (flip Container.find gl . fst &&& genSol) groups_by_idx
      goodSols = Cluster.sortMGResults $ Cluster.filterMGResults sols
      all_msgs = concatMap AllocSol.solutionDescription sols
  case goodSols of
    [] -> fail $ intercalate ", " all_msgs
    (final_group, final_sol):_ ->
      let sel_msg = "Selected group: " ++ Group.name final_group
      in return $ final_sol { AllocSol.asLog = sel_msg : all_msgs }

-- | Handle allocation requests in the dedicated scenario.
runDedicatedAllocation :: Alg.AlgorithmOptions
                       -> Loader.Request
                       -> (Maybe (Node.List, Instance.List), String)
runDedicatedAllocation opts request =
  let Loader.Request rqtype (Loader.ClusterData gl nl il _ _) = request
      allocresult =
        case rqtype of
          Loader.Allocate inst (Cluster.AllocDetails count (Just gn)) rNds -> do
            gdx <- Group.idx <$> Container.findByName gl gn
            let opts' = opts { Alg.algRestrictToNodes =
                                 Alg.algRestrictToNodes opts `mplus` rNds }
            (solution, msgs) <- findAllocation opts' gl nl gdx inst count
            IAlloc.formatAllocate il $ solution { AllocSol.asLog = msgs }
          Loader.Allocate inst (Cluster.AllocDetails count Nothing) rNds ->
            let opts' = opts { Alg.algRestrictToNodes =
                                 Alg.algRestrictToNodes opts `mplus` rNds }
            in findMGAllocation opts' gl nl il inst count
                 >>= IAlloc.formatAllocate il
          Loader.MultiAllocate insts ->
            IAlloc.formatMultiAlloc =<< foldM
              (\(nl', il', res)
                (inst, Cluster.AllocDetails count maybeGroup) -> do
                  ares <- maybe (findMGAllocation opts gl nl' il' inst count)
                            (\gn -> do
                               gdx <- Group.idx <$> Container.findByName gl gn
                               liftM fst
                                 $ findAllocation opts gl nl gdx inst count)
                          maybeGroup
                  let sol = AllocSol.asSolution ares
                      nl'' = AllocSol.extractNl nl' il' sol
                      il'' = AllocSol.updateIl il' sol
                  return (nl'', il'', (inst, ares):res))
               (nl, il, []) insts
          _ -> fail "Dedicated Allocation only for proper allocation requests"
  in IAlloc.formatIAllocResult allocresult