From 730b3ce61a93c1fa0a3c2c4a1a1357971d6d1c1f Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 7 Sep 2014 15:35:38 +0200 Subject: [PATCH] add IQRequestClass, sendIQRequest, runIQHandler --- pontarius-xmpp.cabal | 3 +- source/Network/Xmpp.hs | 5 ++ source/Network/Xmpp/Concurrent/IQ.hs | 78 ++++++++++++++++++++++++- source/Network/Xmpp/Concurrent/Types.hs | 4 +- 4 files changed, 85 insertions(+), 5 deletions(-) diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 900e242..af8c130 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -48,6 +48,7 @@ Library , cryptohash-cryptoapi >=0.1 , data-default >=0.2 , dns >=0.3.0 + , exceptions >= 0.6 , hslogger >=1.1.0 , iproute >=1.2.4 , lens-family @@ -63,7 +64,7 @@ Library , stringprep >=1.0.0 , text >=0.11.1.5 , tls >=1.2 - , transformers >=0.2.2.0 + , transformers >=0.4 , unbounded-delays >=0.1 , void >=0.5.5 , x509-system >=1.4 diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 0b489f2..657ce94 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -194,11 +194,15 @@ module Network.Xmpp , IQResult(..) , IQError(..) , IQResponse(..) + , IQRequestClass(..) + , IQRequestHandler , sendIQ , sendIQ' + , sendIQRequest , answerIQ , iqResult , listenIQ + , runIQHandler , unlistenIQ -- * Errors , StanzaErrorType(..) @@ -208,6 +212,7 @@ module Network.Xmpp , StanzaErrorCondition(..) , SaslFailure(..) , IQSendError(..) + , IQRequestError(..) -- * Threads , dupSession -- * Lenses diff --git a/source/Network/Xmpp/Concurrent/IQ.hs b/source/Network/Xmpp/Concurrent/IQ.hs index 68a755f..6e94b0e 100644 --- a/source/Network/Xmpp/Concurrent/IQ.hs +++ b/source/Network/Xmpp/Concurrent/IQ.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Concurrent.IQ where @@ -6,12 +9,20 @@ import Control.Concurrent (forkIO) import Control.Concurrent.STM import Control.Concurrent.Thread.Delay (delay) import Control.Monad +import Control.Monad.Except +import Control.Monad.Trans import qualified Data.Map as Map +import Data.Maybe import Data.Text (Text) +import Data.XML.Pickle import Data.XML.Types +import Lens.Family2 (toListOf, (&), (^.)) import Network.Xmpp.Concurrent.Basic import Network.Xmpp.Concurrent.Types +import Network.Xmpp.Lens +import Network.Xmpp.Stanza import Network.Xmpp.Types +import System.Log.Logger -- | Sends an IQ, returns an STM action that returns the first inbound IQ with a -- matching ID that has type @result@ or @error@ or Nothing if the timeout was @@ -30,9 +41,9 @@ sendIQ :: Maybe Integer -- ^ Timeout . When the timeout is reached the response -> [ExtendedAttribute] -- ^ Additional stanza attributes -> Session -> IO (Either XmppFailure (STM (Maybe (Annotated IQResponse)))) -sendIQ timeOut to tp lang body attrs session = do +sendIQ timeOut t tp lang body attrs session = do newId <- idGenerator session - j <- case to of + j <- case t of Just t -> return $ Right t Nothing -> Left <$> getJid session ref <- atomically $ do @@ -41,7 +52,7 @@ sendIQ timeOut to tp lang body attrs session = do (byNS, byId) <- readTVar (iqHandlers session) writeTVar (iqHandlers session) (byNS, Map.insert newId value byId) return resRef - res <- sendStanza (IQRequestS $ IQRequest newId Nothing to lang tp body attrs) + res <- sendStanza (IQRequestS $ IQRequest newId Nothing t lang tp body attrs) session case res of Right () -> do @@ -138,3 +149,64 @@ answerIQ :: IQRequestTicket -> [ExtendedAttribute] -> IO (Maybe (Either XmppFailure ())) answerIQ = answerTicket + + +-- Class + +class IQRequestClass a where + data IQResponseType a + pickleRequest :: PU Element a + pickleResponse :: PU [Element] (IQResponseType a) + requestType :: a -> IQRequestType + requestNamespace :: a -> Text + +data IQRequestError = IQRequestSendError XmppFailure + | IQRequestTimeout + | IQRequestUnpickleError UnpickleError + deriving Show + +-- | Send an IQ request. May throw IQSendError, UnpickleError, + +sendIQRequest :: (IQRequestClass a, MonadError IQRequestError m, MonadIO m) => + Maybe Integer + -> Maybe Jid + -> a + -> Session + -> m (Either IQError (IQResponseType a)) +sendIQRequest timeout t req con = do + mbRes <- liftIO $ sendIQ' timeout t (requestType req) Nothing + (pickle pickleRequest req) [] con + case mbRes of + Left (IQTimeOut) -> throwError IQRequestTimeout + Left (IQSendError e) -> throwError $ IQRequestSendError e + Right (IQResponseError e) -> return $ Left e + Right (IQResponseResult res) -> + case unpickle pickleResponse (res & toListOf payloadT) of + Left e -> throwError $ IQRequestUnpickleError e + Right r -> return $ Right r + +type IQRequestHandler a = a -> IO (Either StanzaError (IQResponseType a)) + +runIQHandler :: IQRequestClass a => + IQRequestHandler a + -> Session + -> IO () +runIQHandler (handler :: a -> IO (Either StanzaError (IQResponseType a))) + sess = do + let prx = undefined :: a + ns = (requestNamespace prx) + mbChan <- listenIQ (requestType prx) ns sess + case mbChan of + Left _ -> warningM "Pontarius.Xmpp" $ "IQ namespace " ++ show ns + ++ " is already handled" + Right getNext -> forever $ do + ticket <- atomically getNext + case unpickle pickleRequest (iqRequestBody ticket ^. payload) of + Left _ -> answerIQ ticket (Left $ mkStanzaError BadRequest) [] + Right req -> do + res <- handler req + case res of + Left e -> answerIQ ticket (Left e) [] + Right r -> do + let answer = (pickle pickleResponse r) + answerIQ ticket (Right $ listToMaybe answer ) [] diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index 0684711..91460ff 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -168,4 +168,6 @@ data IQRequestTicket = IQRequestTicket data IQSendError = IQSendError XmppFailure -- There was an error sending the IQ -- stanza | IQTimeOut -- No answer was received during the allotted time - deriving (Show, Eq) + deriving (Show, Eq, Typeable) + +instance Ex.Exception IQSendError