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
  , executeRpcCalls
  , rpcErrors
  , logRpcErrors

  , rpcCallName
  , rpcCallTimeout
  , rpcCallData
  , rpcCallAcceptOffline

  , rpcResultFill

  , Compressed
  , packCompressed
  , toCompressed
  , getCompressed

  , RpcCallNodeActivateMasterIp(..)
  , RpcResultNodeActivateMasterIp(..)

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

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

  , InstanceConsoleInfoParams(..)
  , InstanceConsoleInfo(..)
  , RpcCallInstanceConsoleInfo(..)
  , RpcResultInstanceConsoleInfo(..)

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

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

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

  , RpcCallMasterNodeName(..)
  , RpcResultMasterNodeName(..)

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

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

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

  , RpcCallJobqueueUpdate(..)
  , RpcCallJobqueueRename(..)
  , RpcCallSetWatcherPause(..)
  , RpcCallSetDrainFlag(..)

  , RpcCallUploadFile(..)
  , prepareRpcCallUploadFile
  , RpcCallWriteSsconfFiles(..)
  ) where

import Control.Arrow (second)
import Control.Monad
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.Map as Map
import Data.List (zipWith4)
import Data.Maybe (mapMaybe)
import qualified Text.JSON as J
import Text.JSON.Pretty (pp_value)
import qualified Data.ByteString.Base64.Lazy as Base64
import System.Directory
import System.Posix.Files ( modificationTime, accessTime, fileOwner
                          , fileGroup, fileMode, getFileStatus)

import Network.BSD (getServiceByName, servicePort)
import Network.Curl hiding (content)
import qualified Ganeti.Path as P

import Ganeti.BasicTypes
import qualified Ganeti.Constants as C
import Ganeti.Codec
import Ganeti.Curl.Multi
import Ganeti.Errors
import Ganeti.JSON (ArrayObject(..), GenericContainer(..))
import Ganeti.Logging
import Ganeti.Objects
import Ganeti.Runtime
import Ganeti.Ssconf
import Ganeti.THH
import Ganeti.THH.Field
import Ganeti.Types
import Ganeti.Utils
import Ganeti.VCluster

-- * 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 (ArrayObject 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 :: a -> String
  rpcCallData = J.encode . J.JSArray . toJSArray
  -- | 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) => Int -> Node -> a -> String
prepareUrl port node call =
  let node_ip = nodePrimaryIp node
      node_address = if isIpV6 node_ip
                     then "[" ++ node_ip ++ "]"
                     else node_ip
      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) => Int -> [CurlOption] -> Node
                   -> String -> a -> ERpcError HttpClientRequest
prepareHttpRequest port opts node reqdata call
  | rpcCallAcceptOffline call || not (nodeOffline node) =
      Right HttpClientRequest { requestUrl  = prepareUrl port node call
                              , requestData = reqdata
                              , 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 extract
-- all the RPC errors.
rpcErrors :: [(a, ERpcError b)] -> [(a, RpcError)]
rpcErrors =
  let rpcErr (node, Left err) = Just (node, err)
      rpcErr _                = Nothing
  in mapMaybe rpcErr

-- | Scan the list of results produced by executeRpcCall and log all the RPC
-- errors. Returns the list of errors for further processing.
logRpcErrors :: (MonadLog m, Show a) => [(a, ERpcError b)]
                                     -> m [(a, RpcError)]
logRpcErrors rs =
  let logOneRpcErr (node, err) =
        logError $ "Error in the RPC HTTP reply from '" ++
                   show node ++ "': " ++ show err
      errs = rpcErrors rs
  in mapM_ logOneRpcErr errs >> return errs

-- | Get options for RPC call
getOptionsForCall :: (Rpc a b) => FilePath -> FilePath -> a -> [CurlOption]
getOptionsForCall cert_path client_cert_path call =
  [ CurlTimeout (fromIntegral $ rpcCallTimeout call)
  , CurlSSLCert client_cert_path
  , CurlSSLKey client_cert_path
  , CurlCAInfo cert_path
  ]

-- | Determine to port to call noded at.
getNodedPort :: IO Int
getNodedPort = withDefaultOnIOError C.defaultNodedPort
               . liftM (fromIntegral . servicePort)
               $ getServiceByName C.noded "tcp"

-- | Execute multiple distinct RPC calls in parallel
executeRpcCalls :: (Rpc a b) => [(Node, a)] -> IO [(Node, ERpcError b)]
executeRpcCalls = executeRpcCalls' . map (\(n, c) -> (n, c, rpcCallData c))

-- | Execute multiple RPC calls in parallel
executeRpcCalls' :: (Rpc a b) => [(Node, a, String)] -> IO [(Node, ERpcError b)]
executeRpcCalls' nodeCalls = do
  port <- getNodedPort
  cert_file <- P.nodedCertFile
  client_cert_file_name <- P.nodedClientCertFile
  client_file_exists <- doesFileExist client_cert_file_name
  -- This is needed to allow upgrades from 2.10 or earlier;
  -- note that Ganeti supports jump-upgrades.
  let client_cert_file = if client_file_exists
                         then client_cert_file_name
                         else cert_file
      (nodes, calls, datas) = unzip3 nodeCalls
      opts = map (getOptionsForCall cert_file client_cert_file) calls
      opts_urls = zipWith4 (\n c d o ->
                         case prepareHttpRequest port o n d c of
                           Left v -> Left v
                           Right request ->
                             Right (CurlPostFields [requestData request]:
                                    requestOpts request,
                                    requestUrl request)
                    ) nodes calls datas opts
  -- 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'' = zipWith parseHttpReply calls results'
      pairedList = zip nodes results''
  _ <- logRpcErrors pairedList
  return pairedList

-- | Execute an RPC call for many nodes in parallel.
-- NB this computes the RPC call payload string only once.
executeRpcCall :: (Rpc a b) => [Node] -> a -> IO [(Node, ERpcError b)]
executeRpcCall nodes call = executeRpcCalls' [(n, call, rpc_data) | n <- nodes]
  where rpc_data = rpcCallData call

-- | 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)

-- | An opaque data type for representing data that might be compressed
-- over the wire.
--
-- On Python side it is decompressed by @backend._Decompress@.
newtype Compressed = Compressed { getCompressed :: BL.ByteString }
  deriving (Eq, Ord, Show)

-- TODO Add a unit test for all octets
instance J.JSON Compressed where
  -- zlib compress and Base64 encode the data but only if it's long enough
  showJSON = J.showJSON
    . (\x ->
      if (BL.length $ BL.take 4096 x) < 4096 then
        (C.rpcEncodingNone, x)
      else
        (C.rpcEncodingZlibBase64, Base64.encode . compressZlib $ x)
      )
    . getCompressed

  readJSON = J.readJSON >=> decompress
    where
      decompress (enc, cont)
        | enc == C.rpcEncodingNone =
            return $ Compressed cont
        | enc == C.rpcEncodingZlibBase64 =
            liftM Compressed
            . either fail return . decompressZlib
            <=< either (fail . ("Base64: " ++)) return . Base64.decode
            $ cont
        | otherwise =
            fail $ "Unknown RPC encoding type: " ++ show enc

packCompressed :: BL.ByteString -> Compressed
packCompressed = Compressed

toCompressed :: String -> Compressed
toCompressed = packCompressed . BL.pack

-- * RPC calls and results

-- ** Instance info

-- | Returns information about a single instance
$(buildObject "RpcCallInstanceInfo" "rpcCallInstInfo"
  [ simpleField "instance" [t| String |]
  , simpleField "hname" [t| Hypervisor |]
  ])

$(declareILADT "InstanceState"
  [ ("InstanceStateRunning", 0)
  , ("InstanceStateShutdown", 1)
  ])

$(makeJSONInstance ''InstanceState)

instance PyValue InstanceState where
  showValue = show . instanceStateToRaw

$(buildObject "InstanceInfo" "instInfo"
  [ simpleField "memory" [t| Int|]
  , simpleField "state"  [t| InstanceState |]
  , 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

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

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

$(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 (
    map fst $ rpcCallAllInstInfoHypervisors call,
    GenericContainer . Map.fromList $ 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))

-- ** InstanceConsoleInfo

-- | Returns information about how to access instances on the given node
$(buildObject "InstanceConsoleInfoParams" "instConsInfoParams"
  [ simpleField "instance"    [t| Instance |]
  , simpleField "node"        [t| Node |]
  , simpleField "group"       [t| NodeGroup |]
  , simpleField "hvParams"    [t| HvParams |]
  , simpleField "beParams"    [t| FilledBeParams |]
  ])

$(buildObject "RpcCallInstanceConsoleInfo" "rpcCallInstConsInfo"
  [ simpleField "instanceInfo" [t| [(String, InstanceConsoleInfoParams)] |] ])

$(buildObject "InstanceConsoleInfo" "instConsInfo"
  [ simpleField "instance"    [t| String |]
  , simpleField "kind"        [t| String |]
  , optionalField $
    simpleField "message"     [t| String |]
  , optionalField $
    simpleField "host"        [t| String |]
  , optionalField $
    simpleField "port"        [t| Int |]
  , optionalField $
    simpleField "user"        [t| String |]
  , optionalField $
    simpleField "command"     [t| [String] |]
  , optionalField $
    simpleField "display"     [t| String |]
  ])

$(buildObject "RpcResultInstanceConsoleInfo" "rpcResInstConsInfo"
  [ simpleField "instancesInfo" [t| [(String, InstanceConsoleInfo)] |] ])

instance RpcCall RpcCallInstanceConsoleInfo where
  rpcCallName _          = "instance_console_info"
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
  rpcCallAcceptOffline _ = False
  rpcCallData call       = J.encode .
    GenericContainer $ Map.fromList (rpcCallInstConsInfoInstanceInfo call)

instance Rpc RpcCallInstanceConsoleInfo RpcResultInstanceConsoleInfo where
  rpcResultFill _ res =
    case res of
      J.JSObject res' ->
        let res'' = map (second J.readJSON) (J.fromJSObject res')
                        :: [(String, J.Result InstanceConsoleInfo)] in
        case sanitizeDictResults res'' of
          Left err -> Left err
          Right instInfos -> Right $ RpcResultInstanceConsoleInfo instInfos
      _ -> Left $ JsonDecodeError
           ("Expected JSObject, got " ++ show (pp_value res))

-- ** 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

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

-- ** NodeInfo

-- | Returns node information
$(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo"
  [ simpleField "storage_units" [t| [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 |]
  ])

-- | Common fields (as described in hv_base.py) are mandatory,
-- other fields are optional.
$(buildObject "HvInfo" "hvInfo"
  [ optionalField $ simpleField C.hvNodeinfoKeyVersion [t| [Int] |]
  , simpleField "memory_total" [t| Int |]
  , simpleField "memory_free" [t| Int |]
  , simpleField "memory_dom0" [t| Int |]
  , optionalField $ simpleField "memory_hv" [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 call       = J.encode
    ( 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

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

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

-- ** Job Queue Replication

-- | Update a job queue file

$(buildObject "RpcCallJobqueueUpdate" "rpcCallJobqueueUpdate"
  [ simpleField "file_name" [t| String |]
  , simpleField "content" [t| String |]
  ])

$(buildObject "RpcResultJobQueueUpdate" "rpcResultJobQueueUpdate" [])

instance RpcCall RpcCallJobqueueUpdate where
  rpcCallName _          = "jobqueue_update"
  rpcCallTimeout _       = rpcTimeoutToRaw Fast
  rpcCallAcceptOffline _ = False
  rpcCallData call       = J.encode
    ( rpcCallJobqueueUpdateFileName call
    , toCompressed $ rpcCallJobqueueUpdateContent call
    )

instance Rpc RpcCallJobqueueUpdate RpcResultJobQueueUpdate where
  rpcResultFill _ res =
    case res of
      J.JSNull ->  Right RpcResultJobQueueUpdate
      _ -> Left $ JsonDecodeError
           ("Expected JSNull, got " ++ show (pp_value res))

-- | Rename a file in the job queue

$(buildObject "RpcCallJobqueueRename" "rpcCallJobqueueRename"
  [ simpleField "rename" [t| [(String, String)] |]
  ])

$(buildObject "RpcResultJobqueueRename" "rpcResultJobqueueRename" [])

instance RpcCall RpcCallJobqueueRename where
  rpcCallName _          = "jobqueue_rename"
  rpcCallTimeout _       = rpcTimeoutToRaw Fast
  rpcCallAcceptOffline _ = False

instance Rpc RpcCallJobqueueRename RpcResultJobqueueRename where
  rpcResultFill call res =
    -- Upon success, the RPC returns the list of return values of
    -- the rename operations, which is always None, serialized to
    -- null in JSON.
    let expected = J.showJSON . map (const J.JSNull)
                     $ rpcCallJobqueueRenameRename call
    in if res == expected
      then Right RpcResultJobqueueRename
      else Left
             $ JsonDecodeError ("Expected JSNull, got " ++ show (pp_value res))

-- ** Watcher Status Update

-- | Set the watcher status

$(buildObject "RpcCallSetWatcherPause" "rpcCallSetWatcherPause"
  [ optionalField $ timeAsDoubleField "time"
  ])

instance RpcCall RpcCallSetWatcherPause where
  rpcCallName _          = "set_watcher_pause"
  rpcCallTimeout _       = rpcTimeoutToRaw Fast
  rpcCallAcceptOffline _ = False

$(buildObject "RpcResultSetWatcherPause" "rpcResultSetWatcherPause" [])

instance Rpc RpcCallSetWatcherPause RpcResultSetWatcherPause where
  rpcResultFill _ res =
    case res of
      J.JSNull ->  Right RpcResultSetWatcherPause
      _ -> Left $ JsonDecodeError
           ("Expected JSNull, got " ++ show (pp_value res))

-- ** Queue drain status

-- | Set the queu drain flag

$(buildObject "RpcCallSetDrainFlag" "rpcCallSetDrainFlag"
  [ simpleField "value" [t| Bool |]
  ])

instance RpcCall RpcCallSetDrainFlag where
  rpcCallName _          = "jobqueue_set_drain_flag"
  rpcCallTimeout _       = rpcTimeoutToRaw Fast
  rpcCallAcceptOffline _ = False

$(buildObject "RpcResultSetDrainFlag" "rpcResultSetDrainFalg" [])

instance Rpc RpcCallSetDrainFlag RpcResultSetDrainFlag where
  rpcResultFill _ res =
    case res of
      J.JSNull ->  Right RpcResultSetDrainFlag
      _ -> Left $ JsonDecodeError
           ("Expected JSNull, got " ++ show (pp_value res))

-- ** Configuration files upload to nodes

-- | Upload a configuration file to nodes

$(buildObject "RpcCallUploadFile" "rpcCallUploadFile"
  [ simpleField "file_name" [t| FilePath |]
  , simpleField "content" [t| Compressed |]
  , optionalField $ fileModeAsIntField "mode"
  , simpleField "uid" [t| String |]
  , simpleField "gid" [t| String |]
  , timeAsDoubleField "atime"
  , timeAsDoubleField "mtime"
  ])

instance RpcCall RpcCallUploadFile where
  rpcCallName _          = "upload_file_single"
  rpcCallTimeout _       = rpcTimeoutToRaw Normal
  rpcCallAcceptOffline _ = False

$(buildObject "RpcResultUploadFile" "rpcResultUploadFile" [])

instance Rpc RpcCallUploadFile RpcResultUploadFile where
  rpcResultFill _ res =
    case res of
      J.JSNull -> Right RpcResultUploadFile
      _ -> Left $ JsonDecodeError
           ("Expected JSNull, got " ++ show (pp_value res))

-- | Reads a file and constructs the corresponding 'RpcCallUploadFile' value.
prepareRpcCallUploadFile :: RuntimeEnts -> FilePath
                         -> ResultG RpcCallUploadFile
prepareRpcCallUploadFile re path = do
  status <- liftIO $ getFileStatus path
  content <- liftIO $ BL.readFile path
  let lookupM x m = maybe (failError $ "Uid/gid " ++ show x ++
                                       " not found, probably file " ++
                                       show path ++ " isn't a Ganeti file")
                          return
                          (Map.lookup x m)
  uid <- lookupM (fileOwner status) (reUidToUser re)
  gid <- lookupM (fileGroup status) (reGidToGroup re)
  vpath <- liftIO $ makeVirtualPath path
  return $ RpcCallUploadFile
    vpath
    (packCompressed content)
    (Just $ fileMode status)
    uid
    gid
    (cTimeToClockTime $ accessTime status)
    (cTimeToClockTime $ modificationTime status)

-- | Upload ssconf files to nodes

$(buildObject "RpcCallWriteSsconfFiles" "rpcCallWriteSsconfFiles"
  [ simpleField "values" [t| SSConf |]
  ])

instance RpcCall RpcCallWriteSsconfFiles where
  rpcCallName _          = "write_ssconf_files"
  rpcCallTimeout _       = rpcTimeoutToRaw Fast
  rpcCallAcceptOffline _ = False

$(buildObject "RpcResultWriteSsconfFiles" "rpcResultWriteSsconfFiles" [])

instance Rpc RpcCallWriteSsconfFiles RpcResultWriteSsconfFiles where
  rpcResultFill _ res =
    case res of
      J.JSNull -> Right RpcResultWriteSsconfFiles
      _ -> Left $ JsonDecodeError
           ("Expected JSNull, got " ++ show (pp_value res))

-- | Activate the master IP address

$(buildObject "RpcCallNodeActivateMasterIp" "rpcCallNodeActivateMasterIp"
  [ simpleField "params" [t| MasterNetworkParameters |]
  , simpleField "ems"    [t| Bool |]
  ])

instance RpcCall RpcCallNodeActivateMasterIp where
  rpcCallName _          = "node_activate_master_ip"
  rpcCallTimeout _       = rpcTimeoutToRaw Fast
  rpcCallAcceptOffline _ = False

$(buildObject "RpcResultNodeActivateMasterIp" "rpcResultNodeActivateMasterIp"
  [])

instance Rpc RpcCallNodeActivateMasterIp RpcResultNodeActivateMasterIp where
  rpcResultFill _ res =
    case res of
      J.JSNull -> Right RpcResultNodeActivateMasterIp
      _ -> Left $ JsonDecodeError
           ("Expected JSNull, got " ++ show (pp_value res))

-- | Ask who the node believes is the master.

$(buildObject "RpcCallMasterNodeName" "rpcCallMasterNodeName" [])

instance RpcCall RpcCallMasterNodeName where
  rpcCallName _           = "master_node_name"
  rpcCallTimeout _        = rpcTimeoutToRaw Slow
  rpcCallAcceptOffline _  = True

$(buildObject "RpcResultMasterNodeName" "rpcResultMasterNodeName"
    [ simpleField "master" [t| String |]
    ])

instance Rpc RpcCallMasterNodeName RpcResultMasterNodeName where
  rpcResultFill _ res =
    case res of
      J.JSString master -> Right . RpcResultMasterNodeName
                                     $ J.fromJSString master
      _ -> Left . JsonDecodeError . (++) "expected string, but got " . show
                                            $ pp_value res