Rpc.hs 10.8 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
33

{-| 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
  , RpcResult
  , Rpc
  , RpcError(..)
34
  , ERpcError
35
  , executeRpcCall
36
37
38
39
40
41
42

  , rpcCallName
  , rpcCallTimeout
  , rpcCallData
  , rpcCallAcceptOffline

  , rpcResultFill
43
44
45
46
47

  , InstanceInfo(..)
  , RpcCallAllInstancesInfo(..)
  , RpcResultAllInstancesInfo(..)

48
49
50
  , RpcCallInstanceList(..)
  , RpcResultInstanceList(..)

51
52
53
54
55
  , HvInfo(..)
  , VgInfo(..)
  , RpcCallNodeInfo(..)
  , RpcResultNodeInfo(..)

56
  , rpcTimeoutFromRaw -- FIXME: Not used anywhere
57
58
  ) where

59
import Control.Arrow (second)
60
import qualified Text.JSON as J
61
import Text.JSON.Pretty (pp_value)
62
import Text.JSON (makeObj)
63

64
65
#ifndef NO_CURL
import Network.Curl
Agata Murawska's avatar
Agata Murawska committed
66
import qualified Ganeti.Path as P
67
68
69
#endif

import qualified Ganeti.Constants as C
70
import Ganeti.Objects
71
import Ganeti.THH
72
73
import Ganeti.Compat
import Ganeti.JSON
74
75
76
77
78

#ifndef NO_CURL
-- | The curl options used for RPC.
curlOpts :: [CurlOption]
curlOpts = [ CurlFollowLocation False
Agata Murawska's avatar
Agata Murawska committed
79
           , CurlCAInfo P.nodedCertFile
80
81
82
           , CurlSSLVerifyHost 0
           , CurlSSLVerifyPeer True
           , CurlSSLCertType "PEM"
Agata Murawska's avatar
Agata Murawska committed
83
           , CurlSSLCert P.nodedCertFile
84
           , CurlSSLKeyType "PEM"
Agata Murawska's avatar
Agata Murawska committed
85
           , CurlSSLKey P.nodedCertFile
86
87
88
           , CurlConnectTimeout (fromIntegral C.rpcConnectTimeout)
           ]
#endif
89
90
91
92
93
94

-- | Data type for RPC error reporting.
data RpcError
  = CurlDisabledError
  | CurlLayerError Node String
  | JsonDecodeError String
Agata Murawska's avatar
Agata Murawska committed
95
  | RpcResultError String
96
97
98
99
100
101
102
  | OfflineNodeError Node
  deriving Eq

instance Show RpcError where
  show CurlDisabledError =
    "RPC/curl backend disabled at compile time"
  show (CurlLayerError node code) =
Agata Murawska's avatar
Agata Murawska committed
103
    "Curl error for " ++ nodeName node ++ ", " ++ code
104
  show (JsonDecodeError msg) =
Agata Murawska's avatar
Agata Murawska committed
105
106
107
    "Error while decoding JSON from HTTP response: " ++ msg
  show (RpcResultError msg) =
    "Error reponse received from RPC server: " ++ msg
108
109
110
  show (OfflineNodeError node) =
    "Node " ++ nodeName node ++ " is marked as offline"

111
112
type ERpcError = Either RpcError

113
114
115
116
117
118
119
120
121
122
-- | 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 )
  ])

123
124
125
126
127
128
129
130
131
132
133
134
135
136
-- | 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

-- | A generic class for RPC results with default implementation.
class (J.JSON a) => RpcResult a where
  -- | Create a result based on the received HTTP response.
137
  rpcResultFill :: (Monad m) => J.JSValue -> m (ERpcError a)
138
139
140
141

-- | Generic class that ensures matching RPC call with its respective
-- result.
class (RpcCall a, RpcResult b) => Rpc a b | a -> b
142
143
144
145
146
147
148
149
150
151

-- | 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.
152
153
executeHttpRequest :: Node -> ERpcError HttpClientRequest
                   -> IO (ERpcError String)
154
155
156
157
158
159
160
161
162
163
164
165

executeHttpRequest _ (Left rpc_err) = return $ Left rpc_err
#ifdef NO_CURL
executeHttpRequest _ _ = return $ Left CurlDisabledError
#else
executeHttpRequest node (Right request) = do
  let reqOpts = [ CurlTimeout (fromIntegral $ requestTimeout request)
                , CurlPostFields [requestPostData request]
                ]
      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
166
167
168
  return $ case code of
             CurlOK -> Right body
             _ -> Left $ CurlLayerError node (show code)
169
170
171
172
173
174
175
#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
176
177
      path_prefix = "https://" ++ node_ip ++ ":" ++ show port
  in path_prefix ++ "/" ++ rpcCallName call
178
179
180
181

-- | Create HTTP request for a given node provided it is online,
-- otherwise create empty response.
prepareHttpRequest ::  (RpcCall a) => Node -> a
182
                   -> ERpcError HttpClientRequest
183
prepareHttpRequest node call
Iustin Pop's avatar
Iustin Pop committed
184
185
186
187
188
  | rpcCallAcceptOffline call || not (nodeOffline node) =
      Right HttpClientRequest { requestTimeout = rpcCallTimeout call
                              , requestUrl = prepareUrl node call
                              , requestPostData = rpcCallData node call
                              }
189
190
  | otherwise = Left $ OfflineNodeError node

191
192
193
194
195
196
197
198
199
200
201
-- | Parse a result based on the received HTTP response.
rpcResultParse :: (Monad m, RpcResult a) => String -> m (ERpcError a)
rpcResultParse res = do
  res' <- fromJResult "Reading JSON response" $ J.decode res
  case res' of
    (True, res'') ->
       rpcResultFill res''
    (False, jerr) -> case jerr of
       J.JSString msg -> return . Left $ RpcResultError (J.fromJSString msg)
       _ -> (return . Left) . JsonDecodeError $ show (pp_value jerr)

202
-- | Parse the response or propagate the error.
203
204
parseHttpResponse :: (Monad m, RpcResult a) => ERpcError String
                  -> m (ERpcError a)
205
parseHttpResponse (Left err) = return $ Left err
206
parseHttpResponse (Right response) = rpcResultParse response
207
208

-- | Execute RPC call for a sigle node.
209
executeSingleRpcCall :: (Rpc a b) => Node -> a -> IO (Node, ERpcError b)
210
211
212
213
214
215
216
executeSingleRpcCall node call = do
  let request = prepareHttpRequest node call
  response <- executeHttpRequest node request
  result <- parseHttpResponse response
  return (node, result)

-- | Execute RPC call for many nodes in parallel.
217
executeRpcCall :: (Rpc a b) => [Node] -> a -> IO [(Node, ERpcError b)]
218
219
220
executeRpcCall nodes call =
  sequence $ parMap rwhnf (uncurry executeSingleRpcCall)
               (zip nodes $ repeat call)
221

222
223
224
225
226
227
228
229
230
-- | Helper function that is used to read dictionaries of values.
sanitizeDictResults :: [(String, J.Result a)] -> ERpcError [(String, a)]
sanitizeDictResults [] = Right []
sanitizeDictResults ((_, J.Error err):_) = Left $ JsonDecodeError err
sanitizeDictResults ((name, J.Ok val):xs) =
  case sanitizeDictResults xs of
    Left err -> Left err
    Right res' -> Right $ (name, val):res'

231
232
233
-- * RPC calls and results

-- | AllInstancesInfo
234
--   Returns information about all running instances on the given nodes.
Iustin Pop's avatar
Iustin Pop committed
235
$(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo"
236
237
  [ simpleField "hypervisors" [t| [Hypervisor] |] ])

Iustin Pop's avatar
Iustin Pop committed
238
$(buildObject "InstanceInfo" "instInfo"
239
240
  [ simpleField "memory" [t| Int|]
  , simpleField "state"  [t| String |] -- It depends on hypervisor :(
241
242
243
244
  , simpleField "vcpus"  [t| Int |]
  , simpleField "time"   [t| Int |]
  ])

Iustin Pop's avatar
Iustin Pop committed
245
$(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo"
246
  [ simpleField "instances" [t| [(String, InstanceInfo)] |] ])
247
248
249
250
251

instance RpcCall RpcCallAllInstancesInfo where
  rpcCallName _ = "all_instances_info"
  rpcCallTimeout _ = rpcTimeoutToRaw Urgent
  rpcCallAcceptOffline _ = False
252
253
254
255
256
257
258
259
260
261
262
263
264
265
  rpcCallData _ call = J.encode [rpcCallAllInstInfoHypervisors call]

instance RpcResult RpcResultAllInstancesInfo where
  -- FIXME: Is there a simpler way to do it?
  rpcResultFill res =
    return $ case res of
      J.JSObject res' -> do
        let res'' = map (second J.readJSON) (J.fromJSObject res')
                        :: [(String, J.Result InstanceInfo)]
        case sanitizeDictResults res'' of
          Left err -> Left err
          Right insts -> Right $ RpcResultAllInstancesInfo insts
      _ -> Left $ JsonDecodeError
           ("Expected JSObject, got " ++ show res)
266
267

instance Rpc RpcCallAllInstancesInfo RpcResultAllInstancesInfo
268
269
270

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

Iustin Pop's avatar
Iustin Pop committed
274
$(buildObject "RpcResultInstanceList" "rpcResInstList"
275
  [ simpleField "instances" [t| [String] |] ])
276
277
278
279
280

instance RpcCall RpcCallInstanceList where
  rpcCallName _ = "instance_list"
  rpcCallTimeout _ = rpcTimeoutToRaw Urgent
  rpcCallAcceptOffline _ = False
281
  rpcCallData _ call = J.encode [rpcCallInstListHypervisors call]
282

283
284
285
286
287
instance RpcResult RpcResultInstanceList where
  rpcResultFill res =
    return $ case J.readJSON res of
      J.Error err -> Left $ JsonDecodeError err
      J.Ok insts -> Right $ RpcResultInstanceList insts
288
289

instance Rpc RpcCallInstanceList RpcResultInstanceList
290
291
292

-- | NodeInfo
-- Return node information.
Iustin Pop's avatar
Iustin Pop committed
293
$(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo"
294
295
  [ simpleField "volume_groups" [t| [String] |]
  , simpleField "hypervisors" [t| [Hypervisor] |]
296
297
  ])

Iustin Pop's avatar
Iustin Pop committed
298
$(buildObject "VgInfo" "vgInfo"
299
  [ simpleField "name" [t| String |]
300
301
  , optionalField $ simpleField "vg_free" [t| Int |]
  , optionalField $ simpleField "vg_size" [t| Int |]
302
303
304
  ])

-- | We only provide common fields as described in hv_base.py.
Iustin Pop's avatar
Iustin Pop committed
305
$(buildObject "HvInfo" "hvInfo"
306
307
308
309
310
311
312
313
  [ 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
314
$(buildObject "RpcResultNodeInfo" "rpcResNodeInfo"
315
316
317
318
319
320
321
322
323
  [ simpleField "boot_id" [t| String |]
  , simpleField "vg_info" [t| [VgInfo] |]
  , simpleField "hv_info" [t| [HvInfo] |]
  ])

instance RpcCall RpcCallNodeInfo where
  rpcCallName _ = "node_info"
  rpcCallTimeout _ = rpcTimeoutToRaw Urgent
  rpcCallAcceptOffline _ = False
324
325
326
327
328
329
330
331
332
333
  rpcCallData _ call = J.encode ( rpcCallNodeInfoVolumeGroups call
                                , rpcCallNodeInfoHypervisors call
                                )

instance RpcResult RpcResultNodeInfo where
  rpcResultFill res =
    return $ case J.readJSON res of
      J.Error err -> Left $ JsonDecodeError err
      J.Ok (boot_id, vg_info, hv_info) ->
          Right $ RpcResultNodeInfo boot_id vg_info hv_info
334
335

instance Rpc RpcCallNodeInfo RpcResultNodeInfo