packages feed

pontarius-xmpp 0.0.3.0 → 0.5.7.2

raw patch · 67 files changed

Files

+ ChangeLog.md view
@@ -0,0 +1,15 @@+# 0.5.1 to 0.6.0+* Changed roster update callback to take RosterUpdate type+* Added onrosterPushL lens+* Removed legacy `crypto-random` (this caused issues when compiling with GHC 9.2.5)++# 0.5.0 to 0.5.1+* Fixed input logger choking on long non-ascii messages++# 0.4.5 to 0.5.0+* Support for the session element is now determined from stream features, the+  establishSession option was removed+* The parser can now handle nonzas. Nonzas can be handled with a plugin+* An initial roster can now be set with the initialRoster session configuration+  option+* The JID parser can now handle "/" and "@" characters in the resource part
− Examples/EchoClient.hs 
@@ -1,73 +0,0 @@-{---This file (EchoClient.hs) illustrates how to connect, authenticate and set a-presence with Pontarius XMPP. The contents of this file may be used freely, as-if it is in the public domain.---}---import Network.XMPP--import Control.Concurrent.Chan (Chan, readChan, writeChan)-import Data.Maybe-import Data.XML.Types-import qualified Data.Text as DT----- Account and server details.--host = "test.pontarius.org"-userName = "sprint3-xmpp"-server = "test.pontarius.org"-port = 5222-resource = "echo-client"-password = ""----- Creates a Pontarius XMPP session and requests to connect.--main :: IO ()-main =-  do (inEvents, outEvents) <- createSession-     writeChan outEvents $ XOEConnect host port-     loop inEvents outEvents----- All "in" events (incoming events to this program, events from Pontarius XMPP)--- are being processed in this loop. A state variable could be added here.--loop :: Chan XMPPInEvent -> Chan XMPPOutEvent -> IO ()-loop c c_ =-  do e <- readChan c-     -- putStrLn $ "XMPPInEvent received: " ++ (show e)-     processEvent e-     loop c c_-  where-    processEvent :: XMPPInEvent -> IO ()-    -    -- When connected, authenticate-    processEvent XIEConnectionSucceeded =-      writeChan c_ $ XOEAuthenticate userName password resource-    -    -- When authenticated, set presence-    processEvent XIEAuthenticationSucceeded =-      writeChan c_ $ XOEPresence $-        presence Nothing Nothing Nothing Nothing Available []-    -    -- Auto-accept subscriptions when asked and ask for subscription-    processEvent (XIEPresence (Presence { presenceStanza = stanza-                                        , presenceType = Subscribe })) = do-      let jid = stanzaFrom stanza-      writeChan c_ $ XOEPresence $ presence Nothing Nothing jid Nothing-        Subscribed []-      writeChan c_ $ XOEPresence $ presence Nothing Nothing jid Nothing-        Subscribe []-      return ()-    -    -- Echo messages-    processEvent (XIEMessage m) =-      writeChan c_ $ XOEMessage $-        message Nothing Nothing (stanzaFrom $ messageStanza m) Nothing-        (messageType m) (messagePayload m)-    processEvent _ = return ()
− LICENSE 
@@ -1,28 +0,0 @@-Copyright © 2010-2011, Jon Kristensen--All rights reserved.--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 Pontarius, Pontarius XMPP 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 <COPYRIGHT HOLDER> 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.
+ LICENSE.md view
@@ -0,0 +1,35 @@+Copyright © 2005-2011 Dmitry Astapov  +Copyright © 2005-2011 Pierre Kovalev  +Copyright © 2010-2011 Mahdi Abdinejadi  +Copyright © 2010-2013 Jon Kristensen  +Copyright © 2011      IETF Trust  +Copyright © 2012-2013 Philipp Balzarek++All rights reserved.++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.
− Network/XMPP.hs 
@@ -1,66 +0,0 @@--- | Module:      $Header$---   Description: A minimalistic and easy-to-use XMPP library---   Copyright:   Copyright © 2010-2011 Jon Kristensen---   License:     BSD-3---   ---   Maintainer:  info@pontarius.org---   Stability:   unstable---   Portability: portable---- | Pontarius XMPP aims to be a secure, concurrent/event-based and easy-to-use---   XMPP library for Haskell. It is being actively developed.---   ---   Note that we are not recommending anyone to use Pontarius XMPP at this time---   as it's still in an experimental stage and will have its API and data types---   modified frequently. See the project's web site at---   <http://www.pontarius.org/projects/pontarius-xmpp/> for more information.---   ---   This module will be documented soon.--module Network.XMPP ( -- Network.XMPP.JID-                      JID (..)-                    , jid-                    , jidIsFull-                    , jidIsBare-                    , stringToJID-                    , jidToString-                    -                      -- Network.XMPP.SASL-                    , replyToChallenge1-                    -                      -- Network.XMPP.Session-                    , XMPPInEvent (..)-                    , XMPPOutEvent (..)-                    , createSession-                    -                      -- Network.XMPP.Stanza-                    , StanzaID (SID)-                    , From-                    , To-                    , XMLLang-                    , Stanza (..)-                    , MessageType (..)-                    , Message (..)-                    , message-                    , PresenceType (..)-                    , Presence (..)-                    , presence-                    , IQ (..)-                    , iqGet-                    , iqSet-                    , iqResult-                    , iqStanza-                    , iqPayloadNamespace-                    , iqPayload-                    -                    -- Network.XMPP.Utilities-                    , elementToString-                    , elementsToString-                    , getID-                    , getID_ ) where--import Network.XMPP.JID-import Network.XMPP.SASL-import Network.XMPP.Session-import Network.XMPP.Stanza-import Network.XMPP.Utilities
− Network/XMPP/JID.hs 
@@ -1,133 +0,0 @@--- | Module:      $Header$---   Description: JabberID (JID) data type and utility functions---   Copyright:   Copyright © 2010-2011 Jon Kristensen---   License:     BSD-3---   ---   Maintainer:  info@pontarius.org---   Stability:   unstable---   Portability: portable---   ---   JIDs are written in the format of `node@server/resource'. An example of a---   JID is `jonkri@jabber.org'.---   ---   The node identifier is the part before the `@' character in Jabber IDs.---   Node names are optional. The server identifier is the part after the `@'---   character in Jabber IDs (and before the `/' character). The server---   identifier is the only required field of a JID. The server identifier MAY---   be an IP address but SHOULD be a fully qualified domain name. The resource---   identifier is the part after the `/' character in Jabber IDs. Like with---   node names, the resource identifier is optional.---   ---   A JID without a resource identifier (i.e. a JID in the form of---   `node@server') is called `bare JID'. A JID with a resource identifier is---   called `full JID'.---- Node identifiers MUST be formatted in such a way so that the Nodeprep profile--- (see RFC 3920: XMPP Core, Appendix A) of RFC 3454: Preparation of--- Internationalized Strings (`stringprep') can be applied without failing.--- Servers MUST and clients SHOULD apply the Nodeprep profile to node names--- prior to comparing them. Node identifiers MUST NOT be more than 1023 bytes in--- length.------ If it is a domain name it MUST be an `internationalized domain name' as--- defined in RFC 3490: Internationalizing Domain Names in Applications (IDNA),--- to which RFC 3491: Nameprep: A Stringprep Profile for Internationalized--- Domain Names (IDN) can be applied without failing. Servers MUST and clients--- SHOULD first apply the Nameprep profile to the domain names prior to--- comparing them. Like with node names, server identifiers MUST NOT be more--- than 1023 bytes in length.------ A resource identifier has to be formatted in such a way so that the--- Resourceprep profile of RFC 3454: Preparation of Internationalized Strings--- (`stringprep') can be applied without failing. Servers MUST and clients--- SHOULD first apply the Resourceprep profile (see RFC 3920: XMPP Core,--- Appendix B) to resource names prior to comparing them. The resource--- identifier MUST MOT be more than 1023 bytes in length.------ Given the length of the `@' and `/' characters as well as the restrictions--- imposed on the node, server and resource identifiers, a JID will never be--- longer than 3071 bytes.---- TODO: Make the regular expression only match valid JIDs.--- TODO: Use Perl regular expressions to use non-capturing groups with "(?:"?--- TODO: Validate the input in the jid and stringToJID functions.--module Network.XMPP.JID  ( JID (jidNode, jidServer, jidResource)-                         , jid-                         , jidIsFull-                         , jidIsBare-                         , stringToJID-                         , jidToString ) where--import Text.Regex.Posix ((=~))----- JID is a data type that has to be constructed in this module using either jid--- or stringToJID.--data JID = JID { jidNode :: Maybe String-               , jidServer :: String-               , jidResource :: Maybe String } deriving (Eq, Show)----- | Simple function to construct a JID. We will add validation to this function---   in a later release.--jid :: Maybe String -> String -> Maybe String -> JID-jid n s r = JID { jidNode = n, jidServer = s, jidResource = r }----- | Converts a (JID) String to a JID record.--stringToJID :: String -> Maybe JID--stringToJID string = matchToJID $ string =~ "^(([^@]+)@)?([^/]+)(/(.+))?$"-  where-    matchToJID [[_, _, "", server, _, ""]] =-      Just JID { jidNode = Nothing, jidServer = server, jidResource = Nothing }-    matchToJID [[_, _, node, server, _, ""]] =-      Just JID { jidNode = Just node-               , jidServer = server-               , jidResource = Nothing }-    matchToJID [[_, _, "", server, _, resource]] =-      Just JID { jidNode = Nothing-               , jidServer = server-               , jidResource = Just resource }-    matchToJID [[_, _, node, server, _, resource]] =-      Just JID { jidNode = Just node-               , jidServer = server-               , jidResource = Just resource }-    matchToJID _ = Nothing----- | Converts a JID to a String.--jidToString :: JID -> String--jidToString JID { jidNode = n, jidServer = s, jidResource = r }-  | n == Nothing && r == Nothing = s-  | r == Nothing                 = let Just n' = n in n' ++ "@" ++ s-  | n == Nothing                 = let Just r' = r in s ++ "/" ++ r'-  | otherwise                    = let Just n' = n; Just r' = r-                                   in n' ++ "@" ++ s ++ "/" ++ r'----- | JIDs are written in the format of `node@server/resource'. A JID without a---   resource identifier (i.e. a JID in the form of `server' or `node@server')---   is called a `bare JID'. A JID with a resource identifier is called `full---   JID'. This function returns True if the JID is `bare' and False otherwise.--jidIsBare :: JID -> Bool-jidIsBare j | jidResource j == Nothing = True-            | otherwise                = False----- | JIDs are written in the format of `node@server/resource'. A JID without a---   resource identifier (i.e. a JID in the form of `server' or `node@server')---   is called a `bare JID'. A JID with a resource identifier is called `full---   JID'. This function returns True if the JID is `full' and False otherwise.---- This function is defined in terms of (not) jidIsBare.--jidIsFull :: JID -> Bool-jidIsFull jid = not $ jidIsBare jid
− Network/XMPP/SASL.hs 
@@ -1,194 +0,0 @@--- TODO: Make it possible to include host.--- TODO: Host is assumed to be ISO 8859-1; make list of assumptions.--- TODO: Can it contain newline characters?--module Network.XMPP.SASL (replyToChallenge1) where--import Data.ByteString.Internal (c2w)-import Data.Char (isLatin1)-import Data.Digest.Pure.MD5-import qualified Data.Binary as DBi (Binary, encode)-import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack,-                                              fromChunks, toChunks, null)-import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack)-import qualified Data.List as DL---data Challenge1Error = C1MultipleCriticalAttributes       |-                       C1NotAllParametersPresent          |-                       C1SomeParamtersPresentMoreThanOnce |-                       C1WrongRealm                       |-                       C1UnsupportedAlgorithm             |-                       C1UnsupportedCharset               |-                       C1UnsupportedQOP-                       deriving Show----- Will produce a list of key-value pairs given a string in the format of--- realm="somerealm",nonce="OA6MG9tEQGm2hh",qop="auth",charset=utf-8...-stringToList :: String -> [(String, String)]-stringToList "" = []-stringToList s' = let (next, rest) = break' s' ','-                  in break' next '=' : stringToList rest-  where-    -- Like break, but will remove the first char of the continuation, if-    -- present.-    break' :: String -> Char -> (String, String)-    break' s' c = let (first, second) = break ((==) c) s'-                  in (first, removeCharIfPresent second c)-    -    -- Removes the first character, if present; "=hello" with '=' becomes-    -- "hello".-    removeCharIfPresent :: String -> Char -> String-    removeCharIfPresent [] _               = []-    removeCharIfPresent (c:t) c' | c == c' = t-    removeCharIfPresent s' c               = s'---- Counts the number of directives in the pair list.-countDirectives :: String -> [(String, String)] -> Int-countDirectives v l = DL.length $ filter (isEntry v) l-  where-    isEntry :: String -> (String, String) -> Bool-    isEntry name (name', _) | name == name' = True-                            | otherwise     = False----- Returns the given directive in the list of pairs, or Nothing.-lookupDirective :: String -> [(String, String)] -> Maybe String-lookupDirective d []                      = Nothing-lookupDirective d ((d', v):t) | d == d'   = Just v-                              | otherwise = lookupDirective d t----- Returns the given directive in the list of pairs, or the default value--- otherwise.-lookupDirectiveWithDefault :: String -> [(String, String)] -> String -> String-lookupDirectiveWithDefault di l de-  | lookup == Nothing = de-  | otherwise         = let Just r = lookup in r-  where-    lookup = lookupDirective di l----- Takes a challenge string (which is not Base64-encoded), the host name of the--- Jabber server, the Jabber user name (JID), the password and a random and--- unique "cnonce" value and generates either an error or a response to that--- challenge.---- We have broken replyToChallenge1 for non-TLS authentication. In order to--- change it back, just uncomment the lines relevant to the realm and match it--- in the C1NotAllParametersSet case.--replyToChallenge1 :: String -> String -> String -> String -> String ->-                     Either String Challenge1Error-replyToChallenge1 s h u p c =-  -- Remove all new line characters.-  let list = stringToList $ filter (/= '\n') s-  in -- Count that there are no more than one nonce or algorithm directives.-     case countDirectives "nonce"     list <= 1 &&-          countDirectives "algorithm" list <= 1 of-       True ->-         let -- realm     = lookupDirective "realm" list-             nonce     = lookupDirective "nonce" list-             qop       = lookupDirectiveWithDefault "qop" list "auth"-             charset   = lookupDirectiveWithDefault "charset" list "utf-8"-             algorithm = lookupDirective "algorithm" list-         -         -- Verify that all necessary directives has been set.-         in case (nonce, qop, charset, algorithm) of-              (Just nonce', qop', charset', Just algorithm') ->-                -                -- Strip quotations of the directives that need it.-                let -- realm'' = stripQuotations realm'-                    nonce'' = stripQuotations nonce'-                    qop'' = stripQuotations qop' -- It seems ejabberd gives us an errorous "auth" instead of auth-                in-                -- -- Verify that the realm is the same as the Jabber host.-                -- case realm'' == h of-                --      True ->-                       -                       -- Verify that QOP is "auth", charset is "utf-8" and that-                       -- the algorithm is "md5-sess".-                       case qop'' == "auth" of-                         True ->-                           case charset' == "utf-8" of-                             True ->-                               case algorithm' == "md5-sess" of-                                 True ->-                                 -                                   -- All data is valid; generate the reply.-                                   Left (reply nonce'' qop'')-                                 -                                 -- Errors are caught and reported below.-                                 False -> Right C1UnsupportedAlgorithm-                             False -> Right C1UnsupportedCharset-                         False -> Right C1UnsupportedQOP-                     -- False -> Right C1WrongRealm-              _ -> Right C1NotAllParametersPresent-  where-    reply n q =-      let -- We start with what's in RFC 2831 is referred to as "A1", a 16 octet-          -- MD5 hash.-          -          -- If the username or password values are in ISO-8859-1, we convert-          -- them to ISO-8859-1 strings.-          username = case all isLatin1 u of-            True -> DBL.pack $ map c2w u-            False -> DBLC.pack $ u-          password = case all isLatin1 p of-            True -> DBL.pack $ map c2w p-            False -> DBLC.pack p-          -          nc = "00000001"-          digestUri = "xmpp/" ++ h-          -          -- Build the "{ username-value, ":", realm-value, ":", passwd }"-          -- bytestring, the rest of the bytestring and then join them.-          a1a = DBi.encode $ md5 $ DBLC.append-                (DBLC.append username (DBLC.pack (":" ++ h ++ ":")))-                password-          a1aDebug = "DBi.encode $ md5 $ " ++ (DBLC.unpack $ DBLC.append-                (DBLC.append username (DBLC.pack (":" ++ h ++ ":")))-                password)-          a1b = DBLC.pack (":" ++ n ++ ":" ++ c)-          a1 = DBLC.append a1a a1b-          -          -- Generate the "A2" value.-          a2 = DBLC.pack ("AUTHENTICATE:" ++ digestUri)-          -          -- Produce the responseValue.-          k = DBLC.pack (show $ md5 a1)-          colon = DBLC.pack ":"-          s0 = DBLC.pack (n ++ ":" ++ nc ++ ":" ++ c ++ ":" ++-                          q ++ ":")-          s1 = DBLC.pack $ show $ md5 a2-          -          s_ = DBLC.append s0 s1-          -- append k:d and 16 octet hash it-          kd = md5 (DBLC.append k (DBLC.append colon s_))-          -          lol0 = DBLC.unpack s_-          lol1 = show kd-          -          response = show kd-      in "username=\"" ++ u ++ "\",realm=\"" ++ h ++ "\",nonce=\"" ++ n ++-         "\",cnonce=\"" ++ c ++ "\",nc=" ++ nc ++ ",digest-uri=\"" ++-         digestUri ++ "\",qop=auth,response=" ++ response ++ ",charset=utf-8"-         -- "\n\n" ++-         -- "a1aDebug: " ++ a1aDebug ++ "\n" ++-         -- "a1b: " ++ (DBLC.unpack a1b) ++ "\n" ++-         -- "a1: " ++ (DBLC.unpack a1) ++ "\n" ++-         -- "a2: " ++ (DBLC.unpack a2) ++ "\n" ++-         -- "k: " ++ (DBLC.unpack k) ++ "\n" ++-         -- "colon: " ++ (DBLC.unpack colon) ++ "\n" ++-         -- "s0: " ++ (DBLC.unpack s0) ++ "\n" ++-         -- "s1: " ++ (DBLC.unpack s1) ++ "\n" ++-         -- "s_: " ++ (DBLC.unpack s_) ++ "\n"----- Stripts the quotations around a string, if any; "\"hello\"" becomes "hello".--stripQuotations :: String -> String-stripQuotations ""                                     = ""-stripQuotations s | (head s == '"') && (last s == '"') = tail $ init s-                  | otherwise                          = s
− Network/XMPP/Session.hs 
@@ -1,906 +0,0 @@--- | Module:      $Header$---   Description: XMPP client session management module---   Copyright:   Copyright © 2010-2011 Jon Kristensen---   License:     BSD-3---   ---   Maintainer:  info@pontarius.org---   Stability:   unstable---   Portability: portable---   ---   This module will be documented soon.---- TODO: Send white-space characters with regular intervals to keep the---       connection alive.--- TODO: Add namespace support for stream/features?--- TODO: Add support for `ver optional' support for features?--- TODO: Presence priority?--- TODO: Stop the logger--- TODO: Catch errors--module Network.XMPP.Session ( XMPPInEvent (..)-                            , XMPPOutEvent (..)-                            , createSession ) where---import Network.XMPP.JID-import Network.XMPP.SASL-import Network.XMPP.Stanza-import Network.XMPP.Utilities--import Codec.Binary.UTF8.String-import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)-import Control.Concurrent (forkIO, threadDelay)-import Control.Monad.IO.Class (liftIO, MonadIO)-import Data.Enumerator (($$), Iteratee, continue, joinI,-                        run_, yield)-import Data.Enumerator.Binary (enumHandle, enumFile)-import Data.Maybe-import Data.String-import Data.XML.Types-import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput)-import Network-import Network.TLS-import Network.TLS.Cipher-import System.IO (BufferMode, BufferMode(NoBuffering))-import System.Log.HLogger-import System.Log.SimpleHLogger-import Text.XML.Enumerator.Parse (parseBytes, decodeEntities)-import Text.XML.Enumerator.Document (fromEvents)-import qualified Codec.Binary.Base64.String as CBBS-import qualified Data.ByteString as DB-import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack, fromChunks, toChunks, null)-import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack)-import qualified Data.Enumerator as E-import qualified Data.Enumerator.List as EL-import qualified Data.List as DL-import qualified Data.Text as DT-import qualified Data.Text.Lazy as DTL---type Server = String-type Port = Integer--type UserName = String-type Password = String-type Resource = String---data XMPPInEvent = XIEConnectionSucceeded |-                   XIEConnectionFailed |-                   XIEAuthenticationSucceeded |-                   XIEAuthenticationFailed |-                   XIEMessage Message |-                   XIEPresence Presence |-                   XIEIQ IQ |-                   -- XIEIQJingle | -- Added for Jingle sessions-                   -- XIEIQXTLS |   -- Added for XTLS connection-                   XIEDisconnect deriving (Eq, Show)--data XMPPOutEvent = XOEConnect Server Port |-                    XOEAuthenticate UserName Password Resource |-                    XOEMessage Message |-                    XOEPresence Presence |-                    XOEIQ IQ |-                    -- XOEIQJingle | -- Added for Jingle sessions-                    -- XOEIQXTLS |   -- Added for XTLS connection-                    XOEDisconnect deriving (Eq, Show)---data SecurityEvent = TLSSucceeded TLSCtx | TLSFailed---instance Show SecurityEvent where-  show (TLSSucceeded _) = "TLSSucceeded Ctx"-  show TLSFailed        = "TLSFailed"---data ConnectionState = Disconnected               |-                       ConnectedNotTLSSecured     |-                       ConnectedTLSSecured TLSCtx--instance Eq ConnectionState where-  (==) Disconnected Disconnected = True-  (==) ConnectedNotTLSSecured ConnectedNotTLSSecured = True-  (==) (ConnectedTLSSecured _) (ConnectedTLSSecured _) = True-  (==) _ _ = False--data AuthenticationState = AuthNotRequested    |-                           AuthRequested       |-                           Challenge1Processed |-                           Authenticated deriving (Eq)--data State = State { stateConnectionState :: ConnectionState-                   , stateAuthenticationState :: AuthenticationState-                   , stateHandle :: Maybe Handle-                   , stateServer :: Maybe (Server, Port)-                   , stateUserName :: Maybe String-                   , statePassword :: Maybe String-                   , stateResource :: Maybe String-                   , stateStreamID :: Maybe String }--defaultState = State { stateConnectionState = Disconnected-                     , stateAuthenticationState = AuthNotRequested-                     , stateHandle = Nothing-                     , stateServer = Nothing-                     , stateUserName = Nothing-                     , statePassword = Nothing-                     , stateResource = Nothing-                     , stateStreamID = Nothing }----- An XMLEvent is a high-level XMPP event generated by our XML parsing code.--data XMLEvent = XEBeginStream Stream | XEFeatures Features |-                XEChallenge Challenge | XESuccess Success |-                XEEndStream | XEIQ IQ | XEPresence Presence |-                XEMessage Message | XEOther String deriving (Show)----- Represents the top-level "<stream>" element.--data Stream = Stream { streamNamespace :: StreamNamespace-                     , streamID :: String-                     , streamVersion :: Float } deriving (Show)----- TODO: Do not make this assumption, but parse the element instead.--defaultStream id = Stream { streamNamespace = Client-                          , streamID = id-                          , streamVersion = 1.0 }----- The "<stream:features>" element.--data Features = Features { featuresStartTLS :: Bool-                         , featuresMechanisms :: [FeaturesMechanism]-                         , featuresCompressionMethods :: [CompressionMethod] } deriving (Show)----- TODO: Do not make this assumption, but parse the element instead.--featuresDefault = Features { featuresStartTLS = True,-                             featuresMechanisms = [DigestMD5],-                             featuresCompressionMethods = [] }----- TODO: Necessary?--data StreamNamespace = Client | Server deriving (Show)----- Authentication mechanisms. We only support DigestMD5 at this point.--data FeaturesMechanism = DigestMD5 | CramMD5 | Login | Plain | UnknownMechanism deriving (Show)--data UnknownMechanism = UM String deriving (Show)---data CompressionMethod = Zlib deriving (Show)----- Containers for information from SASL challenges and successes.--data Challenge = Chal String deriving (Show)--data Success = Succ String deriving (Show)---data InternalEvent = IEX XMLEvent |-                     IEO XMPPOutEvent |-                     IES SecurityEvent deriving (Show)----- | Creates a Pontarius XMPP session by setting up internal processes and state---   and creates the two (in and out) event channels that the XMPP client uses---   for communicating with Pontarius XMPP.--createSession :: IO (Chan XMPPInEvent, Chan XMPPOutEvent)--createSession = do-  logger <- simpleLogger "PontariusXMPP"-  loggerLog logger (Just ("Session", "createSession")) Info "Pontarius XMPP has started"-  -  -- Create client "in" and "out" channels (naming from the perspective of the-  -- XMPP client) as well as the internal event channel used by the state loop-  inChan <- newChan-  outChan <- newChan-  internalChan <- newChan-  -  -- Start to listen to client "out" events (client actions)-  forkIO $ clientListener outChan internalChan logger-  -  -- Start the state loop, the main loop of Pontarius XMPP-  forkIO $ stateLoop defaultState internalChan inChan logger-  -  return (inChan, outChan)----- Receives events from the XMPP client and forwards them to the state loop by--- using the internal event channel.--clientListener :: Chan XMPPOutEvent -> Chan InternalEvent -> Logger -> IO ()--clientListener c c_ l =-  do event <- readChan c-     loggerLog l (Just ("Session", "clientListener")) Debug $ "clientListener: Forwarding received client event: " ++ show (event)-     writeChan c_ (IEO event)-     clientListener c c_ l----- Processes internal events to possibly perform actions and update the session--- state. Note that the InternalEvent type wraps the external client events.--stateLoop :: State -> Chan InternalEvent -> Chan XMPPInEvent -> Logger -> IO ()--stateLoop s c c_ l =-  do event <- readChan c-     -- logDebug l $ "stateLoop: Received event: " ++ (show event)-     -- TODO: Debug with state?-     s' <- processEvent event-     stateLoop s' c c_ l-    where-      connectionState = stateConnectionState s-      authenticationState = stateAuthenticationState s-      handle = stateHandle s-      server = stateServer s-      userName = stateUserName s-      password = statePassword s-      resource = stateResource s-      streamID = stateStreamID s-      Just (serverHost, serverPort) = stateServer s-      tlsCtx = let ConnectedTLSSecured x = connectionState in x-      -      -- let xml = clientOutEventToXML clientEvent-      -- logDebug l $ "processEvent: Sending XML: " ++ xml-      -- sendData (fromJust tlsCtx) $ DBLC.pack $ encodeString $ xml-      -      processEvent (IEO clientOutEvent) = do-        loggerLog l (Just ("Session", "processEvent")) Debug $ "Processing client out event " ++ (show clientOutEvent)-        case clientOutEvent of-          XOEConnect serverHost_ serverPort_ -> do-            handle <- connectTo serverHost_ (PortNumber $ fromInteger serverPort_)-            hSetBuffering handle NoBuffering-            hPutStr handle $ encodeString $-              "<?xml version='1.0'?><stream:stream to='" ++ serverHost_ ++-              "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.or" ++-              "g/streams' version='1.0'>"-            hFlush handle-            -            -- Start XML enumerator, which will read from the handle to generate the-            -- relevant internal events-            forkIO $ xmlEnumerator c handle serverHost_ l-            -            return s { stateConnectionState = ConnectedNotTLSSecured-                     , stateHandle = Just handle-                     , stateServer = Just (serverHost_, serverPort_) }-          -          -- TODO: Function to verify certificate?-          XOEAuthenticate userName_ password_ resource_ -> do-            sendData tlsCtx $ DBLC.pack $ encodeString-              "<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='DIGEST-MD5'/>"-            return s { stateAuthenticationState = AuthRequested-                     , stateUserName = Just userName_-                     , statePassword = Just password_-                     , stateResource = Just resource_ }-          -          XOEPresence presence -> do-            presence' <- case stanzaID $ presenceStanza presence of-              Nothing -> do-                id <- getID-                return $ presence { presenceStanza = (presenceStanza presence) { stanzaID = Just (SID id) } }-              _ -> return presence-            -            let xml = presenceToXML presence'-            loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Will send presence XML: " ++ xml-            sendData tlsCtx $ DBLC.pack $ encodeString $ xml-            return s-          -          XOEMessage message -> do-            message' <- case stanzaID $ messageStanza message of-              Nothing -> do-                id <- getID-                return $ message { messageStanza = (messageStanza message) { stanzaID = Just (SID id) } }-              _ -> return message-            -            let xml = messageToXML message'-            loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Will send message XML: " ++ xml-            sendData tlsCtx $ DBLC.pack $ encodeString $ xml-            return s-          -          XOEIQ iq -> do-            iq' <- case stanzaID $ iqStanza iq of-              Nothing -> do-                id <- getID-                return $ case iq of-                  IQGet {} -> do-                    iq { iqGetStanza = (iqStanza iq) { stanzaID = Just (SID id) } }-                  IQSet {} -> do-                    iq { iqSetStanza = (iqStanza iq) { stanzaID = Just (SID id) } }-                  IQResult {} -> do-                    iq { iqResultStanza = (iqStanza iq) { stanzaID = Just (SID id) } }-              _ -> return iq-            -            let xml = iqToXML iq'-            loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Will send IQ XML: " ++ xml-            sendData tlsCtx $ DBLC.pack $ encodeString $ xml-            return s-          -          XOEDisconnect -> do-            -- TODO: Close stream-            return s-      -      -- TODO: processEvent (IES TLSFailed) =-      -      processEvent (IES (TLSSucceeded receivedTLSCtx)) =-        return (s { stateConnectionState = ConnectedTLSSecured receivedTLSCtx })-      -      -- A <stream:stream> element has begun-      -- TODO: Parse the XEStreamBegin object-      processEvent (IEX (XEBeginStream _)) = do-        loggerLog l (Just ("Session", "processEvent")) Debug "processEvent: A new stream has been opened"-        return s-      -      -- We have received <features> on an insecure stream-      -- TODO: Parse the XEFeatures object-      processEvent (IEX (XEFeatures _))-        | connectionState == ConnectedNotTLSSecured = do-          loggerLog l (Just ("Session", "processEvent")) Debug $-            "processEvent: Received features ([...]) on insecure stream; req" ++-            "uesting \"starttls\""-          hPutStr (fromJust handle) $-            "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>"-          hFlush (fromJust handle)-          return s-      -      -- We have received <features> on a secure and non-authenticated stream-      processEvent (IEX (XEFeatures _))-        | connectionState == ConnectedTLSSecured tlsCtx &&-          authenticationState /= Authenticated = do-            loggerLog l (Just ("Session", "processEvent")) Debug $-              "processEvent: Received features ([...]) on an unauthenticated" ++-              " secure stream"-            writeChan c_ $ XIEConnectionSucceeded-            return s-      -      -- We have received <features> on an authenticated secure stream; we are-      -- now ready to start processing client events-      processEvent (IEX (XEFeatures _))-        | connectionState == ConnectedTLSSecured tlsCtx = do-          loggerLog l (Just ("Session", "processEvent")) Debug $-            "processEvent: Received features ([...]) on an authenticated sec" ++-            "ure stream"-          loggerLog l (Just ("Session", "processEvent")) Info $ "processEvent: User has successfully logged in"-          case resource of-            Nothing -> do-              sendData tlsCtx $ DBLC.pack $ encodeString-                "<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" ++-                "s:xml:ns:xmpp-bind\"></bind></iq>"-              return ()-            _ -> do-              loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Setting resource: " ++-                (fromJust resource)-              sendData tlsCtx $ DBLC.pack $ encodeString-                "<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" ++-                "s:xml:ns:xmpp-bind\"><resource>" ++ fromJust resource ++-                "</resource></bind></iq>"-              return ()-          r <- getID-          sendData tlsCtx $ DBLC.pack $ encodeString $-            "<iq type=\"set\" id=\"" ++ r ++-            "\"><session xmlns=\"urn:ietf:params:xml:ns:xmpp-session\"/>" ++-            "</iq>"-          writeChan c_ $ XIEAuthenticationSucceeded-          return (s { stateAuthenticationState = Authenticated })-      -      -- We have received a SASL challenge on a secure stream-      processEvent (IEX (XEChallenge (Chal challenge)))-        | connectionState == ConnectedTLSSecured tlsCtx = do-          let challenge' = CBBS.decode challenge-          case authenticationState of-            AuthRequested -> do-              -- This is the first challenge - we need to calculate the reply-              loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Received initial challenge: " ++-                challenge ++ " (or " ++ challenge' ++ ")"-              random <- getID -- TODO: Length and content.-              case replyToChallenge1 challenge' serverHost (fromJust userName)-                   (fromJust password) random of-                Left reply -> do-                  let reply' = (filter (/= '\n') (CBBS.encode reply))-                  loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Sending challenge response: " ++-                    reply'-                  sendData tlsCtx $ DBLC.pack $ encodeString $-                    "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>" ++-                    reply' ++ "</response>"-                  return (s { stateAuthenticationState = Challenge1Processed } )-                Right error -> do-                  putStrLn $ show error-                  return s-            Challenge1Processed  -> do-              -- This is not the first challenge; [...]-              -- TODO: Can we assume "rspauth"?-              loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Received non-initial challenge: " ++-                challenge ++ " (or " ++ challenge' ++ ")"-              liftIO $ sendData tlsCtx $ DBLC.pack $ encodeString $-                "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/>"-              return s-      -      -- We have received a SASL "success" message over a secured connection-      -- TODO: Parse the success message?-      -- TODO: <?xml version='1.0'?>?-      processEvent (IEX (XESuccess (Succ _)))-        | connectionState == ConnectedTLSSecured tlsCtx = do-          loggerLog l (Just ("Session", "processEvent")) Debug $-            "processEvent: Received authentication success: [...]; restartin" ++-            "g stream" -- TODO-          sendData tlsCtx $ DBLC.pack $-            encodeString "<?xml version='1.0'?><stream:stream to='" ++-            serverHost ++-            "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++-            "streams' version='1.0'>"-          return s { stateAuthenticationState = Authenticated }-      -      -- Ignore id="bind_1" and session IQ result, otherwise create client event-      processEvent (IEX (XEIQ iqEvent))-        | authenticationState == Authenticated = do-          case shouldIgnoreIQ iqEvent of-            True ->-              return s-            False -> do-              loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Got IQ for client: " ++-                (show iqEvent)-              writeChan c_ $ XIEIQ iqEvent-              return s-      -      processEvent (IEX (XEPresence presenceEvent))-        | authenticationState == Authenticated = do-          loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Got presence for client: " ++-            (show presenceEvent)-          writeChan c_ $ XIEPresence presenceEvent-          return s-      -      processEvent (IEX (XEMessage messageEvent)) = do-        loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Got message for client: " ++-          (show messageEvent)-        writeChan c_ $ XIEMessage messageEvent-        return s-      -      -- We received an XML element that we didn't parse-      processEvent (IEX xmlEvent) = do-        loggerLog l (Just ("Session", "processEvent")) Warning $ "processEvent: XML event slipped through: " ++-          (show xmlEvent)-        return s--      shouldIgnoreIQ :: IQ -> Bool-      shouldIgnoreIQ i = case iqPayload i of-        Nothing -> False-        Just e -> case nameNamespace $ elementName e of-          Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-bind" -> True-          Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-session" -> True-          Just _ -> False-          Nothing -> False-        -parseIQ :: Element -> IQ-parseIQ e | typeAttr == "get" = let (Just payloadMust) = payload-                                in iqGet idAttr fromAttr toAttr Nothing-                                   payloadMust-          | typeAttr == "set" = let (Just payloadMust) = payload-                                in iqSet idAttr fromAttr toAttr Nothing-                                   payloadMust-          | typeAttr == "result" = iqResult idAttr fromAttr toAttr Nothing-                                   payload--  where-    -- TODO: Many duplicate functions from parsePresence.-    -    payload :: Maybe Element-    payload = case null (elementChildren e) of-      True -> Nothing-      False -> Just $ head $ elementChildren e-    -    typeAttr :: String-    typeAttr = case attributeText typeName e of-      -- Nothing -> Nothing-      Just a -> DT.unpack a-    -    fromAttr :: Maybe JID-    fromAttr = case attributeText fromName e of-      Nothing -> Nothing-      Just a -> stringToJID $ DT.unpack a-    -    toAttr :: Maybe JID-    toAttr = case attributeText toName e of-      Nothing -> Nothing-      Just a -> stringToJID $ DT.unpack a-    -    idAttr :: Maybe StanzaID-    idAttr = case attributeText idName e of-      Nothing -> Nothing-      Just a -> Just (SID (DT.unpack a))-    -    typeName :: Name-    typeName = fromString "type"-    -    fromName :: Name-    fromName = fromString "from"-    -    toName :: Name-    toName = fromString "to"-    -    idName :: Name-    idName = fromString "id"---- TODO: Parse xml:lang--parsePresence :: Element -> Presence-parsePresence e = presence idAttr fromAttr toAttr Nothing typeAttr (elementChildren e)-  where-    -- TODO: Many duplicate functions from parseIQ.-    -    typeAttr :: PresenceType-    typeAttr = case attributeText typeName e of-      Just t -> stringToPresenceType $ DT.unpack t-      Nothing -> Available-    -    fromAttr :: Maybe JID-    fromAttr = case attributeText fromName e of-      Nothing -> Nothing-      Just a -> stringToJID $ DT.unpack a-    -    toAttr :: Maybe JID-    toAttr = case attributeText toName e of-      Nothing -> Nothing-      Just a -> stringToJID $ DT.unpack a-    -    idAttr :: Maybe StanzaID-    idAttr = case attributeText idName e of-      Nothing -> Nothing-      Just a -> Just (SID (DT.unpack a))-    -    fromName :: Name-    fromName = fromString "from"-    -    typeName :: Name-    typeName = fromString "type"-    -    toName :: Name-    toName = fromString "to"-    -    idName :: Name-    idName = fromString "id"--parseMessage :: Element -> Message-parseMessage e = message idAttr fromAttr toAttr Nothing typeAttr (elementChildren e)-  where-    -- TODO: Many duplicate functions from parseIQ.-    -    typeAttr :: MessageType-    typeAttr = case attributeText typeName e of-      Just t -> stringToMessageType $ DT.unpack t-      Nothing -> Normal-    -    fromAttr :: Maybe JID-    fromAttr = case attributeText fromName e of-      Nothing -> Nothing-      Just a -> stringToJID $ DT.unpack a-    -    toAttr :: Maybe JID-    toAttr = case attributeText toName e of-      Nothing -> Nothing-      Just a -> stringToJID $ DT.unpack a-    -    idAttr :: Maybe StanzaID-    idAttr = case attributeText idName e of-      Nothing -> Nothing-      Just a -> Just (SID (DT.unpack a))-    -    fromName :: Name-    fromName = fromString "from"-    -    typeName :: Name-    typeName = fromString "type"-    -    toName :: Name-    toName = fromString "to"-    -    idName :: Name-    idName = fromString "id"---- stringToPresenceType "available" = Available--- stringToPresenceType "away" = Away--- stringToPresenceType "chat" = Chat--- stringToPresenceType "dnd" = DoNotDisturb--- stringToPresenceType "xa" = ExtendedAway--stringToPresenceType "probe" = Probe-stringToPresenceType "error" = PresenceError--stringToPresenceType "unavailable" = Unavailable-stringToPresenceType "subscribe" = Subscribe-stringToPresenceType "subscribed" = Subscribed-stringToPresenceType "unsubscribe" = Unsubscribe-stringToPresenceType "unsubscribed" = Unsubscribed---- presenceTypeToString Available = "available"---- presenceTypeToString Away = "away"--- presenceTypeToString Chat = "chat"--- presenceTypeToString DoNotDisturb = "dnd"--- presenceTypeToString ExtendedAway = "xa"--presenceTypeToString Unavailable = "unavailable"--presenceTypeToString Probe = "probe"-presenceTypeToString PresenceError = "error"--presenceTypeToString Subscribe = "subscribe"-presenceTypeToString Subscribed = "subscribed"-presenceTypeToString Unsubscribe = "unsubscribe"-presenceTypeToString Unsubscribed = "unsubscribed"--stringToMessageType "chat" = Chat-stringToMessageType "error" = MessageError-stringToMessageType "groupchat" = Groupchat-stringToMessageType "headline" = Headline-stringToMessageType "normal" = Normal-stringToMessageType s = OtherMessageType s--messageTypeToString Chat = "chat"-messageTypeToString MessageError = "error"-messageTypeToString Groupchat = "groupchat"-messageTypeToString Headline = "headline"-messageTypeToString Normal = "normal"-messageTypeToString (OtherMessageType s) = s--xmlEnumerator :: Chan InternalEvent -> Handle -> String -> Logger -> IO ()-xmlEnumerator c h s l = do-  loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: Starting to read insecure XML"-  run_ $ enumHandle 1 h $$ joinI $ parseBytes decodeEntities-    $$ xmlReader c [] 0-  loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: Unsecure stream ended - performing TLS handshake"-  t <- handshake' h s-  case t of-    Just tlsctx -> do loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: Handshake successful - st" ++-                        "arting to read secure XML"-                      writeChan c (IES (TLSSucceeded tlsctx))-                      run_ $ enumTLS tlsctx $$ joinI $ parseBytes decodeEntities-                        $$ xmlReader c [] 0-                      loggerLog l (Just ("Session", "processEvent")) Debug $-                        "xmlEnumerator: Secure stream ended, exiting"-                      return ()-    Nothing -> loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: TLS handshake failed" -- TODO: Event-  return ()--enumTLS :: TLSCtx -> E.Enumerator DB.ByteString IO b-enumTLS c s = loop c s where-  loop :: TLSCtx -> E.Step DB.ByteString IO b -> E.Iteratee DB.ByteString IO b-  loop c (E.Continue k) =-    do d <- recvData c-       case DBL.null d of-         True  -> loop c (E.Continue k)-         False -> k (E.Chunks $ DBL.toChunks d) E.>>== loop c-  loop _ step = E.returnI step--hPutStr' :: Handle -> String -> IO ()-hPutStr' h s = do-  hPutStr h $ encodeString "<?xml version='1.0'?><stream:stream to='" ++-       s ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++-       "streams' version='1.0'>"-  hFlush h--getTLSParams :: TLSParams-getTLSParams = TLSParams { pConnectVersion    = TLS10-                    , pAllowedVersions   = [TLS10,TLS11]-                    , pCiphers           = [cipher_AES256_SHA1] -- Check the rest-                    , pCompressions      = [nullCompression]-                    , pWantClientCert    = False-                    , pCertificates      = []-                    , onCertificatesRecv = \_ -> return True } -- Verify cert chain--handshake' :: Handle -> String -> IO (Maybe TLSCtx)-handshake' h s = do-  let t = getTLSParams-  r <- makeSRandomGen-  case r of-    Right sr -> do-      putStrLn $ show sr-      c <- client t sr h-      handshake c-      sendData c $ DBLC.pack $ encodeString "<?xml version='1.0'?><stream:stream to='" ++-       s ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++-       "streams' version='1.0'>"-      putStrLn ">>>>TLS data sended<<<<"-      return (Just c)-    Left ge -> do-      putStrLn $ show ge-      return Nothing----- TODO: Add logger--xmlReader :: Chan InternalEvent -> [Event] -> Int ->-             Iteratee Event IO (Maybe Event)--xmlReader ch [EventBeginDocument] 0 = xmlReader ch [] 0---- TODO: Safe to start change level here? We are doing this since the stream can--- restart.--- TODO: l < 2?-xmlReader ch [EventBeginElement name attribs] l-  | l < 3 && nameLocalName name == DT.pack "stream" &&-    namePrefix name == Just (DT.pack "stream") = do-      liftIO $ writeChan ch $ IEX $ XEBeginStream $ defaultStream "TODO"-      xmlReader ch [] 1--xmlReader ch [EventEndElement name] 1-  | namePrefix name == Just (DT.pack "stream") &&-    nameLocalName name == DT.pack "stream" = do-      liftIO $ writeChan ch $ IEX XEEndStream-      return Nothing---- Check if counter is one to forward it to related function.--- Should replace "reverse ((EventEndElement n):es)" with es--- ...-xmlReader ch ((EventEndElement n):es) 1-  | nameLocalName n == DT.pack "proceed" = E.yield Nothing (E.Chunks [])-  | otherwise = do-    -- liftIO $ putStrLn "Got an IEX Event..."-    liftIO $ writeChan ch $ IEX (processEventList (DL.reverse ((EventEndElement n):es)))-    xmlReader ch [] 1---- Normal condition, buffer the event to events list.-xmlReader ch es co = do-  head <- EL.head-  let co' = counter co head-  liftIO $ putStrLn $ show co' ++ "\t" ++ show head    -- for test-  case head of-    Just e -> xmlReader ch (e:es) co'-    Nothing -> xmlReader ch es co'----- TODO: Generate real event.-processEventList :: [Event] -> XMLEvent-processEventList e-  | namePrefix name == Just (DT.pack "stream") &&-    nameLocalName name == DT.pack "features" = XEFeatures featuresDefault-  | nameLocalName name == DT.pack "challenge" =-    let EventContent (ContentText c) = head es in XEChallenge $ Chal $ DT.unpack c-  | nameLocalName name == DT.pack "success" =-    let EventContent (ContentText c) = head es in XESuccess $ Succ $ DT.unpack c-  | nameLocalName name == DT.pack "iq" = XEIQ $ parseIQ $ eventsToElement e-  | nameLocalName name == DT.pack "presence" = XEPresence $ parsePresence $ eventsToElement e-  | nameLocalName name == DT.pack "message" = XEMessage $ parseMessage $ eventsToElement e-  | otherwise = XEOther $ elementToString $ Just (eventsToElement e)-      where-        (EventBeginElement name attribs) = head e-        es = tail e--eventsToElement :: [Event] -> Element-eventsToElement e = do-  documentRoot $ fromJust (run_ $ enum e $$ fromEvents)-    where-      enum :: [Event] -> E.Enumerator Event Maybe Document-      enum e_ (E.Continue k) = k $ E.Chunks e_-      enum e_ step = E.returnI step--counter :: Int -> Maybe Event -> Int-counter c (Just (EventBeginElement _ _)) = (c + 1)-counter c (Just (EventEndElement _) )    = (c - 1)-counter c _                       = c--presenceToXML :: Presence -> String-presenceToXML p = "<presence" ++ from ++ id' ++ to ++ type' ++ ">" ++-                  (elementsToString $ presencePayload p) ++ "</presence>"-  where-    s = presenceStanza p-    -    from :: String-    from = case stanzaFrom $ presenceStanza p of-      -- TODO: Lower-case-      Just s -> " from='" ++ (jidToString s) ++ "'"-      Nothing -> ""-    -    id' :: String-    id' = case stanzaID s of-      Just (SID s) -> " id='" ++ s ++ "'"-      Nothing -> ""-    -    to :: String-    to = case stanzaTo $ presenceStanza p of-      -- TODO: Lower-case-      Just s -> " to='" ++ (jidToString s) ++ "'"-      Nothing -> ""-    -    type' :: String-    type' = case presenceType p of-      Available -> ""-      t -> " type='" ++ (presenceTypeToString t) ++ "'"--iqToXML :: IQ -> String-iqToXML IQGet { iqGetStanza = s, iqGetPayload = p } =-  let type' = " type='get'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString (Just p)) ++ "</iq>"-  where-    from :: String-    from = case stanzaFrom s of-      -- TODO: Lower-case-      Just s -> " from='" ++ (jidToString s) ++ "'"-      Nothing -> ""-    -    id' :: String-    id' = case stanzaID s of-      Just (SID s) -> " id='" ++ s ++ "'"-      Nothing -> ""-    -    to :: String-    to = case stanzaTo s of-      -- TODO: Lower-case-      Just s -> " to='" ++ (jidToString s) ++ "'"-      Nothing -> ""--iqToXML IQSet { iqSetStanza = s, iqSetPayload = p } =-  let type' = " type='set'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString (Just p)) ++ "</iq>"-  where-    from :: String-    from = case stanzaFrom s of-      -- TODO: Lower-case-      Just s -> " from='" ++ (jidToString s) ++ "'"-      Nothing -> ""-    -    id' :: String-    id' = case stanzaID s of-      Just (SID s) -> " id='" ++ s ++ "'"-      Nothing -> ""-    -    to :: String-    to = case stanzaTo s of-      -- TODO: Lower-case-      Just s -> " to='" ++ (jidToString s) ++ "'"-      Nothing -> ""--iqToXML IQResult { iqResultStanza = s, iqResultPayload = p } =-  let type' = " type='result'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString p) ++ "</iq>"-  where-    from :: String-    from = case stanzaFrom s of-      -- TODO: Lower-case-      Just s -> " from='" ++ (jidToString s) ++ "'"-      Nothing -> ""-    -    id' :: String-    id' = case stanzaID s of-      Just (SID s) -> " id='" ++ s ++ "'"-      Nothing -> ""-    -    to :: String-    to = case stanzaTo s of-      -- TODO: Lower-case-      Just s -> " to='" ++ (jidToString s) ++ "'"-      Nothing -> ""--messageToXML :: Message -> String-messageToXML m = "<message" ++ from ++ id' ++ to ++ type' ++ ">" ++-                  (elementsToString $ messagePayload m) ++ "</message>"-  where-    s = messageStanza m-    -    from :: String-    from = case stanzaFrom $ messageStanza m of-      -- TODO: Lower-case-      Just s -> " from='" ++ (jidToString s) ++ "'"-      Nothing -> ""-    -    id' :: String-    id' = case stanzaID s of-      Just (SID s) -> " id='" ++ s ++ "'"-      Nothing -> ""-    -    to :: String-    to = case stanzaTo $ messageStanza m of-      -- TODO: Lower-case-      Just s -> " to='" ++ (jidToString s) ++ "'"-      Nothing -> ""-    -    type' :: String-    type' = case messageType m of-      Normal -> ""-      t -> " type='" ++ (messageTypeToString t) ++ "'"
− Network/XMPP/Stanza.hs 
@@ -1,237 +0,0 @@--- | Module:      $Header$---   Description: XMPP stanza types and utility functions---   Copyright:   Copyright © 2010-2011 Jon Kristensen---   License:     BSD-3---   ---   Maintainer:  info@pontarius.org---   Stability:   unstable---   Portability: portable---   ---   This module will be documented soon.---- Received stanzas can be assumed to have their ID and to fields set.---- TODO: Handle error stanzas--module Network.XMPP.Stanza ( StanzaID (SID)-                           , From-                           , To-                           , XMLLang-                           , Stanza (..)-                           , MessageType (..)-                           , Message (..)-                           , message-                           , PresenceType (..)-                           , Presence (..)-                           , presence-                           , IQ (..)-                           , iqGet-                           , iqSet-                           , iqResult-                           , iqStanza-                           , iqPayloadNamespace-                           , iqPayload ) where--import Network.XMPP.JID--import Data.XML.Types-import qualified Data.Text as DT---data StanzaID = SID String deriving (Eq, Show)-type From = JID-type To = JID-type XMLLang = String -- Validate, protect---data Stanza = Stanza { stanzaID :: Maybe StanzaID-                     , stanzaFrom :: Maybe From-                     , stanzaTo :: Maybe To-                     , stanzaLang :: Maybe XMLLang } deriving (Eq, Show)---stanza :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang -> Stanza--stanza i f t l = Stanza { stanzaID = i-                        , stanzaFrom = f-                        , stanzaTo = t-                        , stanzaLang = l }---data MessageType = Chat |-                   MessageError |-                   Groupchat |-                   Headline |-                   Normal | -- Default-                   OtherMessageType String deriving (Eq, Show)---data Message = Message { messageStanza :: Stanza-                       , messageType :: MessageType-                       , messagePayload :: [Element] } deriving (Eq, Show)---message :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang ->-           MessageType -> [Element] -> Message--message i f t l t_ p = Message { messageStanza = stanza i f t l-                               , messageType = t_-                               , messagePayload = p }---data PresenceType = Subscribe    | -- ^ Sender wants to subscribe to presence-                    Subscribed   | -- ^ Sender has approved the subscription-                    Unsubscribe  | -- ^ Sender is unsubscribing from presence-                    Unsubscribed | -- ^ Sender has denied or cancelled a-                                   --   subscription-                    Probe        | -- ^ Sender requests current presence;-                                   --   should only be used by servers-                    PresenceError | -- ^ Processing or delivery of previously-                                   --   sent presence stanza failed-                    Available    | -- Not part of type='' [...]-                    -- Away         |-                    -- Chat         |-                    -- DoNotDisturb |-                    -- ExtendedAway |-                    Unavailable-                  deriving (Eq, Show)----- | Presence stanzas are used to express an entity's network availability.--data Presence = Presence { presenceStanza :: Stanza-                         , presenceType :: PresenceType-                         , presencePayload :: [Element] } deriving (Eq, Show)---presence :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang ->-            PresenceType -> [Element] -> Presence--presence i f t l t_ p = Presence { presenceStanza = Stanza { stanzaID = i-                                                           , stanzaFrom = f-                                                           , stanzaTo = t-                                                           , stanzaLang = l }-                                 , presenceType = t_-                                 , presencePayload = p }---data IQ = IQGet { iqGetStanza :: Stanza, iqGetPayload :: Element } |-          IQSet { iqSetStanza :: Stanza, iqSetPayload :: Element } |-          IQResult { iqResultStanza :: Stanza-                   , iqResultPayload :: Maybe Element } deriving (Eq, Show)---iqGet :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang -> Element ->-         IQ--iqGet i f t l p = IQGet { iqGetStanza = Stanza { stanzaID = i-                                               , stanzaFrom = f-                                               , stanzaTo = t-                                               , stanzaLang = l }-                        , iqGetPayload = p }---iqSet :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang -> Element ->-         IQ--iqSet i f t l p = IQSet { iqSetStanza = Stanza { stanzaID = i-                                               , stanzaFrom = f-                                               , stanzaTo = t-                                               , stanzaLang = l }-                        , iqSetPayload = p }---iqResult :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang ->-            Maybe Element -> IQ--iqResult i f t l p = IQResult { iqResultStanza = Stanza { stanzaID = i-                                                        , stanzaFrom = f-                                                        , stanzaTo = t-                                                        , stanzaLang = l }-                              , iqResultPayload = p }---iqStanza :: IQ -> Stanza-iqStanza (IQGet { iqGetStanza = s })       = s-iqStanza (IQSet { iqSetStanza = s })       = s-iqStanza (IQResult { iqResultStanza = s }) = s--iqPayload :: IQ -> Maybe Element-iqPayload (IQGet {iqGetPayload = p}) = Just p-iqPayload (IQSet {iqSetPayload = p}) = Just p-iqPayload (IQResult {iqResultPayload = p}) = p--iqPayloadNamespace :: IQ -> Maybe String-iqPayloadNamespace i = case iqPayload i of-  Nothing -> Nothing-  Just p -> case nameNamespace $ elementName p of-    Nothing -> Nothing-    Just n -> Just (DT.unpack n)----- =============================================================================---  CODE NOT YET USED--- =============================================================================----- | All stanzas (IQ, message, presence) can cause errors, which looks like---   <stanza-kind to='sender' type='error'>. These errors are of one of the---   types listed below.--data StanzaErrorType = Cancel   | -- ^ Error is unrecoverable - do not retry-                       Continue | -- ^ Conditition was a warning - proceed-                       Modify   | -- ^ Change the data and retry-                       Auth     | -- ^ Provide credentials and retry-                       Wait       -- ^ Error is temporary - wait and retry-                       deriving (Eq, Show)----- | The stanza errors are accommodated with one of the error conditions listed---   below. The ones that are not self-explainatory should be documented below.--data StanzaErrorCondition = BadRequest            | -- ^ Malformed XML-                            Conflict              | -- ^ Resource or session-                                                    --   with name already-                                                    --   exists-                            FeatureNotImplemented |-                            Forbidden             | -- ^ Insufficient-                                                    --   permissions-                            Gone                  | -- ^ Entity can no longer-                                                    --   be contacted at this-                                                    --   address-                            InternalServerError   |-                            ItemNotFound          |-                            JIDMalformed          |-                            NotAcceptable         | -- ^ Does not meet policy-                                                    --   criteria-                            NotAllowed            | -- ^ No entity may perform-                                                    --   this action-                            NotAuthorized         | -- ^ Must provide proper-                                                    --   credentials-                            PaymentRequired       |-                            RecipientUnavailable  | -- ^ Temporarily-                                                    --   unavailable-                            Redirect              | -- ^ Redirecting to other-                                                    --   entity, usually-                                                    --   temporarily-                            RegistrationRequired  |-                            RemoteServerNotFound  |-                            RemoteServerTimeout   |-                            ResourceConstraint    | -- ^ Entity lacks the-                                                    --   necessary system-                                                    --   resources-                            ServiceUnavailable    |-                            SubscriptionRequired  |-                            UndefinedCondition    | -- ^ Application-specific-                                                    --   condition-                            UnexpectedRequest       -- ^ Badly timed request-                            deriving (Eq, Show)----- IM/RFC:--- data PresenceStatus = PS String deriving (Eq, Show)---- -- TODO: Validate input.---- presenceStatus :: String -> Maybe PresenceStatus--- presenceStatus s = Just (PS s)
− Network/XMPP/Utilities.hs 
@@ -1,109 +0,0 @@--- | Module:      $Header$---   Description: Utility functions for Pontarius XMPP; currently only random ID---                generation functions---   Copyright:   Copyright © 2010-2011 Jon Kristensen---   License:     BSD-3---   ---   Maintainer:  info@pontarius.org---   Stability:   unstable---   Portability: portable---   ---   This module will be documented soon.---- TODO: Document this module--- TODO: Make is possible to customize characters--- TODO: Make it possible to customize length--module Network.XMPP.Utilities ( elementToString-                              , elementsToString-                              , getID-                              , getID_) where--import Data.Word-import Data.XML.Types-import System.Crypto.Random-import System.Random-import qualified Data.ByteString as DB-import qualified Data.Map as DM-import qualified Data.Text as DT------ =============================================================================---  ID Generation--- =============================================================================---characters :: String-characters = "abcdef0123456789"--getID :: IO String-getID = getID_ 8--getID_ :: Int -> IO String-getID_ i =-  do se <- getSeed-     let st = mkStdGen se-     return $ take i (idSequence st)-    where-      idSequence :: StdGen -> String-      idSequence st = [characters !! (fst $ rand st)] ++ idSequence (snd $ rand st)-      rand :: StdGen -> (Int, StdGen)-      rand st = randomR (0, length characters - 1) st--getSeed :: IO Int-getSeed =-  do h <- openHandle-     b <- hGetEntropy h 8-     let w = DB.unpack b-     let s = seed w-     closeHandle h-     return s-    where seed :: [Word8] -> Int-          seed []     = 1-          seed (x:xs) = ((fromIntegral x) + 1) * (seed xs)------ =============================================================================---  XML Utilities--- =============================================================================---elementsToString :: [Element] -> String-elementsToString [] = ""-elementsToString (e:es) = (elementToString $ Just e) ++ elementsToString es--elementToString :: Maybe Element -> String-elementToString Nothing = ""-elementToString (Just e) = "<" ++ nameToString (elementName e) ++ xmlns ++-                           attributes (DM.toList (elementAttributes e)) ++-                           ">" ++ (nodesToString $ elementNodes e) ++ "</" ++-                           nameToString (elementName e) ++ ">"-  where-    xmlns :: String-    xmlns = case nameNamespace $ elementName e of-      Nothing -> ""-      Just t -> " xmlns='" ++ (DT.unpack t) ++ "'"-    -    nameToString :: Name -> String-    nameToString Name { nameLocalName = n, namePrefix = Nothing } = DT.unpack n-    nameToString Name { nameLocalName = n, namePrefix = Just p } =-      (DT.unpack p) ++ ":" ++ (DT.unpack n)--    contentToString :: Content -> String-    contentToString (ContentText t) = DT.unpack t-    contentToString (ContentEntity t) = DT.unpack t-    -    attributes :: [(Name, [Content])] -> String-    attributes [] = ""-    attributes ((n, c):t) = (" " ++ (nameToString n) ++ "='" ++-                             concat (map contentToString c) ++ "'") ++-                            attributes t-    -    nodesToString :: [Node] -> String-    nodesToString [] = ""-    nodesToString ((NodeElement e):ns) = (elementToString $ Just e) ++-                                         (nodesToString ns)-    nodesToString ((NodeContent c):ns) = (contentToString c) ++-                                         (nodesToString ns)
− README 
@@ -1,23 +0,0 @@-Pontarius XMPP aims to be a secure and easy-to-use XMPP library for Haskell. We-have just released a third alpha version with the following features:--  * Client-to-server Transport Layer Security and DIGEST-MD5 SASL Authentication-  * Concurrent, Flexible and Event-based API for XMPP Client Developers-  * Support for Info/Query, Presence and Message Stanzas-  * Interoperable XML Parsing (Using enumerator, xml-enumerator and xml-types)--Please note that we are not recommending anyone to use Pontarius XMPP at this-time as it’s still in an experimental stage and will have its API and data types-modified. However, if you are interested to use Pontarius XMPP anyway, feel free-to contact the Pontarius project and we will try to help you get started. You-can also see the Example directory for a usage example.--We are currently working on general improvements, securing the client-to-client-communication and having the library support all of RFC 3920: XMPP Core.--We will release the next version, 0.1 Alpha 4, on the 4th of May.--Look at the Pontarius web site <http://www.pontarius.org/>, the Pontarius XMPP-web page <http://www.pontarius.org/projects/pontarius-xmpp/> and the Pontarius-XMPP Hackage page <http://hackage.haskell.org/package/pontarius-xmpp/> for more-information.
+ README.md view
@@ -0,0 +1,112 @@+Pontarius XMPP+==============++Pontarius XMPP is 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 was part of the+Pontarius project, 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+---------------++The latest release of Pontarius XMPP, as well as its module API pages, can+always be found at [the Pontarius XMPP Hackage+page](http://hackage.haskell.org/package/pontarius-xmpp/).++_Note:_ Pontarius XMPP is still in its Alpha phase. Pontarius XMPP is not yet+feature-complete, it may contain bugs, and its API may change between versions.++The first thing to do is to import the modules that we are going to use. We are+also using the OverloadedStrings LANGUAGE pragma in order to be able to type+<code>Text</code> values like strings.++    {-# LANGUAGE OverloadedStrings #-}++    import Network.Xmpp++    import Control.Monad+    import Data.Default+    import System.Log.Logger++Pontarius XMPP supports [hslogger](http://hackage.haskell.org/package/hslogger)+logging. Start by enabling console logging.++    updateGlobalLogger "Pontarius.Xmpp" $ setLevel DEBUG++When this is done, a <code>Session</code> object can be acquired by calling+<code>session</code>. This object will be used for interacting with the library.++    result <- session+                 "example.com"+                  (Just (\_ -> ( [scramSha1 "username" Nothing "password"])+                               , Nothing))+                  def++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+<code>Control.Monad.Error</code> instance, you can utilize the+<code>ErrorT</code> monad transformer for error handling. A more simple way of+doing it could be doing something like this:++    sess <- case result of+                Right s -> return s+                Left e -> error $ "XmppFailure: " ++ (show e)++Next, let us set our status to Online.++    sendPresence 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 sender. This can be done like so:++    forever $ do+        msg <- getMessage sess+        case answerMessage msg (messagePayload msg) of+            Just answer -> sendMessage answer sess+            Nothing -> putStrLn "Received message with no sender."++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>.++For a public domain example of a simple Pontarius XMPP (Cabal) project, refer to+the examples/echoclient directory.
Setup.hs view
@@ -1,3 +1,2 @@ import Distribution.Simple- main = defaultMain
− XTLS.hs 
@@ -1,75 +0,0 @@-{-# LANGUAGE OverloadedStrings #-} ---module XTLS (start) where--import Network.XMPP-import Control.Concurrent (forkIO)-import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)--import Data.XML.Types-import Network.XMPP.Stanza-import Control.Monad ((>=>))-import Data.Maybe--data State = State {}--start :: IO ()-start = putStrLn "Test"--stateLoop :: State -> Chan XMPPInEvent -> Chan XMPPOutEvent -> IO ()-stateLoop s c c_ = do-  e <- readChan c-  s' <- processEvent e s c_-  stateLoop s' c c_--processEvent :: XMPPInEvent -> State -> Chan XMPPOutEvent -> IO State--- processEvent (PATTERN_MATCHING) s c = do---   return s-processEvent (XIEIQ iq) s c = do-  -- putStrLn-  case xtlsOrJingle iq of-    'j' -> return s-    'x' -> return s-    'n' -> return s--xtlsOrJingle :: IQ -> Char-xtlsOrJingle iq =-  case iqPayloadNamespace iq of-    Just "urn:xmpp:jingle:1" ->-      case isXTLS $ head $ getContent (fromJust $ iqPayload iq) of-        []    -> 'j'-        other -> 'x'-    other -> 'n'-    where-      isXTLS :: Element -> [Element]-      isXTLS = elementChildren >=> isNamed xtlsName--      getContent :: Element -> [Element]-      getContent = elementChildren >=> isNamed "content"---xtlsName :: Name-xtlsName = ( "{urn:xmpp:jingle:security:xtls:0}security" :: Name )---- Jingle Event base on the XEP-166-data JingleEvent = ContentAccept | ContentAdd | ContentModify | ContentReject |-                   ContentRemove | DiscriptionInfo | TransportAccept |-                   TransportInfo | TransportReject | TransportReplace--data JingleSession = Initiated   { sid :: String , candidate :: [Candidate] } |-                     Accepted    { sid :: String , candidate :: [Candidate] } |-                     Media       { sid :: String } |-                     Terminated  { sid :: String }--data Candidate = Candidate { id :: Int ,-                             ip :: String ,-                             portNum :: Int ,-                             priority :: Int }--data Transport = IBB { transid :: String , blockSize :: Int} |-                 OBB { transid :: String } -- TODO : define the OBB---data XTLSSecurity = XTLSSecurity { fingerPrint :: String , methods :: [MethodName]}-data MethodName = SRP | X509
+ benchmarks/Bench.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Criterion.Main+import Network.Xmpp.Types++bench_jidFromTexts = whnf (\(a,b,c) -> jidFromTexts a b c)+                            ( Just "+\227\161[\\3\8260\&4"+                            , "\242|8e3\EOTrf6\DLEp\\\a"+                            , Just ")\211\226")++main = do defaultMain [bench "jidFromTexts 2" bench_jidFromTexts]
+ examples/echoclient/LICENSE.md view
@@ -0,0 +1,2 @@+The `Main.hs', `Setup.hs', and `echoclient.cabal' files in this directory are in+the public domain.
+ examples/echoclient/Main.hs view
@@ -0,0 +1,43 @@+{-++This directory defines a project that illustrates how to connect, authenticate,+set a simple presence, receive message stanzas, and echo them back to whoever is+sending them, using Pontarius XMPP. This file is in the public domain.++-}++{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Monad+import Data.Default+import Lens.Family2+import Network.Xmpp+import Network.Xmpp.Internal (TlsBehaviour(..))+import System.Log.Logger+++main :: IO ()+main = do+    updateGlobalLogger "Pontarius.Xmpp" $ setLevel DEBUG+    result <- session+                 "test.pontarius.org"+                  (Just (\_ -> ( [scramSha1 "testuser1" Nothing "pwd1"])+                               , Nothing))+                  $ def & streamConfigurationL . tlsBehaviourL .~ PreferPlain+                        & streamConfigurationL . connectionDetailsL .~+                            UseHost "localhost" 5222+                        & onConnectionClosedL .~ reconnectSession++    sess <- case result of+                Right s -> return s+                Left e -> error $ "XmppFailure: " ++ (show e)+    sendPresence def sess+    forever $ do+        msg <- getMessage sess+        case answerMessage msg (messagePayload msg) of+            Just answer -> sendMessage answer sess >> return ()+            Nothing -> putStrLn "Received message with no sender."+  where+    reconnectSession sess failure = reconnect' sess >> return ()
+ examples/echoclient/README.md view
@@ -0,0 +1,6 @@+This directory defines a project that illustrates how to connect, authenticate,+set a simple presence, receive message stanzas, and echo them back to whoever is+sending them, using Pontarius XMPP.++The `Main.hs', `Setup.hs', and `echoclient.cabal' files in this directory may be+used freely, as they are in the public domain.
+ examples/echoclient/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/echoclient/echoclient.cabal view
@@ -0,0 +1,23 @@+-- This directory defines a project that illustrates how to connect,+-- authenticate, set a simple presence, receive message stanzas, and echo them+-- back to whoever is sending them, using Pontarius XMPP. This file is in the+-- public domain.++Name:           echoclient+Version:        0.0.0.0+Cabal-Version:  >= 1.6+Build-Type:     Simple+License:        OtherLicense+Copyright:      Mahdi Abdinejadi, Jon Kristensen, Philipp Balzarek+Synopsis:       Echo client test program for Pontarius XMPP++Executable echoclient+  Build-Depends:  base+                , data-default+                , hslogger+                , lens-family+                , mtl+                , pontarius-xmpp+                , text+                , tls+  Main-Is:        Main.hs
− install.sh 
@@ -1,5 +0,0 @@-#!/bin/sh-runhaskell Setup.hs configure --user-runhaskell Setup.hs build-runhaskell Setup.hs install-
pontarius-xmpp.cabal view
@@ -1,95 +1,213 @@--- TODO: Set dependency versions.--- TODO: Highlighting bug: The last line of the description.+Cabal-Version: 2.2+Name:          pontarius-xmpp+Version:       0.5.7.2+Build-Type:    Simple+License:       BSD-3-Clause+License-File:  LICENSE.md+Copyright:     Dmitry Astapov, Pierre Kovalev, Mahdi Abdinejadi, Jon Kristensen,+               IETF Trust, Philipp Balzarek, Sergey Alirzaev+Author:        Philipp Balzarek+Maintainer:    l29ah@cock.li+Stability:     alpha+Homepage:      https://github.com/l29ah/pontarius-xmpp/+Bug-Reports:   https://github.com/l29ah/pontarius-xmpp/issues/+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 == 9.8.4 -Name:               pontarius-xmpp-Version:            0.0.3.0-Cabal-Version:      >= 1.6-Build-Type:         Simple-License:            BSD3-License-File:       LICENSE-Copyright:          Copyright © 2011, Jon Kristensen-Author:             Jon Kristensen, Mahdi Abdinejadi-Maintainer:         jon.kristensen@pontarius.org-Stability:          alpha-Homepage:           http://www.pontarius.org/projects/pontarius-xmpp/-Bug-Reports:        mailto:info@pontarius.org-Package-URL:        http://www.pontarius.org/releases/pontarius-xmpp-0.0.3.0.tar.gz-Synopsis:           A (prototyped) secure and easy to use XMPP library-Description:        A work in progress of an implementation of RFC 3920: XMPP-                    Core.-Category:           Network-Tested-With:        GHC ==6.12.3--- Data-Files:--- Data-Dir:--- Extra-Source-Files:--- Extra-Tmp-Files:+Extra-Source-Files: README.md+                  , ChangeLog.md+                  , examples/echoclient/echoclient.cabal+                  , examples/echoclient/LICENSE.md+                  , examples/echoclient/Main.hs+                  , examples/echoclient/README.md+                  , examples/echoclient/Setup.hs +Flag with-th {+  Description: Enable Template Haskell support+  Default:     True+}++-- kludge for https://github.com/haskell/cabal/issues/2032+common stuff+  Build-Depends: attoparsec           >=0.10.0.3+               , base                 >4 && <5+               , base64-bytestring    >=0.1.0.0+               , binary               >=0.4.1+               , conduit              >=1.3 && < 1.4+               , containers           >=0.4.0.0+               , crypto-api           >=0.9+               , cryptohash           >=0.6.1+               , cryptohash-cryptoapi >=0.1+               , data-default         >=0.2+               , dns                  >=3.0+               , exceptions           >=0.6+               , hslogger             >=1.1.0+               , iproute              >=1.2.4+               , lens+               , lens-family+               , lifted-base          >=0.1.0.1+               , mtl                  >=2.0.0.0+               , network              >=2.3.1.0+               , profunctors          >= 4+               , pureMD5              >=2.1.2.1+               , random               >=1.0.0.0+               , resourcet            >=0.3.0+               , split                >=0.1.2.3+               , stm                  >=2.4+               , stringprep           >=1.0.0+               , text                 >=0.11.1.5+               , tls                  >=1.3.9+               , transformers         >=0.3+               , unbounded-delays     >=0.1+               , void                 >=0.5.5+               , crypton-x509-system  >=1.4+               , xml-conduit          >=1.1.0.7+               , xml-picklers         >=0.3.3+               , xml-types            >=0.3.1+               , bytestring           >=0.9.1.9+  If flag(with-th) && impl(ghc >=7.6.1) {+    Build-Depends: template-haskell >=2.5+  }+ Library-  Exposed-Modules:   Network.XMPP, Network.XMPP.JID, Network.XMPP.SASL,-                     Network.XMPP.Session, Network.XMPP.Stanza,-                     Network.XMPP.Utilities-  Exposed:           True-  Build-Depends:     hlogger ==0.0.3.0, base >= 2 && < 5, enumerator,-                     crypto-api, base64-string, regex-posix, pureMD5,-                     utf8-string, network, xml-types, text, transformers,-                     bytestring, binary, random, xml-enumerator, tls ==0.4.1,-                     containers-  -- Other-Modules:-  -- HS-Source-Dirs:-  -- Extensions:-  -- Build-Tools:-  -- Buildable:-  -- GHC-Options:-  -- GHC-Prof-Options:-  -- Hugs-Options:-  -- NHC98-Options:-  -- Includes:-  -- Install-Includes:-  -- Include-Dirs:-  -- C-Sources:-  -- Extra-Libraries:-  -- Extra-Lib-Dirs:-  -- CC-Options:-  -- LD-Options:-  -- Pkgconfig-Depends:-  -- Frameworks:+  import: stuff+  hs-source-dirs: source+  Exposed: True+  Exposed-modules: Network.Xmpp+                 , Network.Xmpp.IM+                 , Network.Xmpp.Internal+                 , Network.Xmpp.Lens+                 , Network.Xmpp.Concurrent+                 , 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.Types+                 , Network.Xmpp.IM.Message+                 , Network.Xmpp.IM.Presence+                 , Network.Xmpp.IM.PresenceTracker+                 , Network.Xmpp.IM.Roster+                 , Network.Xmpp.IM.Roster.Types+                 , Network.Xmpp.IM.PresenceTracker.Types+                 , Network.Xmpp.Marshal+                 , Network.Xmpp.Sasl+                 , Network.Xmpp.Sasl.Common+                 , Network.Xmpp.Sasl.Mechanisms+                 , Network.Xmpp.Sasl.Mechanisms.DigestMd5+                 , Network.Xmpp.Sasl.Mechanisms.Plain+                 , Network.Xmpp.Sasl.Mechanisms.Scram+                 , Network.Xmpp.Sasl.StringPrep+                 , Network.Xmpp.Sasl.Types+                 , Network.Xmpp.Stanza+                 , Network.Xmpp.Stream+                 , Network.Xmpp.Tls+                 , Network.Xmpp.Types+                 , Network.Xmpp.Utilities --- Executable pontarius-xmpp-test-  -- Main-Is:           Test.hs-  -- Build-Depends:     hlogger ==0.0.3.0, base >= 2 && < 5, enumerator,-  --                    crypto-api, base64-string, regex-posix, pureMD5,-  --                    utf8-string, network, xml-types, text, transformers,-  --                    bytestring, binary, random, xml-enumerator, tls ==0.4.1,-  --                    containers-  -- Other-Modules:-  -- HS-Source-Dirs:-  -- Extensions:-  -- Build-Tools:-  -- Buildable:-  -- GHC-Options:-  -- GHC-Prof-Options:-  -- Hugs-Options:-  -- NHC98-Options:-  -- Includes:-  -- Install-Includes:-  -- Include-Dirs:-  -- C-Sources:-  -- Extra-Libraries:-  -- Extra-Lib-Dirs:-  -- CC-Options:-  -- LD-Options:-  -- Pkgconfig-Depends:-  -- Frameworks:+  if flag(with-th) && impl(ghc >= 7.6.1)+    CPP-Options: -DWITH_TEMPLATE_HASKELL+  default-language:    Haskell2010 +Test-Suite tests+  import: stuff+  Type: exitcode-stdio-1.0+  main-is: Main.hs+  Build-Depends: Cabal+               , QuickCheck+               , async+               , async+               , base+               , conduit+               , containers+               , data-default+               , generic-arbitrary+               , hslogger+               , hspec+               , hspec-expectations+               , lens+               , mtl+               , network+               , pontarius-xmpp+               , quickcheck-instances+               , ranges+               , smallcheck+               , stm+               , stringprep >= 1.0.0+               , tasty+               , tasty-hspec+               , tasty-hunit+               , tasty-quickcheck+               , tasty-th+               , text+               , transformers+               , xml-picklers+               , xml-types+  HS-Source-Dirs: tests+  Other-modules: Tests.Arbitrary+               , Tests.Arbitrary.Common+               , Tests.Arbitrary.Xml+               , Tests.Arbitrary.Xmpp+               , Tests.Parsers+               , Tests.Picklers+               , Tests.Stream+  ghc-options: -O2 -fno-warn-orphans -fconstraint-solver-iterations=10+  default-language:    Haskell2010++Test-Suite runtests+  import: stuff+  -- requires credentials to auth at a remote server+  Buildable: False+  Type: exitcode-stdio-1.0+  hs-source-dirs: tests+  main-is: Run.hs+  other-modules: Run.Payload+               , Run.SendReceive+               , Run.Google+               , Run.Config+  GHC-Options: -threaded+  Build-Depends: base+               , HUnit+               , configurator+               , directory+               , filepath+               , hslogger+               , hspec+               , hspec-expectations+               , mtl+               , network+               , pontarius-xmpp+               , stm+               , text+               , xml-picklers+               , xml-types+               , tasty+               , tasty-hunit+               , tls+  default-language:    Haskell2010++benchmark benchmarks+  import: stuff+  type: exitcode-stdio-1.0+  build-depends: base+               , criterion+               , pontarius-xmpp+  hs-source-dirs: benchmarks+  main-is: Bench.hs+  ghc-options: -O2+  default-language:    Haskell2010+ Source-Repository head-  Type:     darcs-  -- Module:-  Location: https://patch-tag.com/r/jonkri/pontarius-xmpp-  -- Subdir:+  Type: git+  Location: https://github.com/l29ah/pontarius-xmpp.git  Source-Repository this-  Type:     darcs-  -- Module:-  Location: https://patch-tag.com/r/jonkri/pontarius-xmpp-  Tag:      0.0.3.0-  -- Subdir:+  Type: git+  Location: https://github.com/l29ah/pontarius-xmpp.git+  Tag: 0.5.7.2
+ source/Network/Xmpp.hs view
@@ -0,0 +1,255 @@+-- |+-- Module:      $Header$+--+-- Stability:   unstable+-- Portability: portable+--+-- The Extensible Messaging and Presence Protocol (XMPP) is an open technology+-- for near-real-time communication, which powers a wide range of applications+-- including instant messaging, presence, multi-party chat, voice and video+-- calls, collaboration, lightweight middleware, content syndication, and+-- generalized routing of XML data. XMPP provides a technology for the+-- asynchronous, end-to-end exchange of structured data by means of direct,+-- persistent XML streams among a distributed network of globally addressable,+-- presence-aware clients and servers.+--+-- Pontarius XMPP is an XMPP client library, implementing the core capabilities+-- of XMPP (RFC 6120): setup and tear-down of XML streams, channel encryption,+-- authentication, error handling, and communication primitives for messaging.+--+-- For low-level access to Pontarius XMPP, see the "Network.Xmpp.Internal"+-- module.+--+-- Getting Started+--+-- We use 'session' to create a session object and connect to a server. Here we+-- use the default 'SessionConfiguration'.+--+-- @+-- sess <- session realm (simpleAuth \"myUsername\" \"mypassword\") def+-- @+--+-- Defining 'AuthData' can be a bit unwieldy, so 'simpleAuth' gives us a+-- reasonable default. Though, for improved security, we should consider+-- restricting the mechanisms to 'scramSha1' whenever we can.+--+-- Next we have to set the presence to online, otherwise we won't be able to+-- send or receive stanzas to/from other entities.+--+-- @+-- sendPresence presenceOnline sess+-- @+--+{-# LANGUAGE CPP, NoMonomorphismRestriction, OverloadedStrings #-}++module Network.Xmpp+  ( -- * Session management+    Session+  , session+  , setConnectionClosedHandler+  , reconnect+  , reconnect'+  , reconnectNow+  , StreamConfiguration(..)+  , SessionConfiguration(..)+  , ConnectionDetails(..)+  , ConnectionState(..)+  , closeConnection+  , endSession+  , waitForStream+  , streamState+    -- ** Feature+  , StreamFeatures(..)+  , getFeatures+    -- ** Authentication handlers+    -- | The use of 'scramSha1' is /recommended/, but 'digestMd5' might be+    -- useful for interaction with older implementations.+  , SaslHandler+  , AuthData+  , Username+  , Password+  , AuthZID+  , simpleAuth+  , scramSha1+  , plain+  , digestMd5+  -- * Addressing+  -- | A JID (historically: Jabber ID) is XMPPs native format+  -- for addressing entities in the network. It is somewhat similar to an e-mail+  -- address, but contains three parts instead of two.+  , Jid+#if WITH_TEMPLATE_HASKELL+  , jid+  , 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+  -- 3 flavors:+  --+  --  * /Message/, for traditional push-style message passing between peers+  --+  --  * /Presence/, for communicating status updates+  --+  --  * /Info/\//Query/ (or /IQ/), for request-response semantics communication+  --+  -- All stanza types have the following attributes in common:+  --+  --  * The /id/ attribute is used by the originating entity to track any+  --    response or error stanza that it might receive in relation to the+  --    generated stanza from another entity (such as an intermediate server or+  --    the intended recipient).  It is up to the originating entity whether the+  --    value of the 'id' attribute is unique only within its current stream or+  --    unique globally.+  --+  --  * The /from/ attribute specifies the JID of the sender.+  --+  --  * The /to/ attribute specifies the JID of the intended recipient for the+  --    stanza.+  --+  --  * The /type/ attribute specifies the purpose or context of the message,+  --    presence, or IQ stanza. The particular allowable values for the 'type'+  --    attribute vary depending on whether the stanza is a message, presence,+  --    or IQ stanza.+  , 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+  -- an 'InstantMessage'+  , Message(..)+  , message+  , MessageError(..)+  , MessageType(..)+  -- *** Creating+  , answerMessage+  -- *** Sending+  , sendMessage+  -- *** Receiving+  , pullMessage+  , getMessage+  , getMessageA+  , waitForMessage+  , waitForMessageA+  , waitForMessageError+  , waitForMessageErrorA+  , filterMessages+  , filterMessagesA+  -- ** Presence+  -- | XMPP includes the ability for an entity to advertise its network+  -- availability, or "presence", to other entities. In XMPP, this availability+  -- for communication is signaled end-to-end by means of a dedicated+  -- communication primitive: the presence stanza.+  , Presence(..)+  , PresenceType(..)+  , PresenceError(..)+  -- *** Creating+  , presence+  , presenceOffline+  , presenceOnline+  , presenceSubscribe+  , presenceSubscribed+  , presenceUnsubscribe+  , presenceUnsubscribed+  , presTo+  -- *** Sending+  -- | Sends a presence stanza. In general, the presence stanza should have no+  -- 'to' attribute, in which case the server to which the client is connected+  -- will broadcast that stanza to all subscribed entities. However, a+  -- publishing client may also send a presence stanza with a 'to' attribute, in+  -- which case the server will route or deliver that stanza to the intended+  -- recipient.+  , sendPresence+  -- *** Receiving+  , pullPresence+  , waitForPresence+  -- ** IQ+  -- | Info\/Query, or IQ, is a /request-response/ mechanism, similar in some+  -- ways to the Hypertext Transfer Protocol @HTTP@. The semantics of IQ enable+  -- an entity to make a request of, and receive a response from, another+  -- entity. The data content and precise semantics  of the request and response+  -- is defined by the schema or other structural definition associated with the+  -- XML namespace that qualifies the direct child element of the IQ element. IQ+  -- interactions follow a common pattern of structured data exchange such as+  -- get\/result or set\/result (although an error can be returned in reply to a+  -- request if appropriate)+  --+  -- <http://xmpp.org/rfcs/rfc6120.html#stanzas-semantics-iq>+  , IQRequest(..)+  , IQRequestTicket+  , iqRequestBody+  , IQRequestType(..)+  , IQResult(..)+  , IQError(..)+  , IQResponse(..)+  , IQRequestClass(..)+  , IQRequestHandler+  , sendIQ+  , sendIQ'+  , sendIQRequest+  , answerIQ+  , iqResult+  , listenIQ+  , runIQHandler+  , unlistenIQ+  -- * Errors+  , StanzaErrorType(..)+  , StanzaError(..)+  , associatedErrorType+  , mkStanzaError+  , StanzaErrorCondition(..)+  , SaslFailure(..)+  , IQSendError(..)+  , IQRequestError(..)+  -- * Threads+  , dupSession+  -- * Lenses+  -- | Network.Xmpp doesn't re-export the accessors to avoid name+  -- clashes. To use them import Network.Xmpp.Lens+  , module Network.Xmpp.Lens+  -- * Plugins+  -- Plugins modify incoming and outgoing stanzas. They can, for example, handle+  -- encryption, compression or other protocol extensions.+  , Annotated+  , Annotation(..)+  , Plugin+  , Plugin'(..)+  -- * LangTag+  , LangTag+  , langTagFromText+  , langTagToText+  , parseLangTag+  -- * Miscellaneous+  , XmppFailure(..)+  , StreamErrorInfo(..)+  , StreamErrorCondition(..)+  , AuthFailure( AuthNoAcceptableMechanism+               , AuthSaslFailure+               , AuthIllegalCredentials+               , AuthOtherFailure )+  , connectTls+  , def+  ) where++import Network.Xmpp.Concurrent+import Network.Xmpp.Sasl+import Network.Xmpp.Sasl.Types+import Network.Xmpp.Stanza+import Network.Xmpp.Types+import Network.Xmpp.Tls+import Network.Xmpp.Lens hiding (view, set, modify)+import Data.Default (def)
+ source/Network/Xmpp/Concurrent.hs view
@@ -0,0 +1,386 @@+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.Xmpp.Concurrent+  ( module Network.Xmpp.Concurrent.Monad+  , module Network.Xmpp.Concurrent.Threads+  , module Network.Xmpp.Concurrent.Basic+  , module Network.Xmpp.Concurrent.Types+  , module Network.Xmpp.Concurrent.Message+  , module Network.Xmpp.Concurrent.Presence+  , module Network.Xmpp.Concurrent.IQ+  , newSession+  , session+  , newStanzaID+  , reconnect+  , reconnect'+  , reconnectNow+  , simpleAuth+  ) where++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           Control.Monad.Except+import qualified Data.List as List+import qualified Data.Map as Map+import           Data.Maybe+import           Data.Text as Text hiding (show)+import           Data.XML.Types+import           Network.Socket+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.Types+import           Network.Xmpp.IM.Roster+import           Network.Xmpp.IM.Roster.Types+import           Network.Xmpp.IM.PresenceTracker+import           Network.Xmpp.IM.PresenceTracker.Types+import           Network.Xmpp.Sasl+import           Network.Xmpp.Sasl.Types+import           Network.Xmpp.Stream+import           Network.Xmpp.Tls+import           Network.Xmpp.Types+import           System.Log.Logger+import           System.Random (randomRIO)++import           Control.Monad.State.Strict+++runHandlers :: [   XmppElement+                -> [Annotation]+                -> IO [Annotated XmppElement]+               ]+               -> XmppElement+               -> IO ()+runHandlers [] sta = do+    errorM "Pontarius.Xmpp" $+           "No stanza handlers set, discarding stanza" ++ show sta+    return ()+runHandlers hs sta = go hs sta []+  where go []        _  _   = return ()+        go (h:hands) sta' as = do+            res <- h sta' as+            forM_ res $ \(sta'', as') -> go hands sta'' (as ++ as')++toChan :: TChan (Annotated Stanza) -> StanzaHandler+toChan stanzaC _ sta as = do+    case sta of+     XmppStanza s -> atomically $ writeTChan stanzaC (s, as)+     _ -> return ()+    return [(sta, [])]++handleIQ :: TVar IQHandlers+         -> StanzaHandler+handleIQ _ _  s@XmppNonza{} _ = return [(s, [])]+handleIQ iqHands out s@(XmppStanza sta) as = do+        case sta of+            IQRequestS     i -> handleIQRequest iqHands i >> return []+            IQResultS      i -> handleIQResponse iqHands (Right i) >> return []+            IQErrorS       i -> handleIQResponse iqHands (Left i)  >> return []+            _                -> return [(s, [])]+  where+    -- If the IQ request has a namespace, send it through the appropriate channel.+    handleIQRequest :: TVar IQHandlers -> IQRequest -> IO ()+    handleIQRequest handlers iq = do+        res <- 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 attrs = do+                          let IQRequest iqid from _to lang _tp bd _attrs = iq+                              response = case answer of+                                  Left er  -> IQErrorS $ IQError iqid Nothing+                                                                  from lang er+                                                                  (Just bd) attrs+                                  Right res -> IQResultS $ IQResult iqid Nothing+                                                                    from lang res+                                                                    attrs+                          Ex.bracketOnError (atomically $ takeTMVar sentRef)+                                            (atomically .  tryPutTMVar sentRef)+                                            $ \wasSent -> do+                              case wasSent of+                                  True -> do+                                      atomically $ putTMVar sentRef True+                                      return Nothing+                                  False -> do+                                      didSend <- out $ XmppStanza response+                                      case didSend of+                                          Right () -> do+                                              atomically $ putTMVar sentRef True+                                              return $ Just (Right ())+                                          er@Left{} -> do+                                              atomically $ putTMVar sentRef False+                                              return $ Just er+                  writeTChan ch $ IQRequestTicket answerT iq as+                  return Nothing+        maybe (return ()) (void . out . XmppStanza) res+    serviceUnavailable (IQRequest iqid from _to lang _tp bd _attrs) =+        IQErrorS $ IQError iqid Nothing from lang err (Just bd) []+    err = StanzaError Cancel ServiceUnavailable Nothing Nothing++    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 () -- The handler might be removed due to+                                      -- timeout+            (Just (expectedJid, tmvar), byID') -> do+                let expected = case expectedJid of+                    -- IQ was sent to the server and we didn't have a bound JID+                    -- We just accept any matching response+                        Left Nothing -> True+                    -- IQ was sent to the server and we had a bound JID. Valid+                    -- responses might have no to attribute, the domain of the+                    -- server, our bare JID or our full JID+                        Left (Just j) -> case iqFrom iq of+                            Nothing -> True+                            Just jf -> jf <~ j+                    -- IQ was sent to a (full) JID. The answer has to come from+                    -- the same exact JID.+                        Right j -> iqFrom iq == Just j+                case expected of+                    True -> do+                        let answer = Just (either IQResponseError+                                                  IQResponseResult iq, as)+                        _ <- tryPutTMVar tmvar answer -- Don't block.+                        writeTVar handlers (byNS, byID')+                    False -> return ()+      where+        iqID (Left err') = iqErrorID err'+        iqID (Right iq') = iqResultID iq'+        iqFrom (Left err') = iqErrorFrom err'+        iqFrom (Right iq') = iqResultFrom iq'++-- | Creates and initializes a new Xmpp context.+newSession :: Stream+           -> SessionConfiguration+           -> HostName+           -> Maybe (ConnectionState -> [SaslHandler] , Maybe Text)+           -> IO (Either XmppFailure Session)+newSession stream config realm mbSasl = runExceptT $ do+    write' <- liftIO $ withStream' (gets $ streamSend . streamHandle) stream+    writeSem <- liftIO $ newTMVarIO write'+    stanzaChan <- lift newTChanIO+    iqHands  <- lift $ newTVarIO (Map.empty, Map.empty)+    eh <- lift $ newEmptyTMVarIO+    ros <- case enableRoster config of+                False -> return $ Roster Nothing Map.empty+                True -> do+                    mbRos <- liftIO $ initialRoster config+                    return $ case mbRos of+                              Nothing -> Roster Nothing Map.empty+                              Just r -> r+    rosRef <- liftIO $ newTVarIO ros+    peers <- liftIO . newTVarIO $ Peers Map.empty+    rew <- lift $ newTVarIO 60+    let out = writeXmppElem writeSem+    boundJid <- liftIO $ withStream' (gets streamJid) stream+    let rosterH = if (enableRoster config)+                  then [handleRoster boundJid rosRef+                          (fromMaybe (\_ _ -> return ()) $ onRosterPush config)+                          (out)]+                  else []+    let presenceH = if (enablePresenceTracking config)+                    then [handlePresence (onPresenceChange config) peers out]+                    else []+    (sXmppElement, ps) <- initPlugins out $ plugins config+    let stanzaHandler = runHandlers $ List.concat+                        [ inHandler <$> ps+                        , [ toChan stanzaChan sXmppElement]+                        , presenceH+                        , rosterH+                        , [ handleIQ iqHands sXmppElement]+                        ]+    (kill, sState, reader) <- ExceptT $ startThreadsWith writeSem stanzaHandler+                                                        eh stream+                                                        (keepAlive config)+    idGen <- liftIO $ sessionStanzaIDs config+    let sess = Session { stanzaCh = stanzaChan+                       , iqHandlers = iqHands+                       , writeSemaphore = writeSem+                       , readerThread = reader+                       , idGenerator = idGen+                       , streamRef = sState+                       , eventHandlers = eh+                       , stopThreads = kill+                       , conf = config+                       , rosterRef = rosRef+                       , presenceRef = peers+                       , sendStanza' = sXmppElement . XmppStanza+                       , sRealm = realm+                       , sSaslCredentials = mbSasl+                       , reconnectWait = rew+                       }+    liftIO . atomically $ putTMVar eh $+        EventHandlers { connectionClosedHandler = onConnectionClosed config sess }+    -- Pass the new session to the plugins so they can "tie the knot"+    liftIO . forM_ ps $ \p -> onSessionUp p sess+    return sess+  where+    -- Pass the stanza out action to each plugin+    initPlugins out' = go out' []+      where+        go out ps' [] = return (out, ps')+        go out ps' (p:ps) = do+            p' <- p out+            go (outHandler p') (p' : ps') ps++connectStream :: HostName+              -> SessionConfiguration+              -> AuthData+              -> 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 <- runExceptT $ do+                      ExceptT $ tls stream+                      cs <- liftIO $ withStream (gets streamConnectionState)+                                                stream+                      mbAuthError <- case mbSasl of+                          Nothing -> return Nothing+                          Just (handlers, resource) -> ExceptT $ 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+        -> AuthData+        -> SessionConfiguration              -- ^ configuration details+        -> IO (Either XmppFailure Session)+session realm mbSasl config = runExceptT $ do+    stream <- ExceptT $ connectStream realm config mbSasl+    ses <- ExceptT $ newSession stream config realm mbSasl+    liftIO $ when (enableRoster config) $ initRoster ses+    return ses++-- | Authenticate using, in order of preference, 'scramSha1', 'digestMd5' and+-- finally, if both of those are not support and the stream is 'Secured' with+-- TLS, try 'plain'+--+-- The resource will be decided by the server+simpleAuth :: Username -> Password -> AuthData+simpleAuth uname pwd = Just (\cstate ->+                              [ scramSha1 uname Nothing pwd+                              , digestMd5 uname Nothing pwd+                              ] +++                              if (cstate == Secured)+                              then [plain uname Nothing pwd]+                              else []+                            , Nothing)++-- | 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
+ source/Network/Xmpp/Concurrent/Basic.hs view
@@ -0,0 +1,87 @@+{-# OPTIONS_HADDOCK hide #-}+module Network.Xmpp.Concurrent.Basic where++import           Control.Applicative+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 (Either XmppFailure ())+semWrite sem bs = Ex.bracket (atomically $ takeTMVar sem)+                          (atomically . putTMVar sem)+                          ($ bs)++writeXmppElem :: WriteSemaphore -> XmppElement -> IO (Either XmppFailure ())+writeXmppElem sem a = do+    let el = case a of+                 XmppStanza s -> pickleElem xpStanza s+                 XmppNonza n -> n+        outData = renderElement $ nsHack el+    debugOut outData+    semWrite sem outData++writeStanza :: WriteSemaphore -> Stanza -> IO (Either XmppFailure ())+writeStanza sem a = do+    let outData = renderElement $ nsHack (pickleElem xpStanza a)+    debugOut outData+    semWrite sem outData+++-- | Send a stanza to the server without running plugins. (The stanza is sent as+-- is)+sendRawStanza :: Stanza -> Session -> IO (Either XmppFailure ())+sendRawStanza a session = writeStanza (writeSemaphore session) a++-- | Send a stanza to the server, managed by plugins+sendStanza :: Stanza -> Session -> IO (Either XmppFailure ())+sendStanza = flip sendStanza'++-- | Get the channel of incoming stanzas.+getStanzaChan :: Session -> TChan (Stanza, [Annotation])+getStanzaChan session = stanzaCh session++-- | Get the next incoming stanza+getStanza :: Session -> IO (Stanza, [Annotation])+getStanza session = atomically . readTChan $ stanzaCh session++-- | Duplicate the inbound channel of the session object. Most receiving+-- functions discard stanzas they are not interested in from the inbound+-- channel. Duplicating the channel ensures that those stanzas can aren't lost+-- and can still be handled somewhere else.+dupSession :: Session -> IO Session+dupSession session = do+    stanzaCh' <- atomically $ cloneTChan (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 stream features the server announced+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++streamState :: Session -> STM ConnectionState+streamState Session{streamRef = sr}  = do+    s <- readTMVar sr+    streamConnectionState <$> (readTMVar $ unStream s)
+ source/Network/Xmpp/Concurrent/IQ.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_HADDOCK hide #-}+module Network.Xmpp.Concurrent.IQ where++import           Control.Applicative ((<$>))+import           Control.Concurrent (forkIO)+import           Control.Concurrent.STM+import           Control.Concurrent.Thread.Delay (delay)+import           Control.Monad+import           Control.Monad.Except+import           Control.Monad.Trans+import qualified Data.Map as Map+import qualified Data.Map.Strict as Map.Strict+import           Data.Maybe+import           Data.Text (Text)+import           Data.XML.Pickle+import           Data.XML.Types+import           Lens.Family2 (toListOf, (&), (^.))+import           Network.Xmpp.Concurrent.Basic+import           Network.Xmpp.Concurrent.Types+import           Network.Xmpp.Lens+import           Network.Xmpp.Stanza+import           Network.Xmpp.Types+import           System.Log.Logger++-- | Sends an IQ, returns an STM action that returns the first inbound IQ with a+-- matching ID that has type @result@ or @error@ or Nothing if the timeout was+-- reached.+--+-- When sending the action fails, an XmppFailure is returned.+sendIQ :: Maybe Integer -- ^ 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)+       -> [ExtendedAttribute] -- ^ Additional stanza attributes+       -> Session+       -> IO (Either XmppFailure (STM (Maybe (Annotated IQResponse))))+sendIQ timeOut t tp lang body attrs session = do+    newId <- idGenerator session+    j <- case t of+        Just t -> return $ Right t+        Nothing -> Left <$> getJid session+    ref <- atomically $ do+        resRef <- newEmptyTMVar+        let value = (j, resRef)+        (byNS, byId) <- readTVar (iqHandlers session)+        writeTVar (iqHandlers session) (byNS, Map.insert newId value byId)+        return resRef+    res <- sendStanza (IQRequestS $ IQRequest newId Nothing t lang tp body attrs)+                      session+    case res of+        Right () -> do+            case timeOut of+                Nothing -> return ()+                Just t -> void . forkIO $ do+                          delay t+                          doTimeOut (iqHandlers session) newId ref+            return . Right $ readTMVar ref+        Left e -> return $ Left e+  where+    doTimeOut handlers iqid var = atomically $ do+      p <- tryPutTMVar var Nothing+      when p $ do+          (byNS, byId) <- readTVar (iqHandlers session)+          writeTVar handlers (byNS, Map.delete iqid byId)+      return ()++-- | Like 'sendIQ', but waits for the answer IQ.+sendIQA' :: Maybe Integer+         -> Maybe Jid+         -> IQRequestType+         -> Maybe LangTag+         -> Element+         -> [ExtendedAttribute]+         -> Session+         -> IO (Either IQSendError (Annotated IQResponse))+sendIQA' timeout to tp lang body attrs session = do+    ref <- sendIQ timeout to tp lang body attrs session+    either (return . Left . IQSendError) (fmap (maybe (Left IQTimeOut) Right)+                                     . atomically) ref++-- | Like 'sendIQ', but waits for the answer IQ. Discards plugin Annotations+sendIQ' :: Maybe Integer+        -> Maybe Jid+        -> IQRequestType+        -> Maybe LangTag+        -> Element+        -> [ExtendedAttribute]+        -> Session+        -> IO (Either IQSendError IQResponse)+sendIQ' timeout to tp lang body attrs session =+    fmap fst <$> sendIQA' timeout to tp lang body attrs session++-- | Register your interest in inbound IQ stanzas of a specific type and+-- namespace. The returned STM action yields the received, matching IQ stanzas.+--+-- If a handler for IQ stanzas with the given type and namespace is already+-- registered, the producer will be wrapped in Left. In this case the returned+-- request tickets may already be processed elsewhere.+listenIQ :: IQRequestType  -- ^ Type of IQs to receive ('Get' or 'Set')+         -> Text -- ^ Namespace of the child element+         -> Session+         -> IO (Either (STM IQRequestTicket) (STM IQRequestTicket))+listenIQ tp ns session = do+    let handlers = (iqHandlers session)+    atomically $ do+        (byNS, byID) <- readTVar handlers+        iqCh <- newTChan+        let (present, byNS') = Map.Strict.insertLookupWithKey+                (\_ _ old -> old)+                (tp, ns)+                iqCh+                byNS+        writeTVar handlers (byNS', byID)+        case present of+            Nothing -> return . Right $ readTChan iqCh+            Just iqCh' -> do+                clonedChan <- cloneTChan iqCh'+                return . Left $ readTChan clonedChan+++-- | Unregister a previously registered IQ handler. No more IQ stanzas will be+-- delivered to any of the returned producers.+unlistenIQ :: IQRequestType  -- ^ Type of IQ ('Get' or 'Set')+           -> Text -- ^ Namespace of the child element+           -> Session+           -> IO ()+unlistenIQ 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)+         -> [ExtendedAttribute]+         -> IO (Maybe (Either XmppFailure ()))+answerIQ = answerTicket+++-- Class++class IQRequestClass a where+    data IQResponseType a+    pickleRequest :: PU Element a+    pickleResponse :: PU [Element] (IQResponseType a)+    requestType :: a -> IQRequestType+    requestNamespace :: a -> Text++data IQRequestError = IQRequestSendError XmppFailure+                    | IQRequestTimeout+                    | IQRequestUnpickleError UnpickleError+                      deriving Show++-- | Send an IQ request. May throw IQSendError, UnpickleError,++sendIQRequest  :: (IQRequestClass a, MonadError IQRequestError m, MonadIO m) =>+                  Maybe Integer+               -> Maybe Jid+               -> a+               -> Session+               -> m (Either IQError (IQResponseType a))+sendIQRequest timeout t req con = do+    mbRes <- liftIO $ sendIQ' timeout t (requestType req) Nothing+                              (pickle pickleRequest req) [] con+    case mbRes of+        Left (IQTimeOut) -> throwError IQRequestTimeout+        Left (IQSendError e) -> throwError $ IQRequestSendError e+        Right (IQResponseError e) -> return $ Left e+        Right (IQResponseResult res) ->+              case unpickle pickleResponse (res & toListOf payloadT) of+                   Left e -> throwError $ IQRequestUnpickleError e+                   Right r -> return $ Right r++type IQRequestHandler a = a -> IO (Either StanzaError (IQResponseType a))++runIQHandler :: IQRequestClass a =>+                IQRequestHandler a+             -> Session+             -> IO ()+runIQHandler (handler :: a -> IO (Either StanzaError (IQResponseType a)))+             sess = do+    let prx = undefined :: a+        ns = (requestNamespace prx)+    mbChan <- listenIQ (requestType prx) ns sess+    case mbChan of+        Left _ -> warningM "Pontarius.Xmpp" $ "IQ namespace " ++ show ns+                            ++ " is already handled"+        Right getNext -> forever $ do+            ticket <- atomically getNext+            case unpickle pickleRequest (iqRequestBody ticket ^. payload) of+                Left _ -> answerIQ ticket (Left $ mkStanzaError BadRequest) []+                Right req -> do+                    res <- handler req+                    case res of+                        Left e -> answerIQ ticket (Left e) []+                        Right r -> do+                            let answer = (pickle pickleResponse r)+                            answerIQ ticket (Right $ listToMaybe answer ) []
+ source/Network/Xmpp/Concurrent/Message.hs view
@@ -0,0 +1,96 @@+{-# OPTIONS_HADDOCK hide #-}+module Network.Xmpp.Concurrent.Message where++import Control.Applicative((<$>))+import Network.Xmpp.Concurrent.Types+import Control.Concurrent.STM+import Network.Xmpp.Types+import Network.Xmpp.Concurrent.Basic++-- | Draw and discard stanzas from the inbound channel until a message or+-- message error is found. Returns the message or message error with annotations.+pullMessageA :: Session -> IO (Either (Annotated MessageError) (Annotated Message))+pullMessageA session = do+    (stanza, as) <- atomically . readTChan $ stanzaCh session+    case stanza of+        MessageS m      -> return $ Right (m, as)+        MessageErrorS e -> return $ Left  (e, as)+        _ -> pullMessageA session++-- | Draw and discard stanzas from the inbound channel until a message or+-- message error is found. Returns the message or message error.+pullMessage :: Session -> IO (Either MessageError Message)+pullMessage s = either (Left . fst) (Right . fst) <$> pullMessageA s++-- | Draw and discard stanzas from the inbound channel until a message is+-- found. Returns the message with annotations.+getMessageA :: Session -> IO (Annotated Message)+getMessageA = waitForMessageA (const True)++-- | Draw and discard stanzas from the inbound channel until a message is+-- found. Returns the message.+getMessage :: Session -> IO Message+getMessage s = fst <$> getMessageA s++-- | Draw and discard stanzas from the inbound channel until a message matching+-- the given predicate is found. Returns the matching message with annotations.+waitForMessageA :: (Annotated Message -> Bool) -> Session -> IO (Annotated Message)+waitForMessageA f session = do+    s <- pullMessageA session+    case s of+        Left _ -> waitForMessageA f session+        Right m | f m -> return m+                | otherwise -> waitForMessageA f session++-- | Draw and discard stanzas from the inbound channel until a message matching+-- the given predicate is found. Returns the matching message.+waitForMessage :: (Message -> Bool) -> Session -> IO Message+waitForMessage f s  = fst <$> waitForMessageA (f . fst) s++-- | Draw and discard stanzas from the inbound channel until a message error+-- matching the given predicate is found. Returns the matching message error with+-- annotations.+waitForMessageErrorA :: (Annotated MessageError -> Bool)+                    -> Session+                    -> IO (Annotated MessageError)+waitForMessageErrorA f session = do+    s <- pullMessageA session+    case s of+        Right _ -> waitForMessageErrorA f session+        Left  m | f m -> return m+                | otherwise -> waitForMessageErrorA f session++-- | Draw and discard stanzas from the inbound channel until a message error+-- matching the given predicate is found. Returns the matching message error+waitForMessageError :: (MessageError -> Bool) -> Session -> IO MessageError+waitForMessageError f s  = fst <$> waitForMessageErrorA (f . fst) s++-- | Draw and discard stanzas from the inbound channel until a message or+-- message error matching the given respective predicate is found. Returns the+-- matching message or message error with annotations+filterMessagesA :: (Annotated MessageError -> Bool)+               -> (Annotated Message -> Bool)+               -> Session -> IO (Either (Annotated MessageError)+                                        (Annotated Message))+filterMessagesA f g session = do+    s <- pullMessageA session+    case s of+        Left  e | f e -> return $ Left e+                | otherwise -> filterMessagesA f g session+        Right m | g m -> return $ Right m+                | otherwise -> filterMessagesA f g session++-- | Draw and discard stanzas from the inbound channel until a message or+-- message error matching the given respective predicate is found. Returns the+-- matching message or message error.+filterMessages :: (MessageError -> Bool)+               -> (Message -> Bool)+               -> Session+               -> IO (Either MessageError Message)+filterMessages f g s = either (Left . fst) (Right . fst) <$>+                          filterMessagesA (f . fst) (g . fst) s++-- | Send a message stanza. Returns @Left@ when the 'Message' could not be+-- sent.+sendMessage :: Message -> Session -> IO (Either XmppFailure ())+sendMessage m session = sendStanza (MessageS m) session
+ source/Network/Xmpp/Concurrent/Monad.hs view
@@ -0,0 +1,118 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.Xmpp.Concurrent.Monad where++import           Control.Applicative ((<$>))+import           Control.Concurrent+import           Control.Concurrent.STM+import qualified Control.Exception.Lifted as Ex+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.+-- withConnection :: XmppConMonad a -> Context -> IO (Either StreamError a)+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+        -- fetch 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 $ 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.+    modifyTMVar_ :: TMVar a -> (a -> a) -> STM ()+    modifyTMVar_ var g = do+      x <- takeTMVar var+      putTMVar var (g x)++-- | 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 (readTMVar $ eventHandlers session)+++-- | End the current XMPP session. Kills the associated threads and closes the+-- connection.+--+-- Note that XMPP clients (that have 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.+closeConnection :: Session -> IO ()+closeConnection session = do+    _ <-flip withConnection session $ \stream -> do+        _ <- closeStreams stream+        return ((), stream)+    runConnectionClosedHandler session StreamEndFailure
+ source/Network/Xmpp/Concurrent/Presence.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS_HADDOCK hide #-}+module Network.Xmpp.Concurrent.Presence where++import Control.Applicative ((<$>))+import Control.Concurrent.STM+import Control.Lens.Prism (_Just)+import Lens.Family2 hiding (to)+import Lens.Family2.Stock hiding (_Just)+import Network.Xmpp.Concurrent.Basic+import Network.Xmpp.Concurrent.Types+import Network.Xmpp.Lens+import Network.Xmpp.Types++-- | Read a presence stanza from the inbound stanza channel, discards any other+-- stanzas. Returns the presence stanza with annotations.+pullPresenceA :: Session -> IO (Either (Annotated PresenceError)+                                      (Annotated Presence))+pullPresenceA session = do+    (stanza, as) <- atomically . readTChan $ stanzaCh session+    case stanza of+        PresenceS p -> return $ Right (p, as)+        PresenceErrorS e -> return $ Left (e, as)+        _ -> pullPresenceA session++-- | Read a presence stanza from the inbound stanza channel, discards any other+-- stanzas. Returns the presence stanza.+pullPresence :: Session -> IO (Either PresenceError Presence)+pullPresence s = either (Left . fst) (Right . fst) <$> pullPresenceA s++-- | Draw and discard stanzas from the inbound channel until a presence stanza matching the given predicate is found. Return the presence stanza with annotations.+waitForPresenceA :: (Annotated Presence -> Bool)+                -> Session+                -> IO (Annotated Presence)+waitForPresenceA f session = do+    s <- pullPresenceA session+    case s of+        Left _ -> waitForPresenceA f session+        Right m | f m -> return m+                | otherwise -> waitForPresenceA f session++-- | Draw and discard stanzas from the inbound channel until a presence stanza matching the given predicate is found. Return the presence stanza with annotations.+waitForPresence :: (Presence -> Bool) -> Session -> IO Presence+waitForPresence f s = fst <$> waitForPresenceA (f . fst) s++-- | Send a presence stanza.+sendPresence :: Presence -> Session -> IO (Either XmppFailure ())+sendPresence p session = sendStanza (PresenceS checkedP) session+  where+    -- | RFC 6121 §3.1.1: When a user sends a presence subscription request to a+    -- potential instant messaging and presence contact, the value of the 'to'+    -- attribute MUST be a bare JID rather than a full JID+    checkedP = case presenceType p of+        Subscribe -> p & to . _Just %~ toBare+        _ -> p
+ source/Network/Xmpp/Concurrent/Threads.hs view
@@ -0,0 +1,131 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.Xmpp.Concurrent.Threads where++import           Control.Applicative((<$>))+import           Control.Concurrent+import           Control.Concurrent.STM+import qualified Control.Exception.Lifted as Ex+import           Control.Monad+import           Control.Monad.Except+import           Control.Monad.IO.Class+import qualified Data.ByteString as BS+import           GHC.IO (unsafeUnmask)+import           Network.Xmpp.Concurrent.Types+import           Network.Xmpp.Stream+import           Network.Xmpp.Types+import           System.Log.Logger++-- Worker to read stanzas from the stream and concurrently distribute them to+-- all listener threads.+readWorker :: (XmppElement -> IO ())+           -> (XmppFailure -> IO ())+           -> TMVar Stream+           -> IO a+readWorker onElement onCClosed stateRef = forever . Ex.mask_ $ do+    s' <- Ex.catches ( do+                        atomically $ do+                            s@(Stream con) <- readTMVar stateRef+                            scs <- streamConnectionState <$> readTMVar con+                            when (stateIsClosed scs)+                                 retry+                            return $ Just s+                   )+               [ Ex.Handler $ \(Interrupt t) -> do+                     void $ handleInterrupts [t]+                     return Nothing++               ]+    case s' of -- Maybe Stream+        Nothing -> return ()+        Just s -> do -- Stream+            res <- Ex.catches (do+                   -- we don't know whether pull will+                   -- necessarily be interruptible+                             allowInterrupt+                             res <- pullXmppElement s+                             case res of+                                 Left e -> do+                                     errorM "Pontarius.Xmpp" $ "Read error: "+                                         ++ show e+                                     _ <- closeStreams s+                                     onCClosed e+                                     return Nothing+                                 Right r -> return $ Just r+                              )+                       [ Ex.Handler $ \(Interrupt t) -> do+                              void $ handleInterrupts [t]+                              return Nothing+                       ]+            case res of+                Nothing -> return () -- Caught an exception, nothing to+                                     -- do. TODO: Can this happen?+                Just sta -> void $ onElement sta+  where+    -- Defining an Control.Exception.allowInterrupt equivalent for GHC 7+    -- compatibility.+    allowInterrupt :: IO ()+    allowInterrupt = unsafeUnmask $ return ()+    -- While waiting for the first semaphore(s) to flip we might receive another+    -- interrupt. When that happens we add it's semaphore to the list and retry+    -- waiting.+    handleInterrupts :: [TMVar ()] -> IO [()]+    handleInterrupts ts =+        Ex.catch (atomically $ forM ts takeTMVar)+            (\(Interrupt t) -> handleInterrupts (t:ts))+    stateIsClosed Closed   = True+    stateIsClosed Finished = True+    stateIsClosed _        = False++-- | 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 :: TMVar (BS.ByteString -> IO (Either XmppFailure ()))+                 -> (XmppElement -> IO ())+                 -> TMVar EventHandlers+                 -> Stream+                 -> Maybe Int+                 -> IO (Either XmppFailure (IO (),+                                            TMVar Stream,+                                            ThreadId))+startThreadsWith writeSem stanzaHandler eh con keepAlive = do+    -- read' <- withStream' (gets $ streamSend . streamHandle) con+    -- writeSem <- newTMVarIO read'+    conS <- newTMVarIO con+    cp <- forkIO $ connPersist keepAlive writeSem+    let onConClosed failure = do+            stopWrites+            noCon eh failure+    rdw <- forkIO $ readWorker stanzaHandler onConClosed conS+    return $ Right ( killConnection [rdw, cp]+                   , conS+                   , rdw+                   )+  where+    stopWrites = atomically $ do+        _ <- takeTMVar writeSem+        putTMVar writeSem $ \_ -> return $ Left XmppNoStream+    killConnection threads = liftIO $ do+        debugM "Pontarius.Xmpp" "killing connection"+        stopWrites+        debugM "Pontarius.Xmpp" "killing threads"+        _ <- forM threads killThread+        return ()+    -- Call the connection closed handlers.+    noCon :: TMVar EventHandlers -> XmppFailure -> IO ()+    noCon h e = do+        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 <delay> seconds to keep the connection alive.+connPersist :: Maybe Int -> TMVar (BS.ByteString -> IO a) -> IO ()+connPersist (Just delay) sem = forever $ do+    pushBS <- atomically $ takeTMVar sem+    _ <- pushBS " "+    atomically $ putTMVar sem pushBS+    threadDelay (delay*1000000)+connPersist Nothing _ = return ()
+ source/Network/Xmpp/Concurrent/Types.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Network.Xmpp.Concurrent.Types where++import           Control.Concurrent+import           Control.Concurrent.STM+import qualified Control.Exception.Lifted as Ex+import           Control.Monad.Except+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.Socket+import           Network.Xmpp.IM.Roster.Types+import           Network.Xmpp.IM.PresenceTracker.Types+import           Network.Xmpp.Sasl.Types+import           Network.Xmpp.Types++type StanzaHandler = (XmppElement -> IO (Either XmppFailure ()) ) -- ^ outgoing+                                                                  -- stanza+                   -> XmppElement  -- ^ stanza to handle+                   -> [Annotation] -- ^ annotations added by previous handlers+                   -> IO [(XmppElement, [Annotation])]  -- ^ modified stanzas and+                                                        -- /additional/ annotations++type Resource = Text++-- | SASL handlers and the desired JID resource+--+-- Nothing to disable authentication+--+-- The allowed SASL mecahnism can depend on the connection state. For example,+-- 'plain' should be avoided unless the connection state is 'Secured'+--+-- It is recommended to leave the resource up to the server+type AuthData = Maybe (ConnectionState -> [SaslHandler] , Maybe Resource)++-- | Annotations are auxiliary data attached to received stanzas by 'Plugin's to+-- convey information regarding their operation. For example, a plugin for+-- encryption might attach information about whether a received stanza was+-- encrypted and which algorithm was used.+data Annotation = forall f.(Typeable f, Show f) => Annotation{fromAnnotation :: f}++instance Show Annotation where+    show (Annotation x) = "Annotation{ fromAnnotation = " ++ show x ++ "}"++type Annotated a = (a, [Annotation])++-- | Retrieve the first matching annotation+getAnnotation :: Typeable b => Annotated a -> Maybe b+getAnnotation = foldr (\(Annotation a) b -> maybe b Just $ cast a) Nothing . snd++data Plugin' = Plugin'+    { -- | Resulting stanzas and additional Annotations+      inHandler :: XmppElement+                -> [Annotation]+                -> IO [(XmppElement, [Annotation])]+    , outHandler :: XmppElement -> IO (Either XmppFailure ())+    -- | In order to allow plugins to tie the knot (Plugin / Session) we pass+    -- the plugin the completed Session once it exists+    , onSessionUp :: Session -> IO ()+    }++type Plugin = (XmppElement -> IO (Either XmppFailure ())) -- ^ pass stanza to+                                                          -- next plugin+              -> ExceptT XmppFailure IO Plugin'++type RosterPushCallback = Roster -> RosterUpdate -> IO ()++-- | Configuration for the @Session@ object.+data SessionConfiguration = SessionConfiguration+    { -- | Configuration for the @Stream@ object.+      sessionStreamConfiguration :: StreamConfiguration+      -- | Handler to be run when the conection to the XMPP server is+      -- closed. See also 'reconnect' and 'reconnect\'' for easy+      -- reconnection. The default does nothing+    , onConnectionClosed         :: Session -> XmppFailure -> IO ()+      -- | Function to generate new stanza identifiers.+    , sessionStanzaIDs           :: IO (IO Text)+      -- | Plugins can modify incoming and outgoing stanzas, for example to en-+      -- and decrypt them, respectively+    , plugins                    :: [Plugin]+      -- | Enable roster handling according to rfc 6121. See 'getRoster' to+      -- acquire the current roster+    , enableRoster               :: Bool+      -- | Initial Roster to user when versioned rosters are supported+    , initialRoster              :: IO (Maybe Roster)+      -- | Callback called on a roster Push. The callback is called after the+      -- roster is updated+    , onRosterPush               :: Maybe RosterPushCallback+      -- | Track incomming presence stancas.+    , enablePresenceTracking     :: Bool+      -- | Callback that is invoked when the presence status of a peer changes,+      -- i.e. it comes online, goes offline or its IM presence changes. The+      -- arguments are the (full) JID of the peer, the old state and the new+      -- state. The function is called in a new thread to avoid blocking+      -- handling stanzas+    , onPresenceChange           :: Maybe ( Jid+                                          -> PeerStatus+                                          -> PeerStatus+                                          -> IO ())+      -- | How often to send keep-alives+      --   'Nothing' disables keep-alive+    , keepAlive                  :: Maybe Int+    }++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+                               , plugins = []+                               , enableRoster = True+                               , initialRoster = return Nothing+                               , onRosterPush = Nothing+                               , enablePresenceTracking = True+                               , onPresenceChange = Nothing+                               , keepAlive = Just 30+                               }++-- | Handlers to be run when the Xmpp session ends and when the Xmpp connection is+-- closed.+data EventHandlers = EventHandlers+    { connectionClosedHandler :: XmppFailure -> IO ()+    }++-- | Interrupt is used to signal to the reader thread that it should stop. Th contained semphore signals the reader to resume it's work.+data Interrupt = Interrupt (TMVar ()) deriving Typeable+instance Show Interrupt where show _ = "<Interrupt>"++instance Ex.Exception Interrupt++type WriteSemaphore = TMVar (BS.ByteString -> IO (Either XmppFailure ()))++-- | The Session object represents a single session with an XMPP server. You can+-- use 'session' to establish a session+data Session = Session+    { stanzaCh :: TChan (Stanza, [Annotation]) -- All stanzas+    , iqHandlers :: TVar IQHandlers+      -- Writing lock, so that only one thread could write to the stream at any+      -- given time.+      -- Fields below are from Context.+    , writeSemaphore :: WriteSemaphore+    , readerThread :: ThreadId+    , 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 :: TMVar EventHandlers+    , stopThreads :: IO ()+    , rosterRef :: TVar Roster+    , presenceRef :: TVar Peers+    , conf :: SessionConfiguration+    , sendStanza' :: Stanza -> IO (Either XmppFailure ())+    , sRealm :: HostName+    , sSaslCredentials :: Maybe (ConnectionState -> [SaslHandler] , Maybe Text)+    , reconnectWait :: TVar Int+    }++-- | 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 Text (Either (Maybe Jid) Jid,+                                  TMVar (Maybe (Annotated IQResponse)))+                  )++-- | A received and wrapped up IQ request. Prevents you from (illegally)+-- answering a single IQ request multiple times+data IQRequestTicket = IQRequestTicket+    {   -- | Send an answer to an IQ request once. Subsequent calls will do+        -- nothing and return Nothing+      answerTicket :: Either StanzaError (Maybe Element)+                      -> [ExtendedAttribute]+                      -> IO (Maybe (Either XmppFailure ()))+      -- | The actual IQ request that created this ticket.+    , iqRequestBody :: IQRequest+      -- | Annotations set by plugins in receive+    , iqRequestAnnotations :: [Annotation]+    }++-- | Error that can occur during sendIQ'+data IQSendError = IQSendError XmppFailure -- There was an error sending the IQ+                                           -- stanza+                 | IQTimeOut -- No answer was received during the allotted time+                   deriving (Show, Eq, Typeable)++instance Ex.Exception IQSendError
+ source/Network/Xmpp/IM.hs view
@@ -0,0 +1,42 @@+-- | 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(..)+  , RosterUpdate(..)+  , getRoster+  , getRosterSTM+  , rosterAdd+  , rosterRemove+  -- * presenceTracker+  , PeerStatus(..)+  , isPeerAvailable+  , getEntityStatus+  , getAvailablePeers+  , getPeerEntities+  ) where++import Network.Xmpp.IM.Message+import Network.Xmpp.IM.Presence+import Network.Xmpp.IM.Roster+import Network.Xmpp.IM.Roster.Types+import Network.Xmpp.IM.PresenceTracker+import Network.Xmpp.IM.PresenceTracker.Types
+ source/Network/Xmpp/IM/Message.hs view
@@ -0,0 +1,116 @@+{-# 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]+                                     }++-- | Empty instant message.+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. Additional IM bodies with the same Langtag are+-- discarded.+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.+--+-- Additional IM bodies with the same Langtag are discarded.+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)
+ source/Network/Xmpp/IM/Presence.hs view
@@ -0,0 +1,77 @@+{-# 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, Eq)++data IMPresence = IMP { showStatus :: Maybe ShowStatus+                      , status     :: Maybe Text+                      , priority   :: Maybe Int+                      } deriving (Show, Eq)++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))+                  -- TODO: Multiple status elements with different lang tags+                  (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"
+ source/Network/Xmpp/IM/PresenceTracker.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE RankNTypes #-}+module Network.Xmpp.IM.PresenceTracker where++import           Control.Applicative+import           Control.Concurrent+import           Control.Concurrent.STM+import           Control.Lens.Prism (_Just)+import           Control.Monad+import qualified Data.Foldable as Foldable+import           Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import           Data.Maybe+import           Lens.Family2 hiding (Prism)+import           Lens.Family2.Stock hiding (Prism, _Just, from)+import           Network.Xmpp.Concurrent.Types+import           Network.Xmpp.IM.Presence+import           Network.Xmpp.Lens hiding (Lens, Traversal)+import           Network.Xmpp.Types+import           Prelude hiding (mapM)++import           Network.Xmpp.IM.PresenceTracker.Types++_peers :: Iso Peers (Map Jid (Map Jid (Maybe IMPresence)))+_peers = mkIso unPeers Peers++_PeerAvailable :: Prism PeerStatus (Maybe IMPresence)+_PeerAvailable = prism' PeerAvailable fromPeerAvailable+  where+    fromPeerAvailable (PeerAvailable pa) = Just pa+    fromPeerAvailable _  = Nothing++_PeerUnavailable :: Prism PeerStatus ()+_PeerUnavailable = prism' (const PeerUnavailable) fromPeerUnavailable+  where+    fromPeerUnavailable PeerUnavailable = Just ()+    fromPeerUnavailable _ = Nothing++_PeerStatus :: Iso (Maybe (Maybe IMPresence)) PeerStatus+_PeerStatus = mkIso toPeerStatus fromPeerStatus+  where+    toPeerStatus (Nothing) = PeerUnavailable+    toPeerStatus (Just imp) = PeerAvailable imp+    fromPeerStatus PeerUnavailable = Nothing+    fromPeerStatus (PeerAvailable imp) = Just imp++maybeMap :: Iso (Maybe (Map a b)) (Map a b)+maybeMap = mkIso maybeToMap mapToMaybe+  where+    maybeToMap Nothing = Map.empty+    maybeToMap (Just m) = m+    mapToMaybe m | Map.null m = Nothing+                 | otherwise = Just m+++-- | Status of give full JID+peerStatusL :: Jid -> Lens' Peers PeerStatus+peerStatusL j = _peers . at (toBare j)  . maybeMap . at j . _PeerStatus++peerMapPeerAvailable :: Jid -> Peers -> Bool+peerMapPeerAvailable j | isFull j = not . nullOf (peerStatusL j . _PeerAvailable)+                       | otherwise = not . nullOf (_peers . at j . _Just)++handlePresence :: Maybe (Jid -> PeerStatus -> PeerStatus -> IO ())+               -> TVar Peers+               -> StanzaHandler+handlePresence onChange peers _ st _  = do+        let mbPr = do+                pr <- st ^? _Stanza . _Presence -- Only act on presence stanzas+                fr <- pr ^? from . _Just . _isFull -- Only act on full JIDs+                return (pr, fr)+        Foldable.forM_ mbPr $ \(pr, fr) ->+            case presenceType pr of+                Available -> setStatus fr   (PeerAvailable (getIMPresence pr))+                Unavailable -> setStatus fr PeerUnavailable+                _ -> return ()+        return [(st, [])]+  where+    setStatus fr newStatus = do+        os <- atomically $ do+            ps <- readTVar peers+            let oldStatus = ps ^. peerStatusL fr+            writeTVar peers $ ps & set (peerStatusL fr) newStatus+            return oldStatus+        unless (os == newStatus) $ case onChange of+            Nothing -> return ()+            Just oc -> void . forkIO $ oc fr os newStatus+        return ()++-- | Check whether a given jid is available+isPeerAvailable :: Jid -> Session -> STM Bool+isPeerAvailable j sess = peerMapPeerAvailable j <$> readTVar (presenceRef sess)++-- | Get status of given full JID+getEntityStatus :: Jid -> Session -> STM PeerStatus+getEntityStatus j sess = do+    peers <- readTVar (presenceRef sess)+    return $ peers ^. peerStatusL j++-- | Get list of (bare) Jids with available entities+getAvailablePeers :: Session -> STM [Jid]+getAvailablePeers sess = do+    Peers peers <- readTVar (presenceRef sess)+    return $ Map.keys peers++-- | Get all available full JIDs to the given JID+getPeerEntities :: Jid -> Session -> STM (Map Jid (Maybe IMPresence))+getPeerEntities j sess = do+    Peers peers <- readTVar (presenceRef sess)+    case Map.lookup (toBare j) peers of+        Nothing -> return Map.empty+        Just js -> return js
+ source/Network/Xmpp/IM/PresenceTracker/Types.hs view
@@ -0,0 +1,20 @@+module Network.Xmpp.IM.PresenceTracker.Types where++import           Data.Map (Map)++import           Network.Xmpp.Types+import           Network.Xmpp.IM.Presence++-- Map from bare JIDs to a map of full JIDs to show maybe status.+--+-- Invariants:+-- * The outer map should not have entries for bare JIDs that have no+--   available resource, i.e. the inner map should never be empty+--+-- * The inner map keys' local and domain part coincide with the outer keys'+newtype Peers = Peers { unPeers :: Map Jid (Map Jid (Maybe IMPresence))}+                deriving (Show)++data PeerStatus = PeerAvailable (Maybe IMPresence)+                | PeerUnavailable+                  deriving (Show, Eq)
+ source/Network/Xmpp/IM/Roster.hs view
@@ -0,0 +1,254 @@+{-# 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++-- | Timeout to use with IQ requests+timeout :: Maybe Integer+timeout = Just 3000000 -- 3 seconds++-- | Add or update an item to the roster.+--+-- To update the item just send the complete set of new data.+rosterSet :: Jid -- ^ JID of the item+          -> Maybe Text -- ^ Name alias+          -> [Text] -- ^ Groups (duplicates will be removed)+          -> Session+          -> IO (Either IQSendError (Annotated IQResponse))+rosterSet 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+                                            }])+    sendIQA' timeout Nothing Set Nothing el [] session++-- | Synonym to rosterSet+rosterAdd :: Jid+          -> Maybe Text+          -> [Text]+          -> Session+          -> IO (Either IQSendError (Annotated IQResponse))+rosterAdd = rosterSet++-- | 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+                Right (IQResponseResult IQResult{}, _) -> return True+                _ -> return False+  where+    rosterPush :: Item+               -> Session+               -> IO (Either IQSendError (Annotated IQResponse))+    rosterPush item session = do+        let el = pickleElem xpQuery (Query Nothing [fromItem item])+        sendIQA' timeout Nothing Set Nothing el [] session++-- | Retrieve the current Roster state (STM version)+getRosterSTM :: Session -> STM Roster+getRosterSTM session = readTVar (rosterRef session)++-- | Retrieve the current Roster state+getRoster :: Session -> IO Roster+getRoster session = atomically $ getRosterSTM session++-- | Get the initial roster or 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 :: Maybe Jid+             -> TVar Roster+             -> RosterPushCallback+             -> StanzaHandler+handleRoster mbBoundJid ref onUpdate out sta _ = do+    case sta of+        XmppStanza (IQRequestS (iqr@IQRequest{iqRequestPayload =+                                              iqb@Element{elementName = en}}))+            | nameNamespace en == Just "jabber:iq:roster" -> do+                let doHandle = case (iqRequestFrom iqr, mbBoundJid) of+                        -- We don't need to check our own JID when the IQ+                        -- request was sent without a from address+                        (Nothing, _) -> True+                        -- We don't have a Jid bound, so we can't verify that+                        -- the from address matches our bare jid+                        (Just _fr, Nothing) -> False+                        -- Check that the from address matches our bare jid+                        (Just fr, Just boundJid) | fr == toBare boundJid -> True+                                                 | otherwise -> False+                if doHandle+                    then case unpickleElem xpQuery iqb of+                        Right Query{ queryVer = v+                                   , queryItems = [update]+                                   } -> do+                            handleUpdate v update+                            _ <- out . XmppStanza $ result iqr+                            return []+                        _ -> do+                            errorM "Pontarius.Xmpp" "Invalid roster query"+                            _ <- out . XmppStanza $ badRequest iqr+                            return []+                    -- Don't handle roster pushes from unauthorized sources+                    else return [(sta, [])]+        _ -> return [(sta, [])]+  where+    handleUpdate v' update = do+        oldRoster <- atomically $ readTVar ref+        case qiSubscription update of+         Just Remove -> do+             let j = qiJid update+             onUpdate oldRoster $ RosterUpdateRemove j+             updateRoster (Map.delete j)+         _ -> do+             let i = (toItem update)+             onUpdate oldRoster $ RosterUpdateAdd i+             updateRoster $ Map.insert (qiJid update) i+      where+        updateRoster f = atomically . modifyTVar ref $+                           \(Roster v is) -> Roster (v' `mplus` v) (f is)++    badRequest (IQRequest iqid from _to lang _tp bd _attrs) =+        IQErrorS $ IQError iqid Nothing from lang errBR (Just bd) []+    errBR = StanzaError Cancel BadRequest Nothing Nothing+    result (IQRequest iqid from _to lang _tp _bd _attrs) =+        IQResultS $ IQResult iqid Nothing from lang Nothing []++retrieveRoster :: Maybe Roster -> Session -> IO (Maybe Roster)+retrieveRoster mbOldRoster sess = do+    useVersioning <- isJust . streamFeaturesRosterVer <$> getFeatures sess+    let version = if useVersioning+                then case mbOldRoster of+                      Nothing -> Just ""+                      Just oldRoster -> ver oldRoster+                else Nothing+    res <- sendIQ' timeout Nothing Get Nothing+                   (pickleElem xpQuery (Query version []))+                   []+                   sess+    case res of+        Left e -> do+            errorM "Pontarius.Xmpp.Roster" $ "getRoster: " ++ show e+            return Nothing+        Right (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'+        Right (IQResponseResult IQResult{iqResultPayload = Nothing}) -> do+            return mbOldRoster+                -- sever indicated that no roster updates are necessary+        Right (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 = fromSubscription (qiSubscription qi)+                 , riGroups = nub $ qiGroups qi+                 }+  where+    fromSubscription Nothing = None+    fromSubscription (Just s) | s `elem` [None, To, From, Both] = s+                              | otherwise = None++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", "") <?>+        xpIso subscriptionFromText+              subscriptionToText+  where+    subscriptionFromText "none" = None+    subscriptionFromText "to" = To+    subscriptionFromText "from" = From+    subscriptionFromText "both" = Both+    subscriptionFromText "remove" = Remove+    subscriptionFromText _ = None+    subscriptionToText None = "none"+    subscriptionToText To = "to"+    subscriptionToText From = "from"+    subscriptionToText Both = "both"+    subscriptionToText Remove = "remove"
+ source/Network/Xmpp/IM/Roster/Types.hs view
@@ -0,0 +1,52 @@+{-# OPTIONS_HADDOCK hide #-}+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 -- ^ the user does not have a subscription to the+                         -- contact's presence information, and the contact does+                         -- not have a subscription to the user's presence+                         -- information+                  | To  -- ^ the user has a subscription to the contact's+                        -- presence information, but the contact does not have a+                        -- subscription to the user's presence information+                  | From -- ^ the contact has a subscription to the user's+                         -- presence information, but the user does not have a+                         -- subscription to the contact's presence information+                  | Both -- ^ both the user and the contact have subscriptions+                         -- to each other's presence information+                  | 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 RosterUpdate = RosterUpdateRemove Jid+                  | RosterUpdateAdd Item -- ^ New or updated item+                  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
+ source/Network/Xmpp/Internal.hs view
@@ -0,0 +1,73 @@+-- |+-- Module:      $Header$+--+-- Stability:   unstable+-- Portability: portable+--+-- This module allows for low-level access to Pontarius XMPP. Generally, the+-- "Network.Xmpp" module should be used instead.+--+-- The 'Stream' object provides the most low-level access to the XMPP+-- stream: a simple and single-threaded interface which exposes the conduit+-- 'Event' source, as well as the input and output byte streams. Custom stateful+-- 'Stream' functions can be executed using 'withStream'.+--+-- The TLS, SASL, and 'Session' functionalities of Pontarius XMPP are built on+-- top of this API.++module Network.Xmpp.Internal+  ( module Network.Xmpp.Concurrent+  , module Network.Xmpp.Concurrent.Basic+  , module Network.Xmpp.Concurrent.IQ+  , module Network.Xmpp.Concurrent.Message+  , module Network.Xmpp.Concurrent.Monad+  , module Network.Xmpp.Concurrent.Presence+  , module Network.Xmpp.Concurrent.Threads+  , module Network.Xmpp.Concurrent.Types+  , module Network.Xmpp.IM.Message+  , module Network.Xmpp.IM.Presence+  , module Network.Xmpp.IM.Roster+  , module Network.Xmpp.IM.Roster.Types+  , module Network.Xmpp.Marshal+  , module Network.Xmpp.Sasl+  , module Network.Xmpp.Sasl.Common+  , module Network.Xmpp.Sasl.Mechanisms+  , module Network.Xmpp.Sasl.Mechanisms.DigestMd5+  , module Network.Xmpp.Sasl.Mechanisms.Plain+  , module Network.Xmpp.Sasl.Mechanisms.Scram+  , module Network.Xmpp.Sasl.StringPrep+  , module Network.Xmpp.Sasl.Types+  , module Network.Xmpp.Stanza+  , module Network.Xmpp.Stream+  , module Network.Xmpp.Tls+  , module Network.Xmpp.Types+  , module Network.Xmpp.Utilities+  ) where+++import Network.Xmpp.Concurrent+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.Types+import Network.Xmpp.IM.Message+import Network.Xmpp.IM.Presence+import Network.Xmpp.IM.Roster+import Network.Xmpp.IM.Roster.Types+import Network.Xmpp.Marshal+import Network.Xmpp.Sasl+import Network.Xmpp.Sasl.Common+import Network.Xmpp.Sasl.Mechanisms+import Network.Xmpp.Sasl.Mechanisms.DigestMd5+import Network.Xmpp.Sasl.Mechanisms.Plain+import Network.Xmpp.Sasl.Mechanisms.Scram+import Network.Xmpp.Sasl.StringPrep+import Network.Xmpp.Sasl.Types+import Network.Xmpp.Stanza+import Network.Xmpp.Stream hiding (mbl, lmb)+import Network.Xmpp.Tls+import Network.Xmpp.Types+import Network.Xmpp.Utilities
+ source/Network/Xmpp/Lens.hs view
@@ -0,0 +1,740 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}++-- | (More than just) Van Laarhoven lenses for XMPP types. The accessors in here+-- are designed to work with an optics library like lens or lens-family. This+-- module also provides a few simple functions ('view', 'modify', 'set' and+-- 'getAll') so you don't need to pull in another library to get some use out+-- of them.+--+-- * The name of the lenses corresponds to the field name of the data types with+-- an upper-case L appended. For documentation of the fields refer to the documentation of the data types (linked in the section header)+--+-- * Same goes for Traversals, except they are suffixed with a \'T\'+--+-- * Prism generally start with an underscore+--+-- /NB/ you do not need to import this module to get access to the optics+-- defined herein. They are also exported from Network.Xmpp. You only need to+-- import this module if you want to use the complementary accessor functions+-- without using an optics library like lens or lens-family++module Network.Xmpp.Lens+       ( Lens+       , Traversal+       , Prism+       , Iso+         -- * Accessors+         -- | Reimplementation of the basic lens functions so you don't have to+         -- bring in a lens library to use the optics++         -- ** Lenses+       , LF.view+       , modify+       , LF.set+         -- * Traversals+       , getAll+         -- * Prisms++         -- ** Construction+       , prism'+       , mkLens+       , mkIso+         -- * Lenses++         -- ** JID+       , _JidText+       , _isFull+       , _isBare++         -- ** Stanzas and Nonzas+       , _Stanza+       , _Nonza+       , _IQRequest+       , _IQResult+       , _IQError+       , _Message+       , _MessageError+       , _Presence+       , _PresenceError+       , IsStanza(..)+       , HasStanzaPayload(..)+       , IsErrorStanza(..)+       , messageTypeL+       , presenceTypeL+       , iqRequestTypeL+         -- *** 'StanzaError'+       , stanzaErrorTypeL+       , stanzaErrorConditionL+       , stanzaErrorTextL+       , stanzaErrorApplL+         -- ** Stream++         -- ** Stream Features+       , featureTlsL+       , featureMechanismsL+       , featureRosterVerL+       , featurePreApprovalL+       , featuresOtherL+         -- *** 'StreamConfiguration'+       , preferredLangL+       , toJidL+       , connectionDetailsL+       , resolvConfL+       , tlsBehaviourL+       , tlsParamsL+         -- **** TLS parameters+       , clientServerIdentificationL+       , tlsServerIdentificationL+       , clientSupportedL+       , supportedCiphersL+       , supportedVersionsL+       , tlsSupportedCiphersL+       , tlsSupportedVersionsL+       , clientUseServerNameIndicationL+       , tlsUseNameIndicationL+         -- *** 'SessionConfiguration'+       , streamConfigurationL+       , onConnectionClosedL+       , sessionStanzaIDsL+       , ensableRosterL+       , onRosterPushL+       , pluginsL+       , onPresenceChangeL+         -- ** IM+         -- *** Roster+         -- **** 'Roster'+       , verL+       , itemsL+         -- **** 'Item'+       , riApprovedL+       , riAskL+       , riJidL+       , riNameL+       , riSubscriptionL+       , riGroupsL+         -- **** 'QueryItem'+       , qiApprovedL+       , qiAskL+       , qiJidL+       , qiNameL+       , qiSubscriptionL+       , qiGroupsL+         -- **** 'Query'+       , queryVerL+       , queryItemsL+         -- ** IM Message+         -- *** 'MessageBody'+       , bodyLangL+       , bodyContentL+         -- *** 'MessageThread'+       , threadIdL+       , threadParentL+         -- *** 'MessageSubject'+       , subjectLangL+       , subjectContentL+         -- *** 'InstantMessage'+       , imThreadL+       , imSubjectL+       , imBodyL+         -- ** 'IMPresence'+       , showStatusL+       , statusL+       , priorityL++       )+       where++import           Control.Applicative+import qualified Data.ByteString as BS+import           Data.Functor.Identity (Identity(..))+import qualified Data.Map as Map+import           Data.Profunctor+import           Data.Text (Text)+import qualified Data.Text as Text+import           Data.XML.Types (Element)+import qualified Lens.Family2 as LF+import           Network.DNS (ResolvConf)+import           Network.TLS as TLS+import           Network.Xmpp.Concurrent.Types+import           Network.Xmpp.IM.Message+import           Network.Xmpp.IM.Presence+import           Network.Xmpp.IM.PresenceTracker.Types+import           Network.Xmpp.IM.Roster.Types+import           Network.Xmpp.Types++-- | Van-Laarhoven lenses.+{-# DEPRECATED Lens "Use Lens' from lens-family or lens" #-}+type Lens a b = forall f . Functor f => (b -> f b) -> a -> f a++{-# DEPRECATED Traversal "Use Traversal' from lens-family or lens" #-}+type Traversal a b = forall f . Applicative f => (b -> f b) -> a -> f a++type Prism a b = forall p f. (Choice p, Applicative f) => p b (f b) -> p a (f a)++type Iso a b = forall p f. (Profunctor p, Functor f) => p b (f b) -> p a (f a)++prism' :: (b -> s) -> (s -> Maybe b) -> Prism s b+prism' bs sma = dimap (\s -> maybe (Left s) Right (sma s))+                      (either pure (fmap bs)) . right'++mkLens :: (a -> b) -> (b -> a ->  a) -> Lens a b+mkLens get set = \inj x -> fmap (flip set x) (inj $ get x)++mkIso :: (a -> b) -> (b -> a) -> Iso a b+mkIso t f = dimap t (fmap f)++newtype Collect a b = Collect {getCollection :: [a]} deriving Functor++instance Applicative (Collect a) where+    pure _ = Collect []+    Collect xs <*> Collect ys = Collect $ xs ++ ys++{-# DEPRECATED getAll "use toListOf (lens-family), partsOf (lens) or similar" #-}+-- | Return all the values a Traversal is pointing to in a list+getAll :: Traversal a b -> a -> [b]+getAll t = getCollection . t (Collect . pure)++{-# DEPRECATED modify "use over (lens-family, lens)" #-}+modify :: Traversal a b -> (b -> b) -> a -> a+modify t f = runIdentity . t (Identity . f)++-- Xmpp Lenses+--------------------++_JidText :: Prism Text Jid+_JidText = prism' jidToText jidFromText++_isFull :: Prism Jid Jid+_isFull = prism' id (\j -> if isFull j then Just j else Nothing)++_isBare :: Prism Jid Jid+_isBare = prism' toBare (\j -> if isBare j then Just j else Nothing)++_Stanza :: Prism XmppElement Stanza+_Stanza = prism' XmppStanza (\v -> case v of+                                    XmppStanza s -> Just s+                                    _ -> Nothing)++_Nonza :: Prism XmppElement Element+_Nonza = prism' XmppNonza (\v -> case v of+                                  XmppNonza n -> Just n+                                  _ -> Nothing)+++class IsStanza s where+    -- | From-attribute of the stanza+    from :: Lens s (Maybe Jid)+    -- | To-attribute of the stanza+    to   :: Lens s (Maybe Jid)+    -- | Langtag of the stanza+    lang :: Lens s (Maybe LangTag)+    -- | Stanza ID. Setting this to /Nothing/ for IQ* stanzas will set the id to+    -- the empty Text.+    sid :: Lens s (Maybe Text)+    -- | Traversal over the payload elements.+    payloadT :: Traversal s Element++traverseList :: Traversal [a] a+traverseList _inj [] = pure []+traverseList inj  (x:xs) = (:) <$> inj x <*> traverseList inj xs++instance IsStanza Message where+    from inj m@(Message{messageFrom=f}) = (\f' -> m{messageFrom = f'}) <$> inj f+    to inj m@(Message{messageTo=t}) = (\t' -> m{messageTo = t'}) <$> inj t+    lang inj m@(Message{messageLangTag=t}) =+        (\t' -> m{messageLangTag = t'}) <$> inj t+    sid inj m@(Message{messageID = i}) =+        ((\i' -> m{messageID = i'}) <$> inj i)+    payloadT inj m@(Message{messagePayload=pl}) =+        (\pl' -> m{messagePayload=pl'}) <$> traverseList inj pl+++instance IsStanza MessageError where+    from inj m@(MessageError{messageErrorFrom=f}) =+        (\f' -> m{messageErrorFrom = f'}) <$> inj f+    to inj m@(MessageError{messageErrorTo=t}) =+        (\t' -> m{messageErrorTo = t'}) <$> inj t+    lang inj m@(MessageError{messageErrorLangTag=t}) =+        (\t' -> m{messageErrorLangTag = t'}) <$> inj t+    sid inj m@(MessageError{messageErrorID = i}) =+        ((\i' -> m{messageErrorID = i'}) <$> inj i)+    payloadT inj m@(MessageError{messageErrorPayload=pl}) =+        (\pl' -> m{messageErrorPayload=pl'}) <$> traverseList inj pl++instance IsStanza Presence where+    from inj m@(Presence{presenceFrom=f}) = (\f' -> m{presenceFrom = f'}) <$> inj f+    to inj m@(Presence{presenceTo=t}) = (\t' -> m{presenceTo = t'}) <$> inj t+    lang inj m@(Presence{presenceLangTag=t}) =+        (\t' -> m{presenceLangTag = t'}) <$> inj t+    sid inj m@(Presence{presenceID = i}) =+        ((\i' -> m{presenceID = i'}) <$> inj i)+    payloadT inj m@(Presence{presencePayload=pl}) =+        (\pl' -> m{presencePayload=pl'}) <$> traverseList inj pl++instance IsStanza PresenceError where+    from inj m@(PresenceError{presenceErrorFrom=f}) =+        (\f' -> m{presenceErrorFrom = f'}) <$> inj f+    to inj m@(PresenceError{presenceErrorTo=t}) =+        (\t' -> m{presenceErrorTo = t'}) <$> inj t+    lang inj m@(PresenceError{presenceErrorLangTag=t}) =+        (\t' -> m{presenceErrorLangTag = t'}) <$> inj t+    sid inj m@(PresenceError{presenceErrorID = i}) =+        ((\i' -> m{presenceErrorID = i'}) <$> inj i)+    payloadT inj m@(PresenceError{presenceErrorPayload=pl}) =+        (\pl' -> m{presenceErrorPayload=pl'}) <$> traverseList inj pl++instance IsStanza IQRequest where+    from inj m@(IQRequest{iqRequestFrom=f}) =+        (\f' -> m{iqRequestFrom = f'}) <$> inj f+    to inj m@(IQRequest{iqRequestTo=t}) =+        (\t' -> m{iqRequestTo = t'}) <$> inj t+    lang inj m@(IQRequest{iqRequestLangTag=t}) =+        (\t' -> m{iqRequestLangTag = t'}) <$> inj t+    sid inj m@(IQRequest{iqRequestID = i}) =+        ((\i' -> m{iqRequestID = i'}) <$> maybeNonempty inj i)+    payloadT inj m@(IQRequest{iqRequestPayload=pl}) =+        (\pl' -> m{iqRequestPayload=pl'}) <$> inj pl++instance IsStanza IQResult where+    from inj m@(IQResult{iqResultFrom=f}) =+        (\f' -> m{iqResultFrom = f'}) <$> inj f+    to inj m@(IQResult{iqResultTo=t}) =+        (\t' -> m{iqResultTo = t'}) <$> inj t+    lang inj m@(IQResult{iqResultLangTag=t}) =+        (\t' -> m{iqResultLangTag = t'}) <$> inj t+    sid inj m@(IQResult{iqResultID = i}) =+        ((\i' -> m{iqResultID = i'}) <$> maybeNonempty inj i)+    payloadT inj m@(IQResult{iqResultPayload=pl}) =+        (\pl' -> m{iqResultPayload=pl'}) <$> maybe (pure Nothing)+                                                   (fmap Just . inj) pl++instance IsStanza IQError where+    from inj m@(IQError{iqErrorFrom=f}) =+        (\f' -> m{iqErrorFrom = f'}) <$> inj f+    to inj m@(IQError{iqErrorTo=t}) =+        (\t' -> m{iqErrorTo = t'}) <$> inj t+    lang inj m@(IQError{iqErrorLangTag=t}) =+        (\t' -> m{iqErrorLangTag = t'}) <$> inj t+    sid inj m@(IQError{iqErrorID = i}) =+        ((\i' -> m{iqErrorID = i'}) <$> maybeNonempty inj i)+    payloadT inj m@(IQError{iqErrorPayload=pl}) =+        (\pl' -> m{iqErrorPayload=pl'}) <$> maybe (pure Nothing)+                                                  (fmap Just . inj) pl++liftLens :: (forall s. IsStanza s => Lens s a) -> Lens Stanza a+liftLens f inj (IQRequestS     s) = IQRequestS     <$> f inj s+liftLens f inj (IQResultS      s) = IQResultS      <$> f inj s+liftLens f inj (IQErrorS       s) = IQErrorS       <$> f inj s+liftLens f inj (MessageS       s) = MessageS       <$> f inj s+liftLens f inj (MessageErrorS  s) = MessageErrorS  <$> f inj s+liftLens f inj (PresenceS      s) = PresenceS      <$> f inj s+liftLens f inj (PresenceErrorS s) = PresenceErrorS <$> f inj s++liftTraversal :: (forall s. IsStanza s => Traversal s a) -> Traversal Stanza a+liftTraversal f inj (IQRequestS     s) = IQRequestS     <$> f inj s+liftTraversal f inj (IQResultS      s) = IQResultS      <$> f inj s+liftTraversal f inj (IQErrorS       s) = IQErrorS       <$> f inj s+liftTraversal f inj (MessageS       s) = MessageS       <$> f inj s+liftTraversal f inj (MessageErrorS  s) = MessageErrorS  <$> f inj s+liftTraversal f inj (PresenceS      s) = PresenceS      <$> f inj s+liftTraversal f inj (PresenceErrorS s) = PresenceErrorS <$> f inj s++instance IsStanza Stanza where+    from     = liftLens from+    to       = liftLens to+    lang     = liftLens lang+    sid      = liftLens sid+    payloadT = liftTraversal payloadT++maybeNonempty :: Lens Text (Maybe Text)+maybeNonempty inj x = (maybe Text.empty id)+                      <$> inj (if Text.null x then Nothing else Just x)+++_IQRequest :: Prism Stanza IQRequest+_IQRequest = prism' IQRequestS fromIQRequestS+  where+    fromIQRequestS (IQRequestS s) = Just s+    fromIQRequestS _ = Nothing++_IQResult :: Prism Stanza IQResult+_IQResult = prism' IQResultS fromIQResultS+  where+    fromIQResultS (IQResultS s) = Just s+    fromIQResultS _ = Nothing++_IQError :: Prism Stanza IQError+_IQError = prism' IQErrorS fromIQErrorS+  where+    fromIQErrorS (IQErrorS s) = Just s+    fromIQErrorS _ = Nothing++_Message :: Prism Stanza Message+_Message = prism' MessageS fromMessageS+  where+    fromMessageS (MessageS s) = Just s+    fromMessageS _ = Nothing++_MessageError :: Prism Stanza MessageError+_MessageError = prism' MessageErrorS fromMessageErrorS+  where+    fromMessageErrorS (MessageErrorS s) = Just s+    fromMessageErrorS _ = Nothing++_Presence :: Prism Stanza Presence+_Presence = prism' PresenceS fromPresenceS+  where+    fromPresenceS (PresenceS s) = Just s+    fromPresenceS _ = Nothing++_PresenceError :: Prism Stanza PresenceError+_PresenceError = prism' PresenceErrorS fromPresenceErrorS+  where+    fromPresenceErrorS (PresenceErrorS s) = Just s+    fromPresenceErrorS _ = Nothing++class IsErrorStanza s where+    -- | Error element of the stanza+    stanzaError :: Lens s StanzaError++instance IsErrorStanza IQError where+    stanzaError inj m@IQError{iqErrorStanzaError = i} =+        (\i' -> m{iqErrorStanzaError = i'}) <$> inj i++instance IsErrorStanza MessageError where+    stanzaError inj m@MessageError{messageErrorStanzaError = i} =+        (\i' -> m{messageErrorStanzaError = i'}) <$> inj i++instance IsErrorStanza PresenceError where+    stanzaError inj m@PresenceError{presenceErrorStanzaError = i} =+        (\i' -> m{presenceErrorStanzaError = i'}) <$> inj i++class HasStanzaPayload s p | s -> p where+    -- | Payload element(s) of the stanza. Since the amount of elements possible+    -- in a stanza vary by type, this lens can't be used with a general+    -- 'Stanza'. There is, however, a more general Traversable that works with+    -- all stanzas (including 'Stanza'): 'payloadT'+    payload :: Lens s p++instance HasStanzaPayload IQRequest Element where+    payload inj m@IQRequest{iqRequestPayload = i} =+        (\i' -> m{iqRequestPayload = i'}) <$> inj i++instance HasStanzaPayload IQResult (Maybe Element) where+    payload inj m@IQResult{iqResultPayload = i} =+        (\i' -> m{iqResultPayload = i'}) <$> inj i++instance HasStanzaPayload IQError (Maybe Element) where+    payload inj m@IQError{iqErrorPayload = i} =+        (\i' -> m{iqErrorPayload = i'}) <$> inj i++instance HasStanzaPayload Message [Element] where+    payload inj m@Message{messagePayload = i} =+        (\i' -> m{messagePayload = i'}) <$> inj i++instance HasStanzaPayload MessageError [Element] where+    payload inj m@MessageError{messageErrorPayload = i} =+        (\i' -> m{messageErrorPayload = i'}) <$> inj i++instance HasStanzaPayload Presence [Element] where+    payload inj m@Presence{presencePayload = i} =+        (\i' -> m{presencePayload = i'}) <$> inj i++instance HasStanzaPayload PresenceError [Element] where+    payload inj m@PresenceError{presenceErrorPayload = i} =+        (\i' -> m{presenceErrorPayload = i'}) <$> inj i++iqRequestTypeL :: Lens IQRequest IQRequestType+iqRequestTypeL inj p@IQRequest{iqRequestType = tp} =+    (\tp' -> p{iqRequestType = tp'}) <$> inj tp+++messageTypeL :: Lens Message MessageType+messageTypeL inj p@Message{messageType = tp} =+    (\tp' -> p{messageType = tp'}) <$> inj tp++presenceTypeL :: Lens Presence PresenceType+presenceTypeL inj p@Presence{presenceType = tp} =+    (\tp' -> p{presenceType = tp'}) <$> inj tp+++-- StanzaError+-----------------------++stanzaErrorTypeL :: Lens StanzaError StanzaErrorType+stanzaErrorTypeL inj se@StanzaError{stanzaErrorType = x} =+    (\x' -> se{stanzaErrorType = x'}) <$> inj x++stanzaErrorConditionL :: Lens StanzaError StanzaErrorCondition+stanzaErrorConditionL inj se@StanzaError{stanzaErrorCondition = x} =+    (\x' -> se{stanzaErrorCondition = x'}) <$> inj x++stanzaErrorTextL :: Lens StanzaError (Maybe (Maybe LangTag, NonemptyText))+stanzaErrorTextL inj se@StanzaError{stanzaErrorText = x} =+    (\x' -> se{stanzaErrorText = x'}) <$> inj x++stanzaErrorApplL  :: Lens StanzaError (Maybe Element)+stanzaErrorApplL inj se@StanzaError{stanzaErrorApplicationSpecificCondition = x} =+    (\x' -> se{stanzaErrorApplicationSpecificCondition = x'}) <$> inj x+++-- StreamConfiguration+-----------------------++preferredLangL :: Lens StreamConfiguration (Maybe LangTag)+preferredLangL inj sc@StreamConfiguration{preferredLang = x}+    = (\x' -> sc{preferredLang = x'}) <$> inj x++toJidL :: Lens StreamConfiguration (Maybe (Jid, Bool))+toJidL inj sc@StreamConfiguration{toJid = x}+    = (\x' -> sc{toJid = x'}) <$> inj x++connectionDetailsL :: Lens StreamConfiguration ConnectionDetails+connectionDetailsL inj sc@StreamConfiguration{connectionDetails = x}+    = (\x' -> sc{connectionDetails = x'}) <$> inj x++resolvConfL :: Lens StreamConfiguration ResolvConf+resolvConfL inj sc@StreamConfiguration{resolvConf = x}+    = (\x' -> sc{resolvConf = x'}) <$> inj x++tlsBehaviourL :: Lens StreamConfiguration TlsBehaviour+tlsBehaviourL inj sc@StreamConfiguration{tlsBehaviour = x}+    = (\x' -> sc{tlsBehaviour = x'}) <$> inj x+++tlsParamsL :: Lens StreamConfiguration ClientParams+tlsParamsL inj sc@StreamConfiguration{tlsParams = x}+    = (\x' -> sc{tlsParams = x'}) <$> inj x++-- TLS parameters+-----------------++clientServerIdentificationL  :: Lens ClientParams (String, BS.ByteString)+clientServerIdentificationL inj cp+    = (\x' -> cp{clientServerIdentification = x'}) <$> inj (clientServerIdentification cp)++clientSupportedL  :: Lens ClientParams Supported+clientSupportedL inj cp+    = (\x' -> cp{clientSupported = x'}) <$> inj (clientSupported cp)++clientUseServerNameIndicationL  :: Lens ClientParams Bool+clientUseServerNameIndicationL inj cp+    = (\x' -> cp{clientUseServerNameIndication = x'}) <$> inj (clientUseServerNameIndication cp)++supportedCiphersL :: Lens Supported [Cipher]+supportedCiphersL inj s+    = (\x' -> s{supportedCiphers = x'}) <$> inj (supportedCiphers s)++supportedVersionsL :: Lens Supported [TLS.Version]+supportedVersionsL inj s+    = (\x' -> s{supportedVersions = x'}) <$> inj (supportedVersions s)++-- SessionConfiguration+-----------------------+streamConfigurationL :: Lens SessionConfiguration StreamConfiguration+streamConfigurationL inj sc@SessionConfiguration{sessionStreamConfiguration = x}+    = (\x' -> sc{sessionStreamConfiguration = x'}) <$> inj x++onConnectionClosedL :: Lens SessionConfiguration (Session -> XmppFailure -> IO ())+onConnectionClosedL inj sc@SessionConfiguration{onConnectionClosed = x}+    = (\x' -> sc{onConnectionClosed = x'}) <$> inj x++sessionStanzaIDsL :: Lens SessionConfiguration (IO (IO Text))+sessionStanzaIDsL inj sc@SessionConfiguration{sessionStanzaIDs = x}+    = (\x' -> sc{sessionStanzaIDs = x'}) <$> inj x++ensableRosterL :: Lens SessionConfiguration Bool+ensableRosterL inj sc@SessionConfiguration{enableRoster = x}+    = (\x' -> sc{enableRoster = x'}) <$> inj x++onRosterPushL :: Lens SessionConfiguration (Maybe RosterPushCallback)+onRosterPushL = mkLens onRosterPush (\orp x -> x{onRosterPush = orp})++pluginsL :: Lens SessionConfiguration [Plugin]+pluginsL inj sc@SessionConfiguration{plugins = x}+    = (\x' -> sc{plugins = x'}) <$> inj x++onPresenceChangeL :: Lens SessionConfiguration (Maybe ( Jid -> PeerStatus+                                                        -> PeerStatus -> IO ()))+onPresenceChangeL inj sc@SessionConfiguration{onPresenceChange = x}+    = (\x' -> sc{onPresenceChange = x'}) <$> inj x++-- | Access clientServerIdentification inside tlsParams inside streamConfiguration+tlsServerIdentificationL  :: Lens SessionConfiguration (String, BS.ByteString)+tlsServerIdentificationL = streamConfigurationL+                         . tlsParamsL+                         . clientServerIdentificationL++-- | Access clientUseServerNameIndication inside tlsParams+tlsUseNameIndicationL :: Lens SessionConfiguration Bool+tlsUseNameIndicationL = streamConfigurationL+                      . tlsParamsL+                      . clientUseServerNameIndicationL++-- | Access supportedCiphers inside clientSupported inside tlsParams+tlsSupportedCiphersL :: Lens SessionConfiguration [Cipher]+tlsSupportedCiphersL =  streamConfigurationL+                     .  tlsParamsL . clientSupportedL . supportedCiphersL++-- | Access supportedVersions inside clientSupported inside tlsParams+tlsSupportedVersionsL :: Lens SessionConfiguration [TLS.Version]+tlsSupportedVersionsL = streamConfigurationL+                      . tlsParamsL . clientSupportedL . supportedVersionsL+++-- Roster+------------------++verL :: Lens Roster (Maybe Text)+verL inj r@Roster{ver = x} = (\x' -> r{ver = x'}) <$> inj x++itemsL :: Lens Roster (Map.Map Jid Item)+itemsL inj r@Roster{items = x} = (\x' -> r{items = x'}) <$> inj x++-- Item+------------------++riApprovedL :: Lens Item Bool+riApprovedL inj i@Item{riApproved = x} = (\x' -> i{riApproved = x'}) <$> inj x++riAskL :: Lens Item Bool+riAskL inj i@Item{riAsk = x} = (\x' -> i{riAsk = x'}) <$> inj x++riJidL :: Lens Item Jid+riJidL inj i@Item{riJid = x} = (\x' -> i{riJid = x'}) <$> inj x++riNameL :: Lens Item (Maybe Text)+riNameL inj i@Item{riName = x} = (\x' -> i{riName = x'}) <$> inj x++riSubscriptionL :: Lens Item Subscription+riSubscriptionL inj i@Item{riSubscription = x} =+    (\x' -> i{riSubscription = x'}) <$> inj x++riGroupsL :: Lens Item [Text]+riGroupsL inj i@Item{riGroups = x} = (\x' -> i{riGroups = x'}) <$> inj x++-- Roster Update+-------------------++_RosterUpdateRemove :: Prism RosterUpdate Jid+_RosterUpdateRemove = prism' RosterUpdateRemove fromRosterUpdateRemove+  where+    fromRosterUpdateRemove (RosterUpdateRemove jid) = Just jid+    fromRosterUpdateRemove RosterUpdateAdd{} = Nothing++_RosterUpdateAdd :: Prism RosterUpdate Item+_RosterUpdateAdd = prism' RosterUpdateAdd fromRosterUpdateAdd+  where+    fromRosterUpdateAdd RosterUpdateRemove{} = Nothing+    fromRosterUpdateAdd (RosterUpdateAdd item) = Just item+++-- QueryItem+-------------------+qiApprovedL :: Lens QueryItem (Maybe Bool)+qiApprovedL inj i@QueryItem{qiApproved = x} =+    (\x' -> i{qiApproved = x'}) <$> inj x++qiAskL :: Lens QueryItem Bool+qiAskL inj i@QueryItem{qiAsk = x} = (\x' -> i{qiAsk = x'}) <$> inj x++qiJidL :: Lens QueryItem Jid+qiJidL inj i@QueryItem{qiJid = x} = (\x' -> i{qiJid = x'}) <$> inj x++qiNameL :: Lens QueryItem (Maybe Text)+qiNameL inj i@QueryItem{qiName = x} = (\x' -> i{qiName = x'}) <$> inj x++qiSubscriptionL :: Lens QueryItem (Maybe Subscription)+qiSubscriptionL inj i@QueryItem{qiSubscription = x} =+    (\x' -> i{qiSubscription = x'}) <$> inj x++qiGroupsL :: Lens QueryItem [Text]+qiGroupsL inj i@QueryItem{qiGroups = x} = (\x' -> i{qiGroups = x'}) <$> inj x++queryVerL :: Lens Query (Maybe Text)+queryVerL inj i@Query{queryVer = x} = (\x' -> i{queryVer = x'}) <$> inj x++queryItemsL :: Lens Query [QueryItem]+queryItemsL inj i@Query{queryItems = x} = (\x' -> i{queryItems = x'}) <$> inj x+++-- IM+-------------------+++bodyLangL :: Lens MessageBody (Maybe LangTag)+bodyLangL inj m@MessageBody{bodyLang = bl} = (\bl' -> m{bodyLang = bl'}) <$> inj bl++bodyContentL :: Lens MessageBody Text+bodyContentL inj m@MessageBody{bodyContent = bc} =+    (\bc' -> m{bodyContent = bc'}) <$> inj bc++threadIdL :: Lens MessageThread Text+threadIdL inj m@MessageThread{threadID = bc} =+    (\bc' -> m{threadID = bc'}) <$> inj bc++threadParentL :: Lens MessageThread (Maybe Text)+threadParentL inj m@MessageThread{threadParent = bc} =+    (\bc' -> m{threadParent = bc'}) <$> inj bc++subjectLangL :: Lens MessageSubject (Maybe LangTag)+subjectLangL inj m@MessageSubject{subjectLang = bc} =+    (\bc' -> m{subjectLang = bc'}) <$> inj bc++subjectContentL :: Lens MessageSubject Text+subjectContentL inj m@MessageSubject{subjectContent = bc} =+    (\bc' -> m{subjectContent = bc'}) <$> inj bc++imThreadL :: Lens InstantMessage (Maybe MessageThread)+imThreadL inj m@InstantMessage{imThread = bc} =+    (\bc' -> m{imThread = bc'}) <$> inj bc++imSubjectL :: Lens InstantMessage [MessageSubject]+imSubjectL inj m@InstantMessage{imSubject = bc} =+    (\bc' -> m{imSubject = bc'}) <$> inj bc++imBodyL :: Lens InstantMessage [MessageBody]+imBodyL inj m@InstantMessage{imBody = bc} =+    (\bc' -> m{imBody = bc'}) <$> inj bc++-- IM Presence+------------------++showStatusL :: Lens IMPresence (Maybe ShowStatus)+showStatusL inj m@IMP{showStatus = bc} =+    (\bc' -> m{showStatus = bc'}) <$> inj bc++statusL :: Lens IMPresence (Maybe Text)+statusL inj m@IMP{status = bc} =+    (\bc' -> m{status = bc'}) <$> inj bc++priorityL :: Lens IMPresence (Maybe Int)+priorityL inj m@IMP{priority = bc} =+    (\bc' -> m{priority = bc'}) <$> inj bc++-- StreamFeatures+-------------------++featureTlsL :: Lens StreamFeatures (Maybe Bool)+featureTlsL = mkLens streamFeaturesTls (\x sf -> sf{streamFeaturesTls = x})++featureMechanismsL :: Lens StreamFeatures [Text]+featureMechanismsL =+    mkLens streamFeaturesMechanisms (\x sf -> sf{streamFeaturesMechanisms = x})++featureRosterVerL :: Lens StreamFeatures (Maybe Bool)+featureRosterVerL =+    mkLens streamFeaturesRosterVer (\x sf -> sf{streamFeaturesRosterVer = x})++featurePreApprovalL :: Lens StreamFeatures Bool+featurePreApprovalL =+    mkLens streamFeaturesPreApproval (\x sf -> sf{streamFeaturesPreApproval = x})++featuresOtherL :: Lens StreamFeatures [Element]+featuresOtherL =+    mkLens streamFeaturesOther (\x sf -> sf{streamFeaturesOther = x})
+ source/Network/Xmpp/Marshal.hs view
@@ -0,0 +1,536 @@+-- Picklers and unpicklers convert Haskell data to XML and XML to Haskell data,+-- respectively. By convention, pickler/unpickler ("PU") function names start+-- with "xp".++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++{-# OPTIONS_HADDOCK hide #-}++module Network.Xmpp.Marshal where++import           Data.XML.Pickle+import           Data.XML.Types++import qualified Control.Exception as Ex+import           Data.Text (Text)+import qualified Data.Text as Text++import           Network.Xmpp.Types++xpNonemptyText :: PU Text NonemptyText+xpNonemptyText = ("xpNonemptyText" , "") <?+> xpWrap Nonempty fromNonempty xpText++xpStreamElement :: PU [Node] (Either StreamErrorInfo XmppElement)+xpStreamElement = xpEither xpStreamError $ xpAlt elemSel+    [ xpWrap XmppStanza     (\(XmppStanza     x) -> x) xpStanza+    , xpWrap XmppNonza      (\(XmppNonza      x) -> x) xpElemVerbatim+    ]+  where+    -- Selector for which pickler to execute above.+    elemSel :: XmppElement -> Int+    elemSel (XmppStanza     _) = 0+    elemSel (XmppNonza      _) = 1++xpStreamStanza :: PU [Node] (Either StreamErrorInfo Stanza)+xpStreamStanza = xpEither xpStreamError xpStanza++xpExtendedAttrs :: PU [Attribute] [ExtendedAttribute]+xpExtendedAttrs = ("xpAttrVerbatim" , "") <?+>+                    xpIso (map (\(name, cs) -> (name, flattenContents cs)))+                          (map (\(name, c) -> (name, [ContentText c])))+  where+    flattenContents = Text.concat . filterContentText+    filterContentText = map (\c -> case c of+        ContentText t -> t+        ContentEntity{} -> Ex.throw UnresolvedEntityException )++xpStanza :: PU [Node] Stanza+xpStanza = ("xpStanza" , "") <?+> xpAlt stanzaSel+    [ xpWrap IQRequestS     (\(IQRequestS     x) -> x) xpIQRequest+    , xpWrap IQResultS      (\(IQResultS      x) -> x) xpIQResult+    , xpWrap IQErrorS       (\(IQErrorS       x) -> x) xpIQError+    , xpWrap MessageErrorS  (\(MessageErrorS  x) -> x) xpMessageError+    , 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.+    stanzaSel :: Stanza -> Int+    stanzaSel (IQRequestS     _) = 0+    stanzaSel (IQResultS      _) = 1+    stanzaSel (IQErrorS       _) = 2+    stanzaSel (MessageErrorS  _) = 3+    stanzaSel (MessageS       _) = 4+    stanzaSel (PresenceErrorS _) = 5+    stanzaSel (PresenceS      _) = 6++xpMessage :: PU [Node] (Message)+xpMessage = ("xpMessage" , "") <?+> xpWrap+    (\((tp, qid, from, to, lang, attrs), ext) -> Message qid from to lang tp ext attrs)+    (\(Message qid from to lang tp ext attrs) -> ((tp, qid, from, to, lang, attrs), ext))+    (xpElem "{jabber:client}message"+         (xp6Tuple+             (xpDefault Normal $ xpAttr "type" xpMessageType)+             (xpAttrImplied "id"   xpId)+             (xpAttrImplied "from" xpJid)+             (xpAttrImplied "to"   xpJid)+             xpLangTag+             xpExtendedAttrs+             -- TODO: NS?+         )+         (xpAll xpElemVerbatim)+    )++xpPresence :: PU [Node] Presence+xpPresence = ("xpPresence" , "") <?+> xpWrap+    (\((qid, from, to, lang, tp, attr), ext)+        -> Presence qid from to lang tp ext attr)+    (\(Presence qid from to lang tp ext attr)+       -> ((qid, from, to, lang, tp, attr), ext))+    (xpElem "{jabber:client}presence"+         (xp6Tuple+              (xpAttrImplied "id"   xpId)+              (xpAttrImplied "from" xpJid)+              (xpAttrImplied "to"   xpJid)+              xpLangTag+              (xpDefault Available $ xpAttr "type" xpPresenceType)+              xpExtendedAttrs+         )+         (xpAll xpElemVerbatim)+    )++xpIQRequest :: PU [Node] IQRequest+xpIQRequest = ("xpIQRequest" , "") <?+> xpWrap+    (\((qid, from, to, lang, tp, attr),body)+       -> IQRequest qid from to lang tp body attr)+    (\(IQRequest qid from to lang tp body attr)+        -> ((qid, from, to, lang, tp, attr), body))+    (xpElem "{jabber:client}iq"+         (xp6Tuple+             (xpAttr        "id"   xpId)+             (xpAttrImplied "from" xpJid)+             (xpAttrImplied "to"   xpJid)+             xpLangTag+             ((xpAttr        "type" xpIQRequestType))+             xpExtendedAttrs+         )+         xpElemVerbatim+    )++xpIQResult :: PU [Node] IQResult+xpIQResult = ("xpIQResult" , "") <?+> xpWrap+    (\((qid, from, to, lang, _tp, attr),body)+        -> IQResult qid from to lang body attr)+    (\(IQResult qid from to lang body attr)+        -> ((qid, from, to, lang, (), attr ), body))+    (xpElem "{jabber:client}iq"+         (xp6Tuple+             (xpAttr        "id"   xpId)+             (xpAttrImplied "from" xpJid)+             (xpAttrImplied "to"   xpJid)+             xpLangTag+             ((xpAttrFixed "type" "result"))+             xpExtendedAttrs+         )+         (xpOption xpElemVerbatim)+    )++----------------------------------------------------------+-- Errors+----------------------------------------------------------++xpStanzaErrorCondition :: PU [Node] StanzaErrorCondition+xpStanzaErrorCondition = ("xpErrorCondition" , "") <?+> xpWrapEither+                   (\(cond, (),cont) -> case (cond, cont) of+                         (Gone _, x) -> Right $ Gone x+                         (Redirect _, x) -> Right $ Redirect x+                         (x , Nothing) -> Right x+                         _ -> Left+                              ("Only Gone and Redirect may have character data"+                                 :: String)+                              )+                   (\x -> case x of+                         (Gone t) -> (Gone Nothing, (),  t)+                         (Redirect t) -> (Redirect Nothing, () , t)+                         c -> (c, (), Nothing))+    (xpElemByNamespace+        "urn:ietf:params:xml:ns:xmpp-stanzas"+        xpStanzaErrorConditionShape+        xpUnit+        (xpOption $ xpContent xpNonemptyText)+    )+  where+    -- Create the "shape" of the error condition. In case of Gone and Redirect+    -- the optional field is left empty and must be filled in by the caller+    xpStanzaErrorConditionShape :: PU Text StanzaErrorCondition+    xpStanzaErrorConditionShape = ("xpStanzaErrorCondition", "") <?>+            xpIso stanzaErrorConditionFromText+                  stanzaErrorConditionToText+    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 PolicyViolation = "policy-violation"+    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" = BadRequest+    stanzaErrorConditionFromText "conflict" = Conflict+    stanzaErrorConditionFromText "feature-not-implemented" = FeatureNotImplemented+    stanzaErrorConditionFromText "forbidden" = Forbidden+    stanzaErrorConditionFromText "gone" = Gone Nothing+    stanzaErrorConditionFromText "internal-server-error" = InternalServerError+    stanzaErrorConditionFromText "item-not-found" = ItemNotFound+    stanzaErrorConditionFromText "jid-malformed" = JidMalformed+    stanzaErrorConditionFromText "not-acceptable" = NotAcceptable+    stanzaErrorConditionFromText "not-allowed" = NotAllowed+    stanzaErrorConditionFromText "not-authorized" = NotAuthorized+    stanzaErrorConditionFromText "policy-violation" = PolicyViolation+    stanzaErrorConditionFromText "recipient-unavailable" = RecipientUnavailable+    stanzaErrorConditionFromText "redirect" = Redirect Nothing+    stanzaErrorConditionFromText "registration-required" = RegistrationRequired+    stanzaErrorConditionFromText "remote-server-not-found" = RemoteServerNotFound+    stanzaErrorConditionFromText "remote-server-timeout" = RemoteServerTimeout+    stanzaErrorConditionFromText "resource-constraint" = ResourceConstraint+    stanzaErrorConditionFromText "service-unavailable" = ServiceUnavailable+    stanzaErrorConditionFromText "subscription-required" = SubscriptionRequired+    stanzaErrorConditionFromText "undefined-condition" = UndefinedCondition+    stanzaErrorConditionFromText "unexpected-request" = UnexpectedRequest+    stanzaErrorConditionFromText _ = UndefinedCondition++++xpStanzaError :: PU [Node] StanzaError+xpStanzaError = ("xpStanzaError" , "") <?+> xpWrap+    (\((tp, _code), (cond, txt, ext)) -> StanzaError tp cond txt ext)+    (\(StanzaError tp cond txt ext) -> ((tp, Nothing), (cond, txt, ext)))+    (xpElem "{jabber:client}error"+         (xp2Tuple+             (xpAttr "type" xpStanzaErrorType)+             (xpAttribute' "code" xpId))+         (xp3Tuple+              xpStanzaErrorCondition+              (xpOption $ xpElem "{urn:ietf:params:xml:ns:xmpp-stanzas}text"+                   (xpAttrImplied xmlLang xpLang)+                   (xpContent xpNonemptyText)+              )+              (xpOption xpElemVerbatim)+         )+    )++xpMessageError :: PU [Node] (MessageError)+xpMessageError = ("xpMessageError" , "") <?+> xpWrap+    (\((_, qid, from, to, lang, attr), (err, ext)) ->+        MessageError qid from to lang err ext attr)+    (\(MessageError qid from to lang err ext attr) ->+        (((), qid, from, to, lang, attr), (err, ext)))+    (xpElem "{jabber:client}message"+         (xp6Tuple+              (xpAttrFixed   "type" "error")+              (xpAttrImplied "id"   xpId)+              (xpAttrImplied "from" xpJid)+              (xpAttrImplied "to"   xpJid)+              (xpAttrImplied xmlLang xpLang)+              xpExtendedAttrs+         )+         (xp2Tuple xpStanzaError (xpAll xpElemVerbatim))+    )++xpPresenceError :: PU [Node] PresenceError+xpPresenceError = ("xpPresenceError" , "") <?+> xpWrap+    (\((qid, from, to, lang, _, attr),(err, ext)) ->+        PresenceError qid from to lang err ext attr)+    (\(PresenceError qid from to lang err ext attr) ->+        ((qid, from, to, lang, (), attr), (err, ext)))+    (xpElem "{jabber:client}presence"+         (xp6Tuple+              (xpAttrImplied "id"   xpId)+              (xpAttrImplied "from" xpJid)+              (xpAttrImplied "to"   xpJid)+              xpLangTag+              (xpAttrFixed "type" "error")+              xpExtendedAttrs+         )+         (xp2Tuple xpStanzaError (xpAll xpElemVerbatim))+    )++xpIQError :: PU [Node] IQError+xpIQError = ("xpIQError" , "") <?+> xpWrap+    (\((qid, from, to, lang, _tp, attr),(err, body)) ->+        IQError qid from to lang err body attr)+    (\(IQError qid from to lang err body attr) ->+        ((qid, from, to, lang, (), attr), (err, body)))+    (xpElem "{jabber:client}iq"+         (xp6Tuple+              (xpAttr        "id"   xpId)+              (xpAttrImplied "from" xpJid)+              (xpAttrImplied "to"   xpJid)+              xpLangTag+              ((xpAttrFixed "type" "error"))+              xpExtendedAttrs+         )+         (xp2Tuple xpStanzaError (xpOption xpElemVerbatim))+    )++xpStreamError :: PU [Node] StreamErrorInfo+xpStreamError = ("xpStreamError" , "") <?+> xpWrap+    (\((cond,() ,()), txt, el) -> StreamErrorInfo cond txt el)+    (\(StreamErrorInfo cond txt el) ->((cond,() ,()), txt, el))+    (xpElemNodes+         (Name+              "error"+              (Just "http://etherx.jabber.org/streams")+              (Just "stream")+         )+         (xp3Tuple+              (xpElemByNamespace+                   "urn:ietf:params:xml:ns:xmpp-streams"+                   xpStreamErrorCondition+                   xpUnit+                   xpUnit+              )+              (xpOption $ xpElem+                   "{urn:ietf:params:xml:ns:xmpp-streams}text"+                   xpLangTag+                   (xpContent xpNonemptyText)+              )+              (xpOption xpElemVerbatim) -- Application specific error conditions+         )+    )++xpLangTag :: PU [Attribute] (Maybe LangTag)+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")++-- Given a pickler and an object, produces an Element.+pickleElem :: PU [Node] a -> a -> Element+pickleElem p = pickle $ xpNodeElem p++-- Given a pickler and an element, produces an object.+unpickleElem :: PU [Node] a -> Element -> Either UnpickleError a+unpickleElem p x = unpickle (xpNodeElem p) x++xpNodeElem :: PU [Node] a -> PU Element a+xpNodeElem = xpRoot . xpUnliftElems++mbl :: Maybe [a] -> [a]+mbl (Just l) = l+mbl Nothing = []++lmb :: [t] -> Maybe [t]+lmb [] = Nothing+lmb x = Just x++xpStream :: PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)+xpStream = xpElemAttrs+    (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream"))+    (xp5Tuple+         (xpAttr "version" xpId)+         (xpAttrImplied "from" xpJid)+         (xpAttrImplied "to" xpJid)+         (xpAttrImplied "id" xpId)+         xpLangTag+    )++-- Pickler/Unpickler for the stream features - TLS, SASL, and the rest.+xpStreamFeatures :: PU [Node] StreamFeatures+xpStreamFeatures = ("xpStreamFeatures","") <?> xpWrap+    (\(tls, sasl, ver, preAppr, session, rest)+       -> StreamFeatures tls (mbl sasl) ver preAppr session rest )+    (\(StreamFeatures tls sasl ver preAppr session rest)+     -> (tls, lmb sasl, ver, preAppr, session, rest))+    (xpElemNodes+         (Name+             "features"+             (Just "http://etherx.jabber.org/streams")+             (Just "stream")+         )+         (xp6Tuple+              (xpOption pickleTlsFeature)+              (xpOption pickleSaslFeature)+              (xpOption pickleRosterVer)+              picklePreApproval+              (xpOption pickleSessionFeature)+              (xpAll xpElemVerbatim)+         )+    )+  where+    pickleTlsFeature :: PU [Node] Bool+    pickleTlsFeature = ("pickleTlsFeature", "") <?>+        xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls"+        (xpElemExists "{urn:ietf:params:xml:ns:xmpp-tls}required")+    pickleSaslFeature :: PU [Node] [Text]+    pickleSaslFeature = ("pickleSaslFeature", "") <?>+        xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms"+        (xpAll $ xpElemNodes+             "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId))+    pickleRosterVer = xpElemNodes "{urn:xmpp:features:rosterver}ver" $+                           xpElemExists "{urn:xmpp:features:rosterver}optional"+    picklePreApproval = xpElemExists "{urn:xmpp:features:pre-approval}sub"+    pickleSessionFeature :: PU [Node] Bool+    pickleSessionFeature = ("pickleSessionFeature", "") <?>+        xpElemNodes "{urn:ietf:params:xml:ns:xmpp-session}session"+        (xpElemExists "{urn:ietf:params:xml:ns:xmpp-session}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", "") <?>+        xpIso messageTypeFromText+              messageTypeToText+  where+    messageTypeFromText "chat" = Chat+    messageTypeFromText "groupchat" = GroupChat+    messageTypeFromText "headline" = Headline+    messageTypeFromText "normal" = Normal+    messageTypeFromText _ = 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"+++xpStreamErrorCondition :: PU Text StreamErrorCondition+xpStreamErrorCondition = ("xpStreamErrorCondition", "") <?>+        xpIso streamErrorConditionFromText+              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" = StreamBadFormat+    streamErrorConditionFromText "bad-namespace-prefix" = StreamBadNamespacePrefix+    streamErrorConditionFromText "conflict" = StreamConflict+    streamErrorConditionFromText "connection-timeout" = StreamConnectionTimeout+    streamErrorConditionFromText "host-gone" = StreamHostGone+    streamErrorConditionFromText "host-unknown" = StreamHostUnknown+    streamErrorConditionFromText "improper-addressing" = StreamImproperAddressing+    streamErrorConditionFromText "internal-server-error" = StreamInternalServerError+    streamErrorConditionFromText "invalid-from" = StreamInvalidFrom+    streamErrorConditionFromText "invalid-namespace" = StreamInvalidNamespace+    streamErrorConditionFromText "invalid-xml" = StreamInvalidXml+    streamErrorConditionFromText "not-authorized" = StreamNotAuthorized+    streamErrorConditionFromText "not-well-formed" = StreamNotWellFormed+    streamErrorConditionFromText "policy-violation" = StreamPolicyViolation+    streamErrorConditionFromText "remote-connection-failed" = StreamRemoteConnectionFailed+    streamErrorConditionFromText "reset" = StreamReset+    streamErrorConditionFromText "resource-constraint" = StreamResourceConstraint+    streamErrorConditionFromText "restricted-xml" = StreamRestrictedXml+    streamErrorConditionFromText "see-other-host" = StreamSeeOtherHost+    streamErrorConditionFromText "system-shutdown" = StreamSystemShutdown+    streamErrorConditionFromText "undefined-condition" = StreamUndefinedCondition+    streamErrorConditionFromText "unsupported-encoding" = StreamUnsupportedEncoding+    streamErrorConditionFromText "unsupported-feature" = StreamUnsupportedFeature+    streamErrorConditionFromText "unsupported-stanza-type" = StreamUnsupportedStanzaType+    streamErrorConditionFromText "unsupported-version" = StreamUnsupportedVersion+    streamErrorConditionFromText _ = StreamUndefinedCondition -- §4.9.2
+ source/Network/Xmpp/Sasl.hs view
@@ -0,0 +1,155 @@+{-# 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'+-- functionality.++module Network.Xmpp.Sasl+    ( xmppSasl+    , digestMd5+    , scramSha1+    , plain+    , auth+    ) where++import           Control.Monad.Except+import           Control.Monad.State.Strict+import           Data.Text (Text)+import           Data.XML.Pickle+import           Data.XML.Types+import           Network.Xmpp.Marshal+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+-- success. Returns `Nothing' on success, an `AuthFailure' if+-- authentication fails, or an `XmppFailure' if anything else fails.+xmppSasl :: [SaslHandler] -- ^ Acceptable authentication mechanisms and their+                       -- corresponding handlers+         -> Stream+         -> IO (Either XmppFailure (Maybe AuthFailure))+xmppSasl handlers stream = do+    debugM "Pontarius.Xmpp" "xmppSasl: Attempts to authenticate..."+    flip withStream stream $ do+        -- Chooses the first mechanism that is acceptable by both the client and the+        -- server.+        mechanisms <- gets $ streamFeaturesMechanisms . streamFeatures+        case (filter (\(name, _) -> name `elem` mechanisms)) handlers of+            [] -> return $ Right $ Just $ AuthNoAcceptableMechanism mechanisms+            (_name, handler):_ -> do+                cs <- gets streamConnectionState+                case cs of+                    Closed -> do+                        lift $ errorM "Pontarius.Xmpp" "xmppSasl: Stream state closed."+                        return . Left $ XmppNoStream+                    _ -> runExceptT $ do+                           -- TODO: Log details about handler? SaslHandler "show" instance?+                           lift $ lift $ debugM "Pontarius.Xmpp" "xmppSasl: Performing handler..."+                           r <- ExceptT handler+                           case r of+                               Just ae -> do+                                   lift $ lift $ errorM "Pontarius.Xmpp" $+                                       "xmppSasl: AuthFailure encountered: " +++                                           show ae+                                   return $ Just ae+                               Nothing -> do+                                   lift $ lift $ debugM "Pontarius.Xmpp" "xmppSasl: Authentication successful, restarting stream."+                                   _ <- ExceptT restartStream+                                   lift $ lift $ debugM "Pontarius.Xmpp" "xmppSasl: Stream restarted."+                                   return Nothing++-- | Authenticate to the server using the first matching method and bind a+-- resource.+auth :: [SaslHandler]+     -> Maybe Text+     -> Stream+     -> IO (Either XmppFailure (Maybe AuthFailure))+auth mechanisms resource con = runExceptT $ do+    mbAuthFail <- ExceptT $ xmppSasl mechanisms con+    case mbAuthFail of+        Nothing -> do+            _jid <- ExceptT $ xmppBind resource con+            ExceptT $ flip withStream' con $ do+                s <- get++                case sendStreamElement s of+                    False -> return $ Right Nothing+                    True -> do+                        _ <- liftIO $ startSession con+                        return $ Right Nothing+        f -> return f+  where+    sendStreamElement s =+        and [ -- Check that the stream feature is set and not optional+              streamFeaturesSession (streamFeatures s) == Just False+            ]+++-- Produces a `bind' element, optionally wrapping a resource.+bindBody :: Maybe Text -> Element+bindBody = pickleElem $+               -- Pickler to produce a+               -- "<bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'/>"+               -- element, with a possible "<resource>[JID]</resource>"+               -- child.+               xpBind . xpOption $ xpElemNodes "{urn:ietf:params:xml:ns:xmpp-bind}resource" (xpContent xpId)++-- Sends a (synchronous) IQ set request for a (`Just') given or server-generated+-- resource and extract the JID from the non-error response.+xmppBind  :: Maybe Text -> Stream -> IO (Either XmppFailure Jid)+xmppBind rsrc c = runExceptT $ do+    lift $ debugM "Pontarius.Xmpp" "Attempts to bind..."+    answer <- ExceptT $ 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 j = unpickleElem xpJid' b+            case j of+                Right jid' -> do+                    lift $ infoM "Pontarius.Xmpp" $ "Bound JID: " ++ show jid'+                    _ <- lift $ withStream ( do modify $ \s ->+                                                    s{streamJid = Just jid'})+                                           c+                    return jid'+                _ -> do+                    lift $ errorM "Pontarius.Xmpp"+                        $ "xmppBind: JID could not be unpickled from: "+                          ++ show b+                    throwError $ XmppOtherFailure+        _ -> 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 xpJid)+    jidName = "{urn:ietf:params:xml:ns:xmpp-bind}jid"++-- A `bind' element pickler.+xpBind  :: PU [Node] b -> PU [Node] b+xpBind c = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-bind}bind" c++sessionXml :: Element+sessionXml = pickleElem+    (xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session")+    ()++-- Sends the session IQ set element and waits for an answer. Throws an error if+-- if an IQ error stanza is returned from the server.+startSession :: Stream -> IO Bool+startSession con = do+    debugM "Pontarius.XMPP" "startSession: Pushing `session' IQ set stanza..."+    answer <- pushIQ "session" Nothing Set Nothing sessionXml con+    case answer of+        Left e -> do+            errorM "Pontarius.XMPP" $ "startSession: Error stanza received (" ++ (show e) ++ ")"+            return False+        Right _ -> do+            debugM "Pontarius.XMPP" "startSession: Result stanza received."+            return True
+ source/Network/Xmpp/Sasl/Common.hs view
@@ -0,0 +1,238 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}++module Network.Xmpp.Sasl.Common where++import           Control.Applicative ((<$>))+import           Control.Monad+import           Control.Monad.Except+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 (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.Marshal+import           Network.Xmpp.Sasl.StringPrep+import           Network.Xmpp.Sasl.Types+import           Network.Xmpp.Stream+import           Network.Xmpp.Types++import qualified System.Random as Random++import           Control.Monad.State.Strict++--makeNonce :: ExceptT AuthFailure (StateT StreamState IO) BS.ByteString+makeNonce :: IO BS.ByteString+makeNonce = do+    g <- liftIO Random.newStdGen+    return $ B64.encode . BS.pack . map toWord8 . take 15 $ Random.randoms g+  where+    toWord8 :: Int -> Word8+    toWord8 x = fromIntegral x :: Word8++-- The <auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/> element, with an+-- optional round-trip value.+saslInitE :: Text.Text -> Maybe Text.Text -> Element+saslInitE mechanism rt =+    Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth"+        [("mechanism", [ContentText mechanism])]+        (maybeToList $ NodeContent . ContentText <$> rt)++-- SASL response with text payload.+saslResponseE :: Maybe Text.Text -> Element+saslResponseE resp =+    Element "{urn:ietf:params:xml:ns:xmpp-sasl}response"+    []+    (maybeToList $ NodeContent . ContentText <$> resp)++-- The <success xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/> element.+xpSuccess :: PU [Node] (Maybe Text.Text)+xpSuccess = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}success"+    (xpOption $ xpContent xpId)++-- Parses the incoming SASL data to a mapped list of pairs.+pairs :: BS.ByteString -> Either String Pairs+pairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do+    AP.skipSpace+    name <- AP.takeWhile1 (/= '=')+    _ <- AP.char '='+    qt <- ((AP.char '"' >> return True) `mplus` return False)+    content <- AP.takeWhile1 (AP.notInClass [',', '"'])+    when qt . void $ AP.char '"'+    return (name, content)++-- Failure element pickler.+xpFailure :: PU [Node] SaslFailure+xpFailure = xpWrap+    (\(txt, (failure, _, _)) -> SaslFailure failure txt)+    (\(SaslFailure failure txt) -> (txt,(failure,(),())))+    (xpElemNodes+        "{urn:ietf:params:xml:ns:xmpp-sasl}failure"+        (xp2Tuple+             (xpOption $ xpElem+                  "{urn:ietf:params:xml:ns:xmpp-sasl}text"+                  xpLangTag+                  (xpContent xpId))+        (xpElemByNamespace+             "urn:ietf:params:xml:ns:xmpp-sasl"+             xpSaslError+             (xpUnit)+             (xpUnit))))++xpSaslError :: PU Text.Text SaslError+xpSaslError = ("xpSaslError", "") <?>+        xpIso saslErrorFromText 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" = SaslAborted+    saslErrorFromText "account-disabled" = SaslAccountDisabled+    saslErrorFromText "credentials-expired" = SaslCredentialsExpired+    saslErrorFromText "encryption-required" = SaslEncryptionRequired+    saslErrorFromText "incorrect-encoding" = SaslIncorrectEncoding+    saslErrorFromText "invalid-authzid" = SaslInvalidAuthzid+    saslErrorFromText "invalid-mechanism" = SaslInvalidMechanism+    saslErrorFromText "malformed-request" = SaslMalformedRequest+    saslErrorFromText "mechanism-too-weak" = SaslMechanismTooWeak+    saslErrorFromText "not-authorized" = SaslNotAuthorized+    saslErrorFromText "temporary-auth-failure" = SaslTemporaryAuthFailure+    saslErrorFromText _ = SaslNotAuthorized++-- Challenge element pickler.+xpChallenge :: PU [Node] (Maybe Text.Text)+xpChallenge = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge"+                      (xpOption $ xpContent xpId)++-- | Pickler for SaslElement.+xpSaslElement :: PU [Node] SaslElement+xpSaslElement = xpAlt saslSel+                [ xpWrap SaslSuccess   (\(SaslSuccess x)   -> x) xpSuccess+                , xpWrap SaslChallenge (\(SaslChallenge c) -> c) xpChallenge+                ]+  where+    saslSel (SaslSuccess   _) = 0+    saslSel (SaslChallenge _) = 1++-- | Add quotationmarks around a byte string.+quote :: BS.ByteString -> BS.ByteString+quote x = BS.concat ["\"",x,"\""]++saslInit :: Text.Text -> Maybe BS.ByteString -> ExceptT AuthFailure (StateT StreamState IO) ()+saslInit mechanism payload = do+    r <- lift . pushElement . saslInitE mechanism $+        Text.decodeUtf8 . encodeEmpty . B64.encode <$> payload+    case r of+        Right () -> return ()+        Left e  -> throwError $ AuthStreamFailure e+  where+    -- §6.4.2+    encodeEmpty "" = "="+    encodeEmpty x = x++-- | Pull the next element.+pullSaslElement :: ExceptT AuthFailure (StateT StreamState IO) SaslElement+pullSaslElement = do+    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++-- | Pull the next element, checking that it is a challenge.+pullChallenge :: ExceptT AuthFailure (StateT StreamState IO) (Maybe BS.ByteString)+pullChallenge = do+  e <- pullSaslElement+  case e of+      SaslChallenge Nothing -> return Nothing+      SaslChallenge (Just scb64)+          | Right sc <- B64.decode . Text.encodeUtf8 $ scb64+             -> return $ Just sc+      _ -> throwError AuthOtherFailure -- TODO: Log++-- | Extract value from Just, failing with AuthOtherFailure on Nothing.+saslFromJust :: Maybe a -> ExceptT AuthFailure (StateT StreamState IO) a+saslFromJust Nothing = throwError $ AuthOtherFailure -- TODO: Log+saslFromJust (Just d) = return d++-- | Pull the next element and check that it is success.+pullSuccess :: ExceptT AuthFailure (StateT StreamState IO) (Maybe Text.Text)+pullSuccess = do+    e <- pullSaslElement+    case e of+        SaslSuccess x -> return x+        _ -> throwError $ AuthOtherFailure -- TODO: Log++-- | Pull the next element. When it's success, return it's payload.+-- If it's a challenge, send an empty response and pull success.+pullFinalMessage :: ExceptT AuthFailure (StateT StreamState IO) (Maybe BS.ByteString)+pullFinalMessage = do+    challenge2 <- pullSaslElement+    case challenge2 of+        SaslSuccess   x -> decode x+        SaslChallenge x -> do+            _b <- respond Nothing+            _s <- pullSuccess+            decode x+  where+    decode Nothing  = return Nothing+    decode (Just d) = case B64.decode $ Text.encodeUtf8 d of+        Left _e -> throwError $ AuthOtherFailure -- TODO: Log+        Right x -> return $ Just x++-- | Extract p=q pairs from a challenge.+toPairs :: BS.ByteString -> ExceptT AuthFailure (StateT StreamState IO) Pairs+toPairs ctext = case pairs ctext of+    Left _e -> throwError AuthOtherFailure -- TODO: Log+    Right r -> return r++-- | Send a SASL response element. The content will be base64-encoded.+respond :: Maybe BS.ByteString -> ExceptT 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 () -> return ()++-- | Run the appropriate stringprep profiles on the credentials.+-- May fail with 'AuthStringPrepFailure'+prepCredentials :: Text.Text -> Maybe Text.Text -> Text.Text+                -> ExceptT AuthFailure (StateT StreamState IO) (Text.Text, Maybe Text.Text, Text.Text)+prepCredentials authcid authzid password = case credentials of+    Nothing -> throwError $ AuthIllegalCredentials+    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)++-- | Bit-wise xor of byte strings+xorBS :: BS.ByteString -> BS.ByteString -> BS.ByteString+xorBS x y = BS.pack $ BS.zipWith xor x y++-- | Join byte strings with ","+merge :: [BS.ByteString] -> BS.ByteString+merge = BS.intercalate ","++-- | Infix concatenation of byte strings+(+++) :: BS.ByteString -> BS.ByteString -> BS.ByteString+(+++) = BS.append
+ source/Network/Xmpp/Sasl/Mechanisms.hs view
@@ -0,0 +1,10 @@+{-# OPTIONS_HADDOCK hide #-}+module Network.Xmpp.Sasl.Mechanisms+       ( module Network.Xmpp.Sasl.Mechanisms.DigestMd5+       , scramSha1+       , module Network.Xmpp.Sasl.Mechanisms.Plain+       ) where++import Network.Xmpp.Sasl.Mechanisms.DigestMd5+import Network.Xmpp.Sasl.Mechanisms.Scram+import Network.Xmpp.Sasl.Mechanisms.Plain
+ source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs view
@@ -0,0 +1,122 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Xmpp.Sasl.Mechanisms.DigestMd5+    ( digestMd5+    ) where++import           Control.Monad.Except+import           Control.Monad.State.Strict+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           Data.Text (Text)+import qualified Data.Text.Encoding as Text+import           Network.Xmpp.Sasl.Common+import           Network.Xmpp.Sasl.Types+import           Network.Xmpp.Types++++xmppDigestMd5 ::  Text -- ^ Authentication identity (authzid or username)+               -> Maybe Text -- ^ Authorization identity (authcid)+               -> Text -- ^ Password (authzid)+               -> ExceptT AuthFailure (StateT StreamState IO) ()+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 -> ExceptT AuthFailure (StateT StreamState IO) ()+    xmppDigestMd5' hostname authcid _authzid password = do -- TODO: use authzid?+        -- Push element and receive the challenge.+        _ <- saslInit "DIGEST-MD5" Nothing -- TODO: Check boolean?+        prs <- toPairs =<< saslFromJust =<< pullChallenge+        cnonce <- liftIO $ makeNonce+        _b <- respond . Just $ createResponse hostname prs cnonce+        _challenge2 <- pullFinalMessage+        return ()+      where+        -- Produce the response to the challenge.+        createResponse :: Text+                       -> Pairs+                       -> BS.ByteString -- nonce+                       -> BS.ByteString+        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 hname+            digest     = md5Digest+                uname_+                (lookup "realm" prs)+                passwd_+                digestURI+                nc+                qop+                nonce+                cnonce+            response = BS.intercalate "," . map (BS.intercalate "=") $+                [["username", quote uname_]] +++                    case L.lookup "realm" prs of+                        Just realm -> [["realm" , quote realm ]]+                        Nothing -> [] +++                            [ ["nonce"     , quote nonce    ]+                            , ["cnonce"    , quote cnonce   ]+                            , ["nc"        ,       nc       ]+                            , ["qop"       ,       qop      ]+                            , ["digest-uri", quote digestURI]+                            , ["response"  ,       digest   ]+                            , ["charset"   ,       "utf-8"  ]+                            ]+            in B64.encode response+        hash :: [BS8.ByteString] -> BS8.ByteString+        hash = BS8.pack . show+               . (CC.hash' :: BS.ByteString -> MD5.MD5Digest)+                  . BS.intercalate (":")+        hashRaw :: [BS8.ByteString] -> BS8.ByteString+        hashRaw = toStrict . Binary.encode .+            (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":")+        toStrict :: BL.ByteString -> BS8.ByteString+        toStrict = BS.concat . BL.toChunks+        -- TODO: this only handles MD5-sess+        md5Digest :: BS8.ByteString+                  -> Maybe BS8.ByteString+                  -> BS8.ByteString+                  -> BS8.ByteString+                  -> BS8.ByteString+                  -> BS8.ByteString+                  -> BS8.ByteString+                  -> BS8.ByteString+                  -> BS8.ByteString+        md5Digest uname realm pwd digestURI nc qop nonce cnonce =+          let ha1 = hash [ hashRaw [uname, maybe "" id realm, pwd]+                         , nonce+                         , cnonce+                         ]+              ha2 = hash ["AUTHENTICATE", digestURI]+          in hash [ha1, nonce, nc, cnonce, qop, ha2]++digestMd5 :: Username -- ^ Authentication identity (authcid or username)+          -> Maybe AuthZID -- ^ Authorization identity (authzid)+          -> Password -- ^ Password+          -> SaslHandler+digestMd5 authcid authzid password =+    ( "DIGEST-MD5"+    , do+          r <- runExceptT $ xmppDigestMd5 authcid authzid password+          case r of+              Left (AuthStreamFailure e) -> return $ Left e+              Left e -> return $ Right $ Just e+              Right () -> return $ Right Nothing+    )
+ source/Network/Xmpp/Sasl/Mechanisms/Plain.hs view
@@ -0,0 +1,59 @@+{-# OPTIONS_HADDOCK hide #-}+-- Implementation of the PLAIN Simple Authentication and Security Layer (SASL)+-- Mechanism, http://tools.ietf.org/html/rfc4616.++{-# LANGUAGE OverloadedStrings #-}++module Network.Xmpp.Sasl.Mechanisms.Plain+    ( plain+    ) where++import           Control.Monad.Except+import           Control.Monad.State.Strict+import qualified Data.ByteString as BS+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)+          -> ExceptT AuthFailure (StateT StreamState IO) ()+xmppPlain authcid' authzid' password  = do+    (ac, az, pw) <- prepCredentials authcid' authzid' password+    _ <- saslInit "PLAIN" ( Just $ plainMessage ac az pw)+    _ <- pullSuccess+    return ()+  where+    -- Converts an optional authorization identity, an authentication identity,+    -- and a password to a \NUL-separated PLAIN message.+    plainMessage :: Text.Text -- Authorization identity (authzid)+                 -> 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+                                             ]+      where+        authzid'' = maybe "" Text.encodeUtf8 authzid'++plain :: Username -- ^ authentication ID (username)+      -> Maybe AuthZID -- ^ authorization ID+      -> Password -- ^ password+      -> SaslHandler+plain authcid authzid passwd =+    ( "PLAIN"+    , do+          r <- runExceptT $ xmppPlain authcid authzid passwd+          case r of+              Left (AuthStreamFailure e) -> return $ Left e+              Left e -> return $ Right $ Just e+              Right () -> return $ Right Nothing+    )
+ source/Network/Xmpp/Sasl/Mechanisms/Scram.hs view
@@ -0,0 +1,163 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Xmpp.Sasl.Mechanisms.Scram+  where++import           Control.Applicative ((<$>))+import           Control.Monad+import           Control.Monad.Except+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.Text               as Text+import qualified Data.Text.Encoding      as Text+import           Network.Xmpp.Sasl.Common+import           Network.Xmpp.Sasl.Types+import           Network.Xmpp.Types++-- | A nicer name for undefined, for use as a dummy token to determin+-- the hash function to use+hashToken :: (Crypto.Hash ctx hash) => hash+hashToken = undefined++-- | Salted Challenge Response Authentication Mechanism (SCRAM) SASL+-- mechanism according to RFC 5802.+--+-- This implementation is independent and polymorphic in the used hash function.+scram :: (Crypto.Hash ctx hash)+      => hash            -- ^ Dummy argument to determine the hash to use; you+                         --   can safely pass undefined or a 'hashToken' to it+      -> Text.Text       -- ^ Authentication ID (user name)+      -> Maybe Text.Text -- ^ Authorization ID+      -> Text.Text       -- ^ Password+      -> ExceptT AuthFailure (StateT StreamState IO) ()+scram hToken authcid authzid password = do+    (ac, az, pw) <- prepCredentials authcid authzid password+    scramhelper ac az pw+  where+    scramhelper authcid' authzid' pwd = do+        cnonce <- liftIO makeNonce+        _ <- saslInit "SCRAM-SHA-1" (Just $ cFirstMessage cnonce)+        sFirstMessage <- saslFromJust =<< pullChallenge+        prs <- toPairs sFirstMessage+        (nonce, salt, ic) <- fromPairs prs cnonce+        let (cfm, v) = cFinalMessageAndVerifier nonce salt ic sFirstMessage cnonce+        _ <- respond $ Just cfm+        finalPairs <- toPairs =<< saslFromJust =<< pullFinalMessage+        unless (lookup "v" finalPairs == Just v) $ throwError AuthOtherFailure -- TODO: Log+        return ()+      where+        -- We need to jump through some hoops to get a polymorphic solution+        encode :: Crypto.Hash ctx hash => hash -> hash -> BS.ByteString+        encode _hashtoken = Crypto.encode++        hash :: BS.ByteString -> BS.ByteString+        hash str = encode hToken $ Crypto.hash' str++        hmac :: BS.ByteString -> BS.ByteString -> BS.ByteString+        hmac key str = encode hToken $ Crypto.hmac' (Crypto.MacKey key) str++        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++        cFirstMessageBare :: BS.ByteString -> BS.ByteString+        cFirstMessageBare cnonce = merge [ "n=" +++ Text.encodeUtf8 authcid'+                                         , "r=" +++ cnonce]+        cFirstMessage :: BS.ByteString -> BS.ByteString+        cFirstMessage cnonce = gs2Header +++ cFirstMessageBare cnonce++        fromPairs :: Pairs+                  -> BS.ByteString+                  -> ExceptT AuthFailure (StateT StreamState IO) (BS.ByteString, BS.ByteString, Integer)+        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+                                 -> BS.ByteString+                                 -> Integer+                                 -> BS.ByteString+                                 -> BS.ByteString+                                 -> (BS.ByteString, BS.ByteString)+        cFinalMessageAndVerifier nonce salt ic sfm cnonce+            =  (merge [ cFinalMessageWOProof+                      , "p=" +++ B64.encode clientProof+                      ]+              , B64.encode serverSignature+              )+          where+            cFinalMessageWOProof :: BS.ByteString+            cFinalMessageWOProof = merge [ "c=" +++ B64.encode gs2Header+                                         , "r=" +++ nonce]++            saltedPassword :: BS.ByteString+            saltedPassword       = hi (Text.encodeUtf8 pwd) salt ic++            clientKey :: BS.ByteString+            clientKey            = hmac saltedPassword "Client Key"++            storedKey :: BS.ByteString+            storedKey            = hash clientKey++            authMessage :: BS.ByteString+            authMessage          = merge [ cFirstMessageBare cnonce+                                         , sfm+                                         , cFinalMessageWOProof+                                         ]++            clientSignature :: BS.ByteString+            clientSignature      = hmac storedKey authMessage++            clientProof :: BS.ByteString+            clientProof          = clientKey `xorBS` clientSignature++            serverKey :: BS.ByteString+            serverKey            = hmac saltedPassword "Server Key"++            serverSignature :: BS.ByteString+            serverSignature      = hmac serverKey authMessage++            -- helper+            hi :: BS.ByteString -> BS.ByteString -> Integer -> BS.ByteString+            hi str slt ic' = foldl1' xorBS (genericTake ic' us)+              where+                u1 = hmac str (slt +++ (BS.pack [0,0,0,1]))+                us = iterate (hmac str) u1++scramSha1 :: Username  -- ^ username+          -> Maybe AuthZID -- ^ authorization ID+          -> Password   -- ^ password+          -> SaslHandler+scramSha1 authcid authzid passwd =+    ( "SCRAM-SHA-1"+    , do+          r <- runExceptT $ scram (hashToken :: Crypto.SHA1) authcid authzid passwd+          case r of+              Left (AuthStreamFailure e) -> return $ Left e+              Left e -> return $ Right $ Just e+              Right () -> return $ Right Nothing+    )
+ source/Network/Xmpp/Sasl/StringPrep.hs view
@@ -0,0 +1,37 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.Xmpp.Sasl.StringPrep where++import Text.StringPrep+import qualified Data.Set as Set+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
+ source/Network/Xmpp/Sasl/Types.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS_HADDOCK hide #-}+module Network.Xmpp.Sasl.Types where++import           Control.Monad.State.Strict+import           Data.ByteString(ByteString)+import qualified Data.Text as Text+import           Network.Xmpp.Types++type Username = Text.Text+type Password = Text.Text+type AuthZID  = Text.Text++data SaslElement = SaslSuccess   (Maybe Text.Text)+                 | SaslChallenge (Maybe Text.Text)++type Pairs = [(ByteString, ByteString)]++-- | Tuple defining the SASL Handler's name, and a SASL mechanism computation.+-- The SASL mechanism is a stateful @Stream@ computation, which has the+-- possibility of resulting in an authentication error.+type SaslHandler = (Text.Text, StateT StreamState IO (Either XmppFailure (Maybe AuthFailure)))
+ source/Network/Xmpp/Stanza.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE RecordWildCards #-}++{-# OPTIONS_HADDOCK hide #-}++-- | Stanza related functions and constants+--++module Network.Xmpp.Stanza where++import Data.XML.Types+import Network.Xmpp.Types+import Network.Xmpp.Lens++-- | 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 = Unsubscribe+                                   }++-- | Deny a not-yet approved or terminate a previously approved subscription of+-- an entity+presenceUnsubscribed :: Jid -> Presence+presenceUnsubscribed 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'}++-- | Create a StanzaError with @condition@ and the 'associatedErrorType'. Leave+-- the error text and the application specific condition empty+mkStanzaError :: StanzaErrorCondition -- ^ condition+              -> StanzaError+mkStanzaError condition = StanzaError (associatedErrorType condition)+                                      condition Nothing Nothing++-- | Create an IQ error response to an IQ request using the given condition. The+-- error type is derived from the condition using 'associatedErrorType' and+-- both text and the application specific condition are left empty+iqError :: StanzaErrorCondition -> IQRequest -> IQError+iqError condition (IQRequest iqid from' _to lang' _tp _bd _attr) =+    IQError iqid Nothing from' lang' (mkStanzaError condition) Nothing []+++-- | Create an IQ Result matching an IQ request+iqResult ::  Maybe Element -> IQRequest -> IQResult+iqResult pl iqr = IQResult+              { iqResultID   = iqRequestID iqr+              , iqResultFrom = Nothing+              , iqResultTo   = view from iqr+              , iqResultLangTag = view lang iqr+              , iqResultPayload = pl+              , iqResultAttributes = []+              }++-- | The RECOMMENDED error type associated with an error condition. The+-- following conditions allow for multiple types+--+-- * 'FeatureNotImplemented': 'Cancel' or 'Modify' (returns 'Cancel')+--+-- * 'PolicyViolation': 'Modify' or 'Wait' ('Modify')+--+-- * 'RemoteServerTimeout': 'Wait' or unspecified other ('Wait')+--+-- * 'UndefinedCondition': Any condition ('Cancel')+associatedErrorType :: StanzaErrorCondition -> StanzaErrorType+associatedErrorType BadRequest            = Modify+associatedErrorType Conflict              = Cancel+associatedErrorType FeatureNotImplemented = Cancel -- Or Modify+associatedErrorType Forbidden             = Auth+associatedErrorType Gone{}                = Cancel+associatedErrorType InternalServerError   = Cancel+associatedErrorType ItemNotFound          = Cancel+associatedErrorType JidMalformed          = Modify+associatedErrorType NotAcceptable         = Modify+associatedErrorType NotAllowed            = Cancel+associatedErrorType NotAuthorized         = Auth+associatedErrorType PolicyViolation       = Modify -- Or Wait+associatedErrorType RecipientUnavailable  = Wait+associatedErrorType Redirect{}            = Modify+associatedErrorType RegistrationRequired  = Auth+associatedErrorType RemoteServerNotFound  = Cancel+associatedErrorType RemoteServerTimeout   = Wait -- Possibly Others+associatedErrorType ResourceConstraint    = Wait+associatedErrorType ServiceUnavailable    = Cancel+associatedErrorType SubscriptionRequired  = Auth+associatedErrorType UndefinedCondition    = Cancel -- This can be anything+associatedErrorType UnexpectedRequest     = Modify
+ source/Network/Xmpp/Stream.hs view
@@ -0,0 +1,917 @@+{-# OPTIONS_HADDOCK hide #-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}++module Network.Xmpp.Stream where++import           Control.Applicative ((<$>))+import           Control.Concurrent (forkIO, threadDelay)+import           Control.Concurrent.STM+import qualified Control.Exception as Ex+import qualified Control.Exception.Lifted as ExL+import           Control.Monad+import           Control.Monad.Except+import           Control.Monad.State.Strict+import           Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC8+import           Data.Char (isSpace)+import           Data.Conduit hiding (connect)+import qualified Data.Conduit.Internal as DCI+import qualified Data.Conduit.List as CL+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 qualified Data.Text.Encoding.Error as Text+import           Data.Void (Void)+import           Data.Word (Word16)+import           Data.XML.Pickle+import           Data.XML.Types+import qualified GHC.IO.Exception as GIE+import           Network.Socket hiding (Closed, Stream, connect)+import           Network.DNS hiding (encode, lookup)+import qualified Network.Socket as S+import           Network.Socket (AddrInfo)+import           Network.Xmpp.Marshal+import           Network.Xmpp.Types+import           System.IO+-- 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           Lens.Family2 (over)++import           Network.Xmpp.Utilities+import qualified Network.Xmpp.Lens as L++-- "readMaybe" definition, as readMaybe is not introduced in the `base' package+-- until version 4.6.+readMaybe_ :: (Read a) => String -> Maybe a+readMaybe_ string = case reads string of+                        [(a, "")] -> Just a+                        _ -> Nothing++-- import Text.XML.Stream.Elements++mbl :: Maybe [a] -> [a]+mbl (Just l) = l+mbl Nothing = []++lmb :: [t] -> Maybe [t]+lmb [] = Nothing+lmb x = Just x++-- Unpickles and returns a stream element.+streamUnpickleElem :: PU [Node] a+                   -> Element+                   -> StreamSink a+streamUnpickleElem p x = do+    case unpickleElem p x of+        Left l -> do+            liftIO $ warningM "Pontarius.Xmpp" $ "streamUnpickleElem: Unpickle error: " ++ ppUnpickleError l+            throwError $ XmppOtherFailure+        Right r -> return r++-- This is the conduit sink that handles the stream XML events. We extend it+-- with ExceptT capabilities.+type StreamSink a = ConduitM Event Void (ExceptT XmppFailure IO) a++-- Discards all events before the first EventBeginElement.+throwOutJunk :: Monad m => ConduitM Event a m ()+throwOutJunk = do+    next <- CL.peek+    case next of+        Nothing -> return () -- This will only happen if the stream is closed.+        Just (EventBeginElement _ _) -> return ()+        _ -> CL.drop 1 >> throwOutJunk++-- Returns an (empty) Element from a stream of XML events.+openElementFromEvents :: StreamSink Element+openElementFromEvents = do+    throwOutJunk+    hd <- await+    case hd of+        Just (EventBeginElement name attrs) -> return $ Element name attrs []+        _ -> do+            liftIO $ warningM "Pontarius.Xmpp" "openElementFromEvents: Stream ended."+            throwError XmppOtherFailure++-- Sends the initial stream:stream element and pulls the server features. If the+-- server responds in a way that is invalid, an appropriate stream error will be+-- generated, the connection to the server will be closed, and a XmppFailure+-- will be produced.+startStream :: StateT StreamState IO (Either XmppFailure ())+startStream = runExceptT $ do+    lift $ lift $ debugM "Pontarius.Xmpp" "Starting stream..."+    st <- lift $ get+    -- Set the `from' (which is also the expected to) attribute depending on the+    -- state of the stream.+    let expectedTo = case ( streamConnectionState st+                          , toJid $ streamConfiguration st) of+          (Plain    , (Just (j, True)))  -> Just j+          (Plain    , _               )  -> Nothing+          (Secured  , (Just (j, _   )))  -> Just j+          (Secured  , Nothing         )  -> Nothing+          (Closed   , _               )  -> Nothing+          (Finished , _               )  -> Nothing+    case streamAddress st of+        Nothing -> do+            lift $ lift $ errorM "Pontarius.Xmpp" "Server sent no hostname."+            throwError XmppOtherFailure+        Just address -> do+            ExceptT $ pushXmlDecl+            ExceptT . pushOpenElement . streamNSHack $+                pickleElem xpStream ( "1.0"+                                    , expectedTo+                                    , Just (Jid Nothing (Nonempty address) Nothing)+                                    , Nothing+                                    , preferredLang $ streamConfiguration st+                                    )+    response <- ExceptT $ runEventsSink $ streamS expectedTo+    case response of+      Right (ver, from, to, sid, lt, features)+        | versionFromText ver == Nothing -> closeStreamWithError+                                            StreamUnsupportedVersion Nothing+                                            "Unspecified version"+        | let v = versionFromText ver+          in isJust v && majorVersion (fromJust v) >= 2 ->+            closeStreamWithError StreamUnsupportedVersion Nothing+              "Non-1.x version"+    -- 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 (Nonempty . 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 = sid+                           , streamFrom = from+                         } )+            return ()+      -- Unpickling failed - we investigate the element.+      Left (Element name attrs _children)+        | (nameLocalName name /= "stream") ->+            closeStreamWithError StreamInvalidXml Nothing+               "Root element is not stream"+        | (nameNamespace name /= Just "http://etherx.jabber.org/streams") ->+            closeStreamWithError StreamInvalidNamespace Nothing+               "Wrong root element name space"+        | (isJust $ namePrefix name) && (fromJust (namePrefix name) /= "stream") ->+            closeStreamWithError StreamBadNamespacePrefix Nothing+                "Root name prefix set and not stream"+        | otherwise -> ExceptT $ checkchildren (flattenAttrs attrs)+  where+    -- 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+                          -> ExceptT XmppFailure (StateT StreamState IO) ()+    closeStreamWithError sec el msg = do+        void . lift . pushElement . pickleElem xpStreamError+            $ StreamErrorInfo sec Nothing el+        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 == fmap jidFromText to' ->+                               runExceptT $ closeStreamWithError+                                   StreamBadNamespacePrefix Nothing+                                   "stream to not a valid JID"+                           | Nothing == ver' ->+                               runExceptT $ closeStreamWithError+                                   StreamUnsupportedVersion Nothing+                                   "stream no version"+                           | Just (Nothing :: Maybe LangTag) == (safeRead <$> xl) ->+                               runExceptT $ closeStreamWithError+                                   StreamInvalidXml Nothing+                                   "stream no language tag"+                           | otherwise ->+                               runExceptT $ closeStreamWithError+                                   StreamBadFormat Nothing+                                   ""+    safeRead x = case reads $ Text.unpack x of+        [] -> Nothing+        ((y,_):_) -> Just y++flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)]+flattenAttrs attrs = Prelude.map (\(name, cont) ->+                             ( name+                             , Text.concat $ Prelude.map uncontentify cont)+                             )+                         attrs+  where+    uncontentify (ContentText t) = t+    uncontentify _ = ""++-- Sets a new Event source using the raw source (of bytes)+-- and calls xmppStartStream.+restartStream :: StateT StreamState IO (Either XmppFailure ())+restartStream = do+    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+++-- Creates a conduit from a StreamHandle+sourceStreamHandleRaw :: (MonadIO m, MonadError XmppFailure m)+                      => StreamHandle -> ConduitM i ByteString m ()+sourceStreamHandleRaw s = forever . read $ streamReceive s+  where+    read rd = do+        bs' <- liftIO (rd 4096)+        bs <- case bs' of+            Left e -> throwError e+            Right r -> return r+        yield bs++sourceStreamHandle :: (MonadIO m, MonadError XmppFailure m)+                      => StreamHandle -> ConduitM i ByteString m ()+sourceStreamHandle sh = sourceStreamHandleRaw sh $= logInput++logInput :: MonadIO m => ConduitM ByteString ByteString m ()+logInput = go Nothing+  where+    go mbDec = do+        mbBs <- await+        case mbBs of+         Nothing -> return ()+         Just bs -> do+           let decode = case mbDec of+                         Nothing -> Text.streamDecodeUtf8With Text.lenientDecode+                         Just d -> d+               (Text.Some out leftover cont) = decode bs+               cont' = if BS.null leftover+                       then Nothing+                       else Just cont+           unless (Text.null out) $+               liftIO $ debugM "Pontarius.Xmpp"+                                $ "in: " ++ Text.unpack out+           yield bs+           go cont'++-- 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 :: ConduitT () o (ExceptT XmppFailure IO) ()+          -> IO (ConduitM i o (ExceptT XmppFailure IO) ())+bufferSrc src = do+    ref <- newTMVarIO $ DCI.sealConduitT src+    let go = do+            dt <- liftIO $ Ex.bracketOnError+                      (atomically $ takeTMVar ref)+                      (\_ -> atomically . putTMVar ref $ zeroResumableSource)+                      (\s -> do+                            res <- runExceptT (s $$++ await)+                            case res of+                                Left e -> do+                                    atomically $ putTMVar ref zeroResumableSource+                                    return $ Left e+                                Right (s',b) -> do+                                    atomically $ putTMVar ref s'+                                    return $ Right b+                      )+            case dt of+                Left e -> throwError e+                Right Nothing -> return ()+                Right (Just d) -> yield d >> go+    return go+  where+    zeroResumableSource = DCI.sealConduitT zeroSource++-- 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+-- was encountered at first, or if something other than stream features was+-- encountered second).+-- TODO: from.+streamS :: Maybe Jid -> StreamSink (Either Element ( Text+                                                   , Maybe Jid+                                                   , Maybe Jid+                                                   , Maybe Text+                                                   , Maybe LangTag+                                                   , StreamFeatures ))+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, sid, lTag, features)+      Left el -> return $ Left el+  where+    xmppStreamHeader :: StreamSink (Either Element (Text, Maybe Jid, Maybe Jid, Maybe Text.Text, Maybe LangTag))+    xmppStreamHeader = do+        throwOutJunk+        -- Get the stream:stream element (or whatever it is) from the server,+        -- and validate what we get.+        el <- openElementFromEvents -- May throw `XmppOtherFailure' if an+                                    -- element is not received+        case unpickleElem xpStream el of+            Left _ -> return $ Left el+            Right r -> return $ Right r+    xmppStreamFeatures :: StreamSink StreamFeatures+    xmppStreamFeatures = do+        e <- elements =$ await+        case e of+            Nothing -> do+                lift $ lift $ errorM "Pontarius.Xmpp" "streamS: Stream ended."+                throwError XmppOtherFailure+            Just r -> streamUnpickleElem xpStreamFeatures r++-- | Connects to the XMPP server and opens the XMPP stream against the given+-- realm.+openStream :: HostName -> StreamConfiguration -> IO (Either XmppFailure (Stream))+openStream realm config = runExceptT $ do+    lift $ debugM "Pontarius.Xmpp" "Opening stream..."+    stream' <- createStream realm config+    ExceptT . 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 ()+closeStreams = withStream closeStreams'++closeStreams' :: StateT StreamState IO ()+closeStreams' = do+    lift $ debugM "Pontarius.Xmpp" "Closing stream"+    send <- gets (streamSend . streamHandle)+    cc <- gets (streamClose . streamHandle)+    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+        void ((Ex.try cc) :: IO (Either Ex.SomeException ()))+        return ()+    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 :: MonadIO m =>+                   String+                -> IO a+                -> m (Either XmppFailure a)+wrapIOException tag action = do+    r <- liftIO $ tryIOError action+    case r of+        Right b -> return $ Right b+        Left e -> do+            liftIO $ warningM "Pontarius.Xmpp" $ concat+                [ "wrapIOException ("+                , tag+                , ") : Exception wrapped: "+                , show e+                ]+            return $ Left $ XmppIOException e++pushElement :: Element -> StateT StreamState IO (Either XmppFailure ())+pushElement x = do+    send <- gets (streamSend . streamHandle)+    let outData = renderElement $ nsHack x+    debugOut outData+    lift $ send outData++-- 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 ())+pushStanza s = withStream' . pushElement $ pickleElem xpStanza s++-- XML documents and XMPP streams SHOULD be preceeded by an XML declaration.+-- UTF-8 is the only supported XMPP encoding. The standalone document+-- declaration (matching "SDDecl" in the XML standard) MUST NOT be included in+-- XMPP streams. RFC 6120 defines XMPP only in terms of XML 1.0.+pushXmlDecl :: StateT StreamState IO (Either XmppFailure ())+pushXmlDecl = do+    con <- gets streamHandle+    lift $ streamSend con "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"++pushOpenElement :: Element -> StateT StreamState IO (Either XmppFailure ())+pushOpenElement e = do+    send <- gets (streamSend . streamHandle)+    let outData = renderOpenElement e+    debugOut outData+    lift $ send outData++-- `Connect-and-resumes' the given sink to the stream source, and pulls a+-- `b' value.+runEventsSink :: ConduitT Event Void (ExceptT XmppFailure IO) b+              -> StateT StreamState IO (Either XmppFailure b)+runEventsSink snk = do -- TODO: Wrap exceptions?+    src <- gets streamEventSource+    lift . runExceptT $ src $$ snk++pullElement :: StateT StreamState IO (Either XmppFailure Element)+pullElement = do+    e <- runEventsSink (elements =$ await)+    case e of+        Left l -> do+            liftIO .  errorM "Pontarius.Xmpp" $+                  "Error while retrieving XML element: " ++ show l+            return $ Left l++        Right Nothing -> do+            liftIO $ errorM "Pontarius.Xmpp" "pullElement: Stream ended."+            return . Left $ XmppOtherFailure+        Right (Just r) -> return $ Right r++-- Pulls an element and unpickles it.+pullUnpickle :: PU [Node] a -> StateT StreamState IO (Either XmppFailure a)+pullUnpickle p = do+    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)+                    return . Left $ XmppOtherFailure+                Right r -> return $ Right r++-- | Pulls a stanza (or stream error) from the stream.+pullStanza :: Stream -> IO (Either XmppFailure Stanza)+pullStanza = withStream' $ do+    res <- pullUnpickle xpStreamStanza+    case res of+        Left e -> return $ Left e+        Right (Left e) -> return $ Left $ StreamErrorFailure e+        Right (Right r) -> return $ Right r++-- | Pulls a stanza, nonza or stream error from the stream.+pullXmppElement :: Stream -> IO (Either XmppFailure XmppElement)+pullXmppElement = withStream' $ do+    res <- pullUnpickle xpStreamElement+    case res of+        Left e -> return $ Left e+        Right (Left e) -> return $ Left $ StreamErrorFailure e+        Right (Right r) -> return $ Right r++-- Performs the given IO operation, catches any errors and re-throws everything+-- except 'ResourceVanished' and IllegalOperation, which it will return.+catchPush :: IO () -> IO (Either XmppFailure ())+catchPush p = ExL.catch+    (p >> return (Right ()))+    (\e -> case GIE.ioe_type e of+         GIE.ResourceVanished -> return . Left $ XmppIOException e+         GIE.IllegalOperation -> return . Left $ XmppIOException e+         _ -> ExL.throwIO e+    )++zeroHandle :: StreamHandle+zeroHandle = StreamHandle { streamSend = \_ -> return (Left XmppNoStream)+                          , streamReceive = \_ -> do+                                 errorM "Pontarius.Xmpp"+                                        "xmppNoStream: Stream is closed."+                                 return $ Left XmppNoStream+                          , streamFlush = return ()+                          , streamClose = return ()+                          }++-- Stream state used when there is no connection.+xmppNoStream :: StreamState+xmppNoStream = StreamState {+      streamConnectionState = Closed+    , streamHandle = zeroHandle+    , streamEventSource = zeroSource+    , streamFeatures = mempty+    , streamAddress = Nothing+    , streamFrom = Nothing+    , streamId = Nothing+    , streamLang = Nothing+    , streamJid = Nothing+    , streamConfiguration = def+    }++zeroSource :: ConduitT () a (ExceptT XmppFailure IO) ()+zeroSource = do+    liftIO $ debugM "Pontarius.Xmpp" "zeroSource"+    throwError XmppNoStream++handleToStreamHandle :: Handle -> StreamHandle+handleToStreamHandle h = StreamHandle { streamSend = \d ->+                                         wrapIOException "streamSend"+                                           $ BS.hPut h d+                                      , streamReceive = \n ->+                                         wrapIOException "streamReceive"+                                           $ BS.hGetSome h n+                                      , streamFlush = hFlush h+                                      , streamClose = hClose h+                                      }++createStream :: HostName -> StreamConfiguration -> ExceptT XmppFailure IO (Stream)+createStream realm config = do+    result <- connect realm config+    case result of+        Just hand -> ExceptT $ do+            debugM "Pontarius.Xmpp" "Acquired handle."+            debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle."+            eSource <- liftIO . bufferSrc $+                         (sourceStreamHandle hand $= logConduit)+                           $= XP.parseBytes def+            let stream = StreamState+                  { streamConnectionState = Plain+                  , streamHandle = hand+                  , streamEventSource = eSource+                  , streamFeatures = mempty+                  , streamAddress = Just $ Text.pack realm+                  , streamFrom = Nothing+                  , streamId = Nothing+                  , streamLang = Nothing+                  , streamJid = Nothing+                  , streamConfiguration = maybeSetTlsHost realm config+                  }+            stream' <- mkStream stream+            return $ Right stream'+        Nothing -> do+            lift $ debugM "Pontarius.Xmpp" "Did not acquire handle."+            throwError TcpConnectionFailure+  where+    logConduit :: MonadIO m => ConduitT ByteString ByteString m ()+    logConduit = CL.mapM $ \d -> do+        liftIO . debugM "Pontarius.Xmpp" $ "In: " ++ (BSC8.unpack d) +++            "."+        return d+    tlsIdentL = L.tlsParamsL . L.clientServerIdentificationL+    updateHost host ("", _) = (host, "")+    updateHost _ hst = hst+    maybeSetTlsHost host = over tlsIdentL (updateHost host)++-- Connects using the specified method. Returns the Handle acquired, if any.+connect :: HostName -> StreamConfiguration -> ExceptT XmppFailure IO+           (Maybe StreamHandle)+connect realm config = do+    case connectionDetails config of+        UseHost host port -> lift $ do+            debugM "Pontarius.Xmpp" "Connecting to configured address."+            h <- resolveAndConnectTcp 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 -> ExceptT 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 $ resolveAndConnectTcp host 5222+                Just [(".", _)] -> do+                    liftIO $ infoM "Pontarius.Xmpp"+                                "SRV lookup returned \".\"; service not available"+                    throwError TcpConnectionFailure+                Just srvRecords' -> do+                    lift $ debugM "Pontarius.Xmpp"+                        "SRV records found, looking up host."+                    lift $ resolvSrvsAndConnectTcp+                           ( for srvRecords' $+                              \(domain, port) -> ( BSC8.unpack domain+                                                 , fromIntegral port))+        Nothing -> do+                lift $ errorM "Pontarius.Xmpp"+                    "The hostname could not be validated."+                throwError XmppIllegalTcpDetails+  where for = flip fmap++connectHandle :: AddrInfo -> IO Handle+connectHandle addrInfo = do+    s <- S.socket (S.addrFamily addrInfo) S.Stream S.defaultProtocol+    S.connect s (S.addrAddress addrInfo)+    S.socketToHandle s ReadWriteMode++-- Connects to a list of addresses and ports. Surpresses any exceptions from+-- connectTcp.+connectTcp :: [AddrInfo] -> IO (Maybe Handle)+connectTcp [] = return Nothing+connectTcp (addrInfo:remainder) = do+    let addr = (show $ S.addrAddress addrInfo)+    result <- Ex.try $ (do+        debugM "Pontarius.Xmpp" $ "Connecting to " ++ addr+        connectHandle addrInfo) :: IO (Either Ex.IOException Handle)+    case result of+        Right handle -> do+            debugM "Pontarius.Xmpp" $ "Successfully connected to " ++ addr+            return $ Just handle+        Left _ -> do+            debugM "Pontarius.Xmpp" $+                "Connection to " ++ addr ++ " could not be established."+            connectTcp remainder++#if MIN_VERSION_dns(1, 0, 0)+fixDnsResult :: Either e a -> Maybe a+fixDnsResult = either (const Nothing) Just+#else+fixDnsResult :: Maybe a -> Maybe a+fixDnsResult = id+#endif++-- 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.+resolveAndConnectTcp :: HostName -> PortNumber -> IO (Maybe Handle)+resolveAndConnectTcp hostName port = do+    ais <- S.getAddrInfo Nothing (Just hostName) Nothing+    connectTcp $ setPort <$> ais+  where+    setPort ai = ai {S.addrAddress = setAddressPort port (S.addrAddress ai)}+    setAddressPort port (S.SockAddrInet _ addr) = S.SockAddrInet port addr+    setAddressPort port (S.SockAddrInet6 _ flow addr scope) =+        S.SockAddrInet6 port flow addr scope+    setAddressPort _ addr = addr++-- Tries `resolvAndConnectTcp' for every SRV record, stopping if a handle is+-- acquired.+resolvSrvsAndConnectTcp :: [(HostName, PortNumber)] -> IO (Maybe Handle)+resolvSrvsAndConnectTcp [] = return Nothing+resolvSrvsAndConnectTcp ((domain, port):remaining) = do+    result <- resolveAndConnectTcp domain port+    case result of+        Just handle -> return $ Just handle+        Nothing -> resolvSrvsAndConnectTcp remaining+++-- The DNS functions may make error calls. This function catches any such+-- exceptions and rethrows them as IOExceptions.+rethrowErrorCall :: IO a -> IO a+rethrowErrorCall action = do+    result <- Ex.try action+    case result of+        Right result' -> return result'+        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 -> ExceptT XmppFailure IO (Maybe [(Domain, Word16)])+srvLookup realm resolvSeed = ExceptT $ do+    result <- Ex.try $ rethrowErrorCall $ withResolver resolvSeed+              $ \resolver -> do+        srvResult <- lookupSRV resolver $ BSC8.pack $ "_xmpp-client._tcp." ++ (Text.unpack realm) ++ "."+        case fixDnsResult srvResult of+            Just [] -> do+                debugM "Pontarius.Xmpp" "No SRV result returned."+                return Nothing+            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+    case result of+        Right result' -> return $ Right result'+        Left e -> return $ Left $ XmppIOException e+  where+    -- This function orders the SRV result in accordance with RFC+    -- 2782. It sorts the SRV results in order of priority, and then+    -- uses a random process to order the records with the same+    -- priority based on their weight.+    orderSrvResult :: [(Word16, Word16, Word16, Domain)] -> IO [(Word16, Word16, Word16, Domain)]+    orderSrvResult srvResult = do+        -- Order the result set by priority.+        let srvResult' = sortBy (comparing (\(priority, _, _, _) -> priority)) srvResult+        -- Group elements in sublists based on their priority. The+        -- type is `[[(Word16, Word16, Word16, Domain)]]'.+        let srvResult'' = Data.List.groupBy (\(priority, _, _, _) (priority', _, _, _) -> priority == priority') srvResult' :: [[(Word16, Word16, Word16, Domain)]]+        -- For each sublist, put records with a weight of zero first.+        let srvResult''' = Data.List.map (\sublist -> let (a, b) = partition (\(_, weight, _, _) -> weight == 0) sublist in Data.List.concat [a, b]) srvResult''+        -- Order each sublist.+        srvResult'''' <- mapM orderSublist srvResult'''+        -- Concatinated the results.+        return $ Data.List.concat srvResult''''+      where+        orderSublist :: [(Word16, Word16, Word16, Domain)] -> IO [(Word16, Word16, Word16, Domain)]+        orderSublist [] = return []+        orderSublist sublist = do+            -- Compute the running sum, as well as the total sum of+            -- the sublist. Add the running sum to the SRV tuples.+            let (total, sublist') = Data.List.mapAccumL (\total' (priority, weight, port, domain) -> (total' + weight, (priority, weight, port, domain, total' + weight))) 0 sublist+            -- Choose a random number between 0 and the total sum+            -- (inclusive).+            randomNumber <- randomRIO (0, total)+            -- Select the first record with its running sum greater+            -- than or equal to the random number.+            let (beginning, ((priority, weight, port, domain, _):end)) = Data.List.break (\(_, _, _, _, running) -> randomNumber <= running) sublist'+            -- Remove the running total number from the remaining+            -- elements.+            let sublist'' = Data.List.map (\(priority', weight', port', domain', _) -> (priority', weight', port', domain')) (Data.List.concat [beginning, end])+            -- Repeat the ordering procedure on the remaining+            -- elements.+            rest <- orderSublist sublist''+            return $ ((priority, weight, port, domain):rest)++-- | 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 "killStream" cc+    -- (ExL.try cc :: IO (Either ExL.SomeException ()))+    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 :: Text+       -> Maybe Jid+       -> IQRequestType+       -> Maybe LangTag+       -> Element+       -> Stream+       -> IO (Either XmppFailure (Either IQError IQResult))+pushIQ iqID to tp lang body stream = runExceptT $ do+    ExceptT $ pushStanza+        (IQRequestS $ IQRequest iqID Nothing to lang tp body []) stream+    res <- lift $ pullStanza stream+    case res of+        Left e -> throwError e+        Right (IQErrorS e) -> return $ Left e+        Right (IQResultS r) -> do+            unless+                (iqID == iqResultID r) $ liftIO $ do+                    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 r+        _ -> do+                 liftIO $ errorM "Pontarius.Xmpp" $ "pushIQ: Unexpected stanza type."+                 throwError XmppOtherFailure++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)+            yield s+        Nothing -> return ()++elements :: MonadError XmppFailure m => ConduitT Event Element m ()+elements = do+        x <- await+        case x of+            Just (EventBeginElement n as) -> do+                                                 goE n as >>= yield+                                                 elements+            -- 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{} -> throwError StreamEndFailure+            -- This happens when the connection to the server is closed without+            -- the stream being properly terminated+            Just EventEndDocument -> throwError StreamEndFailure+            Just (EventContent (ContentText ct)) | Text.all isSpace ct ->+                elements+            Nothing -> return ()+            _ -> throwError $ XmppInvalidXml $ "not an element: " ++ show x+  where+    many' f =+        go id+      where+        go front = do+            x <- f+            case x of+                Left l -> return $ (l, front [])+                Right r -> go (front . (:) r)+    goE n as = do+        (y, ns) <- many' goN+        if y == Just (EventEndElement n)+            then return $ Element n (map (id >< compressContents) as)+                                    (compressNodes ns)+            else throwError . XmppInvalidXml $ "Missing close tag: " ++ show n+    goN = do+        x <- await+        case x of+            Just (EventBeginElement n as) -> (Right . NodeElement) <$> goE n as+            Just (EventInstruction i) -> return $ Right $ NodeInstruction i+            Just (EventContent c) -> return $ Right $ NodeContent c+            Just (EventComment t) -> return $ Right $ NodeComment t+            Just (EventCDATA t) -> return $ Right $ NodeContent $ ContentText t+            _ -> return $ Left x++    compressNodes :: [Node] -> [Node]+    compressNodes [] = []+    compressNodes [x] = [x]+    compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) =+        compressNodes $ NodeContent (ContentText $ x `Text.append` y) : z+    compressNodes (x:xs) = x : compressNodes xs++    compressContents :: [Content] -> [Content]+    compressContents cs = [ContentText $ Text.concat (map unwrap cs)]+        where unwrap (ContentText t) = t+              unwrap (ContentEntity t) = t++    (><) f g (x, y) = (f x, g y)++withStream :: StateT StreamState IO a -> Stream -> IO a+withStream action (Stream stream) = Ex.bracketOnError+                                         (atomically $ takeTMVar stream )+                                         (atomically . putTMVar stream)+                                         (\s -> do+                                               (r, s') <- runStateT action s+                                               atomically $ putTMVar stream s'+                                               return r+                                         )++-- nonblocking version. Changes to the connection are ignored!+withStream' :: StateT StreamState IO 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)++-- "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)
+ source/Network/Xmpp/Tls.hs view
@@ -0,0 +1,204 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE FlexibleContexts #-}++module Network.Xmpp.Tls where++import                 Control.Applicative ((<$>))+import qualified       Control.Exception.Lifted as Ex+import                 Control.Monad+import                 Control.Monad.Except+import                 Control.Monad.State.Strict+import qualified       Data.ByteString as BS+import qualified       Data.ByteString.Char8 as BSC8+import qualified       Data.ByteString.Lazy as BL+import                 Data.Conduit+import                 Data.IORef+import                 Data.Monoid+import                 Data.XML.Types+import                 Network.DNS.Resolver (ResolvConf)+import                 Network.TLS+import                 Network.Xmpp.Stream+import                 Network.Xmpp.Types+import                 System.Log.Logger (debugM, errorM, infoM)+import                 System.X509++mkBackend :: StreamHandle -> Backend+mkBackend con = Backend { backendSend = \bs -> void (streamSend con bs)+                        , 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+            mbBs <- recv m+            bs <- case mbBs of+                Left e -> Ex.throwIO e+                Right r -> return r+            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" [] []++-- | Checks for TLS support and run starttls procedure if applicable+tls :: Stream -> IO (Either XmppFailure ())+tls con = fmap join -- We can have Left values both from exceptions and the+                    -- error monad. Join unifies them into one error layer+          . wrapExceptions+          . flip withStream con+          . runExceptT $ do+    conf <- gets streamConfiguration+    sState <- gets streamConnectionState+    case sState of+        Plain -> return ()+        Closed -> do+            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.Tls" "The stream is already secured."+            throwError TlsStreamSecured+    features <- lift $ gets streamFeatures+    case (tlsBehaviour conf, streamFeaturesTls features) of+        (RequireTls  , Just _   ) -> startTls+        (RequireTls  , Nothing  ) -> throwError TlsNoServerSupport+        (PreferTls   , Just _   ) -> startTls+        (PreferTls   , Nothing  ) -> skipTls+        (PreferPlain , Just True) -> startTls+        (PreferPlain , _        ) -> skipTls+        (RefuseTls   , Just True) -> throwError XmppOtherFailure+        (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+        ExceptT $ pushElement starttlsE+        answer <- lift $ pullElement+        case answer of+            Left e -> throwError e+            Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] []) ->+                return ()+            Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _) -> do+                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, recv, ctx) <- lift $ tlsinit params (mkBackend hand)+        let newHand = StreamHandle { streamSend = catchPush . psh+                                   , streamReceive = wrapExceptions . 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 => ClientParams -> Backend -> m Context+client params backend = contextNew backend params++tlsinit :: (MonadIO m, MonadIO m1) =>+        ClientParams+     -> Backend+     -> m ( ConduitT () BS.ByteString m1 ()+          , ConduitT BS.ByteString Void m1 ()+          , BS.ByteString -> IO ()+          , Int -> m1 BS.ByteString+          , Context+          )+tlsinit params backend = do+    liftIO $ debugM "Pontarius.Xmpp.Tls" "TLS with debug mode enabled."+    -- gen <- liftIO (cprgCreate <$> createEntropyPool :: IO SystemRNG)+    sysCStore <- liftIO getSystemCertificateStore+    let params' = params{clientShared =+                      (clientShared params){ sharedCAStore =+                          sysCStore <> sharedCAStore (clientShared params)}}+    con <- client params' backend+    handshake con+    let src = forever $ do+            dt <- liftIO $ recvData con+            liftIO $ debugM "Pontarius.Xmpp.Tls" ("In :" ++ BSC8.unpack dt)+            yield dt+    let snk = do+            d <- await+            case d of+                Nothing -> return ()+                Just x -> do+                       sendData con (BL.fromChunks [x])+                       snk+    readWithBuffer <- liftIO $ mkReadBuffer (recvData con)+    return ( src+           , snk+             -- 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 recv = do+    buffer <- newIORef BS.empty+    let read' n = do+            nc <- readIORef buffer+            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+--+-- /NB/ RFC 6120 does not specify this method, but some servers, notably GCS,+-- seem to use it.+connectTls :: ResolvConf -- ^ Resolv conf to use (try 'defaultResolvConf' as a+                         -- default)+           -> ClientParams  -- ^ TLS parameters to use when securing the connection+           -> String     -- ^ Host to use when connecting (will be resolved+                         -- using SRV records)+           -> ExceptT 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+    let params' = params{clientServerIdentification+                   = case clientServerIdentification params of+                       ("", _) -> (host, "")+                       csi -> csi+                       }+    (_raw, _snk, psh, recv, ctx) <- tlsinit params' $ mkBackend hand+    return StreamHandle{ streamSend = catchPush . psh+                       , streamReceive = wrapExceptions . recv+                       , streamFlush = contextFlush ctx+                       , streamClose = bye ctx >> streamClose hand+                       }++wrapExceptions :: IO a -> IO (Either XmppFailure a)+wrapExceptions f = Ex.catches (liftM Right $ f)+                 [ Ex.Handler $ return . Left . XmppIOException+#if !MIN_VERSION_tls(1,8,0)+                 , Ex.Handler $ wrap . XmppTlsError+#endif+                 , Ex.Handler $ wrap . XmppTlsException+                 , Ex.Handler $ return . Left+                 ]+  where+    wrap = return . Left . TlsError
+ source/Network/Xmpp/Types.hs view
@@ -0,0 +1,1311 @@+{-# LANGUAGE CPP #-}++#if WITH_TEMPLATE_HASKELL+{-# LANGUAGE TemplateHaskell #-}+#endif++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK hide #-}++module Network.Xmpp.Types+    ( NonemptyText(..)+    , nonEmpty+    , text+    , IQError(..)+    , IQRequest(..)+    , IQRequestType(..)+    , IQResponse(..)+    , IQResult(..)+    , LangTag (..)+#if WITH_TEMPLATE_HASKELL+    , langTagQ+#endif+    , langTagFromText+    , langTagToText+    , parseLangTag+    , ExtendedAttribute+    , Message(..)+    , message+    , MessageError(..)+    , messageError+    , MessageType(..)+    , Presence(..)+    , presence+    , PresenceError(..)+    , PresenceType(..)+    , SaslError(..)+    , SaslFailure(..)+    , StreamFeatures(..)+    , Stanza(..)+    , XmppElement(..)+    , messageS+    , messageErrorS+    , presenceS+    , StanzaError(..)+    , StanzaErrorCondition(..)+    , StanzaErrorType(..)+    , XmppFailure(..)+    , XmppTlsError(..)+    , StreamErrorCondition(..)+    , Version(..)+    , versionFromText+    , StreamHandle(..)+    , Stream(..)+    , StreamState(..)+    , ConnectionState(..)+    , StreamErrorInfo(..)+    , ConnectionDetails(..)+    , StreamConfiguration(..)+    , xmppDefaultParams+    , xmppDefaultParamsStrong+    , Jid(..)+#if WITH_TEMPLATE_HASKELL+    , jidQ+    , jid+#endif+    , isBare+    , isFull+    , jidFromText+    , jidFromTexts+    , (<~)+    , nodeprepProfile+    , resourceprepProfile+    , jidToText+    , jidToTexts+    , toBare+    , localpart+    , domainpart+    , resourcepart+    , parseJid+    , TlsBehaviour(..)+    , AuthFailure(..)+    ) where++import           Control.Applicative ((<$>), (<|>), many)+import           Control.Concurrent.STM+import           Control.Exception+import           Control.Monad+import           Control.Monad.Except+import qualified Data.Attoparsec.Text as AP+import qualified Data.ByteString as BS+import           Data.Char (isSpace)+import           Data.Conduit+import           Data.Default+import           Data.Semigroup as Sem+import qualified Data.Set as Set+import           Data.String (IsString, fromString)+import           Data.Text (Text)+import qualified Data.Text as Text+import           Data.Typeable(Typeable)+import           Data.XML.Types as XML+import qualified Data.Text.Encoding as Text+import           GHC.Generics+#if WITH_TEMPLATE_HASKELL+import           Language.Haskell.TH+import           Language.Haskell.TH.Quote+import qualified Language.Haskell.TH.Syntax as TH+#endif+import           Network.Socket+import           Network.DNS+import           Network.TLS hiding (Version, HostName)+import           Network.TLS.Extra+import qualified Text.StringPrep as SP+import qualified Text.StringPrep.Profiles as SP+++-- $setup+-- :set -itests+-- >>> :add tests/Tests/Arbitrary.hs+-- >>> import Network.Xmpp.Types+-- >>> import Control.Applicative((<$>))++-- | Type of Texts that contain at least on non-space character+newtype NonemptyText = Nonempty {fromNonempty :: Text}+                       deriving (Show, Read, Eq, Ord)++instance IsString NonemptyText where+    fromString str = case nonEmpty (Text.pack str) of+        Nothing -> error $ "NonemptyText fromString called on empty or " +++                            "all-whitespace string"+        Just r -> r++-- | Check that Text contains at least one non-space character and wrap it+nonEmpty :: Text -> Maybe NonemptyText+nonEmpty txt = if Text.all isSpace txt then Nothing else Just (Nonempty txt)++-- | Same as 'fromNonempty'+text :: NonemptyText -> Text+text (Nonempty txt) = txt++data XmppElement = XmppStanza !Stanza+                 | XmppNonza  !Element+                   deriving (Eq, Show)++-- | The Xmpp communication primitives (Message, Presence and Info/Query) are+-- called stanzas.+data Stanza = IQRequestS     !IQRequest+            | IQResultS      !IQResult+            | IQErrorS       !IQError+            | MessageS       !Message+            | MessageErrorS  !MessageError+            | PresenceS      !Presence+            | PresenceErrorS !PresenceError+              deriving (Eq, Show, Generic)++type ExtendedAttribute = (XML.Name, Text)++-- | 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      :: !Text+                           , iqRequestFrom    :: !(Maybe Jid)+                           , iqRequestTo      :: !(Maybe Jid)+                           , iqRequestLangTag :: !(Maybe LangTag)+                           , iqRequestType    :: !IQRequestType+                           , iqRequestPayload :: !Element+                           , iqRequestAttributes :: ![ExtendedAttribute]+                           } deriving (Eq, Show, Generic)++-- | The type of IQ request that is made.+data IQRequestType = Get | Set deriving (Eq, Ord, Read, Show, Generic)++-- | A "response" Info/Query (IQ) stanza is either an 'IQError', an IQ stanza+-- of  type "result" ('IQResult')+data IQResponse = IQResponseError IQError+                | IQResponseResult IQResult+                deriving (Eq, Show)++-- | The (non-error) answer to an IQ request.+data IQResult = IQResult { iqResultID      :: !Text+                         , iqResultFrom    :: !(Maybe Jid)+                         , iqResultTo      :: !(Maybe Jid)+                         , iqResultLangTag :: !(Maybe LangTag)+                         , iqResultPayload :: !(Maybe Element)+                         , iqResultAttributes :: ![ExtendedAttribute]+                         } deriving (Eq, Show, Generic)++-- | The answer to an IQ request that generated an error.+data IQError = IQError { iqErrorID          :: !Text+                       , iqErrorFrom        :: !(Maybe Jid)+                       , iqErrorTo          :: !(Maybe Jid)+                       , iqErrorLangTag     :: !(Maybe LangTag)+                       , iqErrorStanzaError :: !StanzaError+                       , iqErrorPayload     :: !(Maybe Element) -- should this be []?+                       , iqErrorAttributes  :: ![ExtendedAttribute]+                       } deriving (Eq, Show, Generic)++-- | The message stanza. Used for /push/ type communication.+data Message = Message { messageID      :: !(Maybe Text)+                       , messageFrom    :: !(Maybe Jid)+                       , messageTo      :: !(Maybe Jid)+                       , messageLangTag :: !(Maybe LangTag)+                       , messageType    :: !MessageType+                       , messagePayload :: ![Element]+                       , messageAttributes :: ![ExtendedAttribute]+                       } deriving (Eq, Show, Generic)++-- | An empty message+--+-- @+-- message = Message { messageID      = Nothing+--                   , messageFrom    = Nothing+--                   , messageTo      = Nothing+--                   , messageLangTag = Nothing+--                   , messageType    = Normal+--                   , messagePayload = []+--                   }+-- @+message :: Message+message = Message { messageID      = Nothing+                  , messageFrom    = Nothing+                  , messageTo      = Nothing+                  , messageLangTag = Nothing+                  , messageType    = Normal+                  , messagePayload = []+                  , messageAttributes = []+                  }++-- | Empty message stanza+--+-- @messageS = 'MessageS' 'message'@+messageS :: Stanza+messageS = MessageS message++instance Default Message where+    def = message++-- | An error stanza generated in response to a 'Message'.+data MessageError = MessageError { messageErrorID          :: !(Maybe Text)+                                 , messageErrorFrom        :: !(Maybe Jid)+                                 , messageErrorTo          :: !(Maybe Jid)+                                 , messageErrorLangTag     :: !(Maybe LangTag)+                                 , messageErrorStanzaError :: !StanzaError+                                 , messageErrorPayload     :: ![Element]+                                 , messageErrorAttributes  :: ![ExtendedAttribute]+                                 } deriving (Eq, Show, Generic)++messageError :: MessageError+messageError = MessageError { messageErrorID          = Nothing+                            , messageErrorFrom        = Nothing+                            , messageErrorTo          = Nothing+                            , messageErrorLangTag     = Nothing+                            , messageErrorStanzaError =+                                StanzaError { stanzaErrorType = Cancel+                                            , stanzaErrorCondition =+                                                  ServiceUnavailable+                                            , stanzaErrorText = Nothing+                                            , stanzaErrorApplicationSpecificCondition = Nothing+                                            }+                            , messageErrorPayload     = []+                            , messageErrorAttributes  = []+                            }++instance Default MessageError where+    def = messageError++messageErrorS :: Stanza+messageErrorS = MessageErrorS def++-- | The type of a Message being sent+-- (<http://xmpp.org/rfcs/rfc6121.html#message-syntax-type>)+data MessageType = -- | The message is sent in the context of a one-to-one chat+                   -- session. Typically an interactive client will present a+                   -- message of type /chat/ in an interface that enables+                   -- one-to-one chat between the two parties, including an+                   -- appropriate conversation history.+                   Chat+                   -- | The message is sent in the context of a multi-user chat+                   -- environment (similar to that of @IRC@). Typically a+                   -- receiving client will present a message of type+                   -- /groupchat/ in an interface that enables many-to-many+                   -- chat between the parties, including a roster of parties+                   -- in the chatroom and an appropriate conversation history.+                 | GroupChat+                   -- | The message provides an alert, a notification, or other+                   -- transient information to which no reply is expected+                   -- (e.g., news headlines, sports updates, near-real-time+                   -- market data, or syndicated content). Because no reply to+                   -- the message is expected, typically a receiving client+                   -- will present a message of type /headline/ in an interface+                   -- that appropriately differentiates the message from+                   -- standalone messages, chat messages, and groupchat+                   -- messages (e.g., by not providing the recipient with the+                   -- ability to reply).+                 | Headline+                   -- | The message is a standalone message that is sent outside+                   -- the context of a one-to-one conversation or groupchat, and+                   -- to which it is expected that the recipient will reply.+                   -- Typically a receiving client will present a message of+                   -- type /normal/ in an interface that enables the recipient+                   -- to reply, but without a conversation history.+                   --+                   -- This is the /default/ value.+                 | Normal+                 deriving (Eq, Read, Show, Generic)++-- | The presence stanza. Used for communicating status updates.+data Presence = Presence { presenceID      :: !(Maybe Text)+                         , presenceFrom    :: !(Maybe Jid)+                         , presenceTo      :: !(Maybe Jid)+                         , presenceLangTag :: !(Maybe LangTag)+                         , presenceType    :: !PresenceType+                         , presencePayload :: ![Element]+                         , presenceAttributes :: ![ExtendedAttribute]+                         } deriving (Eq, Show, Generic)++-- | An empty presence.+presence :: Presence+presence = Presence { presenceID       = Nothing+                    , presenceFrom     = Nothing+                    , presenceTo       = Nothing+                    , presenceLangTag  = Nothing+                    , presenceType     = Available+                    , presencePayload  = []+                    , presenceAttributes = []+                    }++-- | Empty presence stanza+presenceS :: Stanza+presenceS = PresenceS presence++instance Default Presence where+    def = presence++-- | An error stanza generated in response to a 'Presence'.+data PresenceError = PresenceError { presenceErrorID          :: !(Maybe Text)+                                   , presenceErrorFrom        :: !(Maybe Jid)+                                   , presenceErrorTo          :: !(Maybe Jid)+                                   , presenceErrorLangTag     :: !(Maybe LangTag)+                                   , presenceErrorStanzaError :: !StanzaError+                                   , presenceErrorPayload     :: ![Element]+                                   , presenceErrorAttributes  :: ![ExtendedAttribute]+                                   } deriving (Eq, Show, Generic)++-- | @PresenceType@ holds Xmpp presence types. The "error" message type is left+-- out as errors are using @PresenceError@.+data PresenceType = Subscribe    | -- ^ Sender wants to subscribe to presence+                    Subscribed   | -- ^ Sender has approved the subscription+                    Unsubscribe  | -- ^ Sender is unsubscribing from presence+                    Unsubscribed | -- ^ Sender has denied or cancelled a+                                   --   subscription+                    Probe        | -- ^ Sender requests current presence;+                                   --   should only be used by servers+                    Available    | -- ^ Sender wants to express availability+                                   --   (no type attribute is defined)+                    Unavailable deriving (Eq, Read, Show, Generic)++-- | All stanzas (IQ, message, presence) can cause errors, which in the Xmpp+-- stream looks like @\<stanza-kind to=\'sender\' type=\'error\'\>@ . These+-- errors are wrapped in the @StanzaError@ type.  TODO: Sender XML is (optional+-- and is) not yet included.+data StanzaError = StanzaError+    { stanzaErrorType                         :: StanzaErrorType+    , stanzaErrorCondition                    :: StanzaErrorCondition+    , stanzaErrorText                         :: Maybe (Maybe LangTag, NonemptyText)+    , stanzaErrorApplicationSpecificCondition :: Maybe Element+    } deriving (Eq, Show, Generic)++-- | @StanzaError@s always have one of these types.+data StanzaErrorType = Cancel   | -- ^ Error is unrecoverable - do not retry+                       Continue | -- ^ Conditition was a warning - proceed+                       Modify   | -- ^ Change the data and retry+                       Auth     | -- ^ Provide credentials and retry+                       Wait       -- ^ Error is temporary - wait and retry+                       deriving (Eq, Read, Show, Generic)++-- | Stanza errors are accommodated with one of the error conditions listed+-- below.+data StanzaErrorCondition = BadRequest            -- ^ Malformed XML.+                          | Conflict              -- ^ Resource or session with+                                                  --   name already exists.+                          | FeatureNotImplemented+                          | Forbidden             -- ^ Insufficient permissions.+                          | Gone (Maybe NonemptyText) -- ^ Entity can no longer+                                                      -- be contacted at this+                                                      -- address.+                          | InternalServerError+                          | ItemNotFound+                          | JidMalformed+                          | NotAcceptable         -- ^ Does not meet policy+                                                  --   criteria.+                          | NotAllowed            -- ^ No entity may perform+                                                  --   this action.+                          | NotAuthorized         -- ^ Must provide proper+                                                  --   credentials.+                          | PolicyViolation       -- ^ The entity has violated+                                                  -- some local service policy+                                                  -- (e.g., a message contains+                                                  -- words that are prohibited+                                                  -- by the service)+                          | RecipientUnavailable  -- ^ Temporarily unavailable.+                          | Redirect (Maybe NonemptyText) -- ^ Redirecting to+                                                          -- other entity,+                                                          -- usually+                                                          -- temporarily.+                          | RegistrationRequired+                          | RemoteServerNotFound+                          | RemoteServerTimeout+                          | ResourceConstraint    -- ^ Entity lacks the+                                                  --   necessary system+                                                  --   resources.+                          | ServiceUnavailable+                          | SubscriptionRequired+                          | UndefinedCondition    -- ^ Application-specific+                                                  --   condition.+                          | UnexpectedRequest     -- ^ Badly timed request.+                            deriving (Eq, Read, Show, Generic)++-- =============================================================================+--  OTHER STUFF+-- =============================================================================++data SaslFailure = SaslFailure { saslFailureCondition :: SaslError+                               , saslFailureText :: Maybe ( Maybe LangTag+                                                          , Text+                                                          )+                               } deriving (Eq, Show, Generic)++data SaslError = SaslAborted              -- ^ Client aborted.+               | SaslAccountDisabled      -- ^ The account has been temporarily+                                          --   disabled.+               | SaslCredentialsExpired   -- ^ The authentication failed because+                                          --   the credentials have expired.+               | SaslEncryptionRequired   -- ^ The mechanism requested cannot be+                                          --   used the confidentiality and+                                          --   integrity of the underlying+                                          --   stream is protected (typically+                                          --   with TLS).+               | SaslIncorrectEncoding    -- ^ The base64 encoding is incorrect.+               | SaslInvalidAuthzid       -- ^ The authzid has an incorrect+                                          --   format or the initiating entity+                                          --   does not have the appropriate+                                          --   permissions to authorize that ID.+               | SaslInvalidMechanism     -- ^ The mechanism is not supported by+                                          --   the receiving entity.+               | SaslMalformedRequest     -- ^ Invalid syntax.+               | SaslMechanismTooWeak     -- ^ The receiving entity policy+                                          --   requires a stronger mechanism.+               | SaslNotAuthorized        -- ^ Invalid credentials provided, or+                                          --   some generic authentication+                                          --   failure has occurred.+               | SaslTemporaryAuthFailure -- ^ There receiving entity reported a+                                          --   temporary error condition; the+                                          --   initiating entity is recommended+                                          --   to try again later.+               deriving (Eq, Read, Show, Generic)++-- The documentation of StreamErrorConditions is copied from+-- http://xmpp.org/rfcs/rfc6120.html#streams-error-conditions+data StreamErrorCondition+    = StreamBadFormat -- ^ The entity has sent XML that cannot be processed.+    | StreamBadNamespacePrefix -- ^ The entity has sent a namespace prefix that+                               -- is unsupported, or has sent no namespace+                               -- prefix on an element that needs such a prefix+    | StreamConflict -- ^ The server either (1) is closing the existing stream+                     -- for this entity because a new stream has been initiated+                     -- that conflicts with the existing stream, or (2) is+                     -- refusing a new stream for this entity because allowing+                     -- the new stream would conflict with an existing stream+                     -- (e.g., because the server allows only a certain number+                     -- of connections from the same IP address or allows only+                     -- one server-to-server stream for a given domain pair as a+                     -- way of helping to ensure in-order processing+    | StreamConnectionTimeout -- ^ One party is closing the stream because it+                              -- has reason to believe that the other party has+                              -- permanently lost the ability to communicate+                              -- over the stream.+    | StreamHostGone -- ^ The value of the 'to' attribute provided in the+                     -- initial stream header corresponds to an FQDN that is no+                     -- longer serviced by the receiving entity+    | StreamHostUnknown -- ^ The value of the 'to' attribute provided in the+                        -- initial stream header does not correspond to an FQDN+                        -- that is serviced by the receiving entity.+    | StreamImproperAddressing -- ^ A stanza sent between two servers lacks a+                               -- 'to' or 'from' attribute, the 'from' or 'to'+                               -- attribute has no value, or the value violates+                               -- the rules for XMPP addresses+    | StreamInternalServerError -- ^ The server has experienced a+                                -- misconfiguration or other internal error that+                                -- prevents it from servicing the stream.+    | StreamInvalidFrom -- ^ The data provided in a 'from' attribute does not+                        -- match an authorized JID or validated domain as+                        -- negotiated (1) between two servers using SASL or+                        -- 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+                             -- 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\").+    | 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+                          -- other outbound data before the stream has been+                          -- authenticated, or otherwise is not authorized to+                          -- perform an action related to stream negotiation;+                          -- the receiving entity MUST NOT process the offending+                          -- data before sending the stream error.+    | StreamNotWellFormed -- ^ The initiating entity has sent XML that violates+                          -- the well-formedness rules of [XML] or [XML‑NAMES].+    | StreamPolicyViolation -- ^ The entity has violated some local service+                            -- policy (e.g., a stanza exceeds a configured size+                            -- limit); the server MAY choose to specify the+                            -- policy in the \<text/\> element or in an+                            -- application-specific condition element.+    | StreamRemoteConnectionFailed -- ^ The server is unable to properly connect+                                   -- to a remote entity that is needed for+                                   -- authentication or authorization (e.g., in+                                   -- certain scenarios related to Server+                                   -- Dialback [XEP‑0220]); this condition is+                                   -- not to be used when the cause of the error+                                   -- is within the administrative domain of the+                                   -- XMPP service provider, in which case the+                                   -- \<internal-server-error /\> condition is+                                   -- more appropriate.+    | StreamReset -- ^ The server is closing the stream because it has new+                  -- (typically security-critical) features to offer, because+                  -- the keys or certificates used to establish a secure context+                  -- for the stream have expired or have been revoked during the+                  -- life of the stream , because the TLS sequence number has+                  -- wrapped, etc. The reset applies to the stream and to any+                  -- security context established for that stream (e.g., via TLS+                  -- and SASL), which means that encryption and authentication+                  -- need to be negotiated again for the new stream (e.g., TLS+                  -- session resumption cannot be used)+    | StreamResourceConstraint -- ^ The server lacks the system resources+                               -- necessary to service the stream.+    | StreamRestrictedXml -- ^ he entity has attempted to send restricted XML+                          -- features such as a comment, processing instruction,+                          -- DTD subset, or XML entity reference+    | StreamSeeOtherHost -- ^ The server will not provide service to the+                         -- initiating entity but is redirecting traffic to+                         -- another host under the administrative control of the+                         -- same service provider.+    | StreamSystemShutdown -- ^ The server is being shut down and all active+                           -- streams are being closed.+    | StreamUndefinedCondition -- ^ The error condition is not one of those+                               -- defined by the other conditions in this list+    | StreamUnsupportedEncoding -- ^ The initiating entity has encoded the+                                -- stream in an encoding that is not supported+                                -- by the server or has otherwise improperly+                                -- encoded the stream (e.g., by violating the+                                -- rules of the [UTF‑8] encoding).+    | StreamUnsupportedFeature -- ^ The receiving entity has advertised a+                               -- mandatory-to-negotiate stream feature that the+                               -- initiating entity does not support, and has+                               -- offered no other mandatory-to-negotiate+                               -- feature alongside the unsupported feature.+    | StreamUnsupportedStanzaType -- ^ The initiating entity has sent a+                                  -- first-level child of the stream that is not+                                  -- supported by the server, either because the+                                  -- receiving entity does not understand the+                                  -- namespace or because the receiving entity+                                  -- does not understand the element name for+                                  -- the applicable namespace (which might be+                                  -- the content namespace declared as the+                                  -- default namespace)+    | StreamUnsupportedVersion -- ^ The 'version' attribute provided by the+                               -- initiating entity in the stream header+                               -- specifies a version of XMPP that is not+                               -- supported by the server.+      deriving (Eq, Read, Show, Generic)++-- | Encapsulates information about an XMPP stream error.+data StreamErrorInfo = StreamErrorInfo+    { errorCondition :: !StreamErrorCondition+    , errorText      :: !(Maybe (Maybe LangTag, NonemptyText))+    , errorXml       :: !(Maybe Element)+    } deriving (Show, Eq, Generic)++data XmppTlsError = XmppTlsError TLSError+                  | XmppTlsException TLSException+                    deriving (Show, Eq, Typeable, Generic)++-- | Signals an XMPP stream error or another unpredicted stream-related+-- situation. This error is fatal, and closes the XMPP stream.+data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream+                                                        -- element has been+                                                        -- encountered.+                 | StreamEndFailure -- ^ The stream has been closed.+                                    -- This exception is caught by the+                                    -- concurrent implementation, and+                                    -- will thus not be visible+                                    -- through use of 'Session'.+                 | StreamCloseError ([Element], XmppFailure) -- ^ When an XmppFailure+                                              -- is encountered in+                                              -- closeStreams, this+                                              -- constructor wraps the+                                              -- elements collected so+                                              -- far.+                 | TcpConnectionFailure -- ^ All attempts to TCP+                                        -- connect to the server+                                        -- failed.+                 | XmppIllegalTcpDetails -- ^ The TCP details provided did not+                                         -- validate.+                 | TlsError XmppTlsError -- ^ An error occurred in the+                                     -- TLS layer+                 | TlsNoServerSupport -- ^ The server does not support+                                      -- the use of TLS+                 | XmppNoStream -- ^ An action that required an active+                                -- stream were performed when the+                                -- 'StreamState' was 'Closed'+                 | XmppAuthFailure AuthFailure -- ^ Authentication with the+                                               -- server failed (unrecoverably)+                 | TlsStreamSecured -- ^ Connection already secured+                 | XmppOtherFailure -- ^ Undefined condition. More+                                    -- information should be available in+                                    -- the log.+                 | XmppIOException IOException -- ^ An 'IOException'+                                               -- occurred+                 | XmppInvalidXml String -- ^ Received data is not valid XML+                 deriving (Show, Eq, Typeable, Generic)++instance Exception XmppFailure++-- | 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, Generic)++-- =============================================================================+--  XML TYPES+-- =============================================================================++-- | 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, Read, Show, Generic)++-- If the major version numbers are not equal, compare them. Otherwise, compare+-- the minor version numbers.+instance Ord Version where+    compare (Version amajor aminor) (Version bmajor bminor)+        | amajor /= bmajor = compare amajor bmajor+        | otherwise = compare aminor bminor++-- instance Read Version where+--     readsPrec _ txt = (,"") <$> maybeToList (versionFromText $ Text.pack txt)++-- 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+versionFromText s = case AP.parseOnly versionParser s of+    Right version -> Just version+    Left _ -> Nothing++-- Read numbers, a dot, more numbers, and end-of-file.+versionParser :: AP.Parser Version+versionParser = do+    major <- AP.many1 AP.digit+    AP.skip (== '.')+    minor <- AP.many1 AP.digit+    AP.endOfInput+    return $ Version (read major) (read minor)++-- | The language tag in accordance with RFC 5646 (in the form of "en-US"). It+-- has a primary tag and a number of subtags. Two language tags are considered+-- equal if and only if they contain the same tags (case-insensitive).+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++-- | Parses, validates, and possibly constructs a "LangTag" object.+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+    -- Read until we reach a '-' character, or EOF. This is the `primary tag'.+    primTag <- tag+    -- Read zero or more subtags.+    subTags <- many subtag+    AP.endOfInput+    return $ LangTag primTag subTags+  where+    tag :: AP.Parser Text.Text+    tag = do+        t <- AP.takeWhile1 $ AP.inClass tagChars+        return t+    subtag :: AP.Parser Text.Text+    subtag = do+        AP.skip (== '-')+        tag+    tagChars :: [Char]+    tagChars = ['a'..'z'] ++ ['A'..'Z']++data StreamFeatures = StreamFeatures+    { streamFeaturesTls         :: !(Maybe Bool)+    , streamFeaturesMechanisms  :: ![Text.Text]+    , streamFeaturesRosterVer   :: !(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).+    , streamFeaturesPreApproval :: !Bool -- ^ Does the server support pre-approval+    , streamFeaturesSession     :: !(Maybe Bool)+       -- ^ Does this server allow the stream elelemt? (See+       -- https://tools.ietf.org/html/draft-cridland-xmpp-session-01)+    , streamFeaturesOther       :: ![Element]+      -- TODO: All feature elements instead?+    } deriving (Eq, Show)++instance Sem.Semigroup StreamFeatures where+    sf1 <> sf2 =+        StreamFeatures+               { streamFeaturesTls = mplusOn streamFeaturesTls+               , streamFeaturesMechanisms  = mplusOn streamFeaturesMechanisms+               , streamFeaturesRosterVer   = mplusOn streamFeaturesRosterVer+               , streamFeaturesPreApproval =+                 streamFeaturesPreApproval sf1+                 || streamFeaturesPreApproval sf2+               , streamFeaturesSession   = mplusOn streamFeaturesSession+               , streamFeaturesOther       = mplusOn streamFeaturesOther++               }+      where+        mplusOn f = f sf1 `mplus` f sf2++instance Monoid StreamFeatures where+    mempty = StreamFeatures+               { streamFeaturesTls         = Nothing+               , streamFeaturesMechanisms  = []+               , streamFeaturesRosterVer   = Nothing+               , streamFeaturesPreApproval = False+               , streamFeaturesSession     = Nothing+               , streamFeaturesOther       = []+               }+    mappend = (<>)++-- | Signals the state of the stream connection.+data ConnectionState+    = Closed  -- ^ Stream has not been established yet+    | Plain   -- ^ Stream established, but not secured via TLS+    | Secured -- ^ Stream established and secured via TLS+    | Finished -- ^ Stream was closed+      deriving (Show, Eq, Typeable, Generic)++-- | Defines operations for sending, receiving, flushing, and closing on a+-- stream.+data StreamHandle =+    StreamHandle { streamSend :: BS.ByteString+                                 -> IO (Either XmppFailure ()) -- ^ Sends may not+                                                          -- interleave+                 , streamReceive :: Int -> IO (Either XmppFailure BS.ByteString)+                   -- This is to hold the state of the XML parser (otherwise we+                   -- will receive EventBeginDocument events and forget about+                   -- name prefixes). (TODO: Clarify)+                 , streamFlush :: IO ()+                 , streamClose :: IO ()+                 }++data StreamState = StreamState+    { -- | State of the stream - 'Closed', 'Plain', or 'Secured'+      streamConnectionState :: !ConnectionState+      -- | Functions to send, receive, flush, and close the stream+    , streamHandle :: StreamHandle+      -- | Event conduit source, and its associated finalizer+    , streamEventSource :: ConduitT () Event (ExceptT XmppFailure IO) ()+      -- | Stream features advertised by the server+    , streamFeatures :: !StreamFeatures -- TODO: Maybe?+      -- | The hostname or IP specified for the connection+    , streamAddress :: !(Maybe Text)+      -- | The hostname specified in the server's stream element's+      -- `from' attribute+    , streamFrom :: !(Maybe Jid)+      -- | The identifier specified in the server's stream element's+      -- `id' attribute+    , streamId :: !(Maybe Text)+      -- | The language tag value specified in the server's stream+      -- element's `langtag' attribute; will be a `Just' value once+      -- connected to the server+      -- TODO: Verify+    , streamLang :: !(Maybe LangTag)+      -- | Our JID as assigned by the server+    , streamJid :: !(Maybe Jid)+      -- | Configuration settings for the stream+    , streamConfiguration :: StreamConfiguration+    }++newtype Stream = Stream { unStream :: TMVar StreamState }++---------------+-- JID+---------------++-- | A JID is XMPP\'s native format for addressing entities in the network. It+-- is somewhat similar to an e-mail address but contains three parts instead of+-- two: 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@).+--+-- For more details see RFC 6122 <http://xmpp.org/rfcs/rfc6122.html>++data Jid = Jid { localpart_    :: !(Maybe NonemptyText)+               , domainpart_   :: !NonemptyText+               , resourcepart_ :: !(Maybe NonemptyText)+               } deriving (Eq, Ord)++-- | Converts a JID to a Text.+jidToText :: Jid -> Text+jidToText (Jid nd dmn res) = Text.concat . concat $+                             [ maybe [] (:["@"]) (text <$> nd)+                             , [text dmn]+                             , maybe [] (\r -> ["/",r]) (text <$> res)+                             ]++-- | Converts a JID to up to three Text values: (the optional) localpart, the+-- domainpart, and (the optional) resourcepart.+--+-- >>> jidToTexts [jid|foo@bar/quux|]+-- (Just "foo","bar",Just "quux")+--+-- >>> jidToTexts [jid|bar/quux|]+-- (Nothing,"bar",Just "quux")+--+-- >>> jidToTexts [jid|foo@bar|]+-- (Just "foo","bar",Nothing)+--+-- prop> jidToTexts j == (localpart j, domainpart j, resourcepart j)+jidToTexts :: Jid -> (Maybe Text, Text, Maybe Text)+jidToTexts (Jid nd dmn res) = (text <$> nd, text dmn, text <$> res)++-- Produces a Jid value in the format "parseJid \"<jid>\"".+instance Show Jid where+  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 _ 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.+      case lex s of+        [("parseJid", r')] ->+          case lex r' of+            [(s', r'')] ->+              case (reads s') of+                ((jidTxt,_):_) ->+                  case jidFromText (Text.pack jidTxt) of+                       Nothing -> []+                       Just jid' -> [(jid', r'')]+                _ -> []+            _ -> []+        _ -> []+++#if WITH_TEMPLATE_HASKELL++instance TH.Lift Jid where+    lift (Jid lp dp rp) = [| Jid $(mbTextE $ text <$> lp)+                                 $(textE   $ text dp)+                                 $(mbTextE $ text <$> rp)+                           |]+     where+        textE t = [| Nonempty $ Text.pack $(stringE $ Text.unpack t) |]+        mbTextE Nothing = [| Nothing |]+        mbTextE (Just s) = [| Just $(textE s) |]++-- | Constructs and validates a @Jid@ at compile time.+--+-- Syntax:+-- @+--     [jid|localpart\@domainpart/resourcepart|]+-- @+--+-- >>> [jid|foo@bar/quux|]+-- parseJid "foo@bar/quux"+--+-- >>> Just [jid|foo@bar/quux|] == jidFromTexts (Just "foo") "bar" (Just "quux")+-- True+--+-- >>> Just [jid|foo@bar/quux|] == jidFromText "foo@bar/quux"+-- True+--+-- See also 'jidFromText'+jid :: QuasiQuoter+jid = 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 -> TH.lift j+                  , quotePat = error "Jid patterns aren't implemented"+                  , quoteType = error "jid QQ can't be used in type context"+                  , quoteDec  = error "jid QQ can't be used in declaration context"+                  }++-- | Synonym for 'jid'+jidQ :: QuasiQuoter+jidQ = jidQ+#endif++-- | The partial order of "definiteness". JID1 is less than or equal JID2 iff+-- the domain parts are equal and JID1's local part and resource part each are+-- either Nothing or equal to Jid2's+(<~) :: Jid -> Jid -> Bool+(Jid lp1 dp1 rp1) <~ (Jid lp2 dp2 rp2) =+    dp1 ==  dp2 &&+    lp1 ~<~ lp2 &&+    rp1 ~<~ rp2+  where+   Nothing  ~<~ _ = True+   Just x  ~<~ Just y = x == y+   _  ~<~ _ = False++-- 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 = error $ "LanguageTag patterns aren't"+                                         ++ " implemented"+                       , quoteType = error $ "LanguageTag QQ can't be used"+                                           ++ " in type context"+                       , quoteDec  = error $ "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"++-- | Parse a JID+--+-- >>> localpart <$> jidFromText "foo@bar/quux"+-- Just (Just "foo")+--+-- >>> domainpart <$> jidFromText "foo@bar/quux"+-- Just "bar"+--+-- >>> resourcepart <$> jidFromText "foo@bar/quux"+-- Just (Just "quux")+--+-- @ and / can occur in the domain part+--+-- >>> jidFromText "foo/bar@quux/foo"+-- Just parseJid "foo/bar@quux/foo"+--+-- * Counterexamples+--+-- A JID must only have one \'\@\':+--+-- >>> jidFromText "foo@bar@quux"+-- Nothing+--+-- The domain part can\'t be empty:+--+-- >>> jidFromText "foo@/quux"+-- Nothing+--+-- Both the local part and the resource part can be omitted (but the+-- \'\@\' and \'\/\', must also be removed):+--+-- >>> jidToTexts <$> jidFromText "bar"+-- Just (Nothing,"bar",Nothing)+--+-- >>> jidToTexts <$> jidFromText "@bar"+-- Nothing+--+-- >>> jidToTexts <$> jidFromText "bar/"+-- Nothing+--+jidFromText :: Text -> Maybe Jid+jidFromText t = do+    (l, d, r) <- eitherToMaybe $ AP.parseOnly jidParts t+    jidFromTexts l d r+  where+    eitherToMaybe = either (const Nothing) Just++-- | Convert localpart, domainpart, and resourcepart to a JID. Runs the+-- appropriate stringprep profiles and validates the parts.+--+-- >>> jidFromTexts (Just "foo") "bar" (Just "baz") == jidFromText "foo@bar/baz"+-- True+--+-- prop> \j -> jidFromTexts (localpart j) (domainpart j) (resourcepart j) == Just j+jidFromTexts :: Maybe Text -> Text -> Maybe Text -> Maybe Jid+jidFromTexts l d r = do+    localPart <- case l of+        Nothing -> return Nothing+        Just l'-> do+            l'' <- SP.runStringPrep nodeprepProfile l'+            guard $ validPartLength l''+            let prohibMap = Set.fromList nodeprepExtraProhibitedCharacters+            guard $ Text.all (`Set.notMember` prohibMap) l''+            l''' <- nonEmpty l''+            return $ Just l'''+    -- strip dots again to handle stuff like "⒐" until we are rfc7622+    domainPart' <- forbidSeparators . stripSuffix =<< SP.runStringPrep (SP.namePrepProfile False) (stripSuffix d)+    guard $ validDomainPart domainPart'+    guard $ validPartLength domainPart'+    domainPart <- nonEmpty domainPart'+    resourcePart <- case r of+        Nothing -> return Nothing+        Just r' -> do+            r'' <- SP.runStringPrep resourceprepProfile r'+            guard $ validPartLength r''+            r''' <- nonEmpty r''+            return $ Just r'''+    return $ Jid localPart domainPart resourcePart+  where+    validDomainPart :: Text -> Bool+    validDomainPart s = not $ Text.null s -- TODO: implement more stringent+                                          -- checks++    validPartLength :: Text -> Bool+    validPartLength p = Text.length p > 0+                        && BS.length (Text.encodeUtf8 p) < 1024+    -- RFC6122 §2.2; we strip ALL the dots to avoid looking for a fixed point and bailing out early+    stripSuffix = Text.dropWhileEnd (== '.')+    -- "／" might be a valid JID, but stringprep messes it up, so we use+    forbidSeparators t = if Nothing == Text.find (flip elem ['/', '@']) t then Just t else Nothing++-- | Returns 'True' if the JID is /bare/, that is, it doesn't have a resource+-- part, and 'False' otherwise.+--+-- >>> isBare [jid|foo@bar|]+-- True+--+-- >>> isBare [jid|foo@bar/quux|]+-- False+isBare :: Jid -> Bool+isBare j | resourcepart j == Nothing = True+         | otherwise                 = False++-- | Returns 'True' if the JID is /full/, and 'False' otherwise.+--+-- @isFull = not . isBare@+--+-- >>> isBare [jid|foo@bar|]+-- True+--+-- >>> isBare [jid|foo@bar/quux|]+-- False+isFull :: Jid -> Bool+isFull = not . isBare++-- | Returns the @Jid@ without the resourcepart (if any).+--+-- >>> toBare [jid|foo@bar/quux|] == [jid|foo@bar|]+-- True+toBare :: Jid -> Jid+toBare j  = j{resourcepart_ = Nothing}++-- | Returns the localpart of the @Jid@ (if any).+--+-- >>> localpart [jid|foo@bar/quux|]+-- Just "foo"+localpart :: Jid -> Maybe Text+localpart = fmap text . localpart_++-- | Returns the domainpart of the @Jid@.+--+-- >>> domainpart [jid|foo@bar/quux|]+-- "bar"+domainpart :: Jid -> Text+domainpart = text . domainpart_++-- | Returns the resourcepart of the @Jid@ (if any).+--+-- >>> resourcepart [jid|foo@bar/quux|]+-- Just "quux"+resourcepart :: Jid -> Maybe Text+resourcepart = fmap text . resourcepart_++-- | Parse the parts of a JID. The parts need to be validated with stringprep+-- before the JID can be constructed+jidParts :: AP.Parser (Maybe Text, Text, Maybe Text)+jidParts = do+    maybeLocalPart <- Just <$> localPart <|> return Nothing+    domainPart <- AP.takeWhile1 (AP.notInClass ['@', '/'])+    maybeResourcePart <- Just <$> resourcePart <|> return Nothing+    AP.endOfInput+    return (maybeLocalPart, domainPart, maybeResourcePart)+  where+    localPart = do+        bytes <- AP.takeWhile1 (AP.notInClass ['@', '/'])+        _ <- AP.char '@'+        return bytes+    resourcePart = do+        _ <- AP.char '/'+        AP.takeText++++-- | The `nodeprep' StringPrep profile.+nodeprepProfile :: SP.StringPrepProfile+nodeprepProfile = SP.Profile { SP.maps = [SP.b1, SP.b2]+                             , SP.shouldNormalize = True+                             , SP.prohibited = [ SP.a1+                                               , SP.c11+                                               , SP.c12+                                               , SP.c21+                                               , SP.c22+                                               , SP.c3+                                               , SP.c4+                                               , SP.c5+                                               , SP.c6+                                               , SP.c7+                                               , SP.c8+                                               , SP.c9+                                               ]+                             , SP.shouldCheckBidi = True+                             }++-- | These characters needs to be checked for after normalization.+nodeprepExtraProhibitedCharacters :: [Char]+nodeprepExtraProhibitedCharacters = ['\x22', '\x26', '\x27', '\x2F', '\x3A',+                                     '\x3C', '\x3E', '\x40']++-- | The `resourceprep' StringPrep profile.+resourceprepProfile :: SP.StringPrepProfile+resourceprepProfile = SP.Profile { SP.maps = [SP.b1]+                                 , SP.shouldNormalize = True+                                 , SP.prohibited = [ SP.a1+                                                   , SP.c12+                                                   , SP.c21+                                                   , SP.c22+                                                   , SP.c3+                                                   , SP.c4+                                                   , SP.c5+                                                   , SP.c6+                                                   , SP.c7+                                                   , SP.c8+                                                   , SP.c9+                                                   ]+                                 , SP.shouldCheckBidi = True+                                 }+-- | Specify the method with which the connection is (re-)established+data ConnectionDetails = UseRealm -- ^ Use realm to resolv host. This is the+                                  -- default.+                       | UseSrv HostName -- ^ Use this hostname for a SRV lookup+                       | UseHost HostName PortNumber -- ^ Use specified host+                       | UseConnection (ExceptT XmppFailure IO StreamHandle)+                         -- ^ Use a custom method to create a StreamHandle. This+                         -- will also be used by reconnect. For example, to+                         -- establish TLS before starting the stream as done by+                         -- GCM, see 'connectTls'. You can also return an+                         -- already established connection. This method should+                         -- also return a hostname that is used for TLS+                         -- signature verification. If startTLS is not used it+                         -- can be left empty++-- | Configuration settings related to the stream.+data StreamConfiguration =+    StreamConfiguration { -- | Default language when no language tag is set+                          preferredLang :: !(Maybe LangTag)+                          -- | JID to include in the stream element's `to'+                          -- attribute when the connection is secured; if the+                          -- boolean is set to 'True', then the JID is also+                          -- included when the 'ConnectionState' is 'Plain'+                        , toJid :: !(Maybe (Jid, Bool))+                          -- | By settings this field, clients can specify the+                          -- network interface to use, override the SRV lookup+                          -- of the realm, as well as specify the use of a+                          -- non-standard port when connecting by IP or+                          -- connecting to a domain without SRV records.+                        , connectionDetails :: ConnectionDetails+                          -- | DNS resolver configuration+                        , resolvConf :: ResolvConf+                          -- | Whether or not to perform the legacy+                          -- session bind as defined in the (outdated)+                          -- RFC 3921 specification+                        , tlsBehaviour :: TlsBehaviour+                          -- | Settings to be used for TLS negotitation+                        , tlsParams :: ClientParams+                        }++-- | Default parameters for TLS restricted to strong ciphers+xmppDefaultParamsStrong :: ClientParams+xmppDefaultParamsStrong = (defaultParamsClient "" BS.empty)+                        { clientSupported = def+                            { supportedCiphers = ciphersuite_strong+#if !MIN_VERSION_tls(2,0,0)+                                                 ++ [ cipher_AES256_SHA1+                                                    , cipher_AES128_SHA1+                                                    ]+#endif+                            }+                        }++-- | Default parameters for TLS+-- @ciphersuite_all@ can be used to allow insecure ciphers+xmppDefaultParams :: ClientParams+xmppDefaultParams = (defaultParamsClient "" BS.empty)+                        { clientSupported = def+                            { supportedCiphers = ciphersuite_default+                            }+                        }++instance Default StreamConfiguration where+    def = StreamConfiguration { preferredLang     = Nothing+                              , toJid             = Nothing+                              , connectionDetails = UseRealm+                              , resolvConf        = defaultResolvConf+                              , tlsBehaviour      = PreferTls+                              , tlsParams         = xmppDefaultParams+                              }++-- | How the client should behave in regards to TLS.+data TlsBehaviour = RequireTls -- ^ Require the use of TLS; disconnect if it's+                               -- not offered.+                  | PreferTls  -- ^ Negotitate TLS if it's available.+                  | PreferPlain  -- ^ Negotitate TLS only if the server requires+                                 -- it+                  | RefuseTls  -- ^ Never secure the stream with TLS.+                    deriving (Eq, Show, Generic)
+ source/Network/Xmpp/Utilities.hs view
@@ -0,0 +1,93 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++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.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           Data.XML.Types+import           Prelude+import           System.IO.Unsafe(unsafePerformIO)+import qualified Text.XML.Stream.Render as TXSR+import           Text.XML.Unresolved as TXU++-- | 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 []+  where+    goE (Element name' as' ns') =+          (EventBeginElement name' as' :)+        . goN ns'+        . (EventEndElement name' :)+    goN [] = id+    goN [x] = goN' x+    goN (x:xs) = goN' x . goN xs+    goN' (NodeElement e) = goE e+    goN' (NodeInstruction i) = (EventInstruction i :)+    goN' (NodeContent c) = (EventContent c :)+    goN' (NodeComment t) = (EventComment t :)++renderOpenElement :: Element -> BS.ByteString+renderOpenElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO+    $ CL.sourceList (openElementToEvents e) $$ TXSR.renderText def =$ CL.consume++renderElement :: Element -> BS.ByteString+renderElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO+    $ CL.sourceList (elementToEvents e) $$ TXSR.renderText def =$ CL.consume+  where+    elementToEvents :: Element -> [Event]+    elementToEvents 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]
+ tests/Main.hs view
@@ -0,0 +1,13 @@+module Main where++import Test.Tasty++import Tests.Parsers+import Tests.Picklers+import Tests.Stream++main :: IO ()+main = defaultMain $ testGroup "root" [ parserTests+                                      , picklerTests+                                      , streamTests+                                      ]
+ tests/Run.hs view
@@ -0,0 +1,14 @@+module Main where++import Test.Tasty.HUnit+import Test.Tasty++import qualified Run.SendReceive as SendReceive+import qualified Run.Google as Google++sendReceiveTest = testCase "send and receive" SendReceive.run+googleTest = testCase "connect to google service" Google.connectGoogle++main = defaultMain $ testGroup "connection tests" [ sendReceiveTest+                                                  , googleTest+                                                  ]
+ tests/Run/Config.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}++module Run.Config where++import qualified Data.Configurator as Conf+import qualified Data.Configurator.Types as Conf+import           System.Directory+import           System.FilePath+import           System.Log.Logger+import qualified Data.Text as Text++-- | Load the configuration files+loadConfig :: IO Conf.Config+loadConfig = do+    appData <- getAppUserDataDirectory "pontarius-xmpp-tests"+    home <- getHomeDirectory+    Conf.load [ Conf.Optional $ appData </> "pontarius-xmpp-tests.conf"+              , Conf.Optional $ home </> ".pontarius-xmpp-tests.conf"+              ]++configuredLoglevel conf = do+    loglevel <- Conf.lookup conf "loglevel" >>= \case+        (Nothing :: Maybe Text.Text) -> return ERROR+        Just "debug" -> return DEBUG+        Just "info" -> return INFO+        Just "notice" -> return NOTICE+        Just "warning" -> return WARNING+        Just "error" -> return ERROR+        Just "critical" -> return CRITICAL+        Just "alert" -> return ALERT+        Just "emergency" -> return EMERGENCY+        Just e -> error $ "Log level " ++ (Text.unpack e) ++ " unknown"+    updateGlobalLogger "Pontarius.Xmpp" $ setLevel loglevel+    return loglevel
+ tests/Run/Google.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Test connecting to google services+module Run.Google where+++import qualified Data.Configurator as Conf+import           Network.Xmpp+import           Network.Xmpp.Lens+import           System.Exit+import           System.Log.Logger+import           Test.HUnit+import           Network.TLS++import           Run.Config++xmppConf = set tlsServerIdentificationL ("talk.google.com", "") $ def++connectGoogle = do+    conf <- loadConfig+    _ <- configuredLoglevel conf+    infoM "Pontarius.Xmpp" "Trying to connect to google server"+    let realm = "google.com"+    user <- Conf.require conf "google.user"+    password <- Conf.require conf "google.password"+    mbSess <- session realm (simpleAuth user password) xmppConf+    sess <- case mbSess of+        Left e -> do+            assertFailure $ "google session could not be initialized" ++ show e+            exitFailure+        Right r -> return r+    infoM "Pontarius.Xmpp" "Done trying to connect to google server"++-- connectGoogleSCM = do+--     conf <- loadConfig+--     _ <- configuredLoglevel conf+--     infoM "Pontarius.Xmpp" "Trying to connect to google server"+--     let realm = "gcm.googleapis.com"+--     user <- Conf.require conf "google.user"+--     password <- Conf.require conf "google.password"+--     mbSess <- session realm (simpleAuth user password) xmppConf+--     sess <- case mbSess of+--         Left e -> do+--             assertFailure $ "google session could not be initialized" ++ show e+--             exitFailure+--         Right r -> return r+--     infoM "Pontarius.Xmpp" "Done trying to connect to google server"
+ tests/Run/Payload.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE LambdaCase #-}+++module Run.Payload where++import           Control.Monad+import           Control.Monad.STM+import qualified Data.Text as Text+import           Data.XML.Pickle+import           Data.XML.Types+import           Network.Xmpp+import           Network.Xmpp.Internal+import           System.Log.Logger+import           Test.HUnit hiding (Node)+import           Test.Hspec.Expectations++data Payload = Payload+               { payloadCounter :: !Int+               , ignoreFlag     :: !Bool+               , errorFlag      :: !Bool+               , payloadText    :: !Text.Text+               } deriving (Eq, Show)++testNS :: Text.Text+testNS = "xmpp:library:test"++payloadP :: PU [Node] Payload+payloadP = xpWrap (\((counter,iFlag, eFlag) , message)+                      -> Payload counter iFlag eFlag message)+                  (\(Payload counter iFlag eFlag message)+                      ->((counter,iFlag, eFlag) , message)) $+                   xpElem (Name "request" (Just testNS) Nothing)+                      (xp3Tuple+                        (xpAttr "counter" xpPrim)+                        (xpAttr "ignoreFlag" xpPrim)+                        (xpAttr "errorFlag" xpPrim)+                      )+                      (xpElemNodes (Name "message" (Just testNS) Nothing)+                          (xpContent xpId))++invertPayload :: Payload -> Payload+invertPayload (Payload count _iFlag _eFlag message) =+    Payload (count + 1) False False (Text.reverse message)++iqResponder :: Session -> IO ()+iqResponder context = do+    chan' <- listenIQ Set testNS context+    chan <- case chan' of+        Left _ -> do+            assertFailure "Channel was already taken"+            undefined+        Right c -> return c+    forever $ do+        next <- atomically $ chan+        let Right payload = unpickleElem payloadP . iqRequestPayload $+                              iqRequestBody next+        let answerPayload = invertPayload payload+        let answerBody = pickleElem payloadP answerPayload+        unless (ignoreFlag payload) . void $+            case errorFlag payload of+                False -> answerIQ next (Right $ Just answerBody) []+                True -> answerIQ next (Left $ mkStanzaError NotAcceptable) []++testString :: Text.Text+testString = "abc ÄÖ>"++testPayload :: Jid -> Session -> IO ()+testPayload them session = do+    infoM "Pontarius.Xmpp" "Testing IQ send/receive"+    let pl1 = Payload 1 False False testString+        body1 = pickleElem payloadP pl1+    resp <- sendIQ' (Just 3000000) (Just them) Set Nothing body1 [] session++    case resp of+        Left e -> assertFailure $ "Could not send pl1" ++ show e+        Right (IQResponseError e) ->+            assertFailure $ "Unexpected IQ error" ++ show e+        Right (IQResponseResult IQResult{iqResultPayload = Just pl}) -> do+            case unpickleElem payloadP pl of+                Left e -> assertFailure $ "Error unpickling response p1"+                                           ++ ppUnpickleError e+                Right r -> do+                    payloadCounter r `shouldBe` 2+                    payloadText r `shouldBe` Text.reverse testString+        Right (IQResponseResult _) ->+            assertFailure "IQ result didn't contain payload"+    infoM "Pontarius.Xmpp" "Done testing IQ send/receive"+    ----------------------+    -- Timeout test+    ----------------------+    let pl2 = Payload 2 True False testString+        body2 = pickleElem payloadP pl2+    infoM "Pontarius.Xmpp" "Testing timeout"+    resp <- sendIQ' (Just 1000000) (Just them) Set Nothing body2 [] session+    case resp of+        Left IQTimeOut -> return ()+        Left e -> assertFailure $ "Unexpected send error" ++ show e+        Right r -> assertFailure $ "Unexpected IQ answer" ++ show r+    infoM "Pontarius.Xmpp" "IQ timed out (as expected)"+    ----------------------+    -- Error test+    ----------------------+    infoM "Pontarius.Xmpp" "Testing IQ error"+    let pl3 = Payload 3 False True testString+        body3 = pickleElem payloadP pl3+    resp <- sendIQ' (Just 3000000) (Just them) Set Nothing body3 [] session+    case resp of+        Left e -> assertFailure $ "Unexpected send error" ++ show e+        Right (IQResponseError e) ->+             stanzaErrorCondition (iqErrorStanzaError e) `shouldBe` NotAcceptable++        Right r -> assertFailure $ "Received unexpected IQ response" ++ show r+    infoM "Pontarius.Xmpp" "Received expected error"
+ tests/Run/SendReceive.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE LambdaCase #-}++module Run.SendReceive where++import           Control.Applicative+import           Control.Concurrent+import           Control.Monad+import qualified Data.Configurator as Conf+import qualified Data.Configurator.Types as Conf+import           Data.Maybe+import qualified Data.Text as Text+import           Network.Socket+import           Network.Xmpp+import           System.Exit+import           System.Log.Logger+import           System.Timeout+import           Test.HUnit+import           Test.Hspec.Expectations++import           Run.Payload+import           Run.Config++xmppConfig :: ConnectionDetails -> SessionConfiguration+xmppConfig det = def{sessionStreamConfiguration+                          = def{connectionDetails = det}+                    , onConnectionClosed = \sess _ -> do+                          _ <- reconnect' sess+                          _ <- sendPresence presenceOnline sess+                          return ()+                    }++-- | reflect messages to their origin+reflect :: Session -> IO b+reflect sess = forever $ do+    m <- getMessage sess+    case answerMessage m (messagePayload m) of+        Nothing -> return ()+        Just am ->+            void $ sendMessage am{messageAttributes = messageAttributes m} sess++testAttributes = [( "{org.pontarius.xmpp.test}testattr"+                  , "testvalue  12321 åäü>"+                  )]++run :: IO ()+run = void $ do+    conf <- loadConfig+    uname1 <- Conf.require conf "xmpp.user1"+    pwd1 <- Conf.require conf "xmpp.password1"+    uname2 <- Conf.require conf "xmpp.user1"+    pwd2 <- Conf.require conf "xmpp.password1"+    realm <- Conf.require conf "xmpp.realm"+    server <- Conf.lookup conf "xmpp.server"+    port <- Conf.lookup conf "xmpp.port" :: IO (Maybe Integer)+    let conDetails = case server of+            Nothing -> UseRealm+            Just srv -> case port of+                Nothing -> UseSrv srv+                Just p -> UseHost srv (fromIntegral p)+    _ <- configuredLoglevel conf+    mbSess1 <- session realm (simpleAuth uname1 pwd1)+                                ((xmppConfig conDetails))+    sess1 <- case mbSess1 of+        Left e -> do+            assertFailure $ "session 1 could not be initialized" ++ show e+            exitFailure+        Right r -> return r+    mbSess2 <- session realm (simpleAuth uname2 pwd2)+                                ((xmppConfig conDetails))+    sess2 <- case mbSess2 of+        Left e -> do+            assertFailure $ "session 2 could not be initialized" ++ show e+            exitFailure+        Right r -> return r+    Just jid1 <- getJid sess1+    Just jid2 <- getJid sess2+    _ <- sendPresence presenceOnline sess1+    _ <- forkIO $ reflect sess1+    forkIO $ iqResponder sess1+    _ <- sendPresence presenceOnline sess2+    -- check message responsiveness+    infoM "Pontarius.Xmpp" "Running message mirror"+    sendMessage message{ messageTo = Just jid1+                       , messageAttributes = testAttributes+                       } sess2+    resp <- timeout 3000000 $ waitForMessage (\m -> messageFrom m == Just jid1)+                                             sess2+    case resp of+        Nothing -> assertFailure "Did not receive message answer"+        Just am -> messageAttributes am `shouldBe` testAttributes+    infoM "Pontarius.Xmpp" "Done running message mirror"+    infoM "Pontarius.Xmpp" "Running IQ tests"+    testPayload jid1 sess2+    infoM "Pontarius.Xmpp" "Done running IQ tests"
+ tests/Tests/Arbitrary.hs view
@@ -0,0 +1,6 @@+module Tests.Arbitrary  where++import Tests.Arbitrary.Xml ()+import Tests.Arbitrary.Xmpp ()++-- $derive makeArbitrary IQRequestType
+ tests/Tests/Arbitrary/Common.hs view
@@ -0,0 +1,27 @@+module Tests.Arbitrary.Common where++import           Control.Applicative ((<$>))+import           Data.Char+import qualified Data.Text as Text+import           Test.QuickCheck+import           Test.QuickCheck.Instances ()++shrinkText1 :: Text.Text -> [Text.Text]+shrinkText1 txt = filter (not . Text.null) $ shrink txt++shrinkTextMaybe :: Maybe Text.Text -> [Maybe Text.Text]+shrinkTextMaybe mbtxt = filter (\mb -> mb /= Just (Text.empty)) $ shrink mbtxt++genText1 :: Gen Text.Text+genText1 = Text.pack <$> string1+  where+    string1 = listOf1 arbitrary `suchThat` (not . all isSpace)++maybeGen :: Gen a -> Gen (Maybe a)+maybeGen g = oneof [ return Nothing+                   , Just <$> g+                   ]++shrinkMaybe :: (t -> [t]) -> Maybe t -> [Maybe t]+shrinkMaybe _s Nothing = []+shrinkMaybe s (Just x) = Nothing : map Just (s x)
+ tests/Tests/Arbitrary/Xml.hs view
@@ -0,0 +1,85 @@+module Tests.Arbitrary.Xml where++import           Control.Applicative ((<$>), (<*>))+import           Test.QuickCheck+import           Test.QuickCheck.Instances()+-- import Data.DeriveTH+import qualified Data.Text as Text+import           Data.XML.Types+import           Tests.Arbitrary.Common+import           Text.CharRanges+++selectFromRange :: Range -> Gen Char+selectFromRange (Single a) = return a+selectFromRange (Range a b) = choose (a, b)++nameStartChar :: [Range]+nameStartChar =+    [ -- Single ':'+      Single '_'+    , Range 'A' 'Z'+    , Range 'a' 'z'+    , Range '\xC0' '\xD6'+    , Range '\xD8' '\xF6'+    , Range '\xF8' '\x2FF'+    , Range '\x370' '\x37D'+    , Range '\x37F' '\x1FFF'+    , Range '\x200C' '\x200D'+    , Range '\x2070' '\x218F'+    , Range '\x2C00' '\x2FEF'+    , Range '\x3001' '\xD7FF'+    , Range '\xF900' '\xFDCF'+    , Range '\xFDF0' '\xFFFD'+    , Range '\x10000' '\xEFFFF'+    ]++nameChar :: [Range]+nameChar =+      Single '-'+    : Single '.'+    : Single '\xB7'+    : Range '0' '9'+    : Range '\x0300' '\x036F'+    : Range '\x203F' '\x2040'+    : nameStartChar+++genNCName :: Gen Text.Text+genNCName = do+    sc <- elements nameStartChar >>= selectFromRange+    ncs <- listOf $ elements nameChar >>= selectFromRange+    return . Text.pack $ sc:ncs++-- | Cap the size of child elements.+slow :: Gen a -> Gen a+slow g = sized $ \n -> resize (min 5 (n `div` 4))  g++instance Arbitrary Name where+    arbitrary = Name <$> genNCName <*> genMaybe genNCName <*> genMaybe genNCName+      where+        genMaybe g = oneof [return Nothing, Just <$> g]+    shrink (Name a b c) = [ Name a' b c | a' <- shrinkText1 a]+                        ++[ Name a b' c | b' <- shrinkTextMaybe b]+                        ++[ Name a b c' | c' <- shrinkTextMaybe c]++instance Arbitrary Content where+    arbitrary = ContentText <$> arbitrary+    shrink (ContentText txt) = ContentText <$> shrinkText1 txt+    shrink _ = []+++instance Arbitrary Node where+    arbitrary = oneof [ NodeElement <$> arbitrary+                      , NodeContent <$> arbitrary+                      ]+    shrink (NodeElement e) = NodeElement <$> shrink e+    shrink (NodeContent c) = NodeContent <$> shrink c+    shrink _ = []++instance Arbitrary Element where+    arbitrary = Element <$> arbitrary <*> slow arbitrary <*> slow arbitrary+    shrink (Element a b c) =+          [ Element a' b c | a' <- shrink a]+        ++[ Element a b' c | b' <- shrink b]+        ++[ Element a b c' | c' <- shrink c]
+ tests/Tests/Arbitrary/Xmpp.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+module Tests.Arbitrary.Xmpp where++import           Control.Applicative ((<$>), (<*>))+import           Data.Char+import           Data.Maybe+import qualified Data.Text as Text+import           Network.Xmpp.Internal hiding (elements)+import           Test.QuickCheck+import           Test.QuickCheck.Instances()+import           Test.QuickCheck.Arbitrary.Generic+import qualified Text.CharRanges as Ranges+import qualified Text.StringPrep as SP+import qualified Text.StringPrep.Profiles as SP++import           Tests.Arbitrary.Common+import           Tests.Arbitrary.Xml ()+++instance Arbitrary NonemptyText where+    arbitrary = Nonempty . Text.pack <$> listOf1+                  (arbitrary `suchThat` (not . isSpace))+    shrink (Nonempty txt) = map Nonempty+                            . filter (not . Text.all isSpace) $ shrink txt++instance Arbitrary Jid where+    arbitrary = do+        ~(Just jid) <- tryJid `suchThat` isJust+        return jid+      where+        tryJid = jidFromTexts <$> maybeGen (genString nodeprepProfile False)+                              <*> genString (SP.namePrepProfile False) False+                              <*> maybeGen (genString resourceprepProfile True)++        genString profile node = Text.pack . take 1024 <$> listOf1 genChar+          where+            genChar = arbitrary `suchThat` (not . isProhibited)+            prohibited = Ranges.toSet $ concat (SP.prohibited profile)+            isProhibited x = Ranges.member x prohibited+                             || if node+                                then False+                                else x `elem` ['@','/', '＠', '／']++    shrink (Jid lp dp rp) = [ Jid lp' dp  rp  | lp' <- shrinkMaybe shrink lp]+                         ++ [ Jid lp  dp' rp  | dp' <- shrink dp]+                         ++ [ Jid lp  dp  rp' | rp' <- shrinkMaybe shrink rp]+++-- string :: SP.StringPrepProfile -> Gen [Char]+-- string profile = take 1024 <$> listOf1 genChar+--   where+--     genChar = arbitrary `suchThat` (not . isProhibited)+--     prohibited = Ranges.toSet $ concat (SP.prohibited profile)+--     isProhibited x = Ranges.member x prohibited+--                      || x `elem` "@/"++instance Arbitrary LangTag where+    arbitrary = LangTag <$> genTag <*> listOf genTag+        where genTag = fmap Text.pack . listOf1 . elements $ ['a'..'z'] ++ ['A'..'Z']+    shrink (LangTag lt lts) = [LangTag lt' lts | lt' <- shrinkText1 lt] +++                              [LangTag lt lts' | lts' <- filter (not . Text.null)+                                                         <$> shrink lts]++instance Arbitrary XmppFailure where+  arbitrary = elements [StreamEndFailure, TcpConnectionFailure, XmppIllegalTcpDetails, TlsNoServerSupport, XmppNoStream, TlsStreamSecured, XmppOtherFailure]++-- Auto-derive trivial instances+instance Arbitrary StanzaErrorType where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary StanzaErrorCondition where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary StanzaError where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary StreamErrorInfo where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary IQRequestType where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary IQRequest where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary IQResult where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary IQError where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary MessageType where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary Message where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary MessageError where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary PresenceType where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary Presence where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary PresenceError where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary Stanza where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary SaslError where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary SaslFailure where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary StreamErrorCondition where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary AuthFailure where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary Version where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary ConnectionState where+  arbitrary = genericArbitrary+  shrink = genericShrink++instance Arbitrary TlsBehaviour where+  arbitrary = genericArbitrary+  shrink = genericShrink
+ tests/Tests/Parsers.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Tests.Parsers where++import Control.Applicative ((<$>))+import Network.Xmpp.Internal+import Test.Hspec+import Test.Tasty.QuickCheck+import Test.Tasty+import Test.Tasty.TH+import Test.Tasty.HUnit++import Tests.Arbitrary ()++case_JidFromText :: Assertion+case_JidFromText = hspec . describe "jidFromText" $ do+    it "parses a full JID" $ jidFromText "foo@bar.com/quux"+                             `shouldBe` Just (Jid (Just "foo")+                                          "bar.com"+                                          (Just "quux"))+    it "parses a bare JID" $ jidFromText "foo@bar.com"+                             `shouldBe` Just (Jid (Just "foo")+                                          "bar.com"+                                          Nothing)+    it "parses a domain" $ jidFromText "bar.com"+                             `shouldBe` Just (Jid Nothing+                                          "bar.com"+                                          Nothing)+    it "parses domain with resource" $ jidFromText "bar.com/quux"+                             `shouldBe` Just (Jid Nothing+                                          "bar.com"+                                          (Just "quux"))+    it "rejects multiple '@'" $  shouldReject "foo@bar@baz"+    it "parses multiple '/'" $  jidFromText "foo/bar/baz"+                                `shouldBe`+                                (Just (Jid Nothing "foo" (Just "bar/baz")))+    it "parses multiple '/' after '@'" $ jidFromText  "quux@foo/bar/baz"+                               `shouldBe`+                               (Just (Jid (Just "quux") "foo" (Just "bar/baz")))+    it "parses '@' after '/'" $ jidFromText "foo/bar@baz"+                               `shouldBe`+                               (Just (Jid Nothing "foo" (Just "bar@baz")))+    it "rejects empty local part" $ shouldReject "@bar/baz"+    it "rejects empty resource part" $ shouldReject "foo@bar/"+    it "rejects empty domain part" $ shouldReject "foo@/baz"+  where shouldReject jid = jidFromText jid `shouldBe` Nothing++prop_jidFromText_rightInverse :: Jid -> Bool+prop_jidFromText_rightInverse j = let jidText = jidToText j in+        (jidToText <$> jidFromText jidText) == Just jidText++prop_jidFromText_leftInverse :: Jid -> Bool+prop_jidFromText_leftInverse jid = (jidFromText $ jidToText jid) == Just jid+++case_LangTagParser :: Assertion+case_LangTagParser = hspec . describe "langTagFromText" $+                    it "has some properties" $ pendingWith "Check requirements"++parserTests :: TestTree+parserTests = $testGroupGenerator
+ tests/Tests/Picklers.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+module Tests.Picklers where++import Tests.Arbitrary ()+import Data.XML.Pickle+import Network.Xmpp.Internal+import Test.Tasty+import Test.Tasty.TH+import Test.Tasty.QuickCheck+import Data.Text (Text)++import Data.XML.Types++-- | Test Pickler self-inverse: Check that unpickling after pickling gives the+-- original value+tpsi :: Eq a => PU t a -> a -> Bool+tpsi p = \x -> case unpickle p (pickle p x) of+    Left _ -> False+    Right x' -> x == x'++testPickler :: PU t a -> a -> IO ()+testPickler p x = case unpickle p (pickle p x) of+    Left e -> putStrLn $ ppUnpickleError e+    Right _ -> putStrLn "OK."++prop_xpStreamStanza_invertible :: Either StreamErrorInfo Stanza -> Bool+prop_xpStreamStanza_invertible         = tpsi xpStreamStanza+prop_xpStanza_invertible :: Stanza -> Bool+prop_xpStanza_invertible               = tpsi xpStanza+prop_xpMessage_invertible :: Message -> Bool+prop_xpMessage_invertible              = tpsi xpMessage+prop_xpPresence_invertible             = tpsi xpPresence+prop_xpPresence_invertible :: Presence -> Bool+prop_xpIQRequest_invertible            = tpsi xpIQRequest+prop_xpIQRequest_invertible :: IQRequest -> Bool+prop_xpIQResult_invertible             = tpsi xpIQResult+prop_xpIQResult_invertible :: IQResult -> Bool+prop_xpErrorCondition_invertible       = tpsi xpStanzaErrorCondition+prop_xpErrorCondition_invertible :: StanzaErrorCondition -> Bool+prop_xpStanzaError_invertible          = tpsi xpStanzaError+prop_xpStanzaError_invertible :: StanzaError -> Bool+prop_xpMessageError_invertible         = tpsi xpMessageError+prop_xpMessageError_invertible :: MessageError -> Bool+prop_xpPresenceError_invertible        = tpsi xpPresenceError+prop_xpPresenceError_invertible :: PresenceError -> Bool+prop_xpIQError_invertible              = tpsi xpIQError+prop_xpIQError_invertible :: IQError -> Bool+prop_xpStreamError_invertible          = tpsi xpStreamError+prop_xpStreamError_invertible :: StreamErrorInfo -> Bool+prop_xpLangTag_invertible              = tpsi xpLangTag+prop_xpLangTag_invertible :: Maybe LangTag -> Bool+prop_xpLang_invertible                 = tpsi xpLang+prop_xpLang_invertible :: LangTag -> Bool+prop_xpStream_invertible               = tpsi xpStream+prop_xpStream_invertible :: ( Text+                           , Maybe Jid+                           , Maybe Jid+                           , Maybe Text+                           , Maybe LangTag )+                           -> Bool+prop_xpJid_invertible                  = tpsi xpJid+prop_xpJid_invertible :: Jid -> Bool+prop_xpIQRequestType_invertible        = tpsi xpIQRequestType+prop_xpIQRequestType_invertible :: IQRequestType -> Bool+prop_xpMessageType_invertible          = tpsi xpMessageType+prop_xpMessageType_invertible :: MessageType -> Bool+prop_xpPresenceType_invertible         = tpsi xpPresenceType+prop_xpPresenceType_invertible :: PresenceType -> Bool+prop_xpStanzaErrorType_invertible      = tpsi xpStanzaErrorType+prop_xpStanzaErrorType_invertible :: StanzaErrorType -> Bool+prop_xpStanzaErrorCondition_invertible = tpsi xpStanzaErrorCondition+prop_xpStanzaErrorCondition_invertible :: StanzaErrorCondition -> Bool+prop_xpStreamErrorCondition_invertible = tpsi xpStreamErrorCondition+prop_xpStreamErrorCondition_invertible :: StreamErrorCondition -> Bool+-- prop_xpStreamFeatures_invertible = testPicklerInvertible xpStreamFeatures++picklerTests :: TestTree+picklerTests = $testGroupGenerator++bad = StreamErrorInfo { errorCondition = StreamInvalidFrom+                      , errorText = Just (Nothing,"")+                      , errorXml = Just (+                          Element { elementName =+                                         Name { nameLocalName = "\65044"+                                              , nameNamespace = Just "\14139"+                                              , namePrefix = Just "\651"}+                                  , elementAttributes = []+                                  , elementNodes = []})}
+ tests/Tests/Stream.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Tests.Stream where++import           Control.Monad.Trans+import           Data.Conduit+import qualified Data.Conduit.List as CL+import           Data.XML.Types+import           Test.Hspec+import           Test.Tasty+import           Test.Tasty.HUnit+import           Test.Tasty.TH++import           Network.Xmpp.Internal++junk = [ EventBeginDocument+       , EventEndDocument+       , EventBeginDoctype "" Nothing+       , EventEndDoctype+       , EventInstruction $ Instruction "" ""+--       , EventBeginElement Name [(Name, [Content])]+       , EventEndElement "foo"+       , EventContent $ ContentText ""+       , EventComment ""+       , EventCDATA ""+       ]++beginElem = EventBeginElement "foo" []++case_ThrowOutJunk = hspec . describe "throwOutJunk" $ do+    it "drops everything but EvenBeginElement" $ do+        res <- CL.sourceList junk $$ throwOutJunk >> await+        res `shouldBe` Nothing+    it "keeps everything after (and including) EvenBeginElement" $ do+        res <- CL.sourceList (junk ++ [beginElem] ++ junk)+                             $$ throwOutJunk >> CL.consume+        res `shouldBe` (beginElem : junk)++case_LogInput = hspec . describe "logInput" $ do+    it "Can handle split UTF8 codepoints" $ do+        res <- CL.sourceList ["\209","\136"] $= logInput $$ CL.consume+        res `shouldBe` ["\209","\136"]++streamTests :: TestTree+streamTests = $testGroupGenerator