Synnefo » snf-ganeti

{-| Implementation of the Ganeti Query2 node queries.

 -}

{-

Copyright (C) 2012, 2013 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.Query.Node

  ( Runtime

  , fieldsMap

  , collectLiveData

  ) where

import Control.Applicative

import Data.List

import Data.Maybe

import qualified Data.Map as Map

import qualified Text.JSON as J

import Ganeti.Config

import Ganeti.Common

import Ganeti.Objects

import Ganeti.JSON

import Ganeti.Rpc

import Ganeti.Types

import Ganeti.Query.Language

import Ganeti.Query.Common

import Ganeti.Query.Types

import Ganeti.Storage.Utils

import Ganeti.Utils (niceSort)

-- | Runtime is the resulting type for NodeInfo call.

type Runtime = Either RpcError RpcResultNodeInfo

-- | List of node live fields.

nodeLiveFieldsDefs :: [(FieldName, FieldTitle, FieldType, String, FieldDoc)]

nodeLiveFieldsDefs =

  [ ("bootid", "BootID", QFTText, "bootid",

     "Random UUID renewed for each system reboot, can be used\

     \ for detecting reboots by tracking changes")

  , ("cnodes", "CNodes", QFTNumber, "cpu_nodes",

     "Number of NUMA domains on node (if exported by hypervisor)")

  , ("cnos", "CNOs", QFTNumber, "cpu_dom0",

     "Number of logical processors used by the node OS (dom0 for Xen)")

  , ("csockets", "CSockets", QFTNumber, "cpu_sockets",

     "Number of physical CPU sockets (if exported by hypervisor)")

  , ("ctotal", "CTotal", QFTNumber, "cpu_total",

     "Number of logical processors")

  , ("dfree", "DFree", QFTUnit, "storage_free",

     "Available storage space on storage unit")

  , ("dtotal", "DTotal", QFTUnit, "storage_size",

     "Total storage space on storage unit for instance disk allocation")

  , ("spfree", "SpFree", QFTNumber, "spindles_free",

     "Available spindles in volume group (exclusive storage only)")

  , ("sptotal", "SpTotal", QFTNumber, "spindles_total",

     "Total spindles in volume group (exclusive storage only)")

  , ("mfree", "MFree", QFTUnit, "memory_free",

     "Memory available for instance allocations")

  , ("mnode", "MNode", QFTUnit, "memory_dom0",

     "Amount of memory used by node (dom0 for Xen)")

  , ("mtotal", "MTotal", QFTUnit, "memory_total",

     "Total amount of memory of physical machine")

  ]

-- | Helper function to extract an attribute from a maybe StorageType

getAttrFromStorageInfo :: (J.JSON a) => (StorageInfo -> Maybe a)

                       -> Maybe StorageInfo -> J.JSValue

getAttrFromStorageInfo attr_fn (Just info) =

  case attr_fn info of

    Just val -> J.showJSON val

    Nothing -> J.JSNull

getAttrFromStorageInfo _ Nothing = J.JSNull

-- | Check whether the given storage info fits to the given storage type

isStorageInfoOfType :: StorageType -> StorageInfo -> Bool

isStorageInfoOfType stype sinfo = storageInfoType sinfo ==

    storageTypeToRaw stype

-- | Get storage info for the default storage unit

getStorageInfoForDefault :: [StorageInfo] -> Maybe StorageInfo

getStorageInfoForDefault sinfos = listToMaybe $ filter

    (not . isStorageInfoOfType StorageLvmPv) sinfos

-- | Gets the storage info for a storage type

-- FIXME: This needs to be extended when storage pools are implemented,

-- because storage types are not necessarily unique then

getStorageInfoForType :: [StorageInfo] -> StorageType -> Maybe StorageInfo

getStorageInfoForType sinfos stype = listToMaybe $ filter

    (isStorageInfoOfType stype) sinfos

-- | Map each name to a function that extracts that value from

-- the RPC result.

nodeLiveFieldExtract :: FieldName -> RpcResultNodeInfo -> J.JSValue

nodeLiveFieldExtract "bootid" res =

  J.showJSON $ rpcResNodeInfoBootId res

nodeLiveFieldExtract "cnodes" res =

  jsonHead (rpcResNodeInfoHvInfo res) hvInfoCpuNodes

nodeLiveFieldExtract "cnos" res =

  jsonHead (rpcResNodeInfoHvInfo res) hvInfoCpuDom0

nodeLiveFieldExtract "csockets" res =

  jsonHead (rpcResNodeInfoHvInfo res) hvInfoCpuSockets

nodeLiveFieldExtract "ctotal" res =

  jsonHead (rpcResNodeInfoHvInfo res) hvInfoCpuTotal

nodeLiveFieldExtract "dfree" res =

  getAttrFromStorageInfo storageInfoStorageFree (getStorageInfoForDefault

      (rpcResNodeInfoStorageInfo res))

nodeLiveFieldExtract "dtotal" res =

  getAttrFromStorageInfo storageInfoStorageSize (getStorageInfoForDefault

      (rpcResNodeInfoStorageInfo res))

nodeLiveFieldExtract "spfree" res =

  getAttrFromStorageInfo storageInfoStorageFree (getStorageInfoForType

      (rpcResNodeInfoStorageInfo res) StorageLvmPv)

nodeLiveFieldExtract "sptotal" res =

  getAttrFromStorageInfo storageInfoStorageSize (getStorageInfoForType

      (rpcResNodeInfoStorageInfo res) StorageLvmPv)

nodeLiveFieldExtract "mfree" res =

  jsonHead (rpcResNodeInfoHvInfo res) hvInfoMemoryFree

nodeLiveFieldExtract "mnode" res =

  jsonHead (rpcResNodeInfoHvInfo res) hvInfoMemoryDom0

nodeLiveFieldExtract "mtotal" res =

  jsonHead (rpcResNodeInfoHvInfo res) hvInfoMemoryTotal

nodeLiveFieldExtract _ _ = J.JSNull

-- | Helper for extracting field from RPC result.

nodeLiveRpcCall :: FieldName -> Runtime -> Node -> ResultEntry

nodeLiveRpcCall fname (Right res) _ =

  case nodeLiveFieldExtract fname res of

    J.JSNull -> rsNoData

    x -> rsNormal x

nodeLiveRpcCall _ (Left err) _ =

    ResultEntry (rpcErrorToStatus err) Nothing

-- | Builder for node live fields.

nodeLiveFieldBuilder :: (FieldName, FieldTitle, FieldType, String, FieldDoc)

                     -> FieldData Node Runtime

nodeLiveFieldBuilder (fname, ftitle, ftype, _, fdoc) =

  ( FieldDefinition fname ftitle ftype fdoc

  , FieldRuntime $ nodeLiveRpcCall fname

  , QffNormal)

-- | The docstring for the node role. Note that we use 'reverse' in

-- order to keep the same order as Python.

nodeRoleDoc :: String

nodeRoleDoc =

  "Node role; " ++

  intercalate ", "

   (map (\role ->

          "\"" ++ nodeRoleToRaw role ++ "\" for " ++ roleDescription role)

   (reverse [minBound..maxBound]))

-- | Get node powered status.

getNodePower :: ConfigData -> Node -> ResultEntry

getNodePower cfg node =

  case getNodeNdParams cfg node of

    Nothing -> rsNoData

    Just ndp -> if null (ndpOobProgram ndp)

                  then rsUnavail

                  else rsNormal (nodePowered node)

-- | List of all node fields.

nodeFields :: FieldList Node Runtime

nodeFields =

  [ (FieldDefinition "drained" "Drained" QFTBool "Whether node is drained",

     FieldSimple (rsNormal . nodeDrained), QffNormal)

  , (FieldDefinition "master_candidate" "MasterC" QFTBool

       "Whether node is a master candidate",

     FieldSimple (rsNormal . nodeMasterCandidate), QffNormal)

  , (FieldDefinition "master_capable" "MasterCapable" QFTBool

       "Whether node can become a master candidate",

     FieldSimple (rsNormal . nodeMasterCapable), QffNormal)

  , (FieldDefinition "name" "Node" QFTText "Node name",

     FieldSimple (rsNormal . nodeName), QffHostname)

  , (FieldDefinition "offline" "Offline" QFTBool

       "Whether node is marked offline",

     FieldSimple (rsNormal . nodeOffline), QffNormal)

  , (FieldDefinition "vm_capable" "VMCapable" QFTBool

       "Whether node can host instances",

     FieldSimple (rsNormal . nodeVmCapable), QffNormal)

  , (FieldDefinition "pip" "PrimaryIP" QFTText "Primary IP address",

     FieldSimple (rsNormal . nodePrimaryIp), QffNormal)

  , (FieldDefinition "sip" "SecondaryIP" QFTText "Secondary IP address",

     FieldSimple (rsNormal . nodeSecondaryIp), QffNormal)

  , (FieldDefinition "master" "IsMaster" QFTBool "Whether node is master",

     FieldConfig (\cfg node ->

                    rsNormal (nodeName node ==

                              clusterMasterNode (configCluster cfg))),

     QffNormal)

  , (FieldDefinition "group" "Group" QFTText "Node group",

     FieldConfig (\cfg node ->

                    rsMaybeNoData (groupName <$> getGroupOfNode cfg node)),

     QffNormal)

  , (FieldDefinition "group.uuid" "GroupUUID" QFTText "UUID of node group",

     FieldSimple (rsNormal . nodeGroup), QffNormal)

  ,  (FieldDefinition "ndparams" "NodeParameters" QFTOther

        "Merged node parameters",

      FieldConfig ((rsMaybeNoData .) . getNodeNdParams), QffNormal)

  , (FieldDefinition "custom_ndparams" "CustomNodeParameters" QFTOther

                       "Custom node parameters",

     FieldSimple (rsNormal . nodeNdparams), QffNormal)

  -- FIXME: the below could be generalised a bit, like in Python

  , (FieldDefinition "pinst_cnt" "Pinst" QFTNumber

       "Number of instances with this node as primary",

     FieldConfig (\cfg ->

                    rsNormal . length . fst . getNodeInstances cfg . nodeUuid),

     QffNormal)

  , (FieldDefinition "sinst_cnt" "Sinst" QFTNumber

       "Number of instances with this node as secondary",

     FieldConfig (\cfg ->

                    rsNormal . length . snd . getNodeInstances cfg . nodeUuid),

     QffNormal)

  , (FieldDefinition "pinst_list" "PriInstances" QFTOther

       "List of instances with this node as primary",

     FieldConfig (\cfg -> rsNormal . niceSort . map instName . fst .

                          getNodeInstances cfg . nodeUuid), QffNormal)

  , (FieldDefinition "sinst_list" "SecInstances" QFTOther

       "List of instances with this node as secondary",

     FieldConfig (\cfg -> rsNormal . niceSort . map instName . snd .

                          getNodeInstances cfg . nodeUuid), QffNormal)

  , (FieldDefinition "role" "Role" QFTText nodeRoleDoc,

     FieldConfig ((rsNormal .) . getNodeRole), QffNormal)

  , (FieldDefinition "powered" "Powered" QFTBool

       "Whether node is thought to be powered on",

     FieldConfig getNodePower, QffNormal)

  -- FIXME: the two fields below are incomplete in Python, part of the

  -- non-implemented node resource model; they are declared just for

  -- parity, but are not functional

  , (FieldDefinition "hv_state" "HypervisorState" QFTOther "Hypervisor state",

     FieldSimple (const rsUnavail), QffNormal)

  , (FieldDefinition "disk_state" "DiskState" QFTOther "Disk state",

     FieldSimple (const rsUnavail), QffNormal)

  ] ++

  map nodeLiveFieldBuilder nodeLiveFieldsDefs ++

  map buildNdParamField allNDParamFields ++

  timeStampFields ++

  uuidFields "Node" ++

  serialFields "Node" ++

  tagsFields

-- | The node fields map.

fieldsMap :: FieldMap Node Runtime

fieldsMap =

  Map.fromList $ map (\v@(f, _, _) -> (fdefName f, v)) nodeFields

-- | Create an RPC result for a broken node

rpcResultNodeBroken :: Node -> (Node, Runtime)

rpcResultNodeBroken node = (node, Left (RpcResultError "Broken configuration"))

-- | Collect live data from RPC query if enabled.

--

-- FIXME: Check which fields we actually need and possibly send empty

-- hvs\/vgs if no info from hypervisor\/volume group respectively is

-- required

collectLiveData:: Bool -> ConfigData -> [Node] -> IO [(Node, Runtime)]

collectLiveData False _ nodes =

  return $ zip nodes (repeat $ Left (RpcResultError "Live data disabled"))

collectLiveData True cfg nodes = do

  let hvs = [getDefaultHypervisorSpec cfg]

      good_nodes = nodesWithValidConfig cfg nodes

      -- FIXME: use storage units from calling code

      storage_units = getStorageUnitsOfNodes cfg good_nodes

  rpcres <- executeRpcCall good_nodes (RpcCallNodeInfo storage_units hvs)

  return $ fillUpList (fillPairFromMaybe rpcResultNodeBroken pickPairUnique)

      nodes rpcres

-- | Looks up the default hypervisor and it's hvparams

getDefaultHypervisorSpec :: ConfigData -> (Hypervisor, HvParams)

getDefaultHypervisorSpec cfg = (hv, getHvParamsFromCluster cfg hv)

  where hv = getDefaultHypervisor cfg

-- | Looks up the cluster's hvparams of the given hypervisor

getHvParamsFromCluster :: ConfigData -> Hypervisor -> HvParams

getHvParamsFromCluster cfg hv =

  fromMaybe (GenericContainer (Map.fromList []))

    (Map.lookup (hypervisorToRaw hv)

       (fromContainer (clusterHvparams (configCluster cfg))))