root / htools / Ganeti / Rpc.hs @ eaed5f19
History | View | Annotate | Download (5.9 kB)
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) |