Revision eaed5f19

b/htools/Ganeti/Rpc.hs
1
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
1
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, CPP,
2
  BangPatterns #-}
2 3

  
3 4
{-| Implementation of the RPC client.
4 5

  
......
30 31
  , RpcResult
31 32
  , Rpc
32 33
  , RpcError(..)
34
  , executeRpcCall
33 35

  
34 36
  , rpcCallName
35 37
  , rpcCallTimeout
......
41 43

  
42 44
import qualified Text.JSON as J
43 45

  
46
#ifndef NO_CURL
47
import Network.Curl
48
#endif
49

  
50
import qualified Ganeti.Constants as C
44 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
45 68

  
46 69
-- | Data type for RPC error reporting.
47 70
data RpcError
......
88 111
-- | Generic class that ensures matching RPC call with its respective
89 112
-- result.
90 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)

Also available in: Unified diff