1 {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, CPP,
2 BangPatterns, TemplateHaskell #-}
4 {-| Implementation of the RPC client.
10 Copyright (C) 2012 Google Inc.
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.
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.
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
40 , rpcCallAcceptOffline
45 , RpcCallInstanceInfo(..)
46 , RpcResultInstanceInfo(..)
48 , RpcCallAllInstancesInfo(..)
49 , RpcResultAllInstancesInfo(..)
51 , RpcCallInstanceList(..)
52 , RpcResultInstanceList(..)
57 , RpcResultNodeInfo(..)
60 , RpcResultVersion(..)
63 , RpcCallStorageList(..)
64 , RpcResultStorageList(..)
66 , RpcCallTestDelay(..)
67 , RpcResultTestDelay(..)
69 , rpcTimeoutFromRaw -- FIXME: Not used anywhere
72 import Control.Arrow (second)
73 import qualified Text.JSON as J
74 import Text.JSON.Pretty (pp_value)
78 import qualified Ganeti.Path as P
81 import qualified Ganeti.Constants as C
87 -- * Base RPC functionality and types
90 -- | The curl options used for RPC.
91 curlOpts :: [CurlOption]
92 curlOpts = [ CurlFollowLocation False
94 , CurlSSLVerifyPeer True
95 , CurlSSLCertType "PEM"
96 , CurlSSLKeyType "PEM"
97 , CurlConnectTimeout (fromIntegral C.rpcConnectTimeout)
101 -- | Data type for RPC error reporting.
104 | CurlLayerError Node String
105 | JsonDecodeError String
106 | RpcResultError String
107 | OfflineNodeError Node
110 -- | Provide explanation to RPC errors.
111 explainRpcError :: RpcError -> String
112 explainRpcError CurlDisabledError =
113 "RPC/curl backend disabled at compile time"
114 explainRpcError (CurlLayerError node code) =
115 "Curl error for " ++ nodeName node ++ ", " ++ code
116 explainRpcError (JsonDecodeError msg) =
117 "Error while decoding JSON from HTTP response: " ++ msg
118 explainRpcError (RpcResultError msg) =
119 "Error reponse received from RPC server: " ++ msg
120 explainRpcError (OfflineNodeError node) =
121 "Node " ++ nodeName node ++ " is marked as offline"
123 type ERpcError = Either RpcError
125 -- | Basic timeouts for RPC calls.
126 $(declareIADT "RpcTimeout"
127 [ ( "Urgent", 'C.rpcTmoUrgent )
128 , ( "Fast", 'C.rpcTmoFast )
129 , ( "Normal", 'C.rpcTmoNormal )
130 , ( "Slow", 'C.rpcTmoSlow )
131 , ( "FourHours", 'C.rpcTmo4hrs )
132 , ( "OneDay", 'C.rpcTmo1day )
135 -- | A generic class for RPC calls.
136 class (J.JSON a) => RpcCall a where
137 -- | Give the (Python) name of the procedure.
138 rpcCallName :: a -> String
139 -- | Calculate the timeout value for the call execution.
140 rpcCallTimeout :: a -> Int
141 -- | Prepare arguments of the call to be send as POST.
142 rpcCallData :: Node -> a -> String
143 -- | Whether we accept offline nodes when making a call.
144 rpcCallAcceptOffline :: a -> Bool
146 -- | Generic class that ensures matching RPC call with its respective
148 class (RpcCall a, J.JSON b) => Rpc a b | a -> b, b -> a where
149 -- | Create a result based on the received HTTP response.
150 rpcResultFill :: a -> J.JSValue -> ERpcError b
152 -- | Http Request definition.
153 data HttpClientRequest = HttpClientRequest
154 { requestTimeout :: Int
155 , requestUrl :: String
156 , requestPostData :: String
159 -- | Execute the request and return the result as a plain String. When
160 -- curl reports an error, we propagate it.
161 executeHttpRequest :: Node -> ERpcError HttpClientRequest
162 -> IO (ERpcError String)
164 executeHttpRequest _ (Left rpc_err) = return $ Left rpc_err
166 executeHttpRequest _ _ = return $ Left CurlDisabledError
168 executeHttpRequest node (Right request) = do
169 cert_file <- P.nodedCertFile
170 let reqOpts = [ CurlTimeout (fromIntegral $ requestTimeout request)
171 , CurlPostFields [requestPostData request]
172 , CurlSSLCert cert_file
173 , CurlSSLKey cert_file
174 , CurlCAInfo cert_file
176 url = requestUrl request
177 -- FIXME: This is very similar to getUrl in Htools/Rapi.hs
178 (code, !body) <- curlGetString url $ curlOpts ++ reqOpts
179 return $ case code of
181 _ -> Left $ CurlLayerError node (show code)
184 -- | Prepare url for the HTTP request.
185 prepareUrl :: (RpcCall a) => Node -> a -> String
186 prepareUrl node call =
187 let node_ip = nodePrimaryIp node
188 port = snd C.daemonsPortsGanetiNoded
189 path_prefix = "https://" ++ node_ip ++ ":" ++ show port
190 in path_prefix ++ "/" ++ rpcCallName call
192 -- | Create HTTP request for a given node provided it is online,
193 -- otherwise create empty response.
194 prepareHttpRequest :: (RpcCall a) => Node -> a
195 -> ERpcError HttpClientRequest
196 prepareHttpRequest node call
197 | rpcCallAcceptOffline call || not (nodeOffline node) =
198 Right HttpClientRequest { requestTimeout = rpcCallTimeout call
199 , requestUrl = prepareUrl node call
200 , requestPostData = rpcCallData node call
202 | otherwise = Left $ OfflineNodeError node
204 -- | Parse a result based on the received HTTP response.
205 parseHttpResponse :: (Rpc a b) => a -> ERpcError String -> ERpcError b
206 parseHttpResponse _ (Left err) = Left err
207 parseHttpResponse call (Right res) =
209 J.Error val -> Left $ JsonDecodeError val
210 J.Ok (True, res'') -> rpcResultFill call res''
211 J.Ok (False, jerr) -> case jerr of
212 J.JSString msg -> Left $ RpcResultError (J.fromJSString msg)
213 _ -> Left . JsonDecodeError $ show (pp_value jerr)
215 -- | Execute RPC call for a sigle node.
216 executeSingleRpcCall :: (Rpc a b) => Node -> a -> IO (Node, ERpcError b)
217 executeSingleRpcCall node call = do
218 let request = prepareHttpRequest node call
219 response <- executeHttpRequest node request
220 let result = parseHttpResponse call response
221 return (node, result)
223 -- | Execute RPC call for many nodes in parallel.
224 executeRpcCall :: (Rpc a b) => [Node] -> a -> IO [(Node, ERpcError b)]
225 executeRpcCall nodes call =
226 sequence $ parMap rwhnf (uncurry executeSingleRpcCall)
227 (zip nodes $ repeat call)
229 -- | Helper function that is used to read dictionaries of values.
230 sanitizeDictResults :: [(String, J.Result a)] -> ERpcError [(String, a)]
231 sanitizeDictResults =
232 foldr sanitize1 (Right [])
234 sanitize1 _ (Left e) = Left e
235 sanitize1 (_, J.Error e) _ = Left $ JsonDecodeError e
236 sanitize1 (name, J.Ok v) (Right res) = Right $ (name, v) : res
238 -- | Helper function to tranform JSON Result to Either RpcError b.
239 -- Note: For now we really only use it for b s.t. Rpc c b for some c
240 fromJResultToRes :: J.Result a -> (a -> b) -> ERpcError b
241 fromJResultToRes (J.Error v) _ = Left $ JsonDecodeError v
242 fromJResultToRes (J.Ok v) f = Right $ f v
244 -- | Helper function transforming JSValue to Rpc result type.
245 fromJSValueToRes :: (J.JSON a) => J.JSValue -> (a -> b) -> ERpcError b
246 fromJSValueToRes val = fromJResultToRes (J.readJSON val)
248 -- * RPC calls and results
253 -- Returns information about a single instance.
255 $(buildObject "RpcCallInstanceInfo" "rpcCallInstInfo"
256 [ simpleField "instance" [t| String |]
257 , simpleField "hname" [t| Hypervisor |]
260 $(buildObject "InstanceInfo" "instInfo"
261 [ simpleField "memory" [t| Int|]
262 , simpleField "state" [t| String |] -- It depends on hypervisor :(
263 , simpleField "vcpus" [t| Int |]
264 , simpleField "time" [t| Int |]
267 -- This is optional here because the result may be empty if instance is
268 -- not on a node - and this is not considered an error.
269 $(buildObject "RpcResultInstanceInfo" "rpcResInstInfo"
270 [ optionalField $ simpleField "inst_info" [t| InstanceInfo |]])
272 instance RpcCall RpcCallInstanceInfo where
273 rpcCallName _ = "instance_info"
274 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
275 rpcCallAcceptOffline _ = False
276 rpcCallData _ call = J.encode
277 ( rpcCallInstInfoInstance call
278 , rpcCallInstInfoHname call
281 instance Rpc RpcCallInstanceInfo RpcResultInstanceInfo where
282 rpcResultFill _ res =
285 case J.fromJSObject res' of
286 [] -> Right $ RpcResultInstanceInfo Nothing
287 _ -> fromJSValueToRes res (RpcResultInstanceInfo . Just)
288 _ -> Left $ JsonDecodeError
289 ("Expected JSObject, got " ++ show (pp_value res))
291 -- ** AllInstancesInfo
293 -- | AllInstancesInfo
294 -- Returns information about all running instances on the given nodes
295 $(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo"
296 [ simpleField "hypervisors" [t| [Hypervisor] |] ])
298 $(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo"
299 [ simpleField "instances" [t| [(String, InstanceInfo)] |] ])
301 instance RpcCall RpcCallAllInstancesInfo where
302 rpcCallName _ = "all_instances_info"
303 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
304 rpcCallAcceptOffline _ = False
305 rpcCallData _ call = J.encode [rpcCallAllInstInfoHypervisors call]
307 instance Rpc RpcCallAllInstancesInfo RpcResultAllInstancesInfo where
308 -- FIXME: Is there a simpler way to do it?
309 rpcResultFill _ res =
312 let res'' = map (second J.readJSON) (J.fromJSObject res')
313 :: [(String, J.Result InstanceInfo)] in
314 case sanitizeDictResults res'' of
316 Right insts -> Right $ RpcResultAllInstancesInfo insts
317 _ -> Left $ JsonDecodeError
318 ("Expected JSObject, got " ++ show (pp_value res))
323 -- Returns the list of running instances on the given nodes.
324 $(buildObject "RpcCallInstanceList" "rpcCallInstList"
325 [ simpleField "hypervisors" [t| [Hypervisor] |] ])
327 $(buildObject "RpcResultInstanceList" "rpcResInstList"
328 [ simpleField "instances" [t| [String] |] ])
330 instance RpcCall RpcCallInstanceList where
331 rpcCallName _ = "instance_list"
332 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
333 rpcCallAcceptOffline _ = False
334 rpcCallData _ call = J.encode [rpcCallInstListHypervisors call]
336 instance Rpc RpcCallInstanceList RpcResultInstanceList where
337 rpcResultFill _ res = fromJSValueToRes res RpcResultInstanceList
342 -- Return node information.
343 $(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo"
344 [ simpleField "volume_groups" [t| [String] |]
345 , simpleField "hypervisors" [t| [Hypervisor] |]
348 $(buildObject "VgInfo" "vgInfo"
349 [ simpleField "name" [t| String |]
350 , optionalField $ simpleField "vg_free" [t| Int |]
351 , optionalField $ simpleField "vg_size" [t| Int |]
354 -- | We only provide common fields as described in hv_base.py.
355 $(buildObject "HvInfo" "hvInfo"
356 [ simpleField "memory_total" [t| Int |]
357 , simpleField "memory_free" [t| Int |]
358 , simpleField "memory_dom0" [t| Int |]
359 , simpleField "cpu_total" [t| Int |]
360 , simpleField "cpu_nodes" [t| Int |]
361 , simpleField "cpu_sockets" [t| Int |]
364 $(buildObject "RpcResultNodeInfo" "rpcResNodeInfo"
365 [ simpleField "boot_id" [t| String |]
366 , simpleField "vg_info" [t| [VgInfo] |]
367 , simpleField "hv_info" [t| [HvInfo] |]
370 instance RpcCall RpcCallNodeInfo where
371 rpcCallName _ = "node_info"
372 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
373 rpcCallAcceptOffline _ = False
374 rpcCallData _ call = J.encode
375 ( rpcCallNodeInfoVolumeGroups call
376 , rpcCallNodeInfoHypervisors call
379 instance Rpc RpcCallNodeInfo RpcResultNodeInfo where
380 rpcResultFill _ res =
381 fromJSValueToRes res (\(b, vg, hv) -> RpcResultNodeInfo b vg hv)
386 -- Query node version.
387 -- Note: We can't use THH as it does not know what to do with empty dict
388 data RpcCallVersion = RpcCallVersion {}
391 instance J.JSON RpcCallVersion where
392 showJSON _ = J.JSNull
393 readJSON J.JSNull = return RpcCallVersion
394 readJSON _ = fail "Unable to read RpcCallVersion"
396 $(buildObject "RpcResultVersion" "rpcResultVersion"
397 [ simpleField "version" [t| Int |]
400 instance RpcCall RpcCallVersion where
401 rpcCallName _ = "version"
402 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
403 rpcCallAcceptOffline _ = True
404 rpcCallData _ = J.encode
406 instance Rpc RpcCallVersion RpcResultVersion where
407 rpcResultFill _ res = fromJSValueToRes res RpcResultVersion
413 -- FIXME: This may be moved to Objects
414 $(declareSADT "StorageField"
415 [ ( "SFUsed", 'C.sfUsed)
416 , ( "SFName", 'C.sfName)
417 , ( "SFAllocatable", 'C.sfAllocatable)
418 , ( "SFFree", 'C.sfFree)
419 , ( "SFSize", 'C.sfSize)
421 $(makeJSONInstance ''StorageField)
423 $(buildObject "RpcCallStorageList" "rpcCallStorageList"
424 [ simpleField "su_name" [t| StorageType |]
425 , simpleField "su_args" [t| [String] |]
426 , simpleField "name" [t| String |]
427 , simpleField "fields" [t| [StorageField] |]
430 -- FIXME: The resulting JSValues should have types appropriate for their
431 -- StorageField value: Used -> Bool, Name -> String etc
432 $(buildObject "RpcResultStorageList" "rpcResStorageList"
433 [ simpleField "storage" [t| [[(StorageField, J.JSValue)]] |] ])
435 instance RpcCall RpcCallStorageList where
436 rpcCallName _ = "storage_list"
437 rpcCallTimeout _ = rpcTimeoutToRaw Normal
438 rpcCallAcceptOffline _ = False
439 rpcCallData _ call = J.encode
440 ( rpcCallStorageListSuName call
441 , rpcCallStorageListSuArgs call
442 , rpcCallStorageListName call
443 , rpcCallStorageListFields call
446 instance Rpc RpcCallStorageList RpcResultStorageList where
447 rpcResultFill call res =
448 let sfields = rpcCallStorageListFields call in
449 fromJSValueToRes res (RpcResultStorageList . map (zip sfields))
454 -- | Call definition for test delay.
455 $(buildObject "RpcCallTestDelay" "rpcCallTestDelay"
456 [ simpleField "duration" [t| Double |]
459 -- | Result definition for test delay.
460 data RpcResultTestDelay = RpcResultTestDelay
463 -- | Custom JSON instance for null result.
464 instance J.JSON RpcResultTestDelay where
465 showJSON _ = J.JSNull
466 readJSON J.JSNull = return RpcResultTestDelay
467 readJSON _ = fail "Unable to read RpcResultTestDelay"
469 instance RpcCall RpcCallTestDelay where
470 rpcCallName _ = "test_delay"
471 rpcCallTimeout = ceiling . (+ 5) . rpcCallTestDelayDuration
472 rpcCallAcceptOffline _ = False
473 rpcCallData _ call = J.encode [rpcCallTestDelayDuration call]
475 instance Rpc RpcCallTestDelay RpcResultTestDelay where
476 rpcResultFill _ res = fromJSValueToRes res id