Rpc.hs 15.4 KB
Newer Older
1
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, CPP,
2
  BangPatterns, TemplateHaskell #-}
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

{-| Implementation of the RPC client.

-}

{-

Copyright (C) 2012 Google Inc.

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
37
38
39
40
41
42

  , rpcCallName
  , rpcCallTimeout
  , rpcCallData
  , rpcCallAcceptOffline

  , rpcResultFill
43
44

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

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

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

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

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

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

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

69
  , rpcTimeoutFromRaw -- FIXME: Not used anywhere
70
71
  ) where

72
import Control.Arrow (second)
73
74
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
75
import qualified Text.JSON as J
76
import Text.JSON.Pretty (pp_value)
77

78
79
#ifndef NO_CURL
import Network.Curl
Agata Murawska's avatar
Agata Murawska committed
80
import qualified Ganeti.Path as P
81
82
83
#endif

import qualified Ganeti.Constants as C
84
import Ganeti.Objects
85
import Ganeti.THH
86
import Ganeti.Types
87
import Ganeti.Compat
88

89
90
-- * Base RPC functionality and types

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

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

112
113
114
-- | Provide explanation to RPC errors.
explainRpcError :: RpcError -> String
explainRpcError CurlDisabledError =
115
    "RPC/curl backend disabled at compile time"
116
explainRpcError (CurlLayerError node code) =
Agata Murawska's avatar
Agata Murawska committed
117
    "Curl error for " ++ nodeName node ++ ", " ++ 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
122
explainRpcError (OfflineNodeError node) =
123
124
    "Node " ++ nodeName node ++ " is marked as offline"

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
156
157
158
159
160
161
162

-- | Http Request definition.
data HttpClientRequest = HttpClientRequest
  { requestTimeout :: Int
  , requestUrl :: String
  , requestPostData :: String
  }

-- | Execute the request and return the result as a plain String. When
-- curl reports an error, we propagate it.
163
164
executeHttpRequest :: Node -> ERpcError HttpClientRequest
                   -> IO (ERpcError String)
165
166
167
168
169
170

executeHttpRequest _ (Left rpc_err) = return $ Left rpc_err
#ifdef NO_CURL
executeHttpRequest _ _ = return $ Left CurlDisabledError
#else
executeHttpRequest node (Right request) = do
Iustin Pop's avatar
Iustin Pop committed
171
  cert_file <- P.nodedCertFile
172
173
  let reqOpts = [ CurlTimeout (fromIntegral $ requestTimeout request)
                , CurlPostFields [requestPostData request]
Iustin Pop's avatar
Iustin Pop committed
174
175
176
                , CurlSSLCert cert_file
                , CurlSSLKey cert_file
                , CurlCAInfo cert_file
177
178
179
180
                ]
      url = requestUrl request
  -- FIXME: This is very similar to getUrl in Htools/Rapi.hs
  (code, !body) <- curlGetString url $ curlOpts ++ reqOpts
Iustin Pop's avatar
Iustin Pop committed
181
182
183
  return $ case code of
             CurlOK -> Right body
             _ -> Left $ CurlLayerError node (show code)
184
185
186
187
188
189
190
#endif

-- | Prepare url for the HTTP request.
prepareUrl :: (RpcCall a) => Node -> a -> String
prepareUrl node call =
  let node_ip = nodePrimaryIp node
      port = snd C.daemonsPortsGanetiNoded
Iustin Pop's avatar
Iustin Pop committed
191
192
      path_prefix = "https://" ++ node_ip ++ ":" ++ show port
  in path_prefix ++ "/" ++ rpcCallName call
193
194
195
196

-- | Create HTTP request for a given node provided it is online,
-- otherwise create empty response.
prepareHttpRequest ::  (RpcCall a) => Node -> a
197
                   -> ERpcError HttpClientRequest
198
prepareHttpRequest node call
Iustin Pop's avatar
Iustin Pop committed
199
200
201
202
203
  | rpcCallAcceptOffline call || not (nodeOffline node) =
      Right HttpClientRequest { requestTimeout = rpcCallTimeout call
                              , requestUrl = prepareUrl node call
                              , requestPostData = rpcCallData node call
                              }
204
205
  | otherwise = Left $ OfflineNodeError node

206
-- | Parse a result based on the received HTTP response.
207
208
209
parseHttpResponse :: (Rpc a b) => a -> ERpcError String -> ERpcError b
parseHttpResponse _ (Left err) = Left err
parseHttpResponse call (Right res) =
210
211
212
213
214
215
  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)
216

217
-- | Execute RPC call for a sigle node.
218
executeSingleRpcCall :: (Rpc a b) => Node -> a -> IO (Node, ERpcError b)
219
220
221
executeSingleRpcCall node call = do
  let request = prepareHttpRequest node call
  response <- executeHttpRequest node request
222
  let result = parseHttpResponse call response
223
224
225
  return (node, result)

-- | Execute RPC call for many nodes in parallel.
226
executeRpcCall :: (Rpc a b) => [Node] -> a -> IO [(Node, ERpcError b)]
227
228
229
executeRpcCall nodes call =
  sequence $ parMap rwhnf (uncurry executeSingleRpcCall)
               (zip nodes $ repeat call)
230

231
232
-- | Helper function that is used to read dictionaries of values.
sanitizeDictResults :: [(String, J.Result a)] -> ERpcError [(String, a)]
233
234
235
236
237
238
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
239

240
241
242
243
244
245
246
247
248
249
-- | 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)

250
251
-- * RPC calls and results

252
253
-- ** Instance info

Agata Murawska's avatar
Agata Murawska committed
254
255
256
257
258
259
260
-- | InstanceInfo
--   Returns information about a single instance.

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

Iustin Pop's avatar
Iustin Pop committed
262
$(buildObject "InstanceInfo" "instInfo"
263
264
  [ simpleField "memory" [t| Int|]
  , simpleField "state"  [t| String |] -- It depends on hypervisor :(
265
266
267
268
  , simpleField "vcpus"  [t| Int |]
  , simpleField "time"   [t| Int |]
  ])

Agata Murawska's avatar
Agata Murawska committed
269
270
271
272
273
274
-- 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
275
276
  rpcCallName _          = "instance_info"
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
Agata Murawska's avatar
Agata Murawska committed
277
  rpcCallAcceptOffline _ = False
278
  rpcCallData _ call     = J.encode
Agata Murawska's avatar
Agata Murawska committed
279
280
281
282
283
284
    ( rpcCallInstInfoInstance call
    , rpcCallInstInfoHname call
    )

instance Rpc RpcCallInstanceInfo RpcResultInstanceInfo where
  rpcResultFill _ res =
285
    case res of
Agata Murawska's avatar
Agata Murawska committed
286
287
288
      J.JSObject res' ->
        case J.fromJSObject res' of
          [] -> Right $ RpcResultInstanceInfo Nothing
289
          _ -> fromJSValueToRes res (RpcResultInstanceInfo . Just)
Agata Murawska's avatar
Agata Murawska committed
290
      _ -> Left $ JsonDecodeError
Agata Murawska's avatar
Agata Murawska committed
291
           ("Expected JSObject, got " ++ show (pp_value res))
Agata Murawska's avatar
Agata Murawska committed
292

293
294
-- ** AllInstancesInfo

Agata Murawska's avatar
Agata Murawska committed
295
296
297
298
299
-- | 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
300
$(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo"
301
  [ simpleField "instances" [t| [(String, InstanceInfo)] |] ])
302
303

instance RpcCall RpcCallAllInstancesInfo where
304
305
  rpcCallName _          = "all_instances_info"
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
306
  rpcCallAcceptOffline _ = False
307
  rpcCallData _ call     = J.encode [rpcCallAllInstInfoHypervisors call]
308

Agata Murawska's avatar
Agata Murawska committed
309
instance Rpc RpcCallAllInstancesInfo RpcResultAllInstancesInfo where
310
  -- FIXME: Is there a simpler way to do it?
Agata Murawska's avatar
Agata Murawska committed
311
  rpcResultFill _ res =
312
313
    case res of
      J.JSObject res' ->
314
        let res'' = map (second J.readJSON) (J.fromJSObject res')
315
                        :: [(String, J.Result InstanceInfo)] in
316
317
318
319
        case sanitizeDictResults res'' of
          Left err -> Left err
          Right insts -> Right $ RpcResultAllInstancesInfo insts
      _ -> Left $ JsonDecodeError
Agata Murawska's avatar
Agata Murawska committed
320
           ("Expected JSObject, got " ++ show (pp_value res))
321

322
323
-- ** InstanceList

324
325
-- | InstanceList
-- Returns the list of running instances on the given nodes.
Iustin Pop's avatar
Iustin Pop committed
326
$(buildObject "RpcCallInstanceList" "rpcCallInstList"
327
328
  [ simpleField "hypervisors" [t| [Hypervisor] |] ])

Iustin Pop's avatar
Iustin Pop committed
329
$(buildObject "RpcResultInstanceList" "rpcResInstList"
330
  [ simpleField "instances" [t| [String] |] ])
331
332

instance RpcCall RpcCallInstanceList where
333
334
  rpcCallName _          = "instance_list"
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
335
  rpcCallAcceptOffline _ = False
336
  rpcCallData _ call     = J.encode [rpcCallInstListHypervisors call]
337

Agata Murawska's avatar
Agata Murawska committed
338
instance Rpc RpcCallInstanceList RpcResultInstanceList where
339
  rpcResultFill _ res = fromJSValueToRes res RpcResultInstanceList
340

341
342
-- ** NodeInfo

343
344
-- | NodeInfo
-- Return node information.
Iustin Pop's avatar
Iustin Pop committed
345
$(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo"
346
347
  [ simpleField "volume_groups" [t| [String] |]
  , simpleField "hypervisors" [t| [Hypervisor] |]
348
  , simpleField "exclusive_storage" [t| Map.Map String Bool |]
349
350
  ])

Iustin Pop's avatar
Iustin Pop committed
351
$(buildObject "VgInfo" "vgInfo"
352
  [ simpleField "name" [t| String |]
353
354
  , optionalField $ simpleField "vg_free" [t| Int |]
  , optionalField $ simpleField "vg_size" [t| Int |]
355
356
357
  ])

-- | We only provide common fields as described in hv_base.py.
Iustin Pop's avatar
Iustin Pop committed
358
$(buildObject "HvInfo" "hvInfo"
359
360
361
362
363
364
365
366
  [ 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
367
$(buildObject "RpcResultNodeInfo" "rpcResNodeInfo"
368
369
370
371
372
373
  [ simpleField "boot_id" [t| String |]
  , simpleField "vg_info" [t| [VgInfo] |]
  , simpleField "hv_info" [t| [HvInfo] |]
  ])

instance RpcCall RpcCallNodeInfo where
374
375
  rpcCallName _          = "node_info"
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
376
  rpcCallAcceptOffline _ = False
377
  rpcCallData n call     = J.encode
378
379
    ( rpcCallNodeInfoVolumeGroups call
    , rpcCallNodeInfoHypervisors call
380
381
382
    , fromMaybe (error $ "Programmer error: missing parameter for node named "
                         ++ nodeName n)
                $ Map.lookup (nodeName n) (rpcCallNodeInfoExclusiveStorage call)
383
    )
384

Agata Murawska's avatar
Agata Murawska committed
385
386
instance Rpc RpcCallNodeInfo RpcResultNodeInfo where
  rpcResultFill _ res =
387
    fromJSValueToRes res (\(b, vg, hv) -> RpcResultNodeInfo b vg hv)
388

389
390
-- ** Version

Agata Murawska's avatar
Agata Murawska committed
391
392
393
394
-- | Version
-- Query node version.
-- Note: We can't use THH as it does not know what to do with empty dict
data RpcCallVersion = RpcCallVersion {}
395
  deriving (Show, Eq)
Agata Murawska's avatar
Agata Murawska committed
396
397
398
399
400
401
402
403
404
405
406

instance J.JSON RpcCallVersion where
  showJSON _ = J.JSNull
  readJSON J.JSNull = return RpcCallVersion
  readJSON _ = fail "Unable to read RpcCallVersion"

$(buildObject "RpcResultVersion" "rpcResultVersion"
  [ simpleField "version" [t| Int |]
  ])

instance RpcCall RpcCallVersion where
407
408
  rpcCallName _          = "version"
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
Agata Murawska's avatar
Agata Murawska committed
409
  rpcCallAcceptOffline _ = True
Iustin Pop's avatar
Iustin Pop committed
410
  rpcCallData _          = J.encode
Agata Murawska's avatar
Agata Murawska committed
411

Agata Murawska's avatar
Agata Murawska committed
412
instance Rpc RpcCallVersion RpcResultVersion where
413
  rpcResultFill _ res = fromJSValueToRes res RpcResultVersion
Agata Murawska's avatar
Agata Murawska committed
414

415
416
-- ** StorageList

Agata Murawska's avatar
Agata Murawska committed
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
-- | 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
442
443
  rpcCallName _          = "storage_list"
  rpcCallTimeout _       = rpcTimeoutToRaw Normal
Agata Murawska's avatar
Agata Murawska committed
444
  rpcCallAcceptOffline _ = False
445
  rpcCallData _ call     = J.encode
Agata Murawska's avatar
Agata Murawska committed
446
447
448
449
450
451
452
453
454
    ( rpcCallStorageListSuName call
    , rpcCallStorageListSuArgs call
    , rpcCallStorageListName call
    , rpcCallStorageListFields call
    )

instance Rpc RpcCallStorageList RpcResultStorageList where
  rpcResultFill call res =
    let sfields = rpcCallStorageListFields call in
455
    fromJSValueToRes res (RpcResultStorageList . map (zip sfields))
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482

-- ** 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