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

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