content: {-| 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
                           -> Maybe Node.Node   -- ^ the secondary node of the
                                                -- ^ instance
                           -> Instance.Instance -- ^ the instance with the
                                                -- location score updated
  setInstanceLocationScore t _ Nothing = t { Instance.locationScore = 0 }
  setInstanceLocationScore t p (Just 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
                                                               (Just 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
                                                               (Just 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
                                                                (Just 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
                                                                (Just 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)
  