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 -- | Check if a string represented address is IPv6
162 isIpV6 :: String -> Bool
163 isIpV6 = (':' `elem`)
165 -- | Prepare url for the HTTP request.
166 prepareUrl :: (RpcCall a) => Node -> a -> String
167 prepareUrl node call =
168 let node_ip = nodePrimaryIp node
169 node_address = if isIpV6 node_ip
170 then "[" ++ node_ip ++ "]"
172 port = snd C.daemonsPortsGanetiNoded
173 path_prefix = "https://" ++ node_address ++ ":" ++ show port
174 in path_prefix ++ "/" ++ rpcCallName call
176 -- | Create HTTP request for a given node provided it is online,
177 -- otherwise create empty response.
178 prepareHttpRequest :: (RpcCall a) => [CurlOption] -> Node -> a
179 -> ERpcError HttpClientRequest
180 prepareHttpRequest opts node call
181 | rpcCallAcceptOffline call || not (nodeOffline node) =
182 Right HttpClientRequest { requestUrl = prepareUrl node call
183 , requestData = rpcCallData node call
184 , requestOpts = opts ++ curlOpts
186 | otherwise = Left OfflineNodeError
188 -- | Parse an HTTP reply.
189 parseHttpReply :: (Rpc a b) =>
190 a -> ERpcError (CurlCode, String) -> ERpcError b
191 parseHttpReply _ (Left e) = Left e
192 parseHttpReply call (Right (CurlOK, body)) = parseHttpResponse call body
193 parseHttpReply _ (Right (code, err)) =
194 Left . CurlLayerError $ "code: " ++ show code ++ ", explanation: " ++ err
196 -- | Parse a result based on the received HTTP response.
197 parseHttpResponse :: (Rpc a b) => a -> String -> ERpcError b
198 parseHttpResponse call res =
200 J.Error val -> Left $ JsonDecodeError val
201 J.Ok (True, res'') -> rpcResultFill call res''
202 J.Ok (False, jerr) -> case jerr of
203 J.JSString msg -> Left $ RpcResultError (J.fromJSString msg)
204 _ -> Left . JsonDecodeError $ show (pp_value jerr)
206 -- | Scan the list of results produced by executeRpcCall and log all the RPC
208 logRpcErrors :: [(a, ERpcError b)] -> IO ()
209 logRpcErrors allElems =
210 let logOneRpcErr (_, Right _) = return ()
211 logOneRpcErr (_, Left err) =
212 logError $ "Error in the RPC HTTP reply: " ++ show err
213 in mapM_ logOneRpcErr allElems
215 -- | Execute RPC call for many nodes in parallel.
216 executeRpcCall :: (Rpc a b) => [Node] -> a -> IO [(Node, ERpcError b)]
217 executeRpcCall nodes call = do
218 cert_file <- P.nodedCertFile
219 let opts = [ CurlTimeout (fromIntegral $ rpcCallTimeout call)
220 , CurlSSLCert cert_file
221 , CurlSSLKey cert_file
222 , CurlCAInfo cert_file
224 opts_urls = map (\n ->
225 case prepareHttpRequest opts n call of
228 Right (CurlPostFields [requestData request]:
232 -- split the opts_urls list; we don't want to pass the
233 -- failed-already nodes to Curl
234 let (lefts, rights, trail) = splitEithers opts_urls
235 results <- execMultiCall rights
236 results' <- case recombineEithers lefts results trail of
239 -- now parse the replies
240 let results'' = map (parseHttpReply call) results'
241 pairedList = zip nodes results''
242 logRpcErrors pairedList
245 -- | Helper function that is used to read dictionaries of values.
246 sanitizeDictResults :: [(String, J.Result a)] -> ERpcError [(String, a)]
247 sanitizeDictResults =
248 foldr sanitize1 (Right [])
250 sanitize1 _ (Left e) = Left e
251 sanitize1 (_, J.Error e) _ = Left $ JsonDecodeError e
252 sanitize1 (name, J.Ok v) (Right res) = Right $ (name, v) : res
254 -- | Helper function to tranform JSON Result to Either RpcError b.
255 -- Note: For now we really only use it for b s.t. Rpc c b for some c
256 fromJResultToRes :: J.Result a -> (a -> b) -> ERpcError b
257 fromJResultToRes (J.Error v) _ = Left $ JsonDecodeError v
258 fromJResultToRes (J.Ok v) f = Right $ f v
260 -- | Helper function transforming JSValue to Rpc result type.
261 fromJSValueToRes :: (J.JSON a) => J.JSValue -> (a -> b) -> ERpcError b
262 fromJSValueToRes val = fromJResultToRes (J.readJSON val)
264 -- * RPC calls and results
269 -- Returns information about a single instance.
271 $(buildObject "RpcCallInstanceInfo" "rpcCallInstInfo"
272 [ simpleField "instance" [t| String |]
273 , simpleField "hname" [t| Hypervisor |]
276 $(buildObject "InstanceInfo" "instInfo"
277 [ simpleField "memory" [t| Int|]
278 , simpleField "state" [t| String |] -- It depends on hypervisor :(
279 , simpleField "vcpus" [t| Int |]
280 , simpleField "time" [t| Int |]
283 -- This is optional here because the result may be empty if instance is
284 -- not on a node - and this is not considered an error.
285 $(buildObject "RpcResultInstanceInfo" "rpcResInstInfo"
286 [ optionalField $ simpleField "inst_info" [t| InstanceInfo |]])
288 instance RpcCall RpcCallInstanceInfo where
289 rpcCallName _ = "instance_info"
290 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
291 rpcCallAcceptOffline _ = False
292 rpcCallData _ call = J.encode
293 ( rpcCallInstInfoInstance call
294 , rpcCallInstInfoHname call
297 instance Rpc RpcCallInstanceInfo RpcResultInstanceInfo where
298 rpcResultFill _ res =
301 case J.fromJSObject res' of
302 [] -> Right $ RpcResultInstanceInfo Nothing
303 _ -> fromJSValueToRes res (RpcResultInstanceInfo . Just)
304 _ -> Left $ JsonDecodeError
305 ("Expected JSObject, got " ++ show (pp_value res))
307 -- ** AllInstancesInfo
309 -- | AllInstancesInfo
310 -- Returns information about all running instances on the given nodes
311 $(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo"
312 [ simpleField "hypervisors" [t| [Hypervisor] |] ])
314 $(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo"
315 [ simpleField "instances" [t| [(String, InstanceInfo)] |] ])
317 instance RpcCall RpcCallAllInstancesInfo where
318 rpcCallName _ = "all_instances_info"
319 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
320 rpcCallAcceptOffline _ = False
321 rpcCallData _ call = J.encode [rpcCallAllInstInfoHypervisors call]
323 instance Rpc RpcCallAllInstancesInfo RpcResultAllInstancesInfo where
324 -- FIXME: Is there a simpler way to do it?
325 rpcResultFill _ res =
328 let res'' = map (second J.readJSON) (J.fromJSObject res')
329 :: [(String, J.Result InstanceInfo)] in
330 case sanitizeDictResults res'' of
332 Right insts -> Right $ RpcResultAllInstancesInfo insts
333 _ -> Left $ JsonDecodeError
334 ("Expected JSObject, got " ++ show (pp_value res))
339 -- Returns the list of running instances on the given nodes.
340 $(buildObject "RpcCallInstanceList" "rpcCallInstList"
341 [ simpleField "hypervisors" [t| [Hypervisor] |] ])
343 $(buildObject "RpcResultInstanceList" "rpcResInstList"
344 [ simpleField "instances" [t| [String] |] ])
346 instance RpcCall RpcCallInstanceList where
347 rpcCallName _ = "instance_list"
348 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
349 rpcCallAcceptOffline _ = False
350 rpcCallData _ call = J.encode [rpcCallInstListHypervisors call]
352 instance Rpc RpcCallInstanceList RpcResultInstanceList where
353 rpcResultFill _ res = fromJSValueToRes res RpcResultInstanceList
358 -- Return node information.
359 $(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo"
360 [ simpleField "storage_units" [t| Map.Map String [StorageUnit] |]
361 , simpleField "hypervisors" [t| [ (Hypervisor, HvParams) ] |]
364 $(buildObject "StorageInfo" "storageInfo"
365 [ simpleField "name" [t| String |]
366 , simpleField "type" [t| String |]
367 , optionalField $ simpleField "storage_free" [t| Int |]
368 , optionalField $ simpleField "storage_size" [t| Int |]
371 -- | We only provide common fields as described in hv_base.py.
372 $(buildObject "HvInfo" "hvInfo"
373 [ simpleField "memory_total" [t| Int |]
374 , simpleField "memory_free" [t| Int |]
375 , simpleField "memory_dom0" [t| Int |]
376 , simpleField "cpu_total" [t| Int |]
377 , simpleField "cpu_nodes" [t| Int |]
378 , simpleField "cpu_sockets" [t| Int |]
379 , simpleField "cpu_dom0" [t| Int |]
382 $(buildObject "RpcResultNodeInfo" "rpcResNodeInfo"
383 [ simpleField "boot_id" [t| String |]
384 , simpleField "storage_info" [t| [StorageInfo] |]
385 , simpleField "hv_info" [t| [HvInfo] |]
388 instance RpcCall RpcCallNodeInfo where
389 rpcCallName _ = "node_info"
390 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
391 rpcCallAcceptOffline _ = False
392 rpcCallData n call = J.encode
393 ( fromMaybe (error $ "Programmer error: missing parameter for node named "
395 $ Map.lookup (nodeUuid n) (rpcCallNodeInfoStorageUnits call)
396 , rpcCallNodeInfoHypervisors call
399 instance Rpc RpcCallNodeInfo RpcResultNodeInfo where
400 rpcResultFill _ res =
401 fromJSValueToRes res (\(b, vg, hv) -> RpcResultNodeInfo b vg hv)
405 -- | Query node version.
406 $(buildObject "RpcCallVersion" "rpcCallVersion" [])
408 -- | Query node reply.
409 $(buildObject "RpcResultVersion" "rpcResultVersion"
410 [ simpleField "version" [t| Int |]
413 instance RpcCall RpcCallVersion where
414 rpcCallName _ = "version"
415 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
416 rpcCallAcceptOffline _ = True
417 rpcCallData _ = J.encode
419 instance Rpc RpcCallVersion RpcResultVersion where
420 rpcResultFill _ res = fromJSValueToRes res RpcResultVersion
426 -- FIXME: This may be moved to Objects
427 $(declareSADT "StorageField"
428 [ ( "SFUsed", 'C.sfUsed)
429 , ( "SFName", 'C.sfName)
430 , ( "SFAllocatable", 'C.sfAllocatable)
431 , ( "SFFree", 'C.sfFree)
432 , ( "SFSize", 'C.sfSize)
434 $(makeJSONInstance ''StorageField)
436 $(buildObject "RpcCallStorageList" "rpcCallStorageList"
437 [ simpleField "su_name" [t| StorageType |]
438 , simpleField "su_args" [t| [String] |]
439 , simpleField "name" [t| String |]
440 , simpleField "fields" [t| [StorageField] |]
443 -- FIXME: The resulting JSValues should have types appropriate for their
444 -- StorageField value: Used -> Bool, Name -> String etc
445 $(buildObject "RpcResultStorageList" "rpcResStorageList"
446 [ simpleField "storage" [t| [[(StorageField, J.JSValue)]] |] ])
448 instance RpcCall RpcCallStorageList where
449 rpcCallName _ = "storage_list"
450 rpcCallTimeout _ = rpcTimeoutToRaw Normal
451 rpcCallAcceptOffline _ = False
452 rpcCallData _ call = J.encode
453 ( rpcCallStorageListSuName call
454 , rpcCallStorageListSuArgs call
455 , rpcCallStorageListName call
456 , rpcCallStorageListFields call
459 instance Rpc RpcCallStorageList RpcResultStorageList where
460 rpcResultFill call res =
461 let sfields = rpcCallStorageListFields call in
462 fromJSValueToRes res (RpcResultStorageList . map (zip sfields))
466 -- | Call definition for test delay.
467 $(buildObject "RpcCallTestDelay" "rpcCallTestDelay"
468 [ simpleField "duration" [t| Double |]
471 -- | Result definition for test delay.
472 data RpcResultTestDelay = RpcResultTestDelay
475 -- | Custom JSON instance for null result.
476 instance J.JSON RpcResultTestDelay where
477 showJSON _ = J.JSNull
478 readJSON J.JSNull = return RpcResultTestDelay
479 readJSON _ = fail "Unable to read RpcResultTestDelay"
481 instance RpcCall RpcCallTestDelay where
482 rpcCallName _ = "test_delay"
483 rpcCallTimeout = ceiling . (+ 5) . rpcCallTestDelayDuration
484 rpcCallAcceptOffline _ = False
485 rpcCallData _ call = J.encode [rpcCallTestDelayDuration call]
487 instance Rpc RpcCallTestDelay RpcResultTestDelay where
488 rpcResultFill _ res = fromJSValueToRes res id
492 -- | Call definition for export list.
494 $(buildObject "RpcCallExportList" "rpcCallExportList" [])
496 -- | Result definition for export list.
497 $(buildObject "RpcResultExportList" "rpcResExportList"
498 [ simpleField "exports" [t| [String] |]
501 instance RpcCall RpcCallExportList where
502 rpcCallName _ = "export_list"
503 rpcCallTimeout _ = rpcTimeoutToRaw Fast
504 rpcCallAcceptOffline _ = False
505 rpcCallData _ = J.encode
507 instance Rpc RpcCallExportList RpcResultExportList where
508 rpcResultFill _ res = fromJSValueToRes res RpcResultExportList