On Wed, Sep 26, 2012 at 02:20:21PM +0200, Agata Murawska wrote: > 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:
Thanks, LGTM. iustin
