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   , RpcResult
  32   , Rpc
  33   , RpcError(..)
  34   , executeRpcCall
  35
  36   , rpcCallName
  37   , rpcCallTimeout
  38   , rpcCallData
  39   , rpcCallAcceptOffline
  40
  41   , rpcResultFill
  42
  43   , InstanceInfo(..)
  44   , RpcCallAllInstancesInfo(..)
  45   , RpcResultAllInstancesInfo(..)
  46
  47   , RpcCallInstanceList(..)
  48   , RpcResultInstanceList(..)
  49
  50   , HvInfo(..)
  51   , VgInfo(..)
  52   , RpcCallNodeInfo(..)
  53   , RpcResultNodeInfo(..)
  54
  55   , rpcTimeoutFromRaw -- FIXME: Not used anywhere
  56   ) where
  57
  58 import qualified Text.JSON as J
  59 import Text.JSON (makeObj)
  60
  61 #ifndef NO_CURL
  62 import Network.Curl
  63 #endif
  64
  65 import qualified Ganeti.Constants as C
  66 import Ganeti.Objects
  67 import Ganeti.THH
  68 import Ganeti.HTools.Compat
  69 import Ganeti.HTools.JSON
  70
  71 #ifndef NO_CURL
  72 -- | The curl options used for RPC.
  73 curlOpts :: [CurlOption]
  74 curlOpts = [ CurlFollowLocation False
  75            , CurlCAInfo C.nodedCertFile
  76            , CurlSSLVerifyHost 0
  77            , CurlSSLVerifyPeer True
  78            , CurlSSLCertType "PEM"
  79            , CurlSSLCert C.nodedCertFile
  80            , CurlSSLKeyType "PEM"
  81            , CurlSSLKey C.nodedCertFile
  82            , CurlConnectTimeout (fromIntegral C.rpcConnectTimeout)
  83            ]
  84 #endif
  85
  86 -- | Data type for RPC error reporting.
  87 data RpcError
  88   = CurlDisabledError
  89   | CurlLayerError Node String
  90   | JsonDecodeError String
  91   | OfflineNodeError Node
  92   deriving Eq
  93
  94 instance Show RpcError where
  95   show CurlDisabledError =
  96     "RPC/curl backend disabled at compile time"
  97   show (CurlLayerError node code) =
  98     "Curl error for " ++ nodeName node ++ ", error " ++ code
  99   show (JsonDecodeError msg) =
 100     "Error while decoding JSON from HTTP response " ++ msg
 101   show (OfflineNodeError node) =
 102     "Node " ++ nodeName node ++ " is marked as offline"
 103
 104 rpcErrorJsonReport :: (Monad m) => J.Result a -> m (Either RpcError a)
 105 rpcErrorJsonReport (J.Error x) = return $ Left $ JsonDecodeError x
 106 rpcErrorJsonReport (J.Ok x) = return $ Right x
 107
 108 -- | Basic timeouts for RPC calls.
 109 $(declareIADT "RpcTimeout"
 110   [ ( "Urgent",    'C.rpcTmoUrgent )
 111   , ( "Fast",      'C.rpcTmoFast )
 112   , ( "Normal",    'C.rpcTmoNormal )
 113   , ( "Slow",      'C.rpcTmoSlow )
 114   , ( "FourHours", 'C.rpcTmo4hrs )
 115   , ( "OneDay",    'C.rpcTmo1day )
 116   ])
 117
 118 -- | A generic class for RPC calls.
 119 class (J.JSON a) => RpcCall a where
 120   -- | Give the (Python) name of the procedure.
 121   rpcCallName :: a -> String
 122   -- | Calculate the timeout value for the call execution.
 123   rpcCallTimeout :: a -> Int
 124   -- | Prepare arguments of the call to be send as POST.
 125   rpcCallData :: Node -> a -> String
 126   -- | Whether we accept offline nodes when making a call.
 127   rpcCallAcceptOffline :: a -> Bool
 128
 129   rpcCallData _ = J.encode
 130
 131 -- | A generic class for RPC results with default implementation.
 132 class (J.JSON a) => RpcResult a where
 133   -- | Create a result based on the received HTTP response.
 134   rpcResultFill :: (Monad m) => String -> m (Either RpcError a)
 135
 136   rpcResultFill res = rpcErrorJsonReport $  J.decode res
 137
 138 -- | Generic class that ensures matching RPC call with its respective
 139 -- result.
 140 class (RpcCall a, RpcResult b) => Rpc a b | a -> b
 141
 142 -- | Http Request definition.
 143 data HttpClientRequest = HttpClientRequest
 144   { requestTimeout :: Int
 145   , requestUrl :: String
 146   , requestPostData :: String
 147   }
 148
 149 -- | Execute the request and return the result as a plain String. When
 150 -- curl reports an error, we propagate it.
 151 executeHttpRequest :: Node -> Either RpcError HttpClientRequest
 152                    -> IO (Either RpcError String)
 153
 154 executeHttpRequest _ (Left rpc_err) = return $ Left rpc_err
 155 #ifdef NO_CURL
 156 executeHttpRequest _ _ = return $ Left CurlDisabledError
 157 #else
 158 executeHttpRequest node (Right request) = do
 159   let reqOpts = [ CurlTimeout (fromIntegral $ requestTimeout request)
 160                 , CurlPostFields [requestPostData request]
 161                 ]
 162       url = requestUrl request
 163   -- FIXME: This is very similar to getUrl in Htools/Rapi.hs
 164   (code, !body) <- curlGetString url $ curlOpts ++ reqOpts
 165   case code of
 166     CurlOK -> return $ Right body
 167     _ -> return $ Left $ CurlLayerError node (show code)
 168 #endif
 169
 170 -- | Prepare url for the HTTP request.
 171 prepareUrl :: (RpcCall a) => Node -> a -> String
 172 prepareUrl node call =
 173   let node_ip = nodePrimaryIp node
 174       port = snd C.daemonsPortsGanetiNoded
 175       path_prefix = "https://" ++ (node_ip) ++ ":" ++ (show port) in
 176   path_prefix ++ "/" ++ rpcCallName call
 177
 178 -- | Create HTTP request for a given node provided it is online,
 179 -- otherwise create empty response.
 180 prepareHttpRequest ::  (RpcCall a) => Node -> a
 181                    -> Either RpcError HttpClientRequest
 182 prepareHttpRequest node call
 183   | rpcCallAcceptOffline call ||
 184     (not $ nodeOffline node) =
 185       Right $ HttpClientRequest { requestTimeout = rpcCallTimeout call
 186                                 , requestUrl = prepareUrl node call
 187                                 , requestPostData = rpcCallData node call
 188                                 }
 189   | otherwise = Left $ OfflineNodeError node
 190
 191 -- | Parse the response or propagate the error.
 192 parseHttpResponse :: (Monad m, RpcResult a) => Either RpcError String
 193                   -> m (Either RpcError a)
 194 parseHttpResponse (Left err) = return $ Left err
 195 parseHttpResponse (Right response) = rpcResultFill response
 196
 197 -- | Execute RPC call for a sigle node.
 198 executeSingleRpcCall :: (Rpc a b) => Node -> a -> IO (Node, Either RpcError b)
 199 executeSingleRpcCall node call = do
 200   let request = prepareHttpRequest node call
 201   response <- executeHttpRequest node request
 202   result <- parseHttpResponse response
 203   return (node, result)
 204
 205 -- | Execute RPC call for many nodes in parallel.
 206 executeRpcCall :: (Rpc a b) => [Node] -> a -> IO [(Node, Either RpcError b)]
 207 executeRpcCall nodes call =
 208   sequence $ parMap rwhnf (uncurry executeSingleRpcCall)
 209                (zip nodes $ repeat call)
 210
 211 -- * RPC calls and results
 212
 213 -- | AllInstancesInfo
 214 --   Returns information about all instances on the given nodes
 215 $(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo" $
 216   [ simpleField "hypervisors" [t| [Hypervisor] |] ])
 217
 218 $(buildObject "InstanceInfo" "instInfo" $
 219   [ simpleField "name"   [t| String |]
 220   , simpleField "memory" [t| Int|]
 221   , simpleField "state"  [t| AdminState |]
 222   , simpleField "vcpus"  [t| Int |]
 223   , simpleField "time"   [t| Int |]
 224   ])
 225
 226 $(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo" $
 227   [ simpleField "instances" [t| [InstanceInfo] |] ])
 228
 229 instance RpcCall RpcCallAllInstancesInfo where
 230   rpcCallName _ = "all_instances_info"
 231   rpcCallTimeout _ = rpcTimeoutToRaw Urgent
 232   rpcCallAcceptOffline _ = False
 233
 234 instance RpcResult RpcResultAllInstancesInfo
 235
 236 instance Rpc RpcCallAllInstancesInfo RpcResultAllInstancesInfo
 237
 238 -- | InstanceList
 239 -- Returns the list of running instances on the given nodes.
 240 $(buildObject "RpcCallInstanceList" "rpcCallInstList" $
 241   [ simpleField "hypervisors" [t| [Hypervisor] |] ])
 242
 243 $(buildObject "RpcResultInstanceList" "rpcResInstList" $
 244   [ simpleField "node"      [t| Node |]
 245   , simpleField "instances" [t| [String] |]
 246   ])
 247
 248 instance RpcCall RpcCallInstanceList where
 249   rpcCallName _ = "instance_list"
 250   rpcCallTimeout _ = rpcTimeoutToRaw Urgent
 251   rpcCallAcceptOffline _ = False
 252
 253 instance RpcResult RpcResultInstanceList
 254
 255 instance Rpc RpcCallInstanceList RpcResultInstanceList
 256
 257 -- | NodeInfo
 258 -- Return node information.
 259 $(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo" $
 260   [ simpleField "hypervisors" [t| [Hypervisor] |]
 261   , simpleField "volume_groups" [t| [String] |]
 262   ])
 263
 264 $(buildObject "VgInfo" "vgInfo" $
 265   [ simpleField "name" [t| String |]
 266   , simpleField "free" [t| Int |]
 267   , simpleField "size" [t| Int |]
 268   ])
 269
 270 -- | We only provide common fields as described in hv_base.py.
 271 $(buildObject "HvInfo" "hvInfo" $
 272   [ simpleField "memory_total" [t| Int |]
 273   , simpleField "memory_free" [t| Int |]
 274   , simpleField "memory_dom0" [t| Int |]
 275   , simpleField "cpu_total" [t| Int |]
 276   , simpleField "cpu_nodes" [t| Int |]
 277   , simpleField "cpu_sockets" [t| Int |]
 278   ])
 279
 280 $(buildObject "RpcResultNodeInfo" "rpcResNodeInfo" $
 281   [ simpleField "boot_id" [t| String |]
 282   , simpleField "vg_info" [t| [VgInfo] |]
 283   , simpleField "hv_info" [t| [HvInfo] |]
 284   ])
 285
 286 instance RpcCall RpcCallNodeInfo where
 287   rpcCallName _ = "node_info"
 288   rpcCallTimeout _ = rpcTimeoutToRaw Urgent
 289   rpcCallAcceptOffline _ = False
 290
 291 instance RpcResult RpcResultNodeInfo
 292
 293 instance Rpc RpcCallNodeInfo RpcResultNodeInfo