diff --git a/README b/README index b4a7bee..b502625 100644 --- a/README +++ b/README @@ -1,2 +1,2 @@ -Pontarius is an active work in progress to build a Haskell XMPP library that -implements the client capabilities of RFC 6120 ("XMPP Core"). \ No newline at end of file +Pontarius XMPP is an active work in progress to build a Haskell XMPP library +that implements the client capabilities of RFC 6120 ("XMPP Core"). diff --git a/examples/EchoClient.hs b/examples/EchoClient.hs index 24c04a1..4ff5d28 100644 --- a/examples/EchoClient.hs +++ b/examples/EchoClient.hs @@ -22,6 +22,11 @@ import Text.Printf import Network.Xmpp import Network.Xmpp.IM +import System.Log.Formatter +import System.Log.Logger +import System.Log.Handler hiding (setLevel) +import System.Log.Handler.Simple +import System.IO (stderr) -- Server and authentication details. host = "localhost" @@ -41,6 +46,11 @@ autoAccept session = forever $ do main :: IO () main = do + updateGlobalLogger "Pontarius.Xmpp" $ setLevel DEBUG + handler <- streamHandler stderr DEBUG >>= \h -> + return $ setFormatter h (simpleLogFormatter "$time - $loggername: $prio: $msg") + updateGlobalLogger "Pontarius.Xmpp" (addHandler handler) + sess <- simpleConnect host port diff --git a/import_visualisation.png b/import_visualisation.png new file mode 100644 index 0000000..001b160 Binary files /dev/null and b/import_visualisation.png differ diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index fd823af..3b71b17 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -31,13 +31,14 @@ Library , resourcet >=0.3.0 , containers >=0.4.0.0 , random >=1.0.0.0 - , tls >=1.0.0 + , tls >=1.1.0 , tls-extra >=0.5.0 , pureMD5 >=2.1.2.1 , base64-bytestring >=0.1.0.0 , binary >=0.4.1 , attoparsec >=0.10.0.3 , crypto-api >=0.9 + , crypto-random-api >=0.2 , cryptohash >=0.6.1 , text >=0.11.1.5 , bytestring >=0.9.1.9 @@ -52,43 +53,42 @@ Library , xml-picklers >=0.3 , data-default >=0.2 , stringprep >=0.1.3 + , hslogger >=1.1.0 Exposed-modules: Network.Xmpp - , Network.Xmpp.IM - , Network.Xmpp.Basic - , Network.Xmpp.Lens --- Undocumented modules - , Network.Xmpp.Bind - , Network.Xmpp.Concurrent - , Network.Xmpp.IM.Message - , Network.Xmpp.IM.Presence - , Network.Xmpp.Marshal , Network.Xmpp.Connection - , Network.Xmpp.Message - , Network.Xmpp.Pickle - , Network.Xmpp.Presence - , Network.Xmpp.Sasl - , Network.Xmpp.Sasl.Mechanisms - , Network.Xmpp.Sasl.Mechanisms.Plain - , Network.Xmpp.Sasl.Mechanisms.DigestMd5 - , Network.Xmpp.Sasl.Mechanisms.Scram - , Network.Xmpp.Sasl.Types - , Network.Xmpp.Session - , Network.Xmpp.Stream - , Network.Xmpp.TLS - , Network.Xmpp.Types - , Network.Xmpp.Xep.ServiceDiscovery - , Network.Xmpp.Jid - , Network.Xmpp.Concurrent.Types - , Network.Xmpp.Concurrent.Channels.IQ - , Network.Xmpp.Concurrent.Channels - , Network.Xmpp.Concurrent.Channels.Types - , Network.Xmpp.Concurrent.Threads - , Network.Xmpp.Concurrent.Monad - , Text.XML.Stream.Elements - , Data.Conduit.TLS - , Network.Xmpp.Sasl.Common - , Network.Xmpp.Sasl.StringPrep - , Network.Xmpp.Errors + , Network.Xmpp.IM + Other-modules: Data.Conduit.Tls + , Network.Xmpp.Bind + , Network.Xmpp.Concurrent + , Network.Xmpp.Concurrent.Types + , Network.Xmpp.Concurrent.Basic + , Network.Xmpp.Concurrent.IQ + , Network.Xmpp.Concurrent.Message + , Network.Xmpp.Concurrent.Presence + , Network.Xmpp.Concurrent.Threads + , Network.Xmpp.Concurrent.Monad + , Network.Xmpp.Connection_ + , Network.Xmpp.IM.Message + , Network.Xmpp.IM.Presence + , Network.Xmpp.Jid + , Network.Xmpp.Marshal + , Network.Xmpp.Message + , Network.Xmpp.Pickle + , Network.Xmpp.Presence + , Network.Xmpp.Sasl + , Network.Xmpp.Sasl.Common + , Network.Xmpp.Sasl.Mechanisms + , Network.Xmpp.Sasl.Mechanisms.DigestMd5 + , Network.Xmpp.Sasl.Mechanisms.Plain + , Network.Xmpp.Sasl.Mechanisms.Scram + , Network.Xmpp.Sasl.StringPrep + , Network.Xmpp.Sasl.Types + , Network.Xmpp.Session + , Network.Xmpp.Stream + , Network.Xmpp.Tls + , Network.Xmpp.Types + , Network.Xmpp.Xep.ServiceDiscovery + , Text.Xml.Stream.Elements GHC-Options: -Wall Source-Repository head diff --git a/source/Data/Conduit/TLS.hs b/source/Data/Conduit/Tls.hs similarity index 94% rename from source/Data/Conduit/TLS.hs rename to source/Data/Conduit/Tls.hs index 68fa23b..0842ae5 100644 --- a/source/Data/Conduit/TLS.hs +++ b/source/Data/Conduit/Tls.hs @@ -1,6 +1,6 @@ {-# Language NoMonomorphismRestriction #-} {-# OPTIONS_HADDOCK hide #-} -module Data.Conduit.TLS +module Data.Conduit.Tls ( tlsinit -- , conduitStdout , module TLS @@ -21,6 +21,7 @@ import qualified Data.Conduit.Binary as CB import Data.IORef import Network.TLS as TLS +import Crypto.Random.API import Network.TLS.Extra as TLSExtra import System.IO (Handle) @@ -42,7 +43,7 @@ tlsinit :: (MonadIO m, MonadIO m1) => ) tlsinit debug tlsParams backend = do when debug . liftIO $ putStrLn "TLS with debug mode enabled" - gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source? + gen <- liftIO $ getSystemRandomGen -- TODO: Find better random source? con <- client tlsParams gen backend handshake con let src = forever $ do diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index d2547da..d0e2e9c 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -1,12 +1,10 @@ -- | -- Module: $Header$ --- Description: RFC 6120 (XMPP: Core). --- License: Apache License 2.0 --- +-- -- Maintainer: info@jonkri.com -- Stability: unstable -- Portability: portable --- +-- -- The Extensible Messaging and Presence Protocol (XMPP) is an open technology -- for near-real-time communication, which powers a wide range of applications -- including instant messaging, presence, multi-party chat, voice and video @@ -15,37 +13,29 @@ -- asynchronous, end-to-end exchange of structured data by means of direct, -- 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. --- --- Note that we are not recommending anyone to use Pontarius XMPP at this time --- as it's still in an experimental stage and will have its API and data types --- modified frequently. +-- +-- For low-level access to Pontarius XMPP, see the "Network.Xmpp.Connection" +-- module. {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} module Network.Xmpp ( -- * Session management Session - , newSession - , withConnection - , connectTcp - , simpleConnect - , startTLS - , simpleAuth - , auth + , session + -- TODO: Close session, etc. + -- ** Authentication handlers , scramSha1 - , digestMd5 , plain - , closeConnection - , endContext - , setConnectionClosedHandler - -- * JID + , digestMd5 + -- * Addressing -- | A JID (historically: Jabber ID) is XMPPs native format -- for addressing entities in the network. It is somewhat similar to an e-mail - -- address but contains three parts instead of two: + -- address, but contains three parts instead of two. , Jid(..) , isBare , isFull @@ -53,32 +43,32 @@ module Network.Xmpp -- | The basic protocol data unit in XMPP is the XML stanza. The stanza is -- essentially a fragment of XML that is sent over a stream. @Stanzas@ come in -- 3 flavors: - -- - -- * @'Message'@, for traditional push-style message passing between peers - -- - -- * @'Presence'@, for communicating status updates - -- - -- * IQ (info/query), for request-response semantics communication - -- + -- + -- * /Message/, for traditional push-style message passing between peers + -- + -- * /Presence/, for communicating status updates + -- + -- * /Info/\//Query/ (or /IQ/), for request-response semantics communication + -- -- All stanza types have the following attributes in common: - -- + -- -- * The /id/ attribute is used by the originating entity to track any -- response or error stanza that it might receive in relation to the -- generated stanza from another entity (such as an intermediate server or -- the intended recipient). It is up to the originating entity whether the -- value of the 'id' attribute is unique only within its current stream or -- unique globally. - -- + -- -- * The /from/ attribute specifies the JID of the sender. - -- + -- -- * The /to/ attribute specifies the JID of the intended recipient for the -- stanza. - -- + -- -- * The /type/ attribute specifies the purpose or context of the message, -- presence, or IQ stanza. The particular allowable values for the 'type' -- attribute vary depending on whether the stanza is a message, presence, -- or IQ stanza. - -- + -- ** Messages -- | The /message/ stanza is a /push/ mechanism whereby one entity -- pushes information to another entity, similar to the communications that @@ -149,22 +139,25 @@ module Network.Xmpp , LangTag(..) , exampleParams , PortID(..) + , XmppFailure(..) + , StreamErrorInfo(..) + , StreamErrorCondition(..) + , AuthFailure( AuthXmlFailure -- Does not export AuthStreamFailure + , AuthNoAcceptableMechanism + , AuthChallengeFailure + , AuthNoConnection + , AuthFailure + , AuthSaslFailure + , AuthStringPrepFailure ) ) where -import Data.XML.Types (Element) - import Network -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.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 +import Network.Xmpp.Tls import Network.Xmpp.Types diff --git a/source/Network/Xmpp/Bind.hs b/source/Network/Xmpp/Bind.hs index 50e9fe7..a3676e6 100644 --- a/source/Network/Xmpp/Bind.hs +++ b/source/Network/Xmpp/Bind.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} @@ -11,12 +10,16 @@ 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 import Control.Monad.State(modify) +import Control.Concurrent.STM.TMVar + +import Control.Monad.Error + -- Produces a `bind' element, optionally wrapping a resource. bindBody :: Maybe Text -> Element bindBody = pickleElem $ @@ -28,16 +31,21 @@ bindBody = pickleElem $ -- Sends a (synchronous) IQ set request for a (`Just') given or server-generated -- resource and extract the JID from the non-error response. -xmppBind :: Maybe Text -> Connection -> IO Jid -xmppBind rsrc c = do - answer <- pushIQ' "bind" Nothing Set Nothing (bindBody rsrc) c - jid <- case () of () | Right IQResult{iqResultPayload = Just b} <- answer - , Right jid <- unpickleElem xpJid b - -> return jid - | otherwise -> throw $ StreamXMLError - ("Bind couldn't unpickle JID from " ++ show answer) - withConnection (modify $ \s -> s{sJid = Just jid}) c - return jid +xmppBind :: Maybe Text -> TMVar Connection -> IO (Either XmppFailure Jid) +xmppBind rsrc c = runErrorT $ do + answer <- ErrorT $ pushIQ' "bind" Nothing Set Nothing (bindBody rsrc) c + case answer of + Right IQResult{iqResultPayload = Just b} -> do + let jid = unpickleElem xpJid b + case jid of + Right jid' -> do + ErrorT $ withConnection (do + modify $ \s -> s{cJid = Just jid'} + return $ Right jid') c -- not pretty + return jid' + otherwise -> throwError XmppOtherFailure + -- TODO: Log: ("Bind couldn't unpickle JID from " ++ show answer) + otherwise -> throwError XmppOtherFailure where -- Extracts the character data in the `jid' element. xpJid :: PU [Node] Jid diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 94f0f62..fa94910 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -1,12 +1,113 @@ {-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE OverloadedStrings #-} module Network.Xmpp.Concurrent - ( Context - , module Network.Xmpp.Concurrent.Monad + ( module Network.Xmpp.Concurrent.Monad , module Network.Xmpp.Concurrent.Threads - , module Network.Xmpp.Concurrent.Channels + , module Network.Xmpp.Concurrent.Basic + , module Network.Xmpp.Concurrent.Types + , module Network.Xmpp.Concurrent.Message + , module Network.Xmpp.Concurrent.Presence + , module Network.Xmpp.Concurrent.IQ + , toChans + , newSession + , writeWorker ) where -import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Monad import Network.Xmpp.Concurrent.Threads -import Network.Xmpp.Concurrent.Channels +import Control.Applicative((<$>),(<*>)) +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad +import qualified Data.ByteString as BS +import Data.IORef +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.XML.Types +import Network.Xmpp.Concurrent.Basic +import Network.Xmpp.Concurrent.IQ +import Network.Xmpp.Concurrent.Message +import Network.Xmpp.Concurrent.Presence +import Network.Xmpp.Concurrent.Types +import Network.Xmpp.Concurrent.Threads +import Network.Xmpp.Marshal +import Network.Xmpp.Pickle +import Network.Xmpp.Types +import Text.Xml.Stream.Elements + +import Control.Monad.Error + +toChans :: TChan Stanza + -> TVar IQHandlers + -> Stanza + -> IO () +toChans stanzaC iqHands sta = atomically $ do + writeTChan stanzaC sta + case sta of + IQRequestS i -> handleIQRequest iqHands i + IQResultS i -> handleIQResponse iqHands (Right i) + IQErrorS i -> handleIQResponse iqHands (Left i) + _ -> return () + where + -- If the IQ request has a namespace, send it through the appropriate channel. + handleIQRequest :: TVar IQHandlers -> IQRequest -> STM () + handleIQRequest handlers iq = do + (byNS, _) <- readTVar handlers + let iqNS = fromMaybe "" (nameNamespace . elementName $ iqRequestPayload iq) + case Map.lookup (iqRequestType iq, iqNS) byNS of + Nothing -> return () -- TODO: send error stanza + Just ch -> do + sent <- newTVar False + writeTChan ch $ IQRequestTicket sent iq + handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> STM () + handleIQResponse handlers iq = do + (byNS, byID) <- readTVar handlers + case Map.updateLookupWithKey (\_ _ -> Nothing) (iqID iq) byID of + (Nothing, _) -> return () -- We are not supposed to send an error. + (Just tmvar, byID') -> do + let answer = either IQResponseError IQResponseResult iq + _ <- tryPutTMVar tmvar answer -- Don't block. + writeTVar handlers (byNS, byID') + where + iqID (Left err) = iqErrorID err + iqID (Right iq') = iqResultID iq' + + +-- | Creates and initializes a new Xmpp context. +newSession :: TMVar Connection -> IO (Either XmppFailure Session) +newSession con = runErrorT $ do + outC <- lift newTChanIO + stanzaChan <- lift newTChanIO + iqHandlers <- lift $ newTVarIO (Map.empty, Map.empty) + eh <- lift $ newTVarIO $ EventHandlers { connectionClosedHandler = \_ -> return () } + let stanzaHandler = toChans stanzaChan iqHandlers + (kill, wLock, conState, readerThread) <- ErrorT $ startThreadsWith stanzaHandler eh con + writer <- lift $ forkIO $ writeWorker outC wLock + idRef <- lift $ newTVarIO 1 + let getId = atomically $ do + curId <- readTVar idRef + writeTVar idRef (curId + 1 :: Integer) + return . read. show $ curId + return $ Session { stanzaCh = stanzaChan + , outCh = outC + , iqHandlers = iqHandlers + , writeRef = wLock + , readerThread = readerThread + , idGenerator = getId + , conRef = conState + , eventHandlers = eh + , stopThreads = kill >> killThread writer + } + +-- Worker to write stanzas to the stream concurrently. +writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO Bool) -> IO () +writeWorker stCh writeR = forever $ do + (write, next) <- atomically $ (,) <$> + takeTMVar writeR <*> + readTChan stCh + r <- write $ renderElement (pickleElem xpStanza next) + atomically $ putTMVar writeR write + unless r $ do + atomically $ unGetTChan stCh next -- If the writing failed, the + -- connection is dead. + threadDelay 250000 -- Avoid free spinning. diff --git a/source/Network/Xmpp/Concurrent/Channels/Basic.hs b/source/Network/Xmpp/Concurrent/Basic.hs similarity index 82% rename from source/Network/Xmpp/Concurrent/Channels/Basic.hs rename to source/Network/Xmpp/Concurrent/Basic.hs index e01d920..5b16e4e 100644 --- a/source/Network/Xmpp/Concurrent/Channels/Basic.hs +++ b/source/Network/Xmpp/Concurrent/Basic.hs @@ -1,8 +1,8 @@ {-# OPTIONS_HADDOCK hide #-} -module Network.Xmpp.Concurrent.Channels.Basic where +module Network.Xmpp.Concurrent.Basic where import Control.Concurrent.STM -import Network.Xmpp.Concurrent.Channels.Types +import Network.Xmpp.Concurrent.Types import Network.Xmpp.Types -- | Send a stanza to the server. diff --git a/source/Network/Xmpp/Concurrent/Channels.hs b/source/Network/Xmpp/Concurrent/Channels.hs deleted file mode 100644 index 31c294a..0000000 --- a/source/Network/Xmpp/Concurrent/Channels.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.Concurrent.Channels - ( module Network.Xmpp.Concurrent.Channels.Basic - , module Network.Xmpp.Concurrent.Channels.Types - , module Network.Xmpp.Concurrent.Channels.Message - , module Network.Xmpp.Concurrent.Channels.Presence - , module Network.Xmpp.Concurrent.Channels.IQ - , toChans - , newSession - , writeWorker - ) - - where - -import Control.Applicative((<$>),(<*>)) -import Control.Concurrent -import Control.Concurrent.STM -import Control.Monad -import qualified Data.ByteString as BS -import Data.IORef -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Data.XML.Types -import Network.Xmpp.Concurrent.Channels.Basic -import Network.Xmpp.Concurrent.Channels.IQ -import Network.Xmpp.Concurrent.Channels.Message -import Network.Xmpp.Concurrent.Channels.Presence -import Network.Xmpp.Concurrent.Channels.Types -import Network.Xmpp.Concurrent.Threads -import Network.Xmpp.Concurrent.Types -import Network.Xmpp.Marshal -import Network.Xmpp.Pickle -import Network.Xmpp.Types -import Text.XML.Stream.Elements - -toChans :: TChan Stanza - -> TVar IQHandlers - -> Stanza - -> IO () -toChans stanzaC iqHands sta = atomically $ do - writeTChan stanzaC sta - case sta of - IQRequestS i -> handleIQRequest iqHands i - IQResultS i -> handleIQResponse iqHands (Right i) - IQErrorS i -> handleIQResponse iqHands (Left i) - _ -> return () - where - -- If the IQ request has a namespace, send it through the appropriate channel. - handleIQRequest :: TVar IQHandlers -> IQRequest -> STM () - handleIQRequest handlers iq = do - (byNS, _) <- readTVar handlers - let iqNS = fromMaybe "" (nameNamespace . elementName $ iqRequestPayload iq) - case Map.lookup (iqRequestType iq, iqNS) byNS of - Nothing -> return () -- TODO: send error stanza - Just ch -> do - sent <- newTVar False - writeTChan ch $ IQRequestTicket sent iq - handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> STM () - handleIQResponse handlers iq = do - (byNS, byID) <- readTVar handlers - case Map.updateLookupWithKey (\_ _ -> Nothing) (iqID iq) byID of - (Nothing, _) -> return () -- We are not supposed to send an error. - (Just tmvar, byID') -> do - let answer = either IQResponseError IQResponseResult iq - _ <- tryPutTMVar tmvar answer -- Don't block. - writeTVar handlers (byNS, byID') - where - iqID (Left err) = iqErrorID err - iqID (Right iq') = iqResultID iq' - - --- | Creates and initializes a new Xmpp context. -newSession :: Connection -> IO Session -newSession con = do - outC <- newTChanIO - stanzaChan <- newTChanIO - iqHandlers <- newTVarIO (Map.empty, Map.empty) - eh <- newTVarIO $ EventHandlers { connectionClosedHandler = \_ -> return () } - let stanzaHandler = toChans stanzaChan iqHandlers - (kill, wLock, conState, readerThread) <- startThreadsWith stanzaHandler eh con - writer <- forkIO $ writeWorker outC wLock - idRef <- newTVarIO 1 - let getId = atomically $ do - curId <- readTVar idRef - writeTVar idRef (curId + 1 :: Integer) - return . read. show $ curId - let cont = Context { writeRef = wLock - , readerThread = readerThread - , idGenerator = getId - , conRef = conState - , eventHandlers = eh - , stopThreads = kill >> killThread writer - } - return $ Session { context = cont - , stanzaCh = stanzaChan - , outCh = outC - , iqHandlers = iqHandlers - } - --- Worker to write stanzas to the stream concurrently. -writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO Bool) -> IO () -writeWorker stCh writeR = forever $ do - (write, next) <- atomically $ (,) <$> - takeTMVar writeR <*> - readTChan stCh - r <- write $ renderElement (pickleElem xpStanza next) - atomically $ putTMVar writeR write - unless r $ do - atomically $ unGetTChan stCh next -- If the writing failed, the - -- connection is dead. - threadDelay 250000 -- Avoid free spinning. diff --git a/source/Network/Xmpp/Concurrent/Channels/IQ.hs b/source/Network/Xmpp/Concurrent/IQ.hs similarity index 94% rename from source/Network/Xmpp/Concurrent/Channels/IQ.hs rename to source/Network/Xmpp/Concurrent/IQ.hs index 4c6ce3d..bd79061 100644 --- a/source/Network/Xmpp/Concurrent/Channels/IQ.hs +++ b/source/Network/Xmpp/Concurrent/IQ.hs @@ -1,5 +1,5 @@ {-# OPTIONS_HADDOCK hide #-} -module Network.Xmpp.Concurrent.Channels.IQ where +module Network.Xmpp.Concurrent.IQ where import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.STM @@ -11,8 +11,7 @@ import qualified Data.Map as Map import Data.Text (Text) import Data.XML.Types -import Network.Xmpp.Concurrent.Channels.Basic -import Network.Xmpp.Concurrent.Channels.Types +import Network.Xmpp.Concurrent.Basic import Network.Xmpp.Concurrent.Types import Network.Xmpp.Types @@ -27,7 +26,7 @@ sendIQ :: Maybe Int -- ^ Timeout -> Session -> IO (TMVar IQResponse) sendIQ timeOut to tp lang body session = do -- TODO: Add timeout - newId <- idGenerator (context session) + newId <- idGenerator session ref <- atomically $ do resRef <- newEmptyTMVar (byNS, byId) <- readTVar (iqHandlers session) diff --git a/source/Network/Xmpp/Concurrent/Channels/Message.hs b/source/Network/Xmpp/Concurrent/Message.hs similarity index 93% rename from source/Network/Xmpp/Concurrent/Channels/Message.hs rename to source/Network/Xmpp/Concurrent/Message.hs index 5cff80a..b84dc2e 100644 --- a/source/Network/Xmpp/Concurrent/Channels/Message.hs +++ b/source/Network/Xmpp/Concurrent/Message.hs @@ -1,12 +1,12 @@ {-# OPTIONS_HADDOCK hide #-} -module Network.Xmpp.Concurrent.Channels.Message where +module Network.Xmpp.Concurrent.Message where -import Network.Xmpp.Concurrent.Channels.Types +import Network.Xmpp.Concurrent.Types import Control.Concurrent.STM import Data.IORef import Network.Xmpp.Types import Network.Xmpp.Concurrent.Types -import Network.Xmpp.Concurrent.Channels.Basic +import Network.Xmpp.Concurrent.Basic -- | Read an element from the inbound stanza channel, acquiring a copy of the -- channel as necessary. diff --git a/source/Network/Xmpp/Concurrent/Monad.hs b/source/Network/Xmpp/Concurrent/Monad.hs index 070cab3..ff0f07a 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_ @@ -59,7 +59,7 @@ import Network.Xmpp.Connection -- ] -- | Executes a function to update the event handlers. -modifyHandlers :: (EventHandlers -> EventHandlers) -> Context -> IO () +modifyHandlers :: (EventHandlers -> EventHandlers) -> Session -> IO () modifyHandlers f session = atomically $ modifyTVar (eventHandlers session) f where -- Borrowing modifyTVar from @@ -71,18 +71,18 @@ 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 :: (StreamError -> Context -> IO ()) -> Context -> IO () -setConnectionClosedHandler eh session = do +setConnectionClosedHandler_ :: (XmppFailure -> Session -> IO ()) -> Session -> IO () +setConnectionClosedHandler_ eh session = do modifyHandlers (\s -> s{connectionClosedHandler = \e -> eh e session}) session -- | Run an event handler. -runHandler :: (EventHandlers -> IO a) -> Context -> IO a +runHandler :: (EventHandlers -> IO a) -> Session -> IO a runHandler h session = h =<< atomically (readTVar $ eventHandlers session) -- | End the current Xmpp session. -endContext :: Context -> IO () +endContext :: Session -> IO () endContext session = do -- TODO: This has to be idempotent (is it?) closeConnection session stopThreads session @@ -90,7 +90,7 @@ endContext session = do -- TODO: This has to be idempotent (is it?) -- | Close the connection to the server. Closes the stream (by enforcing a -- write lock and sending a element), waits (blocks) for three -- seconds, and then closes the connection. -closeConnection :: Context -> IO () +closeConnection :: Session -> IO () closeConnection session = Ex.mask_ $ do (_send, connection) <- atomically $ liftM2 (,) (takeTMVar $ writeRef session) diff --git a/source/Network/Xmpp/Concurrent/Channels/Presence.hs b/source/Network/Xmpp/Concurrent/Presence.hs similarity index 87% rename from source/Network/Xmpp/Concurrent/Channels/Presence.hs rename to source/Network/Xmpp/Concurrent/Presence.hs index 32ec83f..3cb0d6a 100644 --- a/source/Network/Xmpp/Concurrent/Channels/Presence.hs +++ b/source/Network/Xmpp/Concurrent/Presence.hs @@ -1,12 +1,11 @@ {-# OPTIONS_HADDOCK hide #-} -module Network.Xmpp.Concurrent.Channels.Presence where +module Network.Xmpp.Concurrent.Presence where -import Network.Xmpp.Concurrent.Channels.Types import Control.Concurrent.STM import Data.IORef import Network.Xmpp.Types import Network.Xmpp.Concurrent.Types -import Network.Xmpp.Concurrent.Channels.Basic +import Network.Xmpp.Concurrent.Basic -- | Read an element from the inbound stanza channel, acquiring a copy of the -- channel as necessary. diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs index 1ab1a23..c55fc16 100644 --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -16,15 +16,19 @@ 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 import GHC.IO (unsafeUnmask) +import Control.Monad.Error + -- Worker to read stanzas from the stream and concurrently distribute them to -- all listener threads. readWorker :: (Stanza -> IO ()) - -> (StreamError -> IO ()) - -> TMVar Connection + -> (XmppFailure -> IO ()) + -> TMVar (TMVar Connection) -> IO a readWorker onStanza onConnectionClosed stateRef = Ex.mask_ . forever $ do @@ -32,8 +36,8 @@ readWorker onStanza onConnectionClosed stateRef = -- we don't know whether pull will -- necessarily be interruptible s <- atomically $ do - con@(Connection con_) <- readTMVar stateRef - state <- sConnectionState <$> readTMVar con_ + con <- readTMVar stateRef + state <- cState <$> readTMVar con when (state == ConnectionClosed) retry return con @@ -43,13 +47,14 @@ readWorker onStanza onConnectionClosed stateRef = [ Ex.Handler $ \(Interrupt t) -> do void $ handleInterrupts [t] return Nothing - , Ex.Handler $ \(e :: StreamError) -> do + , Ex.Handler $ \(e :: XmppFailure) -> do onConnectionClosed e return Nothing ] case res of - Nothing -> return () -- Caught an exception, nothing to do - Just sta -> onStanza sta + Nothing -> return () -- Caught an exception, nothing to do. TODO: Can this happen? + Just (Left e) -> return () + Just (Right sta) -> onStanza sta where -- Defining an Control.Exception.allowInterrupt equivalent for GHC 7 -- compatibility. @@ -72,31 +77,33 @@ readWorker onStanza onConnectionClosed stateRef = -- connection. startThreadsWith :: (Stanza -> IO ()) -> TVar EventHandlers - -> Connection - -> IO - (IO (), + -> TMVar Connection + -> IO (Either XmppFailure (IO (), TMVar (BS.ByteString -> IO Bool), - TMVar Connection, - ThreadId) + TMVar (TMVar Connection), + ThreadId)) startThreadsWith stanzaHandler eh con = do - read <- withConnection' (gets $ cSend. cHand) con - writeLock <- newTMVarIO read - conS <- newTMVarIO con --- lw <- forkIO $ writeWorker outC writeLock - cp <- forkIO $ connPersist writeLock - rd <- forkIO $ readWorker stanzaHandler (noCon eh) conS - return ( killConnection writeLock [rd, cp] - , writeLock - , conS - , rd - ) + read <- withConnection' (gets $ cSend . cHandle >>= \d -> return $ Right d) con + case read of + Left e -> return $ Left e + Right read' -> do + writeLock <- newTMVarIO read' + conS <- newTMVarIO con + -- lw <- forkIO $ writeWorker outC writeLock + cp <- forkIO $ connPersist writeLock + rd <- forkIO $ readWorker stanzaHandler (noCon eh) conS + return $ Right ( killConnection writeLock [rd, cp] + , writeLock + , conS + , rd + ) where killConnection writeLock threads = liftIO $ do _ <- atomically $ takeTMVar writeLock -- Should we put it back? _ <- forM threads killThread return () -- Call the connection closed handlers. - noCon :: TVar EventHandlers -> StreamError -> IO () + noCon :: TVar EventHandlers -> XmppFailure -> IO () noCon h e = do hands <- atomically $ readTVar h _ <- forkIO $ connectionClosedHandler hands e diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index e862e11..0d61e93 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -12,27 +12,52 @@ import Data.Typeable import Network.Xmpp.Types +import Data.IORef +import qualified Data.Map as Map +import Data.Text (Text) + +import Network.Xmpp.Types + -- | Handlers to be run when the Xmpp session ends and when the Xmpp connection is -- closed. data EventHandlers = EventHandlers - { connectionClosedHandler :: StreamError -> IO () + { connectionClosedHandler :: XmppFailure -> IO () } --- | Xmpp Context object -data Context = Context - { writeRef :: TMVar (BS.ByteString -> IO Bool) +-- | Interrupt is used to signal to the reader thread that it should stop. Th contained semphore signals the reader to resume it's work. +data Interrupt = Interrupt (TMVar ()) deriving Typeable +instance Show Interrupt where show _ = "" + +instance Ex.Exception Interrupt + + +-- | A concurrent interface to Pontarius XMPP. +data Session = Session + { stanzaCh :: TChan Stanza -- All stanzas + , outCh :: TChan Stanza + , iqHandlers :: TVar IQHandlers + -- Writing lock, so that only one thread could write to the stream at any + -- given time. + -- Fields below are from Context. + , writeRef :: TMVar (BS.ByteString -> IO Bool) , readerThread :: ThreadId , idGenerator :: IO StanzaID -- | Lock (used by withConnection) to make sure that a maximum of one -- XmppConMonad action is executed at any given time. - , conRef :: TMVar Connection + , conRef :: TMVar (TMVar Connection) , eventHandlers :: TVar EventHandlers , stopThreads :: IO () } - --- | Interrupt is used to signal to the reader thread that it should stop. Th contained semphore signals the reader to resume it's work. -data Interrupt = Interrupt (TMVar ()) deriving Typeable -instance Show Interrupt where show _ = "" - -instance Ex.Exception Interrupt +-- | IQHandlers holds the registered channels for incomming IQ requests and +-- TMVars of and TMVars for expected IQ responses +type IQHandlers = (Map.Map (IQRequestType, Text) (TChan IQRequestTicket) + , Map.Map StanzaID (TMVar IQResponse) + ) + +-- | Contains whether or not a reply has been sent, and the IQ request body to +-- reply to. +data IQRequestTicket = IQRequestTicket + { sentRef :: (TVar Bool) + , iqRequestBody :: IQRequest + } diff --git a/source/Network/Xmpp/Connection.hs b/source/Network/Xmpp/Connection.hs index a5244d8..d1dddd5 100644 --- a/source/Network/Xmpp/Connection.hs +++ b/source/Network/Xmpp/Connection.hs @@ -1,262 +1,41 @@ -{-# 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.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 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(..)) - --- 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 -> 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 StreamConnectionError - Just r -> return r - ) - [ Ex.Handler (\StreamEnd -> Ex.throwIO StreamStreamEnd) - , Ex.Handler (\(InvalidXmppXml s) - -> liftIO . Ex.throwIO $ StreamXMLError s) - , Ex.Handler $ \(e :: InvalidEventStream) - -> liftIO . Ex.throwIO $ StreamXMLError (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 $ StreamXMLError (show e) - Right r -> return r - --- | Pulls a stanza (or stream error) from the stream. Throws an error on a stream --- error. -pullStanza :: Connection -> IO Stanza -pullStanza = withConnection' $ do - res <- pullUnpickle xpStreamStanza - case res of - Left e -> liftIO . Ex.throwIO $ StreamError 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 - $ StreamConnectionError - , 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 $ StreamConnectionError - --- Connects to the given hostname on port 5222 (TODO: Make this dynamic) and --- updates the XmppConMonad Connection_ state. -connectTcpRaw :: HostName -> PortID -> Text -> IO Connection -connectTcpRaw host port hostname = do - h <- connectTo host port - hSetBuffering h NoBuffering - let eSource = if debug then - DCI.ResumableSource (sourceHandle h - $= debugOut - $= XP.parseBytes def) - (return ()) - else DCI.ResumableSource (sourceHandle h - $= XP.parseBytes def) - (return ()) - let hand = Hand { cSend = if debug - then \d -> do - BS.putStrLn (BS.append "out: " d) - catchPush $ BS.hPut h d - else catchPush . BS.hPut h - , cRecv = if debug then - \n -> do - bs <- BS.hGetSome h n - Prelude.putStr "in: " - BS.putStrLn bs - return bs - else BS.hGetSome h - , 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 - debugOut = do - d <- await - case d of - Nothing -> return () - Just bs -> do - liftIO $ BS.putStr "in: " - liftIO $ BS.putStrLn bs - yield bs - debugOut - --- Closes the connection and updates the XmppConMonad Connection_ state. -killConnection :: 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 - -> 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 $ - StreamXMLError - ("In sendIQ' IDs don't match: " ++ show iqID ++ " /= " ++ - show (iqResultID r) ++ " .") - return $ Right r - _ -> liftIO . Ex.throwIO . StreamXMLError $ - "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 :: 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 StreamStreamEnd -> 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.Session +import Network.Xmpp.Tls +import Network.Xmpp.Types +import Network.Xmpp.Concurrent diff --git a/source/Network/Xmpp/Connection_.hs b/source/Network/Xmpp/Connection_.hs new file mode 100644 index 0000000..a577175 --- /dev/null +++ b/source/Network/Xmpp/Connection_.hs @@ -0,0 +1,285 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Xmpp.Connection_ where + +import Control.Applicative((<$>)) +import Control.Concurrent (forkIO, threadDelay) +import System.IO.Error (tryIOError) +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 +import Control.Monad.Error + +-- 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 + +-- TODO: Can the TLS send/recv functions throw something other than an IO error? + +wrapIOException :: IO a -> StateT Connection IO (Either XmppFailure a) +wrapIOException action = do + r <- liftIO $ tryIOError action + case r of + Right b -> return $ Right b + Left e -> return $ Left $ XmppIOException e + +pushElement :: Element -> StateT Connection IO (Either XmppFailure Bool) +pushElement x = do + send <- gets (cSend . cHandle) + wrapIOException $ send $ renderElement x + +-- | Encode and send stanza +pushStanza :: Stanza -> TMVar Connection -> IO (Either XmppFailure 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 (Either XmppFailure Bool) +pushXmlDecl = do + con <- gets cHandle + wrapIOException $ (cSend con) "" + +pushOpenElement :: Element -> StateT Connection IO (Either XmppFailure Bool) +pushOpenElement e = do + sink <- gets (cSend . cHandle) + wrapIOException $ 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 (Either XmppFailure b) +runEventsSink snk = do -- TODO: Wrap exceptions? + source <- gets cEventSource + (src', r) <- lift $ source $$++ snk + modify (\s -> s{cEventSource = src'}) + return $ Right r + +pullElement :: StateT Connection IO (Either XmppFailure Element) +pullElement = do + Ex.catches (do + e <- runEventsSink (elements =$ await) + case e of + Left f -> return $ Left f + Right Nothing -> return $ Left XmppOtherFailure -- TODO + Right (Just r) -> return $ Right r + ) + [ Ex.Handler (\StreamEnd -> return $ Left StreamEndFailure) + , Ex.Handler (\(InvalidXmppXml s) -- Invalid XML `Event' encountered, or missing element close tag + -> return $ Left XmppOtherFailure) -- TODO: Log: s + , Ex.Handler $ \(e :: InvalidEventStream) -- xml-conduit exception + -> return $ Left XmppOtherFailure -- TODO: Log: (show e) + ] + +-- Pulls an element and unpickles it. +pullUnpickle :: PU [Node] a -> StateT Connection IO (Either XmppFailure a) +pullUnpickle p = do + elem <- pullElement + case elem of + Left e -> return $ Left e + Right elem' -> do + let res = unpickleElem p elem' + case res of + Left e -> return $ Left XmppOtherFailure -- TODO: Log + Right r -> return $ Right r + +-- | Pulls a stanza (or stream error) from the stream. +pullStanza :: TMVar Connection -> IO (Either XmppFailure Stanza) +pullStanza = withConnection' $ do + res <- pullUnpickle xpStreamStanza + case res of + Left e -> return $ Left e + Right (Left e) -> return $ Left $ StreamErrorFailure e + Right (Right r) -> return $ Right 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 + XmppOtherFailure + , 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 $ XmppOtherFailure + +connectTcp :: HostName -> PortID -> Text -> IO (Either XmppFailure (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 + } + con' <- mkConnection con + return $ Right 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 :: TMVar Connection -> IO (Either XmppFailure ()) +killConnection = withConnection $ do + cc <- gets (cClose . cHandle) + err <- wrapIOException cc + -- (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 XmppFailure (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 + Left e -> return $ Left e + Right (IQErrorS e) -> return $ Right $ Left e + Right (IQResultS r) -> do + unless + (iqID == iqResultID r) . liftIO . Ex.throwIO $ + XmppOtherFailure + -- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++ + -- " /= " ++ show (iqResultID r) ++ " .") + return $ Right $ Right r + _ -> return $ Left XmppOtherFailure + -- 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 are returned. +-- Surpresses StreamEndFailure exceptions, but may throw a StreamCloseError. +closeStreams :: TMVar Connection -> IO (Either XmppFailure [Element]) +closeStreams = withConnection $ do + send <- gets (cSend . cHandle) + cc <- gets (cClose . cHandle) + liftIO $ send "" + void $ liftIO $ forkIO $ do + threadDelay 3000000 -- TODO: Configurable value + (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 (Either XmppFailure [Element]) + collectElems es = do + result <- pullElement + case result of + Left StreamEndFailure -> return $ Right es + Left e -> return $ Left $ StreamCloseError (es, e) + 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/Marshal.hs b/source/Network/Xmpp/Marshal.hs index 6738bb4..9b78c4c 100644 --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -14,7 +14,7 @@ import Data.XML.Types import Network.Xmpp.Pickle import Network.Xmpp.Types -xpStreamStanza :: PU [Node] (Either XmppStreamError Stanza) +xpStreamStanza :: PU [Node] (Either StreamErrorInfo Stanza) xpStreamStanza = xpEither xpStreamError xpStanza xpStanza :: PU [Node] Stanza @@ -182,10 +182,10 @@ xpIQError = ("xpIQError" , "") xpWrap (xp2Tuple xpStanzaError (xpOption xpElemVerbatim)) ) -xpStreamError :: PU [Node] XmppStreamError +xpStreamError :: PU [Node] StreamErrorInfo xpStreamError = ("xpStreamError" , "") xpWrap - (\((cond,() ,()), txt, el) -> XmppStreamError cond txt el) - (\(XmppStreamError cond txt el) ->((cond,() ,()), txt, el)) + (\((cond,() ,()), txt, el) -> StreamErrorInfo cond txt el) + (\(StreamErrorInfo cond txt el) ->((cond,() ,()), txt, el)) (xpElemNodes (Name "error" diff --git a/source/Network/Xmpp/Pickle.hs b/source/Network/Xmpp/Pickle.hs index 3cda8d3..b9291d0 100644 --- a/source/Network/Xmpp/Pickle.hs +++ b/source/Network/Xmpp/Pickle.hs @@ -21,7 +21,7 @@ import Data.XML.Pickle import Network.Xmpp.Types -import Text.XML.Stream.Elements +import Text.Xml.Stream.Elements xmlLang :: Name xmlLang = Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml") diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index 0563398..2a61ae2 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 @@ -38,24 +38,30 @@ import qualified System.Random as Random import Network.Xmpp.Sasl.Types import Network.Xmpp.Sasl.Mechanisms +import Control.Concurrent.STM.TMVar + -- | Uses the first supported mechanism to authenticate, if any. Updates the -- state with non-password credentials and restarts the stream upon --- success. +-- success. Returns `Nothing' on success, an `AuthFailure' if +-- authentication fails, or an `XmppFailure' if anything else fails. xmppSasl :: [SaslHandler] -- ^ Acceptable authentication mechanisms and their -- corresponding handlers - -> Connection - -> IO (Either AuthError ()) + -> TMVar Connection + -> IO (Either XmppFailure (Maybe AuthFailure)) 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 + [] -> return $ Right $ Just $ AuthNoAcceptableMechanism mechanisms + (_name, handler):_ -> do + cs <- gets cState case cs of - ConnectionClosed -> throwError AuthConnectionError + ConnectionClosed -> return . Right $ Just AuthNoConnection _ -> do - r <- handler - _ <- ErrorT $ left AuthStreamError <$> restartStream - return r + r <- runErrorT handler + case r of + Left ae -> return $ Right $ Just ae + Right a -> do + _ <- runErrorT $ ErrorT restartStream + return $ Right $ Nothing diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index 5d4164f..e3dcc5c 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 @@ -107,16 +107,21 @@ quote :: BS.ByteString -> BS.ByteString quote x = BS.concat ["\"",x,"\""] saslInit :: Text.Text -> Maybe BS.ByteString -> SaslM Bool -saslInit mechanism payload = lift . pushElement . saslInitE mechanism $ - Text.decodeUtf8 . B64.encode <$> payload +saslInit mechanism payload = do + r <- lift . pushElement . saslInitE mechanism $ + Text.decodeUtf8 . B64.encode <$> payload + case r of + Left e -> throwError $ AuthStreamFailure e + Right b -> return b -- | Pull the next element. pullSaslElement :: SaslM SaslElement pullSaslElement = do - el <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement) - case el of - Left e ->throwError $ AuthSaslFailure e - Right r -> return r + r <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement) + case r of + Left e -> throwError $ AuthStreamFailure e + Right (Left e) -> throwError $ AuthSaslFailure e + Right (Right r) -> return r -- | Pull the next element, checking that it is a challenge. pullChallenge :: SaslM (Maybe BS.ByteString) @@ -127,11 +132,11 @@ pullChallenge = do SaslChallenge (Just scb64) | Right sc <- B64.decode . Text.encodeUtf8 $ scb64 -> return $ Just sc - _ -> throwError AuthChallengeError + _ -> throwError AuthChallengeFailure --- | Extract value from Just, failing with AuthChallengeError on Nothing. +-- | Extract value from Just, failing with AuthChallengeFailure on Nothing. saslFromJust :: Maybe a -> SaslM a -saslFromJust Nothing = throwError $ AuthChallengeError +saslFromJust Nothing = throwError $ AuthChallengeFailure saslFromJust (Just d) = return d -- | Pull the next element and check that it is success. @@ -140,7 +145,7 @@ pullSuccess = do e <- pullSaslElement case e of SaslSuccess x -> return x - _ -> throwError $ AuthXmlError + _ -> throwError $ AuthXmlFailure -- | Pull the next element. When it's success, return it's payload. -- If it's a challenge, send an empty response and pull success. @@ -156,27 +161,30 @@ pullFinalMessage = do where decode Nothing = return Nothing decode (Just d) = case B64.decode $ Text.encodeUtf8 d of - Left _e -> throwError $ AuthChallengeError + Left _e -> throwError $ AuthChallengeFailure Right x -> return $ Just x -- | Extract p=q pairs from a challenge. toPairs :: BS.ByteString -> SaslM Pairs toPairs ctext = case pairs ctext of - Left _e -> throwError AuthChallengeError + Left _e -> throwError AuthChallengeFailure Right r -> return r -- | Send a SASL response element. The content will be base64-encoded. respond :: Maybe BS.ByteString -> SaslM Bool -respond = lift . pushElement . saslResponseE . - fmap (Text.decodeUtf8 . B64.encode) +respond m = do + r <- lift . pushElement . saslResponseE . fmap (Text.decodeUtf8 . B64.encode) $ m + case r of + Left e -> throwError $ AuthStreamFailure e + Right b -> return b -- | Run the appropriate stringprep profiles on the credentials. --- May fail with 'AuthStringPrepError' +-- May fail with 'AuthStringPrepFailure' prepCredentials :: Text.Text -> Maybe Text.Text -> Text.Text -> SaslM (Text.Text, Maybe Text.Text, Text.Text) prepCredentials authcid authzid password = case credentials of - Nothing -> throwError $ AuthStringPrepError + Nothing -> throwError $ AuthStringPrepFailure Just creds -> return creds where credentials = do diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs index 55bce2c..f8fc03c 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,11 +47,8 @@ xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username) -> SaslM () xmppDigestMd5 authcid authzid password = do (ac, az, pw) <- prepCredentials authcid authzid password - hn <- gets sHostname - case hn of - Just hn' -> do - xmppDigestMd5' hn' ac az pw - Nothing -> throwError AuthConnectionError + hn <- gets cHostName + xmppDigestMd5' (fromJust hn) ac az pw where xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> SaslM () xmppDigestMd5' hostname authcid authzid password = do 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/Sasl/Mechanisms/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs index 6cf809d..e9cebc7 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs @@ -59,7 +59,7 @@ scram hashToken authcid authzid password = do let (cfm, v) = cFinalMessageAndVerifier nonce salt ic sFirstMessage cnonce respond $ Just cfm finalPairs <- toPairs =<< saslFromJust =<< pullFinalMessage - unless (lookup "v" finalPairs == Just v) $ throwError AuthServerAuthError + unless (lookup "v" finalPairs == Just v) $ throwError AuthServerAuthFailure return () where -- We need to jump through some hoops to get a polymorphic solution @@ -102,7 +102,7 @@ scram hashToken authcid authzid password = do , Just ic <- lookup "i" pairs , [(i,"")] <- reads $ BS8.unpack ic = return (nonce, salt, i) - fromPairs _ _ = throwError $ AuthChallengeError + fromPairs _ _ = throwError $ AuthChallengeFailure cFinalMessageAndVerifier :: BS.ByteString -> BS.ByteString diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs index a11f9ef..90f20da 100644 --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -7,29 +7,29 @@ import Data.ByteString(ByteString) import qualified Data.Text as Text import Network.Xmpp.Types -data AuthError = AuthXmlError +data AuthFailure = AuthXmlFailure | AuthNoAcceptableMechanism [Text.Text] -- ^ Wraps mechanisms -- offered - | AuthChallengeError - | AuthServerAuthError -- ^ The server failed to authenticate + | AuthChallengeFailure + | AuthServerAuthFailure -- ^ The server failed to authenticate -- itself - | AuthStreamError StreamError -- ^ Stream error on stream restart - -- TODO: Rename AuthConnectionError? - | AuthConnectionError -- ^ Connection is closed - | AuthError -- General instance used for the Error instance + | AuthStreamFailure XmppFailure -- ^ Stream error on stream restart + -- TODO: Rename AuthConnectionFailure? + | AuthNoConnection + | AuthFailure -- General instance used for the Error instance | AuthSaslFailure SaslFailure -- ^ Defined SASL error condition - | AuthStringPrepError -- ^ StringPrep failed + | AuthStringPrepFailure -- ^ StringPrep failed deriving Show -instance Error AuthError where - noMsg = AuthError +instance Error AuthFailure where + noMsg = AuthFailure data SaslElement = SaslSuccess (Maybe Text.Text) | SaslChallenge (Maybe Text.Text) -- | SASL mechanism XmppConnection computation, with the possibility of throwing -- an authentication error. -type SaslM a = ErrorT AuthError (StateT Connection_ IO) a +type SaslM a = ErrorT AuthFailure (StateT Connection IO) a type Pairs = [(ByteString, ByteString)] diff --git a/source/Network/Xmpp/Session.hs b/source/Network/Xmpp/Session.hs index cbfda71..3b491fe 100644 --- a/source/Network/Xmpp/Session.hs +++ b/source/Network/Xmpp/Session.hs @@ -11,97 +11,61 @@ import Network 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.Concurrent +import Network.Xmpp.Connection_ import Network.Xmpp.Marshal import Network.Xmpp.Pickle import Network.Xmpp.Sasl import Network.Xmpp.Sasl.Mechanisms import Network.Xmpp.Sasl.Types import Network.Xmpp.Stream -import Network.Xmpp.TLS +import Network.Xmpp.Tls import Network.Xmpp.Types +import Control.Concurrent.STM.TMVar +import Data.Maybe --- | The quick and easy way to set up a connection to an XMPP server +-- | Creates a 'Session' object by setting up a connection with an XMPP server. -- --- This will --- --- * connect to the host --- --- * secure the connection with TLS --- --- * authenticate to the server using either SCRAM-SHA1 (preferred) or --- Digest-MD5 --- --- * bind a resource --- --- * return the full JID you have been assigned --- --- Note that the server might assign a different resource even when we send --- a preference. -simpleConnect :: HostName -- ^ Host to connect to - -> PortID -- ^ Port to connec to - -> Text -- ^ Hostname of the server (to distinguish the XMPP - -- service) - -> Text -- ^ User name (authcid) - -> Text -- ^ Password - -> Maybe Text -- ^ Desired resource (or Nothing to let the server - -- decide) - -> IO Session -simpleConnect host port hostname username password resource = do - con' <- connectTcp host port hostname - con <- case con' of - Left e -> Ex.throwIO e - Right r -> return r - startTLS exampleParams con - saslResponse <- simpleAuth username password resource con - case saslResponse of - Right jid -> newSession con - Left e -> error $ show e - +-- Will connect to the specified host. If the fourth parameters is a 'Just' +-- value, @session@ will attempt to secure the connection with TLS. If the fifth +-- parameters is a 'Just' value, @session@ will attempt to authenticate and +-- acquire an XMPP resource. +session :: HostName -- ^ Host to connect to + -> Text -- ^ The realm host name (to + -- distinguish the XMPP service) + -> PortID -- ^ Port to connect to + -> Maybe TLS.TLSParams -- ^ TLS settings, if securing the + -- connection to the server is + -- desired + -> Maybe ([SaslHandler], Maybe Text) -- ^ SASL handlers and the desired + -- JID resource (or Nothing to let + -- the server decide) + -> IO (Either XmppFailure (Session, Maybe AuthFailure)) +session hostname realm port tls sasl = runErrorT $ do + con <- ErrorT $ connect hostname port realm + if isJust tls + then ErrorT $ startTls (fromJust tls) con + else return () + aut <- if isJust sasl + then ErrorT $ auth (fst $ fromJust sasl) (snd $ fromJust sasl) con + else return Nothing + ses <- ErrorT $ newSession con + return (ses, aut) --- | Connect to host with given address. -connectTcp :: HostName -> PortID -> Text -> IO (Either StreamError Connection) -connectTcp address port hostname = do - con <- connectTcpRaw address port hostname - result <- withConnection startStream con - case result of +-- | Connects to the XMPP server and opens the XMPP stream against the given +-- host name, port, and realm. +connect :: HostName -> PortID -> Text -> IO (Either XmppFailure (TMVar Connection)) +connect address port hostname = do + con <- connectTcp address port hostname + case con of + Right con' -> do + result <- withConnection startStream con' + return $ Right con' Left e -> do - withConnection (pushElement . pickleElem xpStreamError $ toError e) - con - closeStreams con return $ Left e - Right () -> return $ Right con - where - -- TODO: Descriptive texts in stream errors? - toError (StreamNotStreamElement _name) = - XmppStreamError StreamInvalidXml Nothing Nothing - toError (StreamInvalidStreamNamespace _ns) = - XmppStreamError StreamInvalidNamespace Nothing Nothing - toError (StreamInvalidStreamPrefix _prefix) = - XmppStreamError StreamBadNamespacePrefix Nothing Nothing - -- TODO: Catch remaining xmppStartStream errors. - toError (StreamWrongVersion _ver) = - XmppStreamError StreamUnsupportedVersion Nothing Nothing - toError (StreamWrongLangTag _) = - XmppStreamError StreamInvalidXml Nothing Nothing - toError StreamUnknownError = - XmppStreamError StreamBadFormat Nothing Nothing - toError (StreamWrongTo _) = - XmppStreamError StreamBadFormat Nothing Nothing - toError (StreamXMLError _) = - XmppStreamError StreamInvalidXml Nothing Nothing - toError StreamStreamEnd = - XmppStreamError StreamBadFormat Nothing Nothing - toError StreamConnectionError = - XmppStreamError StreamRemoteConnectionFailed Nothing Nothing - toError (StreamError _) = - XmppStreamError StreamUndefinedCondition Nothing Nothing - - -sessionXML :: Element -sessionXML = pickleElem +sessionXml :: Element +sessionXml = pickleElem (xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session") () @@ -111,14 +75,14 @@ sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" , iqRequestTo = Nothing , iqRequestLangTag = Nothing , iqRequestType = Set - , iqRequestPayload = sessionXML + , iqRequestPayload = sessionXml } -- Sends the session IQ set element and waits for an answer. Throws an error if -- if an IQ error stanza is returned from the server. -startSession :: Connection -> IO () +startSession :: TMVar Connection -> IO () startSession con = do - answer <- pushIQ' "session" Nothing Set Nothing sessionXML con + answer <- pushIQ' "session" Nothing Set Nothing sessionXml con case answer of Left e -> error $ show e Right _ -> return () @@ -127,13 +91,13 @@ startSession con = do -- resource. auth :: [SaslHandler] -> Maybe Text - -> Connection - -> IO (Either AuthError Jid) + -> TMVar Connection + -> IO (Either XmppFailure (Maybe AuthFailure)) auth mechanisms resource con = runErrorT $ do ErrorT $ xmppSasl mechanisms con jid <- lift $ xmppBind resource con lift $ startSession con - return jid + return Nothing -- | Authenticate to the server with the given username and password -- and bind a resource. @@ -143,8 +107,8 @@ simpleAuth :: Text.Text -- ^ The username -> Text.Text -- ^ The password -> Maybe Text -- ^ The desired resource or 'Nothing' to let the -- server assign one - -> Connection - -> IO (Either AuthError Jid) + -> TMVar Connection + -> IO (Either XmppFailure (Maybe AuthFailure)) simpleAuth username passwd resource = flip auth resource $ [ -- TODO: scramSha1Plus scramSha1 username Nothing passwd diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 35cd848..5688dec 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -20,12 +20,12 @@ import Data.Void (Void) import Data.XML.Pickle import Data.XML.Types -import Network.Xmpp.Connection -import Network.Xmpp.Errors +import Network.Xmpp.Connection_ import Network.Xmpp.Pickle import Network.Xmpp.Types +import Network.Xmpp.Marshal -import Text.XML.Stream.Elements +import Text.Xml.Stream.Elements import Text.XML.Stream.Parse as XP -- import Text.XML.Stream.Elements @@ -38,18 +38,18 @@ lmb :: [t] -> Maybe [t] lmb [] = Nothing lmb x = Just x --- Unpickles and returns a stream element. Throws a StreamXMLError on failure. +-- Unpickles and returns a stream element. streamUnpickleElem :: PU [Node] a -> Element -> StreamSink a streamUnpickleElem p x = do case unpickleElem p x of - Left l -> throwError $ StreamXMLError (show l) + Left l -> throwError $ XmppOtherFailure -- TODO: Log: StreamXmlError (show l) Right r -> return r -- This is the conduit sink that handles the stream XML events. We extend it -- with ErrorT capabilities. -type StreamSink a = ErrorT StreamError (Pipe Event Event Void () IO) a +type StreamSink a = ErrorT XmppFailure (Pipe Event Event Void () IO) a -- Discards all events before the first EventBeginElement. throwOutJunk :: Monad m => Sink Event m () @@ -67,42 +67,107 @@ openElementFromEvents = do hd <- lift CL.head case hd of Just (EventBeginElement name attrs) -> return $ Element name attrs [] - _ -> throwError $ StreamConnectionError + _ -> throwError $ XmppOtherFailure --- Sends the initial stream:stream element and pulls the server features. -startStream :: StateT Connection_ IO (Either StreamError ()) +-- Sends the initial stream:stream element and pulls the server features. If the +-- server responds in a way that is invalid, an appropriate stream error will be +-- generated, the connection to the server will be closed, and a XmppFailure +-- will be produced. +startStream :: StateT Connection IO (Either XmppFailure ()) startStream = runErrorT $ do - state <- get - -- Set the `to' attribute depending on the state of the connection. - let from = case sConnectionState state of - ConnectionPlain -> if sJidWhenPlain state - then sJid state else Nothing - ConnectionSecured -> sJid state - case sHostname state of - Nothing -> throwError StreamConnectionError + state <- lift $ get + con <- liftIO $ mkConnection state + -- Set the `from' (which is also the expected to) attribute depending on the + -- state of the connection. + let expectedTo = case cState state of + ConnectionPlain -> if cJidWhenPlain state + then cJid state else Nothing + ConnectionSecured -> cJid state + case cHostName state of + Nothing -> throwError XmppOtherFailure -- TODO: When does this happen? Just hostname -> lift $ do pushXmlDecl pushOpenElement $ pickleElem xpStream ( "1.0" - , from + , expectedTo , Just (Jid Nothing hostname Nothing) , Nothing - , sPreferredLang state + , cPreferredLang state ) - (lt, from, id, features) <- ErrorT . runEventsSink $ runErrorT $ - streamS from - modify (\s -> s{ sFeatures = features - , sStreamLang = Just lt - , sStreamId = id - , sFrom = from - } ) - return () + response <- ErrorT $ runEventsSink $ runErrorT $ streamS expectedTo + case response of + Left e -> throwError e + -- Successful unpickling of stream element. + Right (Right (ver, from, to, id, lt, features)) + | (unpack ver) /= "1.0" -> + closeStreamWithError con StreamUnsupportedVersion Nothing + | 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 $ cHostName state) Nothing)) -> + closeStreamWithError con StreamInvalidFrom Nothing + | to /= expectedTo -> + closeStreamWithError con StreamUndefinedCondition (Just $ Element "invalid-to" [] []) -- TODO: Suitable? + | otherwise -> do + modify (\s -> s{ cFeatures = features + , cStreamLang = lt + , cStreamId = id + , cFrom = from + } ) + return () + -- Unpickling failed - we investigate the element. + Right (Left (Element name attrs children)) + | (nameLocalName name /= "stream") -> + closeStreamWithError con StreamInvalidXml Nothing + | (nameNamespace name /= Just "http://etherx.jabber.org/streams") -> + closeStreamWithError con StreamInvalidNamespace Nothing + | (isJust $ namePrefix name) && (fromJust (namePrefix name) /= "stream") -> + closeStreamWithError con StreamBadNamespacePrefix Nothing + | otherwise -> ErrorT $ checkchildren con (flattenAttrs attrs) + where + -- closeStreamWithError :: MonadIO m => TMVar Connection -> StreamErrorCondition -> + -- Maybe Element -> ErrorT XmppFailure m () + closeStreamWithError con sec el = do + liftIO $ do + withConnection (pushElement . pickleElem xpStreamError $ + StreamErrorInfo sec Nothing el) con + closeStreams con + throwError XmppOtherFailure + checkchildren con children = + let to' = lookup "to" children + ver' = lookup "version" children + xl = lookup xmlLang children + in case () of () | Just (Nothing :: Maybe Jid) == (safeRead <$> to') -> + runErrorT $ closeStreamWithError con + StreamBadNamespacePrefix Nothing + | Nothing == ver' -> + runErrorT $ closeStreamWithError con + StreamUnsupportedVersion Nothing + | Just (Nothing :: Maybe LangTag) == (safeRead <$> xl) -> + runErrorT $ closeStreamWithError con + StreamInvalidXml Nothing + | otherwise -> + runErrorT $ closeStreamWithError con + StreamBadFormat Nothing + safeRead x = case reads $ Text.unpack x of + [] -> Nothing + [(y,_),_] -> Just y + +flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)] +flattenAttrs attrs = Prelude.map (\(name, content) -> + ( name + , Text.concat $ Prelude.map uncontentify content) + ) + attrs + where + uncontentify (ContentText t) = t + uncontentify _ = "" -- Sets a new Event source using the raw source (of bytes) -- and calls xmppStartStream. -restartStream :: StateT Connection_ IO (Either StreamError ()) +restartStream :: StateT Connection IO (Either XmppFailure ()) 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 }) @@ -115,43 +180,43 @@ restartStream = do else yield bs >> loopRead read -- Reads the (partial) stream:stream and the server features from the stream. --- Also validates the stream element's attributes and throws an error if --- appropriate. +-- Returns the (unvalidated) stream attributes, the unparsed element, or +-- throwError throws a `XmppOtherFailure' (if something other than an element +-- was encountered at first, or if something other than stream features was +-- encountered second). -- TODO: from. -streamS :: Maybe Jid -> StreamSink ( LangTag - , Maybe Jid - , Maybe Text - , ServerFeatures) +streamS :: Maybe Jid -> StreamSink (Either Element ( Text + , Maybe Jid + , Maybe Jid + , Maybe Text + , Maybe LangTag + , ServerFeatures )) streamS expectedTo = do - (from, to, id, langTag) <- xmppStreamHeader - features <- xmppStreamFeatures - return (langTag, from, id, features) + header <- xmppStreamHeader + case header of + Right (version, from, to, id, langTag) -> do + features <- xmppStreamFeatures + return $ Right (version, from, to, id, langTag, features) + Left el -> return $ Left el where - xmppStreamHeader :: StreamSink (Maybe Jid, Maybe Jid, Maybe Text.Text, LangTag) + xmppStreamHeader :: StreamSink (Either Element (Text, Maybe Jid, Maybe Jid, Maybe Text.Text, Maybe LangTag)) xmppStreamHeader = do lift throwOutJunk -- Get the stream:stream element (or whatever it is) from the server, -- and validate what we get. - el <- openElementFromEvents - liftIO . print $ unpickleElem xpStream el + el <- openElementFromEvents -- May throw `XmppOtherFailure' if an + -- element is not received case unpickleElem xpStream el of - Left _ -> throwError $ findStreamErrors el - Right r -> validateData r - - validateData (_, _, _, _, Nothing) = throwError $ StreamWrongLangTag Nothing - validateData (ver, from, to, i, Just lang) - | ver /= "1.0" = throwError $ StreamWrongVersion (Just ver) - | isJust to && to /= expectedTo = throwError $ StreamWrongTo (Text.pack . show <$> to) - | otherwise = return (from, to, i, lang) + Left _ -> return $ Left el + Right r -> return $ Right r xmppStreamFeatures :: StreamSink ServerFeatures xmppStreamFeatures = do e <- lift $ elements =$ CL.head case e of - Nothing -> liftIO $ Ex.throwIO StreamConnectionError + Nothing -> throwError XmppOtherFailure Just r -> streamUnpickleElem xpStreamFeatures r - xpStream :: PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag) xpStream = ("xpStream","") xpElemAttrs (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) @@ -175,14 +240,14 @@ xpStreamFeatures = ("xpStreamFeatures", "") xpWrap (Just "stream") ) (xpTriple - (xpOption pickleTLSFeature) + (xpOption pickleTlsFeature) (xpOption pickleSaslFeature) (xpAll xpElemVerbatim) ) ) where - pickleTLSFeature :: PU [Node] Bool - pickleTLSFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls" + pickleTlsFeature :: PU [Node] Bool + pickleTlsFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls" (xpElemExists "required") pickleSaslFeature :: PU [Node] [Text] pickleSaslFeature = xpElemNodes diff --git a/source/Network/Xmpp/TLS.hs b/source/Network/Xmpp/Tls.hs similarity index 59% rename from source/Network/Xmpp/TLS.hs rename to source/Network/Xmpp/Tls.hs index e9f3225..0d5754e 100644 --- a/source/Network/Xmpp/TLS.hs +++ b/source/Network/Xmpp/Tls.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.TLS where +module Network.Xmpp.Tls where import qualified Control.Exception.Lifted as Ex import Control.Monad @@ -13,15 +13,16 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import Data.Conduit import qualified Data.Conduit.Binary as CB -import Data.Conduit.TLS as TLS +import Data.Conduit.Tls as TLS import Data.Typeable import Data.XML.Types -import Network.Xmpp.Connection -import Text.XML.Stream.Elements(ppElement) +import Network.Xmpp.Connection_ import Network.Xmpp.Stream import Network.Xmpp.Types +import Control.Concurrent.STM.TMVar + mkBackend con = Backend { backendSend = \bs -> void (cSend con bs) , backendRecv = cRecv con , backendFlush = cFlush con @@ -72,48 +73,33 @@ exampleParams = TLS.defaultParamsClient return TLS.CertificateUsageAccept } --- | Error conditions that may arise during TLS negotiation. -data XmppTLSError = TLSError TLSError - | TLSNoServerSupport - | TLSNoConnection - | TLSConnectionSecured -- ^ Connection already secured - | TLSStreamError StreamError - | XmppTLSError -- General instance used for the Error instance - deriving (Show, Eq, Typeable) - -instance Error XmppTLSError where - noMsg = XmppTLSError - -- Pushes ", waits for "", performs the TLS handshake, and --- restarts the stream. May throw errors. -startTLS :: TLS.TLSParams -> Connection -> IO (Either XmppTLSError ()) -startTLS params con = Ex.handle (return . Left . TLSError) +-- restarts the stream. +startTls :: TLS.TLSParams -> TMVar Connection -> IO (Either XmppFailure ()) +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 - when (stls features == Nothing) $ throwError TLSNoServerSupport + ConnectionClosed -> throwError XmppNoConnection + ConnectionSecured -> throwError TlsConnectionSecured + con <- lift $ gets cHandle + when (stls features == Nothing) $ throwError TlsNoServerSupport lift $ pushElement starttlsE answer <- lift $ pullElement case answer of - Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return () - Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _ -> - lift . Ex.throwIO $ StreamConnectionError - -- TODO: find something more suitable - e -> lift . Ex.throwIO . StreamXMLError $ - "Unexpected element: " ++ ppElement e + Left e -> return $ Left e + Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] []) -> return $ Right () + Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _) -> return $ Left XmppOtherFailure (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 bb2c033..f36548d 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -28,17 +28,16 @@ module Network.Xmpp.Types , StanzaErrorCondition(..) , StanzaErrorType(..) , StanzaID(..) - , StreamError(..) + , XmppFailure(..) , StreamErrorCondition(..) , Version(..) - , HandleLike(..) + , ConnectionHandle(..) , Connection(..) - , Connection_(..) , withConnection , withConnection' , mkConnection , ConnectionState(..) - , XmppStreamError(..) + , StreamErrorInfo(..) , langTag , module Network.Xmpp.Jid ) @@ -62,6 +61,7 @@ import qualified Data.Text as Text import Data.Typeable(Typeable) import Data.XML.Types +import qualified Network.TLS as TLS import qualified Network as N @@ -619,28 +619,41 @@ instance Read StreamErrorCondition where readsPrec _ "unsupported-version" = [(StreamUnsupportedVersion , "")] readsPrec _ _ = [(StreamUndefinedCondition , "")] -data XmppStreamError = XmppStreamError +-- | Encapsulates information about an XMPP stream error. +data StreamErrorInfo = StreamErrorInfo { errorCondition :: !StreamErrorCondition , errorText :: !(Maybe (Maybe LangTag, Text)) - , errorXML :: !(Maybe Element) + , errorXml :: !(Maybe Element) } deriving (Show, Eq) -data StreamError = StreamError XmppStreamError - | StreamUnknownError -- Something has gone wrong, but we don't - -- know what - | StreamNotStreamElement Text - | StreamInvalidStreamNamespace (Maybe Text) - | StreamInvalidStreamPrefix (Maybe Text) - | StreamWrongTo (Maybe Text) - | StreamWrongVersion (Maybe Text) - | StreamWrongLangTag (Maybe Text) - | StreamXMLError String -- If stream pickling goes wrong. - | StreamStreamEnd -- received closing stream tag - | StreamConnectionError +-- | Signals an XMPP stream error or another unpredicted stream-related +-- situation. +data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream + -- element has been + -- encountered. + | StreamEndFailure -- ^ The stream has been closed. + -- This exception is caught by the + -- concurrent implementation, and + -- will thus not be visible + -- through use of 'Session'. + | StreamCloseError ([Element], XmppFailure) -- ^ When an XmppFailure + -- is encountered in + -- closeStreams, this + -- constructor wraps the + -- elements collected so + -- far. + | TlsError TLS.TLSError + | TlsNoServerSupport + | XmppNoConnection + | TlsConnectionSecured -- ^ Connection already secured + | XmppOtherFailure -- ^ Undefined condition. More + -- information should be available + -- in the log. + | XmppIOException IOException deriving (Show, Eq, Typeable) -instance Exception StreamError -instance Error StreamError where noMsg = StreamConnectionError +instance Exception XmppFailure +instance Error XmppFailure where noMsg = XmppOtherFailure -- ============================================================================= -- XML TYPES @@ -740,59 +753,50 @@ 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 () - } - -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. - } - - -newtype Connection = Connection {unConnection :: TMVar Connection_} - -withConnection :: StateT Connection_ IO c -> Connection -> IO c -withConnection action (Connection con) = bracketOnError +-- | 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 + { 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 (Either XmppFailure c) -> TMVar Connection -> IO (Either XmppFailure c) +withConnection action con = bracketOnError (atomically $ takeTMVar con) (atomically . putTMVar con ) (\c -> do @@ -802,12 +806,12 @@ withConnection action (Connection con) = bracketOnError ) -- nonblocking version. Changes to the connection are ignored! -withConnection' :: StateT Connection_ IO b -> Connection -> IO b -withConnection' action (Connection con) = do +withConnection' :: StateT Connection IO (Either XmppFailure b) -> TMVar Connection -> IO (Either XmppFailure b) +withConnection' action con = do con_ <- atomically $ readTMVar con (r, _) <- runStateT action con_ return r -mkConnection :: Connection_ -> IO Connection -mkConnection con = Connection `fmap` (atomically $ newTMVar con) +mkConnection :: Connection -> IO (TMVar Connection) +mkConnection con = {- Connection `fmap` -} (atomically $ newTMVar con) diff --git a/source/Network/Xmpp/Xep/InbandRegistration.hs b/source/Network/Xmpp/Xep/InbandRegistration.hs index 4f68b60..27deeb8 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.Basic @@ -50,7 +50,7 @@ data Query = Query { instructions :: Maybe Text.Text emptyQuery = Query Nothing False False [] -query :: IQRequestType -> Query -> Connection -> IO (Either IbrError Query) +query :: IQRequestType -> Query -> TMVar Connection -> IO (Either IbrError Query) query queryType x con = do answer <- pushIQ' "ibr" Nothing queryType Nothing (pickleElem xpQuery x) con case answer of @@ -93,8 +93,8 @@ mapError f = mapErrorT (liftM $ left f) -- | Retrieve the necessary fields and fill them in to register an account with -- the server. registerWith :: [(Field, Text.Text)] - -> Connection - -> IO (Either RegisterError Query) + -> TMVar Connection + -> IO (Either RegisterError Query) registerWith givenFields con = runErrorT $ do fs <- mapError IbrError . ErrorT $ requestFields con when (registered fs) . throwError $ AlreadyRegistered @@ -125,7 +125,7 @@ deleteAccount host hostname port username password = do -- | Terminate your account on the server. You have to be logged in for this to -- work. You connection will most likely be terminated after unregistering. -unregister :: Connection -> IO (Either IbrError Query) +unregister :: TMVar Connection -> IO (Either IbrError Query) unregister = query Set $ emptyQuery {remove = True} unregister' :: Session -> IO (Either IbrError Query) diff --git a/source/Network/Xmpp/Xep/ServiceDiscovery.hs b/source/Network/Xmpp/Xep/ServiceDiscovery.hs index f4ee1e1..d5325e0 100644 --- a/source/Network/Xmpp/Xep/ServiceDiscovery.hs +++ b/source/Network/Xmpp/Xep/ServiceDiscovery.hs @@ -26,16 +26,16 @@ import Data.XML.Types 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 data DiscoError = DiscoNoQueryElement - | DiscoIQError IQError + | DiscoIQError (Maybe IQError) | DiscoTimeout - | DiscoXMLError Element UnpickleError + | DiscoXmlError Element UnpickleError deriving (Show) @@ -92,12 +92,12 @@ queryInfo :: Jid -- ^ Entity to query queryInfo to node context = do res <- sendIQ' (Just to) Get Nothing queryBody context return $ case res of - IQResponseError e -> Left $ DiscoIQError e + IQResponseError e -> Left $ DiscoIQError (Just e) IQResponseTimeout -> Left $ DiscoTimeout IQResponseResult r -> case iqResultPayload r of Nothing -> Left DiscoNoQueryElement Just p -> case unpickleElem xpQueryInfo p of - Left e -> Left $ DiscoXMLError p e + Left e -> Left $ DiscoXmlError p e Right r -> Right r where queryBody = pickleElem xpQueryInfo (QIR node [] []) @@ -105,17 +105,19 @@ queryInfo to node context = do xmppQueryInfo :: Maybe Jid -> Maybe Text.Text - -> Connection + -> TMVar Connection -> IO (Either DiscoError QueryInfoResult) xmppQueryInfo to node con = do res <- pushIQ' "info" to Get Nothing queryBody con return $ case res of - Left e -> Left $ DiscoIQError e - Right r -> case iqResultPayload r of - Nothing -> Left DiscoNoQueryElement - Just p -> case unpickleElem xpQueryInfo p of - Left e -> Left $ DiscoXMLError p e - Right r -> Right r + Left e -> Left $ DiscoIQError Nothing + Right res' -> case res' of + Left e -> Left $ DiscoIQError (Just e) + Right r -> case iqResultPayload r of + Nothing -> Left DiscoNoQueryElement + Just p -> case unpickleElem xpQueryInfo p of + Left e -> Left $ DiscoXmlError p e + Right r -> Right r where queryBody = pickleElem xpQueryInfo (QIR node [] []) @@ -156,12 +158,12 @@ queryItems :: Jid -- ^ Entity to query queryItems to node session = do res <- sendIQ' (Just to) Get Nothing queryBody session return $ case res of - IQResponseError e -> Left $ DiscoIQError e + IQResponseError e -> Left $ DiscoIQError (Just e) IQResponseTimeout -> Left $ DiscoTimeout IQResponseResult r -> case iqResultPayload r of Nothing -> Left DiscoNoQueryElement Just p -> case unpickleElem xpQueryItems p of - Left e -> Left $ DiscoXMLError p e + Left e -> Left $ DiscoXmlError p e Right r -> Right r where queryBody = pickleElem xpQueryItems (node, []) diff --git a/source/Text/XML/Stream/Elements.hs b/source/Text/Xml/Stream/Elements.hs similarity index 97% rename from source/Text/XML/Stream/Elements.hs rename to source/Text/Xml/Stream/Elements.hs index e0156e5..a357607 100644 --- a/source/Text/XML/Stream/Elements.hs +++ b/source/Text/Xml/Stream/Elements.hs @@ -1,7 +1,7 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} -module Text.XML.Stream.Elements where +module Text.Xml.Stream.Elements where import Control.Applicative ((<$>)) import Control.Exception diff --git a/source/Utils.hs b/source/Utils.hs deleted file mode 100644 index ed4fd84..0000000 --- a/source/Utils.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Utils where - -whileJust f = do - f' <- f - case f' of - Just x -> x : whileJust f - Nothing -> []