{-| Implementation of the Ganeti Query2 instance queries.

-}

{-

Copyright (C) 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.Query.Instance
  ( Runtime
  , fieldsMap
  , collectLiveData
  , getInstanceInfo
  , instanceFields
  , instanceAliases
  ) where

import Control.Applicative
import Control.Monad (liftM, (>=>))
import qualified Data.ByteString.UTF8 as UTF8
import Data.Either
import Data.List
import Data.Maybe
import Data.Monoid
import qualified Data.Map as Map
import Data.Ord (comparing)
import qualified Text.JSON as J
import Text.Printf

import Ganeti.BasicTypes
import Ganeti.Common
import Ganeti.Config
import qualified Ganeti.Constants as C
import qualified Ganeti.ConstantUtils as C
import Ganeti.Errors
import Ganeti.JSON (MaybeForJSON(..), fromContainer)
import Ganeti.Objects
import Ganeti.Query.Common
import Ganeti.Query.Language
import Ganeti.Query.Types
import Ganeti.Rpc
import Ganeti.Storage.Utils
import Ganeti.Types
import Ganeti.Utils (formatOrdinal)

-- | The LiveInfo consists of two entries whose presence is independent.
-- The 'InstanceInfo' is the live instance information, accompanied by a bool
-- signifying if it was found on its designated primary node or not.
-- The 'InstanceConsoleInfo' describes how to connect to an instance.
-- Any combination of these may or may not be present, depending on node and
-- instance availability.
type LiveInfo = (Maybe (InstanceInfo, Bool), Maybe InstanceConsoleInfo)

-- | Runtime containing the 'LiveInfo'. See the genericQuery function in
-- the Query.hs file for an explanation of the terms used.
type Runtime = Either RpcError LiveInfo

-- | The instance fields map.
fieldsMap :: FieldMap Instance Runtime
fieldsMap = fieldListToFieldMap aliasedFields

-- | The instance aliases.
instanceAliases :: [(FieldName, FieldName)]
instanceAliases =
  [ ("vcpus", "be/vcpus")
  , ("be/memory", "be/maxmem")
  , ("sda_size", "disk.size/0")
  , ("sdb_size", "disk.size/1")
  , ("ip", "nic.ip/0")
  , ("mac", "nic.mac/0")
  , ("bridge", "nic.bridge/0")
  , ("nic_mode", "nic.mode/0")
  , ("nic_link", "nic.link/0")
  , ("nic_network", "nic.network/0")
  ]

-- | The aliased instance fields.
aliasedFields :: FieldList Instance Runtime
aliasedFields = aliasFields instanceAliases instanceFields

-- | The instance fields.
instanceFields :: FieldList Instance Runtime
instanceFields =
  -- Simple fields
  [ (FieldDefinition "admin_state" "InstanceState" QFTText
     "Desired state of instance",
     FieldSimple (rsMaybeNoData . liftM adminStateToRaw . instAdminState),
     QffNormal)
  , (FieldDefinition "admin_state_source" "InstanceStateSource" QFTText
     "Who last changed the desired state of the instance",
     FieldSimple (rsMaybeNoData . liftM adminStateSourceToRaw
                  . instAdminStateSource),
     QffNormal)
  , (FieldDefinition "admin_up" "Autostart" QFTBool
     "Desired state of instance",
     FieldSimple (rsMaybeNoData . liftM (== AdminUp) . instAdminState),
     QffNormal)
  , (FieldDefinition "disks_active" "DisksActive" QFTBool
     "Desired state of instance disks",
     FieldSimple (rsMaybeNoData . instDisksActive), QffNormal)
  , (FieldDefinition "name" "Instance" QFTText
     "Instance name",
     FieldSimple (rsMaybeNoData . instName), QffHostname)
  , (FieldDefinition "hypervisor" "Hypervisor" QFTText
     "Hypervisor name",
     FieldSimple (rsMaybeNoData . instHypervisor), QffNormal)
  , (FieldDefinition "network_port" "Network_port" QFTOther
     "Instance network port if available (e.g. for VNC console)",
     FieldSimple (rsMaybeUnavail . instNetworkPort), QffNormal)
  , (FieldDefinition "os" "OS" QFTText
     "Operating system",
     FieldSimple (rsMaybeNoData . instOs), QffNormal)
  , (FieldDefinition "pnode" "Primary_node" QFTText
     "Primary node",
     FieldConfig getPrimaryNodeName, QffHostname)
  , (FieldDefinition "pnode.group" "PrimaryNodeGroup" QFTText
     "Primary node's group",
     FieldConfig getPrimaryNodeGroupName, QffNormal)
  , (FieldDefinition "pnode.group.uuid" "PrimaryNodeGroupUUID" QFTText
     "Primary node's group UUID",
     FieldConfig getPrimaryNodeGroupUuid, QffNormal)
  , (FieldDefinition "snodes" "Secondary_Nodes" QFTOther
     "Secondary nodes; usually this will just be one node",
     FieldConfig (getSecondaryNodeAttribute nodeName), QffNormal)
  , (FieldDefinition "snodes.group" "SecondaryNodesGroups" QFTOther
     "Node groups of secondary nodes",
     FieldConfig (getSecondaryNodeGroupAttribute groupName), QffNormal)
  , (FieldDefinition "snodes.group.uuid" "SecondaryNodesGroupsUUID" QFTOther
     "Node group UUIDs of secondary nodes",
     FieldConfig (getSecondaryNodeGroupAttribute uuidOf), QffNormal)
  ] ++

  -- Instance parameter fields, whole
  [ (FieldDefinition "hvparams" "HypervisorParameters" QFTOther
     "Hypervisor parameters (merged)",
     FieldConfig
       ((rsNormal .) . getFilledInstHvParams (C.toList C.hvcGlobals)),
     QffNormal),

    (FieldDefinition "beparams" "BackendParameters" QFTOther
     "Backend parameters (merged)",
     FieldConfig ((rsErrorNoData .) . getFilledInstBeParams), QffNormal)
  , (FieldDefinition "osparams" "OpSysParameters" QFTOther
     "Operating system parameters (merged)",
     FieldConfig ((rsNormal .) . getFilledInstOsParams), QffNormal)
  , (FieldDefinition "custom_hvparams" "CustomHypervisorParameters" QFTOther
     "Custom hypervisor parameters",
     FieldSimple (rsNormal . instHvparams), QffNormal)
  , (FieldDefinition "custom_beparams" "CustomBackendParameters" QFTOther
     "Custom backend parameters",
     FieldSimple (rsNormal . instBeparams), QffNormal)
  , (FieldDefinition "custom_osparams" "CustomOpSysParameters" QFTOther
     "Custom operating system parameters",
     FieldSimple (rsNormal . instOsparams), QffNormal)
  , (FieldDefinition "custom_nicparams" "CustomNicParameters" QFTOther
     "Custom network interface parameters",
     FieldSimple (rsNormal . map nicNicparams . instNics), QffNormal)
  ] ++

  -- Instance parameter fields, generated
  map (buildBeParamField beParamGetter) allBeParamFields ++
  map (buildHvParamField hvParamGetter)
      (C.toList C.hvsParameters \\ C.toList C.hvcGlobals) ++

  -- disk parameter fields
  [ (FieldDefinition "disk_usage" "DiskUsage" QFTUnit
     "Total disk space used by instance on each of its nodes; this is not the\
     \ disk size visible to the instance, but the usage on the node",
     FieldConfig getDiskSizeRequirements, QffNormal)
  , (FieldDefinition "disk.count" "Disks" QFTNumber
     "Number of disks",
     FieldSimple (rsNormal . length . instDisks), QffNormal)
  , (FieldDefinition "disk.sizes" "Disk_sizes" QFTOther
     "List of disk sizes", FieldConfig getDiskSizes, QffNormal)
  , (FieldDefinition "disk.spindles" "Disk_spindles" QFTOther
     "List of disk spindles",
     FieldConfig getDiskSpindles, QffNormal)
  , (FieldDefinition "disk.names" "Disk_names" QFTOther
     "List of disk names",
     FieldConfig getDiskNames, QffNormal)
  , (FieldDefinition "disk.uuids" "Disk_UUIDs" QFTOther
     "List of disk UUIDs",
     FieldConfig getDiskUuids, QffNormal)
  , (FieldDefinition "disk.storage_ids" "Disk_storage_ids" QFTOther
     "List of disk storage ids",
     FieldConfig getStorageIds, QffNormal)
  , (FieldDefinition "disk.providers" "Disk_providers" QFTOther
     "List of disk ExtStorage providers",
     FieldConfig getProviders, QffNormal)
    -- For pre-2.14 backwards compatibility
  , (FieldDefinition "disk_template" "Disk_template" QFTText
     "Instance disk template",
     FieldConfig getDiskTemplate, QffNormal)
  ] ++

  -- Per-disk parameter fields
  instantiateIndexedFields C.maxDisks
  [ (fieldDefinitionCompleter "disk.size/%d" "Disk/%d" QFTUnit
    "Disk size of %s disk",
    getIndexedOptionalConfField getInstDisks diskSize,
    QffNormal)
  , (fieldDefinitionCompleter "disk.spindles/%d" "DiskSpindles/%d" QFTNumber
    "Spindles of %s disk",
    getIndexedOptionalConfField getInstDisks diskSpindles,
    QffNormal)
  , (fieldDefinitionCompleter "disk.name/%d" "DiskName/%d" QFTText
    "Name of %s disk",
    getIndexedOptionalConfField getInstDisks diskName, QffNormal)
  , (fieldDefinitionCompleter "disk.uuid/%d" "DiskUUID/%d" QFTText
    "UUID of %s disk",
    getIndexedConfField getInstDisks uuidOf, QffNormal)
  ] ++

  -- Aggregate nic parameter fields
  [ (FieldDefinition "nic.count" "NICs" QFTNumber
     "Number of network interfaces",
     FieldSimple (rsNormal . length . instNics), QffNormal)
  , (FieldDefinition "nic.macs" "NIC_MACs" QFTOther
     (nicAggDescPrefix ++ "MAC address"),
     FieldSimple (rsNormal . map nicMac . instNics), QffNormal)
  , (FieldDefinition "nic.ips" "NIC_IPs" QFTOther
     (nicAggDescPrefix ++ "IP address"),
     FieldSimple (rsNormal . map (MaybeForJSON . nicIp) . instNics),
     QffNormal)
  , (FieldDefinition "nic.names" "NIC_Names" QFTOther
     (nicAggDescPrefix ++ "name"),
     FieldSimple (rsNormal . map (MaybeForJSON . nicName) . instNics),
     QffNormal)
  , (FieldDefinition "nic.uuids" "NIC_UUIDs" QFTOther
     (nicAggDescPrefix ++ "UUID"),
     FieldSimple (rsNormal . map uuidOf . instNics), QffNormal)
  , (FieldDefinition "nic.modes" "NIC_modes" QFTOther
     (nicAggDescPrefix ++ "mode"),
     FieldConfig (\cfg -> rsNormal . map
       (nicpMode . fillNicParamsFromConfig cfg . nicNicparams)
       . instNics),
     QffNormal)
  , (FieldDefinition "nic.vlans" "NIC_VLANs" QFTOther
     (nicAggDescPrefix ++ "VLAN"),
     FieldConfig (\cfg -> rsNormal . map (MaybeForJSON . getNicVlan .
       fillNicParamsFromConfig cfg . nicNicparams) . instNics),
     QffNormal)
  , (FieldDefinition "nic.bridges" "NIC_bridges" QFTOther
     (nicAggDescPrefix ++ "bridge"),
     FieldConfig (\cfg -> rsNormal . map (MaybeForJSON . getNicBridge .
       fillNicParamsFromConfig cfg . nicNicparams) . instNics),
     QffNormal)
  , (FieldDefinition "nic.links" "NIC_links" QFTOther
     (nicAggDescPrefix ++ "link"),
     FieldConfig (\cfg -> rsNormal . map
       (nicpLink . fillNicParamsFromConfig cfg . nicNicparams)
       . instNics), QffNormal)
  , (FieldDefinition "nic.networks" "NIC_networks" QFTOther
     "List containing each interface's network",
     FieldSimple (rsNormal . map (MaybeForJSON . nicNetwork) . instNics),
     QffNormal)
  , (FieldDefinition "nic.networks.names" "NIC_networks_names" QFTOther
     "List containing the name of each interface's network",
     FieldConfig (\cfg -> rsNormal . map
       (\x -> MaybeForJSON (getNetworkName cfg <$> nicNetwork x))
       . instNics),
     QffNormal)
  ] ++

  -- Per-nic parameter fields
  instantiateIndexedFields C.maxNics
  [ (fieldDefinitionCompleter "nic.ip/%d" "NicIP/%d" QFTText
     ("IP address" ++ nicDescSuffix),
     getIndexedOptionalField instNics nicIp, QffNormal)
  , (fieldDefinitionCompleter "nic.uuid/%d" "NicUUID/%d" QFTText
     ("UUID address" ++ nicDescSuffix),
     getIndexedField instNics uuidOf, QffNormal)
  , (fieldDefinitionCompleter "nic.mac/%d" "NicMAC/%d" QFTText
     ("MAC address" ++ nicDescSuffix),
     getIndexedField instNics nicMac, QffNormal)
  , (fieldDefinitionCompleter "nic.name/%d" "NicName/%d" QFTText
     ("Name address" ++ nicDescSuffix),
     getIndexedOptionalField instNics nicName, QffNormal)
  , (fieldDefinitionCompleter "nic.network/%d" "NicNetwork/%d" QFTText
     ("Network" ++ nicDescSuffix),
     getIndexedOptionalField instNics nicNetwork, QffNormal)
  , (fieldDefinitionCompleter "nic.mode/%d" "NicMode/%d" QFTText
     ("Mode" ++ nicDescSuffix),
     getIndexedNicField nicpMode, QffNormal)
  , (fieldDefinitionCompleter "nic.link/%d" "NicLink/%d" QFTText
     ("Link" ++ nicDescSuffix),
     getIndexedNicField nicpLink, QffNormal)
  , (fieldDefinitionCompleter "nic.vlan/%d" "NicVLAN/%d" QFTText
     ("VLAN" ++ nicDescSuffix),
     getOptionalIndexedNicField getNicVlan, QffNormal)
  , (fieldDefinitionCompleter "nic.network.name/%d" "NicNetworkName/%d" QFTText
     ("Network name" ++ nicDescSuffix),
     getIndexedNicNetworkNameField, QffNormal)
  , (fieldDefinitionCompleter "nic.bridge/%d" "NicBridge/%d" QFTText
     ("Bridge" ++ nicDescSuffix),
     getOptionalIndexedNicField getNicBridge, QffNormal)
  ] ++

  -- Live fields using special getters
  [ (FieldDefinition "status" "Status" QFTText
     statusDocText,
     FieldConfigRuntime statusExtract, QffNormal)
  , (FieldDefinition "oper_state" "Running" QFTBool
     "Actual state of instance",
     FieldRuntime operStatusExtract, QffNormal),

    (FieldDefinition "console" "Console" QFTOther
     "Instance console information",
     FieldRuntime consoleExtract, QffNormal)
  ] ++

  -- Simple live fields
  map instanceLiveFieldBuilder instanceLiveFieldsDefs ++

  -- Common fields
  timeStampFields ++
  serialFields "Instance" ++
  uuidFields "Instance" ++
  forthcomingFields "Instance" ++
  tagsFields

-- * Helper functions for node property retrieval

-- | Constant suffix of network interface field descriptions.
nicDescSuffix ::String
nicDescSuffix = " of %s network interface"

-- | Almost-constant suffix of aggregate network interface field descriptions.
nicAggDescPrefix ::String
nicAggDescPrefix = "List containing each network interface's "

-- | Given a network name id, returns the network's name.
getNetworkName :: ConfigData -> String -> NonEmptyString
getNetworkName cfg = networkName . (Map.!) (fromContainer $ configNetworks cfg)
                     . UTF8.fromString

-- | Gets the bridge of a NIC.
getNicBridge :: FilledNicParams -> Maybe String
getNicBridge nicParams
  | nicpMode nicParams == NMBridged = Just $ nicpLink nicParams
  | otherwise                       = Nothing

-- | Gets the VLAN of a NIC.
getNicVlan :: FilledNicParams -> Maybe String
getNicVlan params
  | nicpMode params == NMOvs = Just $ nicpVlan params
  | otherwise                = Nothing

-- | Fill partial NIC params by using the defaults from the configuration.
fillNicParamsFromConfig :: ConfigData -> PartialNicParams -> FilledNicParams
fillNicParamsFromConfig cfg = fillParams (getDefaultNicParams cfg)

-- | Retrieves the default network interface parameters.
getDefaultNicParams :: ConfigData -> FilledNicParams
getDefaultNicParams cfg =
  (Map.!) (fromContainer . clusterNicparams . configCluster $ cfg)
    $ UTF8.fromString C.ppDefault

-- | Retrieves the real disk size requirements for all the disks of the
-- instance. This includes the metadata etc. and is different from the values
-- visible to the instance.
getDiskSizeRequirements :: ConfigData -> Instance -> ResultEntry
getDiskSizeRequirements cfg inst =
  rsErrorNoData . liftA (sum . map getSize) . getInstDisks cfg $ inst
 where
  diskType x = lidDiskType <$> diskLogicalId x
  getSize :: Disk -> Int
  getSize disk =
    let dt = diskType disk
    in case dt of
         Just DTDrbd8    -> fromMaybe 0 (diskSize disk) + C.drbdMetaSize
         Just DTDiskless -> 0
         Just DTBlock    -> 0
         _               -> fromMaybe 0 (diskSize disk)

-- | Get a list of disk sizes for an instance
getDiskSizes :: ConfigData -> Instance -> ResultEntry
getDiskSizes cfg =
  rsErrorNoData . liftA (map $ MaybeForJSON . diskSize)
  . getInstDisks cfg

-- | Get a list of disk spindles
getDiskSpindles :: ConfigData -> Instance -> ResultEntry
getDiskSpindles cfg =
  rsErrorNoData . liftA (map (MaybeForJSON . diskSpindles)) .
    getInstDisks cfg

-- | Get a list of disk names for an instance
getDiskNames :: ConfigData -> Instance -> ResultEntry
getDiskNames cfg =
  rsErrorNoData . liftA (map (MaybeForJSON . diskName)) .
    getInstDisks cfg

-- | Get a list of disk UUIDs for an instance
getDiskUuids :: ConfigData -> Instance -> ResultEntry
getDiskUuids cfg =
  rsErrorNoData . liftA (map uuidOf) . getInstDisks cfg

-- | Get a list of ExtStorage providers for an instance
getProviders :: ConfigData -> Instance -> ResultEntry
getProviders cfg =
  rsErrorNoData . liftA (map MaybeForJSON . filter isJust
                         . mapMaybe getProvider) . getInstDisks cfg
 where
  getProvider x = getExtProvider <$> diskLogicalId x

-- | Get a list of disk storage ids for an instance. Note that for DRBD the list
-- will be empty.
getStorageIds :: ConfigData -> Instance -> ResultEntry
getStorageIds cfg = rsErrorNoData .
  liftA (map MaybeForJSON . filter isJust . mapMaybe storageId) .
  getInstDisks cfg
 where
  storageId x = getStorageId <$> diskLogicalId x

-- | Creates a functions which produces a FieldConfig 'FieldGetter' when fed
-- an index. Works for fields that may not return a value, expressed through
-- the Maybe monad.
getIndexedOptionalConfField :: (J.JSON b)
                            => (ConfigData -> Instance -> ErrorResult [a])
                                              -- ^ Extracts a list of objects
                            -> (a -> Maybe b) -- ^ Possibly gets a property
                                              -- from an object
                            -> Int            -- ^ Index in list to use
                            -> FieldGetter Instance Runtime -- ^ Result
getIndexedOptionalConfField extractor optPropertyGetter index =
  let getProperty x = maybeAt index x >>= optPropertyGetter
  in FieldConfig (\cfg ->
    rsErrorMaybeUnavail . liftA getProperty . extractor cfg)

-- | Creates a function which produces a FieldConfig 'FieldGetter' when fed
-- an index. Works only for fields that surely return a value.
getIndexedConfField :: (J.JSON b)
                    => (ConfigData -> Instance -> ErrorResult [a])
                                  -- ^ Extracts a list of objects
                    -> (a -> b)   -- ^ Gets a property from an object
                    -> Int        -- ^ Index in list to use
                    -> FieldGetter Instance Runtime -- ^ Result
getIndexedConfField extractor propertyGetter index =
  let optPropertyGetter = Just . propertyGetter
  in getIndexedOptionalConfField extractor optPropertyGetter index

-- | Returns a field that retrieves a given NIC's network name.
getIndexedNicNetworkNameField :: Int -> FieldGetter Instance Runtime
getIndexedNicNetworkNameField index =
  FieldConfig (\cfg inst -> rsMaybeUnavail $ do
    nicObj <- maybeAt index $ instNics inst
    nicNetworkId <- nicNetwork nicObj
    return $ getNetworkName cfg nicNetworkId)

-- | Gets a fillable NIC field.
getIndexedNicField :: (J.JSON a)
                   => (FilledNicParams -> a)
                   -> Int
                   -> FieldGetter Instance Runtime
getIndexedNicField getter =
  getOptionalIndexedNicField (\x -> Just . getter $ x)

-- | Gets an optional fillable NIC field.
getOptionalIndexedNicField :: (J.JSON a)
                           => (FilledNicParams -> Maybe a)
                           -> Int
                           -> FieldGetter Instance Runtime
getOptionalIndexedNicField =
  getIndexedFieldWithDefault
    (map nicNicparams . instNics) (\x _ -> getDefaultNicParams x) fillParams

-- | Creates a function which produces a 'FieldGetter' when fed an index. Works
-- for fields that should be filled out through the use of a default.
getIndexedFieldWithDefault :: (J.JSON c)
  => (Instance -> [a])             -- ^ Extracts a list of incomplete objects
  -> (ConfigData -> Instance -> b) -- ^ Extracts the default object
  -> (b -> a -> b)                 -- ^ Fills the default object
  -> (b -> Maybe c)                -- ^ Extracts an obj property
  -> Int                           -- ^ Index in list to use
  -> FieldGetter Instance Runtime  -- ^ Result
getIndexedFieldWithDefault
  listGetter defaultGetter fillFn propertyGetter index =
  FieldConfig (\cfg inst -> rsMaybeUnavail $ do
                              incompleteObj <- maybeAt index $ listGetter inst
                              let defaultObj = defaultGetter cfg inst
                                  completeObj = fillFn defaultObj incompleteObj
                              propertyGetter completeObj)

-- | Creates a function which produces a 'FieldGetter' when fed an index. Works
-- for fields that may not return a value, expressed through the Maybe monad.
getIndexedOptionalField :: (J.JSON b)
                        => (Instance -> [a]) -- ^ Extracts a list of objects
                        -> (a -> Maybe b)    -- ^ Possibly gets a property
                                             -- from an object
                        -> Int               -- ^ Index in list to use
                        -> FieldGetter Instance Runtime -- ^ Result
getIndexedOptionalField extractor optPropertyGetter index =
  FieldSimple(\inst -> rsMaybeUnavail $ do
                         obj <- maybeAt index $ extractor inst
                         optPropertyGetter obj)

-- | Creates a function which produces a 'FieldGetter' when fed an index.
-- Works only for fields that surely return a value.
getIndexedField :: (J.JSON b)
                => (Instance -> [a]) -- ^ Extracts a list of objects
                -> (a -> b)          -- ^ Gets a property from an object
                -> Int               -- ^ Index in list to use
                -> FieldGetter Instance Runtime -- ^ Result
getIndexedField extractor propertyGetter index =
  let optPropertyGetter = Just . propertyGetter
  in getIndexedOptionalField extractor optPropertyGetter index

-- | Retrieves a value from an array at an index, using the Maybe monad to
-- indicate failure.
maybeAt :: Int -> [a] -> Maybe a
maybeAt index list
  | index >= length list = Nothing
  | otherwise            = Just $ list !! index

-- | Primed with format strings for everything but the type, it consumes two
-- values and uses them to complete the FieldDefinition.
-- Warning: a bit unsafe as it uses printf. Handle with care.
fieldDefinitionCompleter :: (PrintfArg t1) => (PrintfArg t2)
                         => FieldName
                         -> FieldTitle
                         -> FieldType
                         -> FieldDoc
                         -> t1
                         -> t2
                         -> FieldDefinition
fieldDefinitionCompleter fName fTitle fType fDoc firstVal secondVal =
  FieldDefinition (printf fName firstVal)
                  (printf fTitle firstVal)
                  fType
                  (printf fDoc secondVal)

-- | Given an incomplete field definition and values that can complete it,
-- return a fully functional FieldData. Cannot work for all cases, should be
-- extended as necessary.
fillIncompleteFields :: (t1 -> t2 -> FieldDefinition,
                         t1 -> FieldGetter a b,
                         QffMode)
                     -> t1
                     -> t2
                     -> FieldData a b
fillIncompleteFields (iDef, iGet, mode) firstVal secondVal =
  (iDef firstVal secondVal, iGet firstVal, mode)

-- | Given indexed fields that describe lists, complete / instantiate them for
-- a given list size.
instantiateIndexedFields :: (Show t1, Integral t1)
                         => Int            -- ^ The size of the list
                         -> [(t1 -> String -> FieldDefinition,
                              t1 -> FieldGetter a b,
                              QffMode)]    -- ^ The indexed fields
                         -> FieldList a b  -- ^ A list of complete fields
instantiateIndexedFields listSize fields = do
  index <- take listSize [0..]
  field <- fields
  return . fillIncompleteFields field index . formatOrdinal $ index + 1

-- * Various helper functions for property retrieval

-- | Helper function for primary node retrieval
getPrimaryNode :: ConfigData -> Instance -> ErrorResult Node
getPrimaryNode cfg = maybe (Bad $ ParameterError "no primary node") return
                       . instName
                     >=> getInstPrimaryNode cfg

-- | Get primary node hostname
getPrimaryNodeName :: ConfigData -> Instance -> ResultEntry
getPrimaryNodeName cfg inst =
  rsErrorNoData $ nodeName <$> getPrimaryNode cfg inst

-- | Get primary node group
getPrimaryNodeGroup :: ConfigData -> Instance -> ErrorResult NodeGroup
getPrimaryNodeGroup cfg inst = do
  pNode <- getPrimaryNode cfg inst
  maybeToError "Configuration missing" $ getGroupOfNode cfg pNode

-- | Get primary node group name
getPrimaryNodeGroupName :: ConfigData -> Instance -> ResultEntry
getPrimaryNodeGroupName cfg inst =
  rsErrorNoData $ groupName <$> getPrimaryNodeGroup cfg inst

-- | Get primary node group uuid
getPrimaryNodeGroupUuid :: ConfigData -> Instance -> ResultEntry
getPrimaryNodeGroupUuid cfg inst =
  rsErrorNoData $ uuidOf <$> getPrimaryNodeGroup cfg inst

-- | Get secondary nodes - the configuration objects themselves
getSecondaryNodes :: ConfigData -> Instance -> ErrorResult [Node]
getSecondaryNodes cfg inst = do
  pNode <- getPrimaryNode cfg inst
  iname <- maybe (Bad $ ParameterError "no name") return $ instName inst
  allNodes <- getInstAllNodes cfg iname
  return $ delete pNode allNodes

-- | Get attributes of the secondary nodes
getSecondaryNodeAttribute :: (J.JSON a)
                          => (Node -> a)
                          -> ConfigData
                          -> Instance
                          -> ResultEntry
getSecondaryNodeAttribute getter cfg inst =
  rsErrorNoData $ map (J.showJSON . getter) <$> getSecondaryNodes cfg inst

-- | Get secondary node groups
getSecondaryNodeGroups :: ConfigData -> Instance -> ErrorResult [NodeGroup]
getSecondaryNodeGroups cfg inst = do
  sNodes <- getSecondaryNodes cfg inst
  return . catMaybes $ map (getGroupOfNode cfg) sNodes

-- | Get attributes of secondary node groups
getSecondaryNodeGroupAttribute :: (J.JSON a)
                               => (NodeGroup -> a)
                               -> ConfigData
                               -> Instance
                               -> ResultEntry
getSecondaryNodeGroupAttribute getter cfg inst =
  rsErrorNoData $ map (J.showJSON . getter) <$> getSecondaryNodeGroups cfg inst

-- | Beparam getter builder: given a field, it returns a FieldConfig
-- getter, that is a function that takes the config and the object and
-- returns the Beparam field specified when the getter was built.
beParamGetter :: String       -- ^ The field we are building the getter for
              -> ConfigData   -- ^ The configuration object
              -> Instance     -- ^ The instance configuration object
              -> ResultEntry  -- ^ The result
beParamGetter field config inst =
  case getFilledInstBeParams config inst of
    Ok beParams -> dictFieldGetter field $ Just beParams
    Bad       _ -> rsNoData

-- | Hvparam getter builder: given a field, it returns a FieldConfig
-- getter, that is a function that takes the config and the object and
-- returns the Hvparam field specified when the getter was built.
hvParamGetter :: String -- ^ The field we're building the getter for
              -> ConfigData -> Instance -> ResultEntry
hvParamGetter field cfg inst =
  rsMaybeUnavail . Map.lookup (UTF8.fromString field) . fromContainer $
    getFilledInstHvParams (C.toList C.hvcGlobals) cfg inst

-- * Live fields functionality

-- | List of node live fields.
instanceLiveFieldsDefs :: [(FieldName, FieldTitle, FieldType, String, FieldDoc)]
instanceLiveFieldsDefs =
  [ ("oper_ram", "Memory", QFTUnit, "oper_ram",
     "Actual memory usage as seen by hypervisor")
  , ("oper_vcpus", "VCPUs", QFTNumber, "oper_vcpus",
     "Actual number of VCPUs as seen by hypervisor")
  ]

-- | Map each name to a function that extracts that value from the RPC result.
instanceLiveFieldExtract :: FieldName -> InstanceInfo -> Instance -> J.JSValue
instanceLiveFieldExtract "oper_ram"   info _ = J.showJSON $ instInfoMemory info
instanceLiveFieldExtract "oper_vcpus" info _ = J.showJSON $ instInfoVcpus info
instanceLiveFieldExtract n _ _ = J.showJSON $
  "The field " ++ n ++ " is not an expected or extractable live field!"

-- | Helper for extracting an instance live field from the RPC results.
instanceLiveRpcCall :: FieldName -> Runtime -> Instance -> ResultEntry
instanceLiveRpcCall fname (Right (Just (res, _), _)) inst =
  case instanceLiveFieldExtract fname res inst of
    J.JSNull -> rsNoData
    x        -> rsNormal x
instanceLiveRpcCall _ (Right (Nothing, _)) _ = rsUnavail
instanceLiveRpcCall _ (Left err) _ =
  ResultEntry (rpcErrorToStatus err) Nothing

-- | Builder for node live fields.
instanceLiveFieldBuilder :: (FieldName, FieldTitle, FieldType, String, FieldDoc)
                         -> FieldData Instance Runtime
instanceLiveFieldBuilder (fname, ftitle, ftype, _, fdoc) =
  ( FieldDefinition fname ftitle ftype fdoc
  , FieldRuntime $ instanceLiveRpcCall fname
  , QffNormal)

-- * Functionality related to status and operational status extraction

-- | The documentation text for the instance status field
statusDocText :: String
statusDocText =
  let si = show . instanceStatusToRaw :: InstanceStatus -> String
  in  "Instance status; " ++
      si Running ++
      " if instance is set to be running and actually is, " ++
      si StatusDown ++
      " if instance is stopped and is not running, " ++
      si WrongNode ++
      " if instance running, but not on its designated primary node, " ++
      si ErrorUp ++
      " if instance should be stopped, but is actually running, " ++
      si ErrorDown ++
      " if instance should run, but doesn't, " ++
      si NodeDown ++
      " if instance's primary node is down, " ++
      si NodeOffline ++
      " if instance's primary node is marked offline, " ++
      si StatusOffline ++
      " if instance is offline and does not use dynamic resources"

-- | Checks if the primary node of an instance is offline
isPrimaryOffline :: ConfigData -> Instance -> Bool
isPrimaryOffline cfg inst =
  let pNodeResult = maybe (Bad $ ParameterError "no primary node") return
                          (instPrimaryNode inst)
                    >>= getNodeByUuid cfg
  in case pNodeResult of
     Ok pNode -> nodeOffline pNode
     Bad    _ -> error "Programmer error - result assumed to be OK is Bad!"

-- | Determines if user shutdown reporting is enabled
userShutdownEnabled :: ConfigData -> Bool
userShutdownEnabled = clusterEnabledUserShutdown . configCluster

-- | Determines the status of a live instance
liveInstanceStatus :: ConfigData
                   -> (InstanceInfo, Bool)
                   -> Instance
                   -> InstanceStatus
liveInstanceStatus cfg (instInfo, foundOnPrimary) inst
  | not foundOnPrimary = WrongNode
  | otherwise =
    case instanceState of
      InstanceStateRunning
        | adminState == Just AdminUp -> Running
        | otherwise -> ErrorUp
      InstanceStateShutdown
        | adminState == Just AdminUp && allowDown -> UserDown
        | adminState == Just AdminUp -> ErrorDown
        | otherwise -> StatusDown
  where adminState = instAdminState inst
        instanceState = instInfoState instInfo

        hvparams =
          fromContainer $ getFilledInstHvParams (C.toList C.hvcGlobals) cfg inst

        allowDown =
          userShutdownEnabled cfg &&
          (instHypervisor inst /= Just Kvm ||
           (Map.member (UTF8.fromString C.hvKvmUserShutdown) hvparams &&
            hvparams Map.! UTF8.fromString C.hvKvmUserShutdown
              == J.JSBool True))

-- | Determines the status of a dead instance.
deadInstanceStatus :: ConfigData -> Instance -> InstanceStatus
deadInstanceStatus cfg inst =
  case instAdminState inst of
    Just AdminUp -> ErrorDown
    Just AdminDown | wasCleanedUp && userShutdownEnabled cfg -> UserDown
                   | otherwise -> StatusDown
    Just AdminOffline -> StatusOffline
    Nothing -> StatusDown
  where wasCleanedUp = instAdminStateSource inst == Just UserSource

-- | Determines the status of the instance, depending on whether it is possible
-- to communicate with its primary node, on which node it is, and its
-- configuration.
determineInstanceStatus :: ConfigData      -- ^ The configuration data
                        -> Runtime         -- ^ All the data from the live call
                        -> Instance        -- ^ Static instance configuration
                        -> InstanceStatus  -- ^ Result
determineInstanceStatus cfg res inst
  | isPrimaryOffline cfg inst = NodeOffline
  | otherwise = case res of
      Left _                   -> NodeDown
      Right (Just liveData, _) -> liveInstanceStatus cfg liveData inst
      Right (Nothing, _)       -> deadInstanceStatus cfg inst

-- | Extracts the instance status, retrieving it using the functions above and
-- transforming it into a 'ResultEntry'.
statusExtract :: ConfigData -> Runtime -> Instance -> ResultEntry
statusExtract cfg res inst =
  rsNormal . J.showJSON . instanceStatusToRaw $
    determineInstanceStatus cfg res inst

-- | Extracts the operational status of the instance.
operStatusExtract :: Runtime -> Instance -> ResultEntry
operStatusExtract res _ =
  rsMaybeNoData $ J.showJSON <$>
    case res of
      Left _       -> Nothing
      Right (x, _) -> Just $ isJust x

-- | Extracts the console connection information
consoleExtract :: Runtime -> Instance -> ResultEntry
consoleExtract (Left err) _ = ResultEntry (rpcErrorToStatus err) Nothing
consoleExtract (Right (_, val)) _ = rsMaybeNoData val

-- * Helper functions extracting information as necessary for the generic query
-- interfaces

-- | This function checks if a node with a given uuid has experienced an error
-- or not.
checkForNodeError :: [(String, ERpcError a)]
                  -> String
                  -> Maybe RpcError
checkForNodeError uuidList uuid =
  case snd <$> pickPairUnique uuid uuidList of
    Just (Left err) -> Just err
    Just (Right _)  -> Nothing
    Nothing         -> Just . RpcResultError $
                         "Node response not present"

-- | Finds information about the instance in the info delivered by a node
findInfoInNodeResult :: Instance
                     -> ERpcError RpcResultAllInstancesInfo
                     -> Maybe InstanceInfo
findInfoInNodeResult inst nodeResponse =
  case nodeResponse of
    Left  _err    -> Nothing
    Right allInfo ->
      let instances = rpcResAllInstInfoInstances allInfo
          maybeMatch = instName inst >>= (`pickPairUnique` instances)
      in snd <$> maybeMatch

-- | Retrieves the instance information if it is present anywhere in the all
-- instances RPC result. Notes if it originates from the primary node.
-- An error is delivered if there is no result, and the primary node is down.
getInstanceInfo :: [(String, ERpcError RpcResultAllInstancesInfo)]
                -> Instance
                -> ERpcError (Maybe (InstanceInfo, Bool))
getInstanceInfo uuidList inst =
  case instPrimaryNode inst of
    Nothing -> Right Nothing
    Just pNodeUuid ->
      let primarySearchResult =
            pickPairUnique pNodeUuid uuidList >>= findInfoInNodeResult inst
                                                    . snd
      in case primarySearchResult of
           Just instInfo -> Right . Just $ (instInfo, True)
           Nothing       ->
             let allSearchResult =
                   getFirst . mconcat $ map
                   (First . findInfoInNodeResult inst . snd) uuidList
             in case allSearchResult of
                  Just instInfo -> Right . Just $ (instInfo, False)
                  Nothing       ->
                    case checkForNodeError uuidList pNodeUuid of
                      Just err -> Left err
                      Nothing  -> Right Nothing

-- | Retrieves the console information if present anywhere in the given results
getConsoleInfo :: [(String, ERpcError RpcResultInstanceConsoleInfo)]
               -> Instance
               -> Maybe InstanceConsoleInfo
getConsoleInfo uuidList inst =
  let allValidResults = concatMap rpcResInstConsInfoInstancesInfo .
                        rights . map snd $ uuidList
  in snd <$> (instName inst >>= flip pickPairUnique allValidResults)

-- | Extracts all the live information that can be extracted.
extractLiveInfo :: [(Node, ERpcError RpcResultAllInstancesInfo)]
                -> [(Node, ERpcError RpcResultInstanceConsoleInfo)]
                -> Instance
                -> Runtime
extractLiveInfo nodeResultList nodeConsoleList inst =
  let uuidConvert     = map (\(x, y) -> (uuidOf x, y))
      uuidResultList  = uuidConvert nodeResultList
      uuidConsoleList = uuidConvert nodeConsoleList
  in case getInstanceInfo uuidResultList inst of
    -- If we can't get the instance info, we can't get the console info either.
    -- Best to propagate the error further.
    Left err  -> Left err
    Right res -> Right (res, getConsoleInfo uuidConsoleList inst)

-- | Retrieves all the parameters for the console calls.
getAllConsoleParams :: ConfigData
                    -> [Instance]
                    -> ErrorResult [InstanceConsoleInfoParams]
getAllConsoleParams cfg = mapM $ \i ->
  InstanceConsoleInfoParams i
    <$> getPrimaryNode cfg i
    <*> getPrimaryNodeGroup cfg i
    <*> pure (getFilledInstHvParams [] cfg i)
    <*> getFilledInstBeParams cfg i

-- | Compares two params according to their node, needed for grouping.
compareParamsByNode :: InstanceConsoleInfoParams
                    -> InstanceConsoleInfoParams
                    -> Bool
compareParamsByNode x y = instConsInfoParamsNode x == instConsInfoParamsNode y

-- | Groups instance information calls heading out to the same nodes.
consoleParamsToCalls :: [InstanceConsoleInfoParams]
                     -> [(Node, RpcCallInstanceConsoleInfo)]
consoleParamsToCalls params =
  let sortedParams = sortBy
        (comparing (instPrimaryNode . instConsInfoParamsInstance)) params
      groupedParams = groupBy compareParamsByNode sortedParams
  in map (\x -> case x of
            [] -> error "Programmer error: group must have one or more members"
            paramGroup@(y:_) ->
              let node = instConsInfoParamsNode y
                  packer z = do
                              name <- instName $ instConsInfoParamsInstance z
                              return (name, z)
              in (node, RpcCallInstanceConsoleInfo . mapMaybe packer
                          $ paramGroup)
         ) groupedParams

-- | Retrieves a list of all the hypervisors and params used by the given
-- instances.
getHypervisorSpecs :: ConfigData -> [Instance] -> [(Hypervisor, HvParams)]
getHypervisorSpecs cfg instances =
  let hvs = nub . mapMaybe instHypervisor $ instances
      hvParamMap = (fromContainer . clusterHvparams . configCluster $ cfg)
  in zip hvs . map ((Map.!) hvParamMap) $ hvs

-- | Collect live data from RPC query if enabled.
collectLiveData :: Bool        -- ^ Live queries allowed
                -> ConfigData  -- ^ The cluster config
                -> [String]    -- ^ The requested fields
                -> [Instance]  -- ^ The instance objects
                -> IO [(Instance, Runtime)]
collectLiveData liveDataEnabled cfg fields instances
  | not liveDataEnabled = return . zip instances . repeat . Left .
                            RpcResultError $ "Live data disabled"
  | otherwise = do
      let hvSpecs = getHypervisorSpecs cfg instances
          instanceNodes =
            nub . justOk
                $ map ( maybe (Bad $ ParameterError "no primary node") return
                       . instPrimaryNode
                       >=> getNodeByUuid cfg) instances
          goodNodes = nodesWithValidConfig cfg instanceNodes
      instInfoRes <- executeRpcCall goodNodes (RpcCallAllInstancesInfo hvSpecs)
      consInfoRes <-
        if "console" `elem` fields
          then case getAllConsoleParams cfg instances of
            Ok  p -> executeRpcCalls $ consoleParamsToCalls p
            Bad _ -> return . zip goodNodes . repeat . Left $
              RpcResultError "Cannot construct parameters for console info call"
          else return [] -- The information is not necessary
      return . zip instances .
        map (extractLiveInfo instInfoRes consInfoRes) $ instances

-- | An aggregate disk attribute for backward compatibility.
getDiskTemplate :: ConfigData -> Instance -> ResultEntry
getDiskTemplate cfg inst =
  let disks = getInstDisks cfg inst
      getDt x = lidDiskType <$> diskLogicalId x
      disk_types :: ErrorResult [DiskTemplate]
      disk_types = nub <$> catMaybes <$> map getDt <$> disks
      mix :: [DiskTemplate] -> J.JSValue
      mix []  = J.showJSON C.dtDiskless
      mix [t] = J.showJSON t
      mix _   = J.showJSON C.dtMixed
  in case mix <$> disk_types of
       Ok t -> rsNormal t
       Bad _ -> rsNoData