diff --git a/LICENSE b/LICENSE deleted file mode 100644 --- a/LICENSE +++ /dev/null @@ -1,15 +0,0 @@ -Copyright © 2005-2011 Dmitry Astapov -Copyright © 2005-2011 Pierre Kovalev -Copyright © 2010-2011 Mahdi Abdinejadi -Copyright © 2010-2012 Jon Kristensen -Copyright © 2011 IETF Trust -Copyright © 2012 Philipp Balzarek - -Licensed under the Apache License, Version 2.0 (the "License"); you may not use -this file except in compliance with the License. You may obtain a copy of the -License at . - -Unless required by applicable law or agreed to in writing, software distributed -under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR -CONDITIONS OF ANY KIND, either express or implied. See the License for the -specific language governing permissions and limitations under the License. diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,16 @@ +Copyright © 2005-2011 Dmitry Astapov +Copyright © 2005-2011 Pierre Kovalev +Copyright © 2010-2011 Mahdi Abdinejadi +Copyright © 2010-2012 Jon Kristensen +Copyright © 2011 IETF Trust +Copyright © 2012 Philipp Balzarek + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use +this file except in compliance with the License. You may obtain a copy of the +License at +[http://www.apache.org/licenses/LICENSE-2.0](http://www.apache.org/licenses/LICENSE-2.0). + +Unless required by applicable law or agreed to in writing, software distributed +under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR +CONDITIONS OF ANY KIND, either express or implied. See the License for the +specific language governing permissions and limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,81 @@ +Welcome to Pontarius XMPP! +========================== + +Pontarius XMPP is an active work in progress to build a Haskell XMPP library +that implements the client capabilities of [RFC 6120](http://tools.ietf.org/html/rfc6120). + +Getting started +--------------- + +The latest release of Pontarius XMPP, as well as its module API pages, can +always be found at [the Pontarius XMPP Hackage +page](http://hackage.haskell.org/package/pontarius-xmpp/). + +_Note:_ Pontarius XMPP is still in its Alpha phase. Pontarius XMPP is not yet +feature-complete, it may contain bugs, and its API may change between versions. + +The first thing to do is to import the modules that we are going to use. + + import Network.Xmpp + + import Control.Monad + import Data.Default + import System.Log.Logger + +Pontarius XMPP supports [hslogger](http://hackage.haskell.org/package/hslogger) +logging. Start by enabling console logging. + + updateGlobalLogger "Pontarius.Xmpp" $ setLevel DEBUG + +When this is done, a Session object can be acquired by calling +session. This object will be used for interacting with the library. + + result <- session + "example.com" + def + (Just ([scramSha1 "username" Nothing "password"], Nothing)) + +_Tip:_ Note that the first parameter actually is a Text value. Import +Data.Text and use the OverloadedStrings LANGUAGE pragma. + +The three parameters above are the XMPP server realm, the session configuration +settings (set to the default settings), and a SASL handler (for authentication). +session will perform the necessary DNS queries to find the address +of the realm, connect, establish the XMPP stream, attempt to secure the stream +with TLS, authenticate, establish a concurrent interface for interacting with +the stream, and return the Session object. + +The return type of session is IO (Either XmppFailure +Session). As XmppFailure is an +Control.Monad.Error instance, you can utilize the +ErrorT monad transformer for error handling. A more simple way of +doing it could be doing something like this: + + sess <- case result of + Right s -> return s + Left e -> error $ "XmppFailure: " ++ (show e) + +Next, let us set our status to Online. + + sendPresence (Presence Nothing Nothing Nothing Nothing Nothing []) sess + +Now, let's say that we want to receive all message stanzas, and echo the stanzas +back to the recipient. This can be done like so: + + forever $ do + msg <- getMessage sess + case answerMessage msg (messagePayload msg) of + Just answer -> sendMessage answer sess + Nothing -> putStrLn "Received message with no sender." + +Additional XMPP threads can be created using dupSession and +forkIO. + +For a public domain example of a simple Pontarius XMPP (Cabal) project, refer to +the examples/echoclient directory. + +More information +---------------- + +Feel free to [contact Jon Kristensen](http://www.jonkri.com/contact/) if you +have any questions or comments. diff --git a/examples/echoclient/LICENSE.md b/examples/echoclient/LICENSE.md new file mode 100644 --- /dev/null +++ b/examples/echoclient/LICENSE.md @@ -0,0 +1,2 @@ +The `Main.hs', `Setup.hs', and `echoclient.cabal' files in this directory are in +the public domain. diff --git a/examples/echoclient/Main.hs b/examples/echoclient/Main.hs new file mode 100644 --- /dev/null +++ b/examples/echoclient/Main.hs @@ -0,0 +1,33 @@ +{- + +This directory defines a project that illustrates how to connect, authenticate, +set a simple presence, receive message stanzas, and echo them back to whoever is +sending them, using Pontarius XMPP. This file is in the public domain. + +-} + +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Monad +import Data.Default +import Network.Xmpp +import System.Log.Logger + +main :: IO () +main = do + updateGlobalLogger "Pontarius.Xmpp" $ setLevel DEBUG + result <- session + "example.com" + def + (Just ([scramSha1 "username" Nothing "password"], Nothing)) + sess <- case result of + Right s -> return s + Left e -> error $ "XmppFailure: " ++ (show e) + sendPresence (Presence Nothing Nothing Nothing Nothing Nothing []) sess + forever $ do + msg <- getMessage sess + case answerMessage msg (messagePayload msg) of + Just answer -> sendMessage answer sess + Nothing -> putStrLn "Received message with no sender." diff --git a/examples/echoclient/README.md b/examples/echoclient/README.md new file mode 100644 --- /dev/null +++ b/examples/echoclient/README.md @@ -0,0 +1,6 @@ +This directory defines a project that illustrates how to connect, authenticate, +set a simple presence, receive message stanzas, and echo them back to whoever is +sending them, using Pontarius XMPP. + +The `Main.hs', `Setup.hs', and `echoclient.cabal' files in this directory may be +used freely, as they are in the public domain. diff --git a/examples/echoclient/Setup.hs b/examples/echoclient/Setup.hs new file mode 100644 --- /dev/null +++ b/examples/echoclient/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/echoclient/echoclient.cabal b/examples/echoclient/echoclient.cabal new file mode 100644 --- /dev/null +++ b/examples/echoclient/echoclient.cabal @@ -0,0 +1,17 @@ +-- This directory defines a project that illustrates how to connect, +-- authenticate, set a simple presence, receive message stanzas, and echo them +-- back to whoever is sending them, using Pontarius XMPP. This file is in the +-- public domain. + +Name: echoclient +Version: 0.0.0.0 +Cabal-Version: >= 1.6 +Build-Type: Simple +License: OtherLicense +Copyright: Mahdi Abdinejadi, Jon Kristensen, Philipp Balzarek +Maintainer: info@jonkri.com +Synopsis: Echo client test program for Pontarius XMPP + +Executable echoclient + Build-Depends: base, data-default, hslogger, mtl, pontarius-xmpp, text, tls + Main-Is: Main.hs diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -1,91 +1,80 @@ -Name: pontarius-xmpp -Version: 0.1.0.2 +Name: pontarius-xmpp +Version: 0.2.0.0 Cabal-Version: >= 1.6 -Build-Type: Simple -License: OtherLicense -License-File: LICENSE -Copyright: Dmitry Astapov, Pierre Kovalev, Mahdi Abdinejadi, Jon Kristensen, - IETF Trust, Philipp Balzarek -Author: Jon Kristensen, Mahdi Abdinejadi, Philipp Balzarek -Maintainer: info@jonkri.com -Stability: alpha -Homepage: http://www.pontarius.org/ -Bug-Reports: mailto:info@jonkri.com -Package-URL: http://hackage.haskell.org/packages/archive/pontarius-xmpp/0.1.0.2/pontarius-xmpp-0.1.0.2.tar.gz -Synopsis: An incomplete implementation of RFC 6120 (XMPP: Core) -Description: Pontarius is a work in progress implementation of - RFC 6120 (XMPP: Core). -Category: Network -Tested-With: GHC ==7.0.4, GHC ==7.4.1 --- Data-Files: --- Data-Dir: --- Extra-Source-Files: --- Extra-Tmp-Files: +Build-Type: Simple +License: OtherLicense +License-File: LICENSE.md +Copyright: Dmitry Astapov, Pierre Kovalev, Mahdi Abdinejadi, Jon Kristensen, + IETF Trust, Philipp Balzarek +Author: Jon Kristensen, Mahdi Abdinejadi, Philipp Balzarek +Maintainer: info@jonkri.com +Stability: alpha +Homepage: https://github.com/jonkri/pontarius-xmpp/ +Bug-Reports: mailto:info@jonkri.com +Package-URL: http://www.jonkri.com/releases/pontarius-xmpp-0.2.0.0.tar.gz +Synopsis: An incomplete implementation of RFC 6120 (XMPP: Core) +Description: Pontarius XMPP is a work in progress implementation of + RFC 6120 (XMPP: Core). +Category: Network +Tested-With: GHC ==7.0.4, GHC ==7.4.1 Library hs-source-dirs: source Exposed: True - Build-Depends: base >4 && <5 - , conduit >=0.5 - , void >=0.5.5 - , resourcet >=0.3.0 - , containers >=0.4.0.0 - , random >=1.0.0.0 - , tls >=1.0.0 - , tls-extra >=0.5.0 - , pureMD5 >=2.1.2.1 + Build-Depends: attoparsec >=0.10.0.3 + , base >4 && <5 , base64-bytestring >=0.1.0.0 , binary >=0.4.1 - , attoparsec >=0.10.0.3 + , bytestring >=0.9.1.9 + , conduit >=0.5 && <1.0 + , containers >=0.4.0.0 , crypto-api >=0.9 + , crypto-random-api >=0.2 , cryptohash >=0.6.1 - , text >=0.11.1.5 - , bytestring >=0.9.1.9 - , transformers >=0.2.2.0 + , data-default >=0.2 + , dns >=0.3.0 + , hslogger >=1.1.0 + , iproute >=1.2.4 + , lifted-base >=0.1.0.1 , mtl >=2.0.0.0 , network >=2.3 - , lifted-base >=0.1.0.1 + , pureMD5 >=2.1.2.1 + , resourcet >=0.3.0 + , random >=1.0.0.0 , split >=0.1.2.3 , stm >=2.1.2.1 + , stringprep >=0.1.3 + , text >=0.11.1.5 + , tls >=1.1.0 + , tls-extra >=0.5.0 + , transformers >=0.2.2.0 + , void >=0.5.5 , xml-types >=0.3.1 , xml-conduit >=1.0 - , xml-picklers >=0.2.2 - , data-default >=0.2 - , stringprep >=0.1.3 + , xml-picklers >=0.3 Exposed-modules: Network.Xmpp - , Network.Xmpp.Bind - , Network.Xmpp.Concurrent - , Network.Xmpp.IM - , Network.Xmpp.IM.Message - , Network.Xmpp.IM.Presence - , Network.Xmpp.Marshal - , Network.Xmpp.Monad - , 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 - Other-modules: - Network.Xmpp.Jid - , Network.Xmpp.Concurrent.Types - , Network.Xmpp.Concurrent.IQ - , Network.Xmpp.Concurrent.Threads - , Network.Xmpp.Concurrent.Monad - , Text.XML.Stream.Elements - , Data.Conduit.BufferedSource - , Data.Conduit.TLS - , Network.Xmpp.Sasl.Common - , Network.Xmpp.Sasl.StringPrep - , Network.Xmpp.Errors + , Network.Xmpp.Internal + Other-modules: 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.Marshal + , 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.Stream + , Network.Xmpp.Tls + , Network.Xmpp.Types + , Network.Xmpp.Utilities GHC-Options: -Wall Source-Repository head @@ -94,7 +83,5 @@ Source-Repository this Type: git - -- Module: Location: git://github.com/jonkri/pontarius-xmpp.git - Tag: 0.1.0.2 - -- Subdir: + Tag: 0.2.0.0 diff --git a/source/Data/Conduit/BufferedSource.hs b/source/Data/Conduit/BufferedSource.hs deleted file mode 100644 --- a/source/Data/Conduit/BufferedSource.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module Data.Conduit.BufferedSource where - -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Exception -import Data.IORef -import Data.Conduit -import Data.Typeable(Typeable) -import qualified Data.Conduit.Internal as DCI -import qualified Data.Conduit.List as CL - -data SourceClosed = SourceClosed deriving (Show, Typeable) - -instance Exception SourceClosed - --- | Buffered source from conduit 0.3 -bufferSource :: MonadIO m => Source m o -> IO (Source m o) -bufferSource s = do - srcRef <- newIORef . Just $ DCI.ResumableSource s (return ()) - return $ do - src' <- liftIO $ readIORef srcRef - src <- case src' of - Just s -> return s - Nothing -> liftIO $ throwIO SourceClosed - let go src = do - (src', res) <- lift $ src $$++ CL.head - case res of - Nothing -> liftIO $ writeIORef srcRef Nothing - Just x -> do - liftIO (writeIORef srcRef $ Just src') - yield x - go src' - in go src diff --git a/source/Data/Conduit/TLS.hs b/source/Data/Conduit/TLS.hs deleted file mode 100644 --- a/source/Data/Conduit/TLS.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# Language NoMonomorphismRestriction #-} -{-# OPTIONS_HADDOCK hide #-} -module Data.Conduit.TLS - ( tlsinit --- , conduitStdout - , module TLS - , module TLSExtra - ) - where - -import Control.Monad(liftM, when) -import Control.Monad.IO.Class - -import Crypto.Random - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL -import Data.Conduit -import Control.Monad - -import Network.TLS as TLS -import Network.TLS.Extra as TLSExtra - -import System.IO(Handle) - -client params gen handle = do - contextNewOnHandle handle params gen - -defaultParams = defaultParamsClient - -tlsinit :: (MonadIO m, MonadIO m1) => - Bool - -> TLSParams - -> Handle -> m ( Source m1 BS.ByteString - , Sink BS.ByteString m1 () - , BS.ByteString -> IO () - , Context - ) -tlsinit debug tlsParams handle = do - when debug . liftIO $ putStrLn "TLS with debug mode enabled" - gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source? - con <- client tlsParams gen handle - handshake con - let src = forever $ do - dt <- liftIO $ recvData con - when debug (liftIO $ putStr "in: " >> BS.putStrLn dt) - yield dt - let snk = do - d <- await - case d of - Nothing -> return () - Just x -> do - sendData con (BL.fromChunks [x]) - when debug (liftIO $ putStr "out: " >> BS.putStrLn x) - snk - return ( src - , snk - , \s -> do - when debug (liftIO $ BS.putStrLn s) - sendData con $ BL.fromChunks [s] - , con - ) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -1,8 +1,5 @@ -- | -- Module: $Header$ --- Description: A work in progress client implementation of RFC 6120 (XMPP: --- Core). --- License: Apache License 2.0 -- -- Maintainer: info@jonkri.com -- Stability: unstable @@ -17,43 +14,47 @@ -- 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.Internal" +-- module. {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} module Network.Xmpp ( -- * Session management Session - , newSession - , withConnection - , connect - , simpleConnect - , startTLS - , simpleAuth - , auth - , closeConnection - , endSession - , setConnectionClosedHandler - -- * JID + , session + , StreamConfiguration(..) + , SessionConfiguration(..) + -- TODO: Close session, etc. + -- ** Authentication handlers + -- | The use of 'scramSha1' is /recommended/, but 'digestMd5' might be + -- useful for interaction with older implementations. + , scramSha1 + , plain + , 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. , Jid(..) , isBare , isFull + , jidFromText + , jidFromTexts -- * Stanzas -- | 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 + -- * /Message/, for traditional push-style message passing between peers -- - -- * @'Presence'@, for communicating status updates + -- * /Presence/, for communicating status updates -- - -- * IQ (info/query), for request-response semantics communication + -- * /Info/\//Query/ (or /IQ/), for request-response semantics communication -- -- All stanza types have the following attributes in common: -- @@ -73,13 +74,12 @@ -- 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. - , getStanzaChan + -- ** Messages - -- | The /message/ stanza is a /push/ mechanism whereby one entity pushes - -- information to another entity, similar to the communications that occur in - -- a system such as email. - -- - -- + -- | The /message/ stanza is a /push/ mechanism whereby one entity + -- pushes information to another entity, similar to the communications that + -- occur in a system such as email. It is not to be confused with + -- /instant messaging/ which is handled in the 'Network.Xmpp.IM' module , Message(..) , MessageError(..) , MessageType(..) @@ -89,6 +89,7 @@ , sendMessage -- *** Receiving , pullMessage + , getMessage , waitForMessage , waitForMessageError , filterMessages @@ -98,9 +99,10 @@ -- for communication is signaled end-to-end by means of a dedicated -- communication primitive: the presence stanza. , Presence(..) + , PresenceType(..) , PresenceError(..) -- *** Creating - , module Network.Xmpp.Presence + , presTo -- *** Sending -- | Sends a presence stanza. In general, the presence stanza should have no -- 'to' attribute, in which case the server to which the client is connected @@ -137,114 +139,27 @@ , listenIQChan , iqRequestPayload , iqResultPayload + -- * Errors + , StanzaError(..) + , StanzaErrorType(..) + , StanzaErrorCondition(..) -- * Threads - , forkSession + , dupSession -- * Miscellaneous , LangTag(..) - , exampleParams + , XmppFailure(..) + , StreamErrorInfo(..) + , StreamErrorCondition(..) + , AuthFailure( AuthNoAcceptableMechanism + , AuthSaslFailure + , AuthIllegalCredentials + , AuthOtherFailure ) ) where -import Data.Text as Text - -import Network -import qualified Network.TLS as TLS -import Network.Xmpp.Bind -import Network.Xmpp.Concurrent -import Network.Xmpp.Concurrent.Types -import Network.Xmpp.Marshal -import Network.Xmpp.Message -import Network.Xmpp.Monad -import Network.Xmpp.Pickle -import Network.Xmpp.Presence -import Network.Xmpp.Sasl -import Network.Xmpp.Sasl.Mechanisms -import Network.Xmpp.Sasl.Types -import Network.Xmpp.Session -import Network.Xmpp.Stream -import Network.Xmpp.TLS -import Network.Xmpp.Types - -import Control.Monad.Error - --- | Connect to host with given address. -connect :: HostName -> Text -> XmppConMonad (Either StreamError ()) -connect address hostname = do - xmppRawConnect address hostname - result <- xmppStartStream - case result of - Left e -> do - pushElement . pickleElem xpStreamError $ toError e - xmppCloseStreams - return () - Right () -> return () - return result - 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 - - --- | Authenticate to the server using the first matching method and bind a --- resource. -auth :: [SaslHandler] - -> Maybe Text - -> XmppConMonad (Either AuthError Jid) -auth mechanisms resource = runErrorT $ do - ErrorT $ xmppSasl mechanisms - jid <- lift $ xmppBind resource - lift $ xmppStartSession - return jid - --- | Authenticate to the server with the given username and password --- and bind a resource. --- --- Prefers SCRAM-SHA1 over DIGEST-MD5. -simpleAuth :: Text.Text -- ^ The username - -> Text.Text -- ^ The password - -> Maybe Text -- ^ The desired resource or 'Nothing' to let the - -- server assign one - -> XmppConMonad (Either AuthError Jid) -simpleAuth username passwd resource = flip auth resource $ - [ -- TODO: scramSha1Plus - scramSha1 username Nothing passwd - , digestMd5 username Nothing passwd - ] - - - --- | The quick and easy way to set up a connection to 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 -- ^ Target host name - -> Text -- ^ User name (authcid) - -> Text -- ^ Password - -> Maybe Text -- ^ Desired resource (or Nothing to let the server - -- decide) - -> XmppConMonad Jid -simpleConnect host username password resource = do - connect host username - startTLS exampleParams - saslResponse <- simpleAuth username password resource - case saslResponse of - Right jid -> return jid - Left e -> error $ show e +import Network +import Network.Xmpp.Concurrent +import Network.Xmpp.Utilities +import Network.Xmpp.Sasl +import Network.Xmpp.Sasl.Types +import Network.Xmpp.Tls +import Network.Xmpp.Types diff --git a/source/Network/Xmpp/Bind.hs b/source/Network/Xmpp/Bind.hs deleted file mode 100644 --- a/source/Network/Xmpp/Bind.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE OverloadedStrings #-} - -{-# OPTIONS_HADDOCK hide #-} - -module Network.Xmpp.Bind where - -import Control.Exception - -import Data.Text as Text -import Data.XML.Pickle -import Data.XML.Types - -import Network.Xmpp.Types -import Network.Xmpp.Pickle -import Network.Xmpp.Monad - -import Control.Monad.State(modify) - --- Produces a `bind' element, optionally wrapping a resource. -bindBody :: Maybe Text -> Element -bindBody = pickleElem $ - -- Pickler to produce a - -- "" - -- element, with a possible "[JID]" - -- child. - xpBind . xpOption $ xpElemNodes "resource" (xpContent xpId) - --- 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 -> XmppConMonad Jid -xmppBind rsrc = do - answer <- xmppSendIQ' "bind" Nothing Set Nothing (bindBody rsrc) - 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) - modify (\s -> s{sJid = Just jid}) - return jid - where - -- Extracts the character data in the `jid' element. - xpJid :: PU [Node] Jid - xpJid = xpBind $ xpElemNodes jidName (xpContent xpPrim) - jidName = "{urn:ietf:params:xml:ns:xmpp-bind}jid" - --- A `bind' element pickler. -xpBind :: PU [Node] b -> PU [Node] b -xpBind c = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-bind}bind" c diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -1,11 +1,148 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE OverloadedStrings #-} module Network.Xmpp.Concurrent - ( Session - , module Network.Xmpp.Concurrent.Monad + ( module Network.Xmpp.Concurrent.Monad , module Network.Xmpp.Concurrent.Threads + , 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 + , session ) where -import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Monad import Network.Xmpp.Concurrent.Threads +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.Types +import Network +import Data.Text as Text +import Network.Xmpp.Tls +import qualified Network.TLS as TLS +import Network.Xmpp.Sasl +import Network.Xmpp.Sasl.Mechanisms +import Network.Xmpp.Sasl.Types +import Data.Maybe +import Network.Xmpp.Stream +import Network.Xmpp.Utilities + +import Control.Monad.Error +import Data.Default +import System.Log.Logger +import Control.Monad.State.Strict + +toChans :: TChan Stanza + -> TChan Stanza + -> TVar IQHandlers + -> Stanza + -> IO () +toChans stanzaC outC 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 -> writeTChan outC $ serviceUnavailable iq + Just ch -> do + sent <- newTVar False + writeTChan ch $ IQRequestTicket sent iq + serviceUnavailable (IQRequest iqid from _to lang _tp bd) = + IQErrorS $ IQError iqid Nothing from lang err (Just bd) + err = StanzaError Cancel ServiceUnavailable Nothing Nothing + + 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 :: Stream -> SessionConfiguration -> IO (Either XmppFailure Session) +newSession stream config = runErrorT $ do + outC <- lift newTChanIO + stanzaChan <- lift newTChanIO + iqHandlers <- lift $ newTVarIO (Map.empty, Map.empty) + eh <- lift $ newTVarIO $ EventHandlers { connectionClosedHandler = sessionClosedHandler config } + let stanzaHandler = toChans stanzaChan outC iqHandlers + (kill, wLock, streamState, readerThread) <- ErrorT $ startThreadsWith stanzaHandler eh stream + writer <- lift $ forkIO $ writeWorker outC wLock + return $ Session { stanzaCh = stanzaChan + , outCh = outC + , iqHandlers = iqHandlers + , writeRef = wLock + , readerThread = readerThread + , idGenerator = sessionStanzaIDs config + , streamRef = streamState + , eventHandlers = eh + , stopThreads = kill >> killThread writer + , conf = config + } + +-- 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. + +-- | Creates a 'Session' object by setting up a connection with an XMPP server. +-- +-- Will connect to the specified host with the provided configuration. If the +-- third parameter is a 'Just' value, @session@ will attempt to authenticate and +-- acquire an XMPP resource. +session :: HostName -- ^ The hostname / realm + -> SessionConfiguration -- ^ configuration details + -> Maybe ([SaslHandler], Maybe Text) -- ^ SASL handlers and the desired + -- JID resource (or Nothing to let + -- the server decide) + -> IO (Either XmppFailure Session) +session realm config mbSasl = runErrorT $ do + stream <- ErrorT $ openStream realm (sessionStreamConfiguration config) + ErrorT $ tls stream + mbAuthError <- case mbSasl of + Nothing -> return Nothing + Just (handlers, resource) -> ErrorT $ auth handlers resource stream + case mbAuthError of + Nothing -> return () + Just _ -> throwError XmppAuthFailure + ses <- ErrorT $ newSession stream config + return ses diff --git a/source/Network/Xmpp/Concurrent/Basic.hs b/source/Network/Xmpp/Concurrent/Basic.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Concurrent/Basic.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_HADDOCK hide #-} +module Network.Xmpp.Concurrent.Basic where + +import Control.Concurrent.STM +import Network.Xmpp.Concurrent.Types +import Network.Xmpp.Types + +-- | Send a stanza to the server. +sendStanza :: Stanza -> Session -> IO () +sendStanza a session = atomically $ writeTChan (outCh session) a + +-- | Create a new session object with the inbound channel duplicated +dupSession :: Session -> IO Session +dupSession session = do + stanzaCh' <- atomically $ dupTChan (stanzaCh session) + return $ session {stanzaCh = stanzaCh'} diff --git a/source/Network/Xmpp/Concurrent/IQ.hs b/source/Network/Xmpp/Concurrent/IQ.hs --- a/source/Network/Xmpp/Concurrent/IQ.hs +++ b/source/Network/Xmpp/Concurrent/IQ.hs @@ -1,17 +1,19 @@ +{-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Concurrent.IQ where -import Control.Concurrent.STM -import Control.Concurrent (forkIO, threadDelay) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader -import Data.XML.Types import qualified Data.Map as Map +import Data.Text (Text) +import Data.XML.Types -import Network.Xmpp.Concurrent.Types -import Network.Xmpp.Concurrent.Monad -import Network.Xmpp.Types +import Network.Xmpp.Concurrent.Basic +import Network.Xmpp.Concurrent.Types +import Network.Xmpp.Types -- | Sends an IQ, returns a 'TMVar' that will be filled with the first inbound -- IQ with a matching ID that has type @result@ or @error@. @@ -59,6 +61,30 @@ atomically $ takeTMVar ref +-- | Retrieves an IQ listener channel. If the namespace/'IQRequestType' is not +-- already handled, a new 'TChan' is created and returned as a 'Right' value. +-- Otherwise, the already existing channel will be returned wrapped in a 'Left' +-- value. Note that the 'Left' channel might need to be duplicated in order not +-- to interfere with existing consumers. +listenIQChan :: IQRequestType -- ^ Type of IQs to receive (@Get@ or @Set@) + -> Text -- ^ Namespace of the child element + -> Session + -> IO (Either (TChan IQRequestTicket) (TChan IQRequestTicket)) +listenIQChan tp ns session = do + let handlers = (iqHandlers session) + atomically $ do + (byNS, byID) <- readTVar handlers + iqCh <- newTChan + let (present, byNS') = Map.insertLookupWithKey' + (\_ _ old -> old) + (tp, ns) + iqCh + byNS + writeTVar handlers (byNS', byID) + return $ case present of + Nothing -> Right iqCh + Just iqCh' -> Left iqCh' + answerIQ :: IQRequestTicket -> Either StanzaError (Maybe Element) -> Session @@ -76,6 +102,6 @@ False -> do writeTVar sentRef True - writeTChan (outCh session) response + writeTChan (outCh session) response return True True -> return False diff --git a/source/Network/Xmpp/Concurrent/Message.hs b/source/Network/Xmpp/Concurrent/Message.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Concurrent/Message.hs @@ -0,0 +1,59 @@ +{-# OPTIONS_HADDOCK hide #-} +module Network.Xmpp.Concurrent.Message where + +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.Basic + +-- | Read an element from the inbound stanza channel, discardes any +-- non-Message stanzas from the channel +pullMessage :: Session -> IO (Either MessageError Message) +pullMessage session = do + stanza <- atomically . readTChan $ stanzaCh session + case stanza of + MessageS m -> return $ Right m + MessageErrorS e -> return $ Left e + _ -> pullMessage session + +-- | Get the next received message +getMessage :: Session -> IO Message +getMessage = waitForMessage (const True) + +-- | Pulls a (non-error) message and returns it if the given predicate returns +-- @True@. +waitForMessage :: (Message -> Bool) -> Session -> IO Message +waitForMessage f session = do + s <- pullMessage session + case s of + Left _ -> waitForMessage f session + Right m | f m -> return m + | otherwise -> waitForMessage f session + +-- | Pulls an error message and returns it if the given predicate returns @True@. +waitForMessageError :: (MessageError -> Bool) -> Session -> IO MessageError +waitForMessageError f session = do + s <- pullMessage session + case s of + Right _ -> waitForMessageError f session + Left m | f m -> return m + | otherwise -> waitForMessageError f session + + +-- | Pulls a message and returns it if the given predicate returns @True@. +filterMessages :: (MessageError -> Bool) + -> (Message -> Bool) + -> Session -> IO (Either MessageError Message) +filterMessages f g session = do + s <- pullMessage session + case s of + Left e | f e -> return $ Left e + | otherwise -> filterMessages f g session + Right m | g m -> return $ Right m + | otherwise -> filterMessages f g session + +-- | Send a message stanza. +sendMessage :: Message -> Session -> IO () +sendMessage m session = sendStanza (MessageS m) session diff --git a/source/Network/Xmpp/Concurrent/Monad.hs b/source/Network/Xmpp/Concurrent/Monad.hs --- a/source/Network/Xmpp/Concurrent/Monad.hs +++ b/source/Network/Xmpp/Concurrent/Monad.hs @@ -1,207 +1,62 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings #-} module Network.Xmpp.Concurrent.Monad where import Network.Xmpp.Types -import Control.Applicative((<$>)) -import Control.Concurrent import Control.Concurrent.STM -import Control.Concurrent.STM.TVar (TVar, readTVar, writeTVar) import qualified Control.Exception.Lifted as Ex -import Control.Monad.IO.Class import Control.Monad.Reader -import Control.Monad.State.Strict -import Data.IORef -import qualified Data.Map as Map -import Data.Text(Text) - import Network.Xmpp.Concurrent.Types -import Network.Xmpp.Monad +import Network.Xmpp.Stream --- | Retrieves an IQ listener channel. If the namespace/'IQRequestType' is not --- already handled, a new 'TChan' is created and returned as a 'Right' value. --- Otherwise, the already existing channel will be returned wrapped in a 'Left' --- value. Note that the 'Left' channel might need to be duplicated in order not --- to interfere with existing consumers. -listenIQChan :: IQRequestType -- ^ Type of IQs to receive (@Get@ or @Set@) - -> Text -- ^ Namespace of the child element - -> Session - -> IO (Either (TChan IQRequestTicket) (TChan IQRequestTicket)) -listenIQChan tp ns session = do - let handlers = iqHandlers session - atomically $ do - (byNS, byID) <- readTVar handlers - iqCh <- newTChan - let (present, byNS') = Map.insertLookupWithKey' - (\_ _ old -> old) - (tp, ns) - iqCh - byNS - writeTVar handlers (byNS', byID) - return $ case present of - Nothing -> Right iqCh - Just iqCh' -> Left iqCh' --- | Get a duplicate of the stanza channel -getStanzaChan :: Session -> IO (TChan Stanza) -getStanzaChan session = atomically $ dupTChan (sShadow session) --- | Get the inbound stanza channel, duplicates from master if necessary. Please --- note that once duplicated it will keep filling up, call 'dropMessageChan' to --- allow it to be garbage collected. -getMessageChan :: Session -> IO (TChan (Either MessageError Message)) -getMessageChan session = do - mCh <- readIORef $ messagesRef session - case mCh of - Nothing -> do - mCh' <- atomically $ dupTChan (mShadow session) - writeIORef (messagesRef session) (Just mCh') - return mCh' - Just mCh' -> return mCh' - --- | Analogous to 'getMessageChan'. -getPresenceChan :: Session -> IO (TChan (Either PresenceError Presence)) -getPresenceChan session = do - pCh <- readIORef $ presenceRef session - case pCh of - Nothing -> do - pCh' <- atomically $ dupTChan (pShadow session) - writeIORef (presenceRef session) (Just pCh') - return pCh' - Just pCh' -> return pCh' - --- | Drop the local end of the inbound stanza channel from our context so it can --- be GC-ed. -dropMessageChan :: Session -> IO () -dropMessageChan session = writeIORef (messagesRef session) Nothing - --- | Analogous to 'dropMessageChan'. -dropPresenceChan :: Session -> IO () -dropPresenceChan session = writeIORef (presenceRef session) Nothing - --- | Read an element from the inbound stanza channel, acquiring a copy of the --- channel as necessary. -pullMessage :: Session -> IO (Either MessageError Message) -pullMessage session = do - c <- getMessageChan session - atomically $ readTChan c - --- | Read an element from the inbound stanza channel, acquiring a copy of the --- channel as necessary. -pullPresence :: Session -> IO (Either PresenceError Presence) -pullPresence session = do - c <- getPresenceChan session - atomically $ readTChan c - --- | Send a stanza to the server. -sendStanza :: Stanza -> Session -> IO () -sendStanza a session = atomically $ writeTChan (outCh session) a - - --- | Create a forked session object -forkSession :: Session -> IO Session -forkSession session = do - mCH' <- newIORef Nothing - pCH' <- newIORef Nothing - return $ session {messagesRef = mCH', presenceRef = pCH'} - --- | Pulls a message and returns it if the given predicate returns @True@. -filterMessages :: (MessageError -> Bool) - -> (Message -> Bool) - -> Session -> IO (Either MessageError Message) -filterMessages f g session = do - s <- pullMessage session - case s of - Left e | f e -> return $ Left e - | otherwise -> filterMessages f g session - Right m | g m -> return $ Right m - | otherwise -> filterMessages f g session - --- | Pulls a (non-error) message and returns it if the given predicate returns --- @True@. -waitForMessage :: (Message -> Bool) -> Session -> IO Message -waitForMessage f session = do - s <- pullMessage session - case s of - Left _ -> waitForMessage f session - Right m | f m -> return m - | otherwise -> waitForMessage f session - - --- | Pulls an error message and returns it if the given predicate returns @True@. -waitForMessageError :: (MessageError -> Bool) -> Session -> IO MessageError -waitForMessageError f session = do - s <- pullMessage session - case s of - Right _ -> waitForMessageError f session - Left m | f m -> return m - | otherwise -> waitForMessageError f session - - --- | Pulls a (non-error) presence and returns it if the given predicate returns --- @True@. -waitForPresence :: (Presence -> Bool) -> Session -> IO Presence -waitForPresence f session = do - s <- pullPresence session - case s of - Left _ -> waitForPresence f session - Right m | f m -> return m - | otherwise -> waitForPresence f session - -- TODO: Wait for presence error? --- | Run an XmppConMonad action in isolation. Reader and writer workers will be --- temporarily stopped and resumed with the new session details once the action --- returns. The action will run in the calling thread. Any uncaught exceptions --- will be interpreted as connection failure. -withConnection :: XmppConMonad a -> Session -> IO (Either StreamError a) -withConnection a session = do - wait <- newEmptyTMVarIO - Ex.mask_ $ do - -- Suspends the reader until the lock (wait) is released (set to `()'). - throwTo (readerThread session) $ Interrupt wait - -- We acquire the write and stateRef locks, to make sure that this is - -- the only thread that can write to the stream and to perform a - -- withConnection calculation. Afterwards, we release the lock and - -- fetches an updated state. - s <- Ex.catch - (atomically $ do - _ <- takeTMVar (writeRef session) - s <- takeTMVar (conStateRef session) - putTMVar wait () - return s - ) - -- If we catch an exception, we have failed to take the MVars above. - (\e -> atomically (putTMVar wait ()) >> - Ex.throwIO (e :: Ex.SomeException) - ) - -- Run the XmppMonad action, save the (possibly updated) states, release - -- the locks, and return the result. - Ex.catches - (do - (res, s') <- runStateT a s - atomically $ do - putTMVar (writeRef session) (sConPushBS s') - putTMVar (conStateRef session) s' - return $ Right res - ) - -- We treat all Exceptions as fatal. If we catch a StreamError, we - -- return it. Otherwise, we throw an exception. - [ Ex.Handler $ \e -> return $ Left (e :: StreamError) - , Ex.Handler $ \e -> runStateT xmppKillConnection s - >> Ex.throwIO (e :: Ex.SomeException) - ] - --- | Send a presence stanza. -sendPresence :: Presence -> Session -> IO () -sendPresence p session = sendStanza (PresenceS p) session - --- | Send a message stanza. -sendMessage :: Message -> Session -> IO () -sendMessage m session = sendStanza (MessageS m) session - +-- -- | Run an XmppConMonad action in isolation. Reader and writer workers will be +-- -- temporarily stopped and resumed with the new session details once the action +-- -- returns. The action will run in the calling thread. Any uncaught exceptions +-- -- will be interpreted as connection failure. +-- withConnection :: XmppConMonad a -> Context -> IO (Either StreamError a) +-- withConnection a session = do +-- wait <- newEmptyTMVarIO +-- Ex.mask_ $ do +-- -- Suspends the reader until the lock (wait) is released (set to `()'). +-- throwTo (readerThread session) $ Interrupt wait +-- -- We acquire the write and stateRef locks, to make sure that this is +-- -- the only thread that can write to the stream and to perform a +-- -- withConnection calculation. Afterwards, we release the lock and +-- -- fetches an updated state. +-- s <- Ex.catch +-- (atomically $ do +-- _ <- takeTMVar (writeRef session) +-- s <- takeTMVar (conStateRef session) +-- putTMVar wait () +-- return s +-- ) +-- -- If we catch an exception, we have failed to take the MVars above. +-- (\e -> atomically (putTMVar wait ()) >> +-- Ex.throwIO (e :: Ex.SomeException) +-- ) +-- -- Run the XmppMonad action, save the (possibly updated) states, release +-- -- the locks, and return the result. +-- Ex.catches +-- (do +-- (res, s') <- runStateT a s +-- atomically $ do +-- putTMVar (writeRef session) (cSend . sCon $ s') +-- putTMVar (conStateRef session) s' +-- return $ Right res +-- ) +-- -- We treat all Exceptions as fatal. If we catch a StreamError, we +-- -- return it. Otherwise, we throw an exception. +-- [ Ex.Handler $ \e -> return $ Left (e :: StreamError) +-- , Ex.Handler $ \e -> runStateT xmppKillConnection s +-- >> Ex.throwIO (e :: Ex.SomeException) +-- ] -- | Executes a function to update the event handlers. modifyHandlers :: (EventHandlers -> EventHandlers) -> Session -> IO () @@ -216,8 +71,8 @@ writeTVar var (f x) -- | Sets the handler to be executed when the server connection is closed. -setConnectionClosedHandler :: (StreamError -> Session -> IO ()) -> Session -> IO () -setConnectionClosedHandler eh session = do +setConnectionClosedHandler_ :: (XmppFailure -> Session -> IO ()) -> Session -> IO () +setConnectionClosedHandler_ eh session = do modifyHandlers (\s -> s{connectionClosedHandler = \e -> eh e session}) session @@ -227,9 +82,9 @@ -- | End the current Xmpp session. -endSession :: Session -> IO () -endSession session = do -- TODO: This has to be idempotent (is it?) - void $ withConnection xmppKillConnection session +endContext :: Session -> IO () +endContext session = do -- TODO: This has to be idempotent (is it?) + closeConnection session stopThreads session -- | Close the connection to the server. Closes the stream (by enforcing a @@ -237,14 +92,8 @@ -- seconds, and then closes the connection. closeConnection :: Session -> IO () closeConnection session = Ex.mask_ $ do - send <- atomically $ takeTMVar (writeRef session) - cc <- sCloseConnection <$> ( atomically $ readTMVar (conStateRef session)) - send "" - void . forkIO $ do - threadDelay 3000000 - -- When we close the connection, we close the handle that was used in the - -- sCloseConnection above. So even if a new connection has been - -- established at this point, it will not be affected by this action. - (Ex.try cc) :: IO (Either Ex.SomeException ()) - return () - atomically $ putTMVar (writeRef session) (\_ -> return False) + (_send, connection) <- atomically $ liftM2 (,) + (takeTMVar $ writeRef session) + (takeTMVar $ streamRef session) + _ <- closeStreams connection + return () diff --git a/source/Network/Xmpp/Concurrent/Presence.hs b/source/Network/Xmpp/Concurrent/Presence.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Concurrent/Presence.hs @@ -0,0 +1,32 @@ +{-# OPTIONS_HADDOCK hide #-} +module Network.Xmpp.Concurrent.Presence where + +import Control.Concurrent.STM +import Data.IORef +import Network.Xmpp.Types +import Network.Xmpp.Concurrent.Types +import Network.Xmpp.Concurrent.Basic + +-- | Read an element from the inbound stanza channel, discardes any non-Presence +-- stanzas from the channel +pullPresence :: Session -> IO (Either PresenceError Presence) +pullPresence session = do + stanza <- atomically . readTChan $ stanzaCh session + case stanza of + PresenceS p -> return $ Right p + PresenceErrorS e -> return $ Left e + _ -> pullPresence session + +-- | Pulls a (non-error) presence and returns it if the given predicate returns +-- @True@. +waitForPresence :: (Presence -> Bool) -> Session -> IO Presence +waitForPresence f session = do + s <- pullPresence session + case s of + Left _ -> waitForPresence f session + Right m | f m -> return m + | otherwise -> waitForPresence f session + +-- | Send a presence stanza. +sendPresence :: Presence -> Session -> IO () +sendPresence p session = sendStanza (PresenceS p) session diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -1,106 +1,67 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Network.Xmpp.Concurrent.Threads where -import Network.Xmpp.Types +import Network.Xmpp.Types -import Control.Applicative((<$>),(<*>)) -import Control.Concurrent -import Control.Concurrent.STM +import Control.Applicative((<$>)) +import Control.Concurrent +import Control.Concurrent.STM import qualified Control.Exception.Lifted as Ex -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Reader -import Control.Monad.State.Strict +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.State.Strict import qualified Data.ByteString as BS -import Data.IORef -import qualified Data.Map as Map -import Data.Maybe - -import Data.XML.Types +import Network.Xmpp.Concurrent.Types +import Network.Xmpp.Stream -import Network.Xmpp.Monad -import Network.Xmpp.Marshal -import Network.Xmpp.Pickle -import Network.Xmpp.Concurrent.Types +import Control.Concurrent.STM.TMVar -import Text.XML.Stream.Elements +import GHC.IO (unsafeUnmask) -import GHC.IO (unsafeUnmask) +import Control.Monad.Error +import System.Log.Logger -- Worker to read stanzas from the stream and concurrently distribute them to -- all listener threads. -readWorker :: TChan (Either MessageError Message) - -> TChan (Either PresenceError Presence) - -> TChan Stanza - -> TVar IQHandlers - -> TVar EventHandlers - -> TMVar XmppConnection - -> IO () -readWorker messageC presenceC stanzaC iqHands handlers stateRef = +readWorker :: (Stanza -> IO ()) + -> (XmppFailure -> IO ()) + -> TMVar Stream + -> IO a +readWorker onStanza onConnectionClosed stateRef = Ex.mask_ . forever $ do - res <- liftIO $ Ex.catches ( do + res <- Ex.catches ( do -- we don't know whether pull will -- necessarily be interruptible - s <- liftIO . atomically $ do - sr <- readTMVar stateRef - when (sConnectionState sr == XmppConnectionClosed) + s <- atomically $ do + s@(Stream con) <- readTMVar stateRef + state <- streamConnectionState <$> readTMVar con + when (state == Closed) retry - return sr + return s allowInterrupt - Just . fst <$> runStateT pullStanza s + Just <$> pullStanza s ) [ Ex.Handler $ \(Interrupt t) -> do void $ handleInterrupts [t] return Nothing - , Ex.Handler $ \(e :: StreamError) -> do - hands <- atomically $ readTVar handlers - _ <- forkIO $ connectionClosedHandler hands e + , Ex.Handler $ \(e :: XmppFailure) -> do + onConnectionClosed e + errorM "Pontarius.Xmpp" $ "Read error: " ++ show e return Nothing ] - liftIO . atomically $ do - case res of - Nothing -> return () - Just sta -> do - writeTChan stanzaC sta - void $ readTChan stanzaC -- sic - case sta of - MessageS m -> do writeTChan messageC $ Right m - _ <- readTChan messageC -- Sic! - return () - -- this may seem ridiculous, but to prevent - -- the channel from filling up we - -- immedtiately remove the - -- Stanza we just put in. It will still be - -- available in duplicates. - MessageErrorS m -> do writeTChan messageC $ Left m - _ <- readTChan messageC - return () - PresenceS p -> do - writeTChan presenceC $ Right p - _ <- readTChan presenceC - return () - PresenceErrorS p -> do - writeTChan presenceC $ Left p - _ <- readTChan presenceC - return () - - IQRequestS i -> handleIQRequest iqHands i - IQResultS i -> handleIQResponse iqHands (Right i) - IQErrorS i -> handleIQResponse iqHands (Left i) - + case res of + 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. allowInterrupt :: IO () allowInterrupt = unsafeUnmask $ return () - -- Call the connection closed handlers. - noCon :: TVar EventHandlers -> StreamError -> IO (Maybe a) - noCon h e = do - hands <- atomically $ readTVar h - _ <- forkIO $ connectionClosedHandler hands e - return Nothing -- While waiting for the first semaphore(s) to flip we might receive another -- interrupt. When that happens we add it's semaphore to the list and retry -- waiting. We do this because we might receive another @@ -111,119 +72,44 @@ Ex.catch (atomically $ forM ts takeTMVar) (\(Interrupt t) -> handleInterrupts (t:ts)) --- If the IQ request has a namespace, sent 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' - --- 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. - - - - -- Two streams: input and output. Threads read from input stream and write to -- output stream. -- | Runs thread in XmppState monad. Returns channel of incoming and outgoing -- stances, respectively, and an Action to stop the Threads and close the -- connection. -startThreads :: IO ( TChan (Either MessageError Message) - , TChan (Either PresenceError Presence) - , TChan Stanza - , TVar IQHandlers - , TChan Stanza - , IO () - , TMVar (BS.ByteString -> IO Bool) - , TMVar XmppConnection - , ThreadId - , TVar EventHandlers - ) -startThreads = do - writeLock <- newTMVarIO (\_ -> return False) - messageC <- newTChanIO - presenceC <- newTChanIO - outC <- newTChanIO - stanzaC <- newTChanIO - handlers <- newTVarIO (Map.empty, Map.empty) - eh <- newTVarIO zeroEventHandlers - conS <- newTMVarIO xmppNoConnection - lw <- forkIO $ writeWorker outC writeLock - cp <- forkIO $ connPersist writeLock - rd <- forkIO $ readWorker messageC presenceC stanzaC handlers eh conS - return ( messageC - , presenceC - , stanzaC - , handlers - , outC - , killConnection writeLock [lw, rd, cp] - , writeLock - , conS - , rd - , eh) +startThreadsWith :: (Stanza -> IO ()) + -> TVar EventHandlers + -> Stream + -> IO (Either XmppFailure (IO (), + TMVar (BS.ByteString -> IO Bool), + TMVar Stream, + ThreadId)) +startThreadsWith stanzaHandler eh con = do + read <- withStream' (gets $ streamSend . streamHandle >>= \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 () - zeroEventHandlers :: EventHandlers - zeroEventHandlers = EventHandlers - { connectionClosedHandler = \_ -> return () - } - --- | Initializes a new XMPP session. -newSession :: IO Session -newSession = do - (mC, pC, sC, hand, outC, stopThreads', writeR, conS, rdr, eh) <- startThreads - workermCh <- newIORef $ Nothing - workerpCh <- newIORef $ Nothing - idRef <- newTVarIO 1 - let getId = atomically $ do - curId <- readTVar idRef - writeTVar idRef (curId + 1 :: Integer) - return . read. show $ curId - return $ Session - mC - pC - sC - workermCh - workerpCh - outC - hand - writeR - rdr - getId - conS - eh - stopThreads' + -- Call the connection closed handlers. + noCon :: TVar EventHandlers -> XmppFailure -> IO () + noCon h e = do + hands <- atomically $ readTVar h + _ <- forkIO $ connectionClosedHandler hands e + return () -- Acquires the write lock, pushes a space, and releases the lock. -- | Sends a blank space every 30 seconds to keep the connection alive. diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -6,62 +6,55 @@ import qualified Control.Exception.Lifted as Ex import Control.Concurrent import Control.Concurrent.STM -import Control.Monad.Trans.Reader import qualified Data.ByteString as BS -import Data.IORef -import qualified Data.Map as Map -import Data.Text(Text) import Data.Typeable import Network.Xmpp.Types --- Map between the IQ request type and the "query" namespace pair, and the TChan --- for the IQ request and "sent" boolean pair. -type IQHandlers = (Map.Map (IQRequestType, Text) (TChan IQRequestTicket) - , Map.Map StanzaId (TMVar IQResponse) - ) +import Data.IORef +import qualified Data.Map as Map +import Data.Text (Text) --- Handlers to be run when the Xmpp session ends and when the Xmpp connection is +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 () } --- The Session object is the Xmpp (ReaderT) state. +-- | 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 - { -- The original master channels that the reader puts stanzas - -- into. These are cloned by @get{STanza,Message,Presence}Chan - -- on demand when first used by the thread and are stored in the - -- {message,presence}Ref fields below. - mShadow :: TChan (Either MessageError Message) - , pShadow :: TChan (Either PresenceError Presence) - , sShadow :: TChan Stanza -- All stanzas - -- The cloned copies of the original/shadow channels. They are - -- thread-local (as opposed to the shadow channels) and contains all - -- stanzas received after the cloning of the shadow channels. - , messagesRef :: IORef (Maybe (TChan (Either MessageError Message))) - , presenceRef :: IORef (Maybe (TChan (Either PresenceError Presence))) + { 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 calculation is executed at any given time. - , conStateRef :: TMVar XmppConnection + , idGenerator :: IO StanzaID + -- | Lock (used by withStream) to make sure that a maximum of one + -- Stream action is executed at any given time. + , streamRef :: TMVar (Stream) , eventHandlers :: TVar EventHandlers , stopThreads :: IO () + , conf :: SessionConfiguration } - --- Interrupt is used to signal to the reader thread that it should stop. -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. diff --git a/source/Network/Xmpp/Errors.hs b/source/Network/Xmpp/Errors.hs deleted file mode 100644 --- a/source/Network/Xmpp/Errors.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.Errors where - -import Control.Applicative ((<$>)) -import Control.Monad(unless) -import Control.Monad.Error -import Control.Monad.Error.Class -import qualified Data.Text as Text -import Data.XML.Types -import Network.Xmpp.Types -import Network.Xmpp.Pickle - - --- Finds unpickling problems. Not to be used for data validation -findStreamErrors :: Element -> StreamError -findStreamErrors (Element name attrs children) - | (nameLocalName name /= "stream") - = StreamNotStreamElement $ nameLocalName name - | (nameNamespace name /= Just "http://etherx.jabber.org/streams") - = StreamInvalidStreamNamespace $ nameNamespace name - | otherwise = checkchildren (flattenAttrs attrs) - where - checkchildren children = - let to' = lookup "to" children - ver' = lookup "version" children - xl = lookup xmlLang children - in case () of () | Just (Nothing :: Maybe Jid) == (safeRead <$> to') - -> StreamWrongTo to' - | Nothing == ver' - -> StreamWrongVersion Nothing - | Just (Nothing :: Maybe LangTag) == - (safeRead <$> xl) - -> StreamWrongLangTag xl - | otherwise - -> StreamUnknownError - safeRead x = case reads $ Text.unpack x of - [] -> Nothing - [(y,_),_] -> Just y - -flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)] -flattenAttrs attrs = map (\(name, content) -> - ( name - , Text.concat $ map uncontentify content) - ) - attrs - where - uncontentify (ContentText t) = t - uncontentify _ = "" diff --git a/source/Network/Xmpp/IM.hs b/source/Network/Xmpp/IM.hs deleted file mode 100644 --- a/source/Network/Xmpp/IM.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Network.Xmpp.IM - ( module Network.Xmpp.IM.Message - , module Network.Xmpp.IM.Presence - ) where - -import Network.Xmpp.IM.Message -import Network.Xmpp.IM.Presence diff --git a/source/Network/Xmpp/IM/Message.hs b/source/Network/Xmpp/IM/Message.hs deleted file mode 100644 --- a/source/Network/Xmpp/IM/Message.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.IM.Message - where - -import Control.Applicative ((<$>)) - -import Data.Maybe (maybeToList) -import Data.Text (Text) -import Data.XML.Pickle -import Data.XML.Types - -import Network.Xmpp.Types -import Network.Xmpp.Pickle - -data MessageBody = MessageBody (Maybe LangTag) Text -data MessageThread = MessageThread - Text -- Thread ID - (Maybe Text) -- Parent Thread -data MessageSubject = MessageSubject (Maybe LangTag) Text - -xpMessageSubject :: PU [Element] MessageSubject -xpMessageSubject = xpUnliftElems . - xpWrap (\(l, s) -> MessageSubject l s) - (\(MessageSubject l s) -> (l,s)) - $ xpElem "{jabber:client}subject" xpLangTag $ xpContent xpId - -xpMessageBody :: PU [Element] MessageBody -xpMessageBody = xpUnliftElems . - xpWrap (\(l, s) -> MessageBody l s) - (\(MessageBody l s) -> (l,s)) - $ xpElem "{jabber:client}body" xpLangTag $ xpContent xpId - -xpMessageThread :: PU [Element] MessageThread -xpMessageThread = xpUnliftElems - . xpWrap (\(t, p) -> MessageThread p t) - (\(MessageThread p t) -> (t,p)) - $ xpElem "{jabber:client}thread" - (xpAttrImplied "parent" xpId) - (xpContent xpId) - --- | Get the subject elements of a message (if any). Messages may --- contain multiple subjects if each of them has a distinct xml:lang --- attribute -subject :: Message -> [MessageSubject] -subject m = ms - where - -- xpFindMatches will _always_ return Right - Right ms = unpickle (xpFindMatches xpMessageSubject) $ messagePayload m - --- | Get the thread elements of a message (if any). The thread of a --- message is considered opaque, that is, no meaning, other than it's --- literal identity, may be derived from it and it is not human --- readable -thread :: Message -> Maybe MessageThread -thread m = ms - where - -- xpFindMatches will _always_ return Right - Right ms = unpickle (xpOption xpMessageThread) $ messagePayload m - --- | Get the body elements of a message (if any). Messages may contain --- multiple bodies if each of them has a distinct xml:lang attribute -body :: Message -> [MessageBody] -body m = ms - where - -- xpFindMatches will _always_ return Right - Right ms = unpickle (xpFindMatches xpMessageBody) $ messagePayload m - --- | Generate a new instant message -newIM - :: Jid - -> Maybe StanzaId - -> Maybe LangTag - -> MessageType - -> Maybe MessageSubject - -> Maybe MessageThread - -> Maybe MessageBody - -> [Element] - -> Message -newIM t i lang tp sbj thrd bdy payload = Message - { messageID = i - , messageFrom = Nothing - , messageTo = Just t - , messageLangTag = lang - , messageType = tp - , messagePayload = concat $ - maybeToList (pickle xpMessageSubject <$> sbj) - ++ maybeToList (pickle xpMessageThread <$> thrd) - ++ maybeToList (pickle xpMessageBody <$> bdy) - ++ [payload] - } - --- | Generate a simple instance message -simpleIM :: Jid -> Text -> Message -simpleIM t bd = newIM - t - Nothing - Nothing - Normal - Nothing - Nothing - (Just $ MessageBody Nothing bd) - [] - --- | Generate an answer from a received message. The recepient is --- taken from the original sender, the sender is set to Nothing, --- message ID, language tag, message type as well as subject and --- thread are inherited, the remaining payload is replaced by the --- given one -answerIM :: Maybe MessageBody -> [Element] -> Message -> Message -answerIM bd payload msg = Message - { messageID = messageID msg - , messageFrom = Nothing - , messageTo = messageFrom msg - , messageLangTag = messageLangTag msg - , messageType = messageType msg - , messagePayload = concat $ - (pickle xpMessageSubject <$> subject msg) - ++ maybeToList (pickle xpMessageThread <$> thread msg) - ++ maybeToList (pickle xpMessageBody <$> bd) - ++ [payload] - } diff --git a/source/Network/Xmpp/IM/Presence.hs b/source/Network/Xmpp/IM/Presence.hs deleted file mode 100644 --- a/source/Network/Xmpp/IM/Presence.hs +++ /dev/null @@ -1,74 +0,0 @@ -module Network.Xmpp.IM.Presence where - -import Data.Text(Text) -import Network.Xmpp.Types - --- | An empty presence. -presence :: Presence -presence = Presence { presenceID = Nothing - , presenceFrom = Nothing - , presenceTo = Nothing - , presenceLangTag = Nothing - , presenceType = Nothing - , presencePayload = [] - } - --- | Request subscription with an entity. -presenceSubscribe :: Jid -> Presence -presenceSubscribe to = presence { presenceTo = Just to - , presenceType = Just Subscribe - } - --- | Is presence a subscription request? -isPresenceSubscribe :: Presence -> Bool -isPresenceSubscribe pres = presenceType pres == (Just Subscribe) - --- | Approve a subscripton of an entity. -presenceSubscribed :: Jid -> Presence -presenceSubscribed to = presence { presenceTo = Just to - , presenceType = Just Subscribed - } - --- | Is presence a subscription approval? -isPresenceSubscribed :: Presence -> Bool -isPresenceSubscribed pres = presenceType pres == (Just Subscribed) - --- | End a subscription with an entity. -presenceUnsubscribe :: Jid -> Presence -presenceUnsubscribe to = presence { presenceTo = Just to - , presenceType = Just Unsubscribed - } - --- | Is presence an unsubscription request? -isPresenceUnsubscribe :: Presence -> Bool -isPresenceUnsubscribe pres = presenceType pres == (Just Unsubscribe) - --- | Signal to the server that the client is available for communication. -presenceOnline :: Presence -presenceOnline = presence - --- | Signal to the server that the client is no longer available for --- communication. -presenceOffline :: Presence -presenceOffline = presence {presenceType = Just Unavailable} - ----- Change your status ---status --- :: Maybe Text -- ^ Status message --- -> Maybe ShowType -- ^ Status Type --- -> Maybe Int -- ^ Priority --- -> Presence ---status txt showType prio = presence { presenceShowType = showType --- , presencePriority = prio --- , presenceStatus = txt --- } - --- | Set the current availability status. This implicitly sets the client's --- status online. ---presenceAvail :: ShowType -> Presence ---presenceAvail showType = status Nothing (Just showType) Nothing - --- | Set the current status message. This implicitly sets the client's status --- online. ---presenceMessage :: Text -> Presence ---presenceMessage txt = status (Just txt) Nothing Nothing diff --git a/source/Network/Xmpp/Internal.hs b/source/Network/Xmpp/Internal.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Internal.hs @@ -0,0 +1,45 @@ +-- | +-- 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 'Stream' 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 +-- 'Stream' functions can be executed using 'withStream'. +-- +-- The TLS, SASL, and 'Session' functionalities of Pontarius XMPP are built on +-- top of this API. + +module Network.Xmpp.Internal + ( Stream(..) + , StreamConfiguration(..) + , StreamState(..) + , StreamHandle(..) + , StreamFeatures(..) + , openStream + , withStream + , tls + , auth + , pushStanza + , pullStanza + , pushIQ + , SaslHandler(..) + , StanzaID(..) + ) + + where + +import Network.Xmpp.Stream +import Network.Xmpp.Sasl +import Network.Xmpp.Sasl.Common +import Network.Xmpp.Sasl.Types +import Network.Xmpp.Tls +import Network.Xmpp.Types +import Network.Xmpp.Stream +import Network.Xmpp.Marshal diff --git a/source/Network/Xmpp/Jid.hs b/source/Network/Xmpp/Jid.hs deleted file mode 100644 --- a/source/Network/Xmpp/Jid.hs +++ /dev/null @@ -1,205 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} - --- This module deals with JIDs, also known as XMPP addresses. For more --- information on JIDs, see RFC 6122: XMPP: Address Format. - -module Network.Xmpp.Jid - ( Jid(..) - , fromText - , fromStrings - , isBare - , isFull - ) where - -import Control.Applicative ((<$>),(<|>)) -import Control.Monad(guard) - -import qualified Data.Attoparsec.Text as AP -import Data.Maybe(fromJust) -import qualified Data.Set as Set -import Data.String (IsString(..)) -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Text.NamePrep as SP -import qualified Text.StringPrep as SP - --- | A JID is XMPP\'s native format for addressing entities in the network. It --- is somewhat similar to an e-mail address but contains three parts instead of --- two. -data Jid = Jid { -- | The @localpart@ of a JID is an optional identifier placed - -- before the domainpart and separated from the latter by a - -- \'\@\' character. Typically a localpart uniquely identifies - -- the entity requesting and using network access provided by a - -- server (i.e., a local account), although it can also - -- represent other kinds of entities (e.g., a chat room - -- associated with a multi-user chat service). The entity - -- represented by an XMPP localpart is addressed within the - -- context of a specific domain (i.e., - -- @localpart\@domainpart@). - localpart :: !(Maybe Text) - - -- | The domainpart typically identifies the /home/ server to - -- which clients connect for XML routing and data management - -- functionality. However, it is not necessary for an XMPP - -- domainpart to identify an entity that provides core XMPP - -- server functionality (e.g., a domainpart can identify an - -- entity such as a multi-user chat service, a - -- publish-subscribe service, or a user directory). - , domainpart :: !Text - - -- | The resourcepart of a JID is an optional identifier placed - -- after the domainpart and separated from the latter by the - -- \'\/\' character. A resourcepart can modify either a - -- @localpart\@domainpart@ address or a mere @domainpart@ - -- address. Typically a resourcepart uniquely identifies a - -- specific connection (e.g., a device or location) or object - -- (e.g., an occupant in a multi-user chat room) belonging to - -- the entity associated with an XMPP localpart at a domain - -- (i.e., @localpart\@domainpart/resourcepart@). - , resourcepart :: !(Maybe Text) - } deriving Eq - -instance Show Jid where - show (Jid nd dmn res) = - maybe "" ((++ "@") . Text.unpack) nd ++ Text.unpack dmn ++ - maybe "" (('/' :) . Text.unpack) res - -instance Read Jid where - readsPrec _ x = case fromText (Text.pack x) of - Nothing -> [] - Just j -> [(j,"")] - -instance IsString Jid where - fromString = fromJust . fromText . Text.pack - --- | Converts a Text to a JID. -fromText :: Text -> Maybe Jid -fromText t = do - (l, d, r) <- eitherToMaybe $ AP.parseOnly jidParts t - fromStrings l d r - where - eitherToMaybe = either (const Nothing) Just - --- | Converts localpart, domainpart, and resourcepart strings to a JID. Runs the --- appropriate stringprep profiles and validates the parts. -fromStrings :: Maybe Text -> Text -> Maybe Text -> Maybe Jid -fromStrings l d r = do - localPart <- case l of - Nothing -> return Nothing - Just l'-> do - l'' <- SP.runStringPrep nodeprepProfile l' - guard $ validPartLength l'' - let prohibMap = Set.fromList nodeprepExtraProhibitedCharacters - guard $ Text.all (`Set.notMember` prohibMap) l'' - return $ Just l'' - domainPart <- SP.runStringPrep (SP.namePrepProfile False) d - guard $ validDomainPart domainPart - resourcePart <- case r of - Nothing -> return Nothing - Just r' -> do - r'' <- SP.runStringPrep resourceprepProfile r' - guard $ validPartLength r'' - return $ Just r'' - return $ Jid localPart domainPart resourcePart - where - validDomainPart :: Text -> Bool - validDomainPart _s = True -- TODO - - validPartLength :: Text -> Bool - validPartLength p = Text.length p > 0 && Text.length p < 1024 - --- | Returns 'True' if the JID is /bare/, and 'False' otherwise. -isBare :: Jid -> Bool -isBare j | resourcepart j == Nothing = True - | otherwise = False - --- | Returns 'True' if the JID is /full/, and 'False' otherwise. -isFull :: Jid -> Bool -isFull = not . isBare - --- Parses an JID string and returns its three parts. It performs no validation --- or transformations. -jidParts :: AP.Parser (Maybe Text, Text, Maybe Text) -jidParts = do - -- Read until we reach an '@', a '/', or EOF. - a <- AP.takeWhile1 (AP.notInClass ['@', '/']) - -- Case 1: We found an '@', and thus the localpart. At least the domainpart - -- is remaining. Read the '@' and until a '/' or EOF. - do - b <- domainPartP - -- Case 1A: We found a '/' and thus have all the JID parts. Read the '/' - -- and until EOF. - do - c <- resourcePartP -- Parse resourcepart - return (Just a, b, Just c) - -- Case 1B: We have reached EOF; the JID is in the form - -- localpart@domainpart. - <|> do - AP.endOfInput - return (Just a, b, Nothing) - -- Case 2: We found a '/'; the JID is in the form - -- domainpart/resourcepart. - <|> do - b <- resourcePartP - AP.endOfInput - return (Nothing, a, Just b) - -- Case 3: We have reached EOF; we have an JID consisting of only a - -- domainpart. - <|> do - AP.endOfInput - return (Nothing, a, Nothing) - where - -- Read an '@' and everything until a '/'. - domainPartP :: AP.Parser Text - domainPartP = do - _ <- AP.char '@' - AP.takeWhile1 (/= '/') - -- Read everything until a '/'. - resourcePartP :: AP.Parser Text - resourcePartP = do - _ <- AP.char '/' - AP.takeText - --- The `nodeprep' StringPrep profile. -nodeprepProfile :: SP.StringPrepProfile -nodeprepProfile = SP.Profile { SP.maps = [SP.b1, SP.b2] - , SP.shouldNormalize = True - , SP.prohibited = [SP.a1 - , SP.c11 - , SP.c12 - , SP.c21 - , SP.c22 - , SP.c3 - , SP.c4 - , SP.c5 - , SP.c6 - , SP.c7 - , SP.c8 - , SP.c9 - ] - , SP.shouldCheckBidi = True - } - --- These characters needs to be checked for after normalization. -nodeprepExtraProhibitedCharacters :: [Char] -nodeprepExtraProhibitedCharacters = ['\x22', '\x26', '\x27', '\x2F', '\x3A', - '\x3C', '\x3E', '\x40'] - --- The `resourceprep' StringPrep profile. -resourceprepProfile :: SP.StringPrepProfile -resourceprepProfile = SP.Profile { SP.maps = [SP.b1] - , SP.shouldNormalize = True - , SP.prohibited = [ SP.a1 - , SP.c12 - , SP.c21 - , SP.c22 - , SP.c3 - , SP.c4 - , SP.c5 - , SP.c6 - , SP.c7 - , SP.c8 - , SP.c9 - ] - , SP.shouldCheckBidi = True - } diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -11,14 +11,15 @@ import Data.XML.Pickle import Data.XML.Types -import Network.Xmpp.Pickle +import Data.Text + import Network.Xmpp.Types -xpStreamStanza :: PU [Node] (Either XmppStreamError Stanza) +xpStreamStanza :: PU [Node] (Either StreamErrorInfo Stanza) xpStreamStanza = xpEither xpStreamError xpStanza xpStanza :: PU [Node] Stanza -xpStanza = xpAlt stanzaSel +xpStanza = ("xpStanza" , "") xpAlt stanzaSel [ xpWrap IQRequestS (\(IQRequestS x) -> x) xpIQRequest , xpWrap IQResultS (\(IQResultS x) -> x) xpIQResult , xpWrap IQErrorS (\(IQErrorS x) -> x) xpIQError @@ -39,7 +40,7 @@ stanzaSel (PresenceErrorS _) = 6 xpMessage :: PU [Node] (Message) -xpMessage = xpWrap +xpMessage = ("xpMessage" , "") xpWrap (\((tp, qid, from, to, lang), ext) -> Message qid from to lang tp ext) (\(Message qid from to lang tp ext) -> ((tp, qid, from, to, lang), ext)) (xpElem "{jabber:client}message" @@ -55,7 +56,7 @@ ) xpPresence :: PU [Node] Presence -xpPresence = xpWrap +xpPresence = ("xpPresence" , "") xpWrap (\((qid, from, to, lang, tp), ext) -> Presence qid from to lang tp ext) (\(Presence qid from to lang tp ext) -> ((qid, from, to, lang, tp), ext)) (xpElem "{jabber:client}presence" @@ -70,7 +71,7 @@ ) xpIQRequest :: PU [Node] IQRequest -xpIQRequest = xpWrap +xpIQRequest = ("xpIQRequest" , "") xpWrap (\((qid, from, to, lang, tp),body) -> IQRequest qid from to lang tp body) (\(IQRequest qid from to lang tp body) -> ((qid, from, to, lang, tp), body)) (xpElem "{jabber:client}iq" @@ -85,7 +86,7 @@ ) xpIQResult :: PU [Node] IQResult -xpIQResult = xpWrap +xpIQResult = ("xpIQResult" , "") xpWrap (\((qid, from, to, lang, _tp),body) -> IQResult qid from to lang body) (\(IQResult qid from to lang body) -> ((qid, from, to, lang, ()), body)) (xpElem "{jabber:client}iq" @@ -104,7 +105,7 @@ ---------------------------------------------------------- xpErrorCondition :: PU [Node] StanzaErrorCondition -xpErrorCondition = xpWrap +xpErrorCondition = ("xpErrorCondition" , "") xpWrap (\(cond, (), ()) -> cond) (\cond -> (cond, (), ())) (xpElemByNamespace @@ -115,7 +116,7 @@ ) xpStanzaError :: PU [Node] StanzaError -xpStanzaError = xpWrap +xpStanzaError = ("xpStanzaError" , "") xpWrap (\(tp, (cond, txt, ext)) -> StanzaError tp cond txt ext) (\(StanzaError tp cond txt ext) -> (tp, (cond, txt, ext))) (xpElem "{jabber:client}error" @@ -131,7 +132,7 @@ ) xpMessageError :: PU [Node] (MessageError) -xpMessageError = xpWrap +xpMessageError = ("xpMessageError" , "") xpWrap (\((_, qid, from, to, lang), (err, ext)) -> MessageError qid from to lang err ext) (\(MessageError qid from to lang err ext) -> @@ -149,7 +150,7 @@ ) xpPresenceError :: PU [Node] PresenceError -xpPresenceError = xpWrap +xpPresenceError = ("xpPresenceError" , "") xpWrap (\((qid, from, to, lang, _),(err, ext)) -> PresenceError qid from to lang err ext) (\(PresenceError qid from to lang err ext) -> @@ -166,7 +167,7 @@ ) xpIQError :: PU [Node] IQError -xpIQError = xpWrap +xpIQError = ("xpIQError" , "") xpWrap (\((qid, from, to, lang, _tp),(err, body)) -> IQError qid from to lang err body) (\(IQError qid from to lang err body) -> @@ -182,10 +183,10 @@ (xp2Tuple xpStanzaError (xpOption xpElemVerbatim)) ) -xpStreamError :: PU [Node] XmppStreamError -xpStreamError = xpWrap - (\((cond,() ,()), txt, el) -> XmppStreamError cond txt el) - (\(XmppStreamError cond txt el) ->((cond,() ,()), txt, el)) +xpStreamError :: PU [Node] StreamErrorInfo +xpStreamError = ("xpStreamError" , "") xpWrap + (\((cond,() ,()), txt, el) -> StreamErrorInfo cond txt el) + (\(StreamErrorInfo cond txt el) ->((cond,() ,()), txt, el)) (xpElemNodes (Name "error" @@ -207,3 +208,67 @@ (xpOption xpElemVerbatim) -- Application specific error conditions ) ) + +xpLangTag :: PU [Attribute] (Maybe LangTag) +xpLangTag = xpAttrImplied xmlLang xpPrim + +xmlLang :: Name +xmlLang = Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml") + +-- Given a pickler and an object, produces an Element. +pickleElem :: PU [Node] a -> a -> Element +pickleElem p = pickle $ xpNodeElem p + +-- Given a pickler and an element, produces an object. +unpickleElem :: PU [Node] a -> Element -> Either UnpickleError a +unpickleElem p x = unpickle (xpNodeElem p) x + +xpNodeElem :: PU [Node] a -> PU Element a +xpNodeElem = xpRoot . xpUnliftElems + +mbl :: Maybe [a] -> [a] +mbl (Just l) = l +mbl Nothing = [] + +lmb :: [t] -> Maybe [t] +lmb [] = Nothing +lmb x = Just x + +xpStream :: PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag) +xpStream = xpElemAttrs + (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) + (xp5Tuple + (xpAttr "version" xpId) + (xpAttrImplied "from" xpPrim) + (xpAttrImplied "to" xpPrim) + (xpAttrImplied "id" xpId) + xpLangTag + ) + +-- Pickler/Unpickler for the stream features - TLS, SASL, and the rest. +xpStreamFeatures :: PU [Node] StreamFeatures +xpStreamFeatures = ("xpStreamFeatures","") xpWrap + (\(tls, sasl, rest) -> StreamFeatures tls (mbl sasl) rest) + (\(StreamFeatures tls sasl rest) -> (tls, lmb sasl, rest)) + (xpElemNodes + (Name + "features" + (Just "http://etherx.jabber.org/streams") + (Just "stream") + ) + (xpTriple + (xpOption pickleTlsFeature) + (xpOption pickleSaslFeature) + (xpAll xpElemVerbatim) + ) + ) + where + pickleTlsFeature :: PU [Node] Bool + pickleTlsFeature = ("pickleTlsFeature", "") + xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls" + (xpElemExists "{urn:ietf:params:xml:ns:xmpp-tls}required") + pickleSaslFeature :: PU [Node] [Text] + pickleSaslFeature = ("pickleSaslFeature", "") + xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms" + (xpAll $ xpElemNodes + "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId)) diff --git a/source/Network/Xmpp/Message.hs b/source/Network/Xmpp/Message.hs deleted file mode 100644 --- a/source/Network/Xmpp/Message.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Network.Xmpp.Message - ( Message(..) - , MessageError(..) - , MessageType(..) - , answerMessage - , message - ) where - -import Data.XML.Types - -import Network.Xmpp.Types - --- | An empty message. -message :: Message -message = Message { messageID = Nothing - , messageFrom = Nothing - , messageTo = Nothing - , messageLangTag = Nothing - , messageType = Normal - , messagePayload = [] - } - --- Produce an answer message with the given payload, switching the "from" and --- "to" attributes in the original message. -answerMessage :: Message -> [Element] -> Maybe Message -answerMessage Message{messageFrom = Just frm, ..} payload = - Just Message{ messageFrom = messageTo - , messageID = Nothing - , messageTo = Just frm - , messagePayload = payload - , .. - } -answerMessage _ _ = Nothing diff --git a/source/Network/Xmpp/Monad.hs b/source/Network/Xmpp/Monad.hs deleted file mode 100644 --- a/source/Network/Xmpp/Monad.hs +++ /dev/null @@ -1,238 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} - -module Network.Xmpp.Monad 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 qualified Data.Conduit.List as CL -import Data.Conduit.BufferedSource -import Data.Conduit.Binary as CB -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 -> XmppConMonad Bool -pushElement x = do - sink <- gets sConPushBS - liftIO . sink $ renderElement x - -pushStanza :: Stanza -> XmppConMonad Bool -pushStanza = pushElement . pickleElem xpStanza - --- 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 :: XmppConMonad Bool -pushXmlDecl = do - sink <- gets sConPushBS - liftIO $ sink "" - -pushOpenElement :: Element -> XmppConMonad Bool -pushOpenElement e = do - sink <- gets sConPushBS - liftIO . sink $ renderOpenElement e - --- `Connect-and-resumes' the given sink to the connection source, and pulls a --- `b' value. -pullToSink :: Sink Event IO b -> XmppConMonad b -pullToSink snk = do - source <- gets sConSrc - (_, r) <- lift $ source $$+ snk - return r - -pullElement :: XmppConMonad Element -pullElement = do - Ex.catches (do - e <- pullToSink (elements =$ CL.head) - 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. -pullPickle :: PU [Node] a -> XmppConMonad a -pullPickle 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 :: XmppConMonad Stanza -pullStanza = do - res <- pullPickle 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 - ) - --- XmppConnection state used when there is no connection. -xmppNoConnection :: XmppConnection -xmppNoConnection = XmppConnection - { sConSrc = zeroSource - , sRawSrc = zeroSource - , sConPushBS = \_ -> return False -- Nothing has been sent. - , sConHandle = Nothing - , sFeatures = SF Nothing [] [] - , sConnectionState = XmppConnectionClosed - , sHostname = Nothing - , sJid = Nothing - , sCloseConnection = return () - , 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 XmppConnection state. -xmppRawConnect :: HostName -> Text -> XmppConMonad () -xmppRawConnect host hostname = do - con <- liftIO $ do - con <- connectTo host (PortNumber 5222) - hSetBuffering con NoBuffering - return con - let raw = if debug - then sourceHandle con $= debugConduit - else sourceHandle con - src <- liftIO . bufferSource $ raw $= XP.parseBytes def - let st = XmppConnection - { sConSrc = src - , sRawSrc = raw - , sConPushBS = if debug - then \d -> do - BS.putStrLn (BS.append "out: " d) - catchPush $ BS.hPut con d - else catchPush . BS.hPut con - , sConHandle = (Just con) - , sFeatures = (SF Nothing [] []) - , sConnectionState = XmppConnectionPlain - , sHostname = (Just hostname) - , sJid = Nothing - , sCloseConnection = (hClose con) - , 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 - } - put st - --- Execute a XmppConMonad computation. -xmppNewSession :: XmppConMonad a -> IO (a, XmppConnection) -xmppNewSession action = runStateT action xmppNoConnection - --- Closes the connection and updates the XmppConMonad XmppConnection state. -xmppKillConnection :: XmppConMonad (Either Ex.SomeException ()) -xmppKillConnection = do - cc <- gets sCloseConnection - 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. -xmppSendIQ' :: StanzaId - -> Maybe Jid - -> IQRequestType - -> Maybe LangTag - -> Element - -> XmppConMonad (Either IQError IQResult) -xmppSendIQ' iqID to tp lang body = do - pushStanza . IQRequestS $ IQRequest iqID Nothing to lang tp body - res <- pullPickle $ xpEither xpIQError xpIQResult - case res of - Left e -> return $ Left e - Right iq' -> do - unless - (iqID == iqResultID iq') . liftIO . Ex.throwIO $ - StreamXMLError - ("In xmppSendIQ' IDs don't match: " ++ show iqID ++ " /= " ++ - show (iqResultID iq') ++ " .") - return $ Right iq' - --- | 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. -xmppCloseStreams :: XmppConMonad ([Element], Bool) -xmppCloseStreams = do - send <- gets sConPushBS - cc <- gets sCloseConnection - 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] -> XmppConMonad ([Element], Bool) - collectElems elems = do - result <- Ex.try pullElement - case result of - Left StreamStreamEnd -> return (elems, True) - Left _ -> return (elems, False) - Right elem -> collectElems (elem:elems) - -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/Pickle.hs b/source/Network/Xmpp/Pickle.hs deleted file mode 100644 --- a/source/Network/Xmpp/Pickle.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - --- Marshalling between XML and Native Types - - -module Network.Xmpp.Pickle - ( mbToBool - , xmlLang - , xpLangTag - , xpNodeElem - , ignoreAttrs - , mbl - , lmb - , right - , unpickleElem' - , unpickleElem - , pickleElem - , ppElement - ) where - -import Data.XML.Types -import Data.XML.Pickle - -import Network.Xmpp.Types - -import Text.XML.Stream.Elements - -mbToBool :: Maybe t -> Bool -mbToBool (Just _) = True -mbToBool _ = False - -xmlLang :: Name -xmlLang = Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml") - -xpLangTag :: PU [Attribute] (Maybe LangTag) -xpLangTag = xpAttrImplied xmlLang xpPrim - -xpNodeElem :: PU [Node] a -> PU Element a -xpNodeElem xp = PU { pickleTree = \x -> head $ (pickleTree xp x) >>= \y -> - case y of - NodeElement e -> [e] - _ -> [] - , unpickleTree = \x -> case unpickleTree xp $ [NodeElement x] of - Left l -> Left l - Right (a,(_,c)) -> Right (a,(Nothing,c)) - } - -ignoreAttrs :: PU t ((), b) -> PU t b -ignoreAttrs = xpWrap snd ((),) - -mbl :: Maybe [a] -> [a] -mbl (Just l) = l -mbl Nothing = [] - -lmb :: [t] -> Maybe [t] -lmb [] = Nothing -lmb x = Just x - -right :: Either [Char] t -> t -right (Left l) = error l -right (Right r) = r - -unpickleElem' :: PU [Node] c -> Element -> c -unpickleElem' p x = case unpickle (xpNodeElem p) x of - Left l -> error $ (show l) ++ "\n saw: " ++ ppElement x - Right r -> r - --- Given a pickler and an element, produces an object. -unpickleElem :: PU [Node] a -> Element -> Either UnpickleError a -unpickleElem p x = unpickle (xpNodeElem p) x - --- Given a pickler and an object, produces an Element. -pickleElem :: PU [Node] a -> a -> Element -pickleElem p = pickle $ xpNodeElem p diff --git a/source/Network/Xmpp/Presence.hs b/source/Network/Xmpp/Presence.hs deleted file mode 100644 --- a/source/Network/Xmpp/Presence.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} - -module Network.Xmpp.Presence where - -import Data.Text(Text) -import Network.Xmpp.Types - --- | Add a recipient to a presence notification. -presTo :: Presence -> Jid -> Presence -presTo pres to = pres{presenceTo = Just to} diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -1,7 +1,19 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} -module Network.Xmpp.Sasl where +-- Submodule for functionality related to SASL negotation: +-- authentication functions, SASL functionality, bind functionality, +-- and the legacy `{urn:ietf:params:xml:ns:xmpp-session}session' +-- functionality. +module Network.Xmpp.Sasl + ( xmppSasl + , digestMd5 + , scramSha1 + , plain + , auth + ) where + import Control.Applicative import Control.Arrow (left) import Control.Monad @@ -23,33 +35,154 @@ import Data.Text (Text) import qualified Data.Text.Encoding as Text -import Network.Xmpp.Monad import Network.Xmpp.Stream import Network.Xmpp.Types -import Network.Xmpp.Pickle +import System.Log.Logger (debugM, errorM) import qualified System.Random as Random -import Network.Xmpp.Sasl.Types +import Network.Xmpp.Sasl.Types +import Network.Xmpp.Sasl.Mechanisms --- Uses the first supported mechanism to authenticate, if any. Updates the --- XmppConMonad state with non-password credentials and restarts the stream upon --- success. This computation wraps an ErrorT computation, which means that --- catchError can be used to catch any errors. +import Control.Concurrent.STM.TMVar + +import Control.Exception + +import Data.XML.Pickle +import Data.XML.Types + +import Network.Xmpp.Types +import Network.Xmpp.Marshal + +import Control.Monad.State(modify) + +import Control.Concurrent.STM.TMVar + +import Control.Monad.Error + +-- | Uses the first supported mechanism to authenticate, if any. Updates the +-- state with non-password credentials and restarts the stream upon +-- 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 - -> XmppConMonad (Either AuthError ()) -xmppSasl handlers = do - -- Chooses the first mechanism that is acceptable by both the client and the - -- server. - mechanisms <- gets $ saslMechanisms . sFeatures - case (filter (\(name, _) -> name `elem` mechanisms)) handlers of - [] -> return . Left $ AuthNoAcceptableMechanism mechanisms - (_name, handler):_ -> runErrorT $ do - cs <- gets sConnectionState - case cs of - XmppConnectionClosed -> throwError AuthConnectionError - _ -> do - r <- handler - _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream - return r + -> Stream + -> IO (Either XmppFailure (Maybe AuthFailure)) +xmppSasl handlers stream = do + debugM "Pontarius.Xmpp" "xmppSasl: Attempts to authenticate..." + flip withStream stream $ do + -- Chooses the first mechanism that is acceptable by both the client and the + -- server. + mechanisms <- gets $ streamSaslMechanisms . streamFeatures + case (filter (\(name, _) -> name `elem` mechanisms)) handlers of + [] -> return $ Right $ Just $ AuthNoAcceptableMechanism mechanisms + (_name, handler):_ -> do + cs <- gets streamConnectionState + case cs of + Closed -> do + lift $ errorM "Pontarius.Xmpp" "xmppSasl: Stream state closed." + return . Left $ XmppNoStream + _ -> runErrorT $ do + -- TODO: Log details about handler? SaslHandler "show" instance? + lift $ lift $ debugM "Pontarius.Xmpp" "xmppSasl: Performing handler..." + r <- ErrorT handler + case r of + Just ae -> do + lift $ lift $ errorM "Pontarius.Xmpp" $ + "xmppSasl: AuthFailure encountered: " ++ + show ae + return $ Just ae + Nothing -> do + lift $ lift $ debugM "Pontarius.Xmpp" "xmppSasl: Authentication successful, restarting stream." + _ <- ErrorT restartStream + lift $ lift $ debugM "Pontarius.Xmpp" "xmppSasl: Stream restarted." + return Nothing + +-- | Authenticate to the server using the first matching method and bind a +-- resource. +auth :: [SaslHandler] + -> Maybe Text + -> Stream + -> IO (Either XmppFailure (Maybe AuthFailure)) +auth mechanisms resource con = runErrorT $ do + ErrorT $ xmppSasl mechanisms con + jid <- ErrorT $ xmppBind resource con + ErrorT $ flip withStream con $ do + s <- get + case establishSession $ streamConfiguration s of + False -> return $ Right Nothing + True -> do + _ <- lift $ startSession con + return $ Right Nothing + return Nothing + +-- Produces a `bind' element, optionally wrapping a resource. +bindBody :: Maybe Text -> Element +bindBody = pickleElem $ + -- Pickler to produce a + -- "" + -- element, with a possible "[JID]" + -- child. + xpBind . xpOption $ xpElemNodes "resource" (xpContent xpId) + +-- 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 -> Stream -> IO (Either XmppFailure Jid) +xmppBind rsrc c = runErrorT $ do + lift $ debugM "Pontarius.Xmpp" "Attempts to bind..." + answer <- ErrorT $ pushIQ "bind" Nothing Set Nothing (bindBody rsrc) c + case answer of + Right IQResult{iqResultPayload = Just b} -> do + lift $ debugM "Pontarius.XMPP" "xmppBind: IQ result received; unpickling JID..." + let jid = unpickleElem xpJid b + case jid of + Right jid' -> do + lift $ debugM "Pontarius.XMPP" $ "xmppBind: JID unpickled: " ++ show jid' + ErrorT $ withStream (do + modify $ \s -> s{streamJid = Just jid'} + return $ Right jid') c -- not pretty + return jid' + otherwise -> do + lift $ errorM "Pontarius.XMPP" $ "xmppBind: JID could not be unpickled from: " + ++ show b + throwError $ XmppOtherFailure + otherwise -> do + lift $ errorM "Pontarius.XMPP" "xmppBind: IQ error received." + throwError XmppOtherFailure + where + -- Extracts the character data in the `jid' element. + xpJid :: PU [Node] Jid + xpJid = xpBind $ xpElemNodes jidName (xpContent xpPrim) + jidName = "{urn:ietf:params:xml:ns:xmpp-bind}jid" + +-- A `bind' element pickler. +xpBind :: PU [Node] b -> PU [Node] b +xpBind c = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-bind}bind" c + +sessionXml :: Element +sessionXml = pickleElem + (xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session") + () + +sessionIQ :: Stanza +sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" + , iqRequestFrom = Nothing + , iqRequestTo = Nothing + , iqRequestLangTag = Nothing + , iqRequestType = Set + , 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 :: Stream -> IO Bool +startSession con = do + debugM "Pontarius.XMPP" "startSession: Pushing `session' IQ set stanza..." + answer <- pushIQ "session" Nothing Set Nothing sessionXml con + case answer of + Left e -> do + errorM "Pontarius.XMPP" $ "startSession: Error stanza received (" ++ (show e) ++ ")" + return False + Right _ -> do + debugM "Pontarius.XMPP" "startSession: Result stanza received." + return True diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} @@ -21,14 +22,16 @@ import Data.XML.Pickle import Data.XML.Types -import Network.Xmpp.Monad -import Network.Xmpp.Pickle -import Network.Xmpp.Sasl.Types +import Network.Xmpp.Stream import Network.Xmpp.Sasl.StringPrep +import Network.Xmpp.Sasl.Types +import Network.Xmpp.Marshal import qualified System.Random as Random ---makeNonce :: SaslM BS.ByteString +import Control.Monad.State.Strict + +--makeNonce :: ErrorT AuthFailure (StateT StreamState IO) BS.ByteString makeNonce :: IO BS.ByteString makeNonce = do g <- liftIO Random.newStdGen @@ -105,20 +108,25 @@ 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 :: Text.Text -> Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) Bool +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 :: ErrorT AuthFailure (StateT StreamState IO) SaslElement pullSaslElement = do - el <- lift $ pullPickle (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) +pullChallenge :: ErrorT AuthFailure (StateT StreamState IO) (Maybe BS.ByteString) pullChallenge = do e <- pullSaslElement case e of @@ -126,24 +134,24 @@ SaslChallenge (Just scb64) | Right sc <- B64.decode . Text.encodeUtf8 $ scb64 -> return $ Just sc - _ -> throwError AuthChallengeError + _ -> throwError AuthOtherFailure -- TODO: Log --- | Extract value from Just, failing with AuthChallengeError on Nothing. -saslFromJust :: Maybe a -> SaslM a -saslFromJust Nothing = throwError $ AuthChallengeError +-- | Extract value from Just, failing with AuthOtherFailure on Nothing. +saslFromJust :: Maybe a -> ErrorT AuthFailure (StateT StreamState IO) a +saslFromJust Nothing = throwError $ AuthOtherFailure -- TODO: Log saslFromJust (Just d) = return d -- | Pull the next element and check that it is success. -pullSuccess :: SaslM (Maybe Text.Text) +pullSuccess :: ErrorT AuthFailure (StateT StreamState IO) (Maybe Text.Text) pullSuccess = do e <- pullSaslElement case e of SaslSuccess x -> return x - _ -> throwError $ AuthXmlError + _ -> throwError $ AuthOtherFailure -- TODO: Log -- | Pull the next element. When it's success, return it's payload. -- If it's a challenge, send an empty response and pull success. -pullFinalMessage :: SaslM (Maybe BS.ByteString) +pullFinalMessage :: ErrorT AuthFailure (StateT StreamState IO) (Maybe BS.ByteString) pullFinalMessage = do challenge2 <- pullSaslElement case challenge2 of @@ -155,27 +163,30 @@ where decode Nothing = return Nothing decode (Just d) = case B64.decode $ Text.encodeUtf8 d of - Left _e -> throwError $ AuthChallengeError + Left _e -> throwError $ AuthOtherFailure -- TODO: Log Right x -> return $ Just x -- | Extract p=q pairs from a challenge. -toPairs :: BS.ByteString -> SaslM Pairs +toPairs :: BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) Pairs toPairs ctext = case pairs ctext of - Left _e -> throwError AuthChallengeError + Left _e -> throwError AuthOtherFailure -- TODO: Log 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 :: Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) Bool +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) + -> ErrorT AuthFailure (StateT StreamState IO) (Text.Text, Maybe Text.Text, Text.Text) prepCredentials authcid authzid password = case credentials of - Nothing -> throwError $ AuthStringPrepError + Nothing -> throwError $ AuthIllegalCredentials Just creds -> return creds where credentials = do diff --git a/source/Network/Xmpp/Sasl/Mechanisms.hs b/source/Network/Xmpp/Sasl/Mechanisms.hs --- a/source/Network/Xmpp/Sasl/Mechanisms.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms.hs @@ -1,6 +1,7 @@ +{-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Sasl.Mechanisms ( module Network.Xmpp.Sasl.Mechanisms.DigestMd5 - , module Network.Xmpp.Sasl.Mechanisms.Scram + , scramSha1 , module Network.Xmpp.Sasl.Mechanisms.Plain ) where diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs --- a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs @@ -1,6 +1,9 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.Sasl.Mechanisms.DigestMd5 where +module Network.Xmpp.Sasl.Mechanisms.DigestMd5 + ( digestMd5 + ) where import Control.Applicative import Control.Arrow (left) @@ -28,39 +31,31 @@ import Data.XML.Types -import Network.Xmpp.Monad -import Network.Xmpp.Pickle import Network.Xmpp.Stream import Network.Xmpp.Types - - import Network.Xmpp.Sasl.Common import Network.Xmpp.Sasl.StringPrep import Network.Xmpp.Sasl.Types -xmppDigestMd5 :: Text -- Authorization identity (authzid) - -> Maybe Text -- Authentication identity (authzid) - -> Text -- Password (authzid) - -> SaslM () +xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username) + -> Maybe Text -- ^ Authorization identity (authcid) + -> Text -- ^ Password (authzid) + -> ErrorT AuthFailure (StateT StreamState IO) () 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 + Just address <- gets streamAddress + xmppDigestMd5' address ac az pw where - xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> SaslM () + xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> ErrorT AuthFailure (StateT StreamState IO) () xmppDigestMd5' hostname authcid authzid password = do - -- Push element and receive the challenge (in SaslM). + -- Push element and receive the challenge. _ <- saslInit "DIGEST-MD5" Nothing -- TODO: Check boolean? pairs <- toPairs =<< saslFromJust =<< pullChallenge cnonce <- liftIO $ makeNonce _b <- respond . Just $ createResponse hostname pairs cnonce challenge2 <- pullFinalMessage - _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream return () where -- Produce the response to the challenge. @@ -128,10 +123,16 @@ ha2 = hash ["AUTHENTICATE", digestURI] in hash [ha1, nonce, nc, cnonce, qop, ha2] -digestMd5 :: Text -- Authorization identity (authzid) - -> Maybe Text -- Authentication identity (authzid) - -> Text -- Password (authzid) +digestMd5 :: Text -- ^ Authentication identity (authcid or username) + -> Maybe Text -- ^ Authorization identity (authzid) + -> Text -- ^ Password -> SaslHandler -digestMd5 authcid authzid password = ( "DIGEST-MD5" - , xmppDigestMd5 authcid authzid password - ) +digestMd5 authcid authzid password = + ( "DIGEST-MD5" + , do + r <- runErrorT $ xmppDigestMd5 authcid authzid password + case r of + Left (AuthStreamFailure e) -> return $ Left e + Left e -> return $ Right $ Just e + Right () -> return $ Right Nothing + ) diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs --- a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs @@ -1,9 +1,12 @@ +{-# OPTIONS_HADDOCK hide #-} -- Implementation of the PLAIN Simple Authentication and Security Layer (SASL) -- Mechanism, http://tools.ietf.org/html/rfc4616. {-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.Sasl.Mechanisms.Plain where +module Network.Xmpp.Sasl.Mechanisms.Plain + ( plain + ) where import Control.Applicative import Control.Arrow (left) @@ -26,30 +29,28 @@ import Data.Text (Text) import qualified Data.Text.Encoding as Text -import Data.XML.Pickle +import Data.XML.Pickle import qualified Data.ByteString as BS -import Data.XML.Types +import Data.XML.Types -import Network.Xmpp.Monad import Network.Xmpp.Stream import Network.Xmpp.Types -import Network.Xmpp.Pickle import qualified System.Random as Random -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe) import qualified Data.Text as Text -import Network.Xmpp.Sasl.Common -import Network.Xmpp.Sasl.Types +import Network.Xmpp.Sasl.Common +import Network.Xmpp.Sasl.Types -- TODO: stringprep xmppPlain :: Text.Text -- ^ Password -> Maybe Text.Text -- ^ Authorization identity (authzid) -> Text.Text -- ^ Authentication identity (authcid) - -> SaslM () + -> ErrorT AuthFailure (StateT StreamState IO) () xmppPlain authcid authzid password = do (ac, az, pw) <- prepCredentials authcid authzid password _ <- saslInit "PLAIN" ( Just $ plainMessage ac az pw) @@ -72,5 +73,16 @@ where authzid' = maybe "" Text.encodeUtf8 authzid -plain :: Text.Text -> Maybe Text.Text -> Text.Text -> SaslHandler -plain authcid authzid passwd = ("PLAIN", xmppPlain authcid authzid passwd) +plain :: Text.Text -- ^ authentication ID (username) + -> Maybe Text.Text -- ^ authorization ID + -> Text.Text -- ^ password + -> SaslHandler +plain authcid authzid passwd = + ( "PLAIN" + , do + r <- runErrorT $ xmppPlain authcid authzid passwd + case r of + Left (AuthStreamFailure e) -> return $ Left e + Left e -> return $ Right $ Just e + Right () -> return $ Right Nothing + ) diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs --- a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs @@ -1,8 +1,10 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.Sasl.Mechanisms.Scram where +module Network.Xmpp.Sasl.Mechanisms.Scram + where import Control.Applicative ((<$>)) import Control.Monad.Error @@ -27,7 +29,11 @@ import Network.Xmpp.Sasl.Common import Network.Xmpp.Sasl.StringPrep import Network.Xmpp.Sasl.Types +import Network.Xmpp.Types + +import Control.Monad.State.Strict + -- | A nicer name for undefined, for use as a dummy token to determin -- the hash function to use hashToken :: (Crypto.Hash ctx hash) => hash @@ -43,7 +49,7 @@ -> Text.Text -- ^ Authentication ID (user name) -> Maybe Text.Text -- ^ Authorization ID -> Text.Text -- ^ Password - -> SaslM () + -> ErrorT AuthFailure (StateT StreamState IO) () scram hashToken authcid authzid password = do (ac, az, pw) <- prepCredentials authcid authzid password scramhelper hashToken ac az pw @@ -57,7 +63,7 @@ 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 AuthOtherFailure -- TODO: Log return () where -- We need to jump through some hoops to get a polymorphic solution @@ -92,7 +98,7 @@ fromPairs :: Pairs -> BS.ByteString - -> SaslM (BS.ByteString, BS.ByteString, Integer) + -> ErrorT AuthFailure (StateT StreamState IO) (BS.ByteString, BS.ByteString, Integer) fromPairs pairs cnonce | Just nonce <- lookup "r" pairs , cnonce `BS.isPrefixOf` nonce , Just salt' <- lookup "s" pairs @@ -100,7 +106,7 @@ , Just ic <- lookup "i" pairs , [(i,"")] <- reads $ BS8.unpack ic = return (nonce, salt, i) - fromPairs _ _ = throwError $ AuthChallengeError + fromPairs _ _ = throwError $ AuthOtherFailure -- TODO: Log cFinalMessageAndVerifier :: BS.ByteString -> BS.ByteString @@ -153,12 +159,16 @@ u1 = hmac str (salt +++ (BS.pack [0,0,0,1])) us = iterate (hmac str) u1 --- | 'scram' spezialised to the SHA-1 hash function, packaged as a SaslHandler scramSha1 :: Text.Text -- ^ username -> Maybe Text.Text -- ^ authorization ID -> Text.Text -- ^ password -> SaslHandler scramSha1 authcid authzid passwd = - ("SCRAM-SHA-1" - , scram (hashToken :: Crypto.SHA1) authcid authzid passwd + ( "SCRAM-SHA-1" + , do + r <- runErrorT $ scram (hashToken :: Crypto.SHA1) authcid authzid passwd + case r of + Left (AuthStreamFailure e) -> return $ Left e + Left e -> return $ Right $ Just e + Right () -> return $ Right Nothing ) diff --git a/source/Network/Xmpp/Sasl/StringPrep.hs b/source/Network/Xmpp/Sasl/StringPrep.hs --- a/source/Network/Xmpp/Sasl/StringPrep.hs +++ b/source/Network/Xmpp/Sasl/StringPrep.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings #-} module Network.Xmpp.Sasl.StringPrep where diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Sasl.Types where import Control.Monad.Error @@ -6,31 +7,31 @@ import qualified Data.Text as Text import Network.Xmpp.Types -data AuthError = AuthXmlError - | AuthNoAcceptableMechanism [Text.Text] -- ^ Wraps mechanisms - -- offered - | AuthChallengeError - | AuthServerAuthError -- ^ 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 - | AuthSaslFailure SaslFailure -- ^ Defined SASL error condition - | AuthStringPrepError -- ^ StringPrep failed +-- | Signals a (non-fatal) SASL authentication error condition. +data AuthFailure = -- | No mechanism offered by the server was matched + -- by the provided acceptable mechanisms; wraps the + -- mechanisms offered by the server + AuthNoAcceptableMechanism [Text.Text] + | AuthStreamFailure XmppFailure -- TODO: Remove + -- | A SASL failure element was encountered + | AuthSaslFailure SaslFailure + -- | The credentials provided did not conform to + -- the SASLprep Stringprep profile + | AuthIllegalCredentials + -- | Other failure; more information is available + -- in the log + | AuthOtherFailure deriving Show -instance Error AuthError where - noMsg = AuthError +instance Error AuthFailure where + noMsg = AuthOtherFailure 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 XmppConnection IO) a - type Pairs = [(ByteString, ByteString)] --- | Tuple defining the SASL Handler's name, and a SASL mechanism computation -type SaslHandler = (Text.Text, SaslM ()) +-- | Tuple defining the SASL Handler's name, and a SASL mechanism computation. +-- The SASL mechanism is a stateful @Stream@ computation, which has the +-- possibility of resulting in an authentication error. +type SaslHandler = (Text.Text, StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))) diff --git a/source/Network/Xmpp/Session.hs b/source/Network/Xmpp/Session.hs deleted file mode 100644 --- a/source/Network/Xmpp/Session.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Network.Xmpp.Session where - -import Data.XML.Pickle -import Data.XML.Types(Element) - -import Network.Xmpp.Monad -import Network.Xmpp.Pickle -import Network.Xmpp.Types -import Network.Xmpp.Concurrent - -sessionXML :: Element -sessionXML = pickleElem - (xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session") - () - -sessionIQ :: Stanza -sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" - , iqRequestFrom = Nothing - , iqRequestTo = Nothing - , iqRequestLangTag = Nothing - , iqRequestType = Set - , 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. -xmppStartSession :: XmppConMonad () -xmppStartSession = do - answer <- xmppSendIQ' "session" Nothing Set Nothing sessionXML - case answer of - Left e -> error $ show e - Right _ -> return () - --- 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 :: Session -> IO () -startSession session = do - answer <- sendIQ' Nothing Set Nothing sessionXML session - case answer of - IQResponseResult _ -> return () - e -> error $ show e diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -1,44 +1,91 @@ -{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} module Network.Xmpp.Stream where import Control.Applicative ((<$>), (<*>)) +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.STM import qualified Control.Exception as Ex +import Control.Exception.Base +import qualified Control.Exception.Lifted as ExL +import Control.Monad import Control.Monad.Error +import Control.Monad.IO.Class +import Control.Monad.Reader import Control.Monad.State.Strict - +import Control.Monad.Trans.Class +import qualified Data.ByteString as BS +import Data.ByteString.Base64 +import Data.ByteString.Char8 as BSC8 import Data.Conduit -import Data.Conduit.BufferedSource -import Data.Conduit.List as CL +import Data.Conduit.Binary as CB +import qualified Data.Conduit.Internal as DCI +import qualified Data.Conduit.List as CL import Data.Maybe (fromJust, isJust, isNothing) -import Data.Text as Text +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Void (Void) import Data.XML.Pickle import Data.XML.Types -import Data.Void (Void) - -import Network.Xmpp.Monad -import Network.Xmpp.Pickle +import qualified GHC.IO.Exception as GIE +import Network +import Network.Xmpp.Marshal import Network.Xmpp.Types -import Network.Xmpp.Errors - -import Text.XML.Stream.Elements +import System.IO +import System.IO.Error (tryIOError) +import System.Log.Logger import Text.XML.Stream.Parse as XP +import Text.XML.Unresolved(InvalidEventStream(..)) +import Control.Monad.Trans.Resource as R +import Network.Xmpp.Utilities + +import Network.DNS hiding (encode, lookup) + +import Data.Ord +import Data.Maybe +import Data.List +import Data.IP +import System.Random + +import qualified Network.Socket as NS + +-- "readMaybe" definition, as readMaybe is not introduced in the `base' package +-- until version 4.6. +readMaybe_ :: (Read a) => String -> Maybe a +readMaybe_ string = case reads string of + [(a, "")] -> Just a + _ -> Nothing + -- import Text.XML.Stream.Elements --- Unpickles and returns a stream element. Throws a StreamXMLError on failure. +mbl :: Maybe [a] -> [a] +mbl (Just l) = l +mbl Nothing = [] + +lmb :: [t] -> Maybe [t] +lmb [] = Nothing +lmb x = Just x + +-- 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 -> do + liftIO $ warningM "Pontarius.Xmpp" $ "streamUnpickleElem: Unpickle error: " ++ ppUnpickleError l + throwError $ XmppOtherFailure 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 () @@ -56,117 +103,655 @@ hd <- lift CL.head case hd of Just (EventBeginElement name attrs) -> return $ Element name attrs [] - _ -> throwError $ StreamConnectionError + _ -> do + liftIO $ warningM "Pontarius.Xmpp" "openElementFromEvents: Stream ended." + throwError XmppOtherFailure --- Sends the initial stream:stream element and pulls the server features. -xmppStartStream :: XmppConMonad (Either StreamError ()) -xmppStartStream = runErrorT $ do - state <- get - -- Set the `to' attribute depending on the state of the connection. - let from = case sConnectionState state of - XmppConnectionPlain -> if sJidWhenPlain state - then sJid state else Nothing - XmppConnectionSecured -> sJid state - case sHostname state of - Nothing -> throwError StreamConnectionError - Just hostname -> lift $ do +-- 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 StreamState IO (Either XmppFailure ()) +startStream = runErrorT $ do + lift $ lift $ debugM "Pontarius.Xmpp" "Starting stream..." + state <- lift $ get + -- Set the `from' (which is also the expected to) attribute depending on the + -- state of the stream. + let expectedTo = case ( streamConnectionState state + , toJid $ streamConfiguration state) of + (Plain, (Just (jid, True))) -> Just jid + (Secured, (Just (jid, _))) -> Just jid + (Plain, Nothing) -> Nothing + (Secured, Nothing) -> Nothing + case streamAddress state of + Nothing -> do + lift $ lift $ errorM "Pontarius.XMPP" "Server sent no hostname." + throwError XmppOtherFailure + Just address -> lift $ do pushXmlDecl pushOpenElement $ pickleElem xpStream ( "1.0" - , from - , Just (Jid Nothing hostname Nothing) + , expectedTo + , Just (Jid Nothing address Nothing) , Nothing - , sPreferredLang state + , preferredLang $ streamConfiguration state ) - (lt, from, id, features) <- ErrorT . pullToSink $ runErrorT $ xmppStream 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)) + | (Text.unpack ver) /= "1.0" -> + closeStreamWithError StreamUnsupportedVersion Nothing + "Unknown version" + | lt == Nothing -> + closeStreamWithError StreamInvalidXml Nothing + "Stream has no language tag" + -- 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 $ streamAddress state) Nothing)) -> + closeStreamWithError StreamInvalidFrom Nothing + "Stream from is invalid" + | to /= expectedTo -> + closeStreamWithError StreamUndefinedCondition (Just $ Element "invalid-to" [] []) + "Stream to invalid"-- TODO: Suitable? + | otherwise -> do + modify (\s -> s{ streamFeatures = features + , streamLang = lt + , streamId = id + , streamFrom = from + } ) + return () + -- Unpickling failed - we investigate the element. + Right (Left (Element name attrs children)) + | (nameLocalName name /= "stream") -> + closeStreamWithError StreamInvalidXml Nothing + "Root element is not stream" + | (nameNamespace name /= Just "http://etherx.jabber.org/streams") -> + closeStreamWithError StreamInvalidNamespace Nothing + "Wrong root element name space" + | (isJust $ namePrefix name) && (fromJust (namePrefix name) /= "stream") -> + closeStreamWithError StreamBadNamespacePrefix Nothing + "Root name prefix set and not stream" + | otherwise -> ErrorT $ checkchildren (flattenAttrs attrs) + where + -- closeStreamWithError :: MonadIO m => Stream -> StreamErrorCondition -> + -- Maybe Element -> ErrorT XmppFailure m () + closeStreamWithError :: StreamErrorCondition -> Maybe Element -> String + -> ErrorT XmppFailure (StateT StreamState IO) () + closeStreamWithError sec el msg = do + lift . pushElement . pickleElem xpStreamError + $ StreamErrorInfo sec Nothing el + lift $ closeStreams' + lift $ lift $ errorM "Pontarius.XMPP" $ "closeStreamWithError: " ++ msg + throwError XmppOtherFailure + checkchildren 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 + StreamBadNamespacePrefix Nothing + "stream to not a valid JID" + | Nothing == ver' -> + runErrorT $ closeStreamWithError + StreamUnsupportedVersion Nothing + "stream no version" + | Just (Nothing :: Maybe LangTag) == (safeRead <$> xl) -> + runErrorT $ closeStreamWithError + StreamInvalidXml Nothing + "stream no language tag" + | otherwise -> + runErrorT $ closeStreamWithError + 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. -xmppRestartStream :: XmppConMonad (Either StreamError ()) -xmppRestartStream = do - raw <- gets sRawSrc - newsrc <- liftIO . bufferSource $ raw $= XP.parseBytes def - modify (\s -> s{sConSrc = newsrc}) - xmppStartStream +restartStream :: StateT StreamState IO (Either XmppFailure ()) +restartStream = do + lift $ debugM "Pontarius.XMPP" "Restarting stream..." + raw <- gets (streamReceive . streamHandle) + let newSource = DCI.ResumableSource (loopRead raw $= XP.parseBytes def) + (return ()) + modify (\s -> s{streamEventSource = newSource }) + startStream + where + loopRead read = do + bs <- liftIO (read 4096) + if BS.null bs + then return () + 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. -xmppStream :: Maybe Jid -> StreamSink ( LangTag - , Maybe Jid - , Maybe Text - , ServerFeatures) -xmppStream expectedTo = do - (from, to, id, langTag) <- xmppStreamHeader - features <- xmppStreamFeatures - return (langTag, from, id, features) +streamS :: Maybe Jid -> StreamSink (Either Element ( Text + , Maybe Jid + , Maybe Jid + , Maybe Text + , Maybe LangTag + , StreamFeatures )) +streamS expectedTo = do + 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 + 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) - xmppStreamFeatures :: StreamSink ServerFeatures + Left _ -> return $ Left el + Right r -> return $ Right r + xmppStreamFeatures :: StreamSink StreamFeatures xmppStreamFeatures = do e <- lift $ elements =$ CL.head case e of - Nothing -> liftIO $ Ex.throwIO StreamConnectionError + Nothing -> do + lift $ lift $ errorM "Pontarius.XMPP" "streamS: Stream ended." + throwError XmppOtherFailure Just r -> streamUnpickleElem xpStreamFeatures r +-- | Connects to the XMPP server and opens the XMPP stream against the given +-- realm. +openStream :: HostName -> StreamConfiguration -> IO (Either XmppFailure (Stream)) +openStream realm config = runErrorT $ do + lift $ debugM "Pontarius.XMPP" "Opening stream..." + stream' <- createStream realm config + result <- liftIO $ withStream startStream stream' + return stream' +-- | 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 :: Stream -> IO (Either XmppFailure [Element]) +closeStreams = withStream closeStreams' -xpStream :: PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag) -xpStream = xpElemAttrs - (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) - (xp5Tuple - (xpAttr "version" xpId) - (xpAttrImplied "from" xpPrim) - (xpAttrImplied "to" xpPrim) - (xpAttrImplied "id" xpId) - xpLangTag - ) +closeStreams' = do + lift $ debugM "Pontarius.XMPP" "Closing stream..." + send <- gets (streamSend . streamHandle) + cc <- gets (streamClose . streamHandle) + 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 StreamState 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) --- Pickler/Unpickler for the stream features - TLS, SASL, and the rest. -xpStreamFeatures :: PU [Node] ServerFeatures -xpStreamFeatures = xpWrap - (\(tls, sasl, rest) -> SF tls (mbl sasl) rest) - (\(SF tls sasl rest) -> (tls, lmb sasl, rest)) - (xpElemNodes - (Name - "features" - (Just "http://etherx.jabber.org/streams") - (Just "stream") - ) - (xpTriple - (xpOption pickleTLSFeature) - (xpOption pickleSaslFeature) - (xpAll xpElemVerbatim) - ) +-- TODO: Can the TLS send/recv functions throw something other than an IO error? + +wrapIOException :: IO a -> StateT StreamState IO (Either XmppFailure a) +wrapIOException action = do + r <- liftIO $ tryIOError action + case r of + Right b -> return $ Right b + Left e -> do + lift $ warningM "Pontarius.XMPP" $ "wrapIOException: Exception wrapped: " ++ (show e) + return $ Left $ XmppIOException e + +pushElement :: Element -> StateT StreamState IO (Either XmppFailure Bool) +pushElement x = do + send <- gets (streamSend . streamHandle) + wrapIOException $ send $ renderElement x + +-- | Encode and send stanza +pushStanza :: Stanza -> Stream -> IO (Either XmppFailure Bool) +pushStanza s = withStream' . 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 StreamState IO (Either XmppFailure Bool) +pushXmlDecl = do + con <- gets streamHandle + wrapIOException $ (streamSend con) "" + +pushOpenElement :: Element -> StateT StreamState IO (Either XmppFailure Bool) +pushOpenElement e = do + sink <- gets (streamSend . streamHandle) + wrapIOException $ sink $ renderOpenElement e + +-- `Connect-and-resumes' the given sink to the stream source, and pulls a +-- `b' value. +runEventsSink :: Sink Event IO b -> StateT StreamState IO (Either XmppFailure b) +runEventsSink snk = do -- TODO: Wrap exceptions? + src <- gets streamEventSource + (src', r) <- lift $ src $$++ snk + modify (\s -> s{streamEventSource = src'}) + return $ Right r + +pullElement :: StateT StreamState IO (Either XmppFailure Element) +pullElement = do + ExL.catches (do + e <- runEventsSink (elements =$ await) + case e of + Left f -> return $ Left f + Right Nothing -> do + lift $ errorM "Pontarius.XMPP" "pullElement: No element." + return . Left $ XmppOtherFailure + Right (Just r) -> return $ Right r + ) + [ ExL.Handler (\StreamEnd -> return $ Left StreamEndFailure) + , ExL.Handler (\(InvalidXmppXml s) -- Invalid XML `Event' encountered, or missing element close tag + -> do + lift $ errorM "Pontarius.XMPP" $ "pullElement: Invalid XML: " ++ (show s) + return . Left $ XmppOtherFailure) + , ExL.Handler $ \(e :: InvalidEventStream) + -> do + lift $ errorM "Pontarius.XMPP" $ "pullElement: Invalid event stream: " ++ (show e) + return . Left $ XmppOtherFailure + ] + +-- Pulls an element and unpickles it. +pullUnpickle :: PU [Node] a -> StateT StreamState 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 -> do + lift $ errorM "Pontarius.XMPP" $ "pullUnpickle: Unpickle failed: " ++ (ppUnpickleError e) + return . Left $ XmppOtherFailure + Right r -> return $ Right r + +-- | Pulls a stanza (or stream error) from the stream. +pullStanza :: Stream -> IO (Either XmppFailure Stanza) +pullStanza = withStream $ 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 = ExL.catch + (p >> return True) + (\e -> case GIE.ioe_type e of + GIE.ResourceVanished -> return False + GIE.IllegalOperation -> return False + _ -> ExL.throwIO e ) + +-- Stream state used when there is no connection. +xmppNoStream :: StreamState +xmppNoStream = StreamState { + streamConnectionState = Closed + , streamHandle = StreamHandle { streamSend = \_ -> return False + , streamReceive = \_ -> do + errorM "Pontarius.XMPP" "xmppNoStream: No stream on receive." + ExL.throwIO $ + XmppOtherFailure + , streamFlush = return () + , streamClose = return () + } + , streamEventSource = DCI.ResumableSource zeroSource (return ()) + , streamFeatures = StreamFeatures Nothing [] [] + , streamAddress = Nothing + , streamFrom = Nothing + , streamId = Nothing + , streamLang = Nothing + , streamJid = Nothing + , streamConfiguration = def + } where - pickleTLSFeature :: PU [Node] Bool - pickleTLSFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls" - (xpElemExists "required") - pickleSaslFeature :: PU [Node] [Text] - pickleSaslFeature = xpElemNodes - "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms" - (xpAll $ xpElemNodes - "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId)) + zeroSource :: Source IO output + zeroSource = liftIO $ do + errorM "Pontarius.XMPP" "zeroSource utilized." + ExL.throwIO XmppOtherFailure + +createStream :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (Stream) +createStream realm config = do + result <- connect realm config + case result of + Just h -> ErrorT $ do + debugM "Pontarius.Xmpp" "Acquired handle." + debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle." + hSetBuffering h NoBuffering + let eSource = DCI.ResumableSource + ((sourceHandle h $= logConduit) $= XP.parseBytes def) + (return ()) + let hand = StreamHandle { streamSend = \d -> catchPush $ BS.hPut h d + , streamReceive = \n -> BS.hGetSome h n + , streamFlush = hFlush h + , streamClose = hClose h + } + let stream = StreamState + { streamConnectionState = Plain + , streamHandle = hand + , streamEventSource = eSource + , streamFeatures = StreamFeatures Nothing [] [] + , streamAddress = Just $ Text.pack realm + , streamFrom = Nothing + , streamId = Nothing + , streamLang = Nothing + , streamJid = Nothing + , streamConfiguration = config + } + stream' <- mkStream stream + return $ Right stream' + Nothing -> do + lift $ debugM "Pontarius.Xmpp" "Did not acquire handle." + throwError TcpConnectionFailure + where + logConduit :: Conduit ByteString IO ByteString + logConduit = CL.mapM $ \d -> do + debugM "Pontarius.Xmpp" $ "Received TCP data: " ++ (BSC8.unpack d) ++ + "." + return d + +-- Connects to the provided hostname or IP address. If a hostname is provided, a +-- DNS-SRV lookup is performed (unless `sockAddr' has been specified, in which +-- case that address is used instead). If an A(AAA) record results are +-- encountered, all IP addresses will be tried until a successful connection +-- attempt has been made. Will return the Handle acquired, if any. +connect :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (Maybe Handle) +connect realm config = do + case socketDetails config of + -- Just (_, NS.SockAddrUnix _) -> do + -- lift $ errorM "Pontarius.Xmpp" "SockAddrUnix address provided." + -- throwError XmppIllegalTcpDetails + Just socketDetails' -> lift $ do + debugM "Pontarius.Xmpp" "Connecting to configured SockAddr address..." + connectTcp $ Left socketDetails' + Nothing -> do + case (readMaybe_ realm :: Maybe IPv6, readMaybe_ realm :: Maybe IPv4, hostname (Text.pack realm) :: Maybe Hostname) of + (Just ipv6, Nothing, _) -> lift $ connectTcp $ Right [(show ipv6, 5222)] + (Nothing, Just ipv4, _) -> lift $ connectTcp $ Right [(show ipv4, 5222)] + (Nothing, Nothing, Just (Hostname realm')) -> do + resolvSeed <- lift $ makeResolvSeed (resolvConf config) + lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..." + srvRecords <- srvLookup realm' resolvSeed + case srvRecords of + -- No SRV records. Try fallback lookup. + Nothing -> do + lift $ debugM "Pontarius.Xmpp" "No SRV records, using fallback process..." + lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ realm) 5222 + Just srvRecords' -> do + lift $ debugM "Pontarius.Xmpp" "SRV records found, performing A/AAAA lookups..." + lift $ resolvSrvsAndConnectTcp resolvSeed srvRecords' + (Nothing, Nothing, Nothing) -> do + lift $ errorM "Pontarius.Xmpp" "The hostname could not be validated." + throwError XmppIllegalTcpDetails + +-- Connects to a list of addresses and ports. Surpresses any exceptions from +-- connectTcp. +connectTcp :: Either (NS.Socket, NS.SockAddr) [(HostName, Int)] -> IO (Maybe Handle) +connectTcp (Right []) = return Nothing +connectTcp (Right ((address, port):remainder)) = do + result <- try $ (do + debugM "Pontarius.Xmpp" $ "Connecting to " ++ (address) ++ " on port " ++ + (show port) ++ "." + connectTo address (PortNumber $ fromIntegral port)) :: IO (Either IOException Handle) + case result of + Right handle -> do + debugM "Pontarius.Xmpp" "Successfully connected to HostName." + return $ Just handle + Left _ -> do + debugM "Pontarius.Xmpp" "Connection to HostName could not be established." + connectTcp $ Right remainder +connectTcp (Left (sock, sockAddr)) = do + result <- try $ (do + NS.connect sock sockAddr + NS.socketToHandle sock ReadWriteMode) :: IO (Either IOException Handle) + case result of + Right handle -> do + debugM "Pontarius.Xmpp" "Successfully connected to SockAddr." + return $ Just handle + Left _ -> do + debugM "Pontarius.Xmpp" "Connection to SockAddr could not be established." + return Nothing + +-- Makes an AAAA query to acquire a IPs, and tries to connect to all of them. If +-- a handle can not be acquired this way, an analogous A query is performed. +-- Surpresses all IO exceptions. +resolvAndConnectTcp :: ResolvSeed -> Domain -> Int -> IO (Maybe Handle) +resolvAndConnectTcp resolvSeed domain port = do + aaaaResults <- (try $ rethrowErrorCall $ withResolver resolvSeed $ + \resolver -> lookupAAAA resolver domain) :: IO (Either IOException (Maybe [IPv6])) + handle <- case aaaaResults of + Right Nothing -> return Nothing + Right (Just ipv6s) -> connectTcp $ Right $ Data.List.map (\ipv6 -> (show ipv6, port)) ipv6s + Left e -> return Nothing + case handle of + Nothing -> do + aResults <- (try $ rethrowErrorCall $ withResolver resolvSeed $ + \resolver -> lookupA resolver domain) :: IO (Either IOException (Maybe [IPv4])) + handle' <- case aResults of + Right Nothing -> return Nothing + Right (Just ipv4s) -> connectTcp $ Right $ Data.List.map (\ipv4 -> (show ipv4, port)) ipv4s + case handle' of + Nothing -> return Nothing + Just handle'' -> return $ Just handle'' + Just handle' -> return $ Just handle' + +-- Tries `resolvAndConnectTcp' for every SRV record, stopping if a handle is +-- acquired. +resolvSrvsAndConnectTcp :: ResolvSeed -> [(Domain, Int)] -> IO (Maybe Handle) +resolvSrvsAndConnectTcp _ [] = return Nothing +resolvSrvsAndConnectTcp resolvSeed ((domain, port):remaining) = do + result <- resolvAndConnectTcp resolvSeed domain port + case result of + Just handle -> return $ Just handle + Nothing -> resolvSrvsAndConnectTcp resolvSeed remaining + + +-- The DNS functions may make error calls. This function catches any such +-- exceptions and rethrows them as IOExceptions. +rethrowErrorCall :: IO a -> IO a +rethrowErrorCall action = do + result <- try action + case result of + Right result' -> return result' + Left (ErrorCall e) -> ioError $ userError $ "rethrowErrorCall: " ++ e + Left e -> throwIO e + +-- Provides a list of A(AAA) names and port numbers upon a successful +-- DNS-SRV request, or `Nothing' if the DNS-SRV request failed. +srvLookup :: Text -> ResolvSeed -> ErrorT XmppFailure IO (Maybe [(Domain, Int)]) +srvLookup realm resolvSeed = ErrorT $ do + result <- try $ rethrowErrorCall $ withResolver resolvSeed $ \resolver -> do + srvResult <- lookupSRV resolver $ BSC8.pack $ "_xmpp-client._tcp." ++ (Text.unpack realm) ++ "." + case srvResult of + Just srvResult -> do + debugM "Pontarius.Xmpp" $ "SRV result: " ++ (show srvResult) + -- Get [(Domain, PortNumber)] of SRV request, if any. + srvResult' <- orderSrvResult srvResult + return $ Just $ Prelude.map (\(_, _, port, domain) -> (domain, port)) srvResult' + -- The service is not available at this domain. + -- Sorts the records based on the priority value. + Just [(_, _, _, ".")] -> do + debugM "Pontarius.Xmpp" $ "\".\" SRV result returned." + return $ Just [] + Nothing -> do + debugM "Pontarius.Xmpp" "No SRV result returned." + return Nothing + case result of + Right result' -> return $ Right result' + Left e -> return $ Left $ XmppIOException e + where + -- This function orders the SRV result in accordance with RFC + -- 2782. It sorts the SRV results in order of priority, and then + -- uses a random process to order the records with the same + -- priority based on their weight. + orderSrvResult :: [(Int, Int, Int, Domain)] -> IO [(Int, Int, Int, Domain)] + orderSrvResult srvResult = do + -- Order the result set by priority. + let srvResult' = sortBy (comparing (\(priority, _, _, _) -> priority)) srvResult + -- Group elements in sublists based on their priority. The + -- type is `[[(Int, Int, Int, Domain)]]'. + let srvResult'' = Data.List.groupBy (\(priority, _, _, _) (priority', _, _, _) -> priority == priority') srvResult' :: [[(Int, Int, Int, Domain)]] + -- For each sublist, put records with a weight of zero first. + let srvResult''' = Data.List.map (\sublist -> let (a, b) = partition (\(_, weight, _, _) -> weight == 0) sublist in Data.List.concat [a, b]) srvResult'' + -- Order each sublist. + srvResult'''' <- mapM orderSublist srvResult''' + -- Concatinated the results. + return $ Data.List.concat srvResult'''' + where + orderSublist :: [(Int, Int, Int, Domain)] -> IO [(Int, Int, Int, Domain)] + orderSublist [] = return [] + orderSublist sublist = do + -- Compute the running sum, as well as the total sum of + -- the sublist. Add the running sum to the SRV tuples. + let (total, sublist') = Data.List.mapAccumL (\total (priority, weight, port, domain) -> (total + weight, (priority, weight, port, domain, total + weight))) 0 sublist + -- Choose a random number between 0 and the total sum + -- (inclusive). + randomNumber <- randomRIO (0, total) + -- Select the first record with its running sum greater + -- than or equal to the random number. + let (beginning, ((priority, weight, port, domain, _):end)) = Data.List.break (\(_, _, _, _, running) -> randomNumber <= running) sublist' + -- Remove the running total number from the remaining + -- elements. + let sublist'' = Data.List.map (\(priority, weight, port, domain, _) -> (priority, weight, port, domain)) (Data.List.concat [beginning, end]) + -- Repeat the ordering procedure on the remaining + -- elements. + tail <- orderSublist sublist'' + return $ ((priority, weight, port, domain):tail) + +-- Closes the connection and updates the XmppConMonad Stream state. +-- killStream :: Stream -> IO (Either ExL.SomeException ()) +killStream :: Stream -> IO (Either XmppFailure ()) +killStream = withStream $ do + cc <- gets (streamClose . streamHandle) + err <- wrapIOException cc + -- (ExL.try cc :: IO (Either ExL.SomeException ())) + put xmppNoStream + 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 + -> Stream + -> IO (Either XmppFailure (Either IQError IQResult)) +pushIQ iqID to tp lang body stream = do + pushStanza (IQRequestS $ IQRequest iqID Nothing to lang tp body) stream + res <- pullStanza stream + case res of + Left e -> return $ Left e + Right (IQErrorS e) -> return $ Right $ Left e + Right (IQResultS r) -> do + unless + (iqID == iqResultID r) $ liftIO $ do + errorM "Pontarius.XMPP" $ "pushIQ: ID mismatch (" ++ (show iqID) ++ " /= " ++ (show $ iqResultID r) ++ ")." + ExL.throwIO XmppOtherFailure + -- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++ + -- " /= " ++ show (iqResultID r) ++ " .") + return $ Right $ Right r + _ -> do + errorM "Pontarius.XMPP" $ "pushIQ: Unexpected stanza type." + return . Left $ XmppOtherFailure + +debugConduit :: Pipe l ByteString ByteString u IO b +debugConduit = forever $ do + s' <- await + case s' of + Just s -> do + liftIO $ debugM "Pontarius.XMPP" $ "debugConduit: In: " ++ (show s) + yield s + Nothing -> return () + +elements :: R.MonadThrow m => Conduit Event m Element +elements = do + x <- await + case x of + Just (EventBeginElement n as) -> do + goE n as >>= yield + elements + Just (EventEndElement streamName) -> lift $ R.monadThrow StreamEnd + Nothing -> return () + _ -> lift $ R.monadThrow $ InvalidXmppXml $ "not an element: " ++ show x + where + many' f = + go id + where + go front = do + x <- f + case x of + Left x -> return $ (x, front []) + Right y -> go (front . (:) y) + goE n as = do + (y, ns) <- many' goN + if y == Just (EventEndElement n) + then return $ Element n as $ compressNodes ns + else lift $ R.monadThrow $ InvalidXmppXml $ + "Missing close tag: " ++ show n + goN = do + x <- await + case x of + Just (EventBeginElement n as) -> (Right . NodeElement) <$> goE n as + Just (EventInstruction i) -> return $ Right $ NodeInstruction i + Just (EventContent c) -> return $ Right $ NodeContent c + Just (EventComment t) -> return $ Right $ NodeComment t + Just (EventCDATA t) -> return $ Right $ NodeContent $ ContentText t + _ -> return $ Left x + + compressNodes :: [Node] -> [Node] + compressNodes [] = [] + compressNodes [x] = [x] + compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) = + compressNodes $ NodeContent (ContentText $ x `Text.append` y) : z + compressNodes (x:xs) = x : compressNodes xs + + streamName :: Name + streamName = (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) + +withStream :: StateT StreamState IO (Either XmppFailure c) -> Stream -> IO (Either XmppFailure c) +withStream action (Stream stream) = bracketOnError + (atomically $ takeTMVar stream ) + (atomically . putTMVar stream) + (\s -> do + (r, s') <- runStateT action s + atomically $ putTMVar stream s' + return r + ) + +-- nonblocking version. Changes to the connection are ignored! +withStream' :: StateT StreamState IO (Either XmppFailure b) -> Stream -> IO (Either XmppFailure b) +withStream' action (Stream stream) = do + stream_ <- atomically $ readTMVar stream + (r, _) <- runStateT action stream_ + return r + + +mkStream :: StreamState -> IO (Stream) +mkStream con = Stream `fmap` (atomically $ newTMVar con) diff --git a/source/Network/Xmpp/TLS.hs b/source/Network/Xmpp/TLS.hs deleted file mode 100644 --- a/source/Network/Xmpp/TLS.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} - -module Network.Xmpp.TLS where - -import qualified Control.Exception.Lifted as Ex -import Control.Monad -import Control.Monad.Error -import Control.Monad.State.Strict - -import Data.Conduit.TLS as TLS -import Data.Typeable -import Data.XML.Types - -import Network.Xmpp.Monad -import Network.Xmpp.Pickle(ppElement) -import Network.Xmpp.Stream -import Network.Xmpp.Types - -starttlsE :: Element -starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] - -exampleParams :: TLS.TLSParams -exampleParams = TLS.defaultParamsClient - { pConnectVersion = TLS.TLS10 - , pAllowedVersions = [TLS.SSL3, TLS.TLS10, TLS.TLS11] - , pCiphers = [TLS.cipher_AES128_SHA1] - , pCompressions = [TLS.nullCompression] - , pUseSecureRenegotiation = False -- No renegotiation - , onCertificatesRecv = \_certificate -> - return TLS.CertificateUsageAccept - } - --- | Error conditions that may arise during TLS negotiation. -data XmppTLSError = TLSError TLSError - | TLSNoServerSupport - | TLSNoConnection - | 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 -> XmppConMonad (Either XmppTLSError ()) -startTLS params = Ex.handle (return . Left . TLSError) . runErrorT $ do - features <- lift $ gets sFeatures - handle' <- lift $ gets sConHandle - handle <- maybe (throwError TLSNoConnection) return handle' - 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 - (raw, _snk, psh, ctx) <- lift $ TLS.tlsinit debug params handle - lift $ modify ( \x -> x - { sRawSrc = raw --- , sConSrc = -- Note: this momentarily leaves us in an - -- inconsistent state - , sConPushBS = catchPush . psh - , sCloseConnection = TLS.bye ctx >> sCloseConnection x - }) - either (lift . Ex.throwIO) return =<< lift xmppRestartStream - modify (\s -> s{sConnectionState = XmppConnectionSecured}) - return () diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Tls.hs @@ -0,0 +1,137 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Xmpp.Tls where + +import Control.Concurrent.STM.TMVar +import qualified Control.Exception.Lifted as Ex +import Control.Monad +import Control.Monad.Error +import Control.Monad.State.Strict +import Crypto.Random.API +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC8 +import qualified Data.ByteString.Lazy as BL +import Data.Conduit +import qualified Data.Conduit.Binary as CB +import Data.IORef +import Data.Typeable +import Data.XML.Types +import Network.TLS +import Network.TLS.Extra +import Network.Xmpp.Stream +import Network.Xmpp.Types +import System.Log.Logger (debugM, errorM) + +mkBackend con = Backend { backendSend = \bs -> void (streamSend con bs) + , backendRecv = streamReceive con + , backendFlush = streamFlush con + , backendClose = streamClose con + } + +starttlsE :: Element +starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] + +-- | Checks for TLS support and run starttls procedure if applicable +tls :: Stream -> IO (Either XmppFailure ()) +tls con = Ex.handle (return . Left . TlsError) + . flip withStream con + . runErrorT $ do + conf <- gets $ streamConfiguration + sState <- gets streamConnectionState + case sState of + Plain -> return () + Closed -> do + liftIO $ errorM "Pontarius.XMPP" "startTls: The stream is closed." + throwError XmppNoStream + Secured -> do + liftIO $ errorM "Pontarius.XMPP" "startTls: The stream is already secured." + throwError TlsStreamSecured + features <- lift $ gets streamFeatures + case (tlsBehaviour conf, streamTls features) of + (RequireTls , Just _ ) -> startTls + (RequireTls , Nothing ) -> throwError TlsNoServerSupport + (PreferTls , Just _ ) -> startTls + (PreferTls , Nothing ) -> return () + (PreferPlain , Just True) -> startTls + (PreferPlain , _ ) -> return () + (RefuseTls , Just True) -> throwError XmppOtherFailure + (RefuseTls , _ ) -> return () + where + startTls = do + params <- gets $ tlsParams . streamConfiguration + lift $ pushElement starttlsE + answer <- lift $ pullElement + case answer of + 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" _ _) -> do + liftIO $ errorM "Pontarius.XMPP" "startTls: TLS initiation failed." + return . Left $ XmppOtherFailure + hand <- gets streamHandle + (raw, _snk, psh, read, ctx) <- lift $ tlsinit params (mkBackend hand) + let newHand = StreamHandle { streamSend = catchPush . psh + , streamReceive = read + , streamFlush = contextFlush ctx + , streamClose = bye ctx >> streamClose hand + } + lift $ modify ( \x -> x {streamHandle = newHand}) + either (lift . Ex.throwIO) return =<< lift restartStream + modify (\s -> s{streamConnectionState = Secured}) + return () + +client params gen backend = do + contextNew backend params gen + +defaultParams = defaultParamsClient + +tlsinit :: (MonadIO m, MonadIO m1) => + TLSParams + -> Backend + -> m ( Source m1 BS.ByteString + , Sink BS.ByteString m1 () + , BS.ByteString -> IO () + , Int -> m1 BS.ByteString + , Context + ) +tlsinit tlsParams backend = do + liftIO $ debugM "Pontarius.Xmpp.TLS" "TLS with debug mode enabled." + gen <- liftIO $ getSystemRandomGen -- TODO: Find better random source? + con <- client tlsParams gen backend + handshake con + let src = forever $ do + dt <- liftIO $ recvData con + liftIO $ debugM "Pontarius.Xmpp.TLS" ("in :" ++ BSC8.unpack dt) + yield dt + let snk = do + d <- await + case d of + Nothing -> return () + Just x -> do + sendData con (BL.fromChunks [x]) + liftIO $ debugM "Pontarius.Xmpp.TLS" + ("out :" ++ BSC8.unpack x) + snk + read <- liftIO $ mkReadBuffer (recvData con) + return ( src + , snk + , \s -> do + liftIO $ debugM "Pontarius.Xmpp.TLS" ("out :" ++ BSC8.unpack s) + sendData con $ BL.fromChunks [s] + , liftIO . read + , con + ) + +mkReadBuffer :: IO BS.ByteString -> IO (Int -> IO BS.ByteString) +mkReadBuffer read = do + buffer <- newIORef BS.empty + let read' n = do + nc <- readIORef buffer + bs <- if BS.null nc then read + else return nc + let (result, rest) = BS.splitAt n bs + writeIORef buffer rest + return result + return read' diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -22,61 +22,89 @@ , PresenceType(..) , SaslError(..) , SaslFailure(..) - , ServerFeatures(..) + , StreamFeatures(..) , Stanza(..) , StanzaError(..) , StanzaErrorCondition(..) , StanzaErrorType(..) - , StanzaId(..) - , StreamError(..) + , StanzaID(..) + , XmppFailure(..) , StreamErrorCondition(..) , Version(..) - , XmppConMonad - , XmppConnection(..) - , XmppConnectionState(..) - , XmppT(..) - , XmppStreamError(..) + , StreamHandle(..) + , Stream(..) + , StreamState(..) + , ConnectionState(..) + , StreamErrorInfo(..) + , StreamConfiguration(..) , langTag - , module Network.Xmpp.Jid + , Jid(..) + , isBare + , isFull + , jidFromText + , jidFromTexts + , StreamEnd(..) + , InvalidXmppXml(..) + , Hostname(..) + , hostname + , SessionConfiguration(..) + , TlsBehaviour(..) ) where -import Control.Applicative ((<$>), many) +import Control.Concurrent.STM import Control.Exception +import Control.Monad.Error import Control.Monad.IO.Class import Control.Monad.State.Strict -import Control.Monad.Error import qualified Data.Attoparsec.Text as AP import qualified Data.ByteString as BS import Data.Conduit -import Data.String(IsString(..)) +import Data.IORef import Data.Maybe (fromJust, fromMaybe, maybeToList) +import Data.String(IsString(..)) import Data.Text (Text) import qualified Data.Text as Text import Data.Typeable(Typeable) import Data.XML.Types -import qualified Network as N +import Network.TLS hiding (Version) +import Network.TLS.Extra -import Network.Xmpp.Jid +import qualified Network as N import System.IO +import Control.Applicative ((<$>), (<|>), many) +import Control.Monad(guard) + +import qualified Data.Set as Set +import Data.String (IsString(..)) +import qualified Text.NamePrep as SP +import qualified Text.StringPrep as SP + +import Network +import Network.DNS +import Network.Socket + +import Data.Default +import Data.IP + -- | -- Wraps a string of random characters that, when using an appropriate --- @IDGenerator@, is guaranteed to be unique for the Xmpp session. +-- @IdGenerator@, is guaranteed to be unique for the Xmpp session. -data StanzaId = SI !Text deriving (Eq, Ord) +data StanzaID = StanzaID !Text deriving (Eq, Ord) -instance Show StanzaId where - show (SI s) = Text.unpack s +instance Show StanzaID where + show (StanzaID s) = Text.unpack s -instance Read StanzaId where - readsPrec _ x = [(SI $ Text.pack x, "")] +instance Read StanzaID where + readsPrec _ x = [(StanzaID $ Text.pack x, "")] -instance IsString StanzaId where - fromString = SI . Text.pack +instance IsString StanzaID where + fromString = StanzaID . Text.pack -- | The Xmpp communication primities (Message, Presence and Info/Query) are -- called stanzas. @@ -91,7 +119,7 @@ -- | A "request" Info/Query (IQ) stanza is one with either "get" or "set" as -- type. It always contains an xml payload. -data IQRequest = IQRequest { iqRequestID :: !StanzaId +data IQRequest = IQRequest { iqRequestID :: !StanzaID , iqRequestFrom :: !(Maybe Jid) , iqRequestTo :: !(Maybe Jid) , iqRequestLangTag :: !(Maybe LangTag) @@ -119,7 +147,7 @@ deriving Show -- | The (non-error) answer to an IQ request. -data IQResult = IQResult { iqResultID :: !StanzaId +data IQResult = IQResult { iqResultID :: !StanzaID , iqResultFrom :: !(Maybe Jid) , iqResultTo :: !(Maybe Jid) , iqResultLangTag :: !(Maybe LangTag) @@ -127,7 +155,7 @@ } deriving Show -- | The answer to an IQ request that generated an error. -data IQError = IQError { iqErrorID :: !StanzaId +data IQError = IQError { iqErrorID :: !StanzaID , iqErrorFrom :: !(Maybe Jid) , iqErrorTo :: !(Maybe Jid) , iqErrorLangTag :: !(Maybe LangTag) @@ -136,7 +164,7 @@ } deriving Show -- | The message stanza. Used for /push/ type communication. -data Message = Message { messageID :: !(Maybe StanzaId) +data Message = Message { messageID :: !(Maybe StanzaID) , messageFrom :: !(Maybe Jid) , messageTo :: !(Maybe Jid) , messageLangTag :: !(Maybe LangTag) @@ -145,7 +173,7 @@ } deriving Show -- | An error stanza generated in response to a 'Message'. -data MessageError = MessageError { messageErrorID :: !(Maybe StanzaId) +data MessageError = MessageError { messageErrorID :: !(Maybe StanzaID) , messageErrorFrom :: !(Maybe Jid) , messageErrorTo :: !(Maybe Jid) , messageErrorLangTag :: !(Maybe LangTag) @@ -205,7 +233,7 @@ readsPrec _ _ = [(Normal, "")] -- | The presence stanza. Used for communicating status updates. -data Presence = Presence { presenceID :: !(Maybe StanzaId) +data Presence = Presence { presenceID :: !(Maybe StanzaID) , presenceFrom :: !(Maybe Jid) , presenceTo :: !(Maybe Jid) , presenceLangTag :: !(Maybe LangTag) @@ -215,7 +243,7 @@ -- | An error stanza generated in response to a 'Presence'. -data PresenceError = PresenceError { presenceErrorID :: !(Maybe StanzaId) +data PresenceError = PresenceError { presenceErrorID :: !(Maybe StanzaID) , presenceErrorFrom :: !(Maybe Jid) , presenceErrorTo :: !(Maybe Jid) , presenceErrorLangTag :: !(Maybe LangTag) @@ -613,28 +641,53 @@ 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. This error is fatal, and closes the XMPP stream. +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. + | TcpConnectionFailure -- ^ All attempts to TCP + -- connect to the server + -- failed. + | XmppIllegalTcpDetails -- ^ The TCP details provided did not + -- validate. + | TlsError TLSError -- ^ An error occurred in the + -- TLS layer + | TlsNoServerSupport -- ^ The server does not support + -- the use of TLS + | XmppNoStream -- ^ An action that required an active + -- stream were performed when the + -- 'StreamState' was 'Closed' + | XmppAuthFailure -- ^ Authentication with the server failed + -- unrecoverably + | TlsStreamSecured -- ^ Connection already secured + | XmppOtherFailure -- ^ Undefined condition. More + -- information should be available in + -- the log. + | XmppIOException IOException -- ^ An 'IOException' + -- occurred deriving (Show, Eq, Typeable) -instance Exception StreamError -instance Error StreamError where noMsg = StreamConnectionError +instance Exception XmppFailure +instance Error XmppFailure where noMsg = XmppOtherFailure -- ============================================================================= -- XML TYPES @@ -728,56 +781,355 @@ tagChars :: [Char] tagChars = ['a'..'z'] ++ ['A'..'Z'] -data ServerFeatures = SF - { stls :: !(Maybe Bool) - , saslMechanisms :: ![Text.Text] - , other :: ![Element] +data StreamFeatures = StreamFeatures + { streamTls :: !(Maybe Bool) + , streamSaslMechanisms :: ![Text.Text] + , streamOtherFeatures :: ![Element] -- TODO: All feature elements instead? } deriving Show -data XmppConnectionState - = XmppConnectionClosed -- ^ No connection at this point. - | XmppConnectionPlain -- ^ Connection established, but not secured. - | XmppConnectionSecured -- ^ Connection established and secured via TLS. +-- | Signals the state of the stream connection. +data ConnectionState + = Closed -- ^ No stream has been established + | Plain -- ^ Stream established, but not secured via TLS + | Secured -- ^ Stream established and secured via TLS deriving (Show, Eq, Typeable) -data XmppConnection = XmppConnection - { sConSrc :: !(Source IO Event) - , sRawSrc :: !(Source IO BS.ByteString) - , sConPushBS :: !(BS.ByteString -> IO Bool) - , sConHandle :: !(Maybe Handle) - , sFeatures :: !ServerFeatures - , sConnectionState :: !XmppConnectionState - , sHostname :: !(Maybe Text) - , sJid :: !(Maybe Jid) - , sCloseConnection :: !(IO ()) - , sPreferredLang :: !(Maybe LangTag) - , 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. - } +-- | Defines operations for sending, receiving, flushing, and closing on a +-- stream. +data StreamHandle = + StreamHandle { streamSend :: BS.ByteString -> IO Bool + , streamReceive :: 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). (TODO: Clarify) + , streamFlush :: IO () + , streamClose :: IO () + } --- | --- The Xmpp monad transformer. Contains internal state in order to --- work with Pontarius. Pontarius clients needs to operate in this --- context. -newtype XmppT m a = XmppT { runXmppT :: StateT XmppConnection m a } deriving (Monad, MonadIO) +data StreamState = StreamState + { -- | State of the stream - 'Closed', 'Plain', or 'Secured' + streamConnectionState :: !ConnectionState -- ^ State of connection + -- | Functions to send, receive, flush, and close on the stream + , streamHandle :: StreamHandle + -- | Event conduit source, and its associated finalizer + , streamEventSource :: ResumableSource IO Event + -- | Stream features advertised by the server + , streamFeatures :: !StreamFeatures -- TODO: Maybe? + -- | The hostname or IP specified for the connection + , streamAddress :: !(Maybe Text) + -- | The hostname specified in the server's stream element's + -- `from' attribute + , streamFrom :: !(Maybe Jid) + -- | The identifier specified in the server's stream element's + -- `id' attribute + , streamId :: !(Maybe Text) + -- | The language tag value specified in the server's stream + -- element's `langtag' attribute; will be a `Just' value once + -- connected to the server + -- TODO: Verify + , streamLang :: !(Maybe LangTag) + -- | Our JID as assigned by the server + , streamJid :: !(Maybe Jid) + -- | Configuration settings for the stream + , streamConfiguration :: StreamConfiguration + } --- | Low-level and single-threaded Xmpp monad. See @Xmpp@ for a concurrent --- implementation. -type XmppConMonad a = StateT XmppConnection IO a +newtype Stream = Stream { unStream :: TMVar StreamState } --- Make XmppT derive the Monad and MonadIO instances. -deriving instance (Monad m, MonadIO m) => MonadState (XmppConnection) (XmppT m) +--------------- +-- JID +--------------- + +-- | A JID is XMPP\'s native format for addressing entities in the network. It +-- is somewhat similar to an e-mail address but contains three parts instead of +-- two. +data Jid = Jid { -- | The @localpart@ of a JID is an optional identifier placed + -- before the domainpart and separated from the latter by a + -- \'\@\' character. Typically a localpart uniquely identifies + -- the entity requesting and using network access provided by a + -- server (i.e., a local account), although it can also + -- represent other kinds of entities (e.g., a chat room + -- associated with a multi-user chat service). The entity + -- represented by an XMPP localpart is addressed within the + -- context of a specific domain (i.e., + -- @localpart\@domainpart@). + localpart :: !(Maybe Text) + + -- | The domainpart typically identifies the /home/ server to + -- which clients connect for XML routing and data management + -- functionality. However, it is not necessary for an XMPP + -- domainpart to identify an entity that provides core XMPP + -- server functionality (e.g., a domainpart can identify an + -- entity such as a multi-user chat service, a + -- publish-subscribe service, or a user directory). + , domainpart :: !Text + + -- | The resourcepart of a JID is an optional identifier placed + -- after the domainpart and separated from the latter by the + -- \'\/\' character. A resourcepart can modify either a + -- @localpart\@domainpart@ address or a mere @domainpart@ + -- address. Typically a resourcepart uniquely identifies a + -- specific connection (e.g., a device or location) or object + -- (e.g., an occupant in a multi-user chat room) belonging to + -- the entity associated with an XMPP localpart at a domain + -- (i.e., @localpart\@domainpart/resourcepart@). + , resourcepart :: !(Maybe Text) + } deriving Eq + +instance Show Jid where + show (Jid nd dmn res) = + maybe "" ((++ "@") . Text.unpack) nd ++ Text.unpack dmn ++ + maybe "" (('/' :) . Text.unpack) res + +instance Read Jid where + readsPrec _ x = case jidFromText (Text.pack x) of + Nothing -> [] + Just j -> [(j,"")] + +instance IsString Jid where + fromString = fromJust . jidFromText . Text.pack + +-- | Converts a Text to a JID. +jidFromText :: Text -> Maybe Jid +jidFromText t = do + (l, d, r) <- eitherToMaybe $ AP.parseOnly jidParts t + jidFromTexts l d r + where + eitherToMaybe = either (const Nothing) Just + +-- | Converts localpart, domainpart, and resourcepart strings to a JID. Runs the +-- appropriate stringprep profiles and validates the parts. +jidFromTexts :: Maybe Text -> Text -> Maybe Text -> Maybe Jid +jidFromTexts l d r = do + localPart <- case l of + Nothing -> return Nothing + Just l'-> do + l'' <- SP.runStringPrep nodeprepProfile l' + guard $ validPartLength l'' + let prohibMap = Set.fromList nodeprepExtraProhibitedCharacters + guard $ Text.all (`Set.notMember` prohibMap) l'' + return $ Just l'' + domainPart <- SP.runStringPrep (SP.namePrepProfile False) d + guard $ validDomainPart domainPart + resourcePart <- case r of + Nothing -> return Nothing + Just r' -> do + r'' <- SP.runStringPrep resourceprepProfile r' + guard $ validPartLength r'' + return $ Just r'' + return $ Jid localPart domainPart resourcePart + where + validDomainPart :: Text -> Bool + validDomainPart _s = True -- TODO + + validPartLength :: Text -> Bool + validPartLength p = Text.length p > 0 && Text.length p < 1024 + +-- | Returns 'True' if the JID is /bare/, and 'False' otherwise. +isBare :: Jid -> Bool +isBare j | resourcepart j == Nothing = True + | otherwise = False + +-- | Returns 'True' if the JID is /full/, and 'False' otherwise. +isFull :: Jid -> Bool +isFull = not . isBare + +-- Parses an JID string and returns its three parts. It performs no validation +-- or transformations. +jidParts :: AP.Parser (Maybe Text, Text, Maybe Text) +jidParts = do + -- Read until we reach an '@', a '/', or EOF. + a <- AP.takeWhile1 (AP.notInClass ['@', '/']) + -- Case 1: We found an '@', and thus the localpart. At least the domainpart + -- is remaining. Read the '@' and until a '/' or EOF. + do + b <- domainPartP + -- Case 1A: We found a '/' and thus have all the JID parts. Read the '/' + -- and until EOF. + do + c <- resourcePartP -- Parse resourcepart + return (Just a, b, Just c) + -- Case 1B: We have reached EOF; the JID is in the form + -- localpart@domainpart. + <|> do + AP.endOfInput + return (Just a, b, Nothing) + -- Case 2: We found a '/'; the JID is in the form + -- domainpart/resourcepart. + <|> do + b <- resourcePartP + AP.endOfInput + return (Nothing, a, Just b) + -- Case 3: We have reached EOF; we have an JID consisting of only a + -- domainpart. + <|> do + AP.endOfInput + return (Nothing, a, Nothing) + where + -- Read an '@' and everything until a '/'. + domainPartP :: AP.Parser Text + domainPartP = do + _ <- AP.char '@' + AP.takeWhile1 (/= '/') + -- Read everything until a '/'. + resourcePartP :: AP.Parser Text + resourcePartP = do + _ <- AP.char '/' + AP.takeText + +-- The `nodeprep' StringPrep profile. +nodeprepProfile :: SP.StringPrepProfile +nodeprepProfile = SP.Profile { SP.maps = [SP.b1, SP.b2] + , SP.shouldNormalize = True + , SP.prohibited = [SP.a1 + , SP.c11 + , SP.c12 + , SP.c21 + , SP.c22 + , SP.c3 + , SP.c4 + , SP.c5 + , SP.c6 + , SP.c7 + , SP.c8 + , SP.c9 + ] + , SP.shouldCheckBidi = True + } + +-- These characters needs to be checked for after normalization. +nodeprepExtraProhibitedCharacters :: [Char] +nodeprepExtraProhibitedCharacters = ['\x22', '\x26', '\x27', '\x2F', '\x3A', + '\x3C', '\x3E', '\x40'] + +-- The `resourceprep' StringPrep profile. +resourceprepProfile :: SP.StringPrepProfile +resourceprepProfile = SP.Profile { SP.maps = [SP.b1] + , SP.shouldNormalize = True + , SP.prohibited = [ SP.a1 + , SP.c12 + , SP.c21 + , SP.c22 + , SP.c3 + , SP.c4 + , SP.c5 + , SP.c6 + , SP.c7 + , SP.c8 + , SP.c9 + ] + , SP.shouldCheckBidi = True + } + +data StreamEnd = StreamEnd deriving (Typeable, Show) +instance Exception StreamEnd + +data InvalidXmppXml = InvalidXmppXml String deriving (Show, Typeable) + +instance Exception InvalidXmppXml + +-- | Configuration settings related to the stream. +data StreamConfiguration = + StreamConfiguration { -- | Default language when no language tag is set + preferredLang :: !(Maybe LangTag) + -- | JID to include in the stream element's `to' + -- attribute when the connection is secured; if the + -- boolean is set to 'True', then the JID is also + -- included when the 'ConnectionState' is 'Plain' + , toJid :: !(Maybe (Jid, Bool)) + -- | By settings this field, clients can specify the + -- network interface to use, override the SRV lookup + -- of the realm, as well as specify the use of a + -- non-standard port when connecting by IP or + -- connecting to a domain without SRV records. + , socketDetails :: Maybe (Socket, SockAddr) + -- | DNS resolver configuration + , resolvConf :: ResolvConf + -- | Whether or not to perform the legacy + -- session bind as defined in the (outdated) + -- RFC 3921 specification + , establishSession :: Bool + -- | How the client should behave in regards to TLS. + , tlsBehaviour :: TlsBehaviour + -- | Settings to be used for TLS negotitation + , tlsParams :: TLSParams + } + + +instance Default StreamConfiguration where + def = StreamConfiguration { preferredLang = Nothing + , toJid = Nothing + , socketDetails = Nothing + , resolvConf = defaultResolvConf + , establishSession = True + , tlsBehaviour = PreferTls + , tlsParams = defaultParamsClient { pConnectVersion = TLS12 + , pAllowedVersions = [TLS12] + , pCiphers = ciphersuite_strong + } + } + +data Hostname = Hostname Text deriving (Eq, Show) + +instance Read Hostname where + readsPrec _ x = case hostname (Text.pack x) of + Nothing -> [] + Just h -> [(h,"")] + +instance IsString Hostname where + fromString = fromJust . hostname . Text.pack + +-- | Validates the hostname string in accordance with RFC 1123. +hostname :: Text -> Maybe Hostname +hostname t = do + eitherToMaybeHostname $ AP.parseOnly hostnameP t + where + eitherToMaybeHostname = either (const Nothing) (Just . Hostname) + +-- Validation of RFC 1123 hostnames. +hostnameP :: AP.Parser Text +hostnameP = do + -- Hostnames may not begin with a hyphen. + h <- AP.satisfy $ AP.inClass $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] + t <- AP.takeWhile $ AP.inClass $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ ['-'] + let label = Text.concat [Text.pack [h], t] + if Text.length label > 63 + then fail "Label too long." + else do + AP.endOfInput + return label + <|> do + _ <- AP.satisfy (== '.') + r <- hostnameP + if (Text.length label) + 1 + (Text.length r) > 255 + then fail "Hostname too long." + else return $ Text.concat [label, Text.pack ".", r] + +-- | Configuration for the @Session@ object. +data SessionConfiguration = SessionConfiguration + { -- | Configuration for the @Stream@ object. + sessionStreamConfiguration :: StreamConfiguration + -- | Handler to be run when the session ends (for whatever reason). + , sessionClosedHandler :: XmppFailure -> IO () + -- | Function to generate the stream of stanza identifiers. + , sessionStanzaIDs :: IO StanzaID + } + +instance Default SessionConfiguration where + def = SessionConfiguration { sessionStreamConfiguration = def + , sessionClosedHandler = \_ -> return () + , sessionStanzaIDs = do + idRef <- newTVarIO 1 + atomically $ do + curId <- readTVar idRef + writeTVar idRef (curId + 1 :: Integer) + return . read. show $ curId + } + +-- | How the client should behave in regards to TLS. +data TlsBehaviour = RequireTls -- ^ Require the use of TLS; disconnect if it's + -- not offered. + | PreferTls -- ^ Negotitate TLS if it's available. + | PreferPlain -- ^ Negotitate TLS only if the server requires + -- it + | RefuseTls -- ^ Never secure the stream with TLS. diff --git a/source/Network/Xmpp/Utilities.hs b/source/Network/Xmpp/Utilities.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Utilities.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_HADDOCK hide #-} + +module Network.Xmpp.Utilities (presTo, message, answerMessage, openElementToEvents, renderOpenElement, renderElement) where + +import Network.Xmpp.Types + +import Control.Monad.STM +import Control.Concurrent.STM.TVar +import Prelude + +import Data.XML.Types + +import qualified Data.Attoparsec.Text as AP +import qualified Data.Text as Text + +import qualified Data.ByteString as BS +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import System.IO.Unsafe(unsafePerformIO) +import Data.Conduit.List as CL +-- import Data.Typeable +import Control.Applicative ((<$>)) +import Control.Exception +import Control.Monad.Trans.Class + +import Data.Conduit as C +import Data.XML.Types + +import qualified Text.XML.Stream.Render as TXSR +import Text.XML.Unresolved as TXU + + +-- TODO: Not used, and should probably be removed. +-- | Creates a new @IdGenerator@. Internally, it will maintain an infinite list +-- of IDs ('[\'a\', \'b\', \'c\'...]'). The argument is a prefix to prepend the +-- IDs with. Calling the function will extract an ID and update the generator's +-- internal state so that the same ID will not be generated again. +idGenerator :: Text.Text -> IO IdGenerator +idGenerator prefix = atomically $ do + tvar <- newTVar $ ids prefix + return $ IdGenerator $ next tvar + where + -- Transactionally extract the next ID from the infinite list of IDs. + next :: TVar [Text.Text] -> IO Text.Text + next tvar = atomically $ do + list <- readTVar tvar + case list of + [] -> error "empty list in Utilities.hs" + (x:xs) -> do + writeTVar tvar xs + return x + + -- Generates an infinite and predictable list of IDs, all beginning with the + -- provided prefix. Adds the prefix to all combinations of IDs (ids'). + ids :: Text.Text -> [Text.Text] + ids p = Prelude.map (\ id -> Text.append p id) ids' + where + -- Generate all combinations of IDs, with increasing length. + ids' :: [Text.Text] + ids' = Prelude.map Text.pack $ Prelude.concatMap ids'' [1..] + -- Generates all combinations of IDs with the given length. + ids'' :: Integer -> [String] + ids'' 0 = [""] + ids'' l = [x:xs | x <- repertoire, xs <- ids'' (l - 1)] + -- Characters allowed in IDs. + repertoire :: String + repertoire = ['a'..'z'] + +-- Constructs a "Version" based on the major and minor version numbers. +versionFromNumbers :: Integer -> Integer -> Version +versionFromNumbers major minor = Version major minor + +-- | Add a recipient to a presence notification. +presTo :: Presence -> Jid -> Presence +presTo pres to = pres{presenceTo = Just to} + +-- | An empty message. +message :: Message +message = Message { messageID = Nothing + , messageFrom = Nothing + , messageTo = Nothing + , messageLangTag = Nothing + , messageType = Normal + , messagePayload = [] + } + +-- | Produce an answer message with the given payload, switching the "from" and +-- "to" attributes in the original message. Produces a 'Nothing' value of the +-- provided message message has no from attribute. +answerMessage :: Message -> [Element] -> Maybe Message +answerMessage Message{messageFrom = Just frm, ..} payload = + Just Message{ messageFrom = messageTo + , messageID = Nothing + , messageTo = Just frm + , messagePayload = payload + , .. + } +answerMessage _ _ = Nothing + +openElementToEvents :: Element -> [Event] +openElementToEvents (Element name as ns) = EventBeginElement name as : goN ns [] + where + goE (Element name' as' ns') = + (EventBeginElement name' as' :) + . goN ns' + . (EventEndElement name' :) + goN [] = id + goN [x] = goN' x + goN (x:xs) = goN' x . goN xs + goN' (NodeElement e) = goE e + goN' (NodeInstruction i) = (EventInstruction i :) + goN' (NodeContent c) = (EventContent c :) + goN' (NodeComment t) = (EventComment t :) + +renderOpenElement :: Element -> BS.ByteString +renderOpenElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO + $ CL.sourceList (openElementToEvents e) $$ TXSR.renderText def =$ CL.consume + +renderElement :: Element -> BS.ByteString +renderElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO + $ CL.sourceList (elementToEvents e) $$ TXSR.renderText def =$ CL.consume + where + elementToEvents :: Element -> [Event] + elementToEvents e@(Element name _ _) = openElementToEvents e ++ [EventEndElement name] diff --git a/source/Network/Xmpp/Xep/ServiceDiscovery.hs b/source/Network/Xmpp/Xep/ServiceDiscovery.hs deleted file mode 100644 --- a/source/Network/Xmpp/Xep/ServiceDiscovery.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - --- XEP 0030: Service Discovery (disco) - -module Network.Xmpp.Xep.ServiceDiscovery - ( QueryInfoResult(..) - , Identity(..) - , queryInfo - , xmppQueryInfo - , Item - , queryItems - , DiscoError(..) - ) - where - -import Control.Applicative((<$>)) -import Control.Monad.IO.Class -import Control.Monad.Error - -import qualified Data.Text as Text -import Data.XML.Pickle -import Data.XML.Types - -import Network.Xmpp -import Network.Xmpp.Monad -import Network.Xmpp.Pickle -import Network.Xmpp.Types -import Network.Xmpp.Concurrent - -data DiscoError = DiscoNoQueryElement - | DiscoIQError IQError - | DiscoTimeout - | DiscoXMLError Element UnpickleError - - deriving (Show) - -instance Error DiscoError - -data Identity = Ident { iCategory :: Text.Text - , iName :: Maybe Text.Text - , iType :: Text.Text - , iLang :: Maybe LangTag - } deriving Show - -data QueryInfoResult = QIR { qiNode :: Maybe Text.Text - , qiIdentities :: [Identity] - , qiFeatures :: [Text.Text] - } deriving Show - -discoInfoNS :: Text.Text -discoInfoNS = "http://jabber.org/protocol/disco#info" - -infoN :: Text.Text -> Name -infoN name = (Name name (Just discoInfoNS) Nothing) - -xpIdentities = xpWrap (map $(\(cat, n, tp, lang) -> Ident cat n tp lang) . fst) - (map $ \(Ident cat n tp lang) -> ((cat, n, tp, lang),())) $ - xpElems (infoN "identity") - (xp4Tuple - (xpAttr "category" xpText) - (xpAttrImplied "name" xpText) - (xpAttr "type" xpText) - xpLangTag - ) - xpUnit - -xpFeatures :: PU [Node] [Text.Text] -xpFeatures = xpWrap (map fst) (map (,())) $ - xpElems (infoN "feature") - (xpAttr "var" xpText) - xpUnit - -xpQueryInfo = xpWrap (\(nd, (feats, ids)) -> QIR nd ids feats) - (\(QIR nd ids feats) -> (nd, (feats, ids))) $ - xpElem (infoN "query") - (xpAttrImplied "node" xpText) - (xp2Tuple - xpFeatures - xpIdentities - ) - --- | Query an entity for it's identity and features -queryInfo :: Jid -- ^ Entity to query - -> Maybe Text.Text -- ^ Node - -> Session - -> IO (Either DiscoError QueryInfoResult) -queryInfo to node session = do - res <- sendIQ' (Just to) Get Nothing queryBody session - return $ case res of - IQResponseError e -> Left $ DiscoIQError 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 - Right r -> Right r - where - queryBody = pickleElem xpQueryInfo (QIR node [] []) - - -xmppQueryInfo :: Maybe Jid - -> Maybe Text.Text - -> XmppConMonad (Either DiscoError QueryInfoResult) -xmppQueryInfo to node = do - res <- xmppSendIQ' "info" to Get Nothing queryBody - 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 - where - queryBody = pickleElem xpQueryInfo (QIR node [] []) - - --- --- Items --- - -data Item = Item { itemJid :: Jid - , itemName :: Maybe Text.Text - , itemNode :: Maybe Text.Text - } deriving Show - -discoItemsNS :: Text.Text -discoItemsNS = "http://jabber.org/protocol/disco#items" - -itemsN :: Text.Text -> Name -itemsN n = Name n (Just discoItemsNS) Nothing - -xpItem = xpWrap (\(jid, name, node) -> Item jid name node) - (\(Item jid name node) -> (jid, name, node)) $ - xpElemAttrs (itemsN "item") - (xp3Tuple - (xpAttr "jid" xpPrim) - (xpAttrImplied "name" xpText) - (xpAttrImplied "node" xpText)) - - -xpQueryItems = xpElem (itemsN "query") - (xpAttrImplied "node" xpText) - (xpAll xpItem) - --- | Query an entity for Items of a node -queryItems :: Jid -- ^ Entity to query - -> Maybe Text.Text -- ^ Node - -> Session - -> IO (Either DiscoError (Maybe Text.Text, [Item])) -queryItems to node session = do - res <- sendIQ' (Just to) Get Nothing queryBody session - return $ case res of - IQResponseError e -> Left $ DiscoIQError 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 - 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 deleted file mode 100644 --- a/source/Text/XML/Stream/Elements.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -module Text.XML.Stream.Elements where - -import Control.Applicative ((<$>)) -import Control.Exception -import Control.Monad.Trans.Class -import Control.Monad.Trans.Resource as R - -import qualified Data.ByteString as BS -import Data.Conduit as C -import Data.Conduit.List as CL -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Data.Typeable -import Data.XML.Types - -import System.IO.Unsafe(unsafePerformIO) - -import qualified Text.XML.Stream.Render as TXSR -import Text.XML.Unresolved as TXU - -compressNodes :: [Node] -> [Node] -compressNodes [] = [] -compressNodes [x] = [x] -compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) = - compressNodes $ NodeContent (ContentText $ x `Text.append` y) : z -compressNodes (x:xs) = x : compressNodes xs - -streamName :: Name -streamName = - (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) - -data StreamEnd = StreamEnd deriving (Typeable, Show) -instance Exception StreamEnd - -data InvalidXmppXml = InvalidXmppXml String deriving (Show, Typeable) - -instance Exception InvalidXmppXml - -parseElement txt = documentRoot $ TXU.parseText_ TXU.def txt - -elements :: R.MonadThrow m => C.Conduit Event m Element -elements = do - x <- C.await - case x of - Just (EventBeginElement n as) -> do - goE n as >>= C.yield - elements - Just (EventEndElement streamName) -> lift $ R.monadThrow StreamEnd - Nothing -> return () - _ -> lift $ R.monadThrow $ InvalidXmppXml $ "not an element: " ++ show x - where - many' f = - go id - where - go front = do - x <- f - case x of - Left x -> return $ (x, front []) - Right y -> go (front . (:) y) - goE n as = do - (y, ns) <- many' goN - if y == Just (EventEndElement n) - then return $ Element n as $ compressNodes ns - else lift $ R.monadThrow $ InvalidXmppXml $ - "Missing close tag: " ++ show n - goN = do - x <- await - case x of - Just (EventBeginElement n as) -> (Right . NodeElement) <$> goE n as - Just (EventInstruction i) -> return $ Right $ NodeInstruction i - Just (EventContent c) -> return $ Right $ NodeContent c - Just (EventComment t) -> return $ Right $ NodeComment t - Just (EventCDATA t) -> return $ Right $ NodeContent $ ContentText t - _ -> return $ Left x - - -openElementToEvents :: Element -> [Event] -openElementToEvents (Element name as ns) = EventBeginElement name as : goN ns [] - where - goE (Element name' as' ns') = - (EventBeginElement name' as' :) - . goN ns' - . (EventEndElement name' :) - goN [] = id - goN [x] = goN' x - goN (x:xs) = goN' x . goN xs - goN' (NodeElement e) = goE e - goN' (NodeInstruction i) = (EventInstruction i :) - goN' (NodeContent c) = (EventContent c :) - goN' (NodeComment t) = (EventComment t :) - -elementToEvents :: Element -> [Event] -elementToEvents e@(Element name _ _) = openElementToEvents e ++ [EventEndElement name] - - -renderOpenElement :: Element -> BS.ByteString -renderOpenElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO - $ CL.sourceList (openElementToEvents e) $$ TXSR.renderText def =$ CL.consume - -renderElement :: Element -> BS.ByteString -renderElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO - $ CL.sourceList (elementToEvents e) $$ TXSR.renderText def =$ CL.consume - -ppElement :: Element -> String -ppElement = Text.unpack . Text.decodeUtf8 . renderElement