diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 diff --git a/Examples/EchoClient.hs b/Examples/EchoClient.hs deleted file mode 100644 --- a/Examples/EchoClient.hs +++ /dev/null @@ -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 () diff --git a/LICENSE b/LICENSE deleted file mode 100644 --- a/LICENSE +++ /dev/null @@ -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 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. diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -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. diff --git a/Network/XMPP.hs b/Network/XMPP.hs deleted file mode 100644 --- a/Network/XMPP.hs +++ /dev/null @@ -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 --- 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 diff --git a/Network/XMPP/JID.hs b/Network/XMPP/JID.hs deleted file mode 100644 --- a/Network/XMPP/JID.hs +++ /dev/null @@ -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 diff --git a/Network/XMPP/SASL.hs b/Network/XMPP/SASL.hs deleted file mode 100644 --- a/Network/XMPP/SASL.hs +++ /dev/null @@ -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 diff --git a/Network/XMPP/Session.hs b/Network/XMPP/Session.hs deleted file mode 100644 --- a/Network/XMPP/Session.hs +++ /dev/null @@ -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 "" 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 "" 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 $ - "" - 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 - "" - 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 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 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) $ - "" - hFlush (fromJust handle) - return s - - -- We have received 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 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 - "" - return () - _ -> do - loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Setting resource: " ++ - (fromJust resource) - sendData tlsCtx $ DBLC.pack $ encodeString - "" ++ fromJust resource ++ - "" - return () - r <- getID - sendData tlsCtx $ DBLC.pack $ encodeString $ - "" ++ - "" - 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 $ - "" ++ - reply' ++ "" - 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 $ - "" - return s - - -- We have received a SASL "success" message over a secured connection - -- TODO: Parse the success message? - -- TODO: ? - 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 "" - 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 "" - 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 "" - 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 = "" ++ - (elementsToString $ presencePayload p) ++ "" - 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 "" ++ (elementToString (Just p)) ++ "" - 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 "" ++ (elementToString (Just p)) ++ "" - 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 "" ++ (elementToString p) ++ "" - 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 = "" ++ - (elementsToString $ messagePayload m) ++ "" - 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) ++ "'" diff --git a/Network/XMPP/Stanza.hs b/Network/XMPP/Stanza.hs deleted file mode 100644 --- a/Network/XMPP/Stanza.hs +++ /dev/null @@ -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 --- . 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) diff --git a/Network/XMPP/Utilities.hs b/Network/XMPP/Utilities.hs deleted file mode 100644 --- a/Network/XMPP/Utilities.hs +++ /dev/null @@ -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) ++ "" - 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) diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -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 , the Pontarius XMPP -web page and the Pontarius -XMPP Hackage page for more -information. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 +Text 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 Session object can be acquired by calling +session. 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). session will perform the necessary DNS queries to find +the address of the realm, connect, establish the XMPP stream, attempt to secure +the stream with TLS, authenticate, establish a concurrent interface for +interacting with the stream, and return the Session object. + +The return type of session is IO (Either XmppFailure +Session). As XmppFailure is an +Control.Monad.Error instance, you can utilize the +ErrorT monad transformer for error handling. A more simple way of +doing it could be doing something like this: + + sess <- case result of + Right s -> return s + Left e -> error $ "XmppFailure: " ++ (show e) + +Next, let us set our status to Online. + + sendPresence def sess + +Here, def refers to the default Presence value, which +is the same as Presence Nothing Nothing Nothing Nothing Available +[]. + +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 Text 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 dupSession and +forkIO. + +For a public domain example of a simple Pontarius XMPP (Cabal) project, refer to +the examples/echoclient directory. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,2 @@ import Distribution.Simple - main = defaultMain diff --git a/XTLS.hs b/XTLS.hs deleted file mode 100644 --- a/XTLS.hs +++ /dev/null @@ -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 diff --git a/benchmarks/Bench.hs b/benchmarks/Bench.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Bench.hs @@ -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] diff --git a/examples/echoclient/LICENSE.md b/examples/echoclient/LICENSE.md new file mode 100644 --- /dev/null +++ b/examples/echoclient/LICENSE.md @@ -0,0 +1,2 @@ +The `Main.hs', `Setup.hs', and `echoclient.cabal' files in this directory are in +the public domain. diff --git a/examples/echoclient/Main.hs b/examples/echoclient/Main.hs new file mode 100644 --- /dev/null +++ b/examples/echoclient/Main.hs @@ -0,0 +1,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 () diff --git a/examples/echoclient/README.md b/examples/echoclient/README.md new file mode 100644 --- /dev/null +++ b/examples/echoclient/README.md @@ -0,0 +1,6 @@ +This directory defines a project that illustrates how to connect, authenticate, +set a simple presence, receive message stanzas, and echo them back to whoever is +sending them, using Pontarius XMPP. + +The `Main.hs', `Setup.hs', and `echoclient.cabal' files in this directory may be +used freely, as they are in the public domain. diff --git a/examples/echoclient/Setup.hs b/examples/echoclient/Setup.hs new file mode 100644 --- /dev/null +++ b/examples/echoclient/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/echoclient/echoclient.cabal b/examples/echoclient/echoclient.cabal new file mode 100644 --- /dev/null +++ b/examples/echoclient/echoclient.cabal @@ -0,0 +1,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 diff --git a/install.sh b/install.sh deleted file mode 100644 --- a/install.sh +++ /dev/null @@ -1,5 +0,0 @@ -#!/bin/sh -runhaskell Setup.hs configure --user -runhaskell Setup.hs build -runhaskell Setup.hs install - diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -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 diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp.hs @@ -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) + -- + -- + , 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) diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Concurrent.hs @@ -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 diff --git a/source/Network/Xmpp/Concurrent/Basic.hs b/source/Network/Xmpp/Concurrent/Basic.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Concurrent/Basic.hs @@ -0,0 +1,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) diff --git a/source/Network/Xmpp/Concurrent/IQ.hs b/source/Network/Xmpp/Concurrent/IQ.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Concurrent/IQ.hs @@ -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 ) [] diff --git a/source/Network/Xmpp/Concurrent/Message.hs b/source/Network/Xmpp/Concurrent/Message.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Concurrent/Message.hs @@ -0,0 +1,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 diff --git a/source/Network/Xmpp/Concurrent/Monad.hs b/source/Network/Xmpp/Concurrent/Monad.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Concurrent/Monad.hs @@ -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 \ 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 diff --git a/source/Network/Xmpp/Concurrent/Presence.hs b/source/Network/Xmpp/Concurrent/Presence.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Concurrent/Presence.hs @@ -0,0 +1,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 diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -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 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 () diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -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 _ = "" + +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 diff --git a/source/Network/Xmpp/IM.hs b/source/Network/Xmpp/IM.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/IM.hs @@ -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 diff --git a/source/Network/Xmpp/IM/Message.hs b/source/Network/Xmpp/IM/Message.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/IM/Message.hs @@ -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) diff --git a/source/Network/Xmpp/IM/Presence.hs b/source/Network/Xmpp/IM/Presence.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/IM/Presence.hs @@ -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" diff --git a/source/Network/Xmpp/IM/PresenceTracker.hs b/source/Network/Xmpp/IM/PresenceTracker.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/IM/PresenceTracker.hs @@ -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 diff --git a/source/Network/Xmpp/IM/PresenceTracker/Types.hs b/source/Network/Xmpp/IM/PresenceTracker/Types.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/IM/PresenceTracker/Types.hs @@ -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) diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/IM/Roster.hs @@ -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" diff --git a/source/Network/Xmpp/IM/Roster/Types.hs b/source/Network/Xmpp/IM/Roster/Types.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/IM/Roster/Types.hs @@ -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 diff --git a/source/Network/Xmpp/Internal.hs b/source/Network/Xmpp/Internal.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Internal.hs @@ -0,0 +1,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 diff --git a/source/Network/Xmpp/Lens.hs b/source/Network/Xmpp/Lens.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Lens.hs @@ -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}) diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Marshal.hs @@ -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 diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Sasl.hs @@ -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 + -- "" + -- element, with a possible "[JID]" + -- 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 diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -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 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 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 diff --git a/source/Network/Xmpp/Sasl/Mechanisms.hs b/source/Network/Xmpp/Sasl/Mechanisms.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Sasl/Mechanisms.hs @@ -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 diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs @@ -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 + ) diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs @@ -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 + ) diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs @@ -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 + ) diff --git a/source/Network/Xmpp/Sasl/StringPrep.hs b/source/Network/Xmpp/Sasl/StringPrep.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Sasl/StringPrep.hs @@ -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 diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -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))) diff --git a/source/Network/Xmpp/Stanza.hs b/source/Network/Xmpp/Stanza.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Stanza.hs @@ -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 diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Stream.hs @@ -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 \"\" 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 "" + 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 "" + +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 + -- "". 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) diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Tls.hs @@ -0,0 +1,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 diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Types.hs @@ -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 +-- () +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 @\@ . 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 \ 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 + -- \ 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 "\.\". 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 "." 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 + +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 \"\"". +instance Show Jid where + show j = "parseJid " ++ show (jidToText j) + +-- The string must be in the format "parseJid \"\"". +-- 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 \"\"". +instance Show LangTag where + show l = "parseLangTag " ++ show (langTagToText l) + +-- The string must be in the format "parseLangTag \"\"". 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 \"\"'" + [("parseLangTag", r')] -> case lex r' of + [] -> error "Expected `parseLangTag \"\"'" + [(s'', r'')] -> (s'', r'') + _ -> error "Expected `parseLangTag \"\"'" + _ -> error "Expected `parseLangTag \"\"'" + [(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) diff --git a/source/Network/Xmpp/Utilities.hs b/source/Network/Xmpp/Utilities.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Utilities.hs @@ -0,0 +1,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] diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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 + ] diff --git a/tests/Run.hs b/tests/Run.hs new file mode 100644 --- /dev/null +++ b/tests/Run.hs @@ -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 + ] diff --git a/tests/Run/Config.hs b/tests/Run/Config.hs new file mode 100644 --- /dev/null +++ b/tests/Run/Config.hs @@ -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 diff --git a/tests/Run/Google.hs b/tests/Run/Google.hs new file mode 100644 --- /dev/null +++ b/tests/Run/Google.hs @@ -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" diff --git a/tests/Run/Payload.hs b/tests/Run/Payload.hs new file mode 100644 --- /dev/null +++ b/tests/Run/Payload.hs @@ -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" diff --git a/tests/Run/SendReceive.hs b/tests/Run/SendReceive.hs new file mode 100644 --- /dev/null +++ b/tests/Run/SendReceive.hs @@ -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" diff --git a/tests/Tests/Arbitrary.hs b/tests/Tests/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Arbitrary.hs @@ -0,0 +1,6 @@ +module Tests.Arbitrary where + +import Tests.Arbitrary.Xml () +import Tests.Arbitrary.Xmpp () + +-- $derive makeArbitrary IQRequestType diff --git a/tests/Tests/Arbitrary/Common.hs b/tests/Tests/Arbitrary/Common.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Arbitrary/Common.hs @@ -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) diff --git a/tests/Tests/Arbitrary/Xml.hs b/tests/Tests/Arbitrary/Xml.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Arbitrary/Xml.hs @@ -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] diff --git a/tests/Tests/Arbitrary/Xmpp.hs b/tests/Tests/Arbitrary/Xmpp.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Arbitrary/Xmpp.hs @@ -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 diff --git a/tests/Tests/Parsers.hs b/tests/Tests/Parsers.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Parsers.hs @@ -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 diff --git a/tests/Tests/Picklers.hs b/tests/Tests/Picklers.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Picklers.hs @@ -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 = []})} diff --git a/tests/Tests/Stream.hs b/tests/Tests/Stream.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Stream.hs @@ -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