From da64e8758e2cac031547057b89001ca8828a2958 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 12 Nov 2013 17:24:23 +0100 Subject: [PATCH] remove IQResponseTimeout from IQResponse IQResponseTimeout does not model an XMPP type but is instead an implementation specific signal that a user-set timeout has occured. Removing it keeps our representation closer to the defined protocol. add IQSendError to keep the result of sendIQ' clear --- source/Network/Xmpp/Concurrent.hs | 2 +- source/Network/Xmpp/Concurrent/IQ.hs | 8 ++++---- source/Network/Xmpp/Concurrent/Types.hs | 7 ++++++- source/Network/Xmpp/IM/Roster.hs | 21 +++++++++------------ source/Network/Xmpp/Types.hs | 3 +-- 5 files changed, 21 insertions(+), 20 deletions(-) diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 0ea5c4d..4f33461 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -117,7 +117,7 @@ handleIQ iqHands out sta = do case Map.updateLookupWithKey (\_ _ -> Nothing) (iqID iq) byID of (Nothing, _) -> return () -- We are not supposed to send an error. (Just tmvar, byID') -> do - let answer = either IQResponseError IQResponseResult iq + let answer = Just $ either IQResponseError IQResponseResult iq _ <- tryPutTMVar tmvar answer -- Don't block. writeTVar handlers (byNS, byID') where diff --git a/source/Network/Xmpp/Concurrent/IQ.hs b/source/Network/Xmpp/Concurrent/IQ.hs index 9055875..718ba03 100644 --- a/source/Network/Xmpp/Concurrent/IQ.hs +++ b/source/Network/Xmpp/Concurrent/IQ.hs @@ -49,7 +49,7 @@ sendIQ timeOut to tp lang body session = do -- TODO: Add timeout else return Nothing where doTimeOut handlers iqid var = atomically $ do - p <- tryPutTMVar var IQResponseTimeout + p <- tryPutTMVar var Nothing when p $ do (byNS, byId) <- readTVar (iqHandlers session) writeTVar handlers (byNS, Map.delete iqid byId) @@ -62,11 +62,11 @@ sendIQ' :: Maybe Integer -> Maybe LangTag -> Element -> Session - -> IO (Maybe IQResponse) + -> IO (Either IQSendError IQResponse) sendIQ' timeout to tp lang body session = do ref <- sendIQ timeout to tp lang body session - maybe (return Nothing) (fmap Just . atomically . takeTMVar) ref - + maybe (return $ Left IQSendError) (fmap (maybe (Left IQTimeOut) Right) + . atomically . takeTMVar) ref -- | Retrieves an IQ listener channel. If the namespace/'IQRequestType' is not -- already handled, a new 'TChan' is created and returned as a 'Right' value. diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index 5d27cb1..5d7eef2 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -97,7 +97,7 @@ data Session = Session -- TMVars of and TMVars for expected IQ responses (the second Text represent a -- stanza identifier. type IQHandlers = ( Map.Map (IQRequestType, Text) (TChan IQRequestTicket) - , Map.Map Text (TMVar IQResponse) + , Map.Map Text (TMVar (Maybe IQResponse)) ) -- | Contains whether or not a reply has been sent, and the IQ request body to @@ -110,3 +110,8 @@ data IQRequestTicket = IQRequestTicket -- but failed (e.g. there is a connection failure) , iqRequestBody :: IQRequest } + +-- | Error that can occur during sendIQ' +data IQSendError = IQSendError -- There was an error sending the IQ stanza + | IQTimeOut -- No answer was received during the allotted time + deriving (Show, Eq) diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs index 5e1a8aa..324d667 100644 --- a/source/Network/Xmpp/IM/Roster.hs +++ b/source/Network/Xmpp/IM/Roster.hs @@ -33,7 +33,7 @@ timeout = Just 3000000 -- 3 seconds -- | Push a roster item to the server. The values for approved and ask are -- ignored and all values for subsciption except "remove" are ignored -rosterPush :: Item -> Session -> IO (Maybe IQResponse) +rosterPush :: Item -> Session -> IO (Either IQSendError IQResponse) rosterPush item session = do let el = pickleElem xpQuery (Query Nothing [fromItem item]) sendIQ' timeout Nothing Set Nothing el session @@ -45,7 +45,7 @@ rosterAdd :: Jid -- ^ JID of the item -> Maybe Text -- ^ Name alias -> [Text] -- ^ Groups (duplicates will be removed) -> Session - -> IO (Maybe IQResponse) + -> IO (Either IQSendError IQResponse) rosterAdd j n gs session = do let el = pickleElem xpQuery (Query Nothing [QueryItem { qiApproved = Nothing @@ -67,7 +67,7 @@ rosterRemove j sess = do Just _ -> do res <- rosterPush (Item False False j Nothing Remove []) sess case res of - Just (IQResponseResult IQResult{}) -> return True + Right (IQResponseResult IQResult{}) -> return True _ -> return False -- | Retrieve the current Roster state @@ -82,7 +82,7 @@ initRoster session = do else Nothing ) session case mbRoster of Nothing -> errorM "Pontarius.Xmpp" - "Server did not return a roster" + "Server did not return a roster: " Just roster -> atomically $ writeTVar (rosterRef session) roster handleRoster :: TVar Roster -> StanzaHandler @@ -129,22 +129,19 @@ retrieveRoster mbOldRoster sess = do (pickleElem xpQuery (Query version [])) sess case res of - Nothing -> do - errorM "Pontarius.Xmpp.Roster" "getRoster: sending stanza failed" + Left e -> do + errorM "Pontarius.Xmpp.Roster" $ "getRoster: " ++ show e return Nothing - Just (IQResponseResult (IQResult{iqResultPayload = Just ros})) + Right (IQResponseResult (IQResult{iqResultPayload = Just ros})) -> case unpickleElem xpQuery ros of Left _e -> do errorM "Pontarius.Xmpp.Roster" "getRoster: invalid query element" return Nothing Right ros' -> return . Just $ toRoster ros' - Just (IQResponseResult (IQResult{iqResultPayload = Nothing})) -> do + Right (IQResponseResult (IQResult{iqResultPayload = Nothing})) -> do return mbOldRoster -- sever indicated that no roster updates are necessary - Just IQResponseTimeout -> do - errorM "Pontarius.Xmpp.Roster" "getRoster: request timed out" - return Nothing - Just (IQResponseError e) -> do + Right (IQResponseError e) -> do errorM "Pontarius.Xmpp.Roster" $ "getRoster: server returned error" ++ show e return Nothing diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 638be84..f411403 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -119,10 +119,9 @@ data IQRequest = IQRequest { iqRequestID :: !Text data IQRequestType = Get | Set deriving (Eq, Ord, Read, Show) -- | A "response" Info/Query (IQ) stanza is either an 'IQError', an IQ stanza --- of type "result" ('IQResult') or a Timeout. +-- of type "result" ('IQResult') data IQResponse = IQResponseError IQError | IQResponseResult IQResult - | IQResponseTimeout deriving Show -- | The (non-error) answer to an IQ request.