{-| Generic data loader.

This module holds the common code for parsing the input data after it
has been loaded from external sources.

-}

{-

Copyright (C) 2009, 2010, 2011, 2012 Google Inc.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

module Ganeti.HTools.Loader
  ( mergeData
  , checkData
  , assignIndices
  , setMaster
  , lookupNode
  , lookupInstance
  , lookupGroup
  , eitherLive
  , commonSuffix
  , extractExTags
  , updateExclTags
  , RqType(..)
  , Request(..)
  , ClusterData(..)
  , emptyCluster
  ) where

import Control.Monad
import Data.List
import qualified Data.Map as M
import Data.Maybe
import Text.Printf (printf)
import System.Time (ClockTime(..))

import qualified Ganeti.HTools.Container as Container
import qualified Ganeti.HTools.Instance as Instance
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Group as Group
import qualified Ganeti.HTools.Cluster as Cluster

import Ganeti.BasicTypes
import qualified Ganeti.Constants as C
import Ganeti.HTools.Types
import Ganeti.Utils

-- * Constants

-- | The exclusion tag prefix.
exTagsPrefix :: String
exTagsPrefix = "htools:iextags:"

-- * Types

{-| The iallocator request type.

This type denotes what request we got from Ganeti and also holds
request-specific fields.

-}
data RqType
  = Allocate Instance.Instance Int           -- ^ A new instance allocation
  | Relocate Idx Int [Ndx]                   -- ^ Choose a new secondary node
  | NodeEvacuate [Idx] EvacMode              -- ^ node-evacuate mode
  | ChangeGroup [Gdx] [Idx]                  -- ^ Multi-relocate mode
  | MultiAllocate [(Instance.Instance, Int)] -- ^ Multi-allocate mode
    deriving (Show)

-- | A complete request, as received from Ganeti.
data Request = Request RqType ClusterData
               deriving (Show)

-- | The cluster state.
data ClusterData = ClusterData
  { cdGroups    :: Group.List    -- ^ The node group list
  , cdNodes     :: Node.List     -- ^ The node list
  , cdInstances :: Instance.List -- ^ The instance list
  , cdTags      :: [String]      -- ^ The cluster tags
  , cdIPolicy   :: IPolicy       -- ^ The cluster instance policy
  } deriving (Show, Eq)

-- | An empty cluster.
emptyCluster :: ClusterData
emptyCluster = ClusterData Container.empty Container.empty Container.empty []
                 defIPolicy

-- * Functions

-- | Lookups a node into an assoc list.
lookupNode :: (Monad m) => NameAssoc -> String -> String -> m Ndx
lookupNode ktn inst node =
  maybe (fail $ "Unknown node '" ++ node ++ "' for instance " ++ inst) return $
    M.lookup node ktn

-- | Lookups an instance into an assoc list.
lookupInstance :: (Monad m) => NameAssoc -> String -> m Idx
lookupInstance kti inst =
  maybe (fail $ "Unknown instance '" ++ inst ++ "'") return $ M.lookup inst kti

-- | Lookups a group into an assoc list.
lookupGroup :: (Monad m) => NameAssoc -> String -> String -> m Gdx
lookupGroup ktg nname gname =
  maybe (fail $ "Unknown group '" ++ gname ++ "' for node " ++ nname) return $
    M.lookup gname ktg

-- | Given a list of elements (and their names), assign indices to them.
assignIndices :: (Element a) =>
                 [(String, a)]
              -> (NameAssoc, Container.Container a)
assignIndices name_element =
  let (name_idx, idx_element) =
          unzip . map (\ (idx, (k, v)) -> ((k, idx), (idx, setIdx v idx)))
          . zip [0..] $ name_element
  in (M.fromList name_idx, Container.fromList idx_element)

-- | Given am indexed node list, and the name of the master, mark it as such. 
setMaster :: (Monad m) => NameAssoc -> Node.List -> String -> m Node.List
setMaster node_names node_idx master = do
  kmaster <- maybe (fail $ "Master node " ++ master ++ " unknown") return $
             M.lookup master node_names
  let mnode = Container.find kmaster node_idx
  return $ Container.add kmaster (Node.setMaster mnode True) node_idx

-- | For each instance, add its index to its primary and secondary nodes.
fixNodes :: Node.List
         -> Instance.Instance
         -> Node.List
fixNodes accu inst =
  let pdx = Instance.pNode inst
      sdx = Instance.sNode inst
      pold = Container.find pdx accu
      pnew = Node.setPri pold inst
      ac2 = Container.add pdx pnew accu
  in if sdx /= Node.noSecondary
       then let sold = Container.find sdx accu
                snew = Node.setSec sold inst
            in Container.add sdx snew ac2
       else ac2

-- | Set the node's policy to its group one. Note that this requires
-- the group to exist (should have been checked before), otherwise it
-- will abort with a runtime error.
setNodePolicy :: Group.List -> Node.Node -> Node.Node
setNodePolicy gl node =
  let grp = Container.find (Node.group node) gl
      gpol = Group.iPolicy grp
  in Node.setPolicy gpol node

-- | Update instance with exclusion tags list.
updateExclTags :: [String] -> Instance.Instance -> Instance.Instance
updateExclTags tl inst =
  let allTags = Instance.allTags inst
      exclTags = filter (\tag -> any (`isPrefixOf` tag) tl) allTags
  in inst { Instance.exclTags = exclTags }

-- | Update the movable attribute.
updateMovable :: [String]           -- ^ Selected instances (if not empty)
              -> [String]           -- ^ Excluded instances
              -> Instance.Instance  -- ^ Target Instance
              -> Instance.Instance  -- ^ Target Instance with updated attribute
updateMovable selinsts exinsts inst =
  if Instance.name inst `elem` exinsts ||
     not (null selinsts || Instance.name inst `elem` selinsts)
    then Instance.setMovable inst False
    else inst

-- | Disables moves for instances with a split group.
disableSplitMoves :: Node.List -> Instance.Instance -> Instance.Instance
disableSplitMoves nl inst =
  if not . isOk . Cluster.instanceGroup nl $ inst
    then Instance.setMovable inst False
    else inst

-- | Set the auto-repair policy for an instance.
setArPolicy :: [String]       -- ^ Cluster tags
            -> Group.List     -- ^ List of node groups
            -> Node.List      -- ^ List of nodes
            -> Instance.List  -- ^ List of instances
            -> ClockTime      -- ^ Current timestamp, to evaluate ArSuspended
            -> Instance.List  -- ^ Updated list of instances
setArPolicy ctags gl nl il time =
  let getArPolicy' = flip getArPolicy time
      cpol = fromMaybe ArNotEnabled $ getArPolicy' ctags
      gpols = Container.map (fromMaybe cpol . getArPolicy' . Group.allTags) gl
      ipolfn = getArPolicy' . Instance.allTags
      nlookup = flip Container.find nl . Instance.pNode
      glookup = flip Container.find gpols . Node.group . nlookup
      updateInstance inst = inst {
        Instance.arPolicy = fromMaybe (glookup inst) $ ipolfn inst }
  in
   Container.map updateInstance il

-- | Get the auto-repair policy from a list of tags.
--
-- This examines the ganeti:watcher:autorepair and
-- ganeti:watcher:autorepair:suspend tags to determine the policy. If none of
-- these tags are present, Nothing (and not ArNotEnabled) is returned.
getArPolicy :: [String] -> ClockTime -> Maybe AutoRepairPolicy
getArPolicy tags time =
  let enabled = mapMaybe (autoRepairTypeFromRaw <=<
                          chompPrefix C.autoRepairTagEnabled) tags
      suspended = mapMaybe (chompPrefix C.autoRepairTagSuspended) tags
      futureTs = filter (> time) . map (flip TOD 0) $
                   mapMaybe (tryRead "auto-repair suspend time") suspended
  in
   case () of
     -- Note how we must return ArSuspended even if "enabled" is empty, so that
     -- node groups or instances can suspend repairs that were enabled at an
     -- upper scope (cluster or node group).
     _ | "" `elem` suspended -> Just $ ArSuspended Forever
       | not $ null futureTs -> Just . ArSuspended . Until . maximum $ futureTs
       | not $ null enabled  -> Just $ ArEnabled (minimum enabled)
       | otherwise           -> Nothing

-- | Compute the longest common suffix of a list of strings that
-- starts with a dot.
longestDomain :: [String] -> String
longestDomain [] = ""
longestDomain (x:xs) =
  foldr (\ suffix accu -> if all (isSuffixOf suffix) xs
                            then suffix
                            else accu)
          "" $ filter (isPrefixOf ".") (tails x)

-- | Extracts the exclusion tags from the cluster configuration.
extractExTags :: [String] -> [String]
extractExTags = filter (not . null) . mapMaybe (chompPrefix exTagsPrefix)

-- | Extracts the common suffix from node\/instance names.
commonSuffix :: Node.List -> Instance.List -> String
commonSuffix nl il =
  let node_names = map Node.name $ Container.elems nl
      inst_names = map Instance.name $ Container.elems il
  in longestDomain (node_names ++ inst_names)

-- | Initializer function that loads the data from a node and instance
-- list and massages it into the correct format.
mergeData :: [(String, DynUtil)]  -- ^ Instance utilisation data
          -> [String]             -- ^ Exclusion tags
          -> [String]             -- ^ Selected instances (if not empty)
          -> [String]             -- ^ Excluded instances
          -> ClockTime            -- ^ The current timestamp
          -> ClusterData          -- ^ Data from backends
          -> Result ClusterData   -- ^ Fixed cluster data
mergeData um extags selinsts exinsts time cdata@(ClusterData gl nl il ctags _) =
  let il2 = setArPolicy ctags gl nl il time
      il3 = foldl' (\im (name, n_util) ->
                        case Container.findByName im name of
                          Nothing -> im -- skipping unknown instance
                          Just inst ->
                              let new_i = inst { Instance.util = n_util }
                              in Container.add (Instance.idx inst) new_i im
                   ) il2 um
      allextags = extags ++ extractExTags ctags
      inst_names = map Instance.name $ Container.elems il3
      selinst_lkp = map (lookupName inst_names) selinsts
      exinst_lkp = map (lookupName inst_names) exinsts
      lkp_unknown = filter (not . goodLookupResult) (selinst_lkp ++ exinst_lkp)
      selinst_names = map lrContent selinst_lkp
      exinst_names = map lrContent exinst_lkp
      node_names = map Node.name (Container.elems nl)
      common_suffix = longestDomain (node_names ++ inst_names)
      il4 = Container.map (computeAlias common_suffix .
                           updateExclTags allextags .
                           updateMovable selinst_names exinst_names) il3
      nl2 = foldl' fixNodes nl (Container.elems il4)
      nl3 = Container.map (setNodePolicy gl .
                           computeAlias common_suffix .
                           (`Node.buildPeers` il4)) nl2
      il5 = Container.map (disableSplitMoves nl3) il4
  in if' (null lkp_unknown)
         (Ok cdata { cdNodes = nl3, cdInstances = il5 })
         (Bad $ "Unknown instance(s): " ++ show(map lrContent lkp_unknown))

-- | Checks the cluster data for consistency.
checkData :: Node.List -> Instance.List
          -> ([String], Node.List)
checkData nl il =
    Container.mapAccum
        (\ msgs node ->
             let nname = Node.name node
                 nilst = map (`Container.find` il) (Node.pList node)
                 dilst = filter Instance.instanceDown nilst
                 adj_mem = sum . map Instance.mem $ dilst
                 delta_mem = truncate (Node.tMem node)
                             - Node.nMem node
                             - Node.fMem node
                             - nodeImem node il
                             + adj_mem
                 delta_dsk = truncate (Node.tDsk node)
                             - Node.fDsk node
                             - nodeIdsk node il
                 newn = Node.setFmem (Node.setXmem node delta_mem)
                        (Node.fMem node - adj_mem)
                 umsg1 =
                   if delta_mem > 512 || delta_dsk > 1024
                      then printf "node %s is missing %d MB ram \
                                  \and %d GB disk"
                                  nname delta_mem (delta_dsk `div` 1024):msgs
                      else msgs
             in (umsg1, newn)
        ) [] nl

-- | Compute the amount of memory used by primary instances on a node.
nodeImem :: Node.Node -> Instance.List -> Int
nodeImem node il =
  let rfind = flip Container.find il
      il' = map rfind $ Node.pList node
      oil' = filter Instance.notOffline il'
  in sum . map Instance.mem $ oil'


-- | Compute the amount of disk used by instances on a node (either primary
-- or secondary).
nodeIdsk :: Node.Node -> Instance.List -> Int
nodeIdsk node il =
  let rfind = flip Container.find il
  in sum . map (Instance.dsk . rfind)
       $ Node.pList node ++ Node.sList node

-- | Get live information or a default value
eitherLive :: (Monad m) => Bool -> a -> m a -> m a
eitherLive True _ live_data = live_data
eitherLive False def_data _ = return def_data