Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Rpc.hs @ b5c3a4f2

History | View | Annotate | Download (16.4 kB)

1
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
2
  BangPatterns, TemplateHaskell #-}
3

    
4
{-| Implementation of the RPC client.
5

    
6
-}
7

    
8
{-
9

    
10
Copyright (C) 2012, 2013 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
  , Rpc
32
  , RpcError(..)
33
  , ERpcError
34
  , explainRpcError
35
  , executeRpcCall
36
  , logRpcErrors
37

    
38
  , rpcCallName
39
  , rpcCallTimeout
40
  , rpcCallData
41
  , rpcCallAcceptOffline
42

    
43
  , rpcResultFill
44

    
45
  , InstanceInfo(..)
46
  , RpcCallInstanceInfo(..)
47
  , RpcResultInstanceInfo(..)
48

    
49
  , RpcCallAllInstancesInfo(..)
50
  , RpcResultAllInstancesInfo(..)
51

    
52
  , RpcCallInstanceList(..)
53
  , RpcResultInstanceList(..)
54

    
55
  , HvInfo(..)
56
  , VgInfo(..)
57
  , RpcCallNodeInfo(..)
58
  , RpcResultNodeInfo(..)
59

    
60
  , RpcCallVersion(..)
61
  , RpcResultVersion(..)
62

    
63
  , StorageField(..)
64
  , RpcCallStorageList(..)
65
  , RpcResultStorageList(..)
66

    
67
  , RpcCallTestDelay(..)
68
  , RpcResultTestDelay(..)
69

    
70
  , RpcCallExportList(..)
71
  , RpcResultExportList(..)
72

    
73
  , rpcTimeoutFromRaw -- FIXME: Not used anywhere
74
  ) where
75

    
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)
81

    
82
import Network.Curl
83
import qualified Ganeti.Path as P
84

    
85
import Ganeti.BasicTypes
86
import qualified Ganeti.Constants as C
87
import Ganeti.Logging
88
import Ganeti.Objects
89
import Ganeti.THH
90
import Ganeti.Types
91
import Ganeti.Curl.Multi
92
import Ganeti.Utils
93

    
94
-- * Base RPC functionality and types
95

    
96
-- | The curl options used for RPC.
97
curlOpts :: [CurlOption]
98
curlOpts = [ CurlFollowLocation False
99
           , CurlSSLVerifyHost 0
100
           , CurlSSLVerifyPeer True
101
           , CurlSSLCertType "PEM"
102
           , CurlSSLKeyType "PEM"
103
           , CurlConnectTimeout (fromIntegral C.rpcConnectTimeout)
104
           ]
105

    
106
-- | Data type for RPC error reporting.
107
data RpcError
108
  = CurlLayerError String
109
  | JsonDecodeError String
110
  | RpcResultError String
111
  | OfflineNodeError
112
  deriving (Show, Eq)
113

    
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"
124

    
125
type ERpcError = Either RpcError
126

    
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 )
135
  ])
136

    
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
147

    
148
-- | Generic class that ensures matching RPC call with its respective
149
-- result.
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
153

    
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
159
  }
160

    
161
-- | Check if a string represented address is IPv6
162
isIpV6 :: String -> Bool
163
isIpV6 ip = elem ':' ip
164

    
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 ++ "]"
171
                     else node_ip
172
      port = snd C.daemonsPortsGanetiNoded
173
      path_prefix = "https://" ++ node_address ++ ":" ++ show port
174
  in path_prefix ++ "/" ++ rpcCallName call
175

    
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
185
                              }
186
  | otherwise = Left OfflineNodeError
187

    
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
195

    
196
-- | Parse a result based on the received HTTP response.
197
parseHttpResponse :: (Rpc a b) => a -> String -> ERpcError b
198
parseHttpResponse call res =
199
  case J.decode res of
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)
205

    
206
-- | Scan the list of results produced by executeRpcCall and log all the RPC
207
-- errors.
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
214

    
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
223
             ]
224
      opts_urls = map (\n ->
225
                         case prepareHttpRequest opts n call of
226
                           Left v -> Left v
227
                           Right request ->
228
                             Right (CurlPostFields [requestData request]:
229
                                    requestOpts request,
230
                                    requestUrl request)
231
                      ) nodes
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
237
                Bad msg -> error msg
238
                Ok r -> return r
239
  -- now parse the replies
240
  let results'' = map (parseHttpReply call) results'
241
      pairedList = zip nodes results''
242
  logRpcErrors pairedList
243
  return pairedList
244

    
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 [])
249
  where
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
253

    
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
259

    
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)
263

    
264
-- * RPC calls and results
265

    
266
-- ** Instance info
267

    
268
-- | InstanceInfo
269
--   Returns information about a single instance.
270

    
271
$(buildObject "RpcCallInstanceInfo" "rpcCallInstInfo"
272
  [ simpleField "instance" [t| String |]
273
  , simpleField "hname" [t| Hypervisor |]
274
  ])
275

    
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 |]
281
  ])
282

    
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 |]])
287

    
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
295
    )
296

    
297
instance Rpc RpcCallInstanceInfo RpcResultInstanceInfo where
298
  rpcResultFill _ res =
299
    case res of
300
      J.JSObject 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))
306

    
307
-- ** AllInstancesInfo
308

    
309
-- | AllInstancesInfo
310
--   Returns information about all running instances on the given nodes
311
$(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo"
312
  [ simpleField "hypervisors" [t| [Hypervisor] |] ])
313

    
314
$(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo"
315
  [ simpleField "instances" [t| [(String, InstanceInfo)] |] ])
316

    
317
instance RpcCall RpcCallAllInstancesInfo where
318
  rpcCallName _          = "all_instances_info"
319
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
320
  rpcCallAcceptOffline _ = False
321
  rpcCallData _ call     = J.encode [rpcCallAllInstInfoHypervisors call]
322

    
323
instance Rpc RpcCallAllInstancesInfo RpcResultAllInstancesInfo where
324
  -- FIXME: Is there a simpler way to do it?
325
  rpcResultFill _ res =
326
    case res of
327
      J.JSObject res' ->
328
        let res'' = map (second J.readJSON) (J.fromJSObject res')
329
                        :: [(String, J.Result InstanceInfo)] in
330
        case sanitizeDictResults res'' of
331
          Left err -> Left err
332
          Right insts -> Right $ RpcResultAllInstancesInfo insts
333
      _ -> Left $ JsonDecodeError
334
           ("Expected JSObject, got " ++ show (pp_value res))
335

    
336
-- ** InstanceList
337

    
338
-- | InstanceList
339
-- Returns the list of running instances on the given nodes.
340
$(buildObject "RpcCallInstanceList" "rpcCallInstList"
341
  [ simpleField "hypervisors" [t| [Hypervisor] |] ])
342

    
343
$(buildObject "RpcResultInstanceList" "rpcResInstList"
344
  [ simpleField "instances" [t| [String] |] ])
345

    
346
instance RpcCall RpcCallInstanceList where
347
  rpcCallName _          = "instance_list"
348
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
349
  rpcCallAcceptOffline _ = False
350
  rpcCallData _ call     = J.encode [rpcCallInstListHypervisors call]
351

    
352
instance Rpc RpcCallInstanceList RpcResultInstanceList where
353
  rpcResultFill _ res = fromJSValueToRes res RpcResultInstanceList
354

    
355
-- ** NodeInfo
356

    
357
-- | NodeInfo
358
-- Return node information.
359
$(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo"
360
  [ simpleField "volume_groups" [t| [String] |]
361
  , simpleField "hypervisors" [t| [Hypervisor] |]
362
  , simpleField "exclusive_storage" [t| Map.Map String Bool |]
363
  ])
364

    
365
$(buildObject "VgInfo" "vgInfo"
366
  [ simpleField "name" [t| String |]
367
  , optionalField $ simpleField "vg_free" [t| Int |]
368
  , optionalField $ simpleField "vg_size" [t| Int |]
369
  ])
370

    
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
  ])
380

    
381
$(buildObject "RpcResultNodeInfo" "rpcResNodeInfo"
382
  [ simpleField "boot_id" [t| String |]
383
  , simpleField "vg_info" [t| [VgInfo] |]
384
  , simpleField "hv_info" [t| [HvInfo] |]
385
  ])
386

    
387
instance RpcCall RpcCallNodeInfo where
388
  rpcCallName _          = "node_info"
389
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
390
  rpcCallAcceptOffline _ = False
391
  rpcCallData n call     = J.encode
392
    ( rpcCallNodeInfoVolumeGroups call
393
    , rpcCallNodeInfoHypervisors call
394
    , fromMaybe (error $ "Programmer error: missing parameter for node named "
395
                         ++ nodeName n)
396
                $ Map.lookup (nodeName n) (rpcCallNodeInfoExclusiveStorage call)
397
    )
398

    
399
instance Rpc RpcCallNodeInfo RpcResultNodeInfo where
400
  rpcResultFill _ res =
401
    fromJSValueToRes res (\(b, vg, hv) -> RpcResultNodeInfo b vg hv)
402

    
403
-- ** Version
404

    
405
-- | Query node version.
406
$(buildObject "RpcCallVersion" "rpcCallVersion" [])
407

    
408
-- | Query node reply.
409
$(buildObject "RpcResultVersion" "rpcResultVersion"
410
  [ simpleField "version" [t| Int |]
411
  ])
412

    
413
instance RpcCall RpcCallVersion where
414
  rpcCallName _          = "version"
415
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
416
  rpcCallAcceptOffline _ = True
417
  rpcCallData _          = J.encode
418

    
419
instance Rpc RpcCallVersion RpcResultVersion where
420
  rpcResultFill _ res = fromJSValueToRes res RpcResultVersion
421

    
422
-- ** StorageList
423

    
424
-- | StorageList
425

    
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)
433
  ])
434
$(makeJSONInstance ''StorageField)
435

    
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] |]
441
  ])
442

    
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)]] |] ])
447

    
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
457
    )
458

    
459
instance Rpc RpcCallStorageList RpcResultStorageList where
460
  rpcResultFill call res =
461
    let sfields = rpcCallStorageListFields call in
462
    fromJSValueToRes res (RpcResultStorageList . map (zip sfields))
463

    
464
-- ** TestDelay
465

    
466
-- | Call definition for test delay.
467
$(buildObject "RpcCallTestDelay" "rpcCallTestDelay"
468
  [ simpleField "duration" [t| Double |]
469
  ])
470

    
471
-- | Result definition for test delay.
472
data RpcResultTestDelay = RpcResultTestDelay
473
                          deriving Show
474

    
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"
480

    
481
instance RpcCall RpcCallTestDelay where
482
  rpcCallName _          = "test_delay"
483
  rpcCallTimeout         = ceiling . (+ 5) . rpcCallTestDelayDuration
484
  rpcCallAcceptOffline _ = False
485
  rpcCallData _ call     = J.encode [rpcCallTestDelayDuration call]
486

    
487
instance Rpc RpcCallTestDelay RpcResultTestDelay where
488
  rpcResultFill _ res = fromJSValueToRes res id
489

    
490
-- ** ExportList
491

    
492
-- | Call definition for export list.
493

    
494
$(buildObject "RpcCallExportList" "rpcCallExportList" [])
495

    
496
-- | Result definition for export list.
497
$(buildObject "RpcResultExportList" "rpcResExportList"
498
  [ simpleField "exports" [t| [String] |]
499
  ])
500

    
501
instance RpcCall RpcCallExportList where
502
  rpcCallName _          = "export_list"
503
  rpcCallTimeout _       = rpcTimeoutToRaw Fast
504
  rpcCallAcceptOffline _ = False
505
  rpcCallData _          = J.encode
506

    
507
instance Rpc RpcCallExportList RpcResultExportList where
508
  rpcResultFill _ res = fromJSValueToRes res RpcResultExportList