, Rpc
, RpcError(..)
, ERpcError
+ , explainRpcError
, executeRpcCall
, rpcCallName
, RpcCallStorageList(..)
, RpcResultStorageList(..)
+ , RpcCallTestDelay(..)
+ , RpcResultTestDelay(..)
+
, rpcTimeoutFromRaw -- FIXME: Not used anywhere
) where
import Ganeti.Compat
import Ganeti.JSON
+-- * Base RPC functionality and types
+
#ifndef NO_CURL
-- | The curl options used for RPC.
curlOpts :: [CurlOption]
| 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) =
+explainRpcError (CurlLayerError node code) =
"Curl error for " ++ nodeName node ++ ", " ++ code
- show (JsonDecodeError msg) =
+explainRpcError (JsonDecodeError msg) =
"Error while decoding JSON from HTTP response: " ++ msg
- show (RpcResultError msg) =
+explainRpcError (RpcResultError msg) =
"Error reponse received from RPC server: " ++ msg
- show (OfflineNodeError node) =
+explainRpcError (OfflineNodeError node) =
"Node " ++ nodeName node ++ " is marked as offline"
type ERpcError = Either RpcError
-- result.
class (RpcCall a, J.JSON b) => Rpc a b | a -> b, b -> a where
-- | Create a result based on the received HTTP response.
- rpcResultFill :: (Monad m) => a -> J.JSValue -> m (ERpcError b)
+ rpcResultFill :: a -> J.JSValue -> ERpcError b
-- | Http Request definition.
data HttpClientRequest = HttpClientRequest
| otherwise = Left $ OfflineNodeError node
-- | Parse a result based on the received HTTP response.
-rpcResultParse :: (Monad m, Rpc a b) => a -> String -> m (ERpcError b)
-rpcResultParse call res = do
- res' <- fromJResult "Reading JSON response" $ J.decode res
- case res' of
- (True, res'') ->
- rpcResultFill call res''
- (False, jerr) -> case jerr of
- J.JSString msg -> return . Left $ RpcResultError (J.fromJSString msg)
- _ -> (return . Left) . JsonDecodeError $ show (pp_value jerr)
-
--- | Parse the response or propagate the error.
-parseHttpResponse :: (Rpc a b) => a -> ERpcError String -> IO (ERpcError b)
-parseHttpResponse _ (Left err) = return $ Left err
-parseHttpResponse call (Right response) = rpcResultParse call 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, ERpcError b)
executeSingleRpcCall node call = do
let request = prepareHttpRequest node call
response <- executeHttpRequest node request
- result <- parseHttpResponse call response
+ let result = parseHttpResponse call response
return (node, result)
-- | Execute RPC call for many nodes in parallel.
-- | Helper function that is used to read dictionaries of values.
sanitizeDictResults :: [(String, J.Result a)] -> ERpcError [(String, a)]
-sanitizeDictResults [] = Right []
-sanitizeDictResults ((_, J.Error err):_) = Left $ JsonDecodeError err
-sanitizeDictResults ((name, J.Ok val):xs) =
- case sanitizeDictResults xs of
- Left err -> Left err
- Right res' -> Right $ (name, val):res'
+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
+-- ** Instance info
+
-- | InstanceInfo
-- Returns information about a single instance.
[ optionalField $ simpleField "inst_info" [t| InstanceInfo |]])
instance RpcCall RpcCallInstanceInfo where
- rpcCallName _ = "instance_info"
- rpcCallTimeout _ = rpcTimeoutToRaw Urgent
+ rpcCallName _ = "instance_info"
+ rpcCallTimeout _ = rpcTimeoutToRaw Urgent
rpcCallAcceptOffline _ = False
- rpcCallData _ call = J.encode
+ rpcCallData _ call = J.encode
( rpcCallInstInfoInstance call
, rpcCallInstInfoHname call
)
instance Rpc RpcCallInstanceInfo RpcResultInstanceInfo where
rpcResultFill _ res =
- return $ case res of
+ case res of
J.JSObject res' ->
case J.fromJSObject res' of
[] -> Right $ RpcResultInstanceInfo Nothing
- _ ->
- case J.readJSON res of
- J.Error err -> Left $ JsonDecodeError err
- J.Ok val -> Right . RpcResultInstanceInfo $ Just val
+ _ -> fromJSValueToRes res (RpcResultInstanceInfo . Just)
_ -> Left $ JsonDecodeError
- ("Expected JSObject, got " ++ show res)
+ ("Expected JSObject, got " ++ show (pp_value res))
+
+-- ** AllInstancesInfo
-- | AllInstancesInfo
-- Returns information about all running instances on the given nodes
[ simpleField "instances" [t| [(String, InstanceInfo)] |] ])
instance RpcCall RpcCallAllInstancesInfo where
- rpcCallName _ = "all_instances_info"
- rpcCallTimeout _ = rpcTimeoutToRaw Urgent
+ rpcCallName _ = "all_instances_info"
+ rpcCallTimeout _ = rpcTimeoutToRaw Urgent
rpcCallAcceptOffline _ = False
- rpcCallData _ call = J.encode [rpcCallAllInstInfoHypervisors call]
+ rpcCallData _ call = J.encode [rpcCallAllInstInfoHypervisors call]
instance Rpc RpcCallAllInstancesInfo RpcResultAllInstancesInfo where
-- FIXME: Is there a simpler way to do it?
rpcResultFill _ res =
- return $ case res of
- J.JSObject res' -> do
+ case res of
+ J.JSObject res' ->
let res'' = map (second J.readJSON) (J.fromJSObject res')
- :: [(String, J.Result InstanceInfo)]
+ :: [(String, J.Result InstanceInfo)] in
case sanitizeDictResults res'' of
Left err -> Left err
Right insts -> Right $ RpcResultAllInstancesInfo insts
_ -> Left $ JsonDecodeError
- ("Expected JSObject, got " ++ show res)
+ ("Expected JSObject, got " ++ show (pp_value res))
+
+-- ** InstanceList
-- | InstanceList
-- Returns the list of running instances on the given nodes.
[ 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]
-
+ rpcCallData _ call = J.encode [rpcCallInstListHypervisors call]
instance Rpc RpcCallInstanceList RpcResultInstanceList where
- rpcResultFill _ res =
- return $ case J.readJSON res of
- J.Error err -> Left $ JsonDecodeError err
- J.Ok insts -> Right $ RpcResultInstanceList insts
+ rpcResultFill _ res = fromJSValueToRes res RpcResultInstanceList
+
+-- ** NodeInfo
-- | NodeInfo
-- Return node information.
])
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
- )
+ rpcCallData _ call = J.encode
+ ( rpcCallNodeInfoVolumeGroups call
+ , rpcCallNodeInfoHypervisors call
+ )
instance Rpc RpcCallNodeInfo RpcResultNodeInfo where
rpcResultFill _ res =
- return $ case J.readJSON res of
- J.Error err -> Left $ JsonDecodeError err
- J.Ok (boot_id, vg_info, hv_info) ->
- Right $ RpcResultNodeInfo boot_id vg_info hv_info
+ fromJSValueToRes res (\(b, vg, hv) -> RpcResultNodeInfo b vg hv)
+
+-- ** Version
-- | Version
-- Query node version.
])
instance RpcCall RpcCallVersion where
- rpcCallName _ = "version"
- rpcCallTimeout _ = rpcTimeoutToRaw Urgent
+ rpcCallName _ = "version"
+ rpcCallTimeout _ = rpcTimeoutToRaw Urgent
rpcCallAcceptOffline _ = True
- rpcCallData call _ = J.encode [call]
+ rpcCallData _ = J.encode
instance Rpc RpcCallVersion RpcResultVersion where
- rpcResultFill _ res =
- return $ case J.readJSON res of
- J.Error err -> Left $ JsonDecodeError err
- J.Ok ver -> Right $ RpcResultVersion ver
+ rpcResultFill _ res = fromJSValueToRes res RpcResultVersion
+
+-- ** StorageList
-- | StorageList
-- Get list of storage units.
[ simpleField "storage" [t| [[(StorageField, J.JSValue)]] |] ])
instance RpcCall RpcCallStorageList where
- rpcCallName _ = "storage_list"
- rpcCallTimeout _ = rpcTimeoutToRaw Normal
+ rpcCallName _ = "storage_list"
+ rpcCallTimeout _ = rpcTimeoutToRaw Normal
rpcCallAcceptOffline _ = False
- rpcCallData _ call = J.encode
+ rpcCallData _ call = J.encode
( rpcCallStorageListSuName call
, rpcCallStorageListSuArgs call
, rpcCallStorageListName call
instance Rpc RpcCallStorageList RpcResultStorageList where
rpcResultFill call res =
let sfields = rpcCallStorageListFields call in
- return $ case J.readJSON res of
- J.Error err -> Left $ JsonDecodeError err
- J.Ok res_lst -> Right $ RpcResultStorageList (map (zip sfields) res_lst)
+ 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 RpcCallTestDelay RpcResultTestDelay where
+ rpcResultFill _ res = fromJSValueToRes res id
projects / ganeti-local / blobdiff