pontarius-xmpp 0.1.0.2 → 0.2.0.0

raw patch · 48 files changed

+2499/−2321 lines, 48 filesdep +crypto-random-apidep +dnsdep +hsloggerdep ~conduitdep ~tlsdep ~xml-picklersPVP ok

version bump matches the API change (PVP)

Dependencies added: crypto-random-api, dns, hslogger, iproute

Dependency ranges changed: conduit, tls, xml-picklers

API changes (from Hackage documentation)

Files

• LICENSE +0/−15
• LICENSE.md +16/−0
• README.md +81/−0
• examples/echoclient/LICENSE.md +2/−0
• examples/echoclient/Main.hs +33/−0
• examples/echoclient/README.md +6/−0
• examples/echoclient/Setup.hs +2/−0
• examples/echoclient/echoclient.cabal +17/−0
• pontarius-xmpp.cabal +62/−75
• source/Data/Conduit/BufferedSource.hs +0/−34
• source/Data/Conduit/TLS.hs +0/−62
• source/Network/Xmpp.hs +50/−135
• source/Network/Xmpp/Bind.hs +0/−49
• source/Network/Xmpp/Concurrent.hs +140/−3
• source/Network/Xmpp/Concurrent/Basic.hs +16/−0
• source/Network/Xmpp/Concurrent/IQ.hs +36/−10
• source/Network/Xmpp/Concurrent/Message.hs +59/−0
• source/Network/Xmpp/Concurrent/Monad.hs +53/−204
• source/Network/Xmpp/Concurrent/Presence.hs +32/−0
• source/Network/Xmpp/Concurrent/Threads.hs +63/−177
• source/Network/Xmpp/Concurrent/Types.hs +27/−34
• source/Network/Xmpp/Errors.hs +0/−49
• source/Network/Xmpp/IM.hs +0/−7
• source/Network/Xmpp/IM/Message.hs +0/−121
• source/Network/Xmpp/IM/Presence.hs +0/−74
• source/Network/Xmpp/Internal.hs +45/−0
• source/Network/Xmpp/Jid.hs +0/−205
• source/Network/Xmpp/Marshal.hs +81/−16
• source/Network/Xmpp/Message.hs +0/−34
• source/Network/Xmpp/Monad.hs +0/−238
• source/Network/Xmpp/Pickle.hs +0/−76
• source/Network/Xmpp/Presence.hs +0/−10
• source/Network/Xmpp/Sasl.hs +156/−23
• source/Network/Xmpp/Sasl/Common.hs +40/−29
• source/Network/Xmpp/Sasl/Mechanisms.hs +2/−1
• source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +24/−23
• source/Network/Xmpp/Sasl/Mechanisms/Plain.hs +23/−11
• source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +18/−8
• source/Network/Xmpp/Sasl/StringPrep.hs +1/−0
• source/Network/Xmpp/Sasl/Types.hs +21/−20
• source/Network/Xmpp/Session.hs +0/−43
• source/Network/Xmpp/Stream.hs +686/−101
• source/Network/Xmpp/TLS.hs +0/−72
• source/Network/Xmpp/Tls.hs +137/−0
• source/Network/Xmpp/Types.hs +443/−91
• source/Network/Xmpp/Utilities.hs +127/−0
• source/Network/Xmpp/Xep/ServiceDiscovery.hs +0/−163
• source/Text/XML/Stream/Elements.hs +0/−108

@@ -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 <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.

@@ -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.

@@ -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 <code>Session</code> object can be acquired by calling+<code>session</code>. 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+<code>Data.Text</code> 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).+<code>session</code> 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 <code>Session</code> object.++The return type of <code>session</code> is <code>IO (Either XmppFailure+Session)</code>. As <code>XmppFailure</code> is an+<code>Control.Monad.Error</code> instance, you can utilize the+<code>ErrorT</code> 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 <code>dupSession</code> and+<code>forkIO</code>.++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.

@@ -0,0 +1,2 @@+The `Main.hs', `Setup.hs', and `echoclient.cabal' files in this directory are in+the public domain.

@@ -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."

@@ -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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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

@@ -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

@@ -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

@@ -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-           )

@@ -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.-  ---  -- <http://xmpp.org/rfcs/rfc6120.html#stanzas-semantics-message>+  -- | 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

@@ -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-               -- "<bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'/>"-               -- element, with a possible "<resource>[JID]</resource>"-               -- 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

@@ -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

@@ -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'}

@@ -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

@@ -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

@@ -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 "</stream:stream>"-    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 ()

@@ -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

@@ -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.

@@ -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 _ = "<Interrupt>"++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 _ = "<Interrupt>"--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.

@@ -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 _ = ""

@@ -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

@@ -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]-    }

@@ -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

@@ -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

@@ -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-                                 }

@@ -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))

@@ -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

@@ -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 "<?xml version='1.0' encoding='UTF-8' ?>"--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 "</stream:stream>" 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 </stream:stream> element from the server is returned.-xmppCloseStreams :: XmppConMonad ([Element], Bool)-xmppCloseStreams = do-    send <- gets sConPushBS-    cc <- gets sCloseConnection-    liftIO $ send "</stream:stream>"-    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 ()

@@ -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

@@ -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}

@@ -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+               -- "<bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'/>"+               -- element, with a possible "<resource>[JID]</resource>"+               -- 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

@@ -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

@@ -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 

@@ -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+    )

@@ -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+    )

@@ -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     )

@@ -1,3 +1,4 @@+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings #-} module Network.Xmpp.Sasl.StringPrep where 

@@ -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)))

@@ -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

@@ -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 "</stream:stream>" 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 "</stream:stream>"+    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) "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"++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)

@@ -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 "<starttls/>, waits for "<proceed/>", 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 ()

@@ -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'

@@ -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.

@@ -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]

@@ -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, [])

@@ -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