pontarius-xmpp 0.2.0.1 → 0.3.0.0

raw patch · 32 files changed

+2412/−1345 lines, 32 filesdep +cryptohash-cryptoapidep +template-haskelldep ~bytestringdep ~conduitdep ~networkPVP ok

version bump matches the API change (PVP)

Dependencies added: cryptohash-cryptoapi, template-haskell

Dependency ranges changed: bytestring, conduit, network, xml-conduit, xml-picklers

API changes (from Hackage documentation)

Files

• LICENSE.md +29/−10
• README.md +47/−10
• examples/echoclient/Main.hs +4/−3
• pontarius-xmpp.cabal +76/−46
• source/Network/Xmpp.hs +42/−9
• source/Network/Xmpp/Concurrent.hs +218/−73
• source/Network/Xmpp/Concurrent/Basic.hs +52/−5
• source/Network/Xmpp/Concurrent/IQ.hs +51/−37
• source/Network/Xmpp/Concurrent/Message.hs +3/−4
• source/Network/Xmpp/Concurrent/Monad.hs +87/−68
• source/Network/Xmpp/Concurrent/Presence.hs +1/−2
• source/Network/Xmpp/Concurrent/Threads.hs +70/−59
• source/Network/Xmpp/Concurrent/Types.hs +52/−16
• source/Network/Xmpp/IM.hs +32/−0
• source/Network/Xmpp/IM/Message.hs +115/−0
• source/Network/Xmpp/IM/Presence.hs +76/−0
• source/Network/Xmpp/IM/Roster.hs +213/−0
• source/Network/Xmpp/IM/Roster/Types.hs +34/−0
• source/Network/Xmpp/Internal.hs +3/−5
• source/Network/Xmpp/Marshal.hs +246/−42
• source/Network/Xmpp/Sasl.hs +31/−71
• source/Network/Xmpp/Sasl/Common.hs +52/−25
• source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +16/−32
• source/Network/Xmpp/Sasl/Mechanisms/Plain.hs +12/−41
• source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +37/−49
• source/Network/Xmpp/Sasl/StringPrep.hs +8/−1
• source/Network/Xmpp/Sasl/Types.hs +0/−20
• source/Network/Xmpp/Stanza.hs +56/−0
• source/Network/Xmpp/Stream.hs +328/−226
• source/Network/Xmpp/Tls.hs +75/−35
• source/Network/Xmpp/Types.hs +291/−368
• source/Network/Xmpp/Utilities.hs +55/−88

@@ -1,16 +1,35 @@ Copyright © 2005-2011 Dmitry Astapov   Copyright © 2005-2011 Pierre Kovalev   Copyright © 2010-2011 Mahdi Abdinejadi  -Copyright © 2010-2012 Jon Kristensen  +Copyright © 2010-2013 Jon Kristensen   Copyright © 2011      IETF Trust  -Copyright © 2012      Philipp Balzarek  +Copyright © 2012-2013 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).+All rights reserved. -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.+Pontarius XMPP is licensed under the three-clause BSD license.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.++* Neither the name of the Pontarius project nor the names of its contributors+  may be used to endorse or promote products derived from this software without+  specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE PONTARIUS PROJECT BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE+GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT+OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -1,9 +1,37 @@ 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).+Pontarius XMPP is an active work in progress to build a Haskell XMPP client+library that implements the capabilities of [RFC 6120+("XMPP CORE")](http://tools.ietf.org/html/rfc6120), [RFC 6121 ("XMPP+IM")](http://tools.ietf.org/html/rfc6121), and [RFC 6122 ("XMPP+ADDR")](http://tools.ietf.org/html/rfc6122). Pontarius XMPP is part of [the+Pontarius project](http://www.pontarius.org/), an effort to produce free and+open source, uncentralized, and privacy-aware software solutions. +While in alpha, Pontarius XMPP works quite well and fulfills most requirements+of the RFCs.++Prerequisites+-------------++Pontarius XMPP requires GHC 7.0, or later.++You will need the ICU Unicode library and it's header files in order to be able+to build Pontarius XMPP. On Debian, you will need to install the *libicu-dev*+package. In Fedora, the package is called *libicu-devel*.++_Note to users of GHC 7.0 and GHC 7.2:_ You will need *cabal-install*, version+*0.14.0* or higher, or the build will fail with an "unrecognized option:+--disable-benchmarks" error. The versions *1.16.0* and higher might not build on+your system; if so, install *0.14.0* with "cabal install cabal-install-0.14.0".++_Note to users of GHC 7.2.1:_ Due to a bug, recent versions of the *binary*+package wont build without running "ghc-pkg trust base".++_Note to users of GHC 7.0.1:_ You will want to configure your Cabal environment+(including *cabal-install*) for version *0.9.2.1* of *bytestring*.+ Getting started --------------- @@ -36,15 +64,16 @@      result <- session                  "example.com"+                  (Just (\_ -> ( [scramSha1 "username" Nothing "password"])+                               , Nothing))                   def-                  (Just ([scramSha1 "username" Nothing "password"], Nothing)) -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 three parameters above are the XMPP server realm, a SASL handler (for+authentication), and the session configuration settings (set to the default+settings). <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@@ -58,8 +87,12 @@  Next, let us set our status to Online. -    sendPresence (Presence Nothing Nothing Nothing Nothing Nothing []) sess+    sendPresence def sess +Here, <code>def</code> refers to the default <code>Presence</code> value, which+is the same as <code>Presence Nothing Nothing Nothing Nothing Available+[]</code>.+ 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: @@ -68,6 +101,10 @@         case answerMessage msg (messagePayload msg) of             Just answer -> sendMessage answer sess             Nothing -> putStrLn "Received message with no sender."++You don't need to worry about escaping your <code>Text</code> values - Pontarius+XMPP (or rather, [xml-picklers](https://github.com/Philonous/xml-picklers)) will+take care of that for you.  Additional XMPP threads can be created using <code>dupSession</code> and <code>forkIO</code>.

@@ -20,14 +20,15 @@     updateGlobalLogger "Pontarius.Xmpp" $ setLevel DEBUG     result <- session                  "example.com"+                  (Just (\_ -> ( [scramSha1 "username" Nothing "password"])+                               , Nothing))                   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+    sendPresence def sess     forever $ do         msg <- getMessage sess         case answerMessage msg (messagePayload msg) of-            Just answer -> sendMessage answer sess+            Just answer -> sendMessage answer sess >> return ()             Nothing -> putStrLn "Received message with no sender."

@@ -1,22 +1,24 @@ Name:          pontarius-xmpp-Version:       0.2.0.1+Version:       0.3.0.0 Cabal-Version: >= 1.6 Build-Type:    Simple-License:       OtherLicense+License:       BSD3 License-File:  LICENSE.md Copyright:     Dmitry Astapov, Pierre Kovalev, Mahdi Abdinejadi, Jon Kristensen,                IETF Trust, Philipp Balzarek-Author:        Jon Kristensen, Mahdi Abdinejadi, Philipp Balzarek+Author:        Jon Kristensen, 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.1.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).+Homepage:      https://github.com/pontarius/pontarius-xmpp/+Bug-Reports:   https://github.com/pontarius/pontarius-xmpp/issues/+Package-URL:   http://www.jonkri.com/releases/pontarius-xmpp-0.3.0.0.tar.gz+Synopsis:      An XMPP client library+Description:   Pontarius XMPP is a work in progress implementation of RFC 6120+               ("XMPP CORE"), RFC 6121 ("XMPP IM"), and RFC 6122 ("XMPP ADDR").+               While in alpha, Pontarius XMPP works quite well and fulfills most+               requirements of the RFCs. Category:      Network-Tested-With:   GHC ==7.0.4, GHC ==7.4.1+Tested-With:   GHC >=7.0.1 && <=7.6.3  Extra-Source-Files: README.md                   , examples/echoclient/echoclient.cabal@@ -25,50 +27,74 @@                   , examples/echoclient/README.md                   , examples/echoclient/Setup.hs +Flag with-th {+  Description: Enable Template Haskell support+  Default:     True+}+ Library   hs-source-dirs: source   Exposed: True-  Build-Depends: attoparsec        >=0.10.0.3-               , base              >4 && <5-               , base64-bytestring >=0.1.0.0-               , binary            >=0.4.1-               , 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-               , 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-               , 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.3++  -- The only different between the below two blocks is that the first one caps+  -- the range for the `bytestring' package, and that the second one includes+  -- `template-haskell' for GHC 7.6.1 and above.++  Build-Depends: attoparsec           >=0.10.0.3+               , base                 >4 && <5+               , base64-bytestring    >=0.1.0.0+               , binary               >=0.4.1+               , conduit              >=1.0.1+               , containers           >=0.4.0.0+               , crypto-api           >=0.9+               , crypto-random-api    >=0.2+               , cryptohash           >=0.6.1+               , cryptohash-cryptoapi >=0.1+               , 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.4.1.0+               , 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.1.0.7+               , xml-picklers         >=0.3.3++  If impl(ghc ==7.0.1) {+    Build-Depends: bytestring         >=0.9.1.9 && <=0.9.2.1+  } Else {+    Build-Depends: bytestring         >=0.9.1.9+  }+  If flag(with-th) && impl(ghc >=7.6.1) {+    Build-Depends: template-haskell >=2.5+  }   Exposed-modules: Network.Xmpp+                 , Network.Xmpp.IM                  , 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.Monad                , Network.Xmpp.Concurrent.Presence                , Network.Xmpp.Concurrent.Threads-               , Network.Xmpp.Concurrent.Monad+               , Network.Xmpp.Concurrent.Types+               , Network.Xmpp.IM.Message+               , Network.Xmpp.IM.Presence+               , Network.Xmpp.IM.Roster+               , Network.Xmpp.IM.Roster.Types                , Network.Xmpp.Marshal                , Network.Xmpp.Sasl                , Network.Xmpp.Sasl.Common@@ -78,17 +104,21 @@                , Network.Xmpp.Sasl.Mechanisms.Scram                , Network.Xmpp.Sasl.StringPrep                , Network.Xmpp.Sasl.Types+               , Network.Xmpp.Stanza                , Network.Xmpp.Stream                , Network.Xmpp.Tls                , Network.Xmpp.Types                , Network.Xmpp.Utilities++  if flag(with-th) && impl(ghc >= 7.6.1)+    CPP-Options: -DWITH_TEMPLATE_HASKELL   GHC-Options: -Wall  Source-Repository head   Type: git-  Location: git://github.com/jonkri/pontarius-xmpp.git+  Location: git://github.com/pontarius/pontarius-xmpp.git  Source-Repository this   Type: git-  Location: git://github.com/jonkri/pontarius-xmpp.git-  Tag: 0.2.0.1+  Location: git://github.com/pontarius/pontarius-xmpp.git+  Tag: 0.3.0.0

@@ -21,14 +21,22 @@ -- For low-level access to Pontarius XMPP, see the "Network.Xmpp.Internal" -- module. -{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}+{-# LANGUAGE CPP, NoMonomorphismRestriction, OverloadedStrings #-}  module Network.Xmpp   ( -- * Session management     Session   , session+  , setConnectionClosedHandler+  , reconnect+  , reconnect'+  , reconnectNow   , StreamConfiguration(..)   , SessionConfiguration(..)+  , ConnectionDetails(..)+  , closeConnection+  , endSession+  , waitForStream     -- TODO: Close session, etc.     -- ** Authentication handlers     -- | The use of 'scramSha1' is /recommended/, but 'digestMd5' might be@@ -40,11 +48,22 @@   -- | 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(..)+  , Jid+#if WITH_TEMPLATE_HASKELL+  , jidQ+#endif   , isBare   , isFull   , jidFromText   , jidFromTexts+  , jidToText+  , jidToTexts+  , toBare+  , localpart+  , domainpart+  , resourcepart+  , parseJid+  , getJid   -- * 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@@ -74,13 +93,16 @@   --    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.-+  , getStanza+  , getStanzaChan+  , newStanzaID   -- ** 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. It is not to be confused with   -- /instant messaging/ which is handled in the 'Network.Xmpp.IM' module   , Message(..)+  , message   , MessageError(..)   , MessageType(..)   -- *** Creating@@ -102,6 +124,12 @@   , PresenceType(..)   , PresenceError(..)   -- *** Creating+  , presence+  , presenceOffline+  , presenceOnline+  , presenceSubscribe+  , presenceSubscribed+  , presenceUnsubscribe   , presTo   -- *** Sending   -- | Sends a presence stanza. In general, the presence stanza should have no@@ -137,16 +165,19 @@   , sendIQ'   , answerIQ   , listenIQChan-  , iqRequestPayload-  , iqResultPayload+  , dropIQChan   -- * Errors   , StanzaError(..)   , StanzaErrorType(..)   , StanzaErrorCondition(..)+  , SaslFailure(..)   -- * Threads   , dupSession   -- * Miscellaneous-  , LangTag(..)+  , LangTag+  , langTagFromText+  , langTagToText+  , parseLangTag   , XmppFailure(..)   , StreamErrorInfo(..)   , StreamErrorCondition(..)@@ -154,12 +185,14 @@                , AuthSaslFailure                , AuthIllegalCredentials                , AuthOtherFailure )+  , SaslHandler+  , ConnectionState(..)+  , connectTls   ) where -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.Stanza import Network.Xmpp.Types+import Network.Xmpp.Tls

@@ -10,51 +10,50 @@   , module Network.Xmpp.Concurrent.IQ   , StanzaHandler   , newSession-  , writeWorker   , session+  , newStanzaID+  , reconnect+  , reconnect'+  , reconnectNow   ) where -import           Control.Applicative((<$>),(<*>))-import           Control.Concurrent+import           Control.Applicative ((<$>))+import           Control.Arrow (second)+import           Control.Concurrent (threadDelay) import           Control.Concurrent.STM+import qualified Control.Exception as Ex import           Control.Monad-import qualified Data.ByteString as BS-import           Data.IORef+import           Control.Monad.Error import qualified Data.Map as Map import           Data.Maybe-import           Data.Maybe (fromMaybe) import           Data.Text as Text import           Data.XML.Types import           Network-import qualified Network.TLS as TLS import           Network.Xmpp.Concurrent.Basic import           Network.Xmpp.Concurrent.IQ import           Network.Xmpp.Concurrent.Message import           Network.Xmpp.Concurrent.Monad import           Network.Xmpp.Concurrent.Presence import           Network.Xmpp.Concurrent.Threads-import           Network.Xmpp.Concurrent.Threads import           Network.Xmpp.Concurrent.Types-import           Network.Xmpp.Marshal+import           Network.Xmpp.IM.Roster+import           Network.Xmpp.IM.Roster.Types import           Network.Xmpp.Sasl-import           Network.Xmpp.Sasl.Mechanisms import           Network.Xmpp.Sasl.Types import           Network.Xmpp.Stream import           Network.Xmpp.Tls import           Network.Xmpp.Types-import           Network.Xmpp.Utilities--import           Control.Monad.Error-import           Data.Default import           System.Log.Logger+import           System.Random (randomRIO)+ import           Control.Monad.State.Strict -runHandlers :: (TChan Stanza) -> [StanzaHandler] -> Stanza -> IO ()+runHandlers :: WriteSemaphore -> [StanzaHandler] -> Stanza -> IO () runHandlers _    []        _   = return ()-runHandlers outC (h:hands) sta = do-    res <- h outC sta+runHandlers  sem (h:hands) sta = do+    res <- h sem sta     case res of-        True -> runHandlers outC hands sta+        True -> runHandlers sem hands sta         False -> return ()  toChan :: TChan Stanza -> StanzaHandler@@ -65,7 +64,7 @@  handleIQ :: TVar IQHandlers          -> StanzaHandler-handleIQ iqHands outC sta = atomically $ do+handleIQ iqHands writeSem sta = do         case sta of             IQRequestS     i -> handleIQRequest iqHands i >> return False             IQResultS      i -> handleIQResponse iqHands (Right i) >> return False@@ -73,21 +72,49 @@             _                -> return True   where     -- If the IQ request has a namespace, send it through the appropriate channel.-    handleIQRequest :: TVar IQHandlers -> IQRequest -> STM ()+    handleIQRequest :: TVar IQHandlers -> IQRequest -> IO ()     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+        out <- atomically $ do+            (byNS, _) <- readTVar handlers+            let iqNS = fromMaybe "" (nameNamespace . elementName+                                                 $ iqRequestPayload iq)+            case Map.lookup (iqRequestType iq, iqNS) byNS of+                Nothing -> return . Just $ serviceUnavailable iq+                Just ch -> do+                  sentRef <- newTMVar False+                  let answerT answer = do+                          let IQRequest iqid from _to lang _tp bd = iq+                              response = case answer of+                                  Left er  -> IQErrorS $ IQError iqid Nothing+                                                                  from lang er+                                                                  (Just bd)+                                  Right res -> IQResultS $ IQResult iqid Nothing+                                                                    from lang res+                          Ex.bracketOnError (atomically $ takeTMVar sentRef)+                                            (atomically .  putTMVar sentRef)+                                            $ \wasSent -> do+                              case wasSent of+                                  True -> do+                                      atomically $ putTMVar sentRef True+                                      return Nothing+                                  False -> do+                                      didSend <- writeStanza writeSem response+                                      case didSend of+                                          True -> do+                                              atomically $ putTMVar sentRef True+                                              return $ Just True+                                          False -> do+                                              atomically $ putTMVar sentRef False+                                              return $ Just False+                  writeTChan ch $ IQRequestTicket answerT iq+                  return Nothing+        maybe (return ()) (void . writeStanza writeSem) out     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+    handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> IO ()+    handleIQResponse handlers iq = atomically $ do         (byNS, byID) <- readTVar handlers         case Map.updateLookupWithKey (\_ _ -> Nothing) (iqID iq) byID of             (Nothing, _) -> return () -- We are not supposed to send an error.@@ -96,68 +123,186 @@                 _ <- tryPutTMVar tmvar answer -- Don't block.                 writeTVar handlers (byNS, byID')       where-        iqID (Left err) = iqErrorID err+        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+newSession :: Stream+           -> SessionConfiguration+           -> HostName+           -> Maybe (ConnectionState -> [SaslHandler] , Maybe Text)+           -> IO (Either XmppFailure Session)+newSession stream config realm mbSasl = runErrorT $ do+    write' <- liftIO $ withStream' (gets $ streamSend . streamHandle) stream+    writeSem <- liftIO $ newTMVarIO write'     stanzaChan <- lift newTChanIO-    iqHandlers <- lift $ newTVarIO (Map.empty, Map.empty)-    eh <- lift $ newTVarIO $ EventHandlers { connectionClosedHandler = sessionClosedHandler config }-    let stanzaHandler = runHandlers outC $ Prelude.concat [ [toChan stanzaChan]-                                                          , extraStanzaHandlers-                                                                config-                                                          , [handleIQ iqHandlers]-                                                          ]-    (kill, wLock, streamState, readerThread) <- ErrorT $ startThreadsWith stanzaHandler eh stream-    writer <- lift $ forkIO $ writeWorker outC wLock+    iqHands  <- lift $ newTVarIO (Map.empty, Map.empty)+    eh <- lift $ newEmptyTMVarIO+    ros <- liftIO . newTVarIO $ Roster Nothing Map.empty+    rew <- lift $ newTVarIO 60+    let rosterH = if (enableRoster config) then handleRoster ros+                                           else \ _ _ -> return True+    let stanzaHandler = runHandlers writeSem+                        $ Prelude.concat [ [ toChan stanzaChan ]+                                         , extraStanzaHandlers+                                           config+                                         , [ handleIQ iqHands+                                           , rosterH+                                           ]+                                         ]+    (kill, wLock, streamState, reader) <- ErrorT $ startThreadsWith writeSem stanzaHandler eh stream     idGen <- liftIO $ sessionStanzaIDs config-    return $ Session { stanzaCh = stanzaChan-                     , outCh = outC-                     , iqHandlers = iqHandlers-                     , writeRef = wLock-                     , readerThread = readerThread+    let sess = Session { stanzaCh = stanzaChan+                     , iqHandlers = iqHands+                     , writeSemaphore = wLock+                     , readerThread = reader                      , idGenerator = idGen                      , streamRef = streamState                      , eventHandlers = eh-                     , stopThreads = kill >> killThread writer+                     , stopThreads = kill                      , conf = config+                     , rosterRef = ros+                     , sRealm = realm+                     , sSaslCredentials = mbSasl+                     , reconnectWait = rew                      }+    liftIO . atomically $ putTMVar eh $ EventHandlers { connectionClosedHandler =+                                                 onConnectionClosed config sess }+    return sess --- 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.+connectStream :: HostName+              -> SessionConfiguration+              -> Maybe (ConnectionState -> [SaslHandler], Maybe Text)+              -> IO (Either XmppFailure Stream)+connectStream realm config mbSasl = do+    Ex.bracketOnError (openStream realm (sessionStreamConfiguration config))+                      (\s -> case s of+                                  Left _ -> return ()+                                  Right stream -> closeStreams stream) +        (\stream' -> case stream' of+              Left e -> return $ Left e+              Right stream -> do+                  res <- runErrorT $ do+                      ErrorT $ tls stream+                      cs <- liftIO $ withStream (gets streamConnectionState)+                                                stream+                      mbAuthError <- case mbSasl of+                          Nothing -> return Nothing+                          Just (handlers, resource) -> ErrorT $ auth (handlers cs)+                                                                resource stream+                      case mbAuthError of+                          Nothing -> return ()+                          Just e  -> throwError $ XmppAuthFailure e+                      return stream+                  case res of+                      Left e -> do+                          debugM "Pontarius.Xmpp" "Closing stream after error"+                          closeStreams stream+                          return (Left e)+                      Right r -> return $ Right r+                  )+ -- | 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+        -> Maybe (ConnectionState -> [SaslHandler] , Maybe Text)+           -- ^ SASL handlers and the desired JID resource (or Nothing to let+           -- the server decide)         -> 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+session realm mbSasl config = runErrorT $ do+    stream <- ErrorT $ connectStream realm config mbSasl+    ses <- ErrorT $ newSession stream config realm mbSasl+    liftIO $ when (enableRoster config) $ initRoster ses     return ses++-- | Reconnect immediately with the stored settings. Returns @Just@ the error+-- when the reconnect attempt fails and Nothing when no failure was encountered.+--+-- This function does not set your presence to online, so you will have to do+-- this yourself.+reconnectNow :: Session -- ^ session to reconnect+          -> IO (Maybe XmppFailure)+reconnectNow sess@Session{conf = config, reconnectWait = rw} = do+    debugM "Pontarius.Xmpp" "reconnecting"+    res <- flip withConnection sess $ \oldStream -> do+        debugM "Pontarius.Xmpp" "reconnect: closing stream"+        closeStreams oldStream+        debugM "Pontarius.Xmpp" "reconnect: opening stream"+        s <- connectStream (sRealm sess) config (sSaslCredentials sess)+        case s of+            Left  e -> do+                errorM "Pontarius.Xmpp" $ "reconnect failed"  ++ show e+                return (Left e   , oldStream )+            Right r -> return (Right () , r )+    case res of+        Left e -> return $ Just e+        Right (Left e) -> return $ Just e+        Right (Right ()) -> do+            atomically $ writeTVar rw 60+            when (enableRoster config) $ initRoster sess+            return Nothing+++-- | Reconnect with the stored settings.+--+-- Waits a random amount of seconds (between 0 and 60 inclusive) before the+-- first attempt and an increasing amount after each attempt after that. Caps+-- out at 2-5 minutes.+--+-- This function does not set your presence to online, so you will have to do+-- this yourself.+reconnect :: Integer -- ^ Maximum number of retries (numbers of 1 or less will+                     -- perform exactly one retry)+          -> Session -- ^ Session to reconnect+          -> IO (Bool, [XmppFailure]) -- ^ Whether or not the reconnect attempt+                                      -- was successful, and a list of failure+                                      -- modes encountered+reconnect maxTries sess = go maxTries+  where+    go t = do+        res <- doRetry sess+        case res of+            Nothing -> return (True, [])+            Just e  -> if (t > 1) then (second (e:)) <$> go (t - 1)+                                  else return $ (False, [e])++-- | Reconnect with the stored settings with an unlimited number of retries.+--+-- Waits a random amount of seconds (between 0 and 60 inclusive) before the+-- first attempt and an increasing amount after each attempt after that. Caps+-- out at 2-5 minutes.+--+-- This function does not set your presence to online, so you will have to do+-- this yourself.+reconnect' :: Session -- ^ Session to reconnect+          -> IO Integer -- ^ Number of failed retries before connection could be+                        -- established+reconnect' sess = go 0+  where+    go i = do+        res <- doRetry sess+        case res of+            Nothing -> return i+            Just _e  -> go (i+1)++doRetry :: Session -> IO (Maybe XmppFailure)+doRetry sess@Session{reconnectWait = rw} = do+    wait <- atomically $ do+        wt <- readTVar rw+        writeTVar rw $ min 300 (2 * wt)+        return wt+    t <- randomRIO (wait `div` 2 - 30, max 60 wait)+    debugM "Pontarius.Xmpp" $+        "Waiting " ++ show t ++ " seconds before reconnecting"+    threadDelay $ t * 10^(6 :: Int)+    reconnectNow sess++-- | Generates a new stanza identifier based on the 'sessionStanzaIDs' field of+-- 'SessionConfiguration'.+newStanzaID :: Session -> IO Text+newStanzaID = idGenerator

@@ -1,16 +1,63 @@ {-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Concurrent.Basic where -import Control.Concurrent.STM-import Network.Xmpp.Concurrent.Types-import Network.Xmpp.Types+import           Control.Concurrent.STM+import qualified Control.Exception as Ex+import           Control.Monad.State.Strict+import qualified Data.ByteString as BS+import           Network.Xmpp.Concurrent.Types+import           Network.Xmpp.Marshal+import           Network.Xmpp.Stream+import           Network.Xmpp.Types+import           Network.Xmpp.Utilities +semWrite :: WriteSemaphore -> BS.ByteString -> IO Bool+semWrite sem bs = Ex.bracket (atomically $ takeTMVar sem)+                          (atomically . putTMVar sem)+                          ($ bs)++writeStanza :: WriteSemaphore -> Stanza -> IO Bool+writeStanza sem a = do+    let outData = renderElement $ nsHack (pickleElem xpStanza a)+    semWrite sem outData+ -- | Send a stanza to the server.-sendStanza :: Stanza -> Session -> IO ()-sendStanza a session = atomically $ writeTChan (outCh session) a+sendStanza :: Stanza -> Session -> IO Bool+sendStanza a session = writeStanza (writeSemaphore session) a ++-- | Get the channel of incoming stanzas.+getStanzaChan :: Session -> TChan Stanza+getStanzaChan session = stanzaCh session++-- | Get the next incoming stanza+getStanza :: Session -> IO Stanza+getStanza session = atomically . readTChan $ stanzaCh session+ -- | 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'}++-- | Return the JID assigned to us by the server+getJid :: Session -> IO (Maybe Jid)+getJid Session{streamRef = st} = do+    s <- atomically $ readTMVar st+    withStream' (gets streamJid) s++-- | Return the JID assigned to us by the server+getFeatures :: Session -> IO StreamFeatures+getFeatures Session{streamRef = st} = do+    s <- atomically $ readTMVar st+    withStream' (gets streamFeatures) s++-- | Wait until the connection of the stream is re-established+waitForStream :: Session -> IO ()+waitForStream Session{streamRef = sr} = atomically $ do+    s <- readTMVar sr+    ss <- readTMVar $ unStream s+    case streamConnectionState ss of+        Plain -> return ()+        Secured -> return ()+        _ -> retry

@@ -4,8 +4,6 @@ import           Control.Concurrent (forkIO, threadDelay) import           Control.Concurrent.STM import           Control.Monad-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Reader  import qualified Data.Map as Map import           Data.Text (Text)@@ -15,16 +13,20 @@ 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@.-sendIQ :: Maybe Int -- ^ Timeout+-- | Sends an IQ, returns Just a 'TMVar' that will be filled with the first+-- inbound IQ with a matching ID that has type @result@ or @error@ or Nothing if+-- the stanza could not be sent+sendIQ :: Maybe Int -- ^ Timeout . When the timeout is reached the response+                    -- TMVar will be filled with 'IQResponseTimeout' and the id+                    -- is removed from the list of IQ handlers. 'Nothing'+                    -- deactivates the timeout        -> Maybe Jid -- ^ Recipient (to)        -> IQRequestType  -- ^ IQ type (@Get@ or @Set@)        -> Maybe LangTag  -- ^ Language tag of the payload (@Nothing@ for                          -- default)        -> Element -- ^ The IQ body (there has to be exactly one)        -> Session-       -> IO (TMVar IQResponse)+       -> IO (Maybe (TMVar IQResponse)) sendIQ timeOut to tp lang body session = do -- TODO: Add timeout     newId <- idGenerator session     ref <- atomically $ do@@ -33,13 +35,16 @@         writeTVar (iqHandlers session) (byNS, Map.insert newId resRef byId)           -- TODO: Check for id collisions (shouldn't happen?)         return resRef-    sendStanza  (IQRequestS $ IQRequest newId Nothing to lang tp body) session-    case timeOut of-        Nothing -> return ()-        Just t -> void . forkIO $ do-                  threadDelay t-                  doTimeOut (iqHandlers session) newId ref-    return ref+    res <- sendStanza (IQRequestS $ IQRequest newId Nothing to lang tp body) session+    if res+        then do+            case timeOut of+                Nothing -> return ()+                Just t -> void . forkIO $ do+                          threadDelay t+                          doTimeOut (iqHandlers session) newId ref+            return $ Just ref+        else return Nothing   where     doTimeOut handlers iqid var = atomically $ do       p <- tryPutTMVar var IQResponseTimeout@@ -49,24 +54,29 @@       return ()  --- | Like 'sendIQ', but waits for the answer IQ. Times out after 3 seconds+-- | Like 'sendIQ', but waits for the answer IQ. Times out after 30 seconds sendIQ' :: Maybe Jid         -> IQRequestType         -> Maybe LangTag         -> Element         -> Session-        -> IO IQResponse+        -> IO (Maybe IQResponse) sendIQ' to tp lang body session = do-    ref <- sendIQ (Just 3000000) to tp lang body session-    atomically $ takeTMVar ref+    ref <- sendIQ (Just 30000000) to tp lang body session+    maybe (return Nothing) (fmap Just . 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+-- value. 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@)+--+-- Note thet every 'IQRequest' must be answered exactly once. To insure this,+-- the incoming requests are wrapped in an 'IQRequestTicket' that prevents+-- multiple responses. Use 'iqRequestBody' to extract the corresponding request+-- and 'answerIQ' to send the response+listenIQChan :: IQRequestType  -- ^ Type of IQs to receive ('Get' or 'Set')              -> Text -- ^ Namespace of the child element              -> Session              -> IO (Either (TChan IQRequestTicket) (TChan IQRequestTicket))@@ -85,23 +95,27 @@             Nothing -> Right iqCh             Just iqCh' -> Left iqCh' +-- | Unregister a previously acquired IQ channel. Please make sure that you+-- where the one who acquired it in the first place as no check for ownership+-- can be made+dropIQChan :: IQRequestType  -- ^ Type of IQ ('Get' or 'Set')+             -> Text -- ^ Namespace of the child element+             -> Session+             -> IO ()+dropIQChan tp ns session = do+    let handlers = (iqHandlers session)+    atomically $ do+        (byNS, byID) <- readTVar handlers+        let byNS' = Map.delete (tp, ns) byNS+        writeTVar handlers (byNS', byID)+        return ()++-- | Answer an IQ request. Only the first answer ist sent and Just True is+-- returned when the answer is sucessfully sent. If an error occured during+-- sending Just False is returned (and another attempt can be+-- undertaken). Subsequent answers after the first sucessful one are dropped and+-- (False is returned in that case) answerIQ :: IQRequestTicket          -> Either StanzaError (Maybe Element)-         -> Session-         -> IO Bool-answerIQ (IQRequestTicket-              sentRef-              (IQRequest iqid from _to lang _tp bd))-           answer session = do-  let response = case answer of-        Left err  -> IQErrorS $ IQError iqid Nothing from lang err (Just bd)-        Right res -> IQResultS $ IQResult iqid Nothing from lang res-  atomically $ do-       sent <- readTVar sentRef-       case sent of-         False -> do-             writeTVar sentRef True--             writeTChan (outCh  session) response-             return True-         True -> return False+         -> IO (Maybe Bool)+answerIQ ticket = answerTicket ticket

@@ -3,9 +3,7 @@  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@@ -54,6 +52,7 @@         Right m | g m -> return $ Right m                 | otherwise -> filterMessages f g session --- | Send a message stanza.-sendMessage :: Message -> Session -> IO ()+-- | Send a message stanza. Returns @False@ when the 'Message' could not be+-- sent.+sendMessage :: Message -> Session -> IO Bool sendMessage m session = sendStanza (MessageS m) session

@@ -2,98 +2,117 @@ {-# LANGUAGE OverloadedStrings #-} module Network.Xmpp.Concurrent.Monad where -import           Network.Xmpp.Types-+import           Control.Applicative ((<$>))+import           Control.Concurrent import           Control.Concurrent.STM import qualified Control.Exception.Lifted as Ex-import           Control.Monad.Reader-+import           Control.Monad.State import           Network.Xmpp.Concurrent.Types import           Network.Xmpp.Stream---+import           Network.Xmpp.Types  -- 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.+-- | 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)---             ]+withConnection :: (Stream -> IO (b, Stream))+               -> Session+               -> IO (Either XmppFailure b)+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 (writeSemaphore session)+                 s <- takeTMVar (streamRef 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') <- a s+                 wl <- withStream' (gets $ streamSend . streamHandle) s'+                 atomically $ do+                     putTMVar (writeSemaphore session) wl+                     putTMVar (streamRef session) s'+                     return $ Right res+            ) -- TODO: DO we have to replace the MVars in case of ane exception?+            -- 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 :: XmppFailure)+            , Ex.Handler $ \e -> killStream s+                  >> Ex.throwIO (e :: Ex.SomeException)+            ]  -- | Executes a function to update the event handlers. modifyHandlers :: (EventHandlers -> EventHandlers) -> Session -> IO ()-modifyHandlers f session = atomically $ modifyTVar (eventHandlers session) f+modifyHandlers f session = atomically $ modifyTMVar_ (eventHandlers session) f   where     -- Borrowing modifyTVar from     -- http://hackage.haskell.org/packages/archive/stm/2.4/doc/html/src/Control-Concurrent-STM-TVar.html     -- as it's not available in GHC 7.0.-    modifyTVar :: TVar a -> (a -> a) -> STM ()-    modifyTVar var f = do-      x <- readTVar var-      writeTVar var (f x)+    modifyTMVar_ :: TMVar a -> (a -> a) -> STM ()+    modifyTMVar_ var g = do+      x <- takeTMVar var+      putTMVar var (g x) --- | Sets the handler to be executed when the server connection is closed.-setConnectionClosedHandler_ :: (XmppFailure -> Session -> IO ()) -> Session -> IO ()-setConnectionClosedHandler_ eh session = do+-- | Changes the handler to be executed when the server connection is closed. To+-- avoid race conditions the initial value should be set in the configuration+-- when creating the session+setConnectionClosedHandler :: (XmppFailure -> Session -> IO ()) -> Session -> IO ()+setConnectionClosedHandler eh session = do     modifyHandlers (\s -> s{connectionClosedHandler =                                  \e -> eh e session}) session +runConnectionClosedHandler :: Session -> XmppFailure -> IO ()+runConnectionClosedHandler session e = do+    h <- connectionClosedHandler <$> atomically (readTMVar+                                                  $ eventHandlers session)+    h e+ -- | Run an event handler. runHandler :: (EventHandlers -> IO a) -> Session -> IO a-runHandler h session = h =<< atomically (readTVar $ eventHandlers session)+runHandler h session = h =<< atomically (readTMVar $ eventHandlers session)  --- | End the current Xmpp session.-endContext :: Session -> IO ()-endContext session =  do -- TODO: This has to be idempotent (is it?)-    closeConnection session+-- | End the current XMPP session. Kills the associated threads and closes the+-- connection.+--+-- Note that XMPP clients (that has signalled availability) should send+-- \"Unavailable\" presence prior to disconnecting.+--+-- The connectionClosedHandler will not be called (to avoid possibly+-- reestablishing the connection).+endSession :: Session -> IO ()+endSession session =  do -- TODO: This has to be idempotent (is it?)     stopThreads session+    _ <- flip withConnection session $ \stream -> do+        _ <- closeStreams stream+        return ((), stream)+    return () + -- | Close the connection to the server. Closes the stream (by enforcing a--- write lock and sending a </stream:stream> element), waits (blocks) for three--- seconds, and then closes the connection.+-- write lock and sending a \</stream:stream\> element), waits (blocks) for+-- three seconds, and then closes the connection. closeConnection :: Session -> IO ()-closeConnection session = Ex.mask_ $ do-    (_send, connection) <- atomically $ liftM2 (,)-                             (takeTMVar $ writeRef session)-                             (takeTMVar $ streamRef session)-    _ <- closeStreams connection-    return ()+closeConnection session = do+    _ <-flip withConnection session $ \stream -> do+        _ <- closeStreams stream+        return ((), stream)+    runConnectionClosedHandler session StreamEndFailure

@@ -2,7 +2,6 @@ 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@@ -28,5 +27,5 @@                 | otherwise -> waitForPresence f session  -- | Send a presence stanza.-sendPresence :: Presence -> Session -> IO ()+sendPresence :: Presence -> Session -> IO Bool sendPresence p session = sendStanza (PresenceS p) session

@@ -4,25 +4,17 @@  module Network.Xmpp.Concurrent.Threads where -import           Network.Xmpp.Types- 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.State.Strict-+import           Control.Monad.Error import qualified Data.ByteString as BS+import           GHC.IO (unsafeUnmask) import           Network.Xmpp.Concurrent.Types import           Network.Xmpp.Stream--import           Control.Concurrent.STM.TMVar--import           GHC.IO (unsafeUnmask)--import           Control.Monad.Error+import           Network.Xmpp.Types import           System.Log.Logger  -- Worker to read stanzas from the stream and concurrently distribute them to@@ -31,32 +23,48 @@            -> (XmppFailure -> IO ())            -> TMVar Stream            -> IO a-readWorker onStanza onConnectionClosed stateRef =-    Ex.mask_ . forever $ do-        res <- Ex.catches ( do-                       -- we don't know whether pull will-                       -- necessarily be interruptible-                       s <- atomically $ do+readWorker onStanza onCClosed stateRef = forever . Ex.mask_ $ do++    s' <- Ex.catches ( do+                   -- we don't know whether pull will+                   -- necessarily be interruptible+                        atomically $ do                             s@(Stream con) <- readTMVar stateRef-                            state <- streamConnectionState <$> readTMVar con-                            when (state == Closed)+                            scs <- streamConnectionState <$> readTMVar con+                            when (stateIsClosed scs)                                  retry-                            return s-                       allowInterrupt-                       Just <$> pullStanza s-                       )-                   [ Ex.Handler $ \(Interrupt t) -> do-                         void $ handleInterrupts [t]-                         return Nothing-                   , Ex.Handler $ \(e :: XmppFailure) -> do-                         onConnectionClosed e-                         errorM "Pontarius.Xmpp" $  "Read error: " ++ show e-                         return Nothing-                   ]-        case res of-              Nothing -> return () -- Caught an exception, nothing to do. TODO: Can this happen?-              Just (Left e) -> return ()-              Just (Right sta) -> onStanza sta+                            return $ Just s+                   )+               [ Ex.Handler $ \(Interrupt t) -> do+                     void $ handleInterrupts [t]+                     return Nothing++               ]+    case s' of+        Nothing -> return ()+        Just s -> do+            res <- Ex.catches (do+                             allowInterrupt+                             Just <$> pullStanza s+                              )+                       [ Ex.Handler $ \(Interrupt t) -> do+                              void $ handleInterrupts [t]+                              return Nothing+                       , Ex.Handler $ \(e :: XmppFailure) -> do+                              errorM "Pontarius.Xmpp" $ "Read error: "+                                                         ++ show e+                              _ <- closeStreams s+                              onCClosed e+                              return Nothing+                       ]+            case res of+                Nothing -> return () -- Caught an exception, nothing to+                                     -- do. TODO: Can this happen?+                Just (Left e) -> do+                    errorM "Pontarius.Xmpp" $ "Stanza error:" ++ show e+                    _ <- closeStreams s+                    onCClosed e+                Just (Right sta) -> void $ onStanza sta   where     -- Defining an Control.Exception.allowInterrupt equivalent for GHC 7     -- compatibility.@@ -71,51 +79,54 @@     handleInterrupts ts =         Ex.catch (atomically $ forM ts takeTMVar)             (\(Interrupt t) -> handleInterrupts (t:ts))+    stateIsClosed Closed   = True+    stateIsClosed Finished = True+    stateIsClosed _        = False + -- 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.-startThreadsWith :: (Stanza -> IO ())-                 -> TVar EventHandlers+startThreadsWith :: TMVar (BS.ByteString -> IO Bool)+                 -> (Stanza -> IO ())+                 -> TMVar 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-                         )+startThreadsWith writeSem stanzaHandler eh con = do+    -- read' <- withStream' (gets $ streamSend . streamHandle) con+    -- writeSem <- newTMVarIO read'+    conS <- newTMVarIO con+    cp <- forkIO $ connPersist writeSem+    rdw <- forkIO $ readWorker stanzaHandler (noCon eh) conS+    return $ Right ( killConnection [rdw, cp]+                   , writeSem+                   , conS+                   , rdw+                   )   where-    killConnection writeLock threads = liftIO $ do-        _ <- atomically $ takeTMVar writeLock -- Should we put it back?+    killConnection threads = liftIO $ do+        _ <- atomically $ do+            _ <- takeTMVar writeSem+            putTMVar writeSem $ \_ -> return False         _ <- forM threads killThread         return ()     -- Call the connection closed handlers.-    noCon :: TVar EventHandlers -> XmppFailure -> IO ()+    noCon :: TMVar EventHandlers -> XmppFailure -> IO ()     noCon h e = do-        hands <- atomically $ readTVar h+        hands <- atomically $ readTMVar 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. connPersist :: TMVar (BS.ByteString -> IO Bool) -> IO ()-connPersist lock = forever $ do-    pushBS <- atomically $ takeTMVar lock+connPersist sem = forever $ do+    pushBS <- atomically $ takeTMVar sem     _ <- pushBS " "-    atomically $ putTMVar lock pushBS+    atomically $ putTMVar sem pushBS     threadDelay 30000000 -- 30s

@@ -3,21 +3,47 @@  module Network.Xmpp.Concurrent.Types where -import qualified Control.Exception.Lifted as Ex import           Control.Concurrent import           Control.Concurrent.STM-+import qualified Control.Exception.Lifted as Ex import qualified Data.ByteString as BS+import           Data.Default+import qualified Data.Map as Map+import           Data.Text (Text)+import qualified Data.Text as Text import           Data.Typeable-+import           Data.XML.Types (Element)+import           Network+import           Network.Xmpp.IM.Roster.Types import           Network.Xmpp.Types+import           Network.Xmpp.Sasl.Types -import           Data.IORef-import qualified Data.Map as Map-import           Data.Text (Text) -import           Network.Xmpp.Types+-- | 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).+    , onConnectionClosed         :: Session -> XmppFailure -> IO ()+      -- | Function to generate the stream of stanza identifiers.+    , sessionStanzaIDs           :: IO (IO Text)+    , extraStanzaHandlers        :: [StanzaHandler]+    , enableRoster               :: Bool+    } +instance Default SessionConfiguration where+    def = SessionConfiguration { sessionStreamConfiguration = def+                               , onConnectionClosed = \_ _ -> return ()+                               , sessionStanzaIDs = do+                                     idRef <- newTVarIO 1+                                     return . atomically $ do+                                         curId <- readTVar idRef+                                         writeTVar idRef (curId + 1 :: Integer)+                                         return . Text.pack . show $ curId+                               , extraStanzaHandlers = []+                               , enableRoster = True+                               }+ -- | Handlers to be run when the Xmpp session ends and when the Xmpp connection is -- closed. data EventHandlers = EventHandlers@@ -30,35 +56,45 @@  instance Ex.Exception Interrupt +type WriteSemaphore = TMVar (BS.ByteString -> IO Bool)  -- | A concurrent interface to Pontarius XMPP. data Session = Session     { stanzaCh :: TChan Stanza -- All stanzas-    , outCh :: TChan Stanza     , iqHandlers :: TVar IQHandlers       -- Writing lock, so that only one thread could write to the stream at any       -- given time.       -- Fields below are from Context.-    , writeRef :: TMVar (BS.ByteString -> IO Bool)+    , writeSemaphore :: WriteSemaphore     , readerThread :: ThreadId-    , idGenerator :: IO StanzaID+    , idGenerator :: IO Text       -- | 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+    , streamRef :: TMVar Stream+    , eventHandlers :: TMVar EventHandlers     , stopThreads :: IO ()+    , rosterRef :: TVar Roster     , conf :: SessionConfiguration+    , sRealm :: HostName+    , sSaslCredentials :: Maybe (ConnectionState -> [SaslHandler] , Maybe Text)+    , reconnectWait :: TVar Int     } --- | IQHandlers holds the registered channels for incomming IQ requests and--- TMVars of and TMVars for expected IQ responses+-- | IQHandlers holds the registered channels for incoming IQ requests and+-- TMVars of and TMVars for expected IQ responses (the second Text represent a+-- stanza identifier. type IQHandlers = (Map.Map (IQRequestType, Text) (TChan IQRequestTicket)-                  , Map.Map StanzaID (TMVar IQResponse)+                  , Map.Map Text (TMVar IQResponse)                   )  -- | Contains whether or not a reply has been sent, and the IQ request body to -- reply to.+ data IQRequestTicket = IQRequestTicket-    { sentRef     :: (TVar Bool)+    { answerTicket :: Either StanzaError (Maybe Element) -> IO (Maybe Bool)+                      -- ^ Return Nothing when the IQ request was already+                      -- answered before, Just True when it was sucessfully+                      -- answered and Just False when the answer was attempted,+                      -- but failed (e.g. there is a connection failure)     , iqRequestBody :: IQRequest     }

@@ -0,0 +1,32 @@+-- | RFC 6121: Instant Messaging and Presence+--+module Network.Xmpp.IM+  ( -- * Instant Messages+    InstantMessage(..)+  , MessageBody(..)+  , MessageThread(..)+  , MessageSubject(..)+  , Subscription(None, To, From, Both)+  , instantMessage+  , simpleIM+  , getIM+  , withIM+  , answerIM+     -- * Presence+  , ShowStatus(..)+  , IMPresence(..)+  , imPresence+  , getIMPresence+  , withIMPresence+  -- * Roster+  , Roster(..)+  , Item(..)+  , getRoster+  , rosterAdd+  , rosterRemove+  ) where++import Network.Xmpp.IM.Message+import Network.Xmpp.IM.Presence+import Network.Xmpp.IM.Roster+import Network.Xmpp.IM.Roster.Types

@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK hide #-}++module Network.Xmpp.IM.Message where++import Data.Default+import Data.Function+import Data.List+import Data.Text (Text)+import Data.XML.Pickle+import Data.XML.Types+import Network.Xmpp.Marshal+import Network.Xmpp.Types++data MessageBody = MessageBody { bodyLang    :: Maybe LangTag+                               , bodyContent :: Text+                               }++data MessageThread = MessageThread { threadID     :: Text+                                   , threadParent :: Maybe Text+                                   }++data MessageSubject = MessageSubject { subjectLang    :: Maybe LangTag+                                     , subjectContent :: Text+                                     }++-- | The instant message (IM) specific part of a message.+data InstantMessage = InstantMessage { imThread  :: Maybe MessageThread+                                     , imSubject :: [MessageSubject]+                                     , imBody    :: [MessageBody]+                                     }++instantMessage :: InstantMessage+instantMessage = InstantMessage { imThread  = Nothing+                                , imSubject = []+                                , imBody    = []+                                }++instance Default InstantMessage where+    def = instantMessage++-- | Get the IM specific parts of a message. Returns 'Nothing' when the received+-- payload is not valid IM data.+getIM :: Message -> Maybe InstantMessage+getIM im = either (const Nothing) Just . unpickle xpIM $ messagePayload im++sanitizeIM :: InstantMessage -> InstantMessage+sanitizeIM im = im{imBody = nubBy ((==) `on` bodyLang) $ imBody im}++-- | Append IM data to a message+withIM :: Message -> InstantMessage -> Message+withIM m im = m{ messagePayload = messagePayload m+                                 ++ pickleTree xpIM (sanitizeIM im) }++imToElements :: InstantMessage -> [Element]+imToElements im = pickle xpIM (sanitizeIM im)++-- | Generate a simple message+simpleIM :: Jid -- ^ recipient+         -> Text -- ^ body+         -> Message+simpleIM to bd = withIM message{messageTo = Just to}+                       instantMessage{imBody = [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.+--+-- If multiple message bodies are given they MUST have different language tags+answerIM :: [MessageBody] -> Message -> Maybe Message+answerIM bd msg = case getIM msg of+    Nothing -> Nothing+    Just im -> Just $ flip withIM (im{imBody = bd}) $+        message { messageID      = messageID msg+                , messageFrom    = Nothing+                , messageTo      = messageFrom msg+                , messageLangTag = messageLangTag msg+                , messageType    = messageType msg+                }++--------------------------+-- Picklers --------------+--------------------------+xpIM :: PU [Element] InstantMessage+xpIM = xpWrap (\(t, s, b) -> InstantMessage t s b)+              (\(InstantMessage t s b) -> (t, s, b))+       . xpClean+       $ xp3Tuple+           xpMessageThread+           xpMessageSubject+           xpMessageBody+++xpMessageSubject :: PU [Element] [MessageSubject]+xpMessageSubject = xpUnliftElems .+                   xpWrap (map $ \(l, s) -> MessageSubject l s)+                          (map $ \(MessageSubject l s) -> (l,s))+                   $ xpElems "{jabber:client}subject" xpLangTag $ xpContent xpId++xpMessageBody :: PU [Element] [MessageBody]+xpMessageBody = xpUnliftElems .+                xpWrap (map $ \(l, s) ->  MessageBody l s)+                       (map $ \(MessageBody l s) -> (l,s))+                   $ xpElems "{jabber:client}body" xpLangTag $ xpContent xpId++xpMessageThread :: PU [Element] (Maybe MessageThread)+xpMessageThread = xpUnliftElems+                  . xpOption+                  . xpWrap (\(t, p) ->  MessageThread p t)+                          (\(MessageThread p t) -> (t,p))+                   $ xpElem "{jabber:client}thread"+                      (xpAttrImplied "parent" xpId)+                      (xpContent xpId)

@@ -0,0 +1,76 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++module Network.Xmpp.IM.Presence where++import Data.Default+import Data.Text (Text)+import Data.XML.Pickle+import Data.XML.Types+import Network.Xmpp.Types++data ShowStatus = StatusAway+                | StatusChat+                | StatusDnd+                | StatusXa deriving (Read, Show)++data IMPresence = IMP { showStatus :: Maybe ShowStatus+                      , status     :: Maybe Text+                      , priority   :: Maybe Int+                      } deriving Show++imPresence :: IMPresence+imPresence = IMP { showStatus = Nothing+                 , status     = Nothing+                 , priority   = Nothing+                 }++instance Default IMPresence where+    def = imPresence++-- | Try to extract RFC6121 IM presence information from presence stanza+-- Returns Nothing when the data is malformed, (Just IMPresence) otherwise+getIMPresence :: Presence -> Maybe IMPresence+getIMPresence pres = case unpickle xpIMPresence (presencePayload pres) of+    Left _ -> Nothing+    Right r -> Just r++withIMPresence :: IMPresence -> Presence -> Presence+withIMPresence imPres pres = pres{presencePayload = presencePayload pres+                                                   ++ pickleTree xpIMPresence+                                                                 imPres}++--+-- Picklers+--++xpIMPresence :: PU [Element] IMPresence+xpIMPresence = xpUnliftElems .+               xpWrap (\(s, st, p) -> IMP s st p)+                      (\(IMP s st p) -> (s, st, p)) .+               xpClean $+               xp3Tuple+                  (xpOption $ xpElemNodes "{jabber:client}show"+                     (xpContent xpShow))+                  (xpOption $ xpElemNodes "{jabber:client}status"+                     (xpContent xpText))+                  (xpOption $ xpElemNodes "{jabber:client}priority"+                     (xpContent xpPrim))++xpShow :: PU Text ShowStatus+xpShow = ("xpShow", "") <?>+        xpPartial ( \input -> case showStatusFromText input of+                                   Nothing -> Left "Could not parse show status."+                                   Just j -> Right j)+                  showStatusToText+  where+    showStatusFromText "away" = Just StatusAway+    showStatusFromText "chat" = Just StatusChat+    showStatusFromText "dnd" = Just StatusDnd+    showStatusFromText "xa" = Just StatusXa+    showStatusFromText _ = Nothing+    showStatusToText StatusAway = "away"+    showStatusToText StatusChat = "chat"+    showStatusToText StatusDnd = "dnd"+    showStatusToText StatusXa = "xa"

@@ -0,0 +1,213 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Xmpp.IM.Roster where++import           Control.Applicative ((<$>))+import           Control.Concurrent.STM+import           Control.Monad+import           Data.List (nub)+#if MIN_VERSION_containers(0, 5, 0)+import qualified Data.Map.Strict as Map+#else+import qualified Data.Map as Map+#endif+import           Data.Maybe (isJust, fromMaybe)+import           Data.Text (Text)+import           Data.XML.Pickle+import           Data.XML.Types+import           System.Log.Logger++import           Network.Xmpp.Concurrent.Basic+import           Network.Xmpp.Concurrent.IQ+import           Network.Xmpp.Concurrent.Types+import           Network.Xmpp.IM.Roster.Types+import           Network.Xmpp.Marshal+import           Network.Xmpp.Types++-- | Push a roster item to the server. The values for approved and ask are+-- ignored and all values for subsciption except "remove" are ignored+rosterPush :: Item -> Session -> IO (Maybe IQResponse)+rosterPush item session = do+    let el = pickleElem xpQuery (Query Nothing [fromItem item])+    sendIQ'  Nothing Set Nothing el session++-- | Add or update an item to the roster.+--+-- To update the item just send the complete set of new data+rosterAdd :: Jid -- ^ JID of the item+          -> Maybe Text -- ^ Name alias+          -> [Text] -- ^ Groups (duplicates will be removed)+          -> Session+          -> IO (Maybe IQResponse)+rosterAdd j n gs session = do+    let el = pickleElem xpQuery (Query Nothing+                                 [QueryItem { qiApproved = Nothing+                                            , qiAsk = False+                                            , qiJid = j+                                            , qiName = n+                                            , qiSubscription = Nothing+                                            , qiGroups = nub gs+                                            }])+    sendIQ'  Nothing Set Nothing el session++-- | Remove an item from the roster. Return True when the item is sucessfully+-- removed or if it wasn't in the roster to begin with.+rosterRemove :: Jid -> Session -> IO Bool+rosterRemove j sess = do+    roster <- getRoster sess+    case Map.lookup j (items roster) of+        Nothing -> return True -- jid is not on the Roster+        Just _ -> do+            res <- rosterPush (Item False False j Nothing Remove []) sess+            case res of+                Just (IQResponseResult IQResult{}) -> return True+                _ -> return False++-- | Retrieve the current Roster state+getRoster :: Session -> IO Roster+getRoster session = atomically $ readTVar (rosterRef session)++-- | Get the initial roster / refresh the roster. You don't need to call this on your own+initRoster :: Session -> IO ()+initRoster session = do+    oldRoster <- getRoster session+    mbRoster <- retrieveRoster (if isJust (ver oldRoster) then Just oldRoster+                                                          else Nothing ) session+    case mbRoster of+        Nothing -> errorM "Pontarius.Xmpp"+                          "Server did not return a roster"+        Just roster -> atomically $ writeTVar (rosterRef session) roster++handleRoster :: TVar Roster -> WriteSemaphore -> Stanza -> IO Bool+handleRoster ref sem sta = case sta of+    IQRequestS (iqr@IQRequest{iqRequestPayload =+                                   iqb@Element{elementName = en}})+        | nameNamespace en == Just "jabber:iq:roster" -> do+            case iqRequestFrom iqr of+                Just _from -> return True -- Don't handle roster pushes from+                                          -- unauthorized sources+                Nothing -> case unpickleElem xpQuery iqb of+                    Right Query{ queryVer = v+                               , queryItems = [update]+                               } -> do+                        handleUpdate v update+                        _ <- writeStanza sem $ result iqr+                        return False+                    _ -> do+                        errorM "Pontarius.Xmpp" "Invalid roster query"+                        _ <- writeStanza sem $ badRequest iqr+                        return False+    _ -> return True+  where+    handleUpdate v' update = atomically $ modifyTVar ref $ \(Roster v is) ->+        Roster (v' `mplus` v) $ case qiSubscription update of+            Just Remove -> Map.delete (qiJid update) is+            _ -> Map.insert (qiJid update) (toItem update) is++    badRequest (IQRequest iqid from _to lang _tp bd) =+        IQErrorS $ IQError iqid Nothing from lang errBR (Just bd)+    errBR = StanzaError Cancel BadRequest Nothing Nothing+    result (IQRequest iqid from _to lang _tp _bd) =+        IQResultS $ IQResult iqid Nothing from lang Nothing++retrieveRoster :: Maybe Roster -> Session -> IO (Maybe Roster)+retrieveRoster mbOldRoster sess = do+    useVersioning <- isJust . rosterVer <$> getFeatures sess+    let version = if useVersioning+                then case mbOldRoster of+                      Nothing -> Just ""+                      Just oldRoster -> ver oldRoster+                else Nothing+    res <- sendIQ' Nothing Get Nothing+        (pickleElem xpQuery (Query version []))+        sess+    case res of+        Nothing -> do+            errorM "Pontarius.Xmpp.Roster" "getRoster: sending stanza failed"+            return Nothing+        Just (IQResponseResult (IQResult{iqResultPayload = Just ros}))+            -> case unpickleElem xpQuery ros of+            Left _e -> do+                errorM "Pontarius.Xmpp.Roster" "getRoster: invalid query element"+                return Nothing+            Right ros' -> return . Just $ toRoster ros'+        Just (IQResponseResult (IQResult{iqResultPayload = Nothing})) -> do+            return mbOldRoster+                -- sever indicated that no roster updates are necessary+        Just IQResponseTimeout -> do+            errorM "Pontarius.Xmpp.Roster" "getRoster: request timed out"+            return Nothing+        Just (IQResponseError e) -> do+            errorM "Pontarius.Xmpp.Roster" $ "getRoster: server returned error"+                   ++ show e+            return Nothing+  where+    toRoster (Query v is) = Roster v (Map.fromList+                                             $ map (\i -> (qiJid i, toItem i))+                                               is)++toItem :: QueryItem -> Item+toItem qi = Item { riApproved = fromMaybe False (qiApproved qi)+                 , riAsk = qiAsk qi+                 , riJid = qiJid qi+                 , riName = qiName qi+                 , riSubscription = fromMaybe None (qiSubscription qi)+                 , riGroups = nub $ qiGroups qi+                 }++fromItem :: Item -> QueryItem+fromItem i = QueryItem { qiApproved = Nothing+                       , qiAsk = False+                       , qiJid = riJid i+                       , qiName = riName i+                       , qiSubscription = case riSubscription i of+                           Remove -> Just Remove+                           _ -> Nothing+                       , qiGroups = nub $ riGroups i+                       }++xpItems :: PU [Node] [QueryItem]+xpItems = xpWrap (map (\((app_, ask_, jid_, name_, sub_), groups_) ->+                        QueryItem app_ ask_ jid_ name_ sub_ groups_))+                 (map (\(QueryItem app_ ask_ jid_ name_ sub_ groups_) ->+                        ((app_, ask_, jid_, name_, sub_), groups_))) $+          xpElems "{jabber:iq:roster}item"+          (xp5Tuple+            (xpAttribute' "approved" xpBool)+            (xpWrap isJust+                    (\p -> if p then Just () else Nothing) $+                     xpOption $ xpAttribute_ "ask" "subscribe")+            (xpAttribute  "jid" xpJid)+            (xpAttribute' "name" xpText)+            (xpAttribute' "subscription" xpSubscription)+          )+          (xpFindMatches $ xpElemText "{jabber:iq:roster}group")++xpQuery :: PU [Node] Query+xpQuery = xpWrap (\(ver_, items_) -> Query ver_ items_ )+                 (\(Query ver_ items_) -> (ver_, items_)) $+          xpElem "{jabber:iq:roster}query"+            (xpAttribute' "ver" xpText)+            xpItems++xpSubscription :: PU Text Subscription+xpSubscription = ("xpSubscription", "") <?>+        xpPartial ( \input -> case subscriptionFromText input of+                                   Nothing -> Left "Could not parse subscription."+                                   Just j -> Right j)+                  subscriptionToText+  where+    subscriptionFromText "none" = Just None+    subscriptionFromText "to" = Just To+    subscriptionFromText "from" = Just From+    subscriptionFromText "both" = Just Both+    subscriptionFromText "remove" = Just Remove+    subscriptionFromText _ = Nothing+    subscriptionToText None = "none"+    subscriptionToText To = "to"+    subscriptionToText From = "from"+    subscriptionToText Both = "both"+    subscriptionToText Remove = "remove"

@@ -0,0 +1,34 @@+module Network.Xmpp.IM.Roster.Types where++import qualified Data.Map as Map+import           Data.Text (Text)+import           Network.Xmpp.Types++-- Note that `Remove' is not exported from IM.hs, as it will never be visible to+-- the user anyway.+data Subscription = None | To | From | Both | Remove deriving (Eq, Read, Show)++data Roster = Roster { ver :: Maybe Text+                     , items :: Map.Map Jid Item } deriving Show+++-- | Roster Items+data Item = Item { riApproved :: Bool+                 , riAsk :: Bool+                 , riJid :: Jid+                 , riName :: Maybe Text+                 , riSubscription :: Subscription+                 , riGroups :: [Text]+                 } deriving Show++data QueryItem = QueryItem { qiApproved :: Maybe Bool+                           , qiAsk :: Bool+                           , qiJid :: Jid+                           , qiName :: Maybe Text+                           , qiSubscription :: Maybe Subscription+                           , qiGroups :: [Text]+                           } deriving Show++data Query = Query { queryVer :: Maybe Text+                   , queryItems :: [QueryItem]+                   } deriving Show

@@ -29,17 +29,15 @@   , pushStanza   , pullStanza   , pushIQ-  , SaslHandler(..)-  , StanzaID(..)+  , SaslHandler+  , Stanza(..)+  , TlsBehaviour(..)  )         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

@@ -2,7 +2,9 @@ -- respectively. By convensions, pickler/unpickler ("PU") function names start -- out with "xp". -{-# Language OverloadedStrings, ViewPatterns, NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoMonomorphismRestriction #-}  {-# OPTIONS_HADDOCK hide #-} @@ -23,10 +25,10 @@     [ xpWrap IQRequestS     (\(IQRequestS     x) -> x) xpIQRequest     , xpWrap IQResultS      (\(IQResultS      x) -> x) xpIQResult     , xpWrap IQErrorS       (\(IQErrorS       x) -> x) xpIQError-    , xpWrap MessageS       (\(MessageS       x) -> x) xpMessage     , xpWrap MessageErrorS  (\(MessageErrorS  x) -> x) xpMessageError-    , xpWrap PresenceS      (\(PresenceS      x) -> x) xpPresence+    , xpWrap MessageS       (\(MessageS       x) -> x) xpMessage     , xpWrap PresenceErrorS (\(PresenceErrorS x) -> x) xpPresenceError+    , xpWrap PresenceS      (\(PresenceS      x) -> x) xpPresence     ]   where     -- Selector for which pickler to execute above.@@ -34,10 +36,10 @@     stanzaSel (IQRequestS     _) = 0     stanzaSel (IQResultS      _) = 1     stanzaSel (IQErrorS       _) = 2-    stanzaSel (MessageS       _) = 3-    stanzaSel (MessageErrorS  _) = 4-    stanzaSel (PresenceS      _) = 5-    stanzaSel (PresenceErrorS _) = 6+    stanzaSel (MessageErrorS  _) = 3+    stanzaSel (MessageS       _) = 4+    stanzaSel (PresenceErrorS _) = 5+    stanzaSel (PresenceS      _) = 6  xpMessage :: PU [Node] (Message) xpMessage = ("xpMessage" , "") <?+> xpWrap@@ -45,10 +47,10 @@     (\(Message qid from to lang tp ext) -> ((tp, qid, from, to, lang), ext))     (xpElem "{jabber:client}message"          (xp5Tuple-             (xpDefault Normal $ xpAttr "type" xpPrim)-             (xpAttrImplied "id"   xpPrim)-             (xpAttrImplied "from" xpPrim)-             (xpAttrImplied "to"   xpPrim)+             (xpDefault Normal $ xpAttr "type" xpMessageType)+             (xpAttrImplied "id"   xpId)+             (xpAttrImplied "from" xpJid)+             (xpAttrImplied "to"   xpJid)              xpLangTag              -- TODO: NS?          )@@ -61,11 +63,11 @@     (\(Presence qid from to lang tp ext) -> ((qid, from, to, lang, tp), ext))     (xpElem "{jabber:client}presence"          (xp5Tuple-              (xpAttrImplied "id"   xpPrim)-              (xpAttrImplied "from" xpPrim)-              (xpAttrImplied "to"   xpPrim)+              (xpAttrImplied "id"   xpId)+              (xpAttrImplied "from" xpJid)+              (xpAttrImplied "to"   xpJid)               xpLangTag-              (xpAttrImplied "type" xpPrim)+              (xpDefault Available $ xpAttr "type" xpPresenceType)          )          (xpAll xpElemVerbatim)     )@@ -76,11 +78,11 @@     (\(IQRequest qid from to lang tp body) -> ((qid, from, to, lang, tp), body))     (xpElem "{jabber:client}iq"          (xp5Tuple-             (xpAttr        "id"   xpPrim)-             (xpAttrImplied "from" xpPrim)-             (xpAttrImplied "to"   xpPrim)+             (xpAttr        "id"   xpId)+             (xpAttrImplied "from" xpJid)+             (xpAttrImplied "to"   xpJid)              xpLangTag-             ((xpAttr        "type" xpPrim))+             ((xpAttr        "type" xpIQRequestType))          )          xpElemVerbatim     )@@ -91,9 +93,9 @@     (\(IQResult qid from to lang body) -> ((qid, from, to, lang, ()), body))     (xpElem "{jabber:client}iq"          (xp5Tuple-             (xpAttr        "id"   xpPrim)-             (xpAttrImplied "from" xpPrim)-             (xpAttrImplied "to"   xpPrim)+             (xpAttr        "id"   xpId)+             (xpAttrImplied "from" xpJid)+             (xpAttrImplied "to"   xpJid)              xpLangTag              ((xpAttrFixed "type" "result"))          )@@ -110,7 +112,7 @@     (\cond -> (cond, (), ()))     (xpElemByNamespace         "urn:ietf:params:xml:ns:xmpp-stanzas"-        xpPrim+        xpStanzaErrorCondition         xpUnit         xpUnit     )@@ -120,11 +122,11 @@     (\(tp, (cond, txt, ext)) -> StanzaError tp cond txt ext)     (\(StanzaError tp cond txt ext) -> (tp, (cond, txt, ext)))     (xpElem "{jabber:client}error"-         (xpAttr "type" xpPrim)+         (xpAttr "type" xpStanzaErrorType)          (xp3Tuple               xpErrorCondition               (xpOption $ xpElem "{jabber:client}text"-                   (xpAttrImplied xmlLang xpPrim)+                   (xpAttrImplied xmlLang xpLang)                    (xpContent xpId)               )               (xpOption xpElemVerbatim)@@ -140,10 +142,10 @@     (xpElem "{jabber:client}message"          (xp5Tuple               (xpAttrFixed   "type" "error")-              (xpAttrImplied "id"   xpPrim)-              (xpAttrImplied "from" xpPrim)-              (xpAttrImplied "to"   xpPrim)-              (xpAttrImplied xmlLang xpPrim)+              (xpAttrImplied "id"   xpId)+              (xpAttrImplied "from" xpJid)+              (xpAttrImplied "to"   xpJid)+              (xpAttrImplied xmlLang xpLang)               -- TODO: NS?          )          (xp2Tuple xpStanzaError (xpAll xpElemVerbatim))@@ -157,9 +159,9 @@         ((qid, from, to, lang, ()), (err, ext)))     (xpElem "{jabber:client}presence"          (xp5Tuple-              (xpAttrImplied "id"   xpPrim)-              (xpAttrImplied "from" xpPrim)-              (xpAttrImplied "to"   xpPrim)+              (xpAttrImplied "id"   xpId)+              (xpAttrImplied "from" xpJid)+              (xpAttrImplied "to"   xpJid)               xpLangTag               (xpAttrFixed "type" "error")          )@@ -174,9 +176,9 @@         ((qid, from, to, lang, ()), (err, body)))     (xpElem "{jabber:client}iq"          (xp5Tuple-              (xpAttr        "id"   xpPrim)-              (xpAttrImplied "from" xpPrim)-              (xpAttrImplied "to"   xpPrim)+              (xpAttr        "id"   xpId)+              (xpAttrImplied "from" xpJid)+              (xpAttrImplied "to"   xpJid)               xpLangTag               ((xpAttrFixed "type" "error"))          )@@ -196,7 +198,7 @@          (xp3Tuple               (xpElemByNamespace                    "urn:ietf:params:xml:ns:xmpp-streams"-                   xpPrim+                   xpStreamErrorCondition                    xpUnit                    xpUnit               )@@ -210,8 +212,15 @@     )  xpLangTag :: PU [Attribute] (Maybe LangTag)-xpLangTag = xpAttrImplied xmlLang xpPrim+xpLangTag = xpAttrImplied xmlLang xpLang +xpLang :: PU Text LangTag+xpLang = ("xpLang", "") <?>+    xpPartial ( \input -> case langTagFromText input of+                               Nothing -> Left "Could not parse language tag."+                               Just j -> Right j)+              langTagToText+ xmlLang :: Name xmlLang = Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml") @@ -239,8 +248,8 @@     (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream"))     (xp5Tuple          (xpAttr "version" xpId)-         (xpAttrImplied "from" xpPrim)-         (xpAttrImplied "to" xpPrim)+         (xpAttrImplied "from" xpJid)+         (xpAttrImplied "to" xpJid)          (xpAttrImplied "id" xpId)          xpLangTag     )@@ -248,17 +257,18 @@ -- 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))+    (\(tls, sasl, ver, rest) -> StreamFeatures tls (mbl sasl) ver rest)+    (\(StreamFeatures tls sasl ver rest) -> (tls, lmb sasl, ver, rest))     (xpElemNodes          (Name              "features"              (Just "http://etherx.jabber.org/streams")              (Just "stream")          )-         (xpTriple+         (xp4Tuple               (xpOption pickleTlsFeature)               (xpOption pickleSaslFeature)+              (xpOption pickleRosterVer)               (xpAll xpElemVerbatim)          )     )@@ -272,3 +282,197 @@         xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms"         (xpAll $ xpElemNodes              "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId))+    pickleRosterVer = xpElemNodes "{urn:xmpp:features:rosterver}ver" $+                           xpElemExists "{urn:xmpp:features:rosterver}optional"++xpJid :: PU Text Jid+xpJid = ("xpJid", "") <?>+        xpPartial ( \input -> case jidFromText input of+                                   Nothing -> Left "Could not parse JID."+                                   Just j -> Right j)+                  jidToText++xpIQRequestType :: PU Text IQRequestType+xpIQRequestType = ("xpIQRequestType", "") <?>+        xpPartial ( \input -> case iqRequestTypeFromText input of+                                   Nothing -> Left "Could not parse IQ request type."+                                   Just j -> Right j)+                  iqRequestTypeToText+  where+    iqRequestTypeFromText "get" = Just Get+    iqRequestTypeFromText "set" = Just Set+    iqRequestTypeFromText _ = Nothing+    iqRequestTypeToText Get = "get"+    iqRequestTypeToText Set = "set"++xpMessageType :: PU Text MessageType+xpMessageType = ("xpMessageType", "") <?>+        xpPartial ( \input -> case messageTypeFromText input of+                                   Nothing -> Left "Could not parse message type."+                                   Just j -> Right j)+                  messageTypeToText+  where+    messageTypeFromText "chat" = Just Chat+    messageTypeFromText "groupchat" = Just GroupChat+    messageTypeFromText "headline" = Just Headline+    messageTypeFromText "normal" = Just Normal+    messageTypeFromText _ = Just Normal+    messageTypeToText Chat = "chat"+    messageTypeToText GroupChat = "groupchat"+    messageTypeToText Headline = "headline"+    messageTypeToText Normal = "normal"++xpPresenceType :: PU Text PresenceType+xpPresenceType = ("xpPresenceType", "") <?>+        xpPartial ( \input -> case presenceTypeFromText input of+                                   Nothing -> Left "Could not parse presence type."+                                   Just j -> Right j)+                  presenceTypeToText+  where+    presenceTypeFromText "" = Just Available+    presenceTypeFromText "available" = Just Available+    presenceTypeFromText "unavailable" = Just Unavailable+    presenceTypeFromText "subscribe" = Just Subscribe+    presenceTypeFromText "subscribed" = Just Subscribed+    presenceTypeFromText "unsubscribe" = Just Unsubscribe+    presenceTypeFromText "unsubscribed" = Just Unsubscribed+    presenceTypeFromText "probe" = Just Probe+    presenceTypeFromText _ = Nothing+    presenceTypeToText Available = "available"+    presenceTypeToText Unavailable = "unavailable"+    presenceTypeToText Subscribe = "subscribe"+    presenceTypeToText Subscribed = "subscribed"+    presenceTypeToText Unsubscribe = "unsubscribe"+    presenceTypeToText Unsubscribed = "unsubscribed"+    presenceTypeToText Probe = "probe"++xpStanzaErrorType :: PU Text StanzaErrorType+xpStanzaErrorType = ("xpStanzaErrorType", "") <?>+        xpPartial ( \input -> case stanzaErrorTypeFromText input of+                                   Nothing -> Left "Could not parse stanza error type."+                                   Just j -> Right j)+                  stanzaErrorTypeToText+  where+    stanzaErrorTypeFromText "auth" = Just Auth+    stanzaErrorTypeFromText "cancel" = Just Cancel+    stanzaErrorTypeFromText "continue" = Just Continue+    stanzaErrorTypeFromText "modify" = Just Modify+    stanzaErrorTypeFromText "wait" = Just Wait+    stanzaErrorTypeFromText _ = Nothing+    stanzaErrorTypeToText Auth = "auth"+    stanzaErrorTypeToText Cancel = "cancel"+    stanzaErrorTypeToText Continue = "continue"+    stanzaErrorTypeToText Modify = "modify"+    stanzaErrorTypeToText Wait = "wait"++xpStanzaErrorCondition :: PU Text StanzaErrorCondition+xpStanzaErrorCondition = ("xpStanzaErrorCondition", "") <?>+        xpPartial ( \input -> case stanzaErrorConditionFromText input of+                                   Nothing -> Left "Could not parse stanza error condition."+                                   Just j -> Right j)+                  stanzaErrorConditionToText+  where+    stanzaErrorConditionToText BadRequest = "bad-request"+    stanzaErrorConditionToText Conflict = "conflict"+    stanzaErrorConditionToText FeatureNotImplemented = "feature-not-implemented"+    stanzaErrorConditionToText Forbidden = "forbidden"+    stanzaErrorConditionToText Gone = "gone"+    stanzaErrorConditionToText InternalServerError = "internal-server-error"+    stanzaErrorConditionToText ItemNotFound = "item-not-found"+    stanzaErrorConditionToText JidMalformed = "jid-malformed"+    stanzaErrorConditionToText NotAcceptable = "not-acceptable"+    stanzaErrorConditionToText NotAllowed = "not-allowed"+    stanzaErrorConditionToText NotAuthorized = "not-authorized"+    stanzaErrorConditionToText PaymentRequired = "payment-required"+    stanzaErrorConditionToText RecipientUnavailable = "recipient-unavailable"+    stanzaErrorConditionToText Redirect = "redirect"+    stanzaErrorConditionToText RegistrationRequired = "registration-required"+    stanzaErrorConditionToText RemoteServerNotFound = "remote-server-not-found"+    stanzaErrorConditionToText RemoteServerTimeout = "remote-server-timeout"+    stanzaErrorConditionToText ResourceConstraint = "resource-constraint"+    stanzaErrorConditionToText ServiceUnavailable = "service-unavailable"+    stanzaErrorConditionToText SubscriptionRequired = "subscription-required"+    stanzaErrorConditionToText UndefinedCondition = "undefined-condition"+    stanzaErrorConditionToText UnexpectedRequest = "unexpected-request"+    stanzaErrorConditionFromText "bad-request" = Just BadRequest+    stanzaErrorConditionFromText "conflict" = Just Conflict+    stanzaErrorConditionFromText "feature-not-implemented" = Just FeatureNotImplemented+    stanzaErrorConditionFromText "forbidden" = Just Forbidden+    stanzaErrorConditionFromText "gone" = Just Gone+    stanzaErrorConditionFromText "internal-server-error" = Just InternalServerError+    stanzaErrorConditionFromText "item-not-found" = Just ItemNotFound+    stanzaErrorConditionFromText "jid-malformed" = Just JidMalformed+    stanzaErrorConditionFromText "not-acceptable" = Just NotAcceptable+    stanzaErrorConditionFromText "not-allowed" = Just NotAllowed+    stanzaErrorConditionFromText "not-authorized" = Just NotAuthorized+    stanzaErrorConditionFromText "payment-required" = Just PaymentRequired+    stanzaErrorConditionFromText "recipient-unavailable" = Just RecipientUnavailable+    stanzaErrorConditionFromText "redirect" = Just Redirect+    stanzaErrorConditionFromText "registration-required" = Just RegistrationRequired+    stanzaErrorConditionFromText "remote-server-not-found" = Just RemoteServerNotFound+    stanzaErrorConditionFromText "remote-server-timeout" = Just RemoteServerTimeout+    stanzaErrorConditionFromText "resource-constraint" = Just ResourceConstraint+    stanzaErrorConditionFromText "service-unavailable" = Just ServiceUnavailable+    stanzaErrorConditionFromText "subscription-required" = Just SubscriptionRequired+    stanzaErrorConditionFromText "undefined-condition" = Just UndefinedCondition+    stanzaErrorConditionFromText "unexpected-request" = Just UnexpectedRequest+    stanzaErrorConditionFromText _ = Nothing++xpStreamErrorCondition :: PU Text StreamErrorCondition+xpStreamErrorCondition = ("xpStreamErrorCondition", "") <?>+        xpPartial ( \input -> case streamErrorConditionFromText input of+                                   Nothing -> Left "Could not parse stream error condition."+                                   Just j -> Right j)+                  streamErrorConditionToText+  where+    streamErrorConditionToText StreamBadFormat              = "bad-format"+    streamErrorConditionToText StreamBadNamespacePrefix     = "bad-namespace-prefix"+    streamErrorConditionToText StreamConflict               = "conflict"+    streamErrorConditionToText StreamConnectionTimeout      = "connection-timeout"+    streamErrorConditionToText StreamHostGone               = "host-gone"+    streamErrorConditionToText StreamHostUnknown            = "host-unknown"+    streamErrorConditionToText StreamImproperAddressing     = "improper-addressing"+    streamErrorConditionToText StreamInternalServerError    = "internal-server-error"+    streamErrorConditionToText StreamInvalidFrom            = "invalid-from"+    streamErrorConditionToText StreamInvalidNamespace       = "invalid-namespace"+    streamErrorConditionToText StreamInvalidXml             = "invalid-xml"+    streamErrorConditionToText StreamNotAuthorized          = "not-authorized"+    streamErrorConditionToText StreamNotWellFormed          = "not-well-formed"+    streamErrorConditionToText StreamPolicyViolation        = "policy-violation"+    streamErrorConditionToText StreamRemoteConnectionFailed = "remote-connection-failed"+    streamErrorConditionToText StreamReset                  = "reset"+    streamErrorConditionToText StreamResourceConstraint     = "resource-constraint"+    streamErrorConditionToText StreamRestrictedXml          = "restricted-xml"+    streamErrorConditionToText StreamSeeOtherHost           = "see-other-host"+    streamErrorConditionToText StreamSystemShutdown         = "system-shutdown"+    streamErrorConditionToText StreamUndefinedCondition     = "undefined-condition"+    streamErrorConditionToText StreamUnsupportedEncoding    = "unsupported-encoding"+    streamErrorConditionToText StreamUnsupportedFeature     = "unsupported-feature"+    streamErrorConditionToText StreamUnsupportedStanzaType  = "unsupported-stanza-type"+    streamErrorConditionToText StreamUnsupportedVersion     = "unsupported-version"+    streamErrorConditionFromText "bad-format" = Just StreamBadFormat+    streamErrorConditionFromText "bad-namespace-prefix" = Just StreamBadNamespacePrefix+    streamErrorConditionFromText "conflict" = Just StreamConflict+    streamErrorConditionFromText "connection-timeout" = Just StreamConnectionTimeout+    streamErrorConditionFromText "host-gone" = Just StreamHostGone+    streamErrorConditionFromText "host-unknown" = Just StreamHostUnknown+    streamErrorConditionFromText "improper-addressing" = Just StreamImproperAddressing+    streamErrorConditionFromText "internal-server-error" = Just StreamInternalServerError+    streamErrorConditionFromText "invalid-from" = Just StreamInvalidFrom+    streamErrorConditionFromText "invalid-namespace" = Just StreamInvalidNamespace+    streamErrorConditionFromText "invalid-xml" = Just StreamInvalidXml+    streamErrorConditionFromText "not-authorized" = Just StreamNotAuthorized+    streamErrorConditionFromText "not-well-formed" = Just StreamNotWellFormed+    streamErrorConditionFromText "policy-violation" = Just StreamPolicyViolation+    streamErrorConditionFromText "remote-connection-failed" = Just StreamRemoteConnectionFailed+    streamErrorConditionFromText "reset" = Just StreamReset+    streamErrorConditionFromText "resource-constraint" = Just StreamResourceConstraint+    streamErrorConditionFromText "restricted-xml" = Just StreamRestrictedXml+    streamErrorConditionFromText "see-other-host" = Just StreamSeeOtherHost+    streamErrorConditionFromText "system-shutdown" = Just StreamSystemShutdown+    streamErrorConditionFromText "undefined-condition" = Just StreamUndefinedCondition+    streamErrorConditionFromText "unsupported-encoding" = Just StreamUnsupportedEncoding+    streamErrorConditionFromText "unsupported-feature" = Just StreamUnsupportedFeature+    streamErrorConditionFromText "unsupported-stanza-type" = Just StreamUnsupportedStanzaType+    streamErrorConditionFromText "unsupported-version" = Just StreamUnsupportedVersion+    streamErrorConditionFromText _ = Nothing

@@ -1,6 +1,6 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}-+-- -- Submodule for functionality related to SASL negotation: -- authentication functions, SASL functionality, bind functionality, -- and the legacy `{urn:ietf:params:xml:ns:xmpp-session}session'@@ -14,51 +14,17 @@     , auth     ) where -import           Control.Applicative-import           Control.Arrow (left)-import           Control.Monad import           Control.Monad.Error import           Control.Monad.State.Strict-import           Data.Maybe (fromJust, isJust)--import qualified Crypto.Classes as CC--import qualified Data.Binary as Binary-import qualified Data.ByteString.Base64 as B64-import qualified Data.ByteString.Char8 as BS8-import qualified Data.ByteString.Lazy as BL-import qualified Data.Digest.Pure.MD5 as MD5-import qualified Data.List as L-import           Data.Word (Word8)--import qualified Data.Text as Text import           Data.Text (Text)-import qualified Data.Text.Encoding as Text--import           Network.Xmpp.Stream-import           Network.Xmpp.Types--import           System.Log.Logger (debugM, errorM)-import qualified System.Random as Random--import           Network.Xmpp.Sasl.Types-import           Network.Xmpp.Sasl.Mechanisms--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+import           Network.Xmpp.Sasl.Mechanisms+import           Network.Xmpp.Sasl.Types+import           Network.Xmpp.Stream+import           Network.Xmpp.Types+import           System.Log.Logger (debugM, errorM, infoM)  -- | Uses the first supported mechanism to authenticate, if any. Updates the -- state with non-password credentials and restarts the stream upon@@ -105,16 +71,18 @@      -> 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+    mbAuthFail <- ErrorT $ xmppSasl mechanisms con+    case mbAuthFail of+        Nothing -> do+            _jid <- ErrorT $ xmppBind resource con+            ErrorT $ flip withStream' con $ do+                s <- get+                case establishSession $ streamConfiguration s of+                    False -> return $ Right Nothing+                    True -> do+                        _ <-liftIO $ startSession con+                        return $ Right Nothing+        f -> return f  -- Produces a `bind' element, optionally wrapping a resource. bindBody :: Maybe Text -> Element@@ -133,26 +101,27 @@     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+            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+                    lift $ infoM "Pontarius.Xmpp" $ "Bound JID: " ++ show jid'+                    _ <- lift $ withStream ( do modify $ \s ->+                                                    s{streamJid = Just jid'})+                                           c                     return jid'-                otherwise -> do-                    lift $ errorM "Pontarius.XMPP" $ "xmppBind: JID could not be unpickled from: "-                        ++ show b+                _ -> do+                    lift $ errorM "Pontarius.Xmpp"+                        $ "xmppBind: JID could not be unpickled from: "+                          ++ show b                     throwError $ XmppOtherFailure-        otherwise -> do+        _ -> 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)+    xpJid' :: PU [Node] Jid+    xpJid' = xpBind $ xpElemNodes jidName (xpContent xpJid)     jidName = "{urn:ietf:params:xml:ns:xmpp-bind}jid"  -- A `bind' element pickler.@@ -163,15 +132,6 @@ 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.

@@ -4,28 +4,23 @@  module Network.Xmpp.Sasl.Common where -import           Network.Xmpp.Types- import           Control.Applicative ((<$>)) import           Control.Monad.Error-import           Control.Monad.State.Class- import qualified Data.Attoparsec.ByteString.Char8 as AP import           Data.Bits import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64-import           Data.Maybe (fromMaybe) import           Data.Maybe (maybeToList) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import           Data.Word (Word8) import           Data.XML.Pickle import           Data.XML.Types--import           Network.Xmpp.Stream+import           Network.Xmpp.Marshal import           Network.Xmpp.Sasl.StringPrep import           Network.Xmpp.Sasl.Types-import           Network.Xmpp.Marshal+import           Network.Xmpp.Stream+import           Network.Xmpp.Types  import qualified System.Random as Random @@ -66,9 +61,9 @@     AP.skipSpace     name <- AP.takeWhile1 (/= '=')     _ <- AP.char '='-    quote <- ((AP.char '"' >> return True) `mplus` return False)+    qt <- ((AP.char '"' >> return True) `mplus` return False)     content <- AP.takeWhile1 (AP.notInClass [',', '"'])-    when quote . void $ AP.char '"'+    when qt . void $ AP.char '"'     return (name, content)  -- Failure element pickler.@@ -85,10 +80,41 @@                   (xpContent xpId))         (xpElemByNamespace              "urn:ietf:params:xml:ns:xmpp-sasl"-             xpPrim+             xpSaslError              (xpUnit)              (xpUnit)))) +xpSaslError :: PU Text.Text SaslError+xpSaslError = ("xpSaslError", "") <?>+        xpPartial ( \input -> case saslErrorFromText input of+                                   Nothing -> Left "Could not parse SASL error."+                                   Just j -> Right j)+                  saslErrorToText+  where+    saslErrorToText SaslAborted              = "aborted"+    saslErrorToText SaslAccountDisabled      = "account-disabled"+    saslErrorToText SaslCredentialsExpired   = "credentials-expired"+    saslErrorToText SaslEncryptionRequired   = "encryption-required"+    saslErrorToText SaslIncorrectEncoding    = "incorrect-encoding"+    saslErrorToText SaslInvalidAuthzid       = "invalid-authzid"+    saslErrorToText SaslInvalidMechanism     = "invalid-mechanism"+    saslErrorToText SaslMalformedRequest     = "malformed-request"+    saslErrorToText SaslMechanismTooWeak     = "mechanism-too-weak"+    saslErrorToText SaslNotAuthorized        = "not-authorized"+    saslErrorToText SaslTemporaryAuthFailure = "temporary-auth-failure"+    saslErrorFromText "aborted" = Just SaslAborted+    saslErrorFromText "account-disabled" = Just SaslAccountDisabled+    saslErrorFromText "credentials-expired" = Just SaslCredentialsExpired+    saslErrorFromText "encryption-required" = Just SaslEncryptionRequired+    saslErrorFromText "incorrect-encoding" = Just SaslIncorrectEncoding+    saslErrorFromText "invalid-authzid" = Just SaslInvalidAuthzid+    saslErrorFromText "invalid-mechanism" = Just SaslInvalidMechanism+    saslErrorFromText "malformed-request" = Just SaslMalformedRequest+    saslErrorFromText "mechanism-too-weak" = Just SaslMechanismTooWeak+    saslErrorFromText "not-authorized" = Just SaslNotAuthorized+    saslErrorFromText "temporary-auth-failure" = Just SaslTemporaryAuthFailure+    saslErrorFromText _ = Nothing+ -- Challenge element pickler. xpChallenge :: PU [Node] (Maybe Text.Text) xpChallenge = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge"@@ -108,19 +134,20 @@ quote :: BS.ByteString -> BS.ByteString quote x = BS.concat ["\"",x,"\""] -saslInit :: Text.Text -> Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) Bool+saslInit :: Text.Text -> Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) () 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+        Right True -> return ()+        Right False -> throwError $ AuthStreamFailure XmppNoStream+        Left e  -> throwError $ AuthStreamFailure e  -- | Pull the next element. pullSaslElement :: ErrorT AuthFailure (StateT StreamState IO) SaslElement pullSaslElement = do-    r <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement)-    case r of+    mbse <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement)+    case mbse of         Left e -> throwError $ AuthStreamFailure e         Right (Left e) -> throwError $ AuthSaslFailure e         Right (Right r) -> return r@@ -173,13 +200,13 @@     Right r -> return r  -- | Send a SASL response element. The content will be base64-encoded.-respond :: Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) Bool+respond :: Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) () 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-+        Right False -> throwError $ AuthStreamFailure XmppNoStream+        Right True -> return ()  -- | Run the appropriate stringprep profiles on the credentials. -- May fail with 'AuthStringPrepFailure'@@ -190,12 +217,12 @@     Just creds -> return creds   where     credentials = do-    ac <- normalizeUsername authcid-    az <- case authzid of-      Nothing -> Just Nothing-      Just az' -> Just <$> normalizeUsername az'-    pw <- normalizePassword password-    return (ac, az, pw)+        ac <- normalizeUsername authcid+        az <- case authzid of+          Nothing -> Just Nothing+          Just az' -> Just <$> normalizeUsername az'+        pw <- normalizePassword password+        return (ac, az, pw)  -- | Bit-wise xor of byte strings xorBS :: BS.ByteString -> BS.ByteString -> BS.ByteString

@@ -5,37 +5,21 @@     ( digestMd5     ) where -import           Control.Applicative-import           Control.Arrow (left)-import           Control.Monad import           Control.Monad.Error import           Control.Monad.State.Strict-import           Data.Maybe (fromJust, isJust)- import qualified Crypto.Classes as CC- import qualified Data.Binary as Binary+import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BL import qualified Data.Digest.Pure.MD5 as MD5 import qualified Data.List as L--import qualified Data.Text as Text import           Data.Text (Text) import qualified Data.Text.Encoding as Text--import           Data.XML.Pickle--import qualified Data.ByteString as BS--import           Data.XML.Types--import           Network.Xmpp.Stream-import           Network.Xmpp.Types import           Network.Xmpp.Sasl.Common-import           Network.Xmpp.Sasl.StringPrep import           Network.Xmpp.Sasl.Types+import           Network.Xmpp.Types   @@ -43,19 +27,19 @@                -> 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+xmppDigestMd5 authcid' authzid' password' = do+    (ac, az, pw) <- prepCredentials authcid' authzid' password'     Just address <- gets streamAddress     xmppDigestMd5' address ac az pw   where     xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> ErrorT AuthFailure (StateT StreamState IO) ()-    xmppDigestMd5' hostname authcid authzid password = do+    xmppDigestMd5' hostname authcid _authzid password = do -- TODO: use authzid?         -- Push element and receive the challenge.         _ <- saslInit "DIGEST-MD5" Nothing -- TODO: Check boolean?-        pairs <- toPairs =<< saslFromJust =<< pullChallenge+        prs <- toPairs =<< saslFromJust =<< pullChallenge         cnonce <- liftIO $ makeNonce-        _b <- respond . Just $ createResponse hostname pairs cnonce-        challenge2 <- pullFinalMessage+        _b <- respond . Just $ createResponse hostname prs cnonce+        _challenge2 <- pullFinalMessage         return ()       where         -- Produce the response to the challenge.@@ -63,19 +47,19 @@                        -> Pairs                        -> BS.ByteString -- nonce                        -> BS.ByteString-        createResponse hostname pairs cnonce = let-            Just qop   = L.lookup "qop" pairs -- TODO: proper handling-            Just nonce = L.lookup "nonce" pairs+        createResponse hname prs cnonce = let+            Just qop   = L.lookup "qop" prs -- TODO: proper handling+            Just nonce = L.lookup "nonce" prs             uname_     = Text.encodeUtf8 authcid             passwd_    = Text.encodeUtf8 password             -- Using Int instead of Word8 for random 1.0.0.0 (GHC 7)             -- compatibility.              nc         = "00000001"-            digestURI  = "xmpp/" `BS.append` Text.encodeUtf8 hostname+            digestURI  = "xmpp/" `BS.append` Text.encodeUtf8 hname             digest     = md5Digest                 uname_-                (lookup "realm" pairs)+                (lookup "realm" prs)                 passwd_                 digestURI                 nc@@ -84,7 +68,7 @@                 cnonce             response = BS.intercalate "," . map (BS.intercalate "=") $                 [["username", quote uname_]] ++-                    case L.lookup "realm" pairs of+                    case L.lookup "realm" prs of                         Just realm -> [["realm" , quote realm ]]                         Nothing -> [] ++                             [ ["nonce"     , quote nonce    ]@@ -115,8 +99,8 @@                   -> BS8.ByteString                   -> BS8.ByteString                   -> BS8.ByteString-        md5Digest uname realm password digestURI nc qop nonce cnonce =-          let ha1 = hash [ hashRaw [uname, maybe "" id realm, password]+        md5Digest uname realm pwd digestURI nc qop nonce cnonce =+          let ha1 = hash [ hashRaw [uname, maybe "" id realm, pwd]                          , nonce                          , cnonce                          ]

@@ -8,51 +8,22 @@     ( plain     ) where -import           Control.Applicative-import           Control.Arrow (left)-import           Control.Monad import           Control.Monad.Error import           Control.Monad.State.Strict-import           Data.Maybe (fromJust, isJust)--import qualified Crypto.Classes as CC--import qualified Data.Binary as Binary-import qualified Data.ByteString.Base64 as B64-import qualified Data.ByteString.Char8 as BS8-import qualified Data.ByteString.Lazy as BL-import qualified Data.Digest.Pure.MD5 as MD5-import qualified Data.List as L-import           Data.Word (Word8)--import qualified Data.Text as Text-import           Data.Text (Text)-import qualified Data.Text.Encoding as Text--import           Data.XML.Pickle- import qualified Data.ByteString as BS--import           Data.XML.Types--import           Network.Xmpp.Stream-import           Network.Xmpp.Types--import qualified System.Random as Random--import           Data.Maybe (fromMaybe) import qualified Data.Text as Text-+import qualified Data.Text.Encoding as Text import           Network.Xmpp.Sasl.Common import           Network.Xmpp.Sasl.Types+import           Network.Xmpp.Types  -- TODO: stringprep xmppPlain :: Text.Text -- ^ Password           -> Maybe Text.Text -- ^ Authorization identity (authzid)           -> Text.Text -- ^ Authentication identity (authcid)           -> ErrorT AuthFailure (StateT StreamState IO) ()-xmppPlain authcid authzid password  = do-    (ac, az, pw) <- prepCredentials authcid authzid password+xmppPlain authcid' authzid' password  = do+    (ac, az, pw) <- prepCredentials authcid' authzid' password     _ <- saslInit "PLAIN" ( Just $ plainMessage ac az pw)     _ <- pullSuccess     return ()@@ -63,15 +34,15 @@                  -> Maybe Text.Text -- Authentication identity (authcid)                  -> Text.Text -- Password                  -> BS.ByteString -- The PLAIN message-    plainMessage authcid authzid passwd = BS.concat $-                                            [ authzid'-                                            , "\NUL"-                                            , Text.encodeUtf8 $ authcid-                                            , "\NUL"-                                            , Text.encodeUtf8 $ passwd-                                            ]+    plainMessage authcid _authzid passwd = BS.concat $+                                             [ authzid''+                                             , "\NUL"+                                             , Text.encodeUtf8 $ authcid+                                             , "\NUL"+                                             , Text.encodeUtf8 $ passwd+                                             ]       where-        authzid' = maybe "" Text.encodeUtf8 authzid+        authzid'' = maybe "" Text.encodeUtf8 authzid'  plain :: Text.Text -- ^ authentication ID (username)       -> Maybe Text.Text -- ^ authorization ID

@@ -8,32 +8,20 @@  import           Control.Applicative ((<$>)) import           Control.Monad.Error-import           Control.Monad.Trans (liftIO)-import qualified Crypto.Classes as Crypto-import qualified Crypto.HMAC as Crypto-import qualified Crypto.Hash.SHA1 as Crypto-import           Data.Binary(Binary,encode)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Base64 as B64-import           Data.ByteString.Char8  as BS8 (unpack)-import qualified Data.ByteString.Lazy as LBS+import           Control.Monad.State.Strict+import qualified Crypto.Classes          as Crypto+import qualified Crypto.HMAC             as Crypto+import qualified Crypto.Hash.CryptoAPI   as Crypto+import qualified Data.ByteString         as BS+import qualified Data.ByteString.Base64  as B64+import           Data.ByteString.Char8   as BS8 (unpack) import           Data.List (foldl1', genericTake)--import qualified Data.Binary.Builder as Build--import           Data.Maybe (maybeToList)-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text-import           Data.Word(Word8)-+import qualified Data.Text               as Text+import qualified Data.Text.Encoding      as Text 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@@ -50,18 +38,18 @@       -> Maybe Text.Text -- ^ Authorization ID       -> Text.Text       -- ^ Password       -> ErrorT AuthFailure (StateT StreamState IO) ()-scram hashToken authcid authzid password = do+scram hToken authcid authzid password = do     (ac, az, pw) <- prepCredentials authcid authzid password-    scramhelper hashToken ac az pw+    scramhelper ac az pw   where-    scramhelper hashToken authcid authzid' password = do-        cnonce <- liftIO $ makeNonce-        saslInit "SCRAM-SHA-1" (Just $ cFirstMessage cnonce)+    scramhelper authcid' authzid' pwd = do+        cnonce <- liftIO makeNonce+        _ <- saslInit "SCRAM-SHA-1" (Just $ cFirstMessage cnonce)         sFirstMessage <- saslFromJust =<< pullChallenge-        pairs <- toPairs sFirstMessage-        (nonce, salt, ic) <- fromPairs pairs cnonce+        prs <- toPairs sFirstMessage+        (nonce, salt, ic) <- fromPairs prs cnonce         let (cfm, v) = cFinalMessageAndVerifier nonce salt ic sFirstMessage cnonce-        respond $ Just cfm+        _ <- respond $ Just cfm         finalPairs <- toPairs =<< saslFromJust =<< pullFinalMessage         unless (lookup "v" finalPairs == Just v) $ throwError AuthOtherFailure -- TODO: Log         return ()@@ -71,27 +59,27 @@         encode _hashtoken = Crypto.encode          hash :: BS.ByteString -> BS.ByteString-        hash str = encode hashToken $ Crypto.hash' str+        hash str = encode hToken $ Crypto.hash' str          hmac :: BS.ByteString -> BS.ByteString -> BS.ByteString-        hmac key str = encode hashToken $ Crypto.hmac' (Crypto.MacKey key) str+        hmac key str = encode hToken $ Crypto.hmac' (Crypto.MacKey key) str -        authzid :: Maybe BS.ByteString-        authzid              = (\z -> "a=" +++ Text.encodeUtf8 z) <$> authzid'+        authzid'' :: Maybe BS.ByteString+        authzid''              = (\z -> "a=" +++ Text.encodeUtf8 z) <$> authzid'          gs2CbindFlag :: BS.ByteString         gs2CbindFlag         = "n" -- we don't support channel binding yet          gs2Header :: BS.ByteString         gs2Header            = merge $ [ gs2CbindFlag-                                        , maybe "" id authzid-                                        , ""-                                        ]-        cbindData :: BS.ByteString-        cbindData            = "" -- we don't support channel binding yet+                                       , maybe "" id authzid''+                                       , ""+                                       ]+        -- cbindData :: BS.ByteString+        -- cbindData            = "" -- we don't support channel binding yet          cFirstMessageBare :: BS.ByteString -> BS.ByteString-        cFirstMessageBare cnonce = merge [ "n=" +++ Text.encodeUtf8 authcid+        cFirstMessageBare cnonce = merge [ "n=" +++ Text.encodeUtf8 authcid'                                          , "r=" +++ cnonce]         cFirstMessage :: BS.ByteString -> BS.ByteString         cFirstMessage cnonce = gs2Header +++ cFirstMessageBare cnonce@@ -99,13 +87,13 @@         fromPairs :: Pairs                   -> BS.ByteString                   -> 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-                               , Right salt <- B64.decode salt'-                               , Just ic <- lookup "i" pairs-                               , [(i,"")] <- reads $ BS8.unpack ic-                               = return (nonce, salt, i)+        fromPairs prs cnonce | Just nonce <- lookup "r" prs+                             , cnonce `BS.isPrefixOf` nonce+                             , Just salt' <- lookup "s" prs+                             , Right salt <- B64.decode salt'+                             , Just ic <- lookup "i" prs+                             , [(i,"")] <- reads $ BS8.unpack ic+                             = return (nonce, salt, i)         fromPairs _ _ = throwError $ AuthOtherFailure -- TODO: Log          cFinalMessageAndVerifier :: BS.ByteString@@ -126,7 +114,7 @@                                          , "r=" +++ nonce]              saltedPassword :: BS.ByteString-            saltedPassword       = hi (Text.encodeUtf8 password) salt ic+            saltedPassword       = hi (Text.encodeUtf8 pwd) salt ic              clientKey :: BS.ByteString             clientKey            = hmac saltedPassword "Client Key"@@ -154,9 +142,9 @@              -- helper             hi :: BS.ByteString -> BS.ByteString -> Integer -> BS.ByteString-            hi str salt ic = foldl1' xorBS (genericTake ic us)+            hi str slt ic' = foldl1' xorBS (genericTake ic' us)               where-                u1 = hmac str (salt +++ (BS.pack [0,0,0,1]))+                u1 = hmac str (slt +++ (BS.pack [0,0,0,1]))                 us = iterate (hmac str) u1  scramSha1 :: Text.Text  -- ^ username

@@ -4,27 +4,34 @@  import Text.StringPrep import qualified Data.Set as Set-import Data.Text(singleton)+import Data.Text(Text, singleton) +nonAsciiSpaces :: Set.Set Char nonAsciiSpaces = Set.fromList [ '\x00A0', '\x1680', '\x2000', '\x2001', '\x2002'                               , '\x2003', '\x2004', '\x2005', '\x2006', '\x2007'                               , '\x2008', '\x2009', '\x200A', '\x200B', '\x202F'                               , '\x205F', '\x3000'                               ] +toSpace :: Char -> Text toSpace x = if x `Set.member` nonAsciiSpaces then " " else singleton x +saslPrepQuery :: StringPrepProfile saslPrepQuery = Profile     [b1, toSpace]     True     [c12, c21, c22, c3, c4, c5, c6, c7, c8, c9]     True +saslPrepStore :: StringPrepProfile saslPrepStore = Profile     [b1, toSpace]     True     [a1, c12, c21, c22, c3, c4, c5, c6, c7, c8, c9]     True +normalizePassword :: Text -> Maybe Text normalizePassword = runStringPrep saslPrepStore++normalizeUsername :: Text -> Maybe Text normalizeUsername = runStringPrep saslPrepQuery

@@ -1,30 +1,10 @@ {-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Sasl.Types where -import           Control.Monad.Error import           Control.Monad.State.Strict import           Data.ByteString(ByteString) import qualified Data.Text as Text import           Network.Xmpp.Types---- | 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 AuthFailure where-    noMsg = AuthOtherFailure  data SaslElement = SaslSuccess   (Maybe Text.Text)                  | SaslChallenge (Maybe Text.Text)

@@ -0,0 +1,56 @@+{-# LANGUAGE RecordWildCards #-}++{-# OPTIONS_HADDOCK hide #-}++-- | Stanza related functions and constants+--++module Network.Xmpp.Stanza where++import Data.XML.Types+import Network.Xmpp.Types++-- | Request subscription with an entity.+presenceSubscribe :: Jid -> Presence+presenceSubscribe to = presence { presenceTo = Just to+                                , presenceType = Subscribe+                                }++-- | Approve a subscripton of an entity.+presenceSubscribed :: Jid -> Presence+presenceSubscribed to = presence { presenceTo = Just to+                                 , presenceType = Subscribed+                                 }++-- | End a subscription with an entity.+presenceUnsubscribe :: Jid -> Presence+presenceUnsubscribe to = presence { presenceTo = Just to+                                  , presenceType = Unsubscribed+                                  }++-- | 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 = Unavailable}++-- | Produce an answer message with the given payload, setting "from" to the+-- "to" attributes in the original message. Produces a 'Nothing' value of the+-- provided message message has no "from" attribute. Sets the "from" attribute+-- to 'Nothing' to let the server assign one.+answerMessage :: Message -> [Element] -> Maybe Message+answerMessage Message{messageFrom = Just frm, ..} payload =+    Just Message{ messageFrom    = Nothing+                , messageID      = Nothing+                , messageTo      = Just frm+                , messagePayload = payload+                , ..+                }+answerMessage _ _ = Nothing++-- | Add a recipient to a presence notification.+presTo :: Presence -> Jid -> Presence+presTo pres to = pres{presenceTo = Just to}

@@ -7,54 +7,46 @@  module Network.Xmpp.Stream where -import           Control.Applicative ((<$>), (<*>))+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           Control.Monad.Trans.Resource as R+import           Data.ByteString (ByteString) import qualified Data.ByteString as BS-import           Data.ByteString.Base64-import           Data.ByteString.Char8 as BSC8+import qualified Data.ByteString.Char8 as BSC8+import           Data.Char (isSpace) import           Data.Conduit-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.IP+import           Data.List+import           Data.Maybe+import           Data.Ord import           Data.Text (Text) import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text import           Data.Void (Void) import           Data.XML.Pickle import           Data.XML.Types import qualified GHC.IO.Exception as GIE import           Network+import           Network.DNS hiding (encode, lookup) import           Network.Xmpp.Marshal import           Network.Xmpp.Types import           System.IO-import           System.IO.Error (tryIOError)+-- import           System.IO.Error (tryIOError) <- Only available in base >=4.4 import           System.Log.Logger+import           System.Random (randomRIO) 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@@ -72,6 +64,17 @@ lmb [] = Nothing lmb x = Just x +pushing  :: MonadIO m =>+               m (Either XmppFailure Bool)+            -> ErrorT XmppFailure m ()+pushing m = do+    res <- ErrorT m+    case res of+        True -> return ()+        False -> do+            liftIO $ debugM "Pontarius.Xmpp" "Failed to send data."+            throwError XmppOtherFailure+ -- Unpickles and returns a stream element. streamUnpickleElem :: PU [Node] a                    -> Element@@ -85,7 +88,7 @@  -- This is the conduit sink that handles the stream XML events. We extend it -- with ErrorT capabilities.-type StreamSink a = ErrorT XmppFailure (Pipe Event Event Void () IO) a+type StreamSink a = ErrorT XmppFailure (ConduitM Event Void IO) a  -- Discards all events before the first EventBeginElement. throwOutJunk :: Monad m => Sink Event m ()@@ -114,55 +117,63 @@ startStream :: StateT StreamState IO (Either XmppFailure ()) startStream = runErrorT $ do     lift $ lift $ debugM "Pontarius.Xmpp" "Starting stream..."-    state <- lift $ get+    st <- 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+    let expectedTo = case ( streamConnectionState st+                          , toJid $ streamConfiguration st) of+          (Plain    , (Just (jid, True)))  -> Just jid+          (Plain    , _                 )  -> Nothing+          (Secured  , (Just (jid, _   )))  -> Just jid+          (Secured  , Nothing           )  -> Nothing+          (Closed   , _                 )  -> Nothing+          (Finished , _                 )  -> Nothing+    case streamAddress st of         Nothing -> do-            lift $ lift $ errorM "Pontarius.XMPP" "Server sent no hostname."+            lift $ lift $ errorM "Pontarius.Xmpp" "Server sent no hostname."             throwError XmppOtherFailure-        Just address -> lift $ do-            pushXmlDecl-            pushOpenElement $+        Just address -> do+            pushing pushXmlDecl+            pushing . pushOpenElement . streamNSHack $                 pickleElem xpStream ( "1.0"                                     , expectedTo                                     , Just (Jid Nothing address Nothing)                                     , Nothing-                                    , preferredLang $ streamConfiguration state+                                    , preferredLang $ streamConfiguration st                                     )     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))+      Right (ver, from, to, sid, 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)) ->++    -- HACK: We ignore MUST-strength requirement (section 4.7.4. of RFC+    -- 6120) for the sake of compatibility with jabber.org+        --  | 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 st) Nothing)) ->             closeStreamWithError StreamInvalidFrom Nothing                 "Stream from is invalid"         | to /= expectedTo ->             closeStreamWithError StreamUndefinedCondition (Just $ Element "invalid-to" [] [])                 "Stream to invalid"-- TODO: Suitable?         | otherwise -> do+            -- HACK: (ignore section 4.7.4. of RFC 6120), see above+            unless (isJust lt) $ liftIO $ warningM "Pontariusm.Xmpp"+                "Stream has no language tag"             modify (\s -> s{ streamFeatures = features                            , streamLang = lt-                           , streamId = id+                           , streamId = sid                            , streamFrom = from                          } )             return ()       -- Unpickling failed - we investigate the element.-      Right (Left (Element name attrs children))+      Left (Element name attrs _children)         | (nameLocalName name /= "stream") ->             closeStreamWithError StreamInvalidXml Nothing                "Root element is not stream"@@ -174,21 +185,23 @@                 "Root name prefix set and not stream"         | otherwise -> ErrorT $ checkchildren (flattenAttrs attrs)   where-    -- closeStreamWithError :: MonadIO m => Stream -> StreamErrorCondition ->-    --                         Maybe Element -> ErrorT XmppFailure m ()+    -- HACK: We include the default namespace to make isode's M-LINK server happy.+    streamNSHack e = e{elementAttributes = elementAttributes e+                                           ++ [( "xmlns"+                                               , [ContentText "jabber:client"])]}     closeStreamWithError  :: StreamErrorCondition -> Maybe Element -> String                           -> ErrorT XmppFailure (StateT StreamState IO) ()     closeStreamWithError sec el msg = do-        lift . pushElement . pickleElem xpStreamError+        void . lift . pushElement . pickleElem xpStreamError             $ StreamErrorInfo sec Nothing el-        lift $ closeStreams'-        lift $ lift $ errorM "Pontarius.XMPP" $ "closeStreamWithError: " ++ msg+        void . lift $ closeStreams'+        liftIO $ 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') ->+          in case () of () | Just Nothing == fmap jidFromText to' ->                                runErrorT $ closeStreamWithError                                    StreamBadNamespacePrefix Nothing                                    "stream to not a valid JID"@@ -206,12 +219,12 @@                                    ""     safeRead x = case reads $ Text.unpack x of         [] -> Nothing-        [(y,_),_] -> Just y+        ((y,_):_) -> Just y  flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)]-flattenAttrs attrs = Prelude.map (\(name, content) ->+flattenAttrs attrs = Prelude.map (\(name, cont) ->                              ( name-                             , Text.concat $ Prelude.map uncontentify content)+                             , Text.concat $ Prelude.map uncontentify cont)                              )                          attrs   where@@ -222,19 +235,50 @@ -- and calls 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 })+    liftIO $ debugM "Pontarius.Xmpp" "Restarting stream..."+    raw <- gets streamHandle+    let newSource = sourceStreamHandle raw $= XP.parseBytes def+    buffered <- liftIO . bufferSrc $ newSource+    modify (\s -> s{streamEventSource = buffered })     startStream+++sourceStreamHandle :: MonadIO m => StreamHandle -> ConduitM i ByteString m ()+sourceStreamHandle s = loopRead $ streamReceive s   where-    loopRead read = do-        bs <- liftIO (read 4096)+    loopRead rd = do+        bs <- liftIO (rd 4096)         if BS.null bs             then return ()-            else yield bs >> loopRead read+            else do+               liftIO $ debugM "Pontarius.Xmpp" $ "in: " +++                              (Text.unpack . Text.decodeUtf8 $ bs)+               yield bs+               loopRead rd +-- We buffer sources because we don't want to lose data when multiple+-- xml-entities are sent with the same packet and we don't want to eternally+-- block the StreamState while waiting for data to arrive+bufferSrc :: MonadIO m => Source IO o -> IO (ConduitM i o m ())+bufferSrc src = do+    ref <- newTMVarIO $ DCI.ResumableSource src (return ())+    let go = do+            dt <- liftIO $ Ex.bracketOnError (atomically $ takeTMVar ref)+                                          (\_ -> atomically . putTMVar ref $+                                                 DCI.ResumableSource zeroSource+                                                                     (return ())+                                          )+                                          (\s -> do+                                                (s', dt) <- s $$++ CL.head+                                                atomically $ putTMVar ref s'+                                                return dt+                                          )+            case dt of+                Nothing -> return ()+                Just d -> yield d >> go+    return go++ -- Reads the (partial) stream:stream and the server features from the stream. -- Returns the (unvalidated) stream attributes, the unparsed element, or -- throwError throws a `XmppOtherFailure' (if something other than an element@@ -247,12 +291,12 @@                                                    , Maybe Text                                                    , Maybe LangTag                                                    , StreamFeatures ))-streamS expectedTo = do-    header <- xmppStreamHeader-    case header of-      Right (version, from, to, id, langTag) -> do+streamS _expectedTo = do -- TODO: check expectedTo+    streamHeader <- xmppStreamHeader+    case streamHeader of+      Right (version, from, to, sid, lTag) -> do         features <- xmppStreamFeatures-        return $ Right (version, from, to, id, langTag, features)+        return $ Right (version, from, to, sid, lTag, features)       Left el -> return $ Left el   where     xmppStreamHeader :: StreamSink (Either Element (Text, Maybe Jid, Maybe Jid, Maybe Text.Text, Maybe LangTag))@@ -270,7 +314,7 @@         e <- lift $ elements =$ CL.head         case e of             Nothing -> do-                lift $ lift $ errorM "Pontarius.XMPP" "streamS: Stream ended."+                lift $ lift $ errorM "Pontarius.Xmpp" "streamS: Stream ended."                 throwError XmppOtherFailure             Just r -> streamUnpickleElem xpStreamFeatures r @@ -278,39 +322,49 @@ -- realm. openStream :: HostName -> StreamConfiguration -> IO (Either XmppFailure (Stream)) openStream realm config = runErrorT $ do-    lift $ debugM "Pontarius.XMPP" "Opening stream..."+    lift $ debugM "Pontarius.Xmpp" "Opening stream..."     stream' <- createStream realm config-    result <- liftIO $ withStream startStream stream'+    ErrorT . 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])+-- | 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 () closeStreams = withStream closeStreams' +closeStreams' :: StateT StreamState IO () closeStreams' = do-    lift $ debugM "Pontarius.XMPP" "Closing stream..."+    lift $ debugM "Pontarius.Xmpp" "Closing stream"     send <- gets (streamSend . streamHandle)     cc <- gets (streamClose . streamHandle)-    liftIO $ send "</stream:stream>"+    lift $ debugM "Pontarius.Xmpp" "Sending closing tag"+    void . liftIO $ send "</stream:stream>"+    lift $ debugM "Pontarius.Xmpp" "Waiting for stream to close"     void $ liftIO $ forkIO $ do         threadDelay 3000000 -- TODO: Configurable value-        (Ex.try cc) :: IO (Either Ex.SomeException ())+        void ((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)+    put xmppNoStream{ streamConnectionState = Finished }+--     lift $ debugM "Pontarius.Xmpp" "Collecting remaining elements"+--     es <- collectElems []+    -- lift $ debugM "Pontarius.Xmpp" "Stream sucessfully closed"+    -- return es+  -- 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)  -- TODO: Can the TLS send/recv functions throw something other than an IO error?+debugOut :: MonadIO m => ByteString -> m ()+debugOut outData = liftIO $ debugM "Pontarius.Xmpp"+             ("Out: " ++ (Text.unpack . Text.decodeUtf8 $ outData))  wrapIOException :: IO a -> StateT StreamState IO (Either XmppFailure a) wrapIOException action = do@@ -318,14 +372,32 @@     case r of         Right b -> return $ Right b         Left e -> do-            lift $ warningM "Pontarius.XMPP" $ "wrapIOException: Exception wrapped: " ++ (show e)+            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+    let outData = renderElement $ nsHack x+    debugOut outData+    wrapIOException $ send  outData+  where+    -- HACK: We remove the "jabber:client" namespace because it is set as+    -- default in the stream. This is to make isode's M-LINK server happy and+    -- should be removed once jabber.org accepts prefix-free canonicalization +nsHack :: Element -> Element+nsHack e@(Element{elementName = n})+    | nameNamespace n == Just "jabber:client" =+        e{ elementName = Name (nameLocalName n) Nothing Nothing+         , elementNodes = map mapNSHack $ elementNodes e+         }+    | otherwise = e+  where+    mapNSHack :: Node -> Node+    mapNSHack (NodeElement el) = NodeElement $ nsHack el+    mapNSHack nd = nd+ -- | Encode and send stanza pushStanza :: Stanza -> Stream -> IO (Either XmppFailure Bool) pushStanza s = withStream' . pushElement $ pickleElem xpStanza s@@ -341,57 +413,57 @@  pushOpenElement :: Element -> StateT StreamState IO (Either XmppFailure Bool) pushOpenElement e = do-    sink <- gets (streamSend . streamHandle)-    wrapIOException $ sink $ renderOpenElement e+    send <- gets (streamSend . streamHandle)+    let outData = renderOpenElement e+    debugOut outData+    wrapIOException $ send outData  -- `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 :: Sink Event IO b -> StateT StreamState IO b runEventsSink snk = do -- TODO: Wrap exceptions?     src <- gets streamEventSource-    (src', r) <- lift $ src $$++ snk-    modify (\s -> s{streamEventSource = src'})-    return $ Right r+    r <- liftIO $ src $$ snk+    return  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."+            Nothing -> do+                lift $ errorM "Pontarius.Xmpp" "pullElement: Stream ended."                 return . Left $ XmppOtherFailure-            Right (Just r) -> return $ Right r+            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)+                            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)+                            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+    el <- pullElement+    case el 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)+                    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+pullStanza = withStream' $ do     res <- pullUnpickle xpStreamStanza     case res of         Left e -> return $ Left e@@ -409,20 +481,23 @@          _ -> ExL.throwIO e     ) +zeroHandle :: StreamHandle+zeroHandle = StreamHandle { streamSend = \_ -> return False+                          , streamReceive = \_ -> do+                                 errorM "Pontarius.Xmpp"+                                        "xmppNoStream: Stream is closed."+                                 ExL.throwIO XmppOtherFailure+                          , streamFlush = return ()+                          , streamClose = return ()+                          }+ -- 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 [] []+    , streamHandle = zeroHandle+    , streamEventSource = zeroSource+    , streamFeatures = StreamFeatures Nothing [] Nothing []     , streamAddress = Nothing     , streamFrom = Nothing     , streamId = Nothing@@ -430,33 +505,34 @@     , streamJid = Nothing     , streamConfiguration = def     }-  where-    zeroSource :: Source IO output-    zeroSource = liftIO $ do-        errorM "Pontarius.XMPP" "zeroSource utilized."-        ExL.throwIO XmppOtherFailure +zeroSource :: Source IO output+zeroSource = liftIO $ do+    debugM "Pontarius.Xmpp" "zeroSource"+    ExL.throwIO XmppOtherFailure++handleToStreamHandle :: Handle -> StreamHandle+handleToStreamHandle h = StreamHandle { streamSend = \d -> catchPush $ BS.hPut h d+                                      , streamReceive = \n -> BS.hGetSome h n+                                      , streamFlush = hFlush h+                                      , streamClose = hClose h+                                      }+ createStream :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (Stream) createStream realm config = do     result <- connect realm config     case result of-        Just h -> ErrorT $ do+        Just hand -> 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-                                    }+            eSource <- liftIO . bufferSrc $+                         (sourceStreamHandle hand $= logConduit)+                           $= XP.parseBytes def             let stream = StreamState                   { streamConnectionState = Plain                   , streamHandle = hand                   , streamEventSource = eSource-                  , streamFeatures = StreamFeatures Nothing [] []+                  , streamFeatures = StreamFeatures Nothing [] Nothing []                   , streamAddress = Just $ Text.pack realm                   , streamFrom = Nothing                   , streamId = Nothing@@ -472,7 +548,7 @@   where     logConduit :: Conduit ByteString IO ByteString     logConduit = CL.mapM $ \d -> do-        debugM "Pontarius.Xmpp" $ "Received TCP data: " ++ (BSC8.unpack d) +++        debugM "Pontarius.Xmpp" $ "In: " ++ (BSC8.unpack d) ++             "."         return d @@ -481,81 +557,100 @@ -- 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 :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO+           (Maybe StreamHandle) 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'+    case connectionDetails config of+        UseHost host port -> lift $ do+            debugM "Pontarius.Xmpp" "Connecting to configured address."+            h <- connectTcp $ [(host, port)]+            case h of+                Nothing -> return Nothing+                Just h' -> do+                    liftIO $ hSetBuffering h' NoBuffering+                    return . Just $ handleToStreamHandle h'+        UseSrv host -> do+            h <- connectSrv (resolvConf config) host+            case h of+                Nothing -> return Nothing+                Just h' -> do+                    liftIO $ hSetBuffering h' NoBuffering+                    return . Just $ handleToStreamHandle h'+        UseRealm -> do+            h <- connectSrv (resolvConf config) realm+            case h of+                Nothing -> return Nothing+                Just h' -> do+                    liftIO $ hSetBuffering h' NoBuffering+                    return . Just $ handleToStreamHandle h'+        UseConnection mkC -> Just <$> mkC++connectSrv :: ResolvConf -> String -> ErrorT XmppFailure IO (Maybe Handle)+connectSrv config host = do+    case checkHostName (Text.pack host) of+        Just host' -> do+            resolvSeed <- lift $ makeResolvSeed config+            lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..."+            srvRecords <- srvLookup host' resolvSeed+            case srvRecords of+                Nothing -> do+                    lift $ debugM "Pontarius.Xmpp"+                        "No SRV records, using fallback process."+                    lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ host)+                                               5222+                Just srvRecords' -> do+                    lift $ debugM "Pontarius.Xmpp"+                        "SRV records found, performing A/AAAA lookups."+                    lift $ resolvSrvsAndConnectTcp resolvSeed srvRecords'         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+                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 " +++connectTcp :: [(HostName, PortID)] -> IO (Maybe Handle)+connectTcp [] = return Nothing+connectTcp ((address, port):remainder) = do+    result <- Ex.try $ (do+        debugM "Pontarius.Xmpp" $ "Connecting to " ++ address ++ " on port " ++             (show port) ++ "."-        connectTo address (PortNumber $ fromIntegral port)) :: IO (Either IOException Handle)+        connectTo address port) :: IO (Either Ex.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+            connectTcp remainder  -- 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]))+    aaaaResults <- (Ex.try $ rethrowErrorCall $ withResolver resolvSeed $+                        \resolver -> lookupAAAA resolver domain) :: IO (Either Ex.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+        Right (Just ipv6s) -> connectTcp $+                                  map (\ip -> ( show ip+                                                , PortNumber $ fromIntegral 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]))+            aResults <- (Ex.try $ rethrowErrorCall $ withResolver resolvSeed $+                             \resolver -> lookupA resolver domain) :: IO (Either Ex.IOException (Maybe [IPv4]))             handle' <- case aResults of+                Left  _       -> return Nothing                 Right Nothing -> return Nothing-                Right (Just ipv4s) -> connectTcp $ Right $ Data.List.map (\ipv4 -> (show ipv4, port)) ipv4s++                Right (Just ipv4s) -> connectTcp $+                                          map (\ip -> (show ip+                                                        , PortNumber+                                                          $ fromIntegral port))+                                              ipv4s             case handle' of                 Nothing -> return Nothing                 Just handle'' -> return $ Just handle''@@ -576,29 +671,30 @@ -- exceptions and rethrows them as IOExceptions. rethrowErrorCall :: IO a -> IO a rethrowErrorCall action = do-    result <- try action+    result <- Ex.try action     case result of         Right result' -> return result'-        Left (ErrorCall e) -> ioError $ userError $ "rethrowErrorCall: " ++ e-        Left e -> throwIO e+        Left (Ex.ErrorCall e) -> Ex.ioError $ userError+                                 $ "rethrowErrorCall: " ++ 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+    result <- Ex.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 []+            Just srvResult' -> do+                debugM "Pontarius.Xmpp" $ "SRV result: " ++ (show srvResult')+                -- Get [(Domain, PortNumber)] of SRV request, if any.+                orderedSrvResult <- orderSrvResult srvResult'+                return $ Just $ Prelude.map (\(_, _, port, domain) -> (domain, port)) orderedSrvResult+            -- The service is not available at this domain.+            -- Sorts the records based on the priority value.             Nothing -> do                 debugM "Pontarius.Xmpp" "No SRV result returned."                 return Nothing@@ -629,7 +725,7 @@         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+            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)@@ -638,55 +734,56 @@             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])+            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)+            rest <- orderSublist sublist''+            return $ ((priority, weight, port, domain):rest) --- Closes the connection and updates the XmppConMonad Stream state.--- killStream :: Stream -> IO (Either ExL.SomeException ())+-- | Close the connection and updates the XmppConMonad Stream state. Does+-- not send the stream end tag. killStream :: Stream -> IO (Either XmppFailure ()) killStream = withStream $ do     cc <- gets (streamClose . streamHandle)     err <- wrapIOException cc     -- (ExL.try cc :: IO (Either ExL.SomeException ()))-    put xmppNoStream+    put xmppNoStream{ streamConnectionState = Finished }     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+pushIQ :: Text        -> 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+pushIQ iqID to tp lang body stream = runErrorT $ do+    pushing $ pushStanza+        (IQRequestS $ IQRequest iqID Nothing to lang tp body) stream+    res <- lift $ pullStanza stream     case res of-        Left e -> return $ Left e-        Right (IQErrorS e) -> return $ Right $ Left e+        Left e -> throwError e+        Right (IQErrorS e) -> return $ 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+                    liftIO $ errorM "Pontarius.Xmpp" $ "pushIQ: ID mismatch (" ++ (show iqID) ++ " /= " ++ (show $ iqResultID r) ++ ")."+                    liftIO $ ExL.throwIO XmppOtherFailure                 -- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++                 -- " /= " ++ show (iqResultID r) ++ " .")-            return $ Right $ Right r+            return $ Right r         _ -> do-                 errorM "Pontarius.XMPP" $ "pushIQ: Unexpected stanza type."-                 return . Left $ XmppOtherFailure+                 liftIO $ errorM "Pontarius.Xmpp" $ "pushIQ: Unexpected stanza type."+                 throwError XmppOtherFailure -debugConduit :: Pipe l ByteString ByteString u IO b+debugConduit :: (Show o, MonadIO m) => ConduitM o o m b debugConduit = forever $ do     s' <- await     case s' of         Just s ->  do-            liftIO $ debugM "Pontarius.XMPP" $ "debugConduit: In: " ++ (show s)+            liftIO $ debugM "Pontarius.Xmpp" $ "debugConduit: In: " ++ (show s)             yield s         Nothing -> return () @@ -697,7 +794,11 @@             Just (EventBeginElement n as) -> do                                                  goE n as >>= yield                                                  elements-            Just (EventEndElement streamName) -> lift $ R.monadThrow StreamEnd+            -- This might be an XML error if the end element tag is not+            -- "</stream>". TODO: We might want to check this at a later time+            Just (EventEndElement _) -> lift $ R.monadThrow StreamEnd+            Just (EventContent (ContentText ct)) | Text.all isSpace ct ->+                elements             Nothing -> return ()             _ -> lift $ R.monadThrow $ InvalidXmppXml $ "not an element: " ++ show x   where@@ -707,8 +808,8 @@         go front = do             x <- f             case x of-                Left x -> return $ (x, front [])-                Right y -> go (front . (:) y)+                Left l -> return $ (l, front [])+                Right r -> go (front . (:) r)     goE n as = do         (y, ns) <- many' goN         if y == Just (EventEndElement n)@@ -732,11 +833,8 @@         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+withStream :: StateT StreamState IO a -> Stream -> IO a+withStream action (Stream stream) = Ex.bracketOnError                                          (atomically $ takeTMVar stream )                                          (atomically . putTMVar stream)                                          (\s -> do@@ -746,12 +844,16 @@                                          )  -- nonblocking version. Changes to the connection are ignored!-withStream' :: StateT StreamState IO (Either XmppFailure b) -> Stream -> IO (Either XmppFailure b)+withStream' :: StateT StreamState IO a -> Stream -> IO a 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)+mkStream :: StreamState -> IO Stream+mkStream con = Stream `fmap` atomically (newTMVar con)++-- "Borrowed" from base-4.4 for compatibility with GHC 7.0.1.+tryIOError :: IO a -> IO (Either IOError a)+tryIOError f = Ex.catch (Right <$> f) (return . Left)

@@ -4,7 +4,6 @@  module Network.Xmpp.Tls where -import           Control.Concurrent.STM.TMVar import qualified Control.Exception.Lifted as Ex import           Control.Monad import           Control.Monad.Error@@ -14,21 +13,31 @@ 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.DNS.Resolver (ResolvConf) import           Network.TLS-import           Network.TLS.Extra import           Network.Xmpp.Stream import           Network.Xmpp.Types-import           System.Log.Logger (debugM, errorM)+import           System.Log.Logger (debugM, errorM, infoM) +mkBackend :: StreamHandle -> Backend mkBackend con = Backend { backendSend = \bs -> void (streamSend con bs)-                        , backendRecv = streamReceive con+                        , backendRecv = bufferReceive (streamReceive con)                         , backendFlush = streamFlush con                         , backendClose = streamClose con                         }+  where+    bufferReceive _ 0 = return BS.empty+    bufferReceive recv n = BS.concat `liftM` (go n)+      where+        go m = do+            bs <- recv m+            case BS.length bs of+                0 -> return []+                l -> if l < m+                     then (bs :) `liftM` go (m - l)+                     else return [bs]  starttlsE :: Element starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] []@@ -43,49 +52,63 @@     case sState of         Plain -> return ()         Closed -> do-            liftIO $ errorM "Pontarius.XMPP" "startTls: The stream is closed."+            liftIO $ errorM "Pontarius.Xmpp.Tls" "The stream is closed."             throwError XmppNoStream+        Finished -> do+            liftIO $ errorM "Pontarius.Xmpp.Tls" "The stream is finished."+            throwError XmppNoStream         Secured -> do-            liftIO $ errorM "Pontarius.XMPP" "startTls: The stream is already secured."+            liftIO $ errorM "Pontarius.Xmpp.Tls" "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 ()+        (PreferTls   , Nothing  ) -> skipTls         (PreferPlain , Just True) -> startTls-        (PreferPlain , _        ) -> return ()+        (PreferPlain , _        ) -> skipTls         (RefuseTls   , Just True) -> throwError XmppOtherFailure-        (RefuseTls   , _        ) -> return ()+        (RefuseTls   , _        ) -> skipTls   where+    skipTls = liftIO $ infoM "Pontarius.Xmpp.Tls" "Skipping TLS negotiation"     startTls = do+        liftIO $ infoM "Pontarius.Xmpp.Tls" "Running StartTLS"         params <- gets $ tlsParams . streamConfiguration-        lift $ pushElement starttlsE+        sent <- ErrorT $ pushElement starttlsE+        unless sent $ do+            liftIO $ errorM "Pontarius.Xmpp.Tls" "Could not sent stanza."+            throwError XmppOtherFailure         answer <- lift $ pullElement         case answer of-            Left e -> return $ Left e+            Left e -> throwError e             Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] []) ->-                return $ Right ()+                return ()             Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _) -> do-                liftIO $ errorM "Pontarius.XMPP" "startTls: TLS initiation failed."-                return . Left $ XmppOtherFailure+                liftIO $ errorM "Pontarius.Xmpp" "startTls: TLS initiation failed."+                throwError XmppOtherFailure+            Right r ->+                liftIO $ errorM "Pontarius.Xmpp.Tls" $+                            "Unexpected element: " ++ show r         hand <- gets streamHandle-        (raw, _snk, psh, read, ctx) <- lift $ tlsinit params (mkBackend hand)+        (_raw, _snk, psh, recv, ctx) <- lift $ tlsinit params (mkBackend hand)         let newHand = StreamHandle { streamSend = catchPush . psh-                                       , streamReceive = read-                                       , streamFlush = contextFlush ctx-                                       , streamClose = bye ctx >> streamClose hand-                                       }+                                   , streamReceive = recv+                                   , streamFlush = contextFlush ctx+                                   , streamClose = bye ctx >> streamClose hand+                                   }         lift $ modify ( \x -> x {streamHandle = newHand})+        liftIO $ infoM "Pontarius.Xmpp.Tls" "Stream Secured."         either (lift . Ex.throwIO) return =<< lift restartStream         modify (\s -> s{streamConnectionState = Secured})         return () +client :: (MonadIO m, CPRG rng) => Params -> rng -> Backend -> m Context client params gen backend  = do     contextNew backend params gen -defaultParams = defaultParamsClient+xmppDefaultParams :: Params+xmppDefaultParams = defaultParamsClient  tlsinit :: (MonadIO m, MonadIO m1) =>         TLSParams@@ -96,14 +119,14 @@           , Int -> m1 BS.ByteString           , Context           )-tlsinit tlsParams backend = do-    liftIO $ debugM "Pontarius.Xmpp.TLS" "TLS with debug mode enabled."+tlsinit params 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+    con <- client params gen backend     handshake con     let src = forever $ do             dt <- liftIO $ recvData con-            liftIO $ debugM "Pontarius.Xmpp.TLS" ("in :" ++ BSC8.unpack dt)+            liftIO $ debugM "Pontarius.Xmpp.Tls" ("In :" ++ BSC8.unpack dt)             yield dt     let snk = do             d <- await@@ -111,27 +134,44 @@                 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)+    readWithBuffer <- 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+             -- Note: sendData already sends the data to the debug output+           , \s -> sendData con $ BL.fromChunks [s]+           , liftIO . readWithBuffer            , con            )  mkReadBuffer :: IO BS.ByteString -> IO (Int -> IO BS.ByteString)-mkReadBuffer read = do+mkReadBuffer recv = do     buffer <- newIORef BS.empty     let read' n = do             nc <- readIORef buffer-            bs <- if BS.null nc then read+            bs <- if BS.null nc then recv                                 else return nc             let (result, rest) = BS.splitAt n bs             writeIORef buffer rest             return result     return read'++-- | Connect to an XMPP server and secure the connection with TLS before+-- starting the XMPP streams+connectTls :: ResolvConf -- ^ Resolv conf to use (try defaultResolvConf as a+                         -- default)+           -> TLSParams  -- ^ TLS parameters to use when securing the connection+           -> String     -- ^ Host to use when connecting (will be resolved+                         -- using SRV records)+           -> ErrorT XmppFailure IO StreamHandle+connectTls config params host = do+    h <- connectSrv config host >>= \h' -> case h' of+        Nothing -> throwError TcpConnectionFailure+        Just h'' -> return h''+    let hand = handleToStreamHandle h+    (_raw, _snk, psh, recv, ctx) <- tlsinit params $ mkBackend hand+    return $ StreamHandle { streamSend = catchPush . psh+                          , streamReceive = recv+                          , streamFlush = contextFlush ctx+                          , streamClose = bye ctx >> streamClose hand+                          }

@@ -1,3 +1,9 @@+{-# LANGUAGE CPP #-}++#if WITH_TEMPLATE_HASKELL+{-# LANGUAGE TemplateHaskell #-}+#endif+ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -12,12 +18,16 @@     , IQRequestType(..)     , IQResponse(..)     , IQResult(..)-    , IdGenerator(..)     , LangTag (..)+    , langTagFromText+    , langTagToText+    , parseLangTag     , Message(..)+    , message     , MessageError(..)     , MessageType(..)     , Presence(..)+    , presence     , PresenceError(..)     , PresenceType(..)     , SaslError(..)@@ -27,7 +37,6 @@     , StanzaError(..)     , StanzaErrorCondition(..)     , StanzaErrorType(..)-    , StanzaID(..)     , XmppFailure(..)     , StreamErrorCondition(..)     , Version(..)@@ -37,23 +46,31 @@     , ConnectionState(..)     , StreamErrorInfo(..)     , StanzaHandler+    , ConnectionDetails(..)     , StreamConfiguration(..)-    , langTag     , Jid(..)+#if WITH_TEMPLATE_HASKELL+    , jidQ+#endif     , isBare     , isFull     , jidFromText     , jidFromTexts+    , jidToText+    , jidToTexts+    , toBare+    , localpart+    , domainpart+    , resourcepart+    , parseJid     , StreamEnd(..)     , InvalidXmppXml(..)-    , Hostname(..)-    , hostname-    , SessionConfiguration(..)     , TlsBehaviour(..)+    , AuthFailure(..)     )        where -import           Control.Applicative ((<$>), (<|>), many)+import           Control.Applicative ((<|>), many) import           Control.Concurrent.STM import           Control.Exception import           Control.Monad.Error@@ -61,36 +78,22 @@ import qualified Data.ByteString as BS import           Data.Conduit import           Data.Default-import           Data.Maybe (fromJust, maybeToList) import qualified Data.Set as Set-import           Data.String (IsString(..)) import           Data.Text (Text) import qualified Data.Text as Text import           Data.Typeable(Typeable) import           Data.XML.Types+#if WITH_TEMPLATE_HASKELL+import           Language.Haskell.TH+import           Language.Haskell.TH.Quote+#endif import           Network import           Network.DNS-import           Network.Socket import           Network.TLS hiding (Version) import           Network.TLS.Extra import qualified Text.NamePrep as SP import qualified Text.StringPrep as SP --- |--- Wraps a string of random characters that, when using an appropriate--- @IdGenerator@, is guaranteed to be unique for the Xmpp session.--data StanzaID = StanzaID !Text deriving (Eq, Ord)--instance Show StanzaID where-  show (StanzaID s) = Text.unpack s--instance Read StanzaID where-  readsPrec _ x = [(StanzaID $ Text.pack x, "")]--instance IsString StanzaID where-  fromString = StanzaID . Text.pack- -- | The Xmpp communication primities (Message, Presence and Info/Query) are -- called stanzas. data Stanza = IQRequestS     !IQRequest@@ -104,7 +107,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      :: !Text                            , iqRequestFrom    :: !(Maybe Jid)                            , iqRequestTo      :: !(Maybe Jid)                            , iqRequestLangTag :: !(Maybe LangTag)@@ -113,16 +116,7 @@                            } deriving Show  -- | The type of IQ request that is made.-data IQRequestType = Get | Set deriving (Eq, Ord)--instance Show IQRequestType where-  show Get = "get"-  show Set = "set"--instance Read IQRequestType where-  readsPrec _ "get" = [(Get, "")]-  readsPrec _ "set" = [(Set, "")]-  readsPrec _ _ = []+data IQRequestType = Get | Set deriving (Eq, Ord, Read, Show)  -- | A "response" Info/Query (IQ) stanza is either an 'IQError', an IQ stanza -- of  type "result" ('IQResult') or a Timeout.@@ -132,7 +126,7 @@                 deriving Show  -- | The (non-error) answer to an IQ request.-data IQResult = IQResult { iqResultID      :: !StanzaID+data IQResult = IQResult { iqResultID      :: !Text                          , iqResultFrom    :: !(Maybe Jid)                          , iqResultTo      :: !(Maybe Jid)                          , iqResultLangTag :: !(Maybe LangTag)@@ -140,7 +134,7 @@                          } deriving Show  -- | The answer to an IQ request that generated an error.-data IQError = IQError { iqErrorID          :: !StanzaID+data IQError = IQError { iqErrorID          :: !Text                        , iqErrorFrom        :: !(Maybe Jid)                        , iqErrorTo          :: !(Maybe Jid)                        , iqErrorLangTag     :: !(Maybe LangTag)@@ -149,7 +143,7 @@                        } deriving Show  -- | The message stanza. Used for /push/ type communication.-data Message = Message { messageID      :: !(Maybe StanzaID)+data Message = Message { messageID      :: !(Maybe Text)                        , messageFrom    :: !(Maybe Jid)                        , messageTo      :: !(Maybe Jid)                        , messageLangTag :: !(Maybe LangTag)@@ -157,8 +151,23 @@                        , messagePayload :: ![Element]                        } deriving Show +++-- | An empty message+message :: Message+message = Message { messageID      = Nothing+                  , messageFrom    = Nothing+                  , messageTo      = Nothing+                  , messageLangTag = Nothing+                  , messageType    = Normal+                  , messagePayload = []+                  }++instance Default Message where+    def = message+ -- | An error stanza generated in response to a 'Message'.-data MessageError = MessageError { messageErrorID          :: !(Maybe StanzaID)+data MessageError = MessageError { messageErrorID          :: !(Maybe Text)                                  , messageErrorFrom        :: !(Maybe Jid)                                  , messageErrorTo          :: !(Maybe Jid)                                  , messageErrorLangTag     :: !(Maybe LangTag)@@ -202,33 +211,32 @@                    --                    -- This is the /default/ value.                  | Normal-                 deriving (Eq)--instance Show MessageType where-    show Chat      = "chat"-    show GroupChat = "groupchat"-    show Headline  = "headline"-    show Normal    = "normal"--instance Read MessageType where-    readsPrec _  "chat"      = [(Chat, "")]-    readsPrec _  "groupchat" = [(GroupChat, "")]-    readsPrec _  "headline"  = [(Headline, "")]-    readsPrec _  "normal"    = [(Normal, "")]-    readsPrec _  _           = [(Normal, "")]+                 deriving (Eq, Read, Show)  -- | The presence stanza. Used for communicating status updates.-data Presence = Presence { presenceID      :: !(Maybe StanzaID)+data Presence = Presence { presenceID      :: !(Maybe Text)                          , presenceFrom    :: !(Maybe Jid)                          , presenceTo      :: !(Maybe Jid)                          , presenceLangTag :: !(Maybe LangTag)-                         , presenceType    :: !(Maybe PresenceType)+                         , presenceType    :: !PresenceType                          , presencePayload :: ![Element]                          } deriving Show +-- | An empty presence.+presence :: Presence+presence = Presence { presenceID       = Nothing+                    , presenceFrom     = Nothing+                    , presenceTo       = Nothing+                    , presenceLangTag  = Nothing+                    , presenceType     = Available+                    , presencePayload  = []+                    } +instance Default Presence where+    def = presence+ -- | An error stanza generated in response to a 'Presence'.-data PresenceError = PresenceError { presenceErrorID          :: !(Maybe StanzaID)+data PresenceError = PresenceError { presenceErrorID          :: !(Maybe Text)                                    , presenceErrorFrom        :: !(Maybe Jid)                                    , presenceErrorTo          :: !(Maybe Jid)                                    , presenceErrorLangTag     :: !(Maybe LangTag)@@ -245,28 +253,9 @@                                    --   subscription                     Probe        | -- ^ Sender requests current presence;                                    --   should only be used by servers-                    Default      |-                    Unavailable deriving (Eq)--instance Show PresenceType where-    show Subscribe    = "subscribe"-    show Subscribed   = "subscribed"-    show Unsubscribe  = "unsubscribe"-    show Unsubscribed = "unsubscribed"-    show Probe        = "probe"-    show Default      = ""-    show Unavailable  = "unavailable"--instance Read PresenceType where-    readsPrec _  ""             = [(Default, "")]-    readsPrec _  "available"    = [(Default, "")]-    readsPrec _  "unavailable"  = [(Unavailable, "")]-    readsPrec _  "subscribe"    = [(Subscribe, "")]-    readsPrec _  "subscribed"   = [(Subscribed, "")]-    readsPrec _  "unsubscribe"  = [(Unsubscribe, "")]-    readsPrec _  "unsubscribed" = [(Unsubscribed, "")]-    readsPrec _  "probe"        = [(Probe, "")]-    readsPrec _  _              = []+                    Available    | -- ^ Sender wants to express availability+                                   --   (no type attribute is defined)+                    Unavailable deriving (Eq, Read, Show)  -- | All stanzas (IQ, message, presence) can cause errors, which in the Xmpp -- stream looks like <stanza-kind to='sender' type='error'>. These errors are@@ -285,22 +274,7 @@                        Modify   | -- ^ Change the data and retry                        Auth     | -- ^ Provide credentials and retry                        Wait       -- ^ Error is temporary - wait and retry-                       deriving (Eq)--instance Show StanzaErrorType where-    show Cancel   = "cancel"-    show Continue = "continue"-    show Modify   = "modify"-    show Auth     = "auth"-    show Wait     = "wait"--instance Read StanzaErrorType where-  readsPrec _ "auth"     = [( Auth    , "")]-  readsPrec _ "cancel"   = [( Cancel  , "")]-  readsPrec _ "continue" = [( Continue, "")]-  readsPrec _ "modify"   = [( Modify  , "")]-  readsPrec _ "wait"     = [( Wait    , "")]-  readsPrec _ _          = []+                       deriving (Eq, Read, Show)  -- | Stanza errors are accommodated with one of the error conditions listed -- below.@@ -337,56 +311,7 @@                           | UndefinedCondition    -- ^ Application-specific                                                   --   condition.                           | UnexpectedRequest     -- ^ Badly timed request.-                            deriving Eq--instance Show StanzaErrorCondition where-    show BadRequest = "bad-request"-    show Conflict = "conflict"-    show FeatureNotImplemented = "feature-not-implemented"-    show Forbidden = "forbidden"-    show Gone = "gone"-    show InternalServerError = "internal-server-error"-    show ItemNotFound = "item-not-found"-    show JidMalformed = "jid-malformed"-    show NotAcceptable = "not-acceptable"-    show NotAllowed = "not-allowed"-    show NotAuthorized = "not-authorized"-    show PaymentRequired = "payment-required"-    show RecipientUnavailable = "recipient-unavailable"-    show Redirect = "redirect"-    show RegistrationRequired = "registration-required"-    show RemoteServerNotFound = "remote-server-not-found"-    show RemoteServerTimeout = "remote-server-timeout"-    show ResourceConstraint = "resource-constraint"-    show ServiceUnavailable = "service-unavailable"-    show SubscriptionRequired = "subscription-required"-    show UndefinedCondition = "undefined-condition"-    show UnexpectedRequest = "unexpected-request"--instance Read StanzaErrorCondition where-    readsPrec _  "bad-request"             = [(BadRequest           , "")]-    readsPrec _  "conflict"                = [(Conflict             , "")]-    readsPrec _  "feature-not-implemented" = [(FeatureNotImplemented, "")]-    readsPrec _  "forbidden"               = [(Forbidden            , "")]-    readsPrec _  "gone"                    = [(Gone                 , "")]-    readsPrec _  "internal-server-error"   = [(InternalServerError  , "")]-    readsPrec _  "item-not-found"          = [(ItemNotFound         , "")]-    readsPrec _  "jid-malformed"           = [(JidMalformed         , "")]-    readsPrec _  "not-acceptable"          = [(NotAcceptable        , "")]-    readsPrec _  "not-allowed"             = [(NotAllowed           , "")]-    readsPrec _  "not-authorized"          = [(NotAuthorized        , "")]-    readsPrec _  "payment-required"        = [(PaymentRequired      , "")]-    readsPrec _  "recipient-unavailable"   = [(RecipientUnavailable , "")]-    readsPrec _  "redirect"                = [(Redirect             , "")]-    readsPrec _  "registration-required"   = [(RegistrationRequired , "")]-    readsPrec _  "remote-server-not-found" = [(RemoteServerNotFound , "")]-    readsPrec _  "remote-server-timeout"   = [(RemoteServerTimeout  , "")]-    readsPrec _  "resource-constraint"     = [(ResourceConstraint   , "")]-    readsPrec _  "service-unavailable"     = [(ServiceUnavailable   , "")]-    readsPrec _  "subscription-required"   = [(SubscriptionRequired , "")]-    readsPrec _  "unexpected-request"      = [(UnexpectedRequest    , "")]-    readsPrec _  "undefined-condition"     = [(UndefinedCondition   , "")]-    readsPrec _  _                         = [(UndefinedCondition   , "")]+                            deriving (Eq, Read, Show)  -- ============================================================================= --  OTHER STUFF@@ -396,7 +321,7 @@                                , saslFailureText :: Maybe ( Maybe LangTag                                                           , Text                                                           )-                               } deriving Show+                               } deriving (Eq, Show)  data SaslError = SaslAborted              -- ^ Client aborted.                | SaslAccountDisabled      -- ^ The account has been temporarily@@ -425,33 +350,7 @@                                           --   temporary error condition; the                                           --   initiating entity is recommended                                           --   to try again later.--instance Show SaslError where-    show SaslAborted               = "aborted"-    show SaslAccountDisabled       = "account-disabled"-    show SaslCredentialsExpired    = "credentials-expired"-    show SaslEncryptionRequired    = "encryption-required"-    show SaslIncorrectEncoding     = "incorrect-encoding"-    show SaslInvalidAuthzid        = "invalid-authzid"-    show SaslInvalidMechanism      = "invalid-mechanism"-    show SaslMalformedRequest      = "malformed-request"-    show SaslMechanismTooWeak      = "mechanism-too-weak"-    show SaslNotAuthorized         = "not-authorized"-    show SaslTemporaryAuthFailure  = "temporary-auth-failure"--instance Read SaslError where-    readsPrec _ "aborted"                = [(SaslAborted              , "")]-    readsPrec _ "account-disabled"       = [(SaslAccountDisabled      , "")]-    readsPrec _ "credentials-expired"    = [(SaslCredentialsExpired   , "")]-    readsPrec _ "encryption-required"    = [(SaslEncryptionRequired   , "")]-    readsPrec _ "incorrect-encoding"     = [(SaslIncorrectEncoding    , "")]-    readsPrec _ "invalid-authzid"        = [(SaslInvalidAuthzid       , "")]-    readsPrec _ "invalid-mechanism"      = [(SaslInvalidMechanism     , "")]-    readsPrec _ "malformed-request"      = [(SaslMalformedRequest     , "")]-    readsPrec _ "mechanism-too-weak"     = [(SaslMechanismTooWeak     , "")]-    readsPrec _ "not-authorized"         = [(SaslNotAuthorized        , "")]-    readsPrec _ "temporary-auth-failure" = [(SaslTemporaryAuthFailure , "")]-    readsPrec _ _                        = []+               deriving (Eq, Read, Show)  -- The documentation of StreamErrorConditions is copied from -- http://xmpp.org/rfcs/rfc6120.html#streams-error-conditions@@ -492,11 +391,11 @@                         -- Server Dialback, or (2) between a client and a server                         -- via SASL authentication and resource binding.     | StreamInvalidNamespace -- ^ The stream namespace name is something other-                             -- than "http://etherx.jabber.org/streams" (see+                             -- than \"http://etherx.jabber.org/streams\" (see                              -- Section 11.2) or the content namespace declared                              -- as the default namespace is not supported (e.g.,                              -- something other than "jabber:client" or-                             -- "jabber:server").+                             -- \"jabber:server\").     | StreamInvalidXml -- ^ The entity has sent invalid XML over the stream to a                        -- server that performs validation     | StreamNotAuthorized -- ^ The entity has attempted to send XML stanzas or@@ -568,63 +467,7 @@                                -- initiating entity in the stream header                                -- specifies a version of XMPP that is not                                -- supported by the server.-      deriving Eq--instance Show StreamErrorCondition where-    show StreamBadFormat              = "bad-format"-    show StreamBadNamespacePrefix     = "bad-namespace-prefix"-    show StreamConflict               = "conflict"-    show StreamConnectionTimeout      = "connection-timeout"-    show StreamHostGone               = "host-gone"-    show StreamHostUnknown            = "host-unknown"-    show StreamImproperAddressing     = "improper-addressing"-    show StreamInternalServerError    = "internal-server-error"-    show StreamInvalidFrom            = "invalid-from"-    show StreamInvalidNamespace       = "invalid-namespace"-    show StreamInvalidXml             = "invalid-xml"-    show StreamNotAuthorized          = "not-authorized"-    show StreamNotWellFormed          = "not-well-formed"-    show StreamPolicyViolation        = "policy-violation"-    show StreamRemoteConnectionFailed = "remote-connection-failed"-    show StreamReset                  = "reset"-    show StreamResourceConstraint     = "resource-constraint"-    show StreamRestrictedXml          = "restricted-xml"-    show StreamSeeOtherHost           = "see-other-host"-    show StreamSystemShutdown         = "system-shutdown"-    show StreamUndefinedCondition     = "undefined-condition"-    show StreamUnsupportedEncoding    = "unsupported-encoding"-    show StreamUnsupportedFeature     = "unsupported-feature"-    show StreamUnsupportedStanzaType  = "unsupported-stanza-type"-    show StreamUnsupportedVersion     = "unsupported-version"--instance Read StreamErrorCondition where-    readsPrec _ "bad-format"               = [(StreamBadFormat            , "")]-    readsPrec _ "bad-namespace-prefix"     = [(StreamBadNamespacePrefix   , "")]-    readsPrec _ "conflict"                 = [(StreamConflict             , "")]-    readsPrec _ "connection-timeout"       = [(StreamConnectionTimeout    , "")]-    readsPrec _ "host-gone"                = [(StreamHostGone             , "")]-    readsPrec _ "host-unknown"             = [(StreamHostUnknown          , "")]-    readsPrec _ "improper-addressing"      = [(StreamImproperAddressing   , "")]-    readsPrec _ "internal-server-error"    = [(StreamInternalServerError  , "")]-    readsPrec _ "invalid-from"             = [(StreamInvalidFrom          , "")]-    readsPrec _ "invalid-namespace"        = [(StreamInvalidNamespace     , "")]-    readsPrec _ "invalid-xml"              = [(StreamInvalidXml           , "")]-    readsPrec _ "not-authorized"           = [(StreamNotAuthorized        , "")]-    readsPrec _ "not-well-formed"          = [(StreamNotWellFormed        , "")]-    readsPrec _ "policy-violation"         = [(StreamPolicyViolation      , "")]-    readsPrec _ "remote-connection-failed" =-        [(StreamRemoteConnectionFailed, "")]-    readsPrec _ "reset"                    = [(StreamReset                , "")]-    readsPrec _ "resource-constraint"      = [(StreamResourceConstraint   , "")]-    readsPrec _ "restricted-xml"           = [(StreamRestrictedXml        , "")]-    readsPrec _ "see-other-host"           = [(StreamSeeOtherHost         , "")]-    readsPrec _ "system-shutdown"          = [(StreamSystemShutdown       , "")]-    readsPrec _ "undefined-condition"      = [(StreamUndefinedCondition   , "")]-    readsPrec _ "unsupported-encoding"     = [(StreamUnsupportedEncoding  , "")]-    readsPrec _ "unsupported-feature"      = [(StreamUnsupportedFeature   , "")]-    readsPrec _ "unsupported-stanza-type"  = [(StreamUnsupportedStanzaType, "")]-    readsPrec _ "unsupported-version"      = [(StreamUnsupportedVersion   , "")]-    readsPrec _ _                          = [(StreamUndefinedCondition   , "")]+      deriving (Eq, Read, Show)  -- | Encapsulates information about an XMPP stream error. data StreamErrorInfo = StreamErrorInfo@@ -661,8 +504,8 @@                  | XmppNoStream -- ^ An action that required an active                                 -- stream were performed when the                                 -- 'StreamState' was 'Closed'-                 | XmppAuthFailure -- ^ Authentication with the server failed-                                   -- unrecoverably+                 | XmppAuthFailure AuthFailure -- ^ Authentication with the+                                               -- server failed (unrecoverably)                  | TlsStreamSecured -- ^ Connection already secured                  | XmppOtherFailure -- ^ Undefined condition. More                                     -- information should be available in@@ -674,23 +517,34 @@ instance Exception XmppFailure instance Error XmppFailure where noMsg = XmppOtherFailure +-- | Signals a 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 (Eq, Show)++instance Error AuthFailure where+    noMsg = AuthOtherFailure+ -- ============================================================================= --  XML TYPES -- ============================================================================= ---- | Wraps a function that MUST generate a stream of unique Ids. The---   strings MUST be appropriate for use in the stanza id attirubte.---   For a default implementation, see @idGenerator@.--newtype IdGenerator = IdGenerator (IO Text)----- | XMPP version number. Displayed as "<major>.<minor>". 2.4 is lesser than+-- | XMPP version number. Displayed as "\<major\>.\<minor\>". 2.4 is lesser than -- 2.13, which in turn is lesser than 12.3.  data Version = Version { majorVersion :: !Integer-                       , minorVersion :: !Integer } deriving (Eq)+                       , minorVersion :: !Integer } deriving (Eq, Read, Show)  -- If the major version numbers are not equal, compare them. Otherwise, compare -- the minor version numbers.@@ -699,11 +553,11 @@         | amajor /= bmajor = compare amajor bmajor         | otherwise = compare aminor bminor -instance Read Version where-    readsPrec _ txt = (,"") <$> maybeToList (versionFromText $ Text.pack txt)+-- instance Read Version where+--     readsPrec _ txt = (,"") <$> maybeToList (versionFromText $ Text.pack txt) -instance Show Version where-    show (Version major minor) = (show major) ++ "." ++ (show minor)+-- instance Show Version where+--     show (Version major minor) = (show major) ++ "." ++ (show minor)  -- Converts a "<major>.<minor>" numeric version number to a @Version@ object. versionFromText :: Text.Text -> Maybe Version@@ -726,24 +580,21 @@ data LangTag = LangTag { primaryTag :: !Text                        , subtags    :: ![Text] } +-- Equals for language tags is not case-sensitive. instance Eq LangTag where     LangTag p s == LangTag q t = Text.toLower p == Text.toLower q &&         map Text.toLower s == map Text.toLower t -instance Read LangTag where-    readsPrec _ txt = (,"") <$> maybeToList (langTag $ Text.pack txt)--instance Show LangTag where-    show (LangTag p []) = Text.unpack p-    show (LangTag p s) = Text.unpack . Text.concat $-        [p, "-", Text.intercalate "-" s]- -- | Parses, validates, and possibly constructs a "LangTag" object.-langTag :: Text.Text -> Maybe LangTag-langTag s = case AP.parseOnly langTagParser s of-              Right tag -> Just tag-              Left _ -> Nothing+langTagFromText :: Text.Text -> Maybe LangTag+langTagFromText s = case AP.parseOnly langTagParser s of+                        Right tag -> Just tag+                        Left _ -> Nothing +langTagToText :: LangTag -> Text.Text+langTagToText (LangTag p []) = p+langTagToText (LangTag p s) = Text.concat $ [p, "-", Text.intercalate "-" s]+ -- Parses a language tag as defined by RFC 1766 and constructs a LangTag object. langTagParser :: AP.Parser LangTag langTagParser = do@@ -768,6 +619,12 @@ data StreamFeatures = StreamFeatures     { streamTls            :: !(Maybe Bool)     , streamSaslMechanisms :: ![Text.Text]+    , rosterVer            :: !(Maybe Bool) -- ^ @Nothing@ for no roster+                                            -- versioning, @Just False@ for+                                            -- roster versioning and @Just True@+                                            -- when the server sends the+                                            -- non-standard "optional" element+                                            -- (observed with prosody).     , streamOtherFeatures  :: ![Element] -- TODO: All feature elements instead?     } deriving Show @@ -776,12 +633,14 @@     = Closed  -- ^ No stream has been established     | Plain   -- ^ Stream established, but not secured via TLS     | Secured -- ^ Stream established and secured via TLS+    | Finished -- ^ Stream is closed       deriving (Show, Eq, Typeable)  -- | Defines operations for sending, receiving, flushing, and closing on a -- stream. data StreamHandle =-    StreamHandle { streamSend :: BS.ByteString -> IO Bool+    StreamHandle { streamSend :: BS.ByteString -> IO Bool -- ^ Sends may not+                                                          -- interleave                  , streamReceive :: Int -> IO BS.ByteString                    -- This is to hold the state of the XML parser (otherwise we                    -- will receive EventBeginDocument events and forget about@@ -792,11 +651,11 @@  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+      streamConnectionState :: !ConnectionState+      -- | Functions to send, receive, flush, and close the stream     , streamHandle :: StreamHandle       -- | Event conduit source, and its associated finalizer-    , streamEventSource :: ResumableSource IO Event+    , streamEventSource :: Source IO Event       -- | Stream features advertised by the server     , streamFeatures :: !StreamFeatures -- TODO: Maybe?       -- | The hostname or IP specified for the connection@@ -826,53 +685,156 @@  -- | 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+-- two: localpart, domainpart, and resourcepart.+--+-- 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@).+--+-- 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).+--+-- 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@). -                 -- | 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)+data Jid = Jid { localpart_ :: !(Maybe Text)+               , domainpart_ :: !Text+               , resourcepart_ :: !(Maybe Text)                } deriving (Eq, Ord) +-- | Converts a JID to a Text.+jidToText :: Jid -> Text+jidToText (Jid nd dmn res) =+    Text.pack $ (maybe "" ((++ "@") . Text.unpack) nd) ++ (Text.unpack dmn) +++        maybe "" (('/' :) . Text.unpack) res++-- | Converts a JID to up to three Text values: (the optional) localpart, the+-- domainpart, and (the optional) resourcepart.+jidToTexts :: Jid -> (Maybe Text, Text, Maybe Text)+jidToTexts (Jid nd dmn res) = (nd, dmn, res)++-- Produces a Jid value in the format "parseJid \"<jid>\"". instance Show Jid where-  show (Jid nd dmn res) =-      maybe "" ((++ "@") . Text.unpack) nd ++ Text.unpack dmn ++-          maybe "" (('/' :) . Text.unpack) res+  show j = "parseJid " ++ show (jidToText j) +-- The string must be in the format "parseJid \"<jid>\"".+-- TODO: This function should produce its error values in a uniform way.+-- TODO: Do we need to care about precedence here? instance Read Jid where-  readsPrec _ x = case jidFromText (Text.pack x) of-      Nothing -> []-      Just j -> [(j,"")]+    readsPrec _ s = do+        -- Verifies that the first word is "parseJid", parses the second word and+        -- the remainder, if any, and produces these two values or fails.+        let (s', r) = case lex s of+                          [] -> error "Expected `parseJid \"<jid>\"'"+                          [("parseJid", r')] -> case lex r' of+                                              [] -> error "Expected `parseJid \"<jid>\"'"+                                              [(s'', r'')] -> (s'', r'')+                                              _ -> error "Expected `parseJid \"<jid>\"'"+                          _ -> error "Expected `parseJid \"<jid>\"'"+        -- Read the JID string (removes the quotes), validate, and return.+        [(parseJid (read s' :: String), r)] -- May fail with "Prelude.read: no parse"+                                            -- or the `parseJid' error message (see below) -instance IsString Jid where-  fromString = fromJust . jidFromText . Text.pack+#if WITH_TEMPLATE_HASKELL+-- | Constructs a @Jid@ value at compile time.+--  +-- Syntax:+-- @+--     [jidQ|localpart\@domainpart/resourcepart|]+-- @+jidQ :: QuasiQuoter+jidQ = QuasiQuoter { quoteExp = \s -> do+                          when (head s == ' ') . fail $ "Leading whitespaces in JID" ++ show s+                          let t = Text.pack s+                          when (Text.last t == ' ') . reportWarning $ "Trailing whitespace in JID " ++ show s+                          case jidFromText t of+                              Nothing -> fail $ "Could not parse JID " ++ s+                              Just j -> [| Jid $(mbTextE $ localpart_ j)+                                               $(textE   $ domainpart_ j)+                                               $(mbTextE $ resourcepart_ j)+                                        |]+                  , quotePat = fail "Jid patterns aren't implemented"+                  , quoteType = fail "jid QQ can't be used in type context"+                  , quoteDec  = fail "jid QQ can't be used in declaration context"+                  }+  where+    textE t = [| Text.pack $(stringE $ Text.unpack t) |]+    mbTextE Nothing = [| Nothing |]+    mbTextE (Just s) = [| Just $(textE s) |]+#endif +-- Produces a LangTag value in the format "parseLangTag \"<jid>\"".+instance Show LangTag where+  show l = "parseLangTag " ++ show (langTagToText l)++-- The string must be in the format "parseLangTag \"<LangTag>\"". This is based+-- on parseJid, and suffers the same problems.+instance Read LangTag where+    readsPrec _ s = do+        let (s', r) = case lex s of+                          [] -> error "Expected `parseLangTag \"<LangTag>\"'"+                          [("parseLangTag", r')] -> case lex r' of+                                              [] -> error "Expected `parseLangTag \"<LangTag>\"'"+                                              [(s'', r'')] -> (s'', r'')+                                              _ -> error "Expected `parseLangTag \"<LangTag>\"'"+                          _ -> error "Expected `parseLangTag \"<LangTag>\"'"+        [(parseLangTag (read s' :: String), r)]++parseLangTag :: String -> LangTag+parseLangTag s = case langTagFromText $ Text.pack s of+                     Just l -> l+                     Nothing -> error $ "Language tag value (" ++ s ++ ") did not validate"++#if WITH_TEMPLATE_HASKELL+langTagQ :: QuasiQuoter+langTagQ = QuasiQuoter {quoteExp = \s -> case langTagFromText $ Text.pack  s of+                             Nothing -> fail $ "Not a valid language tag: "+                                               ++  s+                             Just lt -> [|LangTag $(textE $ primaryTag lt)+                                                  $(listE $+                                                      map textE (subtags lt))+                                        |]++                       , quotePat = fail $ "LanguageTag patterns aren't"+                                         ++ " implemented"+                       , quoteType = fail $ "LanguageTag QQ can't be used"+                                           ++ " in type context"+                       , quoteDec  = fail $ "LanguageTag QQ can't be used"+                                           ++ " in declaration context"++                       }+  where+    textE t = [| Text.pack $(stringE $ Text.unpack t) |]+#endif+-- | Parses a JID string.+--+-- Note: This function is only meant to be used to reverse @Jid@ Show+-- operations; it will produce an 'undefined' value if the JID does not+-- validate; please refer to @jidFromText@ for a safe equivalent.+parseJid :: String -> Jid+parseJid s = case jidFromText $ Text.pack s of+                 Just j -> j+                 Nothing -> error $ "Jid value (" ++ s ++ ") did not validate"+ -- | Converts a Text to a JID. jidFromText :: Text -> Maybe Jid jidFromText t = do@@ -918,6 +880,22 @@ isFull :: Jid -> Bool isFull = not . isBare +-- | Returns the @Jid@ without the resourcepart (if any).+toBare :: Jid -> Jid+toBare j  = j{resourcepart_ = Nothing}++-- | Returns the localpart of the @Jid@ (if any).+localpart :: Jid -> Maybe Text+localpart = localpart_++-- | Returns the domainpart of the @Jid@.+domainpart :: Jid -> Text+domainpart = domainpart_++-- | Returns the resourcepart of the @Jid@ (if any).+resourcepart :: Jid -> Maybe Text+resourcepart = resourcepart_+ -- Parses an JID string and returns its three parts. It performs no validation -- or transformations. jidParts :: AP.Parser (Maybe Text, Text, Maybe Text)@@ -1012,6 +990,11 @@  instance Exception InvalidXmppXml +data ConnectionDetails = UseRealm -- ^ Use realm to resolv host+                       | UseSrv HostName -- ^ Use this hostname for a SRV lookup+                       | UseHost HostName PortID -- ^ Use specified host+                       | UseConnection (ErrorT XmppFailure IO StreamHandle)+ -- | Configuration settings related to the stream. data StreamConfiguration =     StreamConfiguration { -- | Default language when no language tag is set@@ -1026,7 +1009,7 @@                           -- 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)+                        , connectionDetails :: ConnectionDetails                           -- | DNS resolver configuration                         , resolvConf :: ResolvConf                           -- | Whether or not to perform the legacy@@ -1039,82 +1022,22 @@                         , tlsParams :: TLSParams                         } - instance Default StreamConfiguration where     def = StreamConfiguration { preferredLang = Nothing                               , toJid = Nothing-                              , socketDetails = Nothing+                              , connectionDetails = UseRealm                               , resolvConf = defaultResolvConf                               , establishSession = True                               , tlsBehaviour = PreferTls-                              , tlsParams = defaultParamsClient { pConnectVersion = TLS12-                                                                , pAllowedVersions = [TLS12]+                              , tlsParams = defaultParamsClient { pConnectVersion = TLS10+                                                                , pAllowedVersions = [TLS10, TLS11, 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]--type StanzaHandler =  TChan Stanza -- ^ outgoing stanza+type StanzaHandler =  TMVar (BS.ByteString -> IO Bool) -- ^ outgoing stanza                    -> Stanza       -- ^ stanza to handle                    -> IO Bool      -- ^ True when processing should continue---- | 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 (IO StanzaID)-    , extraStanzaHandlers   :: [StanzaHandler]-    }--instance Default SessionConfiguration where-    def = SessionConfiguration { sessionStreamConfiguration = def-                               , sessionClosedHandler = \_ -> return ()-                               , sessionStanzaIDs = do-                                     idRef <- newTVarIO 1-                                     return . atomically $ do-                                         curId <- readTVar idRef-                                         writeTVar idRef (curId + 1 :: Integer)-                                         return . StanzaID . Text.pack . show $ curId-                               , extraStanzaHandlers = []-                               }  -- | How the client should behave in regards to TLS. data TlsBehaviour = RequireTls -- ^ Require the use of TLS; disconnect if it's

@@ -1,104 +1,44 @@ {-# 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+module Network.Xmpp.Utilities+    ( openElementToEvents+    , renderOpenElement+    , renderElement+    , checkHostName+    , withTMVar+    )+    where +import           Control.Applicative ((<|>))+import           Control.Concurrent.STM+import           Control.Exception+import           Control.Monad.State.Strict import qualified Data.Attoparsec.Text as AP-import qualified Data.Text as Text- import qualified Data.ByteString as BS+import           Data.Conduit as C+import           Data.Conduit.List as CL import qualified Data.Text as Text+import           Data.Text(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           Prelude+import           System.IO.Unsafe(unsafePerformIO) 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+-- | Apply f with the content of tv as state, restoring the original value when an+-- exception occurs+withTMVar :: TMVar a -> (a -> IO (c, a)) -> IO c+withTMVar tv f = bracketOnError (atomically $ takeTMVar tv)+                                (atomically . putTMVar tv)+                                (\s -> do+                                      (x, s') <- f s+                                      atomically $ putTMVar tv s'+                                      return x+                                )  openElementToEvents :: Element -> [Event] openElementToEvents (Element name as ns) = EventBeginElement name as : goN ns []@@ -124,4 +64,31 @@     $ CL.sourceList (elementToEvents e) $$ TXSR.renderText def =$ CL.consume   where     elementToEvents :: Element -> [Event]-    elementToEvents e@(Element name _ _) = openElementToEvents e ++ [EventEndElement name]+    elementToEvents el@(Element name _ _) = openElementToEvents el+                                              ++ [EventEndElement name]++-- | Validates the hostname string in accordance with RFC 1123.+checkHostName :: Text -> Maybe Text+checkHostName t =+    eitherToMaybeHostName $ AP.parseOnly hostnameP t+  where+    eitherToMaybeHostName = either (const Nothing) Just++-- 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]