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