module Ganeti.Rpc
( RpcCall
- , RpcResult
, Rpc
, RpcError(..)
, ERpcError
+ , explainRpcError
, executeRpcCall
, rpcCallName
, rpcResultFill
, InstanceInfo(..)
+ , RpcCallInstanceInfo(..)
+ , RpcResultInstanceInfo(..)
+
, RpcCallAllInstancesInfo(..)
, RpcResultAllInstancesInfo(..)
, RpcCallVersion(..)
, RpcResultVersion(..)
+ , StorageType(..)
+ , StorageField(..)
+ , 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
-- | Whether we accept offline nodes when making a call.
rpcCallAcceptOffline :: a -> Bool
--- | 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) => J.JSValue -> m (ERpcError a)
-
-- | 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
| otherwise = Left $ OfflineNodeError node
-- | Parse a result based on the received HTTP response.
-rpcResultParse :: (Monad m, RpcResult a) => String -> m (ERpcError a)
-rpcResultParse res = do
- res' <- fromJResult "Reading JSON response" $ J.decode res
- case res' of
- (True, res'') ->
- rpcResultFill 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 :: (Monad m, RpcResult a) => ERpcError String
- -> m (ERpcError a)
-parseHttpResponse (Left err) = return $ Left err
-parseHttpResponse (Right response) = rpcResultParse 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 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
--- | AllInstancesInfo
--- Returns information about all running instances on the given nodes.
-$(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo"
- [ simpleField "hypervisors" [t| [Hypervisor] |] ])
+-- ** Instance info
+
+-- | InstanceInfo
+-- Returns information about a single instance.
+
+$(buildObject "RpcCallInstanceInfo" "rpcCallInstInfo"
+ [ simpleField "instance" [t| String |]
+ , simpleField "hname" [t| Hypervisor |]
+ ])
$(buildObject "InstanceInfo" "instInfo"
[ simpleField "memory" [t| Int|]
, simpleField "time" [t| Int |]
])
+-- 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 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
+
+-- | 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 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 RpcResult RpcResultAllInstancesInfo where
+instance Rpc RpcCallAllInstancesInfo RpcResultAllInstancesInfo where
-- FIXME: Is there a simpler way to do it?
- rpcResultFill res =
- return $ case res of
- J.JSObject res' -> do
+ rpcResultFill _ res =
+ 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))
-instance Rpc RpcCallAllInstancesInfo RpcResultAllInstancesInfo
+-- ** 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 RpcResult RpcResultInstanceList where
- rpcResultFill res =
- return $ case J.readJSON res of
- J.Error err -> Left $ JsonDecodeError err
- J.Ok insts -> Right $ RpcResultInstanceList insts
+instance Rpc RpcCallInstanceList RpcResultInstanceList where
+ rpcResultFill _ res = fromJSValueToRes res RpcResultInstanceList
-instance Rpc RpcCallInstanceList 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 RpcResult 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
+instance Rpc RpcCallNodeInfo RpcResultNodeInfo where
+ rpcResultFill _ res =
+ fromJSValueToRes res (\(b, vg, hv) -> RpcResultNodeInfo b vg hv)
-instance Rpc RpcCallNodeInfo RpcResultNodeInfo
+-- ** 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 = 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 RpcResultVersion where
- rpcResultFill res =
- return $ case J.readJSON res of
- J.Error err -> Left $ JsonDecodeError err
- J.Ok ver -> Right $ RpcResultVersion ver
+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 RpcCallVersion RpcResultVersion
+instance Rpc RpcCallTestDelay RpcResultTestDelay where
+ rpcResultFill _ res = fromJSValueToRes res id
projects / ganeti-local / blobdiff