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.
> +
> -- | 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
