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