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