src/Ganeti/HTools/Cluster/MetricsTH.hs

{-# LANGUAGE TemplateHaskell #-}

{-| Declaration of the datatypes and functions dealing with cluster metrics
    generated by template haskell.

-}

{-

Copyright (C) 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.MetricsTH
  ( MetricComponent(..)
  , declareStatistics
  ) where

import Data.List (partition)
import Data.Maybe (mapMaybe)
import Language.Haskell.TH
import Text.Printf (printf)

import qualified Ganeti.HTools.Node as Node
import Ganeti.Utils (printTable)
import Ganeti.Utils.Statistics

-- | Data type describing the metric component. The information provided by
-- this data type is used to generate statistics data types and functions
-- dealing with them
data MetricComponent = MetricComponent
  { name           :: String -- ^ The component name
  , weight         :: Q Exp  -- ^ The component weight in the statistics sum
  , fromNode       :: Q Exp  -- ^ Quasi quoted function obtaining spread value
                             -- from a node given (Node.Node -> fromNodeType)
  , fromNodeType   :: Q Type -- ^ Quasi quoted spread value type
  , statisticsType :: Q Type -- ^ Quasi quoted statistics data type. Stat
                             -- instance for fromNodeType and statisticsType
                             -- should be defined
  , forOnlineNodes :: Bool   -- ^ Whether this component should be calculated
                             -- for online or offline nodes
  , optimalValue   :: Maybe ExpQ  -- ^ Maybe quasi quoted function obtaining
                                  -- optimal value of such component
                                  -- (Node.List -> Double)
  }

-- | Declares all functions and data types implemented in template haskell
declareStatistics :: [MetricComponent] -> Q [Dec]
declareStatistics components = do
  nodeValues              <- nodeValuesDecl components
  getNodeValues           <- getNodeValuesDecl components
  clusterStatistics       <- clusterStatisticsDecl components
  compClusterStatistics   <- compClusterStatisticsDecl components
  updateClusterStatistics <- updateClusterStatisticsDecl components
  compCVfromStats         <- compCVfromStatsDecl components
  showClusterStatistics   <- showClusterStatisticsDecl components
  optimalCVScore          <- optimalCVScoreDecl components
  return $ nodeValues ++ getNodeValues ++ clusterStatistics ++
           compClusterStatistics ++ updateClusterStatistics ++
           compCVfromStats ++ showClusterStatistics ++
           optimalCVScore

-- | Helper function constructing VarStringTypeQ
getVarStrictTypeQ :: (String, Q Type) -> VarStrictTypeQ
getVarStrictTypeQ (n, t) = do
  t' <- t
  return (mkName n, NotStrict, t')

-- | Function constructs NodeValues data type for metric components given.
-- The data type is used to store all spread values of one Node.
nodeValuesDecl :: [MetricComponent] -> Q [Dec]
nodeValuesDecl components = do
  let names = map (("nv_" ++ ) . name ) components
      types = map fromNodeType components
  strict_types <- mapM getVarStrictTypeQ $ zip names types
  return [DataD [] (mkName "NodeValues") []
         [RecC (mkName "NodeValues") strict_types] []]

-- | Function constructs ClusterStatistics data type for metric components
-- given. The data type is used to store all Statistics constructed from the
-- [NodeValues].
clusterStatisticsDecl :: [MetricComponent] -> Q [Dec]
clusterStatisticsDecl components = do
  let names = map (("cs_" ++ ) . name ) components
      types = map statisticsType components
  strict_types <- mapM getVarStrictTypeQ $ zip names types
  return [DataD [] (mkName "ClusterStatistics") []
         [RecC (mkName "ClusterStatistics") strict_types] []]

-- | Generates (getNodeValues :: Node.Node -> NodeValues) declaration for
-- metric components given. The function constructs NodeValues by calling
-- fromNode function for each metrics component.
getNodeValuesDecl :: [MetricComponent] -> Q [Dec]
getNodeValuesDecl components = do
  extract_functions <- mapM fromNode components
  x <- newName "node"
  node_t <- [t| Node.Node |]
  let names = map (mkName . ("nv_" ++) . name) components
      values = map (\f -> AppE f (VarE x)) extract_functions
      body_exp = RecConE (mkName "NodeValues") $ zip names values
      fname = mkName "getNodeValues"
      nv_t = ConT $ mkName "NodeValues"
      sig_d = SigD fname (ArrowT `AppT` node_t `AppT` nv_t)
      fun_d = FunD fname [Clause [VarP x] (NormalB body_exp) []]
  return [sig_d, fun_d]

-- | Helper function passing two arguments to a function
appTwice :: Q Exp -> Q Exp -> Q Exp -> Q Exp
appTwice fun arg1 = appE $ appE fun arg1

-- | Helper function constructing Q (Name, Exp)
getQNameExp :: String -> Q Exp -> Q (Name, Exp)
getQNameExp n e = do
  e' <- e
  return (mkName n, e')

-- | Generates (compClusterStatisticsHelper :: [Node.Node] ->
-- ClusterStatistics) declaration for metric components given. The function
-- constructs ClusterStatistics by calling calculate function for each spread
-- values list. Spread values lists are obtained by getNodeValues call.
compClusterStatisticsDecl :: [MetricComponent] -> Q [Dec]
compClusterStatisticsDecl components = do
  nl_i <- newName "nl"
  let splitted = appTwice [| partition |] [| Node.offline |] (varE nl_i)
      (nl_off, nl_on) = (appE [| fst |] splitted, appE [| snd |] splitted)
      (online, offline) = partition forOnlineNodes components
      nv_f nm = varE . mkName $ "nv_" ++ nm
      nvl_f = appTwice [| map |] (varE (mkName "getNodeValues"))
      nv_field nm = appTwice [| map |] $ nv_f nm
      cs_field nm nvl = appE [| calculate |] $ nv_field nm nvl
      (online_names, offline_names)  = (map name online, map name offline)
      offline_f = map (\nm -> getQNameExp ("cs_" ++ nm) .
                              cs_field nm $ nvl_f nl_off) offline_names
      online_f  = map (\nm -> getQNameExp ("cs_" ++ nm) .
                              cs_field nm $ nvl_f nl_on ) online_names
      body = recConE (mkName "ClusterStatistics") $ offline_f ++ online_f
      cls_stat_t = conT $ mkName "ClusterStatistics"
      fname = mkName "compClusterStatistics"
  sig_d <- sigD fname ((arrowT `appT` [t| [Node.Node] |]) `appT` cls_stat_t)
  fun_d <- funD fname [clause [varP nl_i] (normalB body) []]
  return [sig_d, fun_d]

-- | Generates (updateClusterStatistics :: ClusterStatistics ->
-- (Node.Node, Node.Node) -> ClusterStatistics) declaration for metric
-- components given. The function calls update for each ClusterStatistics
-- field if the node is online or preserves the old ClusterStatistics
-- otherwise. This action replaces contribution of the first node by the
-- contribution of the second node.
updateClusterStatisticsDecl :: [MetricComponent] -> Q [Dec]
updateClusterStatisticsDecl components = do
  old_s <- newName "old_s"
  n  <- newName "n"
  n' <- newName "n'"
  let (online, offline) = partition forOnlineNodes components
      pattern = [varP old_s, tupP [varP n, varP n']]
      is_node_online = appE [| not . Node.offline |] $ varE n
      get_nv nd = appE (varE $ mkName "getNodeValues") $ varE nd
      nv_get_field nm nd = appE (varE . mkName $ "nv_" ++ nm) $ get_nv nd
      cs_cur_field nm = appE (varE . mkName $ "cs_" ++ nm) $ varE old_s
      update_field nm = appTwice (appE [| update |] $ cs_cur_field nm)
                                  (nv_get_field nm n) (nv_get_field nm n')
      (online_names, offline_names) = (map name online, map name offline)
      offline_f = map (\nm -> getQNameExp ("cs_" ++ nm) $
                                          cs_cur_field nm) offline_names
      online_f  = map (\nm -> getQNameExp ("cs_" ++ nm) $
                                          update_field nm) online_names
      body = condE is_node_online
             (recConE (mkName "ClusterStatistics") $ offline_f ++ online_f)
             (varE old_s)
      fname = mkName "updateClusterStatistics"
      cs_t = conT $ mkName "ClusterStatistics"
  sig_d <- sigD fname ((arrowT `appT` cs_t) `appT`
                       ((arrowT `appT` [t| (Node.Node, Node.Node) |]) `appT`
                         cs_t))
  fun_d <- funD fname [clause pattern (normalB body) []]
  return [sig_d, fun_d]

-- | Generates (compCVFromStats :: ClusterStatistics -> Double) declaration
-- for metric components given. The function computes the cluster score from
-- the ClusterStatistics.
compCVfromStatsDecl :: [MetricComponent] -> Q [Dec]
compCVfromStatsDecl components = do
  cs <- newName "cs"
  let get_comp c = appE (varE . mkName $ "cs_" ++ name c) $ varE cs
      get_val c = appE [| getValue |] $ get_comp c
      term c = appTwice [| (*) :: Double -> Double -> Double |]
                         (get_val c) (weight c)
      stat = appE [| sum :: [Double] -> Double |] . listE $ map term components
      fname = mkName "compCVfromStats"
      cs_t = conT $ mkName "ClusterStatistics"
  sig_d <- sigD fname ((arrowT `appT` cs_t) `appT` [t| Double |])
  fun_d <- funD fname [clause [varP cs] (normalB stat) []]
  return [sig_d, fun_d]

-- | Generates (showClusterStatistics :: ClusterStatistics -> String)
-- declaration for metric components given. The function converts
-- ClusterStatistics to a string containing a table obtained by printTable.
showClusterStatisticsDecl :: [MetricComponent] -> Q [Dec]
showClusterStatisticsDecl components = do
  lp <- newName "lp"
  cs <- newName "cs"
  let get_comp c = appE (varE . mkName $ "cs_" ++ name c) $ varE cs
      get_val c = appE [| getValue |] $ get_comp c
      format w h val = listE [ h
                             , appE [| printf "%.8f" |] val
                             , appE [| printf "x%.2f"|] w
                             ]
      print_line c = format (weight c) (litE . StringL $ name c) (get_val c)
      header = [| [ "Field", "Value", "Weight" ] |]
      printed = listE $ map print_line components
      result = appTwice (appTwice [| printTable |] (varE lp) header)
                         printed [| False:repeat True |]
      fname = mkName "showClusterStatistics"
      cs_t = conT $ mkName "ClusterStatistics"
  sig_d <- sigD fname ((arrowT `appT` [t| String |]) `appT`
                       ((arrowT `appT` cs_t) `appT` [t| String |]))
  fun_d <- funD fname [clause [varP lp, varP cs] (normalB result) []]
  return [sig_d, fun_d]


-- | Generates (optimalCVScore :: Node.List -> Double) declaration for metric
-- components given. The function computes the lower bound of the cluster
-- score, i.e., the sum of the minimal values for all cluster score values that
-- are not 0 on a perfectly balanced cluster. Components which optimal values
-- are not 0 have Nothing as optimaLValue component
optimalCVScoreDecl :: [MetricComponent] -> Q [Dec]
optimalCVScoreDecl components = do
  nl <- newName "nl"
  let stat =
        foldl (addVal nl) [| 0 :: Double |] $ mapMaybe optimalValue components
      fname = mkName "optimalCVScore"
  sig_d <- sigD fname ((arrowT `appT` [t| Node.List |]) `appT` [t| Double |])
  fun_d <- funD fname [clause [varP nl] (normalB stat) []]
  return [sig_d, fun_d]
  where
    addVal :: Name -> ExpQ -> ExpQ -> ExpQ
    addVal nl cur f = appTwice [| (+) :: Double -> Double -> Double |]
                               cur . appE f $ varE nl