From a205b23a6bcf06dc7e8037f9c477bd1bd16c9058 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Sun, 6 Jan 2013 00:13:32 +0100 Subject: [PATCH] Hide `Context', add exports, extend documentation As mentioned in #pontarius, `Context' is simply a bunch of thread management features, and users that want that can build their own on top of the `Connection' layer. The benefit of hiding `Context' is that it makes the API clearer, and significantly decreases the complexity of the library. As the `Basic' module is simply an interface to `Connection', it was renamed to `Connection'. The old `Connection' module was moved to `Connection_'. Exported the types of the fields of `Connection' (such as `ConnectionState' and `ConnectionHandle' (previously `HandleLike'). --- pontarius-xmpp.cabal | 4 +- source/Network/Xmpp.hs | 13 +- source/Network/Xmpp/Basic.hs | 29 -- source/Network/Xmpp/Bind.hs | 4 +- source/Network/Xmpp/Concurrent/Channels.hs | 2 +- .../Network/Xmpp/Concurrent/Channels/Types.hs | 3 +- source/Network/Xmpp/Concurrent/Monad.hs | 6 +- source/Network/Xmpp/Concurrent/Threads.hs | 6 +- source/Network/Xmpp/Connection.hs | 308 +++--------------- source/Network/Xmpp/Connection_.hs | 266 +++++++++++++++ source/Network/Xmpp/Sasl.hs | 6 +- source/Network/Xmpp/Sasl/Common.hs | 2 +- .../Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs | 4 +- source/Network/Xmpp/Sasl/Mechanisms/Plain.hs | 2 +- source/Network/Xmpp/Session.hs | 34 +- source/Network/Xmpp/Stream.hs | 26 +- source/Network/Xmpp/Tls.hs | 22 +- source/Network/Xmpp/Types.hs | 75 ++--- source/Network/Xmpp/Xep/InbandRegistration.hs | 2 +- source/Network/Xmpp/Xep/ServiceDiscovery.hs | 2 +- 20 files changed, 404 insertions(+), 412 deletions(-) delete mode 100644 source/Network/Xmpp/Basic.hs create mode 100644 source/Network/Xmpp/Connection_.hs diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 76c2f53..0f8e883 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -54,8 +54,8 @@ Library , stringprep >=0.1.3 , hslogger >=1.1.0 Exposed-modules: Network.Xmpp + , Network.Xmpp.Connection , Network.Xmpp.IM - , Network.Xmpp.Basic Other-modules: Data.Conduit.Tls , Network.Xmpp.Bind , Network.Xmpp.Concurrent @@ -68,7 +68,7 @@ Library , Network.Xmpp.Concurrent.Channels.Types , Network.Xmpp.Concurrent.Threads , Network.Xmpp.Concurrent.Monad - , Network.Xmpp.Connection + , Network.Xmpp.Connection_ , Network.Xmpp.IM.Message , Network.Xmpp.IM.Presence , Network.Xmpp.Jid diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index b4d0b5d..7184ba2 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -1,7 +1,5 @@ -- | -- Module: $Header$ --- Description: RFC 6120 (XMPP: Core). --- License: Apache License 2.0 -- -- Maintainer: info@jonkri.com -- Stability: unstable @@ -16,9 +14,12 @@ -- persistent XML streams among a distributed network of globally addressable, -- presence-aware clients and servers. -- --- Pontarius is an XMPP client library, implementing the core capabilities of --- XMPP (RFC 6120): setup and teardown of XML streams, channel encryption, +-- Pontarius XMPP is an XMPP client library, implementing the core capabilities +-- of XMPP (RFC 6120): setup and teardown of XML streams, channel encryption, -- authentication, error handling, and communication primitives for messaging. +-- +-- For low-level access to Pontarius XMPP, see the "Network.Xmpp.Connection" +-- module. {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} @@ -142,6 +143,7 @@ module Network.Xmpp , StreamErrorInfo(..) , StreamErrorCondition(..) , TlsFailure(..) + , AuthFailure(..) ) where @@ -152,11 +154,12 @@ import Network.Xmpp.Bind import Network.Xmpp.Concurrent import Network.Xmpp.Concurrent.Channels import Network.Xmpp.Concurrent.Types -import Network.Xmpp.Connection +import Network.Xmpp.Connection_ import Network.Xmpp.Marshal import Network.Xmpp.Message import Network.Xmpp.Presence import Network.Xmpp.Sasl +import Network.Xmpp.Sasl.Types import Network.Xmpp.Session import Network.Xmpp.Stream import Network.Xmpp.Tls diff --git a/source/Network/Xmpp/Basic.hs b/source/Network/Xmpp/Basic.hs deleted file mode 100644 index d5129c9..0000000 --- a/source/Network/Xmpp/Basic.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Network.Xmpp.Basic - ( Connection(..) - , ConnectionState(..) - , connectTcp - , newSession - , withConnection - , startTls - , simpleAuth - , auth - , scramSha1 - , digestMd5 - , plain - , closeConnection - , pushStanza - , pullStanza - , closeConnection - , endContext - , setConnectionClosedHandler - ) - - where - -import Network.Xmpp.Connection -import Network.Xmpp.Sasl -import Network.Xmpp.Session -import Network.Xmpp.Stream -import Network.Xmpp.Tls -import Network.Xmpp.Types -import Network.Xmpp.Concurrent \ No newline at end of file diff --git a/source/Network/Xmpp/Bind.hs b/source/Network/Xmpp/Bind.hs index 0e01058..4d180ce 100644 --- a/source/Network/Xmpp/Bind.hs +++ b/source/Network/Xmpp/Bind.hs @@ -11,7 +11,7 @@ import Data.Text as Text import Data.XML.Pickle import Data.XML.Types -import Network.Xmpp.Connection +import Network.Xmpp.Connection_ import Network.Xmpp.Pickle import Network.Xmpp.Types @@ -38,7 +38,7 @@ xmppBind rsrc c = do -> return jid | otherwise -> throw StreamOtherFailure -- TODO: Log: ("Bind couldn't unpickle JID from " ++ show answer) - withConnection (modify $ \s -> s{sJid = Just jid}) c + withConnection (modify $ \s -> s{cJid = Just jid}) c return jid where -- Extracts the character data in the `jid' element. diff --git a/source/Network/Xmpp/Concurrent/Channels.hs b/source/Network/Xmpp/Concurrent/Channels.hs index c84f896..0e12fc0 100644 --- a/source/Network/Xmpp/Concurrent/Channels.hs +++ b/source/Network/Xmpp/Concurrent/Channels.hs @@ -109,4 +109,4 @@ writeWorker stCh writeR = forever $ do unless r $ do atomically $ unGetTChan stCh next -- If the writing failed, the -- connection is dead. - threadDelay 250000 -- Avoid free spinning. + threadDelay 250000 -- Avoid free spinning. \ No newline at end of file diff --git a/source/Network/Xmpp/Concurrent/Channels/Types.hs b/source/Network/Xmpp/Concurrent/Channels/Types.hs index 1648cea..ca0cd3d 100644 --- a/source/Network/Xmpp/Concurrent/Channels/Types.hs +++ b/source/Network/Xmpp/Concurrent/Channels/Types.hs @@ -8,8 +8,7 @@ import Data.Text (Text) import Network.Xmpp.Concurrent.Types import Network.Xmpp.Types --- | The @Session@ object holds the current state of the XMPP connection, and is --- thus necessary for any interaction with it. +-- | A concurrent interface to Pontarius XMPP. data Session = Session { context :: Context , stanzaCh :: TChan Stanza -- All stanzas diff --git a/source/Network/Xmpp/Concurrent/Monad.hs b/source/Network/Xmpp/Concurrent/Monad.hs index c6edf44..ac15313 100644 --- a/source/Network/Xmpp/Concurrent/Monad.hs +++ b/source/Network/Xmpp/Concurrent/Monad.hs @@ -9,7 +9,7 @@ import qualified Control.Exception.Lifted as Ex import Control.Monad.Reader import Network.Xmpp.Concurrent.Types -import Network.Xmpp.Connection +import Network.Xmpp.Connection_ @@ -71,8 +71,8 @@ modifyHandlers f session = atomically $ modifyTVar (eventHandlers session) f writeTVar var (f x) -- | Sets the handler to be executed when the server connection is closed. -setConnectionClosedHandler :: (StreamFailure -> Context -> IO ()) -> Context -> IO () -setConnectionClosedHandler eh session = do +setConnectionClosedHandler_ :: (StreamFailure -> Context -> IO ()) -> Context -> IO () +setConnectionClosedHandler_ eh session = do modifyHandlers (\s -> s{connectionClosedHandler = \e -> eh e session}) session diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs index f1ca0b8..1ff2ff3 100644 --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -16,7 +16,7 @@ import Control.Monad.State.Strict import qualified Data.ByteString as BS import Network.Xmpp.Concurrent.Types -import Network.Xmpp.Connection +import Network.Xmpp.Connection_ import Control.Concurrent.STM.TMVar @@ -35,7 +35,7 @@ readWorker onStanza onConnectionClosed stateRef = -- necessarily be interruptible s <- atomically $ do con <- readTMVar stateRef - state <- sConnectionState <$> readTMVar con + state <- cState <$> readTMVar con when (state == ConnectionClosed) retry return con @@ -81,7 +81,7 @@ startThreadsWith :: (Stanza -> IO ()) TMVar (TMVar Connection), ThreadId) startThreadsWith stanzaHandler eh con = do - read <- withConnection' (gets $ cSend. cHand) con + read <- withConnection' (gets $ cSend. cHandle) con writeLock <- newTMVarIO read conS <- newTMVarIO con -- lw <- forkIO $ writeWorker outC writeLock diff --git a/source/Network/Xmpp/Connection.hs b/source/Network/Xmpp/Connection.hs index 1f62a3b..d0ed75e 100644 --- a/source/Network/Xmpp/Connection.hs +++ b/source/Network/Xmpp/Connection.hs @@ -1,265 +1,43 @@ -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} - -module Network.Xmpp.Connection where - -import Control.Applicative((<$>)) -import Control.Concurrent (forkIO, threadDelay) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Class ---import Control.Monad.Trans.Resource -import qualified Control.Exception.Lifted as Ex -import qualified GHC.IO.Exception as GIE -import Control.Monad.State.Strict - -import Data.ByteString as BS -import Data.ByteString.Char8 as BSC8 -import Data.Conduit -import Data.Conduit.Binary as CB -import Data.Conduit.Internal as DCI -import qualified Data.Conduit.List as CL -import Data.IORef -import Data.Text(Text) -import qualified Data.Text as T -import Data.XML.Pickle -import Data.XML.Types - -import Network -import Network.Xmpp.Types -import Network.Xmpp.Marshal -import Network.Xmpp.Pickle - -import System.IO - -import Text.Xml.Stream.Elements -import Text.XML.Stream.Parse as XP -import Text.XML.Unresolved(InvalidEventStream(..)) - -import System.Log.Logger -import Data.ByteString.Base64 - -import Control.Concurrent.STM.TMVar - - --- Enable/disable debug output --- This will dump all incoming and outgoing network taffic to the console, --- prefixed with "in: " and "out: " respectively -debug :: Bool -debug = False - -pushElement :: Element -> StateT Connection IO Bool -pushElement x = do - send <- gets (cSend . cHand) - liftIO . send $ renderElement x - --- | Encode and send stanza -pushStanza :: Stanza -> TMVar Connection -> IO Bool -pushStanza s = withConnection' . pushElement $ pickleElem xpStanza s - --- XML documents and XMPP streams SHOULD be preceeded by an XML declaration. --- UTF-8 is the only supported XMPP encoding. The standalone document --- declaration (matching "SDDecl" in the XML standard) MUST NOT be included in --- XMPP streams. RFC 6120 defines XMPP only in terms of XML 1.0. -pushXmlDecl :: StateT Connection IO Bool -pushXmlDecl = do - con <- gets cHand - liftIO $ (cSend con) "" - -pushOpenElement :: Element -> StateT Connection IO Bool -pushOpenElement e = do - sink <- gets (cSend . cHand ) - liftIO . sink $ renderOpenElement e - --- `Connect-and-resumes' the given sink to the connection source, and pulls a --- `b' value. -runEventsSink :: Sink Event IO b -> StateT Connection IO b -runEventsSink snk = do - source <- gets cEventSource - (src', r) <- lift $ source $$++ snk - modify (\s -> s{cEventSource = src'}) - return r - -pullElement :: StateT Connection IO Element -pullElement = do - Ex.catches (do - e <- runEventsSink (elements =$ await) - case e of - Nothing -> liftIO $ Ex.throwIO StreamOtherFailure - Just r -> return r - ) - [ Ex.Handler (\StreamEnd -> Ex.throwIO StreamEndFailure) - , Ex.Handler (\(InvalidXmppXml s) -- Invalid XML `Event' encountered, or missing element close tag - -> liftIO . Ex.throwIO $ StreamOtherFailure) -- TODO: Log: s - , Ex.Handler $ \(e :: InvalidEventStream) -- xml-conduit exception - -> liftIO . Ex.throwIO $ StreamOtherFailure -- TODO: Log: (show e) - ] - --- Pulls an element and unpickles it. -pullUnpickle :: PU [Node] a -> StateT Connection IO a -pullUnpickle p = do - res <- unpickleElem p <$> pullElement - case res of - Left e -> liftIO $ Ex.throwIO e - Right r -> return r - --- | Pulls a stanza (or stream error) from the stream. Throws an error on a stream --- error. -pullStanza :: TMVar Connection -> IO Stanza -pullStanza = withConnection' $ do - res <- pullUnpickle xpStreamStanza - case res of - Left e -> liftIO . Ex.throwIO $ StreamErrorFailure e - Right r -> return r - --- Performs the given IO operation, catches any errors and re-throws everything --- except 'ResourceVanished' and IllegalOperation, in which case it will return False instead -catchPush :: IO () -> IO Bool -catchPush p = Ex.catch - (p >> return True) - (\e -> case GIE.ioe_type e of - GIE.ResourceVanished -> return False - GIE.IllegalOperation -> return False - _ -> Ex.throwIO e - ) - --- -- Connection state used when there is no connection. -xmppNoConnection :: Connection -xmppNoConnection = Connection - { cHand = Hand { cSend = \_ -> return False - , cRecv = \_ -> Ex.throwIO - $ StreamOtherFailure - , cFlush = return () - , cClose = return () - } - , cEventSource = DCI.ResumableSource zeroSource (return ()) - , sFeatures = SF Nothing [] [] - , sConnectionState = ConnectionClosed - , sHostname = Nothing - , sJid = Nothing - , sStreamLang = Nothing - , sStreamId = Nothing - , sPreferredLang = Nothing - , sToJid = Nothing - , sJidWhenPlain = False - , sFrom = Nothing - } - where - zeroSource :: Source IO output - zeroSource = liftIO . Ex.throwIO $ StreamOtherFailure - --- Connects to the given hostname on port 5222 (TODO: Make this dynamic) and --- updates the XmppConMonad Connection state. -connectTcpRaw :: HostName -> PortID -> Text -> IO (TMVar Connection) -connectTcpRaw host port hostname = do - let PortNumber portNumber = port - debugM "Pontarius.Xmpp" $ "Connecting to " ++ host ++ " on port " ++ - (show portNumber) ++ " through the realm " ++ (T.unpack hostname) ++ "." - h <- connectTo host port - debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle." - hSetBuffering h NoBuffering - let eSource = DCI.ResumableSource ((sourceHandle h $= logConduit) $= XP.parseBytes def) - (return ()) - let hand = Hand { cSend = \d -> do - let d64 = encode d - debugM "Pontarius.Xmpp" $ "Sending TCP data: " ++ - (BSC8.unpack d64) ++ "." - catchPush $ BS.hPut h d - , cRecv = \n -> do - d <- BS.hGetSome h n - let d64 = encode d - debugM "Pontarius.Xmpp" $ "Received TCP data: " ++ - (BSC8.unpack d64) ++ "." - return d - , cFlush = hFlush h - , cClose = hClose h - } - let con = Connection - { cHand = hand - , cEventSource = eSource - , sFeatures = (SF Nothing [] []) - , sConnectionState = ConnectionPlain - , sHostname = (Just hostname) - , sJid = Nothing - , sPreferredLang = Nothing -- TODO: Allow user to set - , sStreamLang = Nothing - , sStreamId = Nothing - , sToJid = Nothing -- TODO: Allow user to set - , sJidWhenPlain = False -- TODO: Allow user to set - , sFrom = Nothing - } - mkConnection con - where - logConduit :: Conduit ByteString IO ByteString - logConduit = CL.mapM $ \d -> do - let d64 = encode d - debugM "Pontarius.Xmpp" $ "Received TCP data: " ++ (BSC8.unpack d64) ++ - "." - return d - - --- Closes the connection and updates the XmppConMonad Connection state. -killConnection :: TMVar Connection -> IO (Either Ex.SomeException ()) -killConnection = withConnection $ do - cc <- gets (cClose . cHand) - err <- liftIO $ (Ex.try cc :: IO (Either Ex.SomeException ())) - put xmppNoConnection - return err - --- Sends an IQ request and waits for the response. If the response ID does not --- match the outgoing ID, an error is thrown. -pushIQ' :: StanzaId - -> Maybe Jid - -> IQRequestType - -> Maybe LangTag - -> Element - -> TMVar Connection - -> IO (Either IQError IQResult) -pushIQ' iqID to tp lang body con = do - pushStanza (IQRequestS $ IQRequest iqID Nothing to lang tp body) con - res <- pullStanza con - case res of - IQErrorS e -> return $ Left e - IQResultS r -> do - unless - (iqID == iqResultID r) . liftIO . Ex.throwIO $ - StreamOtherFailure - -- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++ - -- " /= " ++ show (iqResultID r) ++ " .") - return $ Right r - _ -> liftIO $ Ex.throwIO StreamOtherFailure - -- TODO: Log: "sendIQ': unexpected stanza type " - --- | Send "" and wait for the server to finish processing and to --- close the connection. Any remaining elements from the server and whether or --- not we received a element from the server is returned. -closeStreams :: TMVar Connection -> IO ([Element], Bool) -closeStreams = withConnection $ do - send <- gets (cSend . cHand) - cc <- gets (cClose . cHand) - liftIO $ send "" - void $ liftIO $ forkIO $ do - threadDelay 3000000 - (Ex.try cc) :: IO (Either Ex.SomeException ()) - return () - collectElems [] - where - -- Pulls elements from the stream until the stream ends, or an error is - -- raised. - collectElems :: [Element] -> StateT Connection IO ([Element], Bool) - collectElems es = do - result <- Ex.try pullElement - case result of - Left StreamEndFailure -> return (es, True) - Left _ -> return (es, False) - Right e -> collectElems (e:es) - -debugConduit :: Pipe l ByteString ByteString u IO b -debugConduit = forever $ do - s' <- await - case s' of - Just s -> do - liftIO $ BS.putStrLn (BS.append "in: " s) - yield s - Nothing -> return () +-- | +-- Module: $Header$ +-- +-- Maintainer: info@jonkri.com +-- Stability: unstable +-- Portability: portable +-- +-- This module allows for low-level access to Pontarius XMPP. Generally, the +-- "Network.Xmpp" module should be used instead. +-- +-- The 'Connection' object provides the most low-level access to the XMPP +-- stream: a simple and single-threaded interface which exposes the conduit +-- 'Event' source, as well as the input and output byte streams. Custom stateful +-- 'Connection' functions can be executed using 'withConnection'. +-- +-- The TLS, SASL, and 'Session' functionalities of Pontarius XMPP are built on +-- top of this API. + +module Network.Xmpp.Connection + ( Connection(..) + , ConnectionState(..) + , ConnectionHandle(..) + , ServerFeatures(..) + , connect + , withConnection + , startTls + , simpleAuth + , auth + , pushStanza + , pullStanza + , closeConnection + , newSession + ) + + where + +import Network.Xmpp.Connection_ +import Network.Xmpp.Sasl +import Network.Xmpp.Session +import Network.Xmpp.Stream +import Network.Xmpp.Tls +import Network.Xmpp.Types +import Network.Xmpp.Concurrent \ No newline at end of file diff --git a/source/Network/Xmpp/Connection_.hs b/source/Network/Xmpp/Connection_.hs new file mode 100644 index 0000000..8317ef1 --- /dev/null +++ b/source/Network/Xmpp/Connection_.hs @@ -0,0 +1,266 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Xmpp.Connection_ where + +import Control.Applicative((<$>)) +import Control.Concurrent (forkIO, threadDelay) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +--import Control.Monad.Trans.Resource +import qualified Control.Exception.Lifted as Ex +import qualified GHC.IO.Exception as GIE +import Control.Monad.State.Strict + +import Data.ByteString as BS +import Data.ByteString.Char8 as BSC8 +import Data.Conduit +import Data.Conduit.Binary as CB +import Data.Conduit.Internal as DCI +import qualified Data.Conduit.List as CL +import Data.IORef +import Data.Text(Text) +import qualified Data.Text as T +import Data.XML.Pickle +import Data.XML.Types + +import Network +import Network.Xmpp.Types +import Network.Xmpp.Marshal +import Network.Xmpp.Pickle + +import System.IO + +import Text.Xml.Stream.Elements +import Text.XML.Stream.Parse as XP +import Text.XML.Unresolved(InvalidEventStream(..)) + +import System.Log.Logger +import Data.ByteString.Base64 + +import Control.Concurrent.STM.TMVar + + +-- Enable/disable debug output +-- This will dump all incoming and outgoing network taffic to the console, +-- prefixed with "in: " and "out: " respectively +debug :: Bool +debug = False + +pushElement :: Element -> StateT Connection IO Bool +pushElement x = do + send <- gets (cSend . cHandle) + liftIO . send $ renderElement x + +-- | Encode and send stanza +pushStanza :: Stanza -> TMVar Connection -> IO Bool +pushStanza s = withConnection' . pushElement $ pickleElem xpStanza s + +-- XML documents and XMPP streams SHOULD be preceeded by an XML declaration. +-- UTF-8 is the only supported XMPP encoding. The standalone document +-- declaration (matching "SDDecl" in the XML standard) MUST NOT be included in +-- XMPP streams. RFC 6120 defines XMPP only in terms of XML 1.0. +pushXmlDecl :: StateT Connection IO Bool +pushXmlDecl = do + con <- gets cHandle + liftIO $ (cSend con) "" + +pushOpenElement :: Element -> StateT Connection IO Bool +pushOpenElement e = do + sink <- gets (cSend . cHandle) + liftIO . sink $ renderOpenElement e + +-- `Connect-and-resumes' the given sink to the connection source, and pulls a +-- `b' value. +runEventsSink :: Sink Event IO b -> StateT Connection IO b +runEventsSink snk = do + source <- gets cEventSource + (src', r) <- lift $ source $$++ snk + modify (\s -> s{cEventSource = src'}) + return r + +pullElement :: StateT Connection IO Element +pullElement = do + Ex.catches (do + e <- runEventsSink (elements =$ await) + case e of + Nothing -> liftIO $ Ex.throwIO StreamOtherFailure + Just r -> return r + ) + [ Ex.Handler (\StreamEnd -> Ex.throwIO StreamEndFailure) + , Ex.Handler (\(InvalidXmppXml s) -- Invalid XML `Event' encountered, or missing element close tag + -> liftIO . Ex.throwIO $ StreamOtherFailure) -- TODO: Log: s + , Ex.Handler $ \(e :: InvalidEventStream) -- xml-conduit exception + -> liftIO . Ex.throwIO $ StreamOtherFailure -- TODO: Log: (show e) + ] + +-- Pulls an element and unpickles it. +pullUnpickle :: PU [Node] a -> StateT Connection IO a +pullUnpickle p = do + res <- unpickleElem p <$> pullElement + case res of + Left e -> liftIO $ Ex.throwIO e + Right r -> return r + +-- | Pulls a stanza (or stream error) from the stream. Throws an error on a stream +-- error. +pullStanza :: TMVar Connection -> IO Stanza +pullStanza = withConnection' $ do + res <- pullUnpickle xpStreamStanza + case res of + Left e -> liftIO . Ex.throwIO $ StreamErrorFailure e + Right r -> return r + +-- Performs the given IO operation, catches any errors and re-throws everything +-- except 'ResourceVanished' and IllegalOperation, in which case it will return False instead +catchPush :: IO () -> IO Bool +catchPush p = Ex.catch + (p >> return True) + (\e -> case GIE.ioe_type e of + GIE.ResourceVanished -> return False + GIE.IllegalOperation -> return False + _ -> Ex.throwIO e + ) + +-- Connection state used when there is no connection. +xmppNoConnection :: Connection +xmppNoConnection = Connection + { cHandle = ConnectionHandle { cSend = \_ -> return False + , cRecv = \_ -> Ex.throwIO + StreamOtherFailure + , cFlush = return () + , cClose = return () + } + , cEventSource = DCI.ResumableSource zeroSource (return ()) + , cFeatures = SF Nothing [] [] + , cState = ConnectionClosed + , cHostName = Nothing + , cJid = Nothing + , cStreamLang = Nothing + , cStreamId = Nothing + , cPreferredLang = Nothing + , cToJid = Nothing + , cJidWhenPlain = False + , cFrom = Nothing + } + where + zeroSource :: Source IO output + zeroSource = liftIO . Ex.throwIO $ StreamOtherFailure + +connectTcp :: HostName -> PortID -> Text -> IO (TMVar Connection) +connectTcp host port hostname = do + let PortNumber portNumber = port + debugM "Pontarius.Xmpp" $ "Connecting to " ++ host ++ " on port " ++ + (show portNumber) ++ " through the realm " ++ (T.unpack hostname) ++ "." + h <- connectTo host port + debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle." + hSetBuffering h NoBuffering + let eSource = DCI.ResumableSource + ((sourceHandle h $= logConduit) $= XP.parseBytes def) + (return ()) + let hand = ConnectionHandle { cSend = \d -> do + let d64 = encode d + debugM "Pontarius.Xmpp" $ + "Sending TCP data: " ++ (BSC8.unpack d64) + ++ "." + catchPush $ BS.hPut h d + , cRecv = \n -> do + d <- BS.hGetSome h n + let d64 = encode d + debugM "Pontarius.Xmpp" $ + "Received TCP data: " ++ + (BSC8.unpack d64) ++ "." + return d + , cFlush = hFlush h + , cClose = hClose h + } + let con = Connection + { cHandle = hand + , cEventSource = eSource + , cFeatures = (SF Nothing [] []) + , cState = ConnectionPlain + , cHostName = (Just hostname) + , cJid = Nothing + , cPreferredLang = Nothing -- TODO: Allow user to set + , cStreamLang = Nothing + , cStreamId = Nothing + , cToJid = Nothing -- TODO: Allow user to set + , cJidWhenPlain = False -- TODO: Allow user to set + , cFrom = Nothing + } + mkConnection con + where + logConduit :: Conduit ByteString IO ByteString + logConduit = CL.mapM $ \d -> do + let d64 = encode d + debugM "Pontarius.Xmpp" $ "Received TCP data: " ++ (BSC8.unpack d64) ++ + "." + return d + + +-- Closes the connection and updates the XmppConMonad Connection state. +killConnection :: TMVar Connection -> IO (Either Ex.SomeException ()) +killConnection = withConnection $ do + cc <- gets (cClose . cHandle) + err <- liftIO $ (Ex.try cc :: IO (Either Ex.SomeException ())) + put xmppNoConnection + return err + +-- Sends an IQ request and waits for the response. If the response ID does not +-- match the outgoing ID, an error is thrown. +pushIQ' :: StanzaId + -> Maybe Jid + -> IQRequestType + -> Maybe LangTag + -> Element + -> TMVar Connection + -> IO (Either IQError IQResult) +pushIQ' iqID to tp lang body con = do + pushStanza (IQRequestS $ IQRequest iqID Nothing to lang tp body) con + res <- pullStanza con + case res of + IQErrorS e -> return $ Left e + IQResultS r -> do + unless + (iqID == iqResultID r) . liftIO . Ex.throwIO $ + StreamOtherFailure + -- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++ + -- " /= " ++ show (iqResultID r) ++ " .") + return $ Right r + _ -> liftIO $ Ex.throwIO StreamOtherFailure + -- TODO: Log: "sendIQ': unexpected stanza type " + +-- | Send "" and wait for the server to finish processing and to +-- close the connection. Any remaining elements from the server and whether or +-- not we received a element from the server is returned. +closeStreams :: TMVar Connection -> IO ([Element], Bool) +closeStreams = withConnection $ do + send <- gets (cSend . cHandle) + cc <- gets (cClose . cHandle) + liftIO $ send "" + void $ liftIO $ forkIO $ do + threadDelay 3000000 + (Ex.try cc) :: IO (Either Ex.SomeException ()) + return () + collectElems [] + where + -- Pulls elements from the stream until the stream ends, or an error is + -- raised. + collectElems :: [Element] -> StateT Connection IO ([Element], Bool) + collectElems es = do + result <- Ex.try pullElement + case result of + Left StreamEndFailure -> return (es, True) + Left _ -> return (es, False) + Right e -> collectElems (e:es) + +debugConduit :: Pipe l ByteString ByteString u IO b +debugConduit = forever $ do + s' <- await + case s' of + Just s -> do + liftIO $ BS.putStrLn (BS.append "in: " s) + yield s + Nothing -> return () diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index c5e2e62..cbcc825 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -29,7 +29,7 @@ import qualified Data.Text as Text import Data.Text (Text) import qualified Data.Text.Encoding as Text -import Network.Xmpp.Connection +import Network.Xmpp.Connection_ import Network.Xmpp.Stream import Network.Xmpp.Types @@ -50,11 +50,11 @@ xmppSasl :: [SaslHandler] -- ^ Acceptable authentication mechanisms and their xmppSasl handlers = withConnection $ do -- Chooses the first mechanism that is acceptable by both the client and the -- server. - mechanisms <- gets $ saslMechanisms . sFeatures + mechanisms <- gets $ saslMechanisms . cFeatures case (filter (\(name, _) -> name `elem` mechanisms)) handlers of [] -> return . Left $ AuthNoAcceptableMechanism mechanisms (_name, handler):_ -> runErrorT $ do - cs <- gets sConnectionState + cs <- gets cState case cs of ConnectionClosed -> throwError AuthConnectionFailure _ -> do diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index 468cf01..a83add5 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -22,7 +22,7 @@ import Data.Word (Word8) import Data.XML.Pickle import Data.XML.Types -import Network.Xmpp.Connection +import Network.Xmpp.Connection_ import Network.Xmpp.Pickle import Network.Xmpp.Sasl.StringPrep import Network.Xmpp.Sasl.Types diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs index 75ddac5..9048842 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs @@ -31,7 +31,7 @@ import qualified Data.ByteString as BS import Data.XML.Types -import Network.Xmpp.Connection +import Network.Xmpp.Connection_ import Network.Xmpp.Pickle import Network.Xmpp.Stream import Network.Xmpp.Types @@ -47,7 +47,7 @@ xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username) -> SaslM () xmppDigestMd5 authcid authzid password = do (ac, az, pw) <- prepCredentials authcid authzid password - hn <- gets sHostname + hn <- gets cHostName case hn of Just hn' -> do xmppDigestMd5' hn' ac az pw diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs index 33a0170..6f1626e 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs @@ -35,7 +35,7 @@ import qualified Data.ByteString as BS import Data.XML.Types -import Network.Xmpp.Connection +import Network.Xmpp.Connection_ import Network.Xmpp.Stream import Network.Xmpp.Types import Network.Xmpp.Pickle diff --git a/source/Network/Xmpp/Session.hs b/source/Network/Xmpp/Session.hs index 554dbea..857778b 100644 --- a/source/Network/Xmpp/Session.hs +++ b/source/Network/Xmpp/Session.hs @@ -12,7 +12,7 @@ import qualified Network.TLS as TLS import Network.Xmpp.Bind import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Channels -import Network.Xmpp.Connection +import Network.Xmpp.Connection_ import Network.Xmpp.Marshal import Network.Xmpp.Pickle import Network.Xmpp.Sasl @@ -42,7 +42,7 @@ session :: HostName -- ^ Host to connect to -- the server decide) -> IO Session -- TODO: ErrorT session hostname realm port tls sasl = do - con' <- connectTcp hostname port realm + con' <- connect hostname port realm con <- case con' of Left e -> Ex.throwIO e Right c -> return c @@ -50,33 +50,15 @@ session hostname realm port tls sasl = do saslResponse <- if isJust sasl then auth (fst $ fromJust sasl) (snd $ fromJust sasl) con >> return () else return () -- TODO: Eats AuthFailure newSession con --- | Connect to host with given address. -connectTcp :: HostName -> PortID -> Text -> IO (Either StreamFailure (TMVar Connection)) -connectTcp address port hostname = do - con <- connectTcpRaw address port hostname +-- | Connects to the XMPP server and opens the XMPP stream against the given +-- host name, port, and realm. +connect :: HostName -> PortID -> Text -> IO (Either StreamFailure (TMVar Connection)) +connect address port hostname = do + con <- connectTcp address port hostname result <- withConnection startStream con case result of - Left e -> do - withConnection (pushElement . pickleElem xpStreamError $ toError e) - con - closeStreams con - return $ Left e + Left e -> return $ Left e -- TODO Right () -> return $ Right con - where - -- toError (StreamNotStreamElement _name) = - -- XmppStreamFailure StreamInvalidXml Nothing Nothing - -- toError (StreamInvalidStreamNamespace _ns) = - -- XmppStreamFailure StreamInvalidNamespace Nothing Nothing - -- toError (StreamInvalidStreamPrefix _prefix) = - -- XmppStreamFailure StreamBadNamespacePrefix Nothing Nothing - -- toError (StreamWrongVersion _ver) = - -- XmppStreamFailure StreamUnsupportedVersion Nothing Nothing - -- toError (StreamWrongLangTag _) = - -- XmppStreamFailure StreamInvalidXml Nothing Nothing - -- toError StreamUnknownError = - -- XmppStreamFailure StreamBadFormat Nothing Nothing - -- TODO: Catch remaining xmppStartStream errors. - toError _ = StreamErrorInfo StreamBadFormat Nothing Nothing sessionXml :: Element sessionXml = pickleElem diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index bf9ad69..3941614 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -20,7 +20,7 @@ import Data.Void (Void) import Data.XML.Pickle import Data.XML.Types -import Network.Xmpp.Connection +import Network.Xmpp.Connection_ import Network.Xmpp.Pickle import Network.Xmpp.Types import Network.Xmpp.Marshal @@ -71,11 +71,11 @@ startStream = runErrorT $ do con <- liftIO $ mkConnection state -- Set the `from' (which is also the expected to) attribute depending on the -- state of the connection. - let expectedTo = case sConnectionState state of - ConnectionPlain -> if sJidWhenPlain state - then sJid state else Nothing - ConnectionSecured -> sJid state - case sHostname state of + let expectedTo = case cState state of + ConnectionPlain -> if cJidWhenPlain state + then cJid state else Nothing + ConnectionSecured -> cJid state + case cHostName state of Nothing -> throwError StreamOtherFailure -- TODO: When does this happen? Just hostname -> lift $ do pushXmlDecl @@ -84,7 +84,7 @@ startStream = runErrorT $ do , expectedTo , Just (Jid Nothing hostname Nothing) , Nothing - , sPreferredLang state + , cPreferredLang state ) response <- ErrorT $ runEventsSink $ runErrorT $ streamS expectedTo case response of @@ -95,15 +95,15 @@ startStream = runErrorT $ do | lt == Nothing -> closeStreamWithError con StreamInvalidXml Nothing -- If `from' is set, we verify that it's the correct one. TODO: Should we check against the realm instead? - | isJust from && (from /= Just (Jid Nothing (fromJust $ sHostname state) Nothing)) -> + | isJust from && (from /= Just (Jid Nothing (fromJust $ cHostName state) Nothing)) -> closeStreamWithError con StreamInvalidFrom Nothing | to /= expectedTo -> closeStreamWithError con StreamUndefinedCondition (Just $ Element "invalid-to" [] []) -- TODO: Suitable? | otherwise -> do - modify (\s -> s{ sFeatures = features - , sStreamLang = lt - , sStreamId = id - , sFrom = from + modify (\s -> s{ cFeatures = features + , cStreamLang = lt + , cStreamId = id + , cFrom = from } ) return () -- Unpickling failed - we investigate the element. @@ -158,7 +158,7 @@ flattenAttrs attrs = Prelude.map (\(name, content) -> -- and calls xmppStartStream. restartStream :: StateT Connection IO (Either StreamFailure ()) restartStream = do - raw <- gets (cRecv . cHand) + raw <- gets (cRecv . cHandle) let newSource = DCI.ResumableSource (loopRead raw $= XP.parseBytes def) (return ()) modify (\s -> s{cEventSource = newSource }) diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs index 5464341..75c73bf 100644 --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -17,7 +17,7 @@ import Data.Conduit.Tls as TLS import Data.Typeable import Data.XML.Types -import Network.Xmpp.Connection +import Network.Xmpp.Connection_ import Network.Xmpp.Pickle(ppElement) import Network.Xmpp.Stream import Network.Xmpp.Types @@ -80,13 +80,13 @@ startTls :: TLS.TLSParams -> TMVar Connection -> IO (Either TlsFailure ()) startTls params con = Ex.handle (return . Left . TlsError) . flip withConnection con . runErrorT $ do - features <- lift $ gets sFeatures - state <- gets sConnectionState + features <- lift $ gets cFeatures + state <- gets cState case state of ConnectionPlain -> return () ConnectionClosed -> throwError TlsNoConnection ConnectionSecured -> throwError TlsConnectionSecured - con <- lift $ gets cHand + con <- lift $ gets cHandle when (stls features == Nothing) $ throwError TlsNoServerSupport lift $ pushElement starttlsE answer <- lift $ pullElement @@ -98,12 +98,12 @@ startTls params con = Ex.handle (return . Left . TlsError) e -> lift $ Ex.throwIO StreamOtherFailure -- TODO: Log: "Unexpected element: " ++ ppElement e (raw, _snk, psh, read, ctx) <- lift $ TLS.tlsinit debug params (mkBackend con) - let newHand = Hand { cSend = catchPush . psh - , cRecv = read - , cFlush = contextFlush ctx - , cClose = bye ctx >> cClose con - } - lift $ modify ( \x -> x {cHand = newHand}) + let newHand = ConnectionHandle { cSend = catchPush . psh + , cRecv = read + , cFlush = contextFlush ctx + , cClose = bye ctx >> cClose con + } + lift $ modify ( \x -> x {cHandle = newHand}) either (lift . Ex.throwIO) return =<< lift restartStream - modify (\s -> s{sConnectionState = ConnectionSecured}) + modify (\s -> s{cState = ConnectionSecured}) return () diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 58d66c2..1a71d94 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -31,7 +31,7 @@ module Network.Xmpp.Types , StreamFailure(..) , StreamErrorCondition(..) , Version(..) - , HandleLike(..) + , ConnectionHandle(..) , Connection(..) , withConnection , withConnection' @@ -739,54 +739,47 @@ data ServerFeatures = SF , other :: ![Element] } deriving Show +-- | Signals the state of the connection. data ConnectionState = ConnectionClosed -- ^ No connection at this point. | ConnectionPlain -- ^ Connection established, but not secured. | ConnectionSecured -- ^ Connection established and secured via TLS. deriving (Show, Eq, Typeable) -data HandleLike = Hand { cSend :: BS.ByteString -> IO Bool - , cRecv :: Int -> IO BS.ByteString - -- This is to hold the state of the XML parser - -- (otherwise we will receive lot's of EvenBegin - -- Document and forger about name prefixes) - , cFlush :: IO () - , cClose :: IO () - } +-- | Defines operations for sending, receiving, flushing, and closing on a +-- connection. +data ConnectionHandle = + ConnectionHandle { cSend :: BS.ByteString -> IO Bool + , cRecv :: Int -> IO BS.ByteString + -- This is to hold the state of the XML parser (otherwise + -- we will receive EventBeginDocument events and forget + -- about name prefixes). + , cFlush :: IO () + , cClose :: IO () + } data Connection = Connection - { sConnectionState :: !ConnectionState -- ^ State of - -- connection - , cHand :: HandleLike - , cEventSource :: ResumableSource IO Event - , sFeatures :: !ServerFeatures -- ^ Features the server - -- advertised - , sHostname :: !(Maybe Text) -- ^ Hostname of the - -- server - , sJid :: !(Maybe Jid) -- ^ Our JID - , sPreferredLang :: !(Maybe LangTag) -- ^ Default language - -- when no explicit - -- language tag is set - , sStreamLang :: !(Maybe LangTag) -- ^ Will be a `Just' - -- value once connected - -- to the server. - , sStreamId :: !(Maybe Text) -- ^ Stream ID as - -- specified by the - -- server. - , sToJid :: !(Maybe Jid) -- ^ JID to include in the - -- stream element's `to' - -- attribute when the - -- connection is - -- secured. See also below. - , sJidWhenPlain :: !Bool -- ^ Whether or not to also - -- include the Jid when the - -- connection is plain. - , sFrom :: !(Maybe Jid) -- ^ From as specified by - -- the server in the - -- stream element's `from' - -- attribute. - } - + { cState :: !ConnectionState -- ^ State of connection + , cHandle :: ConnectionHandle -- ^ Handle to send, receive, flush, and close + -- on the connection. + , cEventSource :: ResumableSource IO Event -- ^ Event conduit source, and + -- its associated finalizer + , cFeatures :: !ServerFeatures -- ^ Features as advertised by the server + , cHostName :: !(Maybe Text) -- ^ Hostname of the server + , cJid :: !(Maybe Jid) -- ^ Our JID + , cPreferredLang :: !(Maybe LangTag) -- ^ Default language when no explicit + -- language tag is set + , cStreamLang :: !(Maybe LangTag) -- ^ Will be a `Just' value once connected + -- to the server. + , cStreamId :: !(Maybe Text) -- ^ Stream ID as specified by the server. + , cToJid :: !(Maybe Jid) -- ^ JID to include in the stream element's `to' + -- attribute when the connection is secured. See + -- also below. + , cJidWhenPlain :: !Bool -- ^ Whether or not to also include the Jid when + -- the connection is plain. + , cFrom :: !(Maybe Jid) -- ^ From as specified by the server in the stream + -- element's `from' attribute. + } withConnection :: StateT Connection IO c -> TMVar Connection -> IO c withConnection action con = bracketOnError diff --git a/source/Network/Xmpp/Xep/InbandRegistration.hs b/source/Network/Xmpp/Xep/InbandRegistration.hs index 6e14447..a2f6fe4 100644 --- a/source/Network/Xmpp/Xep/InbandRegistration.hs +++ b/source/Network/Xmpp/Xep/InbandRegistration.hs @@ -19,7 +19,7 @@ import qualified Data.Text as Text import Data.XML.Pickle import qualified Data.XML.Types as XML -import Network.Xmpp.Connection +import Network.Xmpp.Connection_ import Network.Xmpp.Pickle import Network.Xmpp.Types import Network.Xmpp.Xep.ServiceDiscovery diff --git a/source/Network/Xmpp/Xep/ServiceDiscovery.hs b/source/Network/Xmpp/Xep/ServiceDiscovery.hs index 2138017..85a22c2 100644 --- a/source/Network/Xmpp/Xep/ServiceDiscovery.hs +++ b/source/Network/Xmpp/Xep/ServiceDiscovery.hs @@ -28,7 +28,7 @@ import Network.Xmpp import Network.Xmpp.Concurrent import Network.Xmpp.Concurrent.Channels import Network.Xmpp.Concurrent.Types -import Network.Xmpp.Connection +import Network.Xmpp.Connection_ import Network.Xmpp.Pickle import Network.Xmpp.Types import Control.Concurrent.STM.TMVar