code.grnet.gr Git - ganeti-local/blob - src/Ganeti/Rpc.hs

   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   , StorageField(..)
  63   , RpcCallStorageList(..)
  64   , RpcResultStorageList(..)
  65
  66   , RpcCallTestDelay(..)
  67   , RpcResultTestDelay(..)
  68
  69   , rpcTimeoutFromRaw -- FIXME: Not used anywhere
  70   ) where
  71
  72 import Control.Arrow (second)
  73 import qualified Data.Map as Map
  74 import Data.Maybe (fromMaybe)
  75 import qualified Text.JSON as J
  76 import Text.JSON.Pretty (pp_value)
  77
  78 #ifndef NO_CURL
  79 import Network.Curl
  80 import qualified Ganeti.Path as P
  81 #endif
  82
  83 import qualified Ganeti.Constants as C
  84 import Ganeti.Objects
  85 import Ganeti.THH
  86 import Ganeti.Types
  87 import Ganeti.Compat
  88
  89 -- * Base RPC functionality and types
  90
  91 #ifndef NO_CURL
  92 -- | The curl options used for RPC.
  93 curlOpts :: [CurlOption]
  94 curlOpts = [ CurlFollowLocation False
  95            , CurlSSLVerifyHost 0
  96            , CurlSSLVerifyPeer True
  97            , CurlSSLCertType "PEM"
  98            , CurlSSLKeyType "PEM"
  99            , CurlConnectTimeout (fromIntegral C.rpcConnectTimeout)
 100            ]
 101 #endif
 102
 103 -- | Data type for RPC error reporting.
 104 data RpcError
 105   = CurlDisabledError
 106   | CurlLayerError Node String
 107   | JsonDecodeError String
 108   | RpcResultError String
 109   | OfflineNodeError Node
 110   deriving (Show, Eq)
 111
 112 -- | Provide explanation to RPC errors.
 113 explainRpcError :: RpcError -> String
 114 explainRpcError CurlDisabledError =
 115     "RPC/curl backend disabled at compile time"
 116 explainRpcError (CurlLayerError node code) =
 117     "Curl error for " ++ nodeName node ++ ", " ++ code
 118 explainRpcError (JsonDecodeError msg) =
 119     "Error while decoding JSON from HTTP response: " ++ msg
 120 explainRpcError (RpcResultError msg) =
 121     "Error reponse received from RPC server: " ++ msg
 122 explainRpcError (OfflineNodeError node) =
 123     "Node " ++ nodeName node ++ " is marked as offline"
 124
 125 type ERpcError = Either RpcError
 126
 127 -- | Basic timeouts for RPC calls.
 128 $(declareIADT "RpcTimeout"
 129   [ ( "Urgent",    'C.rpcTmoUrgent )
 130   , ( "Fast",      'C.rpcTmoFast )
 131   , ( "Normal",    'C.rpcTmoNormal )
 132   , ( "Slow",      'C.rpcTmoSlow )
 133   , ( "FourHours", 'C.rpcTmo4hrs )
 134   , ( "OneDay",    'C.rpcTmo1day )
 135   ])
 136
 137 -- | A generic class for RPC calls.
 138 class (J.JSON a) => RpcCall a where
 139   -- | Give the (Python) name of the procedure.
 140   rpcCallName :: a -> String
 141   -- | Calculate the timeout value for the call execution.
 142   rpcCallTimeout :: a -> Int
 143   -- | Prepare arguments of the call to be send as POST.
 144   rpcCallData :: Node -> a -> String
 145   -- | Whether we accept offline nodes when making a call.
 146   rpcCallAcceptOffline :: a -> Bool
 147
 148 -- | Generic class that ensures matching RPC call with its respective
 149 -- result.
 150 class (RpcCall a, J.JSON b) => Rpc a b  | a -> b, b -> a where
 151   -- | Create a result based on the received HTTP response.
 152   rpcResultFill :: a -> J.JSValue -> ERpcError b
 153
 154 -- | Http Request definition.
 155 data HttpClientRequest = HttpClientRequest
 156   { requestTimeout :: Int
 157   , requestUrl :: String
 158   , requestPostData :: String
 159   }
 160
 161 -- | Execute the request and return the result as a plain String. When
 162 -- curl reports an error, we propagate it.
 163 executeHttpRequest :: Node -> ERpcError HttpClientRequest
 164                    -> IO (ERpcError String)
 165
 166 executeHttpRequest _ (Left rpc_err) = return $ Left rpc_err
 167 #ifdef NO_CURL
 168 executeHttpRequest _ _ = return $ Left CurlDisabledError
 169 #else
 170 executeHttpRequest node (Right request) = do
 171   cert_file <- P.nodedCertFile
 172   let reqOpts = [ CurlTimeout (fromIntegral $ requestTimeout request)
 173                 , CurlPostFields [requestPostData request]
 174                 , CurlSSLCert cert_file
 175                 , CurlSSLKey cert_file
 176                 , CurlCAInfo cert_file
 177                 ]
 178       url = requestUrl request
 179   -- FIXME: This is very similar to getUrl in Htools/Rapi.hs
 180   (code, !body) <- curlGetString url $ curlOpts ++ reqOpts
 181   return $ case code of
 182              CurlOK -> Right body
 183              _ -> Left $ CurlLayerError node (show code)
 184 #endif
 185
 186 -- | Prepare url for the HTTP request.
 187 prepareUrl :: (RpcCall a) => Node -> a -> String
 188 prepareUrl node call =
 189   let node_ip = nodePrimaryIp node
 190       port = snd C.daemonsPortsGanetiNoded
 191       path_prefix = "https://" ++ node_ip ++ ":" ++ show port
 192   in path_prefix ++ "/" ++ rpcCallName call
 193
 194 -- | Create HTTP request for a given node provided it is online,
 195 -- otherwise create empty response.
 196 prepareHttpRequest ::  (RpcCall a) => Node -> a
 197                    -> ERpcError HttpClientRequest
 198 prepareHttpRequest node call
 199   | rpcCallAcceptOffline call || not (nodeOffline node) =
 200       Right HttpClientRequest { requestTimeout = rpcCallTimeout call
 201                               , requestUrl = prepareUrl node call
 202                               , requestPostData = rpcCallData node call
 203                               }
 204   | otherwise = Left $ OfflineNodeError node
 205
 206 -- | Parse a result based on the received HTTP response.
 207 parseHttpResponse :: (Rpc a b) => a -> ERpcError String -> ERpcError b
 208 parseHttpResponse _ (Left err) = Left err
 209 parseHttpResponse call (Right res) =
 210   case J.decode res of
 211     J.Error val -> Left $ JsonDecodeError val
 212     J.Ok (True, res'') -> rpcResultFill call res''
 213     J.Ok (False, jerr) -> case jerr of
 214        J.JSString msg -> Left $ RpcResultError (J.fromJSString msg)
 215        _ -> 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 executeSingleRpcCall node call = do
 220   let request = prepareHttpRequest node call
 221   response <- executeHttpRequest node request
 222   let result = parseHttpResponse call response
 223   return (node, result)
 224
 225 -- | Execute RPC call for many nodes in parallel.
 226 executeRpcCall :: (Rpc a b) => [Node] -> a -> IO [(Node, ERpcError b)]
 227 executeRpcCall nodes call =
 228   sequence $ parMap rwhnf (uncurry executeSingleRpcCall)
 229                (zip nodes $ repeat call)
 230
 231 -- | Helper function that is used to read dictionaries of values.
 232 sanitizeDictResults :: [(String, J.Result a)] -> ERpcError [(String, a)]
 233 sanitizeDictResults =
 234   foldr sanitize1 (Right [])
 235   where
 236     sanitize1 _ (Left e) = Left e
 237     sanitize1 (_, J.Error e) _ = Left $ JsonDecodeError e
 238     sanitize1 (name, J.Ok v) (Right res) = Right $ (name, v) : res
 239
 240 -- | Helper function to tranform JSON Result to Either RpcError b.
 241 -- Note: For now we really only use it for b s.t. Rpc c b for some c
 242 fromJResultToRes :: J.Result a -> (a -> b) -> ERpcError b
 243 fromJResultToRes (J.Error v) _ = Left $ JsonDecodeError v
 244 fromJResultToRes (J.Ok v) f = Right $ f v
 245
 246 -- | Helper function transforming JSValue to Rpc result type.
 247 fromJSValueToRes :: (J.JSON a) => J.JSValue -> (a -> b) -> ERpcError b
 248 fromJSValueToRes val = fromJResultToRes (J.readJSON val)
 249
 250 -- * RPC calls and results
 251
 252 -- ** Instance info
 253
 254 -- | InstanceInfo
 255 --   Returns information about a single instance.
 256
 257 $(buildObject "RpcCallInstanceInfo" "rpcCallInstInfo"
 258   [ simpleField "instance" [t| String |]
 259   , simpleField "hname" [t| Hypervisor |]
 260   ])
 261
 262 $(buildObject "InstanceInfo" "instInfo"
 263   [ simpleField "memory" [t| Int|]
 264   , simpleField "state"  [t| String |] -- It depends on hypervisor :(
 265   , simpleField "vcpus"  [t| Int |]
 266   , simpleField "time"   [t| Int |]
 267   ])
 268
 269 -- This is optional here because the result may be empty if instance is
 270 -- not on a node - and this is not considered an error.
 271 $(buildObject "RpcResultInstanceInfo" "rpcResInstInfo"
 272   [ optionalField $ simpleField "inst_info" [t| InstanceInfo |]])
 273
 274 instance RpcCall RpcCallInstanceInfo where
 275   rpcCallName _          = "instance_info"
 276   rpcCallTimeout _       = rpcTimeoutToRaw Urgent
 277   rpcCallAcceptOffline _ = False
 278   rpcCallData _ call     = J.encode
 279     ( rpcCallInstInfoInstance call
 280     , rpcCallInstInfoHname call
 281     )
 282
 283 instance Rpc RpcCallInstanceInfo RpcResultInstanceInfo where
 284   rpcResultFill _ res =
 285     case res of
 286       J.JSObject res' ->
 287         case J.fromJSObject res' of
 288           [] -> Right $ RpcResultInstanceInfo Nothing
 289           _ -> fromJSValueToRes res (RpcResultInstanceInfo . Just)
 290       _ -> Left $ JsonDecodeError
 291            ("Expected JSObject, got " ++ show (pp_value res))
 292
 293 -- ** AllInstancesInfo
 294
 295 -- | AllInstancesInfo
 296 --   Returns information about all running instances on the given nodes
 297 $(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo"
 298   [ simpleField "hypervisors" [t| [Hypervisor] |] ])
 299
 300 $(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo"
 301   [ simpleField "instances" [t| [(String, InstanceInfo)] |] ])
 302
 303 instance RpcCall RpcCallAllInstancesInfo where
 304   rpcCallName _          = "all_instances_info"
 305   rpcCallTimeout _       = rpcTimeoutToRaw Urgent
 306   rpcCallAcceptOffline _ = False
 307   rpcCallData _ call     = J.encode [rpcCallAllInstInfoHypervisors call]
 308
 309 instance Rpc RpcCallAllInstancesInfo RpcResultAllInstancesInfo where
 310   -- FIXME: Is there a simpler way to do it?
 311   rpcResultFill _ res =
 312     case res of
 313       J.JSObject res' ->
 314         let res'' = map (second J.readJSON) (J.fromJSObject res')
 315                         :: [(String, J.Result InstanceInfo)] in
 316         case sanitizeDictResults res'' of
 317           Left err -> Left err
 318           Right insts -> Right $ RpcResultAllInstancesInfo insts
 319       _ -> Left $ JsonDecodeError
 320            ("Expected JSObject, got " ++ show (pp_value res))
 321
 322 -- ** InstanceList
 323
 324 -- | InstanceList
 325 -- Returns the list of running instances on the given nodes.
 326 $(buildObject "RpcCallInstanceList" "rpcCallInstList"
 327   [ simpleField "hypervisors" [t| [Hypervisor] |] ])
 328
 329 $(buildObject "RpcResultInstanceList" "rpcResInstList"
 330   [ simpleField "instances" [t| [String] |] ])
 331
 332 instance RpcCall RpcCallInstanceList where
 333   rpcCallName _          = "instance_list"
 334   rpcCallTimeout _       = rpcTimeoutToRaw Urgent
 335   rpcCallAcceptOffline _ = False
 336   rpcCallData _ call     = J.encode [rpcCallInstListHypervisors call]
 337
 338 instance Rpc RpcCallInstanceList RpcResultInstanceList where
 339   rpcResultFill _ res = fromJSValueToRes res RpcResultInstanceList
 340
 341 -- ** NodeInfo
 342
 343 -- | NodeInfo
 344 -- Return node information.
 345 $(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo"
 346   [ simpleField "volume_groups" [t| [String] |]
 347   , simpleField "hypervisors" [t| [Hypervisor] |]
 348   , simpleField "exclusive_storage" [t| Map.Map String Bool |]
 349   ])
 350
 351 $(buildObject "VgInfo" "vgInfo"
 352   [ simpleField "name" [t| String |]
 353   , optionalField $ simpleField "vg_free" [t| Int |]
 354   , optionalField $ simpleField "vg_size" [t| Int |]
 355   ])
 356
 357 -- | We only provide common fields as described in hv_base.py.
 358 $(buildObject "HvInfo" "hvInfo"
 359   [ simpleField "memory_total" [t| Int |]
 360   , simpleField "memory_free" [t| Int |]
 361   , simpleField "memory_dom0" [t| Int |]
 362   , simpleField "cpu_total" [t| Int |]
 363   , simpleField "cpu_nodes" [t| Int |]
 364   , simpleField "cpu_sockets" [t| Int |]
 365   ])
 366
 367 $(buildObject "RpcResultNodeInfo" "rpcResNodeInfo"
 368   [ simpleField "boot_id" [t| String |]
 369   , simpleField "vg_info" [t| [VgInfo] |]
 370   , simpleField "hv_info" [t| [HvInfo] |]
 371   ])
 372
 373 instance RpcCall RpcCallNodeInfo where
 374   rpcCallName _          = "node_info"
 375   rpcCallTimeout _       = rpcTimeoutToRaw Urgent
 376   rpcCallAcceptOffline _ = False
 377   rpcCallData n call     = J.encode
 378     ( rpcCallNodeInfoVolumeGroups call
 379     , rpcCallNodeInfoHypervisors call
 380     , fromMaybe (error $ "Programmer error: missing parameter for node named "
 381                          ++ nodeName n)
 382                 $ Map.lookup (nodeName n) (rpcCallNodeInfoExclusiveStorage call)
 383     )
 384
 385 instance Rpc RpcCallNodeInfo RpcResultNodeInfo where
 386   rpcResultFill _ res =
 387     fromJSValueToRes res (\(b, vg, hv) -> RpcResultNodeInfo b vg hv)
 388
 389 -- ** Version
 390
 391 -- | Version
 392 -- Query node version.
 393 -- Note: We can't use THH as it does not know what to do with empty dict
 394 data RpcCallVersion = RpcCallVersion {}
 395   deriving (Show, Eq)
 396
 397 instance J.JSON RpcCallVersion where
 398   showJSON _ = J.JSNull
 399   readJSON J.JSNull = return RpcCallVersion
 400   readJSON _ = fail "Unable to read RpcCallVersion"
 401
 402 $(buildObject "RpcResultVersion" "rpcResultVersion"
 403   [ simpleField "version" [t| Int |]
 404   ])
 405
 406 instance RpcCall RpcCallVersion where
 407   rpcCallName _          = "version"
 408   rpcCallTimeout _       = rpcTimeoutToRaw Urgent
 409   rpcCallAcceptOffline _ = True
 410   rpcCallData _          = J.encode
 411
 412 instance Rpc RpcCallVersion RpcResultVersion where
 413   rpcResultFill _ res = fromJSValueToRes res RpcResultVersion
 414
 415 -- ** StorageList
 416
 417 -- | StorageList
 418
 419 -- FIXME: This may be moved to Objects
 420 $(declareSADT "StorageField"
 421   [ ( "SFUsed",        'C.sfUsed)
 422   , ( "SFName",        'C.sfName)
 423   , ( "SFAllocatable", 'C.sfAllocatable)
 424   , ( "SFFree",        'C.sfFree)
 425   , ( "SFSize",        'C.sfSize)
 426   ])
 427 $(makeJSONInstance ''StorageField)
 428
 429 $(buildObject "RpcCallStorageList" "rpcCallStorageList"
 430   [ simpleField "su_name" [t| StorageType |]
 431   , simpleField "su_args" [t| [String] |]
 432   , simpleField "name"    [t| String |]
 433   , simpleField "fields"  [t| [StorageField] |]
 434   ])
 435
 436 -- FIXME: The resulting JSValues should have types appropriate for their
 437 -- StorageField value: Used -> Bool, Name -> String etc
 438 $(buildObject "RpcResultStorageList" "rpcResStorageList"
 439   [ simpleField "storage" [t| [[(StorageField, J.JSValue)]] |] ])
 440
 441 instance RpcCall RpcCallStorageList where
 442   rpcCallName _          = "storage_list"
 443   rpcCallTimeout _       = rpcTimeoutToRaw Normal
 444   rpcCallAcceptOffline _ = False
 445   rpcCallData _ call     = J.encode
 446     ( rpcCallStorageListSuName call
 447     , rpcCallStorageListSuArgs call
 448     , rpcCallStorageListName call
 449     , rpcCallStorageListFields call
 450     )
 451
 452 instance Rpc RpcCallStorageList RpcResultStorageList where
 453   rpcResultFill call res =
 454     let sfields = rpcCallStorageListFields call in
 455     fromJSValueToRes res (RpcResultStorageList . map (zip sfields))
 456
 457 -- ** TestDelay
 458
 459
 460 -- | Call definition for test delay.
 461 $(buildObject "RpcCallTestDelay" "rpcCallTestDelay"
 462   [ simpleField "duration" [t| Double |]
 463   ])
 464
 465 -- | Result definition for test delay.
 466 data RpcResultTestDelay = RpcResultTestDelay
 467                           deriving Show
 468
 469 -- | Custom JSON instance for null result.
 470 instance J.JSON RpcResultTestDelay where
 471   showJSON _        = J.JSNull
 472   readJSON J.JSNull = return RpcResultTestDelay
 473   readJSON _        = fail "Unable to read RpcResultTestDelay"
 474
 475 instance RpcCall RpcCallTestDelay where
 476   rpcCallName _          = "test_delay"
 477   rpcCallTimeout         = ceiling . (+ 5) . rpcCallTestDelayDuration
 478   rpcCallAcceptOffline _ = False
 479   rpcCallData _ call     = J.encode [rpcCallTestDelayDuration call]
 480
 481 instance Rpc RpcCallTestDelay RpcResultTestDelay where
 482   rpcResultFill _ res = fromJSValueToRes res id