M Network/Protocol/XMPP.hs => Network/Protocol/XMPP.hs +8 -19
@@ 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
M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +56 -90
@@ 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
M Network/Protocol/XMPP/Client/Authentication.hs => Network/Protocol/XMPP/Client/Authentication.hs +74 -37
@@ 13,46 13,67 @@
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
+{-# 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
M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +28 -44
@@ 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
A Network/Protocol/XMPP/ErrorT.hs => Network/Protocol/XMPP/ErrorT.hs +66 -0
@@ 0,0 1,66 @@
+-- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>
+--
+-- 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 <http://www.gnu.org/licenses/>.
+
+{-# 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)
A Network/Protocol/XMPP/Monad.hs => Network/Protocol/XMPP/Monad.hs +115 -0
@@ 0,0 1,115 @@
+-- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>
+--
+-- 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 <http://www.gnu.org/licenses/>.
+
+{-# 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
M Network/Protocol/XMPP/Stanza.hs => Network/Protocol/XMPP/Stanza.hs +4 -1
@@ 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
D Network/Protocol/XMPP/Stream.hs => Network/Protocol/XMPP/Stream.hs +0 -34
@@ 1,34 0,0 @@
--- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>
---
--- 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 <http://www.gnu.org/licenses/>.
-
-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
M network-protocol-xmpp.cabal => network-protocol-xmpp.cabal +3 -1
@@ 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