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 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"
-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
-- | 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
}
| 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 "RpcCallInstanceInfo" "rpcCallInstInfo"
+ [ simpleField "instance" [t| String |]
+ , simpleField "hname" [t| Hypervisor |]
+ ])
$(buildObject "InstanceInfo" "instInfo"
- [ simpleField "name" [t| String |]
- , simpleField "memory" [t| Int|]
- , simpleField "state" [t| AdminState |]
+ [ 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] |] ])
-instance Rpc RpcCallAllInstancesInfo RpcResultAllInstancesInfo
+$(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo"
+ [ simpleField "instances" [t| [(String, InstanceInfo)] |] ])
+
+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.
[ simpleField "hypervisors" [t| [Hypervisor] |] ])
$(buildObject "RpcResultInstanceList" "rpcResInstList"
- [ simpleField "node" [t| Node |]
- , simpleField "instances" [t| [String] |]
- ])
+ [ 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] |]
+ [ simpleField "volume_groups" [t| [String] |]
+ , simpleField "hypervisors" [t| [Hypervisor] |]
])
$(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.
])
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] |]
+ ])
-instance RpcResult RpcResultNodeInfo
+-- 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 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