From 9b09c0beec244f10e3321d614cad470f29599aa1 Mon Sep 17 00:00:00 2001
From: Agata Murawska <agatamurawska@google.com>
Date: Fri, 21 Sep 2012 11:25:31 +0200
Subject: [PATCH] Fix RPC call and result (de)serialization
Previous version of RPC calls implementation in Haskell did not take
into account that the actual result type for queries is a list, not
a dictionary.
This patch aims at fixing the problem "for now" - it is not a pretty
solution, but it does work. Note that parsing of the result is now
split into two parts - first, we check if server's aswer is positive,
then if it is, we procede with decoding the actual result.
Values and order of some fields in the result type were changed to
reflect actual order of arguments from server responses.
AllInstancesInfo call was particularly tricky, because it returns a
dictionary where keys are instance names - and the response from
a given node is correct if all the instances were deserialized, not
just some.
Signed-off-by: Agata Murawska <agatamurawska@google.com>
Reviewed-by: Iustin Pop <iustin@google.com>
---
htools/Ganeti/Rpc.hs | 90 +++++++++++++++++++++++++++++++-------------
1 file changed, 63 insertions(+), 27 deletions(-)
diff --git a/htools/Ganeti/Rpc.hs b/htools/Ganeti/Rpc.hs
index 377800c95..0fac0a24f 100644
--- a/htools/Ganeti/Rpc.hs
+++ b/htools/Ganeti/Rpc.hs
@@ -56,7 +56,9 @@ module Ganeti.Rpc
, 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
@@ -108,10 +110,6 @@ instance Show RpcError where
type ERpcError = Either RpcError
-rpcErrorJsonReport :: (Monad m) => J.Result a -> m (ERpcError a)
-rpcErrorJsonReport (J.Error x) = return . Left $ JsonDecodeError x
-rpcErrorJsonReport (J.Ok x) = return $ Right x
-
-- | Basic timeouts for RPC calls.
$(declareIADT "RpcTimeout"
[ ( "Urgent", 'C.rpcTmoUrgent )
@@ -133,14 +131,10 @@ class (J.JSON a) => RpcCall a where
-- | 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 (ERpcError a)
-
- rpcResultFill res = rpcErrorJsonReport $ J.decode res
+ rpcResultFill :: (Monad m) => J.JSValue -> m (ERpcError a)
-- | Generic class that ensures matching RPC call with its respective
-- result.
@@ -194,11 +188,22 @@ prepareHttpRequest node call
}
| 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) = rpcResultFill response
+parseHttpResponse (Right response) = rpcResultParse response
-- | Execute RPC call for a sigle node.
executeSingleRpcCall :: (Rpc a b) => Node -> a -> IO (Node, ERpcError b)
@@ -214,30 +219,50 @@ 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 [] = 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'
+
-- * RPC calls and results
-- | AllInstancesInfo
--- Returns information about all instances on the given nodes
+-- Returns information about all running instances on the given nodes.
$(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo"
[ simpleField "hypervisors" [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] |] ])
+ [ simpleField "instances" [t| [(String, InstanceInfo)] |] ])
instance RpcCall RpcCallAllInstancesInfo where
rpcCallName _ = "all_instances_info"
rpcCallTimeout _ = rpcTimeoutToRaw Urgent
rpcCallAcceptOffline _ = False
-
-instance RpcResult RpcResultAllInstancesInfo
+ rpcCallData _ call = J.encode [rpcCallAllInstInfoHypervisors call]
+
+instance RpcResult RpcResultAllInstancesInfo where
+ -- FIXME: Is there a simpler way to do it?
+ rpcResultFill res =
+ return $ case res of
+ J.JSObject res' -> do
+ let res'' = map (second J.readJSON) (J.fromJSObject res')
+ :: [(String, J.Result InstanceInfo)]
+ case sanitizeDictResults res'' of
+ Left err -> Left err
+ Right insts -> Right $ RpcResultAllInstancesInfo insts
+ _ -> Left $ JsonDecodeError
+ ("Expected JSObject, got " ++ show res)
instance Rpc RpcCallAllInstancesInfo RpcResultAllInstancesInfo
@@ -247,30 +272,33 @@ $(buildObject "RpcCallInstanceList" "rpcCallInstList"
[ 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
rpcCallAcceptOffline _ = False
+ rpcCallData _ call = J.encode [rpcCallInstListHypervisors call]
-instance RpcResult RpcResultInstanceList
+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
-- | 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.
@@ -293,7 +321,15 @@ instance RpcCall RpcCallNodeInfo where
rpcCallName _ = "node_info"
rpcCallTimeout _ = rpcTimeoutToRaw Urgent
rpcCallAcceptOffline _ = False
-
-instance RpcResult RpcResultNodeInfo
+ 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
--
GitLab