1 {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
2 BangPatterns, TemplateHaskell #-}
4 {-| Implementation of the RPC client.
10 Copyright (C) 2012, 2013 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
41 , rpcCallAcceptOffline
46 , RpcCallInstanceInfo(..)
47 , RpcResultInstanceInfo(..)
49 , RpcCallAllInstancesInfo(..)
50 , RpcResultAllInstancesInfo(..)
52 , RpcCallInstanceList(..)
53 , RpcResultInstanceList(..)
58 , RpcResultNodeInfo(..)
61 , RpcResultVersion(..)
64 , RpcCallStorageList(..)
65 , RpcResultStorageList(..)
67 , RpcCallTestDelay(..)
68 , RpcResultTestDelay(..)
70 , RpcCallExportList(..)
71 , RpcResultExportList(..)
73 , rpcTimeoutFromRaw -- FIXME: Not used anywhere
76 import Control.Arrow (second)
77 import qualified Data.Map as Map
78 import Data.Maybe (fromMaybe)
79 import qualified Text.JSON as J
80 import Text.JSON.Pretty (pp_value)
83 import qualified Ganeti.Path as P
85 import Ganeti.BasicTypes
86 import qualified Ganeti.Constants as C
91 import Ganeti.Curl.Multi
94 -- * Base RPC functionality and types
96 -- | The curl options used for RPC.
97 curlOpts :: [CurlOption]
98 curlOpts = [ CurlFollowLocation False
100 , CurlSSLVerifyPeer True
101 , CurlSSLCertType "PEM"
102 , CurlSSLKeyType "PEM"
103 , CurlConnectTimeout (fromIntegral C.rpcConnectTimeout)
106 -- | Data type for RPC error reporting.
108 = CurlLayerError String
109 | JsonDecodeError String
110 | RpcResultError String
114 -- | Provide explanation to RPC errors.
115 explainRpcError :: RpcError -> String
116 explainRpcError (CurlLayerError code) =
117 "Curl error:" ++ code
118 explainRpcError (JsonDecodeError msg) =
119 "Error while decoding JSON from HTTP response: " ++ msg
120 explainRpcError (RpcResultError msg) =
121 "Error reponse received from RPC server: " ++ msg
122 explainRpcError OfflineNodeError =
123 "Node is marked offline"
125 type ERpcError = Either RpcError
127 -- | Basic timeouts for RPC calls.
128 $(declareIADT "RpcTimeout"
129 [ ( "Urgent", 'C.rpcTmoUrgent )
130 , ( "Fast", 'C.rpcTmoFast )
131 , ( "Normal", 'C.rpcTmoNormal )
132 , ( "Slow", 'C.rpcTmoSlow )
133 , ( "FourHours", 'C.rpcTmo4hrs )
134 , ( "OneDay", 'C.rpcTmo1day )
137 -- | A generic class for RPC calls.
138 class (J.JSON a) => RpcCall a where
139 -- | Give the (Python) name of the procedure.
140 rpcCallName :: a -> String
141 -- | Calculate the timeout value for the call execution.
142 rpcCallTimeout :: a -> Int
143 -- | Prepare arguments of the call to be send as POST.
144 rpcCallData :: Node -> a -> String
145 -- | Whether we accept offline nodes when making a call.
146 rpcCallAcceptOffline :: a -> Bool
148 -- | Generic class that ensures matching RPC call with its respective
150 class (RpcCall a, J.JSON b) => Rpc a b | a -> b, b -> a where
151 -- | Create a result based on the received HTTP response.
152 rpcResultFill :: a -> J.JSValue -> ERpcError b
154 -- | Http Request definition.
155 data HttpClientRequest = HttpClientRequest
156 { requestUrl :: String -- ^ The actual URL for the node endpoint
157 , requestData :: String -- ^ The arguments for the call
158 , requestOpts :: [CurlOption] -- ^ The various curl options
161 -- | Prepare url for the HTTP request.
162 prepareUrl :: (RpcCall a) => Node -> a -> String
163 prepareUrl node call =
164 let node_ip = nodePrimaryIp node
165 port = C.defaultNodedPort
166 path_prefix = "https://" ++ node_ip ++ ":" ++ show port
167 in path_prefix ++ "/" ++ rpcCallName call
169 -- | Create HTTP request for a given node provided it is online,
170 -- otherwise create empty response.
171 prepareHttpRequest :: (RpcCall a) => [CurlOption] -> Node -> a
172 -> ERpcError HttpClientRequest
173 prepareHttpRequest opts node call
174 | rpcCallAcceptOffline call || not (nodeOffline node) =
175 Right HttpClientRequest { requestUrl = prepareUrl node call
176 , requestData = rpcCallData node call
177 , requestOpts = opts ++ curlOpts
179 | otherwise = Left OfflineNodeError
181 -- | Parse an HTTP reply.
182 parseHttpReply :: (Rpc a b) =>
183 a -> ERpcError (CurlCode, String) -> ERpcError b
184 parseHttpReply _ (Left e) = Left e
185 parseHttpReply call (Right (CurlOK, body)) = parseHttpResponse call body
186 parseHttpReply _ (Right (code, err)) =
187 Left . CurlLayerError $ "code: " ++ show code ++ ", explanation: " ++ err
189 -- | Parse a result based on the received HTTP response.
190 parseHttpResponse :: (Rpc a b) => a -> String -> ERpcError b
191 parseHttpResponse call res =
193 J.Error val -> Left $ JsonDecodeError val
194 J.Ok (True, res'') -> rpcResultFill call res''
195 J.Ok (False, jerr) -> case jerr of
196 J.JSString msg -> Left $ RpcResultError (J.fromJSString msg)
197 _ -> Left . JsonDecodeError $ show (pp_value jerr)
199 -- | Scan the list of results produced by executeRpcCall and log all the RPC
201 logRpcErrors :: [(a, ERpcError b)] -> IO ()
202 logRpcErrors allElems =
203 let logOneRpcErr (_, Right _) = return ()
204 logOneRpcErr (_, Left err) =
205 logError $ "Error in the RPC HTTP reply: " ++ show err
206 in mapM_ logOneRpcErr allElems
208 -- | Execute RPC call for many nodes in parallel.
209 executeRpcCall :: (Rpc a b) => [Node] -> a -> IO [(Node, ERpcError b)]
210 executeRpcCall nodes call = do
211 cert_file <- P.nodedCertFile
212 let opts = [ CurlTimeout (fromIntegral $ rpcCallTimeout call)
213 , CurlSSLCert cert_file
214 , CurlSSLKey cert_file
215 , CurlCAInfo cert_file
217 opts_urls = map (\n ->
218 case prepareHttpRequest opts n call of
221 Right (CurlPostFields [requestData request]:
225 -- split the opts_urls list; we don't want to pass the
226 -- failed-already nodes to Curl
227 let (lefts, rights, trail) = splitEithers opts_urls
228 results <- execMultiCall rights
229 results' <- case recombineEithers lefts results trail of
232 -- now parse the replies
233 let results'' = map (parseHttpReply call) results'
234 pairedList = zip nodes results''
235 logRpcErrors pairedList
238 -- | Helper function that is used to read dictionaries of values.
239 sanitizeDictResults :: [(String, J.Result a)] -> ERpcError [(String, a)]
240 sanitizeDictResults =
241 foldr sanitize1 (Right [])
243 sanitize1 _ (Left e) = Left e
244 sanitize1 (_, J.Error e) _ = Left $ JsonDecodeError e
245 sanitize1 (name, J.Ok v) (Right res) = Right $ (name, v) : res
247 -- | Helper function to tranform JSON Result to Either RpcError b.
248 -- Note: For now we really only use it for b s.t. Rpc c b for some c
249 fromJResultToRes :: J.Result a -> (a -> b) -> ERpcError b
250 fromJResultToRes (J.Error v) _ = Left $ JsonDecodeError v
251 fromJResultToRes (J.Ok v) f = Right $ f v
253 -- | Helper function transforming JSValue to Rpc result type.
254 fromJSValueToRes :: (J.JSON a) => J.JSValue -> (a -> b) -> ERpcError b
255 fromJSValueToRes val = fromJResultToRes (J.readJSON val)
257 -- * RPC calls and results
262 -- Returns information about a single instance.
264 $(buildObject "RpcCallInstanceInfo" "rpcCallInstInfo"
265 [ simpleField "instance" [t| String |]
266 , simpleField "hname" [t| Hypervisor |]
269 $(buildObject "InstanceInfo" "instInfo"
270 [ simpleField "memory" [t| Int|]
271 , simpleField "state" [t| String |] -- It depends on hypervisor :(
272 , simpleField "vcpus" [t| Int |]
273 , simpleField "time" [t| Int |]
276 -- This is optional here because the result may be empty if instance is
277 -- not on a node - and this is not considered an error.
278 $(buildObject "RpcResultInstanceInfo" "rpcResInstInfo"
279 [ optionalField $ simpleField "inst_info" [t| InstanceInfo |]])
281 instance RpcCall RpcCallInstanceInfo where
282 rpcCallName _ = "instance_info"
283 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
284 rpcCallAcceptOffline _ = False
285 rpcCallData _ call = J.encode
286 ( rpcCallInstInfoInstance call
287 , rpcCallInstInfoHname call
290 instance Rpc RpcCallInstanceInfo RpcResultInstanceInfo where
291 rpcResultFill _ res =
294 case J.fromJSObject res' of
295 [] -> Right $ RpcResultInstanceInfo Nothing
296 _ -> fromJSValueToRes res (RpcResultInstanceInfo . Just)
297 _ -> Left $ JsonDecodeError
298 ("Expected JSObject, got " ++ show (pp_value res))
300 -- ** AllInstancesInfo
302 -- | AllInstancesInfo
303 -- Returns information about all running instances on the given nodes
304 $(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo"
305 [ simpleField "hypervisors" [t| [Hypervisor] |] ])
307 $(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo"
308 [ simpleField "instances" [t| [(String, InstanceInfo)] |] ])
310 instance RpcCall RpcCallAllInstancesInfo where
311 rpcCallName _ = "all_instances_info"
312 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
313 rpcCallAcceptOffline _ = False
314 rpcCallData _ call = J.encode [rpcCallAllInstInfoHypervisors call]
316 instance Rpc RpcCallAllInstancesInfo RpcResultAllInstancesInfo where
317 -- FIXME: Is there a simpler way to do it?
318 rpcResultFill _ res =
321 let res'' = map (second J.readJSON) (J.fromJSObject res')
322 :: [(String, J.Result InstanceInfo)] in
323 case sanitizeDictResults res'' of
325 Right insts -> Right $ RpcResultAllInstancesInfo insts
326 _ -> Left $ JsonDecodeError
327 ("Expected JSObject, got " ++ show (pp_value res))
332 -- Returns the list of running instances on the given nodes.
333 $(buildObject "RpcCallInstanceList" "rpcCallInstList"
334 [ simpleField "hypervisors" [t| [Hypervisor] |] ])
336 $(buildObject "RpcResultInstanceList" "rpcResInstList"
337 [ simpleField "instances" [t| [String] |] ])
339 instance RpcCall RpcCallInstanceList where
340 rpcCallName _ = "instance_list"
341 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
342 rpcCallAcceptOffline _ = False
343 rpcCallData _ call = J.encode [rpcCallInstListHypervisors call]
345 instance Rpc RpcCallInstanceList RpcResultInstanceList where
346 rpcResultFill _ res = fromJSValueToRes res RpcResultInstanceList
351 -- Return node information.
352 $(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo"
353 [ simpleField "storage_units" [t| Map.Map String [StorageUnit] |]
354 , simpleField "hypervisors" [t| [ (Hypervisor, HvParams) ] |]
357 $(buildObject "StorageInfo" "storageInfo"
358 [ simpleField "name" [t| String |]
359 , simpleField "type" [t| String |]
360 , optionalField $ simpleField "storage_free" [t| Int |]
361 , optionalField $ simpleField "storage_size" [t| Int |]
364 -- | We only provide common fields as described in hv_base.py.
365 $(buildObject "HvInfo" "hvInfo"
366 [ simpleField "memory_total" [t| Int |]
367 , simpleField "memory_free" [t| Int |]
368 , simpleField "memory_dom0" [t| Int |]
369 , simpleField "cpu_total" [t| Int |]
370 , simpleField "cpu_nodes" [t| Int |]
371 , simpleField "cpu_sockets" [t| Int |]
372 , simpleField "cpu_dom0" [t| Int |]
375 $(buildObject "RpcResultNodeInfo" "rpcResNodeInfo"
376 [ simpleField "boot_id" [t| String |]
377 , simpleField "storage_info" [t| [StorageInfo] |]
378 , simpleField "hv_info" [t| [HvInfo] |]
381 instance RpcCall RpcCallNodeInfo where
382 rpcCallName _ = "node_info"
383 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
384 rpcCallAcceptOffline _ = False
385 rpcCallData n call = J.encode
386 ( fromMaybe (error $ "Programmer error: missing parameter for node named "
388 $ Map.lookup (nodeUuid n) (rpcCallNodeInfoStorageUnits call)
389 , rpcCallNodeInfoHypervisors call
392 instance Rpc RpcCallNodeInfo RpcResultNodeInfo where
393 rpcResultFill _ res =
394 fromJSValueToRes res (\(b, vg, hv) -> RpcResultNodeInfo b vg hv)
398 -- | Query node version.
399 $(buildObject "RpcCallVersion" "rpcCallVersion" [])
401 -- | Query node reply.
402 $(buildObject "RpcResultVersion" "rpcResultVersion"
403 [ simpleField "version" [t| Int |]
406 instance RpcCall RpcCallVersion where
407 rpcCallName _ = "version"
408 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
409 rpcCallAcceptOffline _ = True
410 rpcCallData _ = J.encode
412 instance Rpc RpcCallVersion RpcResultVersion where
413 rpcResultFill _ res = fromJSValueToRes res RpcResultVersion
419 -- FIXME: This may be moved to Objects
420 $(declareSADT "StorageField"
421 [ ( "SFUsed", 'C.sfUsed)
422 , ( "SFName", 'C.sfName)
423 , ( "SFAllocatable", 'C.sfAllocatable)
424 , ( "SFFree", 'C.sfFree)
425 , ( "SFSize", 'C.sfSize)
427 $(makeJSONInstance ''StorageField)
429 $(buildObject "RpcCallStorageList" "rpcCallStorageList"
430 [ simpleField "su_name" [t| StorageType |]
431 , simpleField "su_args" [t| [String] |]
432 , simpleField "name" [t| String |]
433 , simpleField "fields" [t| [StorageField] |]
436 -- FIXME: The resulting JSValues should have types appropriate for their
437 -- StorageField value: Used -> Bool, Name -> String etc
438 $(buildObject "RpcResultStorageList" "rpcResStorageList"
439 [ simpleField "storage" [t| [[(StorageField, J.JSValue)]] |] ])
441 instance RpcCall RpcCallStorageList where
442 rpcCallName _ = "storage_list"
443 rpcCallTimeout _ = rpcTimeoutToRaw Normal
444 rpcCallAcceptOffline _ = False
445 rpcCallData _ call = J.encode
446 ( rpcCallStorageListSuName call
447 , rpcCallStorageListSuArgs call
448 , rpcCallStorageListName call
449 , rpcCallStorageListFields call
452 instance Rpc RpcCallStorageList RpcResultStorageList where
453 rpcResultFill call res =
454 let sfields = rpcCallStorageListFields call in
455 fromJSValueToRes res (RpcResultStorageList . map (zip sfields))
459 -- | Call definition for test delay.
460 $(buildObject "RpcCallTestDelay" "rpcCallTestDelay"
461 [ simpleField "duration" [t| Double |]
464 -- | Result definition for test delay.
465 data RpcResultTestDelay = RpcResultTestDelay
468 -- | Custom JSON instance for null result.
469 instance J.JSON RpcResultTestDelay where
470 showJSON _ = J.JSNull
471 readJSON J.JSNull = return RpcResultTestDelay
472 readJSON _ = fail "Unable to read RpcResultTestDelay"
474 instance RpcCall RpcCallTestDelay where
475 rpcCallName _ = "test_delay"
476 rpcCallTimeout = ceiling . (+ 5) . rpcCallTestDelayDuration
477 rpcCallAcceptOffline _ = False
478 rpcCallData _ call = J.encode [rpcCallTestDelayDuration call]
480 instance Rpc RpcCallTestDelay RpcResultTestDelay where
481 rpcResultFill _ res = fromJSValueToRes res id
485 -- | Call definition for export list.
487 $(buildObject "RpcCallExportList" "rpcCallExportList" [])
489 -- | Result definition for export list.
490 $(buildObject "RpcResultExportList" "rpcResExportList"
491 [ simpleField "exports" [t| [String] |]
494 instance RpcCall RpcCallExportList where
495 rpcCallName _ = "export_list"
496 rpcCallTimeout _ = rpcTimeoutToRaw Fast
497 rpcCallAcceptOffline _ = False
498 rpcCallData _ = J.encode
500 instance Rpc RpcCallExportList RpcResultExportList where
501 rpcResultFill _ res = fromJSValueToRes res RpcResultExportList