From 92b4b6e3881776844bffc98dd114b252ce248191 Mon Sep 17 00:00:00 2001 From: John Millikin Date: Sat, 17 Apr 2010 23:05:58 +0000 Subject: [PATCH] Define the 'XMPP' monad, so clients don't have to pass a stream around. --- Network/Protocol/XMPP.hs | 27 +--- Network/Protocol/XMPP/Client.hs | 146 +++++++----------- .../Protocol/XMPP/Client/Authentication.hs | 111 ++++++++----- Network/Protocol/XMPP/Component.hs | 72 ++++----- Network/Protocol/XMPP/ErrorT.hs | 66 ++++++++ Network/Protocol/XMPP/Monad.hs | 115 ++++++++++++++ Network/Protocol/XMPP/Stanza.hs | 5 +- Network/Protocol/XMPP/Stream.hs | 34 ---- network-protocol-xmpp.cabal | 4 +- 9 files changed, 354 insertions(+), 226 deletions(-) create mode 100644 Network/Protocol/XMPP/ErrorT.hs create mode 100644 Network/Protocol/XMPP/Monad.hs delete mode 100644 Network/Protocol/XMPP/Stream.hs diff --git a/Network/Protocol/XMPP.hs b/Network/Protocol/XMPP.hs index 3494a12..674142f 100644 --- a/Network/Protocol/XMPP.hs +++ b/Network/Protocol/XMPP.hs @@ -50,29 +50,18 @@ module Network.Protocol.XMPP , emptyPresence , emptyIQ - -- * Streams - , Stream + -- * The XMPP monad + , Server (..) + , XMPP + , runClient + , runComponent , putStanza , getStanza - - -- * Connecting to a server - , Server (..) - - -- ** Clients - , Client - , connectClient - , clientJID - , bindClient - - -- ** Components - , Component - , connectComponent - , componentJID - , componentStreamID + , bindJID ) where -import Network.Protocol.XMPP.JID import Network.Protocol.XMPP.Client import Network.Protocol.XMPP.Component import Network.Protocol.XMPP.Connections -import Network.Protocol.XMPP.Stream +import Network.Protocol.XMPP.JID +import Network.Protocol.XMPP.Monad import Network.Protocol.XMPP.Stanza diff --git a/Network/Protocol/XMPP/Client.hs b/Network/Protocol/XMPP/Client.hs index 8eb4ea9..6be1f21 100644 --- a/Network/Protocol/XMPP/Client.hs +++ b/Network/Protocol/XMPP/Client.hs @@ -15,11 +15,11 @@ {-# LANGUAGE OverloadedStrings #-} module Network.Protocol.XMPP.Client - ( Client - , clientJID - , connectClient - , bindClient + ( runClient + , bindJID ) where +import Control.Monad.Error (throwError) +import Control.Monad.Trans (liftIO) import Network (connectTo) import Text.XML.HXT.Arrow ((>>>)) import qualified Text.XML.HXT.Arrow as A @@ -28,48 +28,23 @@ import qualified Text.XML.HXT.DOM.XmlNode as XN import qualified System.IO as IO import Data.ByteString (ByteString) import qualified Data.Text as T -import qualified Text.XML.LibXML.SAX as SAX import qualified Network.Protocol.XMPP.Client.Authentication as A import qualified Network.Protocol.XMPP.Connections as C import qualified Network.Protocol.XMPP.Client.Features as F import qualified Network.Protocol.XMPP.Handle as H -import qualified Network.Protocol.XMPP.Stream as S -import Network.Protocol.XMPP.XML ( getTree, putTree - , element, qname - , readEventsUntil - ) import qualified Network.Protocol.XMPP.JID as J +import qualified Network.Protocol.XMPP.Monad as M +import Network.Protocol.XMPP.XML (element, qname, readEventsUntil) import Network.Protocol.XMPP.Stanza -data Client = Client - { clientJID :: J.JID - , clientStream :: ClientStream - } - -data ClientStream = ClientStream - { streamJID :: J.JID - , streamHandle :: H.Handle - , streamFeatures :: [F.Feature] - , streamParser :: SAX.Parser - } - -instance S.Stream Client where - streamNamespace _ = "jabber:client" - getTree = S.getTree . clientStream - putTree = S.putTree . clientStream - -instance S.Stream ClientStream where - streamNamespace _ = "jabber:client" - getTree s = getTree (streamHandle s) (streamParser s) - putTree s = putTree (streamHandle s) - -connectClient :: C.Server - -> J.JID -- ^ Client JID - -> T.Text -- ^ Username - -> T.Text -- ^ Password - -> IO Client -connectClient server jid username password = do +runClient :: C.Server + -> J.JID -- ^ Client JID + -> T.Text -- ^ Username + -> T.Text -- ^ Password + -> M.XMPP a + -> IO (Either M.Error a) +runClient server jid username password xmpp = do -- Open a TCP connection let C.Server sjid host port = server rawHandle <- connectTo host port @@ -77,41 +52,50 @@ connectClient server jid username password = do let handle = H.PlainHandle rawHandle -- Open the initial stream and authenticate - stream <- beginStream sjid handle - authedStream <- authenticate stream jid sjid username password - return $ Client jid authedStream - -authenticate :: ClientStream -> J.JID -> J.JID -> T.Text -> T.Text -> IO ClientStream -authenticate stream jid sjid username password = do - let mechanisms = authenticationMechanisms stream - result <- A.authenticate stream mechanisms jid sjid username password - case result of - -- TODO: throwIO some exception type? - A.Failure -> error "Authentication failure" - _ -> restartStream stream - -authenticationMechanisms :: ClientStream -> [ByteString] -authenticationMechanisms = step . streamFeatures where + M.runXMPP handle "jabber:client" $ do + features <- newStream sjid + let mechanisms = authenticationMechanisms features + tryTLS features $ do + A.authenticate mechanisms jid sjid username password + M.restartXMPP Nothing xmpp + +newStream :: J.JID -> M.XMPP [F.Feature] +newStream jid = do + M.Context h _ sax <- M.getContext + liftIO $ H.hPutBytes h $ C.xmlHeader "jabber:client" jid + liftIO $ readEventsUntil C.startOfStream h sax + F.parseFeatures `fmap` M.getTree + +tryTLS :: [F.Feature] -> M.XMPP a -> M.XMPP a +tryTLS features m + | not (streamSupportsTLS features) = m + | otherwise = do + M.putTree xmlStartTLS + M.getTree + h <- M.getHandle + tls <- liftIO $ H.startTLS h + M.restartXMPP (Just tls) m + +authenticationMechanisms :: [F.Feature] -> [ByteString] +authenticationMechanisms = step where step [] = [] step (f:fs) = case f of (F.FeatureSASL ms) -> ms _ -> step fs -bindClient :: Client -> IO J.JID -bindClient c = do +bindJID :: J.JID -> M.XMPP J.JID +bindJID jid = do -- Bind - S.putStanza c $ bindStanza . J.jidResource . clientJID $ c - bindResult <- S.getStanza c + M.putStanza . bindStanza . J.jidResource $ jid + bindResult <- M.getStanza let jidArrow = A.deep (A.hasQName (qname "urn:ietf:params:xml:ns:xmpp-bind" "jid")) >>> A.getChildren >>> A.getText - -- TODO: throwIO with exception - let Just jid = do - result <- bindResult - iq <- case result of + let maybeJID = do + iq <- case bindResult of ReceivedIQ x -> Just x _ -> Nothing @@ -119,14 +103,18 @@ bindClient c = do [] -> Nothing (str:_) -> J.parseJID (T.pack str) + returnedJID <- case maybeJID of + Just x -> return x + Nothing -> throwError $ M.InvalidBindResult bindResult + -- Session - S.putStanza c sessionStanza - S.getStanza c + M.putStanza sessionStanza + M.getStanza - S.putStanza c $ emptyPresence PresenceAvailable - S.getStanza c + M.putStanza $ emptyPresence PresenceAvailable + M.getStanza - return jid + return returnedJID bindStanza :: Maybe J.Resource -> IQ bindStanza resource = emptyIQ IQSet payload where @@ -144,30 +132,8 @@ sessionStanza = emptyIQ IQSet $ element ("", "session") [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-session")] [] -beginStream :: J.JID -> H.Handle -> IO ClientStream -beginStream jid handle = do - plain <- newStream jid handle - if streamSupportsTLS plain - then do - S.putTree plain xmlStartTLS - S.getTree plain - H.startTLS handle >>= newStream jid - else return plain - -restartStream :: ClientStream -> IO ClientStream -restartStream s = newStream (streamJID s) (streamHandle s) - -newStream :: J.JID -> H.Handle -> IO ClientStream -newStream jid h = do - parser <- SAX.mkParser - H.hPutBytes h $ C.xmlHeader "jabber:client" jid - readEventsUntil C.startOfStream h parser - features <- F.parseFeatures `fmap` getTree h parser - - return $ ClientStream jid h features parser - -streamSupportsTLS :: ClientStream -> Bool -streamSupportsTLS = any isStartTLS . streamFeatures where +streamSupportsTLS :: [F.Feature] -> Bool +streamSupportsTLS = any isStartTLS where isStartTLS (F.FeatureStartTLS _) = True isStartTLS _ = False diff --git a/Network/Protocol/XMPP/Client/Authentication.hs b/Network/Protocol/XMPP/Client/Authentication.hs index 3e05cce..c7acf29 100644 --- a/Network/Protocol/XMPP/Client/Authentication.hs +++ b/Network/Protocol/XMPP/Client/Authentication.hs @@ -13,46 +13,67 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} module Network.Protocol.XMPP.Client.Authentication - ( Result(..) + ( Result (..) , authenticate ) where -import Control.Monad.IO.Class (liftIO) +import qualified Control.Exception as Exc +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO, liftIO) +import qualified Control.Monad.Error as E import qualified Data.ByteString.Char8 as B import qualified Data.Text as T import qualified Data.Text.Encoding as TE +import Data.Typeable (Typeable) import Text.XML.HXT.Arrow ((>>>)) import qualified Text.XML.HXT.Arrow as A import qualified Text.XML.HXT.DOM.XmlNode as XN +import Text.XML.HXT.DOM.Interface (XmlTree) import qualified Network.Protocol.SASL.GNU as SASL +import qualified Network.Protocol.XMPP.Monad as M import Network.Protocol.XMPP.JID (JID, formatJID) import Network.Protocol.XMPP.XML (element, qname) -import qualified Network.Protocol.XMPP.Stream as S data Result = Success | Failure deriving (Show, Eq) -authenticate :: S.Stream stream => stream - -> [B.ByteString] -- ^ Mechanisms +data AuthException = XmppError M.Error | SaslError T.Text + deriving (Typeable, Show) + +instance Exc.Exception AuthException + +authenticate :: [B.ByteString] -- ^ Mechanisms -> JID -- ^ User JID -> JID -- ^ Server JID -> T.Text -- ^ Username -> T.Text -- ^ Password - -> IO Result -authenticate stream mechanisms userJID serverJID username password = do - let authz = formatJID userJID - let hostname = formatJID serverJID - let utf8 = TE.encodeUtf8 + -> M.XMPP () +authenticate xmppMechanisms userJID serverJID username password = xmpp where + mechanisms = map SASL.Mechanism xmppMechanisms + authz = formatJID userJID + hostname = formatJID serverJID + utf8 = TE.encodeUtf8 + + xmpp = do + ctx <- M.getContext + res <- liftIO $ Exc.try $ SASL.runSASL $ do + suggested <- SASL.clientSuggestMechanism mechanisms + case suggested of + Nothing -> saslError "No supported authentication mechanism" + Just mechanism -> authSasl ctx mechanism + case res of + Right Success -> return () + Right Failure -> E.throwError $ M.AuthenticationFailure + Left (XmppError err) -> E.throwError err + Left (SaslError err) -> E.throwError $ M.AuthenticationError err - SASL.runSASL $ do - suggested <- SASL.clientSuggestMechanism $ map SASL.Mechanism mechanisms - mechanism <- case suggested of - Just m -> return m - Nothing -> error "No supported SASL mechanisms advertised" + authSasl ctx mechanism = do let (SASL.Mechanism mechBytes) = mechanism - result <- SASL.runClient mechanism $ do + sessionResult <- SASL.runClient mechanism $ do SASL.setProperty SASL.PropertyAuthzID $ utf8 authz SASL.setProperty SASL.PropertyAuthID $ utf8 username SASL.setProperty SASL.PropertyPassword $ utf8 password @@ -60,42 +81,58 @@ authenticate stream mechanisms userJID serverJID username password = do SASL.setProperty SASL.PropertyHostname $ utf8 hostname (b64text, rc) <- SASL.step64 $ B.pack "" - liftIO $ S.putTree stream $ element ("", "auth") + putTree ctx $ element ("", "auth") [ ("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl") , ("", "mechanism", B.unpack mechBytes)] [XN.mkText $ B.unpack b64text] case rc of - SASL.Complete -> liftIO $ saslFinish stream - SASL.NeedsMore -> saslLoop stream - case result of + SASL.Complete -> saslFinish ctx + SASL.NeedsMore -> saslLoop ctx + + case sessionResult of Right x -> return x - Left err -> error $ show err + Left err -> saslError $ T.pack $ show err -saslLoop :: S.Stream s => s -> SASL.Session Result -saslLoop stream = do +saslLoop :: M.Context -> SASL.Session Result +saslLoop ctx = do challengeText <- liftIO $ A.runX ( - A.arrIO (\_ -> S.getTree stream) + A.arrIO (\_ -> getTree ctx) >>> A.getChildren >>> A.hasQName (qname "urn:ietf:params:xml:ns:xmpp-sasl" "challenge") >>> A.getChildren >>> A.getText) + when (null challengeText) $ saslError "Received empty challenge" - if null challengeText - then return Failure - else do - (b64text, rc) <- SASL.step64 $ B.pack $ concat challengeText - liftIO $ S.putTree stream $ element ("", "response") - [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")] - [XN.mkText $ B.unpack b64text] - case rc of - SASL.Complete -> liftIO $ saslFinish stream - SASL.NeedsMore -> saslLoop stream + (b64text, rc) <- SASL.step64 $ B.pack $ concat challengeText + putTree ctx $ element ("", "response") + [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")] + [XN.mkText $ B.unpack b64text] + case rc of + SASL.Complete -> saslFinish ctx + SASL.NeedsMore -> saslLoop ctx -saslFinish :: S.Stream s => s -> IO Result -saslFinish stream = do +saslFinish :: M.Context -> SASL.Session Result +saslFinish ctx = liftIO $ do successElem <- A.runX ( - A.arrIO (\_ -> S.getTree stream) + A.arrIO (\_ -> getTree ctx) >>> A.getChildren >>> A.hasQName (qname "urn:ietf:params:xml:ns:xmpp-sasl" "success")) return $ if null successElem then Failure else Success + +putTree :: M.Context -> XmlTree -> SASL.Session () +putTree ctx tree = liftIO $ do + res <- M.continueXMPP ctx $ M.putTree tree + case res of + Left err -> Exc.throwIO $ XmppError err + Right x -> return x + +getTree :: M.Context -> IO XmlTree +getTree ctx = do + res <- M.continueXMPP ctx $ M.getTree + case res of + Left err -> Exc.throwIO $ XmppError err + Right x -> return x + +saslError :: MonadIO m => T.Text -> m a +saslError = liftIO . Exc.throwIO . SaslError diff --git a/Network/Protocol/XMPP/Component.hs b/Network/Protocol/XMPP/Component.hs index 03f6eac..5ad616c 100644 --- a/Network/Protocol/XMPP/Component.hs +++ b/Network/Protocol/XMPP/Component.hs @@ -16,12 +16,11 @@ {-# LANGUAGE OverloadedStrings #-} module Network.Protocol.XMPP.Component - ( Component - , componentJID - , componentStreamID - , connectComponent + ( runComponent ) where import Control.Monad (when) +import Control.Monad.Error (throwError) +import Control.Monad.Trans (liftIO) import Data.Bits (shiftR, (.&.)) import Data.Char (intToDigit) import qualified Data.ByteString as B @@ -38,47 +37,32 @@ import qualified Text.XML.LibXML.SAX as SAX import qualified Network.Protocol.XMPP.Connections as C import qualified Network.Protocol.XMPP.Handle as H -import qualified Network.Protocol.XMPP.Stream as S -import Network.Protocol.XMPP.XML ( getTree, putTree - , element, qname - , readEventsUntil - ) +import qualified Network.Protocol.XMPP.Monad as M +import Network.Protocol.XMPP.XML (element, qname, readEventsUntil) import Network.Protocol.XMPP.JID (JID) -data Component = Component - { componentJID :: JID - , componentHandle :: H.Handle - , componentParser :: SAX.Parser - , componentStreamID :: T.Text - } - -instance S.Stream Component where - streamNamespace _ = "jabber:component:accept" - getTree s = getTree (componentHandle s) (componentParser s) - putTree s = putTree (componentHandle s) - -connectComponent :: C.Server - -> T.Text -- ^ Password - -> IO Component -connectComponent server password = do +runComponent :: C.Server + -> T.Text -- ^ Password + -> M.XMPP a + -> IO (Either M.Error a) +runComponent server password xmpp = do let C.Server jid host port = server rawHandle <- connectTo host port IO.hSetBuffering rawHandle IO.NoBuffering let handle = H.PlainHandle rawHandle - - stream <- beginStream jid handle - authenticate stream password - return stream + M.runXMPP handle "jabber:component:accept" $ do + streamID <- beginStream jid + authenticate streamID password + xmpp -beginStream :: JID -> H.Handle -> IO Component -beginStream jid h = do - parser <- SAX.mkParser - H.hPutBytes h $ C.xmlHeader "jabber:component:accept" jid - events <- readEventsUntil C.startOfStream h parser - let streamID' = case parseStreamID $ last events of - Nothing -> error "No component stream ID defined" - Just x -> x - return $ Component jid h parser streamID' +beginStream :: JID -> M.XMPP T.Text +beginStream jid = do + M.Context h _ sax <- M.getContext + liftIO $ H.hPutBytes h $ C.xmlHeader "jabber:component:accept" jid + events <- liftIO $ readEventsUntil C.startOfStream h sax + case parseStreamID $ last events of + Nothing -> throwError M.NoComponentStreamID + Just x -> return x parseStreamID :: SAX.Event -> Maybe T.Text parseStreamID (SAX.BeginElement _ attrs) = sid where @@ -92,17 +76,17 @@ parseStreamID (SAX.BeginElement _ attrs) = sid where ] parseStreamID _ = Nothing -authenticate :: Component -> T.Text -> IO () -authenticate stream password = do - let bytes = buildSecret (componentStreamID stream) password +authenticate :: T.Text -> T.Text -> M.XMPP () +authenticate streamID password = do + let bytes = buildSecret streamID password let digest = showDigest $ sha1 bytes - S.putTree stream $ element ("", "handshake") [] [XN.mkText digest] - result <- S.getTree stream + M.putTree $ element ("", "handshake") [] [XN.mkText digest] + result <- M.getTree let accepted = A.runLA $ A.getChildren >>> A.hasQName (qname "jabber:component:accept" "handshake") when (null (accepted result)) $ - error "Component handshake failed" -- TODO: throwIO + throwError M.ComponentHandshakeFailed buildSecret :: T.Text -> T.Text -> B.ByteString buildSecret sid password = bytes where diff --git a/Network/Protocol/XMPP/ErrorT.hs b/Network/Protocol/XMPP/ErrorT.hs new file mode 100644 index 0000000..3fd64cb --- /dev/null +++ b/Network/Protocol/XMPP/ErrorT.hs @@ -0,0 +1,66 @@ +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +{-# LANGUAGE TypeFamilies #-} +module Network.Protocol.XMPP.ErrorT + ( ErrorT (..) + , mapErrorT + ) where + +import Control.Monad (liftM) +import Control.Monad.Trans (MonadIO, liftIO) +import Control.Monad.Trans.Class (MonadTrans, lift) +import qualified Control.Monad.Error as E +import qualified Control.Monad.Reader as R + +-- A custom version of ErrorT, without the 'Error' class restriction. + +newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) } + +instance Functor m => Functor (ErrorT e m) where + fmap f = ErrorT . fmap (fmap f) . runErrorT + +instance Monad m => Monad (ErrorT e m) where + return = ErrorT . return . Right + (>>=) m k = ErrorT $ do + x <- runErrorT m + case x of + Left l -> return $ Left l + Right r -> runErrorT $ k r + +instance Monad m => E.MonadError (ErrorT e m) where + type E.ErrorType (ErrorT e m) = e + throwError = ErrorT . return . Left + catchError m h = ErrorT $ do + x <- runErrorT m + case x of + Left l -> runErrorT $ h l + Right r -> return $ Right r + +instance MonadTrans (ErrorT e) where + lift = ErrorT . liftM Right + +instance R.MonadReader m => R.MonadReader (ErrorT e m) where + type R.EnvType (ErrorT e m) = R.EnvType m + ask = lift R.ask + local = mapErrorT . R.local + +instance MonadIO m => MonadIO (ErrorT e m) where + liftIO = lift . liftIO + +mapErrorT :: (m (Either e a) -> n (Either e' b)) + -> ErrorT e m a + -> ErrorT e' n b +mapErrorT f m = ErrorT $ f (runErrorT m) diff --git a/Network/Protocol/XMPP/Monad.hs b/Network/Protocol/XMPP/Monad.hs new file mode 100644 index 0000000..cd1e5fb --- /dev/null +++ b/Network/Protocol/XMPP/Monad.hs @@ -0,0 +1,115 @@ +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +{-# LANGUAGE TypeFamilies #-} +module Network.Protocol.XMPP.Monad + ( XMPP (..) + , Error (..) + , Context (..) + , runXMPP + , continueXMPP + , restartXMPP + + , getHandle + , getContext + + , putTree + , getTree + + , putStanza + , getStanza + ) where +import Control.Monad.Trans (MonadIO, liftIO) +import qualified Control.Monad.Error as E +import qualified Control.Monad.Reader as R +import Data.Text (Text) +import Text.XML.HXT.DOM.Interface (XmlTree) +import qualified Text.XML.LibXML.SAX as SAX +import Network.Protocol.XMPP.ErrorT +import qualified Network.Protocol.XMPP.Handle as H +import qualified Network.Protocol.XMPP.Stanza as S +import qualified Network.Protocol.XMPP.XML as X + +data Error + = InvalidStanza XmlTree + | InvalidBindResult S.ReceivedStanza + | AuthenticationFailure + | AuthenticationError Text + | NoComponentStreamID + | ComponentHandshakeFailed + deriving (Show) + +data Context = Context H.Handle Text SAX.Parser + +newtype XMPP a = XMPP { unXMPP :: ErrorT Error (R.ReaderT Context IO) a } + +instance Functor XMPP where + fmap f = XMPP . fmap f . unXMPP + +instance Monad XMPP where + return = XMPP . return + m >>= f = XMPP $ unXMPP m >>= unXMPP . f + +instance MonadIO XMPP where + liftIO = XMPP . liftIO + +instance E.MonadError XMPP where + type E.ErrorType XMPP = Error + throwError = XMPP . E.throwError + catchError m h = XMPP $ E.catchError (unXMPP m) (unXMPP . h) + +runXMPP :: H.Handle -> Text -> XMPP a -> IO (Either Error a) +runXMPP h ns xmpp = do + sax <- SAX.mkParser + continueXMPP (Context h ns sax) xmpp + +continueXMPP :: Context -> XMPP a -> IO (Either Error a) +continueXMPP ctx xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) ctx + +restartXMPP :: Maybe H.Handle -> XMPP a -> XMPP a +restartXMPP newH xmpp = do + Context oldH ns _ <- getContext + sax <- liftIO $ SAX.mkParser + let ctx = Context (maybe oldH id newH) ns sax + XMPP $ R.local (const ctx) (unXMPP xmpp) + +getContext :: XMPP Context +getContext = XMPP R.ask + +getHandle :: XMPP H.Handle +getHandle = do + Context h _ _ <- getContext + return h + +putTree :: XmlTree -> XMPP () +putTree t = do + h <- getHandle + liftIO $ X.putTree h t + +getTree :: XMPP XmlTree +getTree = do + Context h _ sax <- getContext + liftIO $ X.getTree h sax + +putStanza :: S.Stanza a => a -> XMPP () +putStanza = putTree . S.stanzaToTree + +getStanza :: XMPP S.ReceivedStanza +getStanza = do + tree <- getTree + Context _ ns _ <- getContext + case S.treeToStanza ns tree of + Just x -> return x + Nothing -> E.throwError $ InvalidStanza tree diff --git a/Network/Protocol/XMPP/Stanza.hs b/Network/Protocol/XMPP/Stanza.hs index 406b68c..bd8960d 100644 --- a/Network/Protocol/XMPP/Stanza.hs +++ b/Network/Protocol/XMPP/Stanza.hs @@ -28,7 +28,6 @@ module Network.Protocol.XMPP.Stanza , emptyPresence , emptyIQ - , stanzaToTree , treeToStanza ) where @@ -52,6 +51,7 @@ data ReceivedStanza = ReceivedMessage Message | ReceivedPresence Presence | ReceivedIQ IQ + deriving (Show) data Message = Message { messageType :: MessageType @@ -61,6 +61,7 @@ data Message = Message , messageLang :: Maybe T.Text , messagePayloads :: [XmlTree] } + deriving (Show) instance Stanza Message where stanzaTo = messageTo @@ -102,6 +103,7 @@ data Presence = Presence , presenceLang :: Maybe T.Text , presencePayloads :: [XmlTree] } + deriving (Show) instance Stanza Presence where stanzaTo = presenceTo @@ -149,6 +151,7 @@ data IQ = IQ , iqLang :: Maybe T.Text , iqPayload :: XmlTree } + deriving (Show) instance Stanza IQ where stanzaTo = iqTo diff --git a/Network/Protocol/XMPP/Stream.hs b/Network/Protocol/XMPP/Stream.hs deleted file mode 100644 index 1458a21..0000000 --- a/Network/Protocol/XMPP/Stream.hs +++ /dev/null @@ -1,34 +0,0 @@ --- Copyright (C) 2010 John Millikin --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program. If not, see . - -module Network.Protocol.XMPP.Stream - ( Stream (..) - , putStanza - , getStanza - ) where -import qualified Data.Text as T -import Text.XML.HXT.DOM.Interface (XmlTree) -import qualified Network.Protocol.XMPP.Stanza as S - -class Stream a where - streamNamespace :: a -> T.Text - putTree :: a -> XmlTree -> IO () - getTree :: a -> IO XmlTree - -putStanza :: (Stream stream, S.Stanza stanza) => stream -> stanza -> IO () -putStanza stream = putTree stream . S.stanzaToTree - -getStanza :: Stream stream => stream -> IO (Maybe S.ReceivedStanza) -getStanza stream = S.treeToStanza (streamNamespace stream) `fmap` getTree stream diff --git a/network-protocol-xmpp.cabal b/network-protocol-xmpp.cabal index c2302c6..f5581a8 100644 --- a/network-protocol-xmpp.cabal +++ b/network-protocol-xmpp.cabal @@ -31,6 +31,7 @@ library , gsasl >= 0.3 && < 0.4 , network >= 2.2 && < 2.3 , transformers >= 0.2 && < 0.3 + , monads-tf >= 0.1 && < 0.2 exposed-modules: Network.Protocol.XMPP @@ -41,8 +42,9 @@ library Network.Protocol.XMPP.Client.Features Network.Protocol.XMPP.Component Network.Protocol.XMPP.Connections + Network.Protocol.XMPP.ErrorT Network.Protocol.XMPP.Handle Network.Protocol.XMPP.JID + Network.Protocol.XMPP.Monad Network.Protocol.XMPP.Stanza - Network.Protocol.XMPP.Stream Network.Protocol.XMPP.XML -- 2.45.2