content: {-| 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)
      -- 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 getInstDisksFromObj diskSize,
      QffNormal)
    , (fieldDefinitionCompleter "disk.spindles/%d" "DiskSpindles/%d" QFTNumber
      "Spindles of %s disk",
      getIndexedOptionalConfField getInstDisksFromObj diskSpindles,
      QffNormal)
    , (fieldDefinitionCompleter "disk.name/%d" "DiskName/%d" QFTText
      "Name of %s disk",
      getIndexedOptionalConfField getInstDisksFromObj diskName, QffNormal)
    , (fieldDefinitionCompleter "disk.uuid/%d" "DiskUUID/%d" QFTText
      "UUID of %s disk",
      getIndexedConfField getInstDisksFromObj 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) . getInstDisksFromObj 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)
    . getInstDisksFromObj cfg
  
  -- | Get a list of disk spindles
  getDiskSpindles :: ConfigData -> Instance -> ResultEntry
  getDiskSpindles cfg =
    rsErrorNoData . liftA (map (MaybeForJSON . diskSpindles)) .
      getInstDisksFromObj cfg
  
  -- | Get a list of disk names for an instance
  getDiskNames :: ConfigData -> Instance -> ResultEntry
  getDiskNames cfg =
    rsErrorNoData . liftA (map (MaybeForJSON . diskName)) .
      getInstDisksFromObj cfg
  
  -- | Get a list of disk UUIDs for an instance
  getDiskUuids :: ConfigData -> Instance -> ResultEntry
  getDiskUuids cfg =
    rsErrorNoData . liftA (map uuidOf) . getInstDisksFromObj cfg
  
  -- | 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)
                      >>= getNode 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
                         >=> getNode 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 = getInstDisksFromObj 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
  