Rpc.hs 16.4 KB
Newer Older
1
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
2
  BangPatterns, TemplateHaskell #-}
3
4
5
6
7
8
9

{-| Implementation of the RPC client.

-}

{-

10
Copyright (C) 2012, 2013 Google Inc.
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

module Ganeti.Rpc
  ( RpcCall
  , Rpc
  , RpcError(..)
33
  , ERpcError
34
  , explainRpcError
35
  , executeRpcCall
36
  , logRpcErrors
37
38
39
40
41
42
43

  , rpcCallName
  , rpcCallTimeout
  , rpcCallData
  , rpcCallAcceptOffline

  , rpcResultFill
44
45

  , InstanceInfo(..)
Agata Murawska's avatar
Agata Murawska committed
46
47
48
  , RpcCallInstanceInfo(..)
  , RpcResultInstanceInfo(..)

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

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

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

Agata Murawska's avatar
Agata Murawska committed
60
61
62
  , RpcCallVersion(..)
  , RpcResultVersion(..)

Agata Murawska's avatar
Agata Murawska committed
63
64
65
66
  , StorageField(..)
  , RpcCallStorageList(..)
  , RpcResultStorageList(..)

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

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

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

76
import Control.Arrow (second)
77
78
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
79
import qualified Text.JSON as J
80
import Text.JSON.Pretty (pp_value)
81

82
import Network.Curl
Agata Murawska's avatar
Agata Murawska committed
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
92
import Ganeti.Curl.Multi
import Ganeti.Utils
93

94
95
-- * Base RPC functionality and types

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

-- | Data type for RPC error reporting.
data RpcError
Iustin Pop's avatar
Iustin Pop committed
108
  = CurlLayerError String
109
  | JsonDecodeError String
Agata Murawska's avatar
Agata Murawska committed
110
  | RpcResultError String
Iustin Pop's avatar
Iustin Pop committed
111
  | OfflineNodeError
112
  deriving (Show, Eq)
113

114
115
-- | Provide explanation to RPC errors.
explainRpcError :: RpcError -> String
Iustin Pop's avatar
Iustin Pop committed
116
117
explainRpcError (CurlLayerError code) =
    "Curl error:" ++ code
118
explainRpcError (JsonDecodeError msg) =
Agata Murawska's avatar
Agata Murawska committed
119
    "Error while decoding JSON from HTTP response: " ++ msg
120
explainRpcError (RpcResultError msg) =
Agata Murawska's avatar
Agata Murawska committed
121
    "Error reponse received from RPC server: " ++ msg
Iustin Pop's avatar
Iustin Pop committed
122
123
explainRpcError OfflineNodeError =
    "Node is marked offline"
124

125
126
type ERpcError = Either RpcError

127
128
129
130
131
132
133
134
135
136
-- | Basic timeouts for RPC calls.
$(declareIADT "RpcTimeout"
  [ ( "Urgent",    'C.rpcTmoUrgent )
  , ( "Fast",      'C.rpcTmoFast )
  , ( "Normal",    'C.rpcTmoNormal )
  , ( "Slow",      'C.rpcTmoSlow )
  , ( "FourHours", 'C.rpcTmo4hrs )
  , ( "OneDay",    'C.rpcTmo1day )
  ])

137
138
139
140
141
142
143
144
145
146
147
148
149
-- | A generic class for RPC calls.
class (J.JSON a) => RpcCall a where
  -- | Give the (Python) name of the procedure.
  rpcCallName :: a -> String
  -- | Calculate the timeout value for the call execution.
  rpcCallTimeout :: a -> Int
  -- | Prepare arguments of the call to be send as POST.
  rpcCallData :: Node -> a -> String
  -- | Whether we accept offline nodes when making a call.
  rpcCallAcceptOffline :: a -> Bool

-- | Generic class that ensures matching RPC call with its respective
-- result.
Agata Murawska's avatar
Agata Murawska committed
150
151
class (RpcCall a, J.JSON b) => Rpc a b  | a -> b, b -> a where
  -- | Create a result based on the received HTTP response.
152
  rpcResultFill :: a -> J.JSValue -> ERpcError b
153
154
155

-- | Http Request definition.
data HttpClientRequest = HttpClientRequest
156
157
158
  { requestUrl  :: String       -- ^ The actual URL for the node endpoint
  , requestData :: String       -- ^ The arguments for the call
  , requestOpts :: [CurlOption] -- ^ The various curl options
159
160
  }

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

165
166
167
168
-- | Prepare url for the HTTP request.
prepareUrl :: (RpcCall a) => Node -> a -> String
prepareUrl node call =
  let node_ip = nodePrimaryIp node
169
170
171
      node_address = if isIpV6 node_ip
                     then "[" ++ node_ip ++ "]"
                     else node_ip
172
      port = snd C.daemonsPortsGanetiNoded
173
      path_prefix = "https://" ++ node_address ++ ":" ++ show port
Iustin Pop's avatar
Iustin Pop committed
174
  in path_prefix ++ "/" ++ rpcCallName call
175
176
177

-- | Create HTTP request for a given node provided it is online,
-- otherwise create empty response.
178
prepareHttpRequest :: (RpcCall a) => [CurlOption] -> Node -> a
179
                   -> ERpcError HttpClientRequest
180
prepareHttpRequest opts node call
Iustin Pop's avatar
Iustin Pop committed
181
  | rpcCallAcceptOffline call || not (nodeOffline node) =
182
183
184
      Right HttpClientRequest { requestUrl  = prepareUrl node call
                              , requestData = rpcCallData node call
                              , requestOpts = opts ++ curlOpts
Iustin Pop's avatar
Iustin Pop committed
185
                              }
Iustin Pop's avatar
Iustin Pop committed
186
  | otherwise = Left OfflineNodeError
187

188
189
190
191
192
193
194
195
-- | Parse an HTTP reply.
parseHttpReply :: (Rpc a b) =>
                  a -> ERpcError (CurlCode, String) -> ERpcError b
parseHttpReply _ (Left e) = Left e
parseHttpReply call (Right (CurlOK, body)) = parseHttpResponse call body
parseHttpReply _ (Right (code, err)) =
  Left . CurlLayerError $ "code: " ++ show code ++ ", explanation: " ++ err

196
-- | Parse a result based on the received HTTP response.
197
198
parseHttpResponse :: (Rpc a b) => a -> String -> ERpcError b
parseHttpResponse call res =
199
200
201
202
203
204
  case J.decode res of
    J.Error val -> Left $ JsonDecodeError val
    J.Ok (True, res'') -> rpcResultFill call res''
    J.Ok (False, jerr) -> case jerr of
       J.JSString msg -> Left $ RpcResultError (J.fromJSString msg)
       _ -> Left . JsonDecodeError $ show (pp_value jerr)
205

206
207
208
209
210
211
212
213
214
-- | Scan the list of results produced by executeRpcCall and log all the RPC
-- errors.
logRpcErrors :: [(a, ERpcError b)] -> IO ()
logRpcErrors allElems =
  let logOneRpcErr (_, Right _) = return ()
      logOneRpcErr (_, Left err) =
        logError $ "Error in the RPC HTTP reply: " ++ show err
  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
218
219
220
221
222
223
executeRpcCall nodes call = do
  cert_file <- P.nodedCertFile
  let opts = [ CurlTimeout (fromIntegral $ rpcCallTimeout call)
             , CurlSSLCert cert_file
             , CurlSSLKey cert_file
             , CurlCAInfo cert_file
             ]
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
      opts_urls = map (\n ->
                         case prepareHttpRequest opts n call of
                           Left v -> Left v
                           Right request ->
                             Right (CurlPostFields [requestData request]:
                                    requestOpts request,
                                    requestUrl request)
                      ) nodes
  -- split the opts_urls list; we don't want to pass the
  -- failed-already nodes to Curl
  let (lefts, rights, trail) = splitEithers opts_urls
  results <- execMultiCall rights
  results' <- case recombineEithers lefts results trail of
                Bad msg -> error msg
                Ok r -> return r
  -- now parse the replies
  let results'' = map (parseHttpReply call) results'
241
242
243
      pairedList = zip nodes results''
  logRpcErrors pairedList
  return pairedList
244

245
246
-- | Helper function that is used to read dictionaries of values.
sanitizeDictResults :: [(String, J.Result a)] -> ERpcError [(String, a)]
247
248
249
250
251
252
sanitizeDictResults =
  foldr sanitize1 (Right [])
  where
    sanitize1 _ (Left e) = Left e
    sanitize1 (_, J.Error e) _ = Left $ JsonDecodeError e
    sanitize1 (name, J.Ok v) (Right res) = Right $ (name, v) : res
253

254
255
256
257
258
259
260
261
262
263
-- | Helper function to tranform JSON Result to Either RpcError b.
-- Note: For now we really only use it for b s.t. Rpc c b for some c
fromJResultToRes :: J.Result a -> (a -> b) -> ERpcError b
fromJResultToRes (J.Error v) _ = Left $ JsonDecodeError v
fromJResultToRes (J.Ok v) f = Right $ f v

-- | Helper function transforming JSValue to Rpc result type.
fromJSValueToRes :: (J.JSON a) => J.JSValue -> (a -> b) -> ERpcError b
fromJSValueToRes val = fromJResultToRes (J.readJSON val)

264
265
-- * RPC calls and results

266
267
-- ** Instance info

Agata Murawska's avatar
Agata Murawska committed
268
269
270
271
272
273
274
-- | InstanceInfo
--   Returns information about a single instance.

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

Iustin Pop's avatar
Iustin Pop committed
276
$(buildObject "InstanceInfo" "instInfo"
277
278
  [ simpleField "memory" [t| Int|]
  , simpleField "state"  [t| String |] -- It depends on hypervisor :(
279
280
281
282
  , simpleField "vcpus"  [t| Int |]
  , simpleField "time"   [t| Int |]
  ])

Agata Murawska's avatar
Agata Murawska committed
283
284
285
286
287
288
-- This is optional here because the result may be empty if instance is
-- not on a node - and this is not considered an error.
$(buildObject "RpcResultInstanceInfo" "rpcResInstInfo"
  [ optionalField $ simpleField "inst_info" [t| InstanceInfo |]])

instance RpcCall RpcCallInstanceInfo where
289
290
  rpcCallName _          = "instance_info"
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
Agata Murawska's avatar
Agata Murawska committed
291
  rpcCallAcceptOffline _ = False
292
  rpcCallData _ call     = J.encode
Agata Murawska's avatar
Agata Murawska committed
293
294
295
296
297
298
    ( rpcCallInstInfoInstance call
    , rpcCallInstInfoHname call
    )

instance Rpc RpcCallInstanceInfo RpcResultInstanceInfo where
  rpcResultFill _ res =
299
    case res of
Agata Murawska's avatar
Agata Murawska committed
300
301
302
      J.JSObject res' ->
        case J.fromJSObject res' of
          [] -> Right $ RpcResultInstanceInfo Nothing
303
          _ -> fromJSValueToRes res (RpcResultInstanceInfo . Just)
Agata Murawska's avatar
Agata Murawska committed
304
      _ -> Left $ JsonDecodeError
Agata Murawska's avatar
Agata Murawska committed
305
           ("Expected JSObject, got " ++ show (pp_value res))
Agata Murawska's avatar
Agata Murawska committed
306

307
308
-- ** AllInstancesInfo

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

Iustin Pop's avatar
Iustin Pop committed
314
$(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo"
315
  [ simpleField "instances" [t| [(String, InstanceInfo)] |] ])
316
317

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

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

336
337
-- ** InstanceList

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

Iustin Pop's avatar
Iustin Pop committed
343
$(buildObject "RpcResultInstanceList" "rpcResInstList"
344
  [ simpleField "instances" [t| [String] |] ])
345
346

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

Agata Murawska's avatar
Agata Murawska committed
352
instance Rpc RpcCallInstanceList RpcResultInstanceList where
353
  rpcResultFill _ res = fromJSValueToRes res RpcResultInstanceList
354

355
356
-- ** NodeInfo

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

Iustin Pop's avatar
Iustin Pop committed
365
$(buildObject "VgInfo" "vgInfo"
366
  [ simpleField "name" [t| String |]
367
368
  , optionalField $ simpleField "vg_free" [t| Int |]
  , optionalField $ simpleField "vg_size" [t| Int |]
369
370
371
  ])

-- | We only provide common fields as described in hv_base.py.
Iustin Pop's avatar
Iustin Pop committed
372
$(buildObject "HvInfo" "hvInfo"
373
374
375
376
377
378
379
380
  [ simpleField "memory_total" [t| Int |]
  , simpleField "memory_free" [t| Int |]
  , simpleField "memory_dom0" [t| Int |]
  , simpleField "cpu_total" [t| Int |]
  , simpleField "cpu_nodes" [t| Int |]
  , simpleField "cpu_sockets" [t| Int |]
  ])

Iustin Pop's avatar
Iustin Pop committed
381
$(buildObject "RpcResultNodeInfo" "rpcResNodeInfo"
382
383
384
385
386
387
  [ simpleField "boot_id" [t| String |]
  , simpleField "vg_info" [t| [VgInfo] |]
  , simpleField "hv_info" [t| [HvInfo] |]
  ])

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

Agata Murawska's avatar
Agata Murawska committed
399
400
instance Rpc RpcCallNodeInfo RpcResultNodeInfo where
  rpcResultFill _ res =
401
    fromJSValueToRes res (\(b, vg, hv) -> RpcResultNodeInfo b vg hv)
402

403
404
-- ** Version

405
406
-- | Query node version.
$(buildObject "RpcCallVersion" "rpcCallVersion" [])
Agata Murawska's avatar
Agata Murawska committed
407

408
-- | Query node reply.
Agata Murawska's avatar
Agata Murawska committed
409
410
411
412
413
$(buildObject "RpcResultVersion" "rpcResultVersion"
  [ simpleField "version" [t| Int |]
  ])

instance RpcCall RpcCallVersion where
414
415
  rpcCallName _          = "version"
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
Agata Murawska's avatar
Agata Murawska committed
416
  rpcCallAcceptOffline _ = True
Iustin Pop's avatar
Iustin Pop committed
417
  rpcCallData _          = J.encode
Agata Murawska's avatar
Agata Murawska committed
418

Agata Murawska's avatar
Agata Murawska committed
419
instance Rpc RpcCallVersion RpcResultVersion where
420
  rpcResultFill _ res = fromJSValueToRes res RpcResultVersion
Agata Murawska's avatar
Agata Murawska committed
421

422
423
-- ** StorageList

Agata Murawska's avatar
Agata Murawska committed
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
-- | StorageList

-- FIXME: This may be moved to Objects
$(declareSADT "StorageField"
  [ ( "SFUsed",        'C.sfUsed)
  , ( "SFName",        'C.sfName)
  , ( "SFAllocatable", 'C.sfAllocatable)
  , ( "SFFree",        'C.sfFree)
  , ( "SFSize",        'C.sfSize)
  ])
$(makeJSONInstance ''StorageField)

$(buildObject "RpcCallStorageList" "rpcCallStorageList"
  [ simpleField "su_name" [t| StorageType |]
  , simpleField "su_args" [t| [String] |]
  , simpleField "name"    [t| String |]
  , simpleField "fields"  [t| [StorageField] |]
  ])

-- FIXME: The resulting JSValues should have types appropriate for their
-- StorageField value: Used -> Bool, Name -> String etc
$(buildObject "RpcResultStorageList" "rpcResStorageList"
  [ simpleField "storage" [t| [[(StorageField, J.JSValue)]] |] ])

instance RpcCall RpcCallStorageList where
449
450
  rpcCallName _          = "storage_list"
  rpcCallTimeout _       = rpcTimeoutToRaw Normal
Agata Murawska's avatar
Agata Murawska committed
451
  rpcCallAcceptOffline _ = False
452
  rpcCallData _ call     = J.encode
Agata Murawska's avatar
Agata Murawska committed
453
454
455
456
457
458
459
460
461
    ( rpcCallStorageListSuName call
    , rpcCallStorageListSuArgs call
    , rpcCallStorageListName call
    , rpcCallStorageListFields call
    )

instance Rpc RpcCallStorageList RpcResultStorageList where
  rpcResultFill call res =
    let sfields = rpcCallStorageListFields call in
462
    fromJSValueToRes res (RpcResultStorageList . map (zip sfields))
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488

-- ** TestDelay

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

-- | Result definition for test delay.
data RpcResultTestDelay = RpcResultTestDelay
                          deriving Show

-- | Custom JSON instance for null result.
instance J.JSON RpcResultTestDelay where
  showJSON _        = J.JSNull
  readJSON J.JSNull = return RpcResultTestDelay
  readJSON _        = fail "Unable to read RpcResultTestDelay"

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

instance Rpc RpcCallTestDelay RpcResultTestDelay where
  rpcResultFill _ res = fromJSValueToRes res id
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508

-- ** ExportList

-- | Call definition for export list.

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

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

instance RpcCall RpcCallExportList where
  rpcCallName _          = "export_list"
  rpcCallTimeout _       = rpcTimeoutToRaw Fast
  rpcCallAcceptOffline _ = False
  rpcCallData _          = J.encode

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