Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / Rpc.hs @ 22381768

History | View | Annotate | Download (15.4 kB)

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

    
4
{-| Implementation of the RPC client.
5

    
6
-}
7

    
8
{-
9

    
10
Copyright (C) 2012 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

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

    
42
  , rpcResultFill
43

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

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

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

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

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

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

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

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

    
73
import Control.Arrow (second)
74
import qualified Text.JSON as J
75
import Text.JSON.Pretty (pp_value)
76

    
77
#ifndef NO_CURL
78
import Network.Curl
79
import qualified Ganeti.Path as P
80
#endif
81

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

    
88
-- * Base RPC functionality and types
89

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

    
102
-- | Data type for RPC error reporting.
103
data RpcError
104
  = CurlDisabledError
105
  | CurlLayerError Node String
106
  | JsonDecodeError String
107
  | RpcResultError String
108
  | OfflineNodeError Node
109
  deriving (Show, Eq)
110

    
111
-- | Provide explanation to RPC errors.
112
explainRpcError :: RpcError -> String
113
explainRpcError CurlDisabledError =
114
    "RPC/curl backend disabled at compile time"
115
explainRpcError (CurlLayerError node code) =
116
    "Curl error for " ++ nodeName node ++ ", " ++ code
117
explainRpcError (JsonDecodeError msg) =
118
    "Error while decoding JSON from HTTP response: " ++ msg
119
explainRpcError (RpcResultError msg) =
120
    "Error reponse received from RPC server: " ++ msg
121
explainRpcError (OfflineNodeError node) =
122
    "Node " ++ nodeName node ++ " is marked as offline"
123

    
124
type ERpcError = Either RpcError
125

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

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

    
147
-- | Generic class that ensures matching RPC call with its respective
148
-- result.
149
class (RpcCall a, J.JSON b) => Rpc a b  | a -> b, b -> a where
150
  -- | Create a result based on the received HTTP response.
151
  rpcResultFill :: a -> J.JSValue -> ERpcError b
152

    
153
-- | Http Request definition.
154
data HttpClientRequest = HttpClientRequest
155
  { requestTimeout :: Int
156
  , requestUrl :: String
157
  , requestPostData :: String
158
  }
159

    
160
-- | Execute the request and return the result as a plain String. When
161
-- curl reports an error, we propagate it.
162
executeHttpRequest :: Node -> ERpcError HttpClientRequest
163
                   -> IO (ERpcError String)
164

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

    
185
-- | Prepare url for the HTTP request.
186
prepareUrl :: (RpcCall a) => Node -> a -> String
187
prepareUrl node call =
188
  let node_ip = nodePrimaryIp node
189
      port = snd C.daemonsPortsGanetiNoded
190
      path_prefix = "https://" ++ node_ip ++ ":" ++ show port
191
  in path_prefix ++ "/" ++ rpcCallName call
192

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

    
205
-- | Parse a result based on the received HTTP response.
206
parseHttpResponse :: (Rpc a b) => a -> ERpcError String -> ERpcError b
207
parseHttpResponse _ (Left err) = Left err
208
parseHttpResponse call (Right res) =
209
  case J.decode res of
210
    J.Error val -> Left $ JsonDecodeError val
211
    J.Ok (True, res'') -> rpcResultFill call res''
212
    J.Ok (False, jerr) -> case jerr of
213
       J.JSString msg -> Left $ RpcResultError (J.fromJSString msg)
214
       _ -> Left . JsonDecodeError $ show (pp_value jerr)
215

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

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

    
230
-- | Helper function that is used to read dictionaries of values.
231
sanitizeDictResults :: [(String, J.Result a)] -> ERpcError [(String, a)]
232
sanitizeDictResults =
233
  foldr sanitize1 (Right [])
234
  where
235
    sanitize1 _ (Left e) = Left e
236
    sanitize1 (_, J.Error e) _ = Left $ JsonDecodeError e
237
    sanitize1 (name, J.Ok v) (Right res) = Right $ (name, v) : res
238

    
239
-- | Helper function to tranform JSON Result to Either RpcError b.
240
-- Note: For now we really only use it for b s.t. Rpc c b for some c
241
fromJResultToRes :: J.Result a -> (a -> b) -> ERpcError b
242
fromJResultToRes (J.Error v) _ = Left $ JsonDecodeError v
243
fromJResultToRes (J.Ok v) f = Right $ f v
244

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

    
249
-- * RPC calls and results
250

    
251
-- ** Instance info
252

    
253
-- | InstanceInfo
254
--   Returns information about a single instance.
255

    
256
$(buildObject "RpcCallInstanceInfo" "rpcCallInstInfo"
257
  [ simpleField "instance" [t| String |]
258
  , simpleField "hname" [t| Hypervisor |]
259
  ])
260

    
261
$(buildObject "InstanceInfo" "instInfo"
262
  [ simpleField "memory" [t| Int|]
263
  , simpleField "state"  [t| String |] -- It depends on hypervisor :(
264
  , simpleField "vcpus"  [t| Int |]
265
  , simpleField "time"   [t| Int |]
266
  ])
267

    
268
-- This is optional here because the result may be empty if instance is
269
-- not on a node - and this is not considered an error.
270
$(buildObject "RpcResultInstanceInfo" "rpcResInstInfo"
271
  [ optionalField $ simpleField "inst_info" [t| InstanceInfo |]])
272

    
273
instance RpcCall RpcCallInstanceInfo where
274
  rpcCallName _          = "instance_info"
275
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
276
  rpcCallAcceptOffline _ = False
277
  rpcCallData _ call     = J.encode
278
    ( rpcCallInstInfoInstance call
279
    , rpcCallInstInfoHname call
280
    )
281

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

    
292
-- ** AllInstancesInfo
293

    
294
-- | AllInstancesInfo
295
--   Returns information about all running instances on the given nodes
296
$(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo"
297
  [ simpleField "hypervisors" [t| [Hypervisor] |] ])
298

    
299
$(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo"
300
  [ simpleField "instances" [t| [(String, InstanceInfo)] |] ])
301

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

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

    
321
-- ** InstanceList
322

    
323
-- | InstanceList
324
-- Returns the list of running instances on the given nodes.
325
$(buildObject "RpcCallInstanceList" "rpcCallInstList"
326
  [ simpleField "hypervisors" [t| [Hypervisor] |] ])
327

    
328
$(buildObject "RpcResultInstanceList" "rpcResInstList"
329
  [ simpleField "instances" [t| [String] |] ])
330

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

    
337
instance Rpc RpcCallInstanceList RpcResultInstanceList where
338
  rpcResultFill _ res = fromJSValueToRes res RpcResultInstanceList
339

    
340
-- ** NodeInfo
341

    
342
-- | NodeInfo
343
-- Return node information.
344
$(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo"
345
  [ simpleField "volume_groups" [t| [String] |]
346
  , simpleField "hypervisors" [t| [Hypervisor] |]
347
  ])
348

    
349
$(buildObject "VgInfo" "vgInfo"
350
  [ simpleField "name" [t| String |]
351
  , optionalField $ simpleField "vg_free" [t| Int |]
352
  , optionalField $ simpleField "vg_size" [t| Int |]
353
  ])
354

    
355
-- | We only provide common fields as described in hv_base.py.
356
$(buildObject "HvInfo" "hvInfo"
357
  [ simpleField "memory_total" [t| Int |]
358
  , simpleField "memory_free" [t| Int |]
359
  , simpleField "memory_dom0" [t| Int |]
360
  , simpleField "cpu_total" [t| Int |]
361
  , simpleField "cpu_nodes" [t| Int |]
362
  , simpleField "cpu_sockets" [t| Int |]
363
  ])
364

    
365
$(buildObject "RpcResultNodeInfo" "rpcResNodeInfo"
366
  [ simpleField "boot_id" [t| String |]
367
  , simpleField "vg_info" [t| [VgInfo] |]
368
  , simpleField "hv_info" [t| [HvInfo] |]
369
  ])
370

    
371
instance RpcCall RpcCallNodeInfo where
372
  rpcCallName _          = "node_info"
373
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
374
  rpcCallAcceptOffline _ = False
375
  rpcCallData _ call     = J.encode
376
    ( rpcCallNodeInfoVolumeGroups call
377
    , rpcCallNodeInfoHypervisors call
378
    )
379

    
380
instance Rpc RpcCallNodeInfo RpcResultNodeInfo where
381
  rpcResultFill _ res =
382
    fromJSValueToRes res (\(b, vg, hv) -> RpcResultNodeInfo b vg hv)
383

    
384
-- ** Version
385

    
386
-- | Version
387
-- Query node version.
388
-- Note: We can't use THH as it does not know what to do with empty dict
389
data RpcCallVersion = RpcCallVersion {}
390
  deriving (Show, Read, Eq)
391

    
392
instance J.JSON RpcCallVersion where
393
  showJSON _ = J.JSNull
394
  readJSON J.JSNull = return RpcCallVersion
395
  readJSON _ = fail "Unable to read RpcCallVersion"
396

    
397
$(buildObject "RpcResultVersion" "rpcResultVersion"
398
  [ simpleField "version" [t| Int |]
399
  ])
400

    
401
instance RpcCall RpcCallVersion where
402
  rpcCallName _          = "version"
403
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
404
  rpcCallAcceptOffline _ = True
405
  rpcCallData _          = J.encode
406

    
407
instance Rpc RpcCallVersion RpcResultVersion where
408
  rpcResultFill _ res = fromJSValueToRes res RpcResultVersion
409

    
410
-- ** StorageList
411

    
412
-- | StorageList
413
-- Get list of storage units.
414
-- FIXME: This may be moved to Objects
415
$(declareSADT "StorageType"
416
  [ ( "STLvmPv", 'C.stLvmPv )
417
  , ( "STFile",  'C.stFile )
418
  , ( "STLvmVg", 'C.stLvmVg )
419
  ])
420
$(makeJSONInstance ''StorageType)
421

    
422
-- FIXME: This may be moved to Objects
423
$(declareSADT "StorageField"
424
  [ ( "SFUsed",        'C.sfUsed)
425
  , ( "SFName",        'C.sfName)
426
  , ( "SFAllocatable", 'C.sfAllocatable)
427
  , ( "SFFree",        'C.sfFree)
428
  , ( "SFSize",        'C.sfSize)
429
  ])
430
$(makeJSONInstance ''StorageField)
431

    
432
$(buildObject "RpcCallStorageList" "rpcCallStorageList"
433
  [ simpleField "su_name" [t| StorageType |]
434
  , simpleField "su_args" [t| [String] |]
435
  , simpleField "name"    [t| String |]
436
  , simpleField "fields"  [t| [StorageField] |]
437
  ])
438

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

    
444
instance RpcCall RpcCallStorageList where
445
  rpcCallName _          = "storage_list"
446
  rpcCallTimeout _       = rpcTimeoutToRaw Normal
447
  rpcCallAcceptOffline _ = False
448
  rpcCallData _ call     = J.encode
449
    ( rpcCallStorageListSuName call
450
    , rpcCallStorageListSuArgs call
451
    , rpcCallStorageListName call
452
    , rpcCallStorageListFields call
453
    )
454

    
455
instance Rpc RpcCallStorageList RpcResultStorageList where
456
  rpcResultFill call res =
457
    let sfields = rpcCallStorageListFields call in
458
    fromJSValueToRes res (RpcResultStorageList . map (zip sfields))
459

    
460
-- ** TestDelay
461

    
462

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

    
468
-- | Result definition for test delay.
469
data RpcResultTestDelay = RpcResultTestDelay
470
                          deriving Show
471

    
472
-- | Custom JSON instance for null result.
473
instance J.JSON RpcResultTestDelay where
474
  showJSON _        = J.JSNull
475
  readJSON J.JSNull = return RpcResultTestDelay
476
  readJSON _        = fail "Unable to read RpcResultTestDelay"
477

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

    
484
instance Rpc RpcCallTestDelay RpcResultTestDelay where
485
  rpcResultFill _ res = fromJSValueToRes res id