module Ganeti.Rpc
( RpcCall
- , RpcResult
, Rpc
, RpcError(..)
+ , ERpcError
+ , explainRpcError
, executeRpcCall
, rpcCallName
, rpcResultFill
, InstanceInfo(..)
+ , RpcCallInstanceInfo(..)
+ , RpcResultInstanceInfo(..)
+
, RpcCallAllInstancesInfo(..)
, RpcResultAllInstancesInfo(..)
, RpcCallNodeInfo(..)
, RpcResultNodeInfo(..)
+ , RpcCallVersion(..)
+ , RpcResultVersion(..)
+
+ , StorageType(..)
+ , StorageField(..)
+ , RpcCallStorageList(..)
+ , RpcResultStorageList(..)
+
+ , RpcCallTestDelay(..)
+ , RpcResultTestDelay(..)
+
, rpcTimeoutFromRaw -- FIXME: Not used anywhere
) where
+import Control.Arrow (second)
import qualified Text.JSON as J
+import Text.JSON.Pretty (pp_value)
import Text.JSON (makeObj)
#ifndef NO_CURL
import Network.Curl
+import qualified Ganeti.Path as P
#endif
import qualified Ganeti.Constants as C
import Ganeti.Objects
import Ganeti.THH
-import Ganeti.HTools.Compat
-import Ganeti.HTools.JSON
+import Ganeti.Compat
+import Ganeti.JSON
+
+-- * Base RPC functionality and types
#ifndef NO_CURL
-- | The curl options used for RPC.
curlOpts :: [CurlOption]
curlOpts = [ CurlFollowLocation False
- , CurlCAInfo C.nodedCertFile
+ , CurlCAInfo P.nodedCertFile
, CurlSSLVerifyHost 0
, CurlSSLVerifyPeer True
, CurlSSLCertType "PEM"
- , CurlSSLCert C.nodedCertFile
+ , CurlSSLCert P.nodedCertFile
, CurlSSLKeyType "PEM"
- , CurlSSLKey C.nodedCertFile
+ , CurlSSLKey P.nodedCertFile
, CurlConnectTimeout (fromIntegral C.rpcConnectTimeout)
]
#endif
= CurlDisabledError
| CurlLayerError Node String
| JsonDecodeError String
+ | RpcResultError String
| OfflineNodeError Node
- deriving Eq
+ deriving (Show, Eq)
-instance Show RpcError where
- show CurlDisabledError =
+-- | Provide explanation to RPC errors.
+explainRpcError :: RpcError -> String
+explainRpcError CurlDisabledError =
"RPC/curl backend disabled at compile time"
- show (CurlLayerError node code) =
- "Curl error for " ++ nodeName node ++ ", error " ++ code
- show (JsonDecodeError msg) =
- "Error while decoding JSON from HTTP response " ++ msg
- show (OfflineNodeError node) =
+explainRpcError (CurlLayerError node code) =
+ "Curl error for " ++ nodeName node ++ ", " ++ code
+explainRpcError (JsonDecodeError msg) =
+ "Error while decoding JSON from HTTP response: " ++ msg
+explainRpcError (RpcResultError msg) =
+ "Error reponse received from RPC server: " ++ msg
+explainRpcError (OfflineNodeError node) =
"Node " ++ nodeName node ++ " is marked as offline"
-rpcErrorJsonReport :: (Monad m) => J.Result a -> m (Either RpcError a)
-rpcErrorJsonReport (J.Error x) = return . Left $ JsonDecodeError x
-rpcErrorJsonReport (J.Ok x) = return $ Right x
+type ERpcError = Either RpcError
-- | Basic timeouts for RPC calls.
$(declareIADT "RpcTimeout"
-- | Whether we accept offline nodes when making a call.
rpcCallAcceptOffline :: a -> Bool
- rpcCallData _ = J.encode
-
--- | A generic class for RPC results with default implementation.
-class (J.JSON a) => RpcResult a where
- -- | Create a result based on the received HTTP response.
- rpcResultFill :: (Monad m) => String -> m (Either RpcError a)
-
- rpcResultFill res = rpcErrorJsonReport $ J.decode res
-
-- | Generic class that ensures matching RPC call with its respective
-- result.
-class (RpcCall a, RpcResult b) => Rpc a b | a -> b
+class (RpcCall a, J.JSON b) => Rpc a b | a -> b, b -> a where
+ -- | Create a result based on the received HTTP response.
+ rpcResultFill :: a -> J.JSValue -> ERpcError b
-- | Http Request definition.
data HttpClientRequest = HttpClientRequest
-- | Execute the request and return the result as a plain String. When
-- curl reports an error, we propagate it.
-executeHttpRequest :: Node -> Either RpcError HttpClientRequest
- -> IO (Either RpcError String)
+executeHttpRequest :: Node -> ERpcError HttpClientRequest
+ -> IO (ERpcError String)
executeHttpRequest _ (Left rpc_err) = return $ Left rpc_err
#ifdef NO_CURL
prepareUrl node call =
let node_ip = nodePrimaryIp node
port = snd C.daemonsPortsGanetiNoded
- path_prefix = "https://" ++ (node_ip) ++ ":" ++ (show port) in
- path_prefix ++ "/" ++ rpcCallName call
+ path_prefix = "https://" ++ node_ip ++ ":" ++ show port
+ in path_prefix ++ "/" ++ rpcCallName call
-- | Create HTTP request for a given node provided it is online,
-- otherwise create empty response.
prepareHttpRequest :: (RpcCall a) => Node -> a
- -> Either RpcError HttpClientRequest
+ -> ERpcError HttpClientRequest
prepareHttpRequest node call
- | rpcCallAcceptOffline call ||
- (not $ nodeOffline node) =
- Right $ HttpClientRequest { requestTimeout = rpcCallTimeout call
- , requestUrl = prepareUrl node call
- , requestPostData = rpcCallData node call
- }
+ | rpcCallAcceptOffline call || not (nodeOffline node) =
+ Right HttpClientRequest { requestTimeout = rpcCallTimeout call
+ , requestUrl = prepareUrl node call
+ , requestPostData = rpcCallData node call
+ }
| otherwise = Left $ OfflineNodeError node
--- | Parse the response or propagate the error.
-parseHttpResponse :: (Monad m, RpcResult a) => Either RpcError String
- -> m (Either RpcError a)
-parseHttpResponse (Left err) = return $ Left err
-parseHttpResponse (Right response) = rpcResultFill response
+-- | Parse a result based on the received HTTP response.
+parseHttpResponse :: (Rpc a b) => a -> ERpcError String -> ERpcError b
+parseHttpResponse _ (Left err) = Left err
+parseHttpResponse call (Right res) =
+ case J.decode res of
+ J.Error val -> Left $ JsonDecodeError val
+ J.Ok (True, res'') -> rpcResultFill call res''
+ J.Ok (False, jerr) -> case jerr of
+ J.JSString msg -> Left $ RpcResultError (J.fromJSString msg)
+ _ -> Left . JsonDecodeError $ show (pp_value jerr)
-- | Execute RPC call for a sigle node.
-executeSingleRpcCall :: (Rpc a b) => Node -> a -> IO (Node, Either RpcError b)
+executeSingleRpcCall :: (Rpc a b) => Node -> a -> IO (Node, ERpcError b)
executeSingleRpcCall node call = do
let request = prepareHttpRequest node call
response <- executeHttpRequest node request
- result <- parseHttpResponse response
+ let result = parseHttpResponse call response
return (node, result)
-- | Execute RPC call for many nodes in parallel.
-executeRpcCall :: (Rpc a b) => [Node] -> a -> IO [(Node, Either RpcError b)]
+executeRpcCall :: (Rpc a b) => [Node] -> a -> IO [(Node, ERpcError b)]
executeRpcCall nodes call =
sequence $ parMap rwhnf (uncurry executeSingleRpcCall)
(zip nodes $ repeat call)
+-- | Helper function that is used to read dictionaries of values.
+sanitizeDictResults :: [(String, J.Result a)] -> ERpcError [(String, a)]
+sanitizeDictResults =
+ foldr sanitize1 (Right [])
+ where
+ sanitize1 _ (Left e) = Left e
+ sanitize1 (_, J.Error e) _ = Left $ JsonDecodeError e
+ sanitize1 (name, J.Ok v) (Right res) = Right $ (name, v) : res
+
+-- | Helper function to tranform JSON Result to Either RpcError b.
+-- Note: For now we really only use it for b s.t. Rpc c b for some c
+fromJResultToRes :: J.Result a -> (a -> b) -> ERpcError b
+fromJResultToRes (J.Error v) _ = Left $ JsonDecodeError v
+fromJResultToRes (J.Ok v) f = Right $ f v
+
+-- | Helper function transforming JSValue to Rpc result type.
+fromJSValueToRes :: (J.JSON a) => J.JSValue -> (a -> b) -> ERpcError b
+fromJSValueToRes val = fromJResultToRes (J.readJSON val)
+
-- * RPC calls and results
--- | AllInstancesInfo
--- Returns information about all instances on the given nodes
-$(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo" $
- [ simpleField "hypervisors" [t| [Hypervisor] |] ])
+-- ** Instance info
+
+-- | InstanceInfo
+-- Returns information about a single instance.
-$(buildObject "InstanceInfo" "instInfo" $
- [ simpleField "name" [t| String |]
- , simpleField "memory" [t| Int|]
- , simpleField "state" [t| AdminState |]
+$(buildObject "RpcCallInstanceInfo" "rpcCallInstInfo"
+ [ simpleField "instance" [t| String |]
+ , simpleField "hname" [t| Hypervisor |]
+ ])
+
+$(buildObject "InstanceInfo" "instInfo"
+ [ simpleField "memory" [t| Int|]
+ , simpleField "state" [t| String |] -- It depends on hypervisor :(
, simpleField "vcpus" [t| Int |]
, simpleField "time" [t| Int |]
])
-$(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo" $
- [ simpleField "instances" [t| [InstanceInfo] |] ])
+-- This is optional here because the result may be empty if instance is
+-- not on a node - and this is not considered an error.
+$(buildObject "RpcResultInstanceInfo" "rpcResInstInfo"
+ [ optionalField $ simpleField "inst_info" [t| InstanceInfo |]])
-instance RpcCall RpcCallAllInstancesInfo where
- rpcCallName _ = "all_instances_info"
- rpcCallTimeout _ = rpcTimeoutToRaw Urgent
+instance RpcCall RpcCallInstanceInfo where
+ rpcCallName _ = "instance_info"
+ rpcCallTimeout _ = rpcTimeoutToRaw Urgent
rpcCallAcceptOffline _ = False
+ rpcCallData _ call = J.encode
+ ( rpcCallInstInfoInstance call
+ , rpcCallInstInfoHname call
+ )
+
+instance Rpc RpcCallInstanceInfo RpcResultInstanceInfo where
+ rpcResultFill _ res =
+ case res of
+ J.JSObject res' ->
+ case J.fromJSObject res' of
+ [] -> Right $ RpcResultInstanceInfo Nothing
+ _ -> fromJSValueToRes res (RpcResultInstanceInfo . Just)
+ _ -> Left $ JsonDecodeError
+ ("Expected JSObject, got " ++ show (pp_value res))
+
+-- ** AllInstancesInfo
-instance RpcResult RpcResultAllInstancesInfo
+-- | AllInstancesInfo
+-- Returns information about all running instances on the given nodes
+$(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo"
+ [ simpleField "hypervisors" [t| [Hypervisor] |] ])
+
+$(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo"
+ [ simpleField "instances" [t| [(String, InstanceInfo)] |] ])
-instance Rpc RpcCallAllInstancesInfo RpcResultAllInstancesInfo
+instance RpcCall RpcCallAllInstancesInfo where
+ rpcCallName _ = "all_instances_info"
+ rpcCallTimeout _ = rpcTimeoutToRaw Urgent
+ rpcCallAcceptOffline _ = False
+ rpcCallData _ call = J.encode [rpcCallAllInstInfoHypervisors call]
+
+instance Rpc RpcCallAllInstancesInfo RpcResultAllInstancesInfo where
+ -- FIXME: Is there a simpler way to do it?
+ rpcResultFill _ res =
+ case res of
+ J.JSObject res' ->
+ let res'' = map (second J.readJSON) (J.fromJSObject res')
+ :: [(String, J.Result InstanceInfo)] in
+ case sanitizeDictResults res'' of
+ Left err -> Left err
+ Right insts -> Right $ RpcResultAllInstancesInfo insts
+ _ -> Left $ JsonDecodeError
+ ("Expected JSObject, got " ++ show (pp_value res))
+
+-- ** InstanceList
-- | InstanceList
-- Returns the list of running instances on the given nodes.
-$(buildObject "RpcCallInstanceList" "rpcCallInstList" $
+$(buildObject "RpcCallInstanceList" "rpcCallInstList"
[ simpleField "hypervisors" [t| [Hypervisor] |] ])
-$(buildObject "RpcResultInstanceList" "rpcResInstList" $
- [ simpleField "node" [t| Node |]
- , simpleField "instances" [t| [String] |]
- ])
+$(buildObject "RpcResultInstanceList" "rpcResInstList"
+ [ simpleField "instances" [t| [String] |] ])
instance RpcCall RpcCallInstanceList where
- rpcCallName _ = "instance_list"
- rpcCallTimeout _ = rpcTimeoutToRaw Urgent
+ rpcCallName _ = "instance_list"
+ rpcCallTimeout _ = rpcTimeoutToRaw Urgent
rpcCallAcceptOffline _ = False
+ rpcCallData _ call = J.encode [rpcCallInstListHypervisors call]
-instance RpcResult RpcResultInstanceList
+instance Rpc RpcCallInstanceList RpcResultInstanceList where
+ rpcResultFill _ res = fromJSValueToRes res RpcResultInstanceList
-instance Rpc RpcCallInstanceList RpcResultInstanceList
+-- ** NodeInfo
-- | NodeInfo
-- Return node information.
-$(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo" $
- [ simpleField "hypervisors" [t| [Hypervisor] |]
- , simpleField "volume_groups" [t| [String] |]
+$(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo"
+ [ simpleField "volume_groups" [t| [String] |]
+ , simpleField "hypervisors" [t| [Hypervisor] |]
])
-$(buildObject "VgInfo" "vgInfo" $
+$(buildObject "VgInfo" "vgInfo"
[ simpleField "name" [t| String |]
- , simpleField "free" [t| Int |]
- , simpleField "size" [t| Int |]
+ , optionalField $ simpleField "vg_free" [t| Int |]
+ , optionalField $ simpleField "vg_size" [t| Int |]
])
-- | We only provide common fields as described in hv_base.py.
-$(buildObject "HvInfo" "hvInfo" $
+$(buildObject "HvInfo" "hvInfo"
[ simpleField "memory_total" [t| Int |]
, simpleField "memory_free" [t| Int |]
, simpleField "memory_dom0" [t| Int |]
, simpleField "cpu_sockets" [t| Int |]
])
-$(buildObject "RpcResultNodeInfo" "rpcResNodeInfo" $
+$(buildObject "RpcResultNodeInfo" "rpcResNodeInfo"
[ simpleField "boot_id" [t| String |]
, simpleField "vg_info" [t| [VgInfo] |]
, simpleField "hv_info" [t| [HvInfo] |]
])
instance RpcCall RpcCallNodeInfo where
- rpcCallName _ = "node_info"
- rpcCallTimeout _ = rpcTimeoutToRaw Urgent
+ rpcCallName _ = "node_info"
+ rpcCallTimeout _ = rpcTimeoutToRaw Urgent
rpcCallAcceptOffline _ = False
+ rpcCallData _ call = J.encode
+ ( rpcCallNodeInfoVolumeGroups call
+ , rpcCallNodeInfoHypervisors call
+ )
+
+instance Rpc RpcCallNodeInfo RpcResultNodeInfo where
+ rpcResultFill _ res =
+ fromJSValueToRes res (\(b, vg, hv) -> RpcResultNodeInfo b vg hv)
+
+-- ** Version
+
+-- | Version
+-- Query node version.
+-- Note: We can't use THH as it does not know what to do with empty dict
+data RpcCallVersion = RpcCallVersion {}
+ deriving (Show, Read, Eq)
+
+instance J.JSON RpcCallVersion where
+ showJSON _ = J.JSNull
+ readJSON J.JSNull = return RpcCallVersion
+ readJSON _ = fail "Unable to read RpcCallVersion"
+
+$(buildObject "RpcResultVersion" "rpcResultVersion"
+ [ simpleField "version" [t| Int |]
+ ])
+
+instance RpcCall RpcCallVersion where
+ rpcCallName _ = "version"
+ rpcCallTimeout _ = rpcTimeoutToRaw Urgent
+ rpcCallAcceptOffline _ = True
+ rpcCallData _ = J.encode
+
+instance Rpc RpcCallVersion RpcResultVersion where
+ rpcResultFill _ res = fromJSValueToRes res RpcResultVersion
+
+-- ** StorageList
+
+-- | StorageList
+-- Get list of storage units.
+-- FIXME: This may be moved to Objects
+$(declareSADT "StorageType"
+ [ ( "STLvmPv", 'C.stLvmPv )
+ , ( "STFile", 'C.stFile )
+ , ( "STLvmVg", 'C.stLvmVg )
+ ])
+$(makeJSONInstance ''StorageType)
+
+-- FIXME: This may be moved to Objects
+$(declareSADT "StorageField"
+ [ ( "SFUsed", 'C.sfUsed)
+ , ( "SFName", 'C.sfName)
+ , ( "SFAllocatable", 'C.sfAllocatable)
+ , ( "SFFree", 'C.sfFree)
+ , ( "SFSize", 'C.sfSize)
+ ])
+$(makeJSONInstance ''StorageField)
+
+$(buildObject "RpcCallStorageList" "rpcCallStorageList"
+ [ simpleField "su_name" [t| StorageType |]
+ , simpleField "su_args" [t| [String] |]
+ , simpleField "name" [t| String |]
+ , simpleField "fields" [t| [StorageField] |]
+ ])
+
+-- FIXME: The resulting JSValues should have types appropriate for their
+-- StorageField value: Used -> Bool, Name -> String etc
+$(buildObject "RpcResultStorageList" "rpcResStorageList"
+ [ simpleField "storage" [t| [[(StorageField, J.JSValue)]] |] ])
-instance RpcResult RpcResultNodeInfo
+instance RpcCall RpcCallStorageList where
+ rpcCallName _ = "storage_list"
+ rpcCallTimeout _ = rpcTimeoutToRaw Normal
+ rpcCallAcceptOffline _ = False
+ rpcCallData _ call = J.encode
+ ( rpcCallStorageListSuName call
+ , rpcCallStorageListSuArgs call
+ , rpcCallStorageListName call
+ , rpcCallStorageListFields call
+ )
+
+instance Rpc RpcCallStorageList RpcResultStorageList where
+ rpcResultFill call res =
+ let sfields = rpcCallStorageListFields call in
+ fromJSValueToRes res (RpcResultStorageList . map (zip sfields))
+
+-- ** TestDelay
+
+
+-- | Call definition for test delay.
+$(buildObject "RpcCallTestDelay" "rpcCallTestDelay"
+ [ simpleField "duration" [t| Double |]
+ ])
+
+-- | Result definition for test delay.
+data RpcResultTestDelay = RpcResultTestDelay
+ deriving Show
+
+-- | Custom JSON instance for null result.
+instance J.JSON RpcResultTestDelay where
+ showJSON _ = J.JSNull
+ readJSON J.JSNull = return RpcResultTestDelay
+ readJSON _ = fail "Unable to read RpcResultTestDelay"
+
+instance RpcCall RpcCallTestDelay where
+ rpcCallName _ = "test_delay"
+ rpcCallTimeout = ceiling . (+ 5) . rpcCallTestDelayDuration
+ rpcCallAcceptOffline _ = False
+ rpcCallData _ call = J.encode [rpcCallTestDelayDuration call]
-instance Rpc RpcCallNodeInfo RpcResultNodeInfo
+instance Rpc RpcCallTestDelay RpcResultTestDelay where
+ rpcResultFill _ res = fromJSValueToRes res id
projects / ganeti-local / blobdiff