code.grnet.gr Git - ganeti-local/blob - htools/Ganeti/Rpc.hs

   1 {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, CPP,
   2   BangPatterns #-}
   3
   4 {-| Implementation of the RPC client.
   5
   6 -}
   7
   8 {-
   9
  10 Copyright (C) 2012 Google Inc.
  11
  12 This program is free software; you can redistribute it and/or modify
  13 it under the terms of the GNU General Public License as published by
  14 the Free Software Foundation; either version 2 of the License, or
  15 (at your option) any later version.
  16
  17 This program is distributed in the hope that it will be useful, but
  18 WITHOUT ANY WARRANTY; without even the implied warranty of
  19 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 General Public License for more details.
  21
  22 You should have received a copy of the GNU General Public License
  23 along with this program; if not, write to the Free Software
  24 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  25 02110-1301, USA.
  26
  27 -}
  28
  29 module Ganeti.Rpc
  30   ( RpcCall
  31   , RpcResult
  32   , Rpc
  33   , RpcError(..)
  34   , executeRpcCall
  35
  36   , rpcCallName
  37   , rpcCallTimeout
  38   , rpcCallData
  39   , rpcCallAcceptOffline
  40
  41   , rpcResultFill
  42   ) where
  43
  44 import qualified Text.JSON as J
  45
  46 #ifndef NO_CURL
  47 import Network.Curl
  48 #endif
  49
  50 import qualified Ganeti.Constants as C
  51 import Ganeti.Objects
  52 import Ganeti.HTools.Compat
  53
  54 #ifndef NO_CURL
  55 -- | The curl options used for RPC.
  56 curlOpts :: [CurlOption]
  57 curlOpts = [ CurlFollowLocation False
  58            , CurlCAInfo C.nodedCertFile
  59            , CurlSSLVerifyHost 0
  60            , CurlSSLVerifyPeer True
  61            , CurlSSLCertType "PEM"
  62            , CurlSSLCert C.nodedCertFile
  63            , CurlSSLKeyType "PEM"
  64            , CurlSSLKey C.nodedCertFile
  65            , CurlConnectTimeout (fromIntegral C.rpcConnectTimeout)
  66            ]
  67 #endif
  68
  69 -- | Data type for RPC error reporting.
  70 data RpcError
  71   = CurlDisabledError
  72   | CurlLayerError Node String
  73   | JsonDecodeError String
  74   | OfflineNodeError Node
  75   deriving Eq
  76
  77 instance Show RpcError where
  78   show CurlDisabledError =
  79     "RPC/curl backend disabled at compile time"
  80   show (CurlLayerError node code) =
  81     "Curl error for " ++ nodeName node ++ ", error " ++ code
  82   show (JsonDecodeError msg) =
  83     "Error while decoding JSON from HTTP response " ++ msg
  84   show (OfflineNodeError node) =
  85     "Node " ++ nodeName node ++ " is marked as offline"
  86
  87 rpcErrorJsonReport :: (Monad m) => J.Result a -> m (Either RpcError a)
  88 rpcErrorJsonReport (J.Error x) = return $ Left $ JsonDecodeError x
  89 rpcErrorJsonReport (J.Ok x) = return $ Right x
  90
  91 -- | A generic class for RPC calls.
  92 class (J.JSON a) => RpcCall a where
  93   -- | Give the (Python) name of the procedure.
  94   rpcCallName :: a -> String
  95   -- | Calculate the timeout value for the call execution.
  96   rpcCallTimeout :: a -> Int
  97   -- | Prepare arguments of the call to be send as POST.
  98   rpcCallData :: Node -> a -> String
  99   -- | Whether we accept offline nodes when making a call.
 100   rpcCallAcceptOffline :: a -> Bool
 101
 102   rpcCallData _ = J.encode
 103
 104 -- | A generic class for RPC results with default implementation.
 105 class (J.JSON a) => RpcResult a where
 106   -- | Create a result based on the received HTTP response.
 107   rpcResultFill :: (Monad m) => String -> m (Either RpcError a)
 108
 109   rpcResultFill res = rpcErrorJsonReport $  J.decode res
 110
 111 -- | Generic class that ensures matching RPC call with its respective
 112 -- result.
 113 class (RpcCall a, RpcResult b) => Rpc a b | a -> b
 114
 115 -- | Http Request definition.
 116 data HttpClientRequest = HttpClientRequest
 117   { requestTimeout :: Int
 118   , requestUrl :: String
 119   , requestPostData :: String
 120   }
 121
 122 -- | Execute the request and return the result as a plain String. When
 123 -- curl reports an error, we propagate it.
 124 executeHttpRequest :: Node -> Either RpcError HttpClientRequest
 125                    -> IO (Either RpcError String)
 126
 127 executeHttpRequest _ (Left rpc_err) = return $ Left rpc_err
 128 #ifdef NO_CURL
 129 executeHttpRequest _ _ = return $ Left CurlDisabledError
 130 #else
 131 executeHttpRequest node (Right request) = do
 132   let reqOpts = [ CurlTimeout (fromIntegral $ requestTimeout request)
 133                 , CurlPostFields [requestPostData request]
 134                 ]
 135       url = requestUrl request
 136   -- FIXME: This is very similar to getUrl in Htools/Rapi.hs
 137   (code, !body) <- curlGetString url $ curlOpts ++ reqOpts
 138   case code of
 139     CurlOK -> return $ Right body
 140     _ -> return $ Left $ CurlLayerError node (show code)
 141 #endif
 142
 143 -- | Prepare url for the HTTP request.
 144 prepareUrl :: (RpcCall a) => Node -> a -> String
 145 prepareUrl node call =
 146   let node_ip = nodePrimaryIp node
 147       port = snd C.daemonsPortsGanetiNoded
 148       path_prefix = "https://" ++ (node_ip) ++ ":" ++ (show port) in
 149   path_prefix ++ "/" ++ rpcCallName call
 150
 151 -- | Create HTTP request for a given node provided it is online,
 152 -- otherwise create empty response.
 153 prepareHttpRequest ::  (RpcCall a) => Node -> a
 154                    -> Either RpcError HttpClientRequest
 155 prepareHttpRequest node call
 156   | rpcCallAcceptOffline call ||
 157     (not $ nodeOffline node) =
 158       Right $ HttpClientRequest { requestTimeout = rpcCallTimeout call
 159                                 , requestUrl = prepareUrl node call
 160                                 , requestPostData = rpcCallData node call
 161                                 }
 162   | otherwise = Left $ OfflineNodeError node
 163
 164 -- | Parse the response or propagate the error.
 165 parseHttpResponse :: (Monad m, RpcResult a) => Either RpcError String
 166                   -> m (Either RpcError a)
 167 parseHttpResponse (Left err) = return $ Left err
 168 parseHttpResponse (Right response) = rpcResultFill response
 169
 170 -- | Execute RPC call for a sigle node.
 171 executeSingleRpcCall :: (Rpc a b) => Node -> a -> IO (Node, Either RpcError b)
 172 executeSingleRpcCall node call = do
 173   let request = prepareHttpRequest node call
 174   response <- executeHttpRequest node request
 175   result <- parseHttpResponse response
 176   return (node, result)
 177
 178 -- | Execute RPC call for many nodes in parallel.
 179 executeRpcCall :: (Rpc a b) => [Node] -> a -> IO [(Node, Either RpcError b)]
 180 executeRpcCall nodes call =
 181   sequence $ parMap rwhnf (uncurry executeSingleRpcCall)
 182                (zip nodes $ repeat call)