Rpc.hs 9.08 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
59
  ) where

import qualified Text.JSON as J
60
import Text.JSON (makeObj)
61

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

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

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

-- | Data type for RPC error reporting.
data RpcError
  = CurlDisabledError
  | CurlLayerError Node String
  | JsonDecodeError String
Agata Murawska's avatar
Agata Murawska committed
93
  | RpcResultError String
94
95
96
97
98
99
100
  | 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
101
    "Curl error for " ++ nodeName node ++ ", " ++ code
102
  show (JsonDecodeError msg) =
Agata Murawska's avatar
Agata Murawska committed
103
104
105
    "Error while decoding JSON from HTTP response: " ++ msg
  show (RpcResultError msg) =
    "Error reponse received from RPC server: " ++ msg
106
107
108
  show (OfflineNodeError node) =
    "Node " ++ nodeName node ++ " is marked as offline"

109
110
111
type ERpcError = Either RpcError

rpcErrorJsonReport :: (Monad m) => J.Result a -> m (ERpcError a)
Iustin Pop's avatar
Iustin Pop committed
112
rpcErrorJsonReport (J.Error x) = return . Left $ JsonDecodeError x
113
114
rpcErrorJsonReport (J.Ok x) = return $ Right x

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

125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
-- | 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

  rpcCallData _ = J.encode

-- | 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.
141
  rpcResultFill :: (Monad m) => String -> m (ERpcError a)
142
143
144
145
146
147

  rpcResultFill res = rpcErrorJsonReport $  J.decode res

-- | Generic class that ensures matching RPC call with its respective
-- result.
class (RpcCall a, RpcResult b) => Rpc a b | a -> b
148
149
150
151
152
153
154
155
156
157

-- | 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.
158
159
executeHttpRequest :: Node -> ERpcError HttpClientRequest
                   -> IO (ERpcError String)
160
161
162
163
164
165
166
167
168
169
170
171

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
172
173
174
  return $ case code of
             CurlOK -> Right body
             _ -> Left $ CurlLayerError node (show code)
175
176
177
178
179
180
181
#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
182
183
      path_prefix = "https://" ++ node_ip ++ ":" ++ show port
  in path_prefix ++ "/" ++ rpcCallName call
184
185
186
187

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

-- | Parse the response or propagate the error.
198
199
parseHttpResponse :: (Monad m, RpcResult a) => ERpcError String
                  -> m (ERpcError a)
200
201
202
203
parseHttpResponse (Left err) = return $ Left err
parseHttpResponse (Right response) = rpcResultFill response

-- | Execute RPC call for a sigle node.
204
executeSingleRpcCall :: (Rpc a b) => Node -> a -> IO (Node, ERpcError b)
205
206
207
208
209
210
211
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.
212
executeRpcCall :: (Rpc a b) => [Node] -> a -> IO [(Node, ERpcError b)]
213
214
215
executeRpcCall nodes call =
  sequence $ parMap rwhnf (uncurry executeSingleRpcCall)
               (zip nodes $ repeat call)
216
217
218
219
220

-- * RPC calls and results

-- | AllInstancesInfo
--   Returns information about all instances on the given nodes
Iustin Pop's avatar
Iustin Pop committed
221
$(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo"
222
223
  [ simpleField "hypervisors" [t| [Hypervisor] |] ])

Iustin Pop's avatar
Iustin Pop committed
224
$(buildObject "InstanceInfo" "instInfo"
225
226
227
228
229
230
231
  [ simpleField "name"   [t| String |]
  , simpleField "memory" [t| Int|]
  , simpleField "state"  [t| AdminState |]
  , simpleField "vcpus"  [t| Int |]
  , simpleField "time"   [t| Int |]
  ])

Iustin Pop's avatar
Iustin Pop committed
232
$(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo"
233
234
235
236
237
238
239
240
241
242
  [ simpleField "instances" [t| [InstanceInfo] |] ])

instance RpcCall RpcCallAllInstancesInfo where
  rpcCallName _ = "all_instances_info"
  rpcCallTimeout _ = rpcTimeoutToRaw Urgent
  rpcCallAcceptOffline _ = False

instance RpcResult RpcResultAllInstancesInfo

instance Rpc RpcCallAllInstancesInfo RpcResultAllInstancesInfo
243
244
245

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

Iustin Pop's avatar
Iustin Pop committed
249
$(buildObject "RpcResultInstanceList" "rpcResInstList"
250
251
252
253
254
255
256
257
258
259
260
261
  [ simpleField "node"      [t| Node |]
  , simpleField "instances" [t| [String] |]
  ])

instance RpcCall RpcCallInstanceList where
  rpcCallName _ = "instance_list"
  rpcCallTimeout _ = rpcTimeoutToRaw Urgent
  rpcCallAcceptOffline _ = False

instance RpcResult RpcResultInstanceList

instance Rpc RpcCallInstanceList RpcResultInstanceList
262
263
264

-- | NodeInfo
-- Return node information.
Iustin Pop's avatar
Iustin Pop committed
265
$(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo"
266
267
268
269
  [ simpleField "hypervisors" [t| [Hypervisor] |]
  , simpleField "volume_groups" [t| [String] |]
  ])

Iustin Pop's avatar
Iustin Pop committed
270
$(buildObject "VgInfo" "vgInfo"
271
272
273
274
275
276
  [ simpleField "name" [t| String |]
  , simpleField "free" [t| Int |]
  , simpleField "size" [t| Int |]
  ])

-- | We only provide common fields as described in hv_base.py.
Iustin Pop's avatar
Iustin Pop committed
277
$(buildObject "HvInfo" "hvInfo"
278
279
280
281
282
283
284
285
  [ 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
286
$(buildObject "RpcResultNodeInfo" "rpcResNodeInfo"
287
288
289
290
291
292
293
294
295
296
297
298
299
  [ 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

instance RpcResult RpcResultNodeInfo

instance Rpc RpcCallNodeInfo RpcResultNodeInfo