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