{-| Implementation of instance moves in a cluster.

-}

{-

Copyright (C) 2009, 2010, 2011, 2012, 2013 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.Moves
  ( applyMoveEx
  , setInstanceLocationScore
  , move
  ) where

import qualified Data.Set as Set

import Ganeti.HTools.Types
import qualified Ganeti.HTools.Container as Container
import qualified Ganeti.HTools.Instance as Instance
import qualified Ganeti.HTools.Node as Node

-- | Extracts the node pairs for an instance. This can fail if the
-- instance is single-homed. FIXME: this needs to be improved,
-- together with the general enhancement for handling non-DRBD moves.
instanceNodes :: Node.List -> Instance.Instance ->
                 (Ndx, Ndx, Node.Node, Node.Node)
instanceNodes nl inst =
  let old_pdx = Instance.pNode inst
      old_sdx = Instance.sNode inst
      old_p = Container.find old_pdx nl
      old_s = Container.find old_sdx nl
  in (old_pdx, old_sdx, old_p, old_s)

-- | Sets the location score of an instance, given its primary
-- and secondary node.
setInstanceLocationScore :: Instance.Instance -- ^ the original instance
                         -> Node.Node -- ^ the primary node of the instance
                         -> Node.Node -- ^ the secondary node of the instance
                         -> Instance.Instance -- ^ the instance with the
                                              -- location score updated
setInstanceLocationScore t p s =
  t { Instance.locationScore =
         Set.size $ Node.locationTags p `Set.intersection` Node.locationTags s }

-- | Applies an instance move to a given node list and instance.
applyMoveEx :: Bool -- ^ whether to ignore soft errors
               -> Node.List -> Instance.Instance
               -> IMove -> OpResult (Node.List, Instance.Instance, Ndx, Ndx)
-- Failover (f)
applyMoveEx force nl inst Failover =
  let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
      int_p = Node.removePri old_p inst
      int_s = Node.removeSec old_s inst
      new_nl = do -- OpResult
        Node.checkMigration old_p old_s
        new_p <- Node.addPriEx (Node.offline old_p || force) int_s inst
        new_s <- Node.addSecExEx (Node.offline old_p)
                   (Node.offline old_p || force) int_p inst old_sdx
        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

-- Failover to any (fa)
applyMoveEx force nl inst (FailoverToAny new_pdx) = do
  let (old_pdx, old_sdx, old_pnode, _) = instanceNodes nl inst
      new_pnode = Container.find new_pdx nl
      force_failover = Node.offline old_pnode || force
  Node.checkMigration old_pnode new_pnode
  new_pnode' <- Node.addPriEx force_failover new_pnode inst
  let old_pnode' = Node.removePri old_pnode inst
      inst' = Instance.setPri inst new_pdx
      nl' = Container.addTwo old_pdx old_pnode' new_pdx new_pnode' nl
  return (nl', inst', new_pdx, old_sdx)

-- Replace the primary (f:, r:np, f)
applyMoveEx force nl inst (ReplacePrimary new_pdx) =
  let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
      tgt_n = Container.find new_pdx nl
      int_p = Node.removePri old_p inst
      int_s = Node.removeSec old_s inst
      new_inst = Instance.setPri (setInstanceLocationScore inst tgt_n int_s)
                 new_pdx
      force_p = Node.offline old_p || force
      new_nl = do -- OpResult
                  -- check that the current secondary can host the instance
                  -- during the migration
        Node.checkMigration old_p old_s
        Node.checkMigration old_s tgt_n
        tmp_s <- Node.addPriEx force_p int_s new_inst
        let tmp_s' = Node.removePri tmp_s new_inst
        new_p <- Node.addPriEx force_p tgt_n new_inst
        new_s <- Node.addSecEx force_p tmp_s' new_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

-- Replace the secondary (r:ns)
applyMoveEx force nl inst (ReplaceSecondary new_sdx) =
  let old_pdx = Instance.pNode inst
      old_sdx = Instance.sNode inst
      old_s = Container.find old_sdx nl
      tgt_n = Container.find new_sdx nl
      pnode = Container.find old_pdx nl
      pnode' = Node.removePri pnode inst
      int_s = Node.removeSec old_s inst
      force_s = Node.offline old_s || force
      new_inst = Instance.setSec (setInstanceLocationScore inst pnode tgt_n)
                 new_sdx
      new_nl = do
        new_s <- Node.addSecEx force_s tgt_n new_inst old_pdx
        pnode'' <- Node.addPriEx True pnode' new_inst
        return (Container.add old_pdx pnode'' $
                Container.addTwo new_sdx new_s old_sdx int_s nl,
                new_inst, old_pdx, new_sdx)
  in new_nl

-- Replace the secondary and failover (r:np, f)
applyMoveEx force nl inst (ReplaceAndFailover new_pdx) =
  let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
      tgt_n = Container.find new_pdx nl
      int_p = Node.removePri old_p inst
      int_s = Node.removeSec old_s inst
      new_inst = Instance.setBoth (setInstanceLocationScore inst tgt_n int_p)
                 new_pdx old_pdx
      force_s = Node.offline old_s || force
      new_nl = do -- OpResult
        Node.checkMigration old_p tgt_n
        new_p <- Node.addPriEx force tgt_n new_inst
        new_s <- Node.addSecEx force_s int_p new_inst new_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

-- Failver and replace the secondary (f, r:ns)
applyMoveEx force nl inst (FailoverAndReplace new_sdx) =
  let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
      tgt_n = Container.find new_sdx nl
      int_p = Node.removePri old_p inst
      int_s = Node.removeSec old_s inst
      force_p = Node.offline old_p || force
      new_inst = Instance.setBoth (setInstanceLocationScore inst int_s tgt_n)
                 old_sdx new_sdx
      new_nl = do -- OpResult
        Node.checkMigration old_p old_s
        new_p <- Node.addPriEx force_p int_s new_inst
        new_s <- Node.addSecEx force_p tgt_n new_inst old_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

-- | Apply a move to an instance, ignoring soft errors. This is a
-- variant of `applyMoveEx True` suitable for folding.
move :: (Node.List, Instance.List)
        -> (Idx, IMove)
        -> OpResult (Node.List, Instance.List)
move (nl, il) (idx, mv) = do
  let inst = Container.find idx il
  (nl', inst', _, _) <- applyMoveEx True nl inst mv
  return (nl', Container.add idx inst' il)