src/Ganeti/Rpc.hs

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
  BangPatterns, TemplateHaskell #-}

{-| Implementation of the RPC client.

-}

{-

Copyright (C) 2012, 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.Rpc
  ( RpcCall
  , Rpc
  , RpcError(..)
  , ERpcError
  , explainRpcError
  , executeRpcCall
  , logRpcErrors

  , rpcCallName
  , rpcCallTimeout
  , rpcCallData
  , rpcCallAcceptOffline

  , rpcResultFill

  , InstanceInfo(..)
  , RpcCallInstanceInfo(..)
  , RpcResultInstanceInfo(..)

  , RpcCallAllInstancesInfo(..)
  , RpcResultAllInstancesInfo(..)

  , RpcCallInstanceList(..)
  , RpcResultInstanceList(..)

  , HvInfo(..)
  , StorageInfo(..)
  , RpcCallNodeInfo(..)
  , RpcResultNodeInfo(..)

  , RpcCallVersion(..)
  , RpcResultVersion(..)

  , RpcCallStorageList(..)
  , RpcResultStorageList(..)

  , RpcCallTestDelay(..)
  , RpcResultTestDelay(..)

  , RpcCallExportList(..)
  , RpcResultExportList(..)
  ) where

import Control.Arrow (second)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import qualified Text.JSON as J
import Text.JSON.Pretty (pp_value)

import Network.Curl
import qualified Ganeti.Path as P

import Ganeti.BasicTypes
import qualified Ganeti.Constants as C
import Ganeti.Logging
import Ganeti.Objects
import Ganeti.THH
import Ganeti.Types
import Ganeti.Curl.Multi
import Ganeti.Utils

-- * Base RPC functionality and types

-- | The curl options used for RPC.
curlOpts :: [CurlOption]
curlOpts = [ CurlFollowLocation False
           , CurlSSLVerifyHost 0
           , CurlSSLVerifyPeer True
           , CurlSSLCertType "PEM"
           , CurlSSLKeyType "PEM"
           , CurlConnectTimeout (fromIntegral C.rpcConnectTimeout)
           ]

-- | Data type for RPC error reporting.
data RpcError
  = CurlLayerError String
  | JsonDecodeError String
  | RpcResultError String
  | OfflineNodeError
  deriving (Show, Eq)

-- | Provide explanation to RPC errors.
explainRpcError :: RpcError -> String
explainRpcError (CurlLayerError code) =
    "Curl error:" ++ code
explainRpcError (JsonDecodeError msg) =
    "Error while decoding JSON from HTTP response: " ++ msg
explainRpcError (RpcResultError msg) =
    "Error reponse received from RPC server: " ++ msg
explainRpcError OfflineNodeError =
    "Node is marked offline"

type ERpcError = Either RpcError

-- | A generic class for RPC calls.
class (J.JSON a) => RpcCall a where
  -- | Give the (Python) name of the procedure.
  rpcCallName :: a -> String
  -- | Calculate the timeout value for the call execution.
  rpcCallTimeout :: a -> Int
  -- | Prepare arguments of the call to be send as POST.
  rpcCallData :: Node -> a -> String
  -- | Whether we accept offline nodes when making a call.
  rpcCallAcceptOffline :: a -> Bool

-- | Generic class that ensures matching RPC call with its respective
-- result.
class (RpcCall a, J.JSON b) => Rpc a b  | a -> b, b -> a where
  -- | Create a result based on the received HTTP response.
  rpcResultFill :: a -> J.JSValue -> ERpcError b

-- | Http Request definition.
data HttpClientRequest = HttpClientRequest
  { requestUrl  :: String       -- ^ The actual URL for the node endpoint
  , requestData :: String       -- ^ The arguments for the call
  , requestOpts :: [CurlOption] -- ^ The various curl options
  }

-- | Check if a string represented address is IPv6
isIpV6 :: String -> Bool
isIpV6 = (':' `elem`)

-- | Prepare url for the HTTP request.
prepareUrl :: (RpcCall a) => Node -> a -> String
prepareUrl node call =
  let node_ip = nodePrimaryIp node
      node_address = if isIpV6 node_ip
                     then "[" ++ node_ip ++ "]"
                     else node_ip
      port = C.defaultNodedPort
      path_prefix = "https://" ++ node_address ++ ":" ++ show port
  in path_prefix ++ "/" ++ rpcCallName call

-- | Create HTTP request for a given node provided it is online,
-- otherwise create empty response.
prepareHttpRequest :: (RpcCall a) => [CurlOption] -> Node -> a
                   -> ERpcError HttpClientRequest
prepareHttpRequest opts node call
  | rpcCallAcceptOffline call || not (nodeOffline node) =
      Right HttpClientRequest { requestUrl  = prepareUrl node call
                              , requestData = rpcCallData node call
                              , requestOpts = opts ++ curlOpts
                              }
  | otherwise = Left OfflineNodeError

-- | Parse an HTTP reply.
parseHttpReply :: (Rpc a b) =>
                  a -> ERpcError (CurlCode, String) -> ERpcError b
parseHttpReply _ (Left e) = Left e
parseHttpReply call (Right (CurlOK, body)) = parseHttpResponse call body
parseHttpReply _ (Right (code, err)) =
  Left . CurlLayerError $ "code: " ++ show code ++ ", explanation: " ++ err

-- | Parse a result based on the received HTTP response.
parseHttpResponse :: (Rpc a b) => a -> String -> ERpcError b
parseHttpResponse call res =
  case J.decode res of
    J.Error val -> Left $ JsonDecodeError val
    J.Ok (True, res'') -> rpcResultFill call res''
    J.Ok (False, jerr) -> case jerr of
       J.JSString msg -> Left $ RpcResultError (J.fromJSString msg)
       _ -> Left . JsonDecodeError $ show (pp_value jerr)

-- | Scan the list of results produced by executeRpcCall and log all the RPC
-- errors.
logRpcErrors :: [(a, ERpcError b)] -> IO ()
logRpcErrors allElems =
  let logOneRpcErr (_, Right _) = return ()
      logOneRpcErr (_, Left err) =
        logError $ "Error in the RPC HTTP reply: " ++ show err
  in mapM_ logOneRpcErr allElems

-- | Execute RPC call for many nodes in parallel.
executeRpcCall :: (Rpc a b) => [Node] -> a -> IO [(Node, ERpcError b)]
executeRpcCall nodes call = do
  cert_file <- P.nodedCertFile
  let opts = [ CurlTimeout (fromIntegral $ rpcCallTimeout call)
             , CurlSSLCert cert_file
             , CurlSSLKey cert_file
             , CurlCAInfo cert_file
             ]
      opts_urls = map (\n ->
                         case prepareHttpRequest opts n call of
                           Left v -> Left v
                           Right request ->
                             Right (CurlPostFields [requestData request]:
                                    requestOpts request,
                                    requestUrl request)
                      ) nodes
  -- split the opts_urls list; we don't want to pass the
  -- failed-already nodes to Curl
  let (lefts, rights, trail) = splitEithers opts_urls
  results <- execMultiCall rights
  results' <- case recombineEithers lefts results trail of
                Bad msg -> error msg
                Ok r -> return r
  -- now parse the replies
  let results'' = map (parseHttpReply call) results'
      pairedList = zip nodes results''
  logRpcErrors pairedList
  return pairedList

-- | Helper function that is used to read dictionaries of values.
sanitizeDictResults :: [(String, J.Result a)] -> ERpcError [(String, a)]
sanitizeDictResults =
  foldr sanitize1 (Right [])
  where
    sanitize1 _ (Left e) = Left e
    sanitize1 (_, J.Error e) _ = Left $ JsonDecodeError e
    sanitize1 (name, J.Ok v) (Right res) = Right $ (name, v) : res

-- | Helper function to tranform JSON Result to Either RpcError b.
-- Note: For now we really only use it for b s.t. Rpc c b for some c
fromJResultToRes :: J.Result a -> (a -> b) -> ERpcError b
fromJResultToRes (J.Error v) _ = Left $ JsonDecodeError v
fromJResultToRes (J.Ok v) f = Right $ f v

-- | Helper function transforming JSValue to Rpc result type.
fromJSValueToRes :: (J.JSON a) => J.JSValue -> (a -> b) -> ERpcError b
fromJSValueToRes val = fromJResultToRes (J.readJSON val)

-- * RPC calls and results

-- ** Instance info

-- | InstanceInfo
--   Returns information about a single instance.

$(buildObject "RpcCallInstanceInfo" "rpcCallInstInfo"
  [ simpleField "instance" [t| String |]
  , simpleField "hname" [t| Hypervisor |]
  ])

$(buildObject "InstanceInfo" "instInfo"
  [ simpleField "memory" [t| Int|]
  , simpleField "state"  [t| String |] -- It depends on hypervisor :(
  , simpleField "vcpus"  [t| Int |]
  , simpleField "time"   [t| Int |]
  ])

-- This is optional here because the result may be empty if instance is
-- not on a node - and this is not considered an error.
$(buildObject "RpcResultInstanceInfo" "rpcResInstInfo"
  [ optionalField $ simpleField "inst_info" [t| InstanceInfo |]])

instance RpcCall RpcCallInstanceInfo where
  rpcCallName _          = "instance_info"
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
  rpcCallAcceptOffline _ = False
  rpcCallData _ call     = J.encode
    ( rpcCallInstInfoInstance call
    , rpcCallInstInfoHname call
    )

instance Rpc RpcCallInstanceInfo RpcResultInstanceInfo where
  rpcResultFill _ res =
    case res of
      J.JSObject res' ->
        case J.fromJSObject res' of
          [] -> Right $ RpcResultInstanceInfo Nothing
          _ -> fromJSValueToRes res (RpcResultInstanceInfo . Just)
      _ -> Left $ JsonDecodeError
           ("Expected JSObject, got " ++ show (pp_value res))

-- ** AllInstancesInfo

-- | AllInstancesInfo
--   Returns information about all running instances on the given nodes
$(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo"
  [ simpleField "hypervisors" [t| [Hypervisor] |] ])

$(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo"
  [ simpleField "instances" [t| [(String, InstanceInfo)] |] ])

instance RpcCall RpcCallAllInstancesInfo where
  rpcCallName _          = "all_instances_info"
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
  rpcCallAcceptOffline _ = False
  rpcCallData _ call     = J.encode [rpcCallAllInstInfoHypervisors call]

instance Rpc RpcCallAllInstancesInfo RpcResultAllInstancesInfo where
  -- FIXME: Is there a simpler way to do it?
  rpcResultFill _ res =
    case res of
      J.JSObject res' ->
        let res'' = map (second J.readJSON) (J.fromJSObject res')
                        :: [(String, J.Result InstanceInfo)] in
        case sanitizeDictResults res'' of
          Left err -> Left err
          Right insts -> Right $ RpcResultAllInstancesInfo insts
      _ -> Left $ JsonDecodeError
           ("Expected JSObject, got " ++ show (pp_value res))

-- ** InstanceList

-- | InstanceList
-- Returns the list of running instances on the given nodes.
$(buildObject "RpcCallInstanceList" "rpcCallInstList"
  [ simpleField "hypervisors" [t| [Hypervisor] |] ])

$(buildObject "RpcResultInstanceList" "rpcResInstList"
  [ simpleField "instances" [t| [String] |] ])

instance RpcCall RpcCallInstanceList where
  rpcCallName _          = "instance_list"
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
  rpcCallAcceptOffline _ = False
  rpcCallData _ call     = J.encode [rpcCallInstListHypervisors call]

instance Rpc RpcCallInstanceList RpcResultInstanceList where
  rpcResultFill _ res = fromJSValueToRes res RpcResultInstanceList

-- ** NodeInfo

-- | NodeInfo
-- Return node information.
$(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo"
  [ simpleField "storage_units" [t| Map.Map String [StorageUnit] |]
  , simpleField "hypervisors" [t| [ (Hypervisor, HvParams) ] |]
  ])

$(buildObject "StorageInfo" "storageInfo"
  [ simpleField "name" [t| String |]
  , simpleField "type" [t| String |]
  , optionalField $ simpleField "storage_free" [t| Int |]
  , optionalField $ simpleField "storage_size" [t| Int |]
  ])

-- | We only provide common fields as described in hv_base.py.
$(buildObject "HvInfo" "hvInfo"
  [ simpleField "memory_total" [t| Int |]
  , simpleField "memory_free" [t| Int |]
  , simpleField "memory_dom0" [t| Int |]
  , simpleField "cpu_total" [t| Int |]
  , simpleField "cpu_nodes" [t| Int |]
  , simpleField "cpu_sockets" [t| Int |]
  , simpleField "cpu_dom0" [t| Int |]
  ])

$(buildObject "RpcResultNodeInfo" "rpcResNodeInfo"
  [ simpleField "boot_id" [t| String |]
  , simpleField "storage_info" [t| [StorageInfo] |]
  , simpleField "hv_info" [t| [HvInfo] |]
  ])

instance RpcCall RpcCallNodeInfo where
  rpcCallName _          = "node_info"
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
  rpcCallAcceptOffline _ = False
  rpcCallData n call     = J.encode
    ( fromMaybe (error $ "Programmer error: missing parameter for node named "
                         ++ nodeName n)
          $ Map.lookup (nodeUuid n) (rpcCallNodeInfoStorageUnits call)
    , rpcCallNodeInfoHypervisors call
    )

instance Rpc RpcCallNodeInfo RpcResultNodeInfo where
  rpcResultFill _ res =
    fromJSValueToRes res (\(b, vg, hv) -> RpcResultNodeInfo b vg hv)

-- ** Version

-- | Query node version.
$(buildObject "RpcCallVersion" "rpcCallVersion" [])

-- | Query node reply.
$(buildObject "RpcResultVersion" "rpcResultVersion"
  [ simpleField "version" [t| Int |]
  ])

instance RpcCall RpcCallVersion where
  rpcCallName _          = "version"
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
  rpcCallAcceptOffline _ = True
  rpcCallData _          = J.encode

instance Rpc RpcCallVersion RpcResultVersion where
  rpcResultFill _ res = fromJSValueToRes res RpcResultVersion

-- ** StorageList

$(buildObject "RpcCallStorageList" "rpcCallStorageList"
  [ simpleField "su_name" [t| StorageType |]
  , simpleField "su_args" [t| [String] |]
  , simpleField "name"    [t| String |]
  , simpleField "fields"  [t| [StorageField] |]
  ])

-- FIXME: The resulting JSValues should have types appropriate for their
-- StorageField value: Used -> Bool, Name -> String etc
$(buildObject "RpcResultStorageList" "rpcResStorageList"
  [ simpleField "storage" [t| [[(StorageField, J.JSValue)]] |] ])

instance RpcCall RpcCallStorageList where
  rpcCallName _          = "storage_list"
  rpcCallTimeout _       = rpcTimeoutToRaw Normal
  rpcCallAcceptOffline _ = False
  rpcCallData _ call     = J.encode
    ( rpcCallStorageListSuName call
    , rpcCallStorageListSuArgs call
    , rpcCallStorageListName call
    , rpcCallStorageListFields call
    )

instance Rpc RpcCallStorageList RpcResultStorageList where
  rpcResultFill call res =
    let sfields = rpcCallStorageListFields call in
    fromJSValueToRes res (RpcResultStorageList . map (zip sfields))

-- ** TestDelay

-- | Call definition for test delay.
$(buildObject "RpcCallTestDelay" "rpcCallTestDelay"
  [ simpleField "duration" [t| Double |]
  ])

-- | Result definition for test delay.
data RpcResultTestDelay = RpcResultTestDelay
                          deriving Show

-- | Custom JSON instance for null result.
instance J.JSON RpcResultTestDelay where
  showJSON _        = J.JSNull
  readJSON J.JSNull = return RpcResultTestDelay
  readJSON _        = fail "Unable to read RpcResultTestDelay"

instance RpcCall RpcCallTestDelay where
  rpcCallName _          = "test_delay"
  rpcCallTimeout         = ceiling . (+ 5) . rpcCallTestDelayDuration
  rpcCallAcceptOffline _ = False
  rpcCallData _ call     = J.encode [rpcCallTestDelayDuration call]

instance Rpc RpcCallTestDelay RpcResultTestDelay where
  rpcResultFill _ res = fromJSValueToRes res id

-- ** ExportList

-- | Call definition for export list.

$(buildObject "RpcCallExportList" "rpcCallExportList" [])

-- | Result definition for export list.
$(buildObject "RpcResultExportList" "rpcResExportList"
  [ simpleField "exports" [t| [String] |]
  ])

instance RpcCall RpcCallExportList where
  rpcCallName _          = "export_list"
  rpcCallTimeout _       = rpcTimeoutToRaw Fast
  rpcCallAcceptOffline _ = False
  rpcCallData _          = J.encode

instance Rpc RpcCallExportList RpcResultExportList where
  rpcResultFill _ res = fromJSValueToRes res RpcResultExportList