On Wed, Sep 26, 2012 at 9:31 AM, Iustin Pop <[email protected]> wrote:
> On Tue, Sep 25, 2012 at 06:43:45PM +0200, Agata Murawska wrote:
>> 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 <[email protected]>
>> ---
>> htools/Ganeti/Rpc.hs | 90
>> +++++++++++++++++++++++++++++++++++---------------
>> 1 files changed, 63 insertions(+), 27 deletions(-)
>>
>> diff --git a/htools/Ganeti/Rpc.hs b/htools/Ganeti/Rpc.hs
>> index 377800c..d21b834 100644
>> --- a/htools/Ganeti/Rpc.hs
>> +++ b/htools/Ganeti/Rpc.hs
>> @@ -56,6 +56,7 @@ module Ganeti.Rpc
>> , rpcTimeoutFromRaw -- FIXME: Not used anywhere
>> ) where
>>
>> +import Control.Arrow (second)
>> import qualified Text.JSON as J
>> import Text.JSON (makeObj)
>>
>> @@ -108,10 +109,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 +130,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 +187,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 jerr
>
> "show jerr" is an ugly way to format JSON objects; please use pp_value, per
> commit c12a68e2.
Forgot about this one; fixed.
>
>> +
>> -- | 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 +218,51 @@ 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)]
>
> Style issue: '->' go always at the beginning of the line, not at the
> end.
>
>> +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'
>
> Mmm… this smells so much of foldM…
>
>> -- * 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)
>
> Hmm, not nice indeed. Let's go with this version and see later if we can
> improve it. It's most likely doable with a newtype+custom JSON
> instance.
>
>> 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] |]
>> ])
>
> Is there a reason for this or is it just cleanup?
>
>> $(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
>
> Rest LGTM, thanks.
>
> iustin
Interdiff for both changes:
diff --git a/htools/Ganeti/Rpc.hs b/htools/Ganeti/Rpc.hs
index d21b834..0fac0a2 100644
--- a/htools/Ganeti/Rpc.hs
+++ b/htools/Ganeti/Rpc.hs
@@ -58,6 +58,7 @@ module Ganeti.Rpc
import Control.Arrow (second)
import qualified Text.JSON as J
+import Text.JSON.Pretty (pp_value)
import Text.JSON (makeObj)
#ifndef NO_CURL
@@ -196,7 +197,7 @@ rpcResultParse res = do
rpcResultFill res''
(False, jerr) -> case jerr of
J.JSString msg -> return . Left $ RpcResultError (J.fromJSString msg)
- _ -> (return . Left) . JsonDecodeError $ show jerr
+ _ -> (return . Left) . JsonDecodeError $ show (pp_value jerr)
-- | Parse the response or propagate the error.
parseHttpResponse :: (Monad m, RpcResult a) => ERpcError String
@@ -219,8 +220,7 @@ executeRpcCall nodes call =
(zip nodes $ repeat call)
-- | Helper function that is used to read dictionaries of values.
-sanitizeDictResults :: [(String, J.Result a)] ->
- ERpcError [(String, a)]
+sanitizeDictResults :: [(String, J.Result a)] -> ERpcError [(String, a)]
sanitizeDictResults [] = Right []
