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