diff --git a/LICENSE.md b/LICENSE.md --- a/LICENSE.md +++ b/LICENSE.md @@ -1,16 +1,35 @@ Copyright © 2005-2011 Dmitry Astapov Copyright © 2005-2011 Pierre Kovalev Copyright © 2010-2011 Mahdi Abdinejadi -Copyright © 2010-2012 Jon Kristensen +Copyright © 2010-2013 Jon Kristensen Copyright © 2011 IETF Trust -Copyright © 2012 Philipp Balzarek +Copyright © 2012-2013 Philipp Balzarek -Licensed under the Apache License, Version 2.0 (the "License"); you may not use -this file except in compliance with the License. You may obtain a copy of the -License at -[http://www.apache.org/licenses/LICENSE-2.0](http://www.apache.org/licenses/LICENSE-2.0). +All rights reserved. -Unless required by applicable law or agreed to in writing, software distributed -under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR -CONDITIONS OF ANY KIND, either express or implied. See the License for the -specific language governing permissions and limitations under the License. +Pontarius XMPP is licensed under the three-clause BSD license. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of the Pontarius project nor the names of its contributors + may be used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE PONTARIUS PROJECT BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,9 +1,37 @@ Welcome to Pontarius XMPP! ========================== -Pontarius XMPP is an active work in progress to build a Haskell XMPP library -that implements the client capabilities of [RFC 6120](http://tools.ietf.org/html/rfc6120). +Pontarius XMPP is an active work in progress to build a Haskell XMPP client +library that implements the capabilities of [RFC 6120 +("XMPP CORE")](http://tools.ietf.org/html/rfc6120), [RFC 6121 ("XMPP +IM")](http://tools.ietf.org/html/rfc6121), and [RFC 6122 ("XMPP +ADDR")](http://tools.ietf.org/html/rfc6122). Pontarius XMPP is part of [the +Pontarius project](http://www.pontarius.org/), an effort to produce free and +open source, uncentralized, and privacy-aware software solutions. +While in alpha, Pontarius XMPP works quite well and fulfills most requirements +of the RFCs. + +Prerequisites +------------- + +Pontarius XMPP requires GHC 7.0, or later. + +You will need the ICU Unicode library and it's header files in order to be able +to build Pontarius XMPP. On Debian, you will need to install the *libicu-dev* +package. In Fedora, the package is called *libicu-devel*. + +_Note to users of GHC 7.0 and GHC 7.2:_ You will need *cabal-install*, version +*0.14.0* or higher, or the build will fail with an "unrecognized option: +--disable-benchmarks" error. The versions *1.16.0* and higher might not build on +your system; if so, install *0.14.0* with "cabal install cabal-install-0.14.0". + +_Note to users of GHC 7.2.1:_ Due to a bug, recent versions of the *binary* +package wont build without running "ghc-pkg trust base". + +_Note to users of GHC 7.0.1:_ You will want to configure your Cabal environment +(including *cabal-install*) for version *0.9.2.1* of *bytestring*. + Getting started --------------- @@ -36,15 +64,16 @@ result <- session "example.com" + (Just (\_ -> ( [scramSha1 "username" Nothing "password"]) + , Nothing)) def - (Just ([scramSha1 "username" Nothing "password"], Nothing)) -The three parameters above are the XMPP server realm, the session configuration -settings (set to the default settings), and a SASL handler (for authentication). -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 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 @@ -58,8 +87,12 @@ Next, let us set our status to Online. - sendPresence (Presence Nothing Nothing Nothing Nothing Nothing []) sess + 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 recipient. This can be done like so: @@ -68,6 +101,10 @@ case answerMessage msg (messagePayload msg) of Just answer -> sendMessage answer sess Nothing -> putStrLn "Received message with no sender." + +You don't need to worry about escaping your 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. diff --git a/examples/echoclient/Main.hs b/examples/echoclient/Main.hs --- a/examples/echoclient/Main.hs +++ b/examples/echoclient/Main.hs @@ -20,14 +20,15 @@ updateGlobalLogger "Pontarius.Xmpp" $ setLevel DEBUG result <- session "example.com" + (Just (\_ -> ( [scramSha1 "username" Nothing "password"]) + , Nothing)) def - (Just ([scramSha1 "username" Nothing "password"], Nothing)) sess <- case result of Right s -> return s Left e -> error $ "XmppFailure: " ++ (show e) - sendPresence (Presence Nothing Nothing Nothing Nothing Nothing []) sess + sendPresence def sess forever $ do msg <- getMessage sess case answerMessage msg (messagePayload msg) of - Just answer -> sendMessage answer sess + Just answer -> sendMessage answer sess >> return () Nothing -> putStrLn "Received message with no sender." diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -1,22 +1,24 @@ Name: pontarius-xmpp -Version: 0.2.0.1 +Version: 0.3.0.0 Cabal-Version: >= 1.6 Build-Type: Simple -License: OtherLicense +License: BSD3 License-File: LICENSE.md Copyright: Dmitry Astapov, Pierre Kovalev, Mahdi Abdinejadi, Jon Kristensen, IETF Trust, Philipp Balzarek -Author: Jon Kristensen, Mahdi Abdinejadi, Philipp Balzarek +Author: Jon Kristensen, Philipp Balzarek Maintainer: info@jonkri.com Stability: alpha -Homepage: https://github.com/jonkri/pontarius-xmpp/ -Bug-Reports: mailto:info@jonkri.com -Package-URL: http://www.jonkri.com/releases/pontarius-xmpp-0.2.0.1.tar.gz -Synopsis: An incomplete implementation of RFC 6120 (XMPP: Core) -Description: Pontarius XMPP is a work in progress implementation of - RFC 6120 (XMPP: Core). +Homepage: https://github.com/pontarius/pontarius-xmpp/ +Bug-Reports: https://github.com/pontarius/pontarius-xmpp/issues/ +Package-URL: http://www.jonkri.com/releases/pontarius-xmpp-0.3.0.0.tar.gz +Synopsis: An XMPP client library +Description: Pontarius XMPP is a work in progress implementation of RFC 6120 + ("XMPP CORE"), RFC 6121 ("XMPP IM"), and RFC 6122 ("XMPP ADDR"). + While in alpha, Pontarius XMPP works quite well and fulfills most + requirements of the RFCs. Category: Network -Tested-With: GHC ==7.0.4, GHC ==7.4.1 +Tested-With: GHC >=7.0.1 && <=7.6.3 Extra-Source-Files: README.md , examples/echoclient/echoclient.cabal @@ -25,50 +27,74 @@ , examples/echoclient/README.md , examples/echoclient/Setup.hs +Flag with-th { + Description: Enable Template Haskell support + Default: True +} + Library hs-source-dirs: source Exposed: True - Build-Depends: attoparsec >=0.10.0.3 - , base >4 && <5 - , base64-bytestring >=0.1.0.0 - , binary >=0.4.1 - , bytestring >=0.9.1.9 - , conduit >=0.5 && <1.0 - , containers >=0.4.0.0 - , crypto-api >=0.9 - , crypto-random-api >=0.2 - , cryptohash >=0.6.1 - , data-default >=0.2 - , dns >=0.3.0 - , hslogger >=1.1.0 - , iproute >=1.2.4 - , lifted-base >=0.1.0.1 - , mtl >=2.0.0.0 - , network >=2.3 - , pureMD5 >=2.1.2.1 - , resourcet >=0.3.0 - , random >=1.0.0.0 - , split >=0.1.2.3 - , stm >=2.1.2.1 - , stringprep >=0.1.3 - , text >=0.11.1.5 - , tls >=1.1.0 - , tls-extra >=0.5.0 - , transformers >=0.2.2.0 - , void >=0.5.5 - , xml-types >=0.3.1 - , xml-conduit >=1.0 - , xml-picklers >=0.3 + + -- The only different between the below two blocks is that the first one caps + -- the range for the `bytestring' package, and that the second one includes + -- `template-haskell' for GHC 7.6.1 and above. + + Build-Depends: attoparsec >=0.10.0.3 + , base >4 && <5 + , base64-bytestring >=0.1.0.0 + , binary >=0.4.1 + , conduit >=1.0.1 + , containers >=0.4.0.0 + , crypto-api >=0.9 + , crypto-random-api >=0.2 + , cryptohash >=0.6.1 + , cryptohash-cryptoapi >=0.1 + , data-default >=0.2 + , dns >=0.3.0 + , hslogger >=1.1.0 + , iproute >=1.2.4 + , lifted-base >=0.1.0.1 + , mtl >=2.0.0.0 + , network >=2.4.1.0 + , pureMD5 >=2.1.2.1 + , resourcet >=0.3.0 + , random >=1.0.0.0 + , split >=0.1.2.3 + , stm >=2.1.2.1 + , stringprep >=0.1.3 + , text >=0.11.1.5 + , tls >=1.1.0 + , tls-extra >=0.5.0 + , transformers >=0.2.2.0 + , void >=0.5.5 + , xml-types >=0.3.1 + , xml-conduit >=1.1.0.7 + , xml-picklers >=0.3.3 + + If impl(ghc ==7.0.1) { + Build-Depends: bytestring >=0.9.1.9 && <=0.9.2.1 + } Else { + Build-Depends: bytestring >=0.9.1.9 + } + If flag(with-th) && impl(ghc >=7.6.1) { + Build-Depends: template-haskell >=2.5 + } Exposed-modules: Network.Xmpp + , Network.Xmpp.IM , Network.Xmpp.Internal Other-modules: Network.Xmpp.Concurrent - , Network.Xmpp.Concurrent.Types , Network.Xmpp.Concurrent.Basic , Network.Xmpp.Concurrent.IQ , Network.Xmpp.Concurrent.Message + , Network.Xmpp.Concurrent.Monad , Network.Xmpp.Concurrent.Presence , Network.Xmpp.Concurrent.Threads - , Network.Xmpp.Concurrent.Monad + , Network.Xmpp.Concurrent.Types + , Network.Xmpp.IM.Message + , Network.Xmpp.IM.Presence + , Network.Xmpp.IM.Roster + , Network.Xmpp.IM.Roster.Types , Network.Xmpp.Marshal , Network.Xmpp.Sasl , Network.Xmpp.Sasl.Common @@ -78,17 +104,21 @@ , Network.Xmpp.Sasl.Mechanisms.Scram , Network.Xmpp.Sasl.StringPrep , Network.Xmpp.Sasl.Types + , Network.Xmpp.Stanza , Network.Xmpp.Stream , Network.Xmpp.Tls , Network.Xmpp.Types , Network.Xmpp.Utilities + + if flag(with-th) && impl(ghc >= 7.6.1) + CPP-Options: -DWITH_TEMPLATE_HASKELL GHC-Options: -Wall Source-Repository head Type: git - Location: git://github.com/jonkri/pontarius-xmpp.git + Location: git://github.com/pontarius/pontarius-xmpp.git Source-Repository this Type: git - Location: git://github.com/jonkri/pontarius-xmpp.git - Tag: 0.2.0.1 + Location: git://github.com/pontarius/pontarius-xmpp.git + Tag: 0.3.0.0 diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -21,14 +21,22 @@ -- For low-level access to Pontarius XMPP, see the "Network.Xmpp.Internal" -- module. -{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} +{-# LANGUAGE CPP, NoMonomorphismRestriction, OverloadedStrings #-} module Network.Xmpp ( -- * Session management Session , session + , setConnectionClosedHandler + , reconnect + , reconnect' + , reconnectNow , StreamConfiguration(..) , SessionConfiguration(..) + , ConnectionDetails(..) + , closeConnection + , endSession + , waitForStream -- TODO: Close session, etc. -- ** Authentication handlers -- | The use of 'scramSha1' is /recommended/, but 'digestMd5' might be @@ -40,11 +48,22 @@ -- | A JID (historically: Jabber ID) is XMPPs native format -- for addressing entities in the network. It is somewhat similar to an e-mail -- address, but contains three parts instead of two. - , Jid(..) + , Jid +#if WITH_TEMPLATE_HASKELL + , jidQ +#endif , isBare , isFull , jidFromText , jidFromTexts + , jidToText + , jidToTexts + , toBare + , localpart + , domainpart + , resourcepart + , parseJid + , getJid -- * Stanzas -- | The basic protocol data unit in XMPP is the XML stanza. The stanza is -- essentially a fragment of XML that is sent over a stream. @Stanzas@ come in @@ -74,13 +93,16 @@ -- presence, or IQ stanza. The particular allowable values for the 'type' -- attribute vary depending on whether the stanza is a message, presence, -- or IQ stanza. - + , getStanza + , getStanzaChan + , newStanzaID -- ** Messages -- | The /message/ stanza is a /push/ mechanism whereby one entity -- pushes information to another entity, similar to the communications that -- occur in a system such as email. It is not to be confused with -- /instant messaging/ which is handled in the 'Network.Xmpp.IM' module , Message(..) + , message , MessageError(..) , MessageType(..) -- *** Creating @@ -102,6 +124,12 @@ , PresenceType(..) , PresenceError(..) -- *** Creating + , presence + , presenceOffline + , presenceOnline + , presenceSubscribe + , presenceSubscribed + , presenceUnsubscribe , presTo -- *** Sending -- | Sends a presence stanza. In general, the presence stanza should have no @@ -137,16 +165,19 @@ , sendIQ' , answerIQ , listenIQChan - , iqRequestPayload - , iqResultPayload + , dropIQChan -- * Errors , StanzaError(..) , StanzaErrorType(..) , StanzaErrorCondition(..) + , SaslFailure(..) -- * Threads , dupSession -- * Miscellaneous - , LangTag(..) + , LangTag + , langTagFromText + , langTagToText + , parseLangTag , XmppFailure(..) , StreamErrorInfo(..) , StreamErrorCondition(..) @@ -154,12 +185,14 @@ , AuthSaslFailure , AuthIllegalCredentials , AuthOtherFailure ) + , SaslHandler + , ConnectionState(..) + , connectTls ) where -import Network import Network.Xmpp.Concurrent -import Network.Xmpp.Utilities import Network.Xmpp.Sasl import Network.Xmpp.Sasl.Types -import Network.Xmpp.Tls +import Network.Xmpp.Stanza import Network.Xmpp.Types +import Network.Xmpp.Tls diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -10,51 +10,50 @@ , module Network.Xmpp.Concurrent.IQ , StanzaHandler , newSession - , writeWorker , session + , newStanzaID + , reconnect + , reconnect' + , reconnectNow ) where -import Control.Applicative((<$>),(<*>)) -import Control.Concurrent +import Control.Applicative ((<$>)) +import Control.Arrow (second) +import Control.Concurrent (threadDelay) import Control.Concurrent.STM +import qualified Control.Exception as Ex import Control.Monad -import qualified Data.ByteString as BS -import Data.IORef +import Control.Monad.Error import qualified Data.Map as Map import Data.Maybe -import Data.Maybe (fromMaybe) import Data.Text as Text import Data.XML.Types import Network -import qualified Network.TLS as TLS import Network.Xmpp.Concurrent.Basic import Network.Xmpp.Concurrent.IQ import Network.Xmpp.Concurrent.Message import Network.Xmpp.Concurrent.Monad import Network.Xmpp.Concurrent.Presence import Network.Xmpp.Concurrent.Threads -import Network.Xmpp.Concurrent.Threads import Network.Xmpp.Concurrent.Types -import Network.Xmpp.Marshal +import Network.Xmpp.IM.Roster +import Network.Xmpp.IM.Roster.Types import Network.Xmpp.Sasl -import Network.Xmpp.Sasl.Mechanisms import Network.Xmpp.Sasl.Types import Network.Xmpp.Stream import Network.Xmpp.Tls import Network.Xmpp.Types -import Network.Xmpp.Utilities - -import Control.Monad.Error -import Data.Default import System.Log.Logger +import System.Random (randomRIO) + import Control.Monad.State.Strict -runHandlers :: (TChan Stanza) -> [StanzaHandler] -> Stanza -> IO () +runHandlers :: WriteSemaphore -> [StanzaHandler] -> Stanza -> IO () runHandlers _ [] _ = return () -runHandlers outC (h:hands) sta = do - res <- h outC sta +runHandlers sem (h:hands) sta = do + res <- h sem sta case res of - True -> runHandlers outC hands sta + True -> runHandlers sem hands sta False -> return () toChan :: TChan Stanza -> StanzaHandler @@ -65,7 +64,7 @@ handleIQ :: TVar IQHandlers -> StanzaHandler -handleIQ iqHands outC sta = atomically $ do +handleIQ iqHands writeSem sta = do case sta of IQRequestS i -> handleIQRequest iqHands i >> return False IQResultS i -> handleIQResponse iqHands (Right i) >> return False @@ -73,21 +72,49 @@ _ -> return True where -- If the IQ request has a namespace, send it through the appropriate channel. - handleIQRequest :: TVar IQHandlers -> IQRequest -> STM () + handleIQRequest :: TVar IQHandlers -> IQRequest -> IO () handleIQRequest handlers iq = do - (byNS, _) <- readTVar handlers - let iqNS = fromMaybe "" (nameNamespace . elementName $ iqRequestPayload iq) - case Map.lookup (iqRequestType iq, iqNS) byNS of - Nothing -> writeTChan outC $ serviceUnavailable iq - Just ch -> do - sent <- newTVar False - writeTChan ch $ IQRequestTicket sent iq + out <- atomically $ do + (byNS, _) <- readTVar handlers + let iqNS = fromMaybe "" (nameNamespace . elementName + $ iqRequestPayload iq) + case Map.lookup (iqRequestType iq, iqNS) byNS of + Nothing -> return . Just $ serviceUnavailable iq + Just ch -> do + sentRef <- newTMVar False + let answerT answer = do + let IQRequest iqid from _to lang _tp bd = iq + response = case answer of + Left er -> IQErrorS $ IQError iqid Nothing + from lang er + (Just bd) + Right res -> IQResultS $ IQResult iqid Nothing + from lang res + Ex.bracketOnError (atomically $ takeTMVar sentRef) + (atomically . putTMVar sentRef) + $ \wasSent -> do + case wasSent of + True -> do + atomically $ putTMVar sentRef True + return Nothing + False -> do + didSend <- writeStanza writeSem response + case didSend of + True -> do + atomically $ putTMVar sentRef True + return $ Just True + False -> do + atomically $ putTMVar sentRef False + return $ Just False + writeTChan ch $ IQRequestTicket answerT iq + return Nothing + maybe (return ()) (void . writeStanza writeSem) out serviceUnavailable (IQRequest iqid from _to lang _tp bd) = IQErrorS $ IQError iqid Nothing from lang err (Just bd) err = StanzaError Cancel ServiceUnavailable Nothing Nothing - handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> STM () - handleIQResponse handlers iq = do + handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> IO () + handleIQResponse handlers iq = atomically $ do (byNS, byID) <- readTVar handlers case Map.updateLookupWithKey (\_ _ -> Nothing) (iqID iq) byID of (Nothing, _) -> return () -- We are not supposed to send an error. @@ -96,68 +123,186 @@ _ <- tryPutTMVar tmvar answer -- Don't block. writeTVar handlers (byNS, byID') where - iqID (Left err) = iqErrorID err + iqID (Left err') = iqErrorID err' iqID (Right iq') = iqResultID iq' -- | Creates and initializes a new Xmpp context. -newSession :: Stream -> SessionConfiguration -> IO (Either XmppFailure Session) -newSession stream config = runErrorT $ do - outC <- lift newTChanIO +newSession :: Stream + -> SessionConfiguration + -> HostName + -> Maybe (ConnectionState -> [SaslHandler] , Maybe Text) + -> IO (Either XmppFailure Session) +newSession stream config realm mbSasl = runErrorT $ do + write' <- liftIO $ withStream' (gets $ streamSend . streamHandle) stream + writeSem <- liftIO $ newTMVarIO write' stanzaChan <- lift newTChanIO - iqHandlers <- lift $ newTVarIO (Map.empty, Map.empty) - eh <- lift $ newTVarIO $ EventHandlers { connectionClosedHandler = sessionClosedHandler config } - let stanzaHandler = runHandlers outC $ Prelude.concat [ [toChan stanzaChan] - , extraStanzaHandlers - config - , [handleIQ iqHandlers] - ] - (kill, wLock, streamState, readerThread) <- ErrorT $ startThreadsWith stanzaHandler eh stream - writer <- lift $ forkIO $ writeWorker outC wLock + iqHands <- lift $ newTVarIO (Map.empty, Map.empty) + eh <- lift $ newEmptyTMVarIO + ros <- liftIO . newTVarIO $ Roster Nothing Map.empty + rew <- lift $ newTVarIO 60 + let rosterH = if (enableRoster config) then handleRoster ros + else \ _ _ -> return True + let stanzaHandler = runHandlers writeSem + $ Prelude.concat [ [ toChan stanzaChan ] + , extraStanzaHandlers + config + , [ handleIQ iqHands + , rosterH + ] + ] + (kill, wLock, streamState, reader) <- ErrorT $ startThreadsWith writeSem stanzaHandler eh stream idGen <- liftIO $ sessionStanzaIDs config - return $ Session { stanzaCh = stanzaChan - , outCh = outC - , iqHandlers = iqHandlers - , writeRef = wLock - , readerThread = readerThread + let sess = Session { stanzaCh = stanzaChan + , iqHandlers = iqHands + , writeSemaphore = wLock + , readerThread = reader , idGenerator = idGen , streamRef = streamState , eventHandlers = eh - , stopThreads = kill >> killThread writer + , stopThreads = kill , conf = config + , rosterRef = ros + , sRealm = realm + , sSaslCredentials = mbSasl + , reconnectWait = rew } + liftIO . atomically $ putTMVar eh $ EventHandlers { connectionClosedHandler = + onConnectionClosed config sess } + return sess --- Worker to write stanzas to the stream concurrently. -writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO Bool) -> IO () -writeWorker stCh writeR = forever $ do - (write, next) <- atomically $ (,) <$> - takeTMVar writeR <*> - readTChan stCh - r <- write $ renderElement (pickleElem xpStanza next) - atomically $ putTMVar writeR write - unless r $ do - atomically $ unGetTChan stCh next -- If the writing failed, the - -- connection is dead. - threadDelay 250000 -- Avoid free spinning. +connectStream :: HostName + -> SessionConfiguration + -> Maybe (ConnectionState -> [SaslHandler], Maybe Text) + -> IO (Either XmppFailure Stream) +connectStream realm config mbSasl = do + Ex.bracketOnError (openStream realm (sessionStreamConfiguration config)) + (\s -> case s of + Left _ -> return () + Right stream -> closeStreams stream) + (\stream' -> case stream' of + Left e -> return $ Left e + Right stream -> do + res <- runErrorT $ do + ErrorT $ tls stream + cs <- liftIO $ withStream (gets streamConnectionState) + stream + mbAuthError <- case mbSasl of + Nothing -> return Nothing + Just (handlers, resource) -> ErrorT $ auth (handlers cs) + resource stream + case mbAuthError of + Nothing -> return () + Just e -> throwError $ XmppAuthFailure e + return stream + case res of + Left e -> do + debugM "Pontarius.Xmpp" "Closing stream after error" + closeStreams stream + return (Left e) + Right r -> return $ Right r + ) + -- | Creates a 'Session' object by setting up a connection with an XMPP server. -- -- Will connect to the specified host with the provided configuration. If the -- third parameter is a 'Just' value, @session@ will attempt to authenticate and -- acquire an XMPP resource. session :: HostName -- ^ The hostname / realm + -> Maybe (ConnectionState -> [SaslHandler] , Maybe Text) + -- ^ SASL handlers and the desired JID resource (or Nothing to let + -- the server decide) -> SessionConfiguration -- ^ configuration details - -> Maybe ([SaslHandler], Maybe Text) -- ^ SASL handlers and the desired - -- JID resource (or Nothing to let - -- the server decide) -> IO (Either XmppFailure Session) -session realm config mbSasl = runErrorT $ do - stream <- ErrorT $ openStream realm (sessionStreamConfiguration config) - ErrorT $ tls stream - mbAuthError <- case mbSasl of - Nothing -> return Nothing - Just (handlers, resource) -> ErrorT $ auth handlers resource stream - case mbAuthError of - Nothing -> return () - Just _ -> throwError XmppAuthFailure - ses <- ErrorT $ newSession stream config +session realm mbSasl config = runErrorT $ do + stream <- ErrorT $ connectStream realm config mbSasl + ses <- ErrorT $ newSession stream config realm mbSasl + liftIO $ when (enableRoster config) $ initRoster ses return ses + +-- | Reconnect immediately with the stored settings. Returns @Just@ the error +-- when the reconnect attempt fails and Nothing when no failure was encountered. +-- +-- This function does not set your presence to online, so you will have to do +-- this yourself. +reconnectNow :: Session -- ^ session to reconnect + -> IO (Maybe XmppFailure) +reconnectNow sess@Session{conf = config, reconnectWait = rw} = do + debugM "Pontarius.Xmpp" "reconnecting" + res <- flip withConnection sess $ \oldStream -> do + debugM "Pontarius.Xmpp" "reconnect: closing stream" + closeStreams oldStream + debugM "Pontarius.Xmpp" "reconnect: opening stream" + s <- connectStream (sRealm sess) config (sSaslCredentials sess) + case s of + Left e -> do + errorM "Pontarius.Xmpp" $ "reconnect failed" ++ show e + return (Left e , oldStream ) + Right r -> return (Right () , r ) + case res of + Left e -> return $ Just e + Right (Left e) -> return $ Just e + Right (Right ()) -> do + atomically $ writeTVar rw 60 + when (enableRoster config) $ initRoster sess + return Nothing + + +-- | Reconnect with the stored settings. +-- +-- Waits a random amount of seconds (between 0 and 60 inclusive) before the +-- first attempt and an increasing amount after each attempt after that. Caps +-- out at 2-5 minutes. +-- +-- This function does not set your presence to online, so you will have to do +-- this yourself. +reconnect :: Integer -- ^ Maximum number of retries (numbers of 1 or less will + -- perform exactly one retry) + -> Session -- ^ Session to reconnect + -> IO (Bool, [XmppFailure]) -- ^ Whether or not the reconnect attempt + -- was successful, and a list of failure + -- modes encountered +reconnect maxTries sess = go maxTries + where + go t = do + res <- doRetry sess + case res of + Nothing -> return (True, []) + Just e -> if (t > 1) then (second (e:)) <$> go (t - 1) + else return $ (False, [e]) + +-- | Reconnect with the stored settings with an unlimited number of retries. +-- +-- Waits a random amount of seconds (between 0 and 60 inclusive) before the +-- first attempt and an increasing amount after each attempt after that. Caps +-- out at 2-5 minutes. +-- +-- This function does not set your presence to online, so you will have to do +-- this yourself. +reconnect' :: Session -- ^ Session to reconnect + -> IO Integer -- ^ Number of failed retries before connection could be + -- established +reconnect' sess = go 0 + where + go i = do + res <- doRetry sess + case res of + Nothing -> return i + Just _e -> go (i+1) + +doRetry :: Session -> IO (Maybe XmppFailure) +doRetry sess@Session{reconnectWait = rw} = do + wait <- atomically $ do + wt <- readTVar rw + writeTVar rw $ min 300 (2 * wt) + return wt + t <- randomRIO (wait `div` 2 - 30, max 60 wait) + debugM "Pontarius.Xmpp" $ + "Waiting " ++ show t ++ " seconds before reconnecting" + threadDelay $ t * 10^(6 :: Int) + reconnectNow sess + +-- | Generates a new stanza identifier based on the 'sessionStanzaIDs' field of +-- 'SessionConfiguration'. +newStanzaID :: Session -> IO Text +newStanzaID = idGenerator diff --git a/source/Network/Xmpp/Concurrent/Basic.hs b/source/Network/Xmpp/Concurrent/Basic.hs --- a/source/Network/Xmpp/Concurrent/Basic.hs +++ b/source/Network/Xmpp/Concurrent/Basic.hs @@ -1,16 +1,63 @@ {-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Concurrent.Basic where -import Control.Concurrent.STM -import Network.Xmpp.Concurrent.Types -import Network.Xmpp.Types +import Control.Concurrent.STM +import qualified Control.Exception as Ex +import Control.Monad.State.Strict +import qualified Data.ByteString as BS +import Network.Xmpp.Concurrent.Types +import Network.Xmpp.Marshal +import Network.Xmpp.Stream +import Network.Xmpp.Types +import Network.Xmpp.Utilities +semWrite :: WriteSemaphore -> BS.ByteString -> IO Bool +semWrite sem bs = Ex.bracket (atomically $ takeTMVar sem) + (atomically . putTMVar sem) + ($ bs) + +writeStanza :: WriteSemaphore -> Stanza -> IO Bool +writeStanza sem a = do + let outData = renderElement $ nsHack (pickleElem xpStanza a) + semWrite sem outData + -- | Send a stanza to the server. -sendStanza :: Stanza -> Session -> IO () -sendStanza a session = atomically $ writeTChan (outCh session) a +sendStanza :: Stanza -> Session -> IO Bool +sendStanza a session = writeStanza (writeSemaphore session) a + +-- | Get the channel of incoming stanzas. +getStanzaChan :: Session -> TChan Stanza +getStanzaChan session = stanzaCh session + +-- | Get the next incoming stanza +getStanza :: Session -> IO Stanza +getStanza session = atomically . readTChan $ stanzaCh session + -- | Create a new session object with the inbound channel duplicated dupSession :: Session -> IO Session dupSession session = do stanzaCh' <- atomically $ dupTChan (stanzaCh session) return $ session {stanzaCh = stanzaCh'} + +-- | Return the JID assigned to us by the server +getJid :: Session -> IO (Maybe Jid) +getJid Session{streamRef = st} = do + s <- atomically $ readTMVar st + withStream' (gets streamJid) s + +-- | Return the JID assigned to us by the server +getFeatures :: Session -> IO StreamFeatures +getFeatures Session{streamRef = st} = do + s <- atomically $ readTMVar st + withStream' (gets streamFeatures) s + +-- | Wait until the connection of the stream is re-established +waitForStream :: Session -> IO () +waitForStream Session{streamRef = sr} = atomically $ do + s <- readTMVar sr + ss <- readTMVar $ unStream s + case streamConnectionState ss of + Plain -> return () + Secured -> return () + _ -> retry diff --git a/source/Network/Xmpp/Concurrent/IQ.hs b/source/Network/Xmpp/Concurrent/IQ.hs --- a/source/Network/Xmpp/Concurrent/IQ.hs +++ b/source/Network/Xmpp/Concurrent/IQ.hs @@ -4,8 +4,6 @@ import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.STM import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader import qualified Data.Map as Map import Data.Text (Text) @@ -15,16 +13,20 @@ import Network.Xmpp.Concurrent.Types import Network.Xmpp.Types --- | Sends an IQ, returns a 'TMVar' that will be filled with the first inbound --- IQ with a matching ID that has type @result@ or @error@. -sendIQ :: Maybe Int -- ^ Timeout +-- | Sends an IQ, returns Just a 'TMVar' that will be filled with the first +-- inbound IQ with a matching ID that has type @result@ or @error@ or Nothing if +-- the stanza could not be sent +sendIQ :: Maybe Int -- ^ Timeout . When the timeout is reached the response + -- TMVar will be filled with 'IQResponseTimeout' and the id + -- is removed from the list of IQ handlers. 'Nothing' + -- deactivates the timeout -> Maybe Jid -- ^ Recipient (to) -> IQRequestType -- ^ IQ type (@Get@ or @Set@) -> Maybe LangTag -- ^ Language tag of the payload (@Nothing@ for -- default) -> Element -- ^ The IQ body (there has to be exactly one) -> Session - -> IO (TMVar IQResponse) + -> IO (Maybe (TMVar IQResponse)) sendIQ timeOut to tp lang body session = do -- TODO: Add timeout newId <- idGenerator session ref <- atomically $ do @@ -33,13 +35,16 @@ writeTVar (iqHandlers session) (byNS, Map.insert newId resRef byId) -- TODO: Check for id collisions (shouldn't happen?) return resRef - sendStanza (IQRequestS $ IQRequest newId Nothing to lang tp body) session - case timeOut of - Nothing -> return () - Just t -> void . forkIO $ do - threadDelay t - doTimeOut (iqHandlers session) newId ref - return ref + res <- sendStanza (IQRequestS $ IQRequest newId Nothing to lang tp body) session + if res + then do + case timeOut of + Nothing -> return () + Just t -> void . forkIO $ do + threadDelay t + doTimeOut (iqHandlers session) newId ref + return $ Just ref + else return Nothing where doTimeOut handlers iqid var = atomically $ do p <- tryPutTMVar var IQResponseTimeout @@ -49,24 +54,29 @@ return () --- | Like 'sendIQ', but waits for the answer IQ. Times out after 3 seconds +-- | Like 'sendIQ', but waits for the answer IQ. Times out after 30 seconds sendIQ' :: Maybe Jid -> IQRequestType -> Maybe LangTag -> Element -> Session - -> IO IQResponse + -> IO (Maybe IQResponse) sendIQ' to tp lang body session = do - ref <- sendIQ (Just 3000000) to tp lang body session - atomically $ takeTMVar ref + ref <- sendIQ (Just 30000000) to tp lang body session + maybe (return Nothing) (fmap Just . atomically . takeTMVar) ref -- | Retrieves an IQ listener channel. If the namespace/'IQRequestType' is not -- already handled, a new 'TChan' is created and returned as a 'Right' value. -- Otherwise, the already existing channel will be returned wrapped in a 'Left' --- value. Note that the 'Left' channel might need to be duplicated in order not +-- value. The 'Left' channel might need to be duplicated in order not -- to interfere with existing consumers. -listenIQChan :: IQRequestType -- ^ Type of IQs to receive (@Get@ or @Set@) +-- +-- Note thet every 'IQRequest' must be answered exactly once. To insure this, +-- the incoming requests are wrapped in an 'IQRequestTicket' that prevents +-- multiple responses. Use 'iqRequestBody' to extract the corresponding request +-- and 'answerIQ' to send the response +listenIQChan :: IQRequestType -- ^ Type of IQs to receive ('Get' or 'Set') -> Text -- ^ Namespace of the child element -> Session -> IO (Either (TChan IQRequestTicket) (TChan IQRequestTicket)) @@ -85,23 +95,27 @@ Nothing -> Right iqCh Just iqCh' -> Left iqCh' +-- | Unregister a previously acquired IQ channel. Please make sure that you +-- where the one who acquired it in the first place as no check for ownership +-- can be made +dropIQChan :: IQRequestType -- ^ Type of IQ ('Get' or 'Set') + -> Text -- ^ Namespace of the child element + -> Session + -> IO () +dropIQChan tp ns session = do + let handlers = (iqHandlers session) + atomically $ do + (byNS, byID) <- readTVar handlers + let byNS' = Map.delete (tp, ns) byNS + writeTVar handlers (byNS', byID) + return () + +-- | Answer an IQ request. Only the first answer ist sent and Just True is +-- returned when the answer is sucessfully sent. If an error occured during +-- sending Just False is returned (and another attempt can be +-- undertaken). Subsequent answers after the first sucessful one are dropped and +-- (False is returned in that case) answerIQ :: IQRequestTicket -> Either StanzaError (Maybe Element) - -> Session - -> IO Bool -answerIQ (IQRequestTicket - sentRef - (IQRequest iqid from _to lang _tp bd)) - answer session = do - let response = case answer of - Left err -> IQErrorS $ IQError iqid Nothing from lang err (Just bd) - Right res -> IQResultS $ IQResult iqid Nothing from lang res - atomically $ do - sent <- readTVar sentRef - case sent of - False -> do - writeTVar sentRef True - - writeTChan (outCh session) response - return True - True -> return False + -> IO (Maybe Bool) +answerIQ ticket = answerTicket ticket diff --git a/source/Network/Xmpp/Concurrent/Message.hs b/source/Network/Xmpp/Concurrent/Message.hs --- a/source/Network/Xmpp/Concurrent/Message.hs +++ b/source/Network/Xmpp/Concurrent/Message.hs @@ -3,9 +3,7 @@ import Network.Xmpp.Concurrent.Types import Control.Concurrent.STM -import Data.IORef import Network.Xmpp.Types -import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Basic -- | Read an element from the inbound stanza channel, discardes any @@ -54,6 +52,7 @@ Right m | g m -> return $ Right m | otherwise -> filterMessages f g session --- | Send a message stanza. -sendMessage :: Message -> Session -> IO () +-- | Send a message stanza. Returns @False@ when the 'Message' could not be +-- sent. +sendMessage :: Message -> Session -> IO Bool sendMessage m session = sendStanza (MessageS m) session diff --git a/source/Network/Xmpp/Concurrent/Monad.hs b/source/Network/Xmpp/Concurrent/Monad.hs --- a/source/Network/Xmpp/Concurrent/Monad.hs +++ b/source/Network/Xmpp/Concurrent/Monad.hs @@ -2,98 +2,117 @@ {-# LANGUAGE OverloadedStrings #-} module Network.Xmpp.Concurrent.Monad where -import Network.Xmpp.Types - +import Control.Applicative ((<$>)) +import Control.Concurrent import Control.Concurrent.STM import qualified Control.Exception.Lifted as Ex -import Control.Monad.Reader - +import Control.Monad.State import Network.Xmpp.Concurrent.Types import Network.Xmpp.Stream - - - +import Network.Xmpp.Types -- TODO: Wait for presence error? --- -- | Run an XmppConMonad action in isolation. Reader and writer workers will be --- -- temporarily stopped and resumed with the new session details once the action --- -- returns. The action will run in the calling thread. Any uncaught exceptions --- -- will be interpreted as connection failure. +-- | Run an XmppConMonad action in isolation. Reader and writer workers will be +-- temporarily stopped and resumed with the new session details once the action +-- returns. The action will run in the calling thread. Any uncaught exceptions +-- will be interpreted as connection failure. -- withConnection :: XmppConMonad a -> Context -> IO (Either StreamError a) --- withConnection a session = do --- wait <- newEmptyTMVarIO --- Ex.mask_ $ do --- -- Suspends the reader until the lock (wait) is released (set to `()'). --- throwTo (readerThread session) $ Interrupt wait --- -- We acquire the write and stateRef locks, to make sure that this is --- -- the only thread that can write to the stream and to perform a --- -- withConnection calculation. Afterwards, we release the lock and --- -- fetches an updated state. --- s <- Ex.catch --- (atomically $ do --- _ <- takeTMVar (writeRef session) --- s <- takeTMVar (conStateRef session) --- putTMVar wait () --- return s --- ) --- -- If we catch an exception, we have failed to take the MVars above. --- (\e -> atomically (putTMVar wait ()) >> --- Ex.throwIO (e :: Ex.SomeException) --- ) --- -- Run the XmppMonad action, save the (possibly updated) states, release --- -- the locks, and return the result. --- Ex.catches --- (do --- (res, s') <- runStateT a s --- atomically $ do --- putTMVar (writeRef session) (cSend . sCon $ s') --- putTMVar (conStateRef session) s' --- return $ Right res --- ) --- -- We treat all Exceptions as fatal. If we catch a StreamError, we --- -- return it. Otherwise, we throw an exception. --- [ Ex.Handler $ \e -> return $ Left (e :: StreamError) --- , Ex.Handler $ \e -> runStateT xmppKillConnection s --- >> Ex.throwIO (e :: Ex.SomeException) --- ] +withConnection :: (Stream -> IO (b, Stream)) + -> Session + -> IO (Either XmppFailure b) +withConnection a session = do + wait <- newEmptyTMVarIO + Ex.mask_ $ do + -- Suspends the reader until the lock (wait) is released (set to `()'). + throwTo (readerThread session) $ Interrupt wait + -- We acquire the write and stateRef locks, to make sure that this is + -- the only thread that can write to the stream and to perform a + -- withConnection calculation. Afterwards, we release the lock and + -- fetches an updated state. + s <- Ex.catch + (atomically $ do + _ <- takeTMVar (writeSemaphore session) + s <- takeTMVar (streamRef session) + putTMVar wait () + return s + ) + -- If we catch an exception, we have failed to take the MVars above. + (\e -> atomically (putTMVar wait ()) >> + Ex.throwIO (e :: Ex.SomeException) + ) + -- Run the XmppMonad action, save the (possibly updated) states, release + -- the locks, and return the result. + Ex.catches + (do + (res, s') <- a s + wl <- withStream' (gets $ streamSend . streamHandle) s' + atomically $ do + putTMVar (writeSemaphore session) wl + putTMVar (streamRef session) s' + return $ Right res + ) -- TODO: DO we have to replace the MVars in case of ane exception? + -- We treat all Exceptions as fatal. If we catch a StreamError, we + -- return it. Otherwise, we throw an exception. + [ Ex.Handler $ \e -> return $ Left (e :: XmppFailure) + , Ex.Handler $ \e -> killStream s + >> Ex.throwIO (e :: Ex.SomeException) + ] -- | Executes a function to update the event handlers. modifyHandlers :: (EventHandlers -> EventHandlers) -> Session -> IO () -modifyHandlers f session = atomically $ modifyTVar (eventHandlers session) f +modifyHandlers f session = atomically $ modifyTMVar_ (eventHandlers session) f where -- Borrowing modifyTVar from -- http://hackage.haskell.org/packages/archive/stm/2.4/doc/html/src/Control-Concurrent-STM-TVar.html -- as it's not available in GHC 7.0. - modifyTVar :: TVar a -> (a -> a) -> STM () - modifyTVar var f = do - x <- readTVar var - writeTVar var (f x) + modifyTMVar_ :: TMVar a -> (a -> a) -> STM () + modifyTMVar_ var g = do + x <- takeTMVar var + putTMVar var (g x) --- | Sets the handler to be executed when the server connection is closed. -setConnectionClosedHandler_ :: (XmppFailure -> Session -> IO ()) -> Session -> IO () -setConnectionClosedHandler_ eh session = do +-- | Changes the handler to be executed when the server connection is closed. To +-- avoid race conditions the initial value should be set in the configuration +-- when creating the session +setConnectionClosedHandler :: (XmppFailure -> Session -> IO ()) -> Session -> IO () +setConnectionClosedHandler eh session = do modifyHandlers (\s -> s{connectionClosedHandler = \e -> eh e session}) session +runConnectionClosedHandler :: Session -> XmppFailure -> IO () +runConnectionClosedHandler session e = do + h <- connectionClosedHandler <$> atomically (readTMVar + $ eventHandlers session) + h e + -- | Run an event handler. runHandler :: (EventHandlers -> IO a) -> Session -> IO a -runHandler h session = h =<< atomically (readTVar $ eventHandlers session) +runHandler h session = h =<< atomically (readTMVar $ eventHandlers session) --- | End the current Xmpp session. -endContext :: Session -> IO () -endContext session = do -- TODO: This has to be idempotent (is it?) - closeConnection session +-- | End the current XMPP session. Kills the associated threads and closes the +-- connection. +-- +-- Note that XMPP clients (that has signalled availability) should send +-- \"Unavailable\" presence prior to disconnecting. +-- +-- The connectionClosedHandler will not be called (to avoid possibly +-- reestablishing the connection). +endSession :: Session -> IO () +endSession session = do -- TODO: This has to be idempotent (is it?) stopThreads session + _ <- flip withConnection session $ \stream -> do + _ <- closeStreams stream + return ((), stream) + return () + -- | Close the connection to the server. Closes the stream (by enforcing a --- write lock and sending a element), waits (blocks) for three --- seconds, and then closes the connection. +-- write lock and sending a \ element), waits (blocks) for +-- three seconds, and then closes the connection. closeConnection :: Session -> IO () -closeConnection session = Ex.mask_ $ do - (_send, connection) <- atomically $ liftM2 (,) - (takeTMVar $ writeRef session) - (takeTMVar $ streamRef session) - _ <- closeStreams connection - return () +closeConnection session = do + _ <-flip withConnection session $ \stream -> do + _ <- closeStreams stream + return ((), stream) + runConnectionClosedHandler session StreamEndFailure diff --git a/source/Network/Xmpp/Concurrent/Presence.hs b/source/Network/Xmpp/Concurrent/Presence.hs --- a/source/Network/Xmpp/Concurrent/Presence.hs +++ b/source/Network/Xmpp/Concurrent/Presence.hs @@ -2,7 +2,6 @@ module Network.Xmpp.Concurrent.Presence where import Control.Concurrent.STM -import Data.IORef import Network.Xmpp.Types import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Basic @@ -28,5 +27,5 @@ | otherwise -> waitForPresence f session -- | Send a presence stanza. -sendPresence :: Presence -> Session -> IO () +sendPresence :: Presence -> Session -> IO Bool sendPresence p session = sendStanza (PresenceS p) session diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -4,25 +4,17 @@ module Network.Xmpp.Concurrent.Threads where -import Network.Xmpp.Types - import Control.Applicative((<$>)) import Control.Concurrent import Control.Concurrent.STM import qualified Control.Exception.Lifted as Ex import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.State.Strict - +import Control.Monad.Error import qualified Data.ByteString as BS +import GHC.IO (unsafeUnmask) import Network.Xmpp.Concurrent.Types import Network.Xmpp.Stream - -import Control.Concurrent.STM.TMVar - -import GHC.IO (unsafeUnmask) - -import Control.Monad.Error +import Network.Xmpp.Types import System.Log.Logger -- Worker to read stanzas from the stream and concurrently distribute them to @@ -31,32 +23,48 @@ -> (XmppFailure -> IO ()) -> TMVar Stream -> IO a -readWorker onStanza onConnectionClosed stateRef = - Ex.mask_ . forever $ do - res <- Ex.catches ( do - -- we don't know whether pull will - -- necessarily be interruptible - s <- atomically $ do +readWorker onStanza onCClosed stateRef = forever . Ex.mask_ $ do + + s' <- Ex.catches ( do + -- we don't know whether pull will + -- necessarily be interruptible + atomically $ do s@(Stream con) <- readTMVar stateRef - state <- streamConnectionState <$> readTMVar con - when (state == Closed) + scs <- streamConnectionState <$> readTMVar con + when (stateIsClosed scs) retry - return s - allowInterrupt - Just <$> pullStanza s - ) - [ Ex.Handler $ \(Interrupt t) -> do - void $ handleInterrupts [t] - return Nothing - , Ex.Handler $ \(e :: XmppFailure) -> do - onConnectionClosed e - errorM "Pontarius.Xmpp" $ "Read error: " ++ show e - return Nothing - ] - case res of - Nothing -> return () -- Caught an exception, nothing to do. TODO: Can this happen? - Just (Left e) -> return () - Just (Right sta) -> onStanza sta + return $ Just s + ) + [ Ex.Handler $ \(Interrupt t) -> do + void $ handleInterrupts [t] + return Nothing + + ] + case s' of + Nothing -> return () + Just s -> do + res <- Ex.catches (do + allowInterrupt + Just <$> pullStanza s + ) + [ Ex.Handler $ \(Interrupt t) -> do + void $ handleInterrupts [t] + return Nothing + , Ex.Handler $ \(e :: XmppFailure) -> do + errorM "Pontarius.Xmpp" $ "Read error: " + ++ show e + _ <- closeStreams s + onCClosed e + return Nothing + ] + case res of + Nothing -> return () -- Caught an exception, nothing to + -- do. TODO: Can this happen? + Just (Left e) -> do + errorM "Pontarius.Xmpp" $ "Stanza error:" ++ show e + _ <- closeStreams s + onCClosed e + Just (Right sta) -> void $ onStanza sta where -- Defining an Control.Exception.allowInterrupt equivalent for GHC 7 -- compatibility. @@ -71,51 +79,54 @@ handleInterrupts ts = Ex.catch (atomically $ forM ts takeTMVar) (\(Interrupt t) -> handleInterrupts (t:ts)) + stateIsClosed Closed = True + stateIsClosed Finished = True + stateIsClosed _ = False + -- Two streams: input and output. Threads read from input stream and write to -- output stream. -- | Runs thread in XmppState monad. Returns channel of incoming and outgoing -- stances, respectively, and an Action to stop the Threads and close the -- connection. -startThreadsWith :: (Stanza -> IO ()) - -> TVar EventHandlers +startThreadsWith :: TMVar (BS.ByteString -> IO Bool) + -> (Stanza -> IO ()) + -> TMVar EventHandlers -> Stream -> IO (Either XmppFailure (IO (), TMVar (BS.ByteString -> IO Bool), TMVar Stream, ThreadId)) -startThreadsWith stanzaHandler eh con = do - read <- withStream' (gets $ streamSend . streamHandle >>= \d -> return $ Right d) con - case read of - Left e -> return $ Left e - Right read' -> do - writeLock <- newTMVarIO read' - conS <- newTMVarIO con - -- lw <- forkIO $ writeWorker outC writeLock - cp <- forkIO $ connPersist writeLock - rd <- forkIO $ readWorker stanzaHandler (noCon eh) conS - return $ Right ( killConnection writeLock [rd, cp] - , writeLock - , conS - , rd - ) +startThreadsWith writeSem stanzaHandler eh con = do + -- read' <- withStream' (gets $ streamSend . streamHandle) con + -- writeSem <- newTMVarIO read' + conS <- newTMVarIO con + cp <- forkIO $ connPersist writeSem + rdw <- forkIO $ readWorker stanzaHandler (noCon eh) conS + return $ Right ( killConnection [rdw, cp] + , writeSem + , conS + , rdw + ) where - killConnection writeLock threads = liftIO $ do - _ <- atomically $ takeTMVar writeLock -- Should we put it back? + killConnection threads = liftIO $ do + _ <- atomically $ do + _ <- takeTMVar writeSem + putTMVar writeSem $ \_ -> return False _ <- forM threads killThread return () -- Call the connection closed handlers. - noCon :: TVar EventHandlers -> XmppFailure -> IO () + noCon :: TMVar EventHandlers -> XmppFailure -> IO () noCon h e = do - hands <- atomically $ readTVar h + hands <- atomically $ readTMVar h _ <- forkIO $ connectionClosedHandler hands e return () -- Acquires the write lock, pushes a space, and releases the lock. -- | Sends a blank space every 30 seconds to keep the connection alive. connPersist :: TMVar (BS.ByteString -> IO Bool) -> IO () -connPersist lock = forever $ do - pushBS <- atomically $ takeTMVar lock +connPersist sem = forever $ do + pushBS <- atomically $ takeTMVar sem _ <- pushBS " " - atomically $ putTMVar lock pushBS + atomically $ putTMVar sem pushBS threadDelay 30000000 -- 30s diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -3,21 +3,47 @@ module Network.Xmpp.Concurrent.Types where -import qualified Control.Exception.Lifted as Ex import Control.Concurrent import Control.Concurrent.STM - +import qualified Control.Exception.Lifted as Ex import qualified Data.ByteString as BS +import Data.Default +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as Text import Data.Typeable - +import Data.XML.Types (Element) +import Network +import Network.Xmpp.IM.Roster.Types import Network.Xmpp.Types +import Network.Xmpp.Sasl.Types -import Data.IORef -import qualified Data.Map as Map -import Data.Text (Text) -import Network.Xmpp.Types +-- | Configuration for the @Session@ object. +data SessionConfiguration = SessionConfiguration + { -- | Configuration for the @Stream@ object. + sessionStreamConfiguration :: StreamConfiguration + -- | Handler to be run when the session ends (for whatever reason). + , onConnectionClosed :: Session -> XmppFailure -> IO () + -- | Function to generate the stream of stanza identifiers. + , sessionStanzaIDs :: IO (IO Text) + , extraStanzaHandlers :: [StanzaHandler] + , enableRoster :: Bool + } +instance Default SessionConfiguration where + def = SessionConfiguration { sessionStreamConfiguration = def + , onConnectionClosed = \_ _ -> return () + , sessionStanzaIDs = do + idRef <- newTVarIO 1 + return . atomically $ do + curId <- readTVar idRef + writeTVar idRef (curId + 1 :: Integer) + return . Text.pack . show $ curId + , extraStanzaHandlers = [] + , enableRoster = True + } + -- | Handlers to be run when the Xmpp session ends and when the Xmpp connection is -- closed. data EventHandlers = EventHandlers @@ -30,35 +56,45 @@ instance Ex.Exception Interrupt +type WriteSemaphore = TMVar (BS.ByteString -> IO Bool) -- | A concurrent interface to Pontarius XMPP. data Session = Session { stanzaCh :: TChan Stanza -- All stanzas - , outCh :: TChan Stanza , iqHandlers :: TVar IQHandlers -- Writing lock, so that only one thread could write to the stream at any -- given time. -- Fields below are from Context. - , writeRef :: TMVar (BS.ByteString -> IO Bool) + , writeSemaphore :: WriteSemaphore , readerThread :: ThreadId - , idGenerator :: IO StanzaID + , idGenerator :: IO Text -- | Lock (used by withStream) to make sure that a maximum of one -- Stream action is executed at any given time. - , streamRef :: TMVar (Stream) - , eventHandlers :: TVar EventHandlers + , streamRef :: TMVar Stream + , eventHandlers :: TMVar EventHandlers , stopThreads :: IO () + , rosterRef :: TVar Roster , conf :: SessionConfiguration + , sRealm :: HostName + , sSaslCredentials :: Maybe (ConnectionState -> [SaslHandler] , Maybe Text) + , reconnectWait :: TVar Int } --- | IQHandlers holds the registered channels for incomming IQ requests and --- TMVars of and TMVars for expected IQ responses +-- | IQHandlers holds the registered channels for incoming IQ requests and +-- TMVars of and TMVars for expected IQ responses (the second Text represent a +-- stanza identifier. type IQHandlers = (Map.Map (IQRequestType, Text) (TChan IQRequestTicket) - , Map.Map StanzaID (TMVar IQResponse) + , Map.Map Text (TMVar IQResponse) ) -- | Contains whether or not a reply has been sent, and the IQ request body to -- reply to. + data IQRequestTicket = IQRequestTicket - { sentRef :: (TVar Bool) + { answerTicket :: Either StanzaError (Maybe Element) -> IO (Maybe Bool) + -- ^ Return Nothing when the IQ request was already + -- answered before, Just True when it was sucessfully + -- answered and Just False when the answer was attempted, + -- but failed (e.g. there is a connection failure) , iqRequestBody :: IQRequest } 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,32 @@ +-- | RFC 6121: Instant Messaging and Presence +-- +module Network.Xmpp.IM + ( -- * Instant Messages + InstantMessage(..) + , MessageBody(..) + , MessageThread(..) + , MessageSubject(..) + , Subscription(None, To, From, Both) + , instantMessage + , simpleIM + , getIM + , withIM + , answerIM + -- * Presence + , ShowStatus(..) + , IMPresence(..) + , imPresence + , getIMPresence + , withIMPresence + -- * Roster + , Roster(..) + , Item(..) + , getRoster + , rosterAdd + , rosterRemove + ) where + +import Network.Xmpp.IM.Message +import Network.Xmpp.IM.Presence +import Network.Xmpp.IM.Roster +import Network.Xmpp.IM.Roster.Types 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,115 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_HADDOCK hide #-} + +module Network.Xmpp.IM.Message where + +import Data.Default +import Data.Function +import Data.List +import Data.Text (Text) +import Data.XML.Pickle +import Data.XML.Types +import Network.Xmpp.Marshal +import Network.Xmpp.Types + +data MessageBody = MessageBody { bodyLang :: Maybe LangTag + , bodyContent :: Text + } + +data MessageThread = MessageThread { threadID :: Text + , threadParent :: Maybe Text + } + +data MessageSubject = MessageSubject { subjectLang :: Maybe LangTag + , subjectContent :: Text + } + +-- | The instant message (IM) specific part of a message. +data InstantMessage = InstantMessage { imThread :: Maybe MessageThread + , imSubject :: [MessageSubject] + , imBody :: [MessageBody] + } + +instantMessage :: InstantMessage +instantMessage = InstantMessage { imThread = Nothing + , imSubject = [] + , imBody = [] + } + +instance Default InstantMessage where + def = instantMessage + +-- | Get the IM specific parts of a message. Returns 'Nothing' when the received +-- payload is not valid IM data. +getIM :: Message -> Maybe InstantMessage +getIM im = either (const Nothing) Just . unpickle xpIM $ messagePayload im + +sanitizeIM :: InstantMessage -> InstantMessage +sanitizeIM im = im{imBody = nubBy ((==) `on` bodyLang) $ imBody im} + +-- | Append IM data to a message +withIM :: Message -> InstantMessage -> Message +withIM m im = m{ messagePayload = messagePayload m + ++ pickleTree xpIM (sanitizeIM im) } + +imToElements :: InstantMessage -> [Element] +imToElements im = pickle xpIM (sanitizeIM im) + +-- | Generate a simple message +simpleIM :: Jid -- ^ recipient + -> Text -- ^ body + -> Message +simpleIM to bd = withIM message{messageTo = Just to} + instantMessage{imBody = [MessageBody Nothing bd]} + +-- | Generate an answer from a received message. The recepient is +-- taken from the original sender, the sender is set to Nothing, +-- message ID, language tag, message type as well as subject and +-- thread are inherited, the remaining payload is replaced by the +-- given one. +-- +-- If multiple message bodies are given they MUST have different language tags +answerIM :: [MessageBody] -> Message -> Maybe Message +answerIM bd msg = case getIM msg of + Nothing -> Nothing + Just im -> Just $ flip withIM (im{imBody = bd}) $ + message { messageID = messageID msg + , messageFrom = Nothing + , messageTo = messageFrom msg + , messageLangTag = messageLangTag msg + , messageType = messageType msg + } + +-------------------------- +-- Picklers -------------- +-------------------------- +xpIM :: PU [Element] InstantMessage +xpIM = xpWrap (\(t, s, b) -> InstantMessage t s b) + (\(InstantMessage t s b) -> (t, s, b)) + . xpClean + $ xp3Tuple + xpMessageThread + xpMessageSubject + xpMessageBody + + +xpMessageSubject :: PU [Element] [MessageSubject] +xpMessageSubject = xpUnliftElems . + xpWrap (map $ \(l, s) -> MessageSubject l s) + (map $ \(MessageSubject l s) -> (l,s)) + $ xpElems "{jabber:client}subject" xpLangTag $ xpContent xpId + +xpMessageBody :: PU [Element] [MessageBody] +xpMessageBody = xpUnliftElems . + xpWrap (map $ \(l, s) -> MessageBody l s) + (map $ \(MessageBody l s) -> (l,s)) + $ xpElems "{jabber:client}body" xpLangTag $ xpContent xpId + +xpMessageThread :: PU [Element] (Maybe MessageThread) +xpMessageThread = xpUnliftElems + . xpOption + . xpWrap (\(t, p) -> MessageThread p t) + (\(MessageThread p t) -> (t,p)) + $ xpElem "{jabber:client}thread" + (xpAttrImplied "parent" xpId) + (xpContent xpId) 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,76 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module Network.Xmpp.IM.Presence where + +import Data.Default +import Data.Text (Text) +import Data.XML.Pickle +import Data.XML.Types +import Network.Xmpp.Types + +data ShowStatus = StatusAway + | StatusChat + | StatusDnd + | StatusXa deriving (Read, Show) + +data IMPresence = IMP { showStatus :: Maybe ShowStatus + , status :: Maybe Text + , priority :: Maybe Int + } deriving Show + +imPresence :: IMPresence +imPresence = IMP { showStatus = Nothing + , status = Nothing + , priority = Nothing + } + +instance Default IMPresence where + def = imPresence + +-- | Try to extract RFC6121 IM presence information from presence stanza +-- Returns Nothing when the data is malformed, (Just IMPresence) otherwise +getIMPresence :: Presence -> Maybe IMPresence +getIMPresence pres = case unpickle xpIMPresence (presencePayload pres) of + Left _ -> Nothing + Right r -> Just r + +withIMPresence :: IMPresence -> Presence -> Presence +withIMPresence imPres pres = pres{presencePayload = presencePayload pres + ++ pickleTree xpIMPresence + imPres} + +-- +-- Picklers +-- + +xpIMPresence :: PU [Element] IMPresence +xpIMPresence = xpUnliftElems . + xpWrap (\(s, st, p) -> IMP s st p) + (\(IMP s st p) -> (s, st, p)) . + xpClean $ + xp3Tuple + (xpOption $ xpElemNodes "{jabber:client}show" + (xpContent xpShow)) + (xpOption $ xpElemNodes "{jabber:client}status" + (xpContent xpText)) + (xpOption $ xpElemNodes "{jabber:client}priority" + (xpContent xpPrim)) + +xpShow :: PU Text ShowStatus +xpShow = ("xpShow", "") + xpPartial ( \input -> case showStatusFromText input of + Nothing -> Left "Could not parse show status." + Just j -> Right j) + showStatusToText + where + showStatusFromText "away" = Just StatusAway + showStatusFromText "chat" = Just StatusChat + showStatusFromText "dnd" = Just StatusDnd + showStatusFromText "xa" = Just StatusXa + showStatusFromText _ = Nothing + showStatusToText StatusAway = "away" + showStatusToText StatusChat = "chat" + showStatusToText StatusDnd = "dnd" + showStatusToText StatusXa = "xa" 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,213 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Xmpp.IM.Roster where + +import Control.Applicative ((<$>)) +import Control.Concurrent.STM +import Control.Monad +import Data.List (nub) +#if MIN_VERSION_containers(0, 5, 0) +import qualified Data.Map.Strict as Map +#else +import qualified Data.Map as Map +#endif +import Data.Maybe (isJust, fromMaybe) +import Data.Text (Text) +import Data.XML.Pickle +import Data.XML.Types +import System.Log.Logger + +import Network.Xmpp.Concurrent.Basic +import Network.Xmpp.Concurrent.IQ +import Network.Xmpp.Concurrent.Types +import Network.Xmpp.IM.Roster.Types +import Network.Xmpp.Marshal +import Network.Xmpp.Types + +-- | Push a roster item to the server. The values for approved and ask are +-- ignored and all values for subsciption except "remove" are ignored +rosterPush :: Item -> Session -> IO (Maybe IQResponse) +rosterPush item session = do + let el = pickleElem xpQuery (Query Nothing [fromItem item]) + sendIQ' Nothing Set Nothing el session + +-- | Add or update an item to the roster. +-- +-- To update the item just send the complete set of new data +rosterAdd :: Jid -- ^ JID of the item + -> Maybe Text -- ^ Name alias + -> [Text] -- ^ Groups (duplicates will be removed) + -> Session + -> IO (Maybe IQResponse) +rosterAdd j n gs session = do + let el = pickleElem xpQuery (Query Nothing + [QueryItem { qiApproved = Nothing + , qiAsk = False + , qiJid = j + , qiName = n + , qiSubscription = Nothing + , qiGroups = nub gs + }]) + sendIQ' Nothing Set Nothing el session + +-- | Remove an item from the roster. Return True when the item is sucessfully +-- removed or if it wasn't in the roster to begin with. +rosterRemove :: Jid -> Session -> IO Bool +rosterRemove j sess = do + roster <- getRoster sess + case Map.lookup j (items roster) of + Nothing -> return True -- jid is not on the Roster + Just _ -> do + res <- rosterPush (Item False False j Nothing Remove []) sess + case res of + Just (IQResponseResult IQResult{}) -> return True + _ -> return False + +-- | Retrieve the current Roster state +getRoster :: Session -> IO Roster +getRoster session = atomically $ readTVar (rosterRef session) + +-- | Get the initial roster / refresh the roster. You don't need to call this on your own +initRoster :: Session -> IO () +initRoster session = do + oldRoster <- getRoster session + mbRoster <- retrieveRoster (if isJust (ver oldRoster) then Just oldRoster + else Nothing ) session + case mbRoster of + Nothing -> errorM "Pontarius.Xmpp" + "Server did not return a roster" + Just roster -> atomically $ writeTVar (rosterRef session) roster + +handleRoster :: TVar Roster -> WriteSemaphore -> Stanza -> IO Bool +handleRoster ref sem sta = case sta of + IQRequestS (iqr@IQRequest{iqRequestPayload = + iqb@Element{elementName = en}}) + | nameNamespace en == Just "jabber:iq:roster" -> do + case iqRequestFrom iqr of + Just _from -> return True -- Don't handle roster pushes from + -- unauthorized sources + Nothing -> case unpickleElem xpQuery iqb of + Right Query{ queryVer = v + , queryItems = [update] + } -> do + handleUpdate v update + _ <- writeStanza sem $ result iqr + return False + _ -> do + errorM "Pontarius.Xmpp" "Invalid roster query" + _ <- writeStanza sem $ badRequest iqr + return False + _ -> return True + where + handleUpdate v' update = atomically $ modifyTVar ref $ \(Roster v is) -> + Roster (v' `mplus` v) $ case qiSubscription update of + Just Remove -> Map.delete (qiJid update) is + _ -> Map.insert (qiJid update) (toItem update) is + + badRequest (IQRequest iqid from _to lang _tp bd) = + IQErrorS $ IQError iqid Nothing from lang errBR (Just bd) + errBR = StanzaError Cancel BadRequest Nothing Nothing + result (IQRequest iqid from _to lang _tp _bd) = + IQResultS $ IQResult iqid Nothing from lang Nothing + +retrieveRoster :: Maybe Roster -> Session -> IO (Maybe Roster) +retrieveRoster mbOldRoster sess = do + useVersioning <- isJust . rosterVer <$> getFeatures sess + let version = if useVersioning + then case mbOldRoster of + Nothing -> Just "" + Just oldRoster -> ver oldRoster + else Nothing + res <- sendIQ' Nothing Get Nothing + (pickleElem xpQuery (Query version [])) + sess + case res of + Nothing -> do + errorM "Pontarius.Xmpp.Roster" "getRoster: sending stanza failed" + return Nothing + Just (IQResponseResult (IQResult{iqResultPayload = Just ros})) + -> case unpickleElem xpQuery ros of + Left _e -> do + errorM "Pontarius.Xmpp.Roster" "getRoster: invalid query element" + return Nothing + Right ros' -> return . Just $ toRoster ros' + Just (IQResponseResult (IQResult{iqResultPayload = Nothing})) -> do + return mbOldRoster + -- sever indicated that no roster updates are necessary + Just IQResponseTimeout -> do + errorM "Pontarius.Xmpp.Roster" "getRoster: request timed out" + return Nothing + Just (IQResponseError e) -> do + errorM "Pontarius.Xmpp.Roster" $ "getRoster: server returned error" + ++ show e + return Nothing + where + toRoster (Query v is) = Roster v (Map.fromList + $ map (\i -> (qiJid i, toItem i)) + is) + +toItem :: QueryItem -> Item +toItem qi = Item { riApproved = fromMaybe False (qiApproved qi) + , riAsk = qiAsk qi + , riJid = qiJid qi + , riName = qiName qi + , riSubscription = fromMaybe None (qiSubscription qi) + , riGroups = nub $ qiGroups qi + } + +fromItem :: Item -> QueryItem +fromItem i = QueryItem { qiApproved = Nothing + , qiAsk = False + , qiJid = riJid i + , qiName = riName i + , qiSubscription = case riSubscription i of + Remove -> Just Remove + _ -> Nothing + , qiGroups = nub $ riGroups i + } + +xpItems :: PU [Node] [QueryItem] +xpItems = xpWrap (map (\((app_, ask_, jid_, name_, sub_), groups_) -> + QueryItem app_ ask_ jid_ name_ sub_ groups_)) + (map (\(QueryItem app_ ask_ jid_ name_ sub_ groups_) -> + ((app_, ask_, jid_, name_, sub_), groups_))) $ + xpElems "{jabber:iq:roster}item" + (xp5Tuple + (xpAttribute' "approved" xpBool) + (xpWrap isJust + (\p -> if p then Just () else Nothing) $ + xpOption $ xpAttribute_ "ask" "subscribe") + (xpAttribute "jid" xpJid) + (xpAttribute' "name" xpText) + (xpAttribute' "subscription" xpSubscription) + ) + (xpFindMatches $ xpElemText "{jabber:iq:roster}group") + +xpQuery :: PU [Node] Query +xpQuery = xpWrap (\(ver_, items_) -> Query ver_ items_ ) + (\(Query ver_ items_) -> (ver_, items_)) $ + xpElem "{jabber:iq:roster}query" + (xpAttribute' "ver" xpText) + xpItems + +xpSubscription :: PU Text Subscription +xpSubscription = ("xpSubscription", "") + xpPartial ( \input -> case subscriptionFromText input of + Nothing -> Left "Could not parse subscription." + Just j -> Right j) + subscriptionToText + where + subscriptionFromText "none" = Just None + subscriptionFromText "to" = Just To + subscriptionFromText "from" = Just From + subscriptionFromText "both" = Just Both + subscriptionFromText "remove" = Just Remove + subscriptionFromText _ = Nothing + subscriptionToText None = "none" + subscriptionToText To = "to" + subscriptionToText From = "from" + subscriptionToText Both = "both" + subscriptionToText Remove = "remove" 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,34 @@ +module Network.Xmpp.IM.Roster.Types where + +import qualified Data.Map as Map +import Data.Text (Text) +import Network.Xmpp.Types + +-- Note that `Remove' is not exported from IM.hs, as it will never be visible to +-- the user anyway. +data Subscription = None | To | From | Both | Remove deriving (Eq, Read, Show) + +data Roster = Roster { ver :: Maybe Text + , items :: Map.Map Jid Item } deriving Show + + +-- | Roster Items +data Item = Item { riApproved :: Bool + , riAsk :: Bool + , riJid :: Jid + , riName :: Maybe Text + , riSubscription :: Subscription + , riGroups :: [Text] + } deriving Show + +data QueryItem = QueryItem { qiApproved :: Maybe Bool + , qiAsk :: Bool + , qiJid :: Jid + , qiName :: Maybe Text + , qiSubscription :: Maybe Subscription + , qiGroups :: [Text] + } deriving Show + +data Query = Query { queryVer :: Maybe Text + , queryItems :: [QueryItem] + } deriving Show diff --git a/source/Network/Xmpp/Internal.hs b/source/Network/Xmpp/Internal.hs --- a/source/Network/Xmpp/Internal.hs +++ b/source/Network/Xmpp/Internal.hs @@ -29,17 +29,15 @@ , pushStanza , pullStanza , pushIQ - , SaslHandler(..) - , StanzaID(..) + , SaslHandler + , Stanza(..) + , TlsBehaviour(..) ) where import Network.Xmpp.Stream import Network.Xmpp.Sasl -import Network.Xmpp.Sasl.Common import Network.Xmpp.Sasl.Types import Network.Xmpp.Tls import Network.Xmpp.Types -import Network.Xmpp.Stream -import Network.Xmpp.Marshal diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -2,7 +2,9 @@ -- respectively. By convensions, pickler/unpickler ("PU") function names start -- out with "xp". -{-# Language OverloadedStrings, ViewPatterns, NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS_HADDOCK hide #-} @@ -23,10 +25,10 @@ [ xpWrap IQRequestS (\(IQRequestS x) -> x) xpIQRequest , xpWrap IQResultS (\(IQResultS x) -> x) xpIQResult , xpWrap IQErrorS (\(IQErrorS x) -> x) xpIQError - , xpWrap MessageS (\(MessageS x) -> x) xpMessage , xpWrap MessageErrorS (\(MessageErrorS x) -> x) xpMessageError - , xpWrap PresenceS (\(PresenceS x) -> x) xpPresence + , xpWrap MessageS (\(MessageS x) -> x) xpMessage , xpWrap PresenceErrorS (\(PresenceErrorS x) -> x) xpPresenceError + , xpWrap PresenceS (\(PresenceS x) -> x) xpPresence ] where -- Selector for which pickler to execute above. @@ -34,10 +36,10 @@ stanzaSel (IQRequestS _) = 0 stanzaSel (IQResultS _) = 1 stanzaSel (IQErrorS _) = 2 - stanzaSel (MessageS _) = 3 - stanzaSel (MessageErrorS _) = 4 - stanzaSel (PresenceS _) = 5 - stanzaSel (PresenceErrorS _) = 6 + stanzaSel (MessageErrorS _) = 3 + stanzaSel (MessageS _) = 4 + stanzaSel (PresenceErrorS _) = 5 + stanzaSel (PresenceS _) = 6 xpMessage :: PU [Node] (Message) xpMessage = ("xpMessage" , "") xpWrap @@ -45,10 +47,10 @@ (\(Message qid from to lang tp ext) -> ((tp, qid, from, to, lang), ext)) (xpElem "{jabber:client}message" (xp5Tuple - (xpDefault Normal $ xpAttr "type" xpPrim) - (xpAttrImplied "id" xpPrim) - (xpAttrImplied "from" xpPrim) - (xpAttrImplied "to" xpPrim) + (xpDefault Normal $ xpAttr "type" xpMessageType) + (xpAttrImplied "id" xpId) + (xpAttrImplied "from" xpJid) + (xpAttrImplied "to" xpJid) xpLangTag -- TODO: NS? ) @@ -61,11 +63,11 @@ (\(Presence qid from to lang tp ext) -> ((qid, from, to, lang, tp), ext)) (xpElem "{jabber:client}presence" (xp5Tuple - (xpAttrImplied "id" xpPrim) - (xpAttrImplied "from" xpPrim) - (xpAttrImplied "to" xpPrim) + (xpAttrImplied "id" xpId) + (xpAttrImplied "from" xpJid) + (xpAttrImplied "to" xpJid) xpLangTag - (xpAttrImplied "type" xpPrim) + (xpDefault Available $ xpAttr "type" xpPresenceType) ) (xpAll xpElemVerbatim) ) @@ -76,11 +78,11 @@ (\(IQRequest qid from to lang tp body) -> ((qid, from, to, lang, tp), body)) (xpElem "{jabber:client}iq" (xp5Tuple - (xpAttr "id" xpPrim) - (xpAttrImplied "from" xpPrim) - (xpAttrImplied "to" xpPrim) + (xpAttr "id" xpId) + (xpAttrImplied "from" xpJid) + (xpAttrImplied "to" xpJid) xpLangTag - ((xpAttr "type" xpPrim)) + ((xpAttr "type" xpIQRequestType)) ) xpElemVerbatim ) @@ -91,9 +93,9 @@ (\(IQResult qid from to lang body) -> ((qid, from, to, lang, ()), body)) (xpElem "{jabber:client}iq" (xp5Tuple - (xpAttr "id" xpPrim) - (xpAttrImplied "from" xpPrim) - (xpAttrImplied "to" xpPrim) + (xpAttr "id" xpId) + (xpAttrImplied "from" xpJid) + (xpAttrImplied "to" xpJid) xpLangTag ((xpAttrFixed "type" "result")) ) @@ -110,7 +112,7 @@ (\cond -> (cond, (), ())) (xpElemByNamespace "urn:ietf:params:xml:ns:xmpp-stanzas" - xpPrim + xpStanzaErrorCondition xpUnit xpUnit ) @@ -120,11 +122,11 @@ (\(tp, (cond, txt, ext)) -> StanzaError tp cond txt ext) (\(StanzaError tp cond txt ext) -> (tp, (cond, txt, ext))) (xpElem "{jabber:client}error" - (xpAttr "type" xpPrim) + (xpAttr "type" xpStanzaErrorType) (xp3Tuple xpErrorCondition (xpOption $ xpElem "{jabber:client}text" - (xpAttrImplied xmlLang xpPrim) + (xpAttrImplied xmlLang xpLang) (xpContent xpId) ) (xpOption xpElemVerbatim) @@ -140,10 +142,10 @@ (xpElem "{jabber:client}message" (xp5Tuple (xpAttrFixed "type" "error") - (xpAttrImplied "id" xpPrim) - (xpAttrImplied "from" xpPrim) - (xpAttrImplied "to" xpPrim) - (xpAttrImplied xmlLang xpPrim) + (xpAttrImplied "id" xpId) + (xpAttrImplied "from" xpJid) + (xpAttrImplied "to" xpJid) + (xpAttrImplied xmlLang xpLang) -- TODO: NS? ) (xp2Tuple xpStanzaError (xpAll xpElemVerbatim)) @@ -157,9 +159,9 @@ ((qid, from, to, lang, ()), (err, ext))) (xpElem "{jabber:client}presence" (xp5Tuple - (xpAttrImplied "id" xpPrim) - (xpAttrImplied "from" xpPrim) - (xpAttrImplied "to" xpPrim) + (xpAttrImplied "id" xpId) + (xpAttrImplied "from" xpJid) + (xpAttrImplied "to" xpJid) xpLangTag (xpAttrFixed "type" "error") ) @@ -174,9 +176,9 @@ ((qid, from, to, lang, ()), (err, body))) (xpElem "{jabber:client}iq" (xp5Tuple - (xpAttr "id" xpPrim) - (xpAttrImplied "from" xpPrim) - (xpAttrImplied "to" xpPrim) + (xpAttr "id" xpId) + (xpAttrImplied "from" xpJid) + (xpAttrImplied "to" xpJid) xpLangTag ((xpAttrFixed "type" "error")) ) @@ -196,7 +198,7 @@ (xp3Tuple (xpElemByNamespace "urn:ietf:params:xml:ns:xmpp-streams" - xpPrim + xpStreamErrorCondition xpUnit xpUnit ) @@ -210,8 +212,15 @@ ) xpLangTag :: PU [Attribute] (Maybe LangTag) -xpLangTag = xpAttrImplied xmlLang xpPrim +xpLangTag = xpAttrImplied xmlLang xpLang +xpLang :: PU Text LangTag +xpLang = ("xpLang", "") + xpPartial ( \input -> case langTagFromText input of + Nothing -> Left "Could not parse language tag." + Just j -> Right j) + langTagToText + xmlLang :: Name xmlLang = Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml") @@ -239,8 +248,8 @@ (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) (xp5Tuple (xpAttr "version" xpId) - (xpAttrImplied "from" xpPrim) - (xpAttrImplied "to" xpPrim) + (xpAttrImplied "from" xpJid) + (xpAttrImplied "to" xpJid) (xpAttrImplied "id" xpId) xpLangTag ) @@ -248,17 +257,18 @@ -- Pickler/Unpickler for the stream features - TLS, SASL, and the rest. xpStreamFeatures :: PU [Node] StreamFeatures xpStreamFeatures = ("xpStreamFeatures","") xpWrap - (\(tls, sasl, rest) -> StreamFeatures tls (mbl sasl) rest) - (\(StreamFeatures tls sasl rest) -> (tls, lmb sasl, rest)) + (\(tls, sasl, ver, rest) -> StreamFeatures tls (mbl sasl) ver rest) + (\(StreamFeatures tls sasl ver rest) -> (tls, lmb sasl, ver, rest)) (xpElemNodes (Name "features" (Just "http://etherx.jabber.org/streams") (Just "stream") ) - (xpTriple + (xp4Tuple (xpOption pickleTlsFeature) (xpOption pickleSaslFeature) + (xpOption pickleRosterVer) (xpAll xpElemVerbatim) ) ) @@ -272,3 +282,197 @@ xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms" (xpAll $ xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId)) + pickleRosterVer = xpElemNodes "{urn:xmpp:features:rosterver}ver" $ + xpElemExists "{urn:xmpp:features:rosterver}optional" + +xpJid :: PU Text Jid +xpJid = ("xpJid", "") + xpPartial ( \input -> case jidFromText input of + Nothing -> Left "Could not parse JID." + Just j -> Right j) + jidToText + +xpIQRequestType :: PU Text IQRequestType +xpIQRequestType = ("xpIQRequestType", "") + xpPartial ( \input -> case iqRequestTypeFromText input of + Nothing -> Left "Could not parse IQ request type." + Just j -> Right j) + iqRequestTypeToText + where + iqRequestTypeFromText "get" = Just Get + iqRequestTypeFromText "set" = Just Set + iqRequestTypeFromText _ = Nothing + iqRequestTypeToText Get = "get" + iqRequestTypeToText Set = "set" + +xpMessageType :: PU Text MessageType +xpMessageType = ("xpMessageType", "") + xpPartial ( \input -> case messageTypeFromText input of + Nothing -> Left "Could not parse message type." + Just j -> Right j) + messageTypeToText + where + messageTypeFromText "chat" = Just Chat + messageTypeFromText "groupchat" = Just GroupChat + messageTypeFromText "headline" = Just Headline + messageTypeFromText "normal" = Just Normal + messageTypeFromText _ = Just Normal + messageTypeToText Chat = "chat" + messageTypeToText GroupChat = "groupchat" + messageTypeToText Headline = "headline" + messageTypeToText Normal = "normal" + +xpPresenceType :: PU Text PresenceType +xpPresenceType = ("xpPresenceType", "") + xpPartial ( \input -> case presenceTypeFromText input of + Nothing -> Left "Could not parse presence type." + Just j -> Right j) + presenceTypeToText + where + presenceTypeFromText "" = Just Available + presenceTypeFromText "available" = Just Available + presenceTypeFromText "unavailable" = Just Unavailable + presenceTypeFromText "subscribe" = Just Subscribe + presenceTypeFromText "subscribed" = Just Subscribed + presenceTypeFromText "unsubscribe" = Just Unsubscribe + presenceTypeFromText "unsubscribed" = Just Unsubscribed + presenceTypeFromText "probe" = Just Probe + presenceTypeFromText _ = Nothing + presenceTypeToText Available = "available" + presenceTypeToText Unavailable = "unavailable" + presenceTypeToText Subscribe = "subscribe" + presenceTypeToText Subscribed = "subscribed" + presenceTypeToText Unsubscribe = "unsubscribe" + presenceTypeToText Unsubscribed = "unsubscribed" + presenceTypeToText Probe = "probe" + +xpStanzaErrorType :: PU Text StanzaErrorType +xpStanzaErrorType = ("xpStanzaErrorType", "") + xpPartial ( \input -> case stanzaErrorTypeFromText input of + Nothing -> Left "Could not parse stanza error type." + Just j -> Right j) + stanzaErrorTypeToText + where + stanzaErrorTypeFromText "auth" = Just Auth + stanzaErrorTypeFromText "cancel" = Just Cancel + stanzaErrorTypeFromText "continue" = Just Continue + stanzaErrorTypeFromText "modify" = Just Modify + stanzaErrorTypeFromText "wait" = Just Wait + stanzaErrorTypeFromText _ = Nothing + stanzaErrorTypeToText Auth = "auth" + stanzaErrorTypeToText Cancel = "cancel" + stanzaErrorTypeToText Continue = "continue" + stanzaErrorTypeToText Modify = "modify" + stanzaErrorTypeToText Wait = "wait" + +xpStanzaErrorCondition :: PU Text StanzaErrorCondition +xpStanzaErrorCondition = ("xpStanzaErrorCondition", "") + xpPartial ( \input -> case stanzaErrorConditionFromText input of + Nothing -> Left "Could not parse stanza error condition." + Just j -> Right j) + stanzaErrorConditionToText + where + stanzaErrorConditionToText BadRequest = "bad-request" + stanzaErrorConditionToText Conflict = "conflict" + stanzaErrorConditionToText FeatureNotImplemented = "feature-not-implemented" + stanzaErrorConditionToText Forbidden = "forbidden" + stanzaErrorConditionToText Gone = "gone" + stanzaErrorConditionToText InternalServerError = "internal-server-error" + stanzaErrorConditionToText ItemNotFound = "item-not-found" + stanzaErrorConditionToText JidMalformed = "jid-malformed" + stanzaErrorConditionToText NotAcceptable = "not-acceptable" + stanzaErrorConditionToText NotAllowed = "not-allowed" + stanzaErrorConditionToText NotAuthorized = "not-authorized" + stanzaErrorConditionToText PaymentRequired = "payment-required" + stanzaErrorConditionToText RecipientUnavailable = "recipient-unavailable" + stanzaErrorConditionToText Redirect = "redirect" + stanzaErrorConditionToText RegistrationRequired = "registration-required" + stanzaErrorConditionToText RemoteServerNotFound = "remote-server-not-found" + stanzaErrorConditionToText RemoteServerTimeout = "remote-server-timeout" + stanzaErrorConditionToText ResourceConstraint = "resource-constraint" + stanzaErrorConditionToText ServiceUnavailable = "service-unavailable" + stanzaErrorConditionToText SubscriptionRequired = "subscription-required" + stanzaErrorConditionToText UndefinedCondition = "undefined-condition" + stanzaErrorConditionToText UnexpectedRequest = "unexpected-request" + stanzaErrorConditionFromText "bad-request" = Just BadRequest + stanzaErrorConditionFromText "conflict" = Just Conflict + stanzaErrorConditionFromText "feature-not-implemented" = Just FeatureNotImplemented + stanzaErrorConditionFromText "forbidden" = Just Forbidden + stanzaErrorConditionFromText "gone" = Just Gone + stanzaErrorConditionFromText "internal-server-error" = Just InternalServerError + stanzaErrorConditionFromText "item-not-found" = Just ItemNotFound + stanzaErrorConditionFromText "jid-malformed" = Just JidMalformed + stanzaErrorConditionFromText "not-acceptable" = Just NotAcceptable + stanzaErrorConditionFromText "not-allowed" = Just NotAllowed + stanzaErrorConditionFromText "not-authorized" = Just NotAuthorized + stanzaErrorConditionFromText "payment-required" = Just PaymentRequired + stanzaErrorConditionFromText "recipient-unavailable" = Just RecipientUnavailable + stanzaErrorConditionFromText "redirect" = Just Redirect + stanzaErrorConditionFromText "registration-required" = Just RegistrationRequired + stanzaErrorConditionFromText "remote-server-not-found" = Just RemoteServerNotFound + stanzaErrorConditionFromText "remote-server-timeout" = Just RemoteServerTimeout + stanzaErrorConditionFromText "resource-constraint" = Just ResourceConstraint + stanzaErrorConditionFromText "service-unavailable" = Just ServiceUnavailable + stanzaErrorConditionFromText "subscription-required" = Just SubscriptionRequired + stanzaErrorConditionFromText "undefined-condition" = Just UndefinedCondition + stanzaErrorConditionFromText "unexpected-request" = Just UnexpectedRequest + stanzaErrorConditionFromText _ = Nothing + +xpStreamErrorCondition :: PU Text StreamErrorCondition +xpStreamErrorCondition = ("xpStreamErrorCondition", "") + xpPartial ( \input -> case streamErrorConditionFromText input of + Nothing -> Left "Could not parse stream error condition." + Just j -> Right j) + streamErrorConditionToText + where + streamErrorConditionToText StreamBadFormat = "bad-format" + streamErrorConditionToText StreamBadNamespacePrefix = "bad-namespace-prefix" + streamErrorConditionToText StreamConflict = "conflict" + streamErrorConditionToText StreamConnectionTimeout = "connection-timeout" + streamErrorConditionToText StreamHostGone = "host-gone" + streamErrorConditionToText StreamHostUnknown = "host-unknown" + streamErrorConditionToText StreamImproperAddressing = "improper-addressing" + streamErrorConditionToText StreamInternalServerError = "internal-server-error" + streamErrorConditionToText StreamInvalidFrom = "invalid-from" + streamErrorConditionToText StreamInvalidNamespace = "invalid-namespace" + streamErrorConditionToText StreamInvalidXml = "invalid-xml" + streamErrorConditionToText StreamNotAuthorized = "not-authorized" + streamErrorConditionToText StreamNotWellFormed = "not-well-formed" + streamErrorConditionToText StreamPolicyViolation = "policy-violation" + streamErrorConditionToText StreamRemoteConnectionFailed = "remote-connection-failed" + streamErrorConditionToText StreamReset = "reset" + streamErrorConditionToText StreamResourceConstraint = "resource-constraint" + streamErrorConditionToText StreamRestrictedXml = "restricted-xml" + streamErrorConditionToText StreamSeeOtherHost = "see-other-host" + streamErrorConditionToText StreamSystemShutdown = "system-shutdown" + streamErrorConditionToText StreamUndefinedCondition = "undefined-condition" + streamErrorConditionToText StreamUnsupportedEncoding = "unsupported-encoding" + streamErrorConditionToText StreamUnsupportedFeature = "unsupported-feature" + streamErrorConditionToText StreamUnsupportedStanzaType = "unsupported-stanza-type" + streamErrorConditionToText StreamUnsupportedVersion = "unsupported-version" + streamErrorConditionFromText "bad-format" = Just StreamBadFormat + streamErrorConditionFromText "bad-namespace-prefix" = Just StreamBadNamespacePrefix + streamErrorConditionFromText "conflict" = Just StreamConflict + streamErrorConditionFromText "connection-timeout" = Just StreamConnectionTimeout + streamErrorConditionFromText "host-gone" = Just StreamHostGone + streamErrorConditionFromText "host-unknown" = Just StreamHostUnknown + streamErrorConditionFromText "improper-addressing" = Just StreamImproperAddressing + streamErrorConditionFromText "internal-server-error" = Just StreamInternalServerError + streamErrorConditionFromText "invalid-from" = Just StreamInvalidFrom + streamErrorConditionFromText "invalid-namespace" = Just StreamInvalidNamespace + streamErrorConditionFromText "invalid-xml" = Just StreamInvalidXml + streamErrorConditionFromText "not-authorized" = Just StreamNotAuthorized + streamErrorConditionFromText "not-well-formed" = Just StreamNotWellFormed + streamErrorConditionFromText "policy-violation" = Just StreamPolicyViolation + streamErrorConditionFromText "remote-connection-failed" = Just StreamRemoteConnectionFailed + streamErrorConditionFromText "reset" = Just StreamReset + streamErrorConditionFromText "resource-constraint" = Just StreamResourceConstraint + streamErrorConditionFromText "restricted-xml" = Just StreamRestrictedXml + streamErrorConditionFromText "see-other-host" = Just StreamSeeOtherHost + streamErrorConditionFromText "system-shutdown" = Just StreamSystemShutdown + streamErrorConditionFromText "undefined-condition" = Just StreamUndefinedCondition + streamErrorConditionFromText "unsupported-encoding" = Just StreamUnsupportedEncoding + streamErrorConditionFromText "unsupported-feature" = Just StreamUnsupportedFeature + streamErrorConditionFromText "unsupported-stanza-type" = Just StreamUnsupportedStanzaType + streamErrorConditionFromText "unsupported-version" = Just StreamUnsupportedVersion + streamErrorConditionFromText _ = Nothing diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -1,6 +1,6 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} - +-- -- Submodule for functionality related to SASL negotation: -- authentication functions, SASL functionality, bind functionality, -- and the legacy `{urn:ietf:params:xml:ns:xmpp-session}session' @@ -14,51 +14,17 @@ , auth ) where -import Control.Applicative -import Control.Arrow (left) -import Control.Monad import Control.Monad.Error import Control.Monad.State.Strict -import Data.Maybe (fromJust, isJust) - -import qualified Crypto.Classes as CC - -import qualified Data.Binary as Binary -import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as BL -import qualified Data.Digest.Pure.MD5 as MD5 -import qualified Data.List as L -import Data.Word (Word8) - -import qualified Data.Text as Text import Data.Text (Text) -import qualified Data.Text.Encoding as Text - -import Network.Xmpp.Stream -import Network.Xmpp.Types - -import System.Log.Logger (debugM, errorM) -import qualified System.Random as Random - -import Network.Xmpp.Sasl.Types -import Network.Xmpp.Sasl.Mechanisms - -import Control.Concurrent.STM.TMVar - -import Control.Exception - import Data.XML.Pickle import Data.XML.Types - -import Network.Xmpp.Types import Network.Xmpp.Marshal - -import Control.Monad.State(modify) - -import Control.Concurrent.STM.TMVar - -import Control.Monad.Error +import Network.Xmpp.Sasl.Mechanisms +import Network.Xmpp.Sasl.Types +import Network.Xmpp.Stream +import Network.Xmpp.Types +import System.Log.Logger (debugM, errorM, infoM) -- | Uses the first supported mechanism to authenticate, if any. Updates the -- state with non-password credentials and restarts the stream upon @@ -105,16 +71,18 @@ -> Stream -> IO (Either XmppFailure (Maybe AuthFailure)) auth mechanisms resource con = runErrorT $ do - ErrorT $ xmppSasl mechanisms con - jid <- ErrorT $ xmppBind resource con - ErrorT $ flip withStream con $ do - s <- get - case establishSession $ streamConfiguration s of - False -> return $ Right Nothing - True -> do - _ <- lift $ startSession con - return $ Right Nothing - return Nothing + mbAuthFail <- ErrorT $ xmppSasl mechanisms con + case mbAuthFail of + Nothing -> do + _jid <- ErrorT $ xmppBind resource con + ErrorT $ flip withStream' con $ do + s <- get + case establishSession $ streamConfiguration s of + False -> return $ Right Nothing + True -> do + _ <-liftIO $ startSession con + return $ Right Nothing + f -> return f -- Produces a `bind' element, optionally wrapping a resource. bindBody :: Maybe Text -> Element @@ -133,26 +101,27 @@ answer <- ErrorT $ pushIQ "bind" Nothing Set Nothing (bindBody rsrc) c case answer of Right IQResult{iqResultPayload = Just b} -> do - lift $ debugM "Pontarius.XMPP" "xmppBind: IQ result received; unpickling JID..." - let jid = unpickleElem xpJid b + lift $ debugM "Pontarius.Xmpp" "xmppBind: IQ result received; unpickling JID..." + let jid = unpickleElem xpJid' b case jid of Right jid' -> do - lift $ debugM "Pontarius.XMPP" $ "xmppBind: JID unpickled: " ++ show jid' - ErrorT $ withStream (do - modify $ \s -> s{streamJid = Just jid'} - return $ Right jid') c -- not pretty + lift $ infoM "Pontarius.Xmpp" $ "Bound JID: " ++ show jid' + _ <- lift $ withStream ( do modify $ \s -> + s{streamJid = Just jid'}) + c return jid' - otherwise -> do - lift $ errorM "Pontarius.XMPP" $ "xmppBind: JID could not be unpickled from: " - ++ show b + _ -> do + lift $ errorM "Pontarius.Xmpp" + $ "xmppBind: JID could not be unpickled from: " + ++ show b throwError $ XmppOtherFailure - otherwise -> do + _ -> do lift $ errorM "Pontarius.XMPP" "xmppBind: IQ error received." throwError XmppOtherFailure where -- Extracts the character data in the `jid' element. - xpJid :: PU [Node] Jid - xpJid = xpBind $ xpElemNodes jidName (xpContent xpPrim) + xpJid' :: PU [Node] Jid + xpJid' = xpBind $ xpElemNodes jidName (xpContent xpJid) jidName = "{urn:ietf:params:xml:ns:xmpp-bind}jid" -- A `bind' element pickler. @@ -163,15 +132,6 @@ sessionXml = pickleElem (xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session") () - -sessionIQ :: Stanza -sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" - , iqRequestFrom = Nothing - , iqRequestTo = Nothing - , iqRequestLangTag = Nothing - , iqRequestType = Set - , iqRequestPayload = sessionXml - } -- Sends the session IQ set element and waits for an answer. Throws an error if -- if an IQ error stanza is returned from the server. diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -4,28 +4,23 @@ module Network.Xmpp.Sasl.Common where -import Network.Xmpp.Types - import Control.Applicative ((<$>)) import Control.Monad.Error -import Control.Monad.State.Class - import qualified Data.Attoparsec.ByteString.Char8 as AP import Data.Bits import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64 -import Data.Maybe (fromMaybe) import Data.Maybe (maybeToList) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Word (Word8) import Data.XML.Pickle import Data.XML.Types - -import Network.Xmpp.Stream +import Network.Xmpp.Marshal import Network.Xmpp.Sasl.StringPrep import Network.Xmpp.Sasl.Types -import Network.Xmpp.Marshal +import Network.Xmpp.Stream +import Network.Xmpp.Types import qualified System.Random as Random @@ -66,9 +61,9 @@ AP.skipSpace name <- AP.takeWhile1 (/= '=') _ <- AP.char '=' - quote <- ((AP.char '"' >> return True) `mplus` return False) + qt <- ((AP.char '"' >> return True) `mplus` return False) content <- AP.takeWhile1 (AP.notInClass [',', '"']) - when quote . void $ AP.char '"' + when qt . void $ AP.char '"' return (name, content) -- Failure element pickler. @@ -85,10 +80,41 @@ (xpContent xpId)) (xpElemByNamespace "urn:ietf:params:xml:ns:xmpp-sasl" - xpPrim + xpSaslError (xpUnit) (xpUnit)))) +xpSaslError :: PU Text.Text SaslError +xpSaslError = ("xpSaslError", "") + xpPartial ( \input -> case saslErrorFromText input of + Nothing -> Left "Could not parse SASL error." + Just j -> Right j) + saslErrorToText + where + saslErrorToText SaslAborted = "aborted" + saslErrorToText SaslAccountDisabled = "account-disabled" + saslErrorToText SaslCredentialsExpired = "credentials-expired" + saslErrorToText SaslEncryptionRequired = "encryption-required" + saslErrorToText SaslIncorrectEncoding = "incorrect-encoding" + saslErrorToText SaslInvalidAuthzid = "invalid-authzid" + saslErrorToText SaslInvalidMechanism = "invalid-mechanism" + saslErrorToText SaslMalformedRequest = "malformed-request" + saslErrorToText SaslMechanismTooWeak = "mechanism-too-weak" + saslErrorToText SaslNotAuthorized = "not-authorized" + saslErrorToText SaslTemporaryAuthFailure = "temporary-auth-failure" + saslErrorFromText "aborted" = Just SaslAborted + saslErrorFromText "account-disabled" = Just SaslAccountDisabled + saslErrorFromText "credentials-expired" = Just SaslCredentialsExpired + saslErrorFromText "encryption-required" = Just SaslEncryptionRequired + saslErrorFromText "incorrect-encoding" = Just SaslIncorrectEncoding + saslErrorFromText "invalid-authzid" = Just SaslInvalidAuthzid + saslErrorFromText "invalid-mechanism" = Just SaslInvalidMechanism + saslErrorFromText "malformed-request" = Just SaslMalformedRequest + saslErrorFromText "mechanism-too-weak" = Just SaslMechanismTooWeak + saslErrorFromText "not-authorized" = Just SaslNotAuthorized + saslErrorFromText "temporary-auth-failure" = Just SaslTemporaryAuthFailure + saslErrorFromText _ = Nothing + -- Challenge element pickler. xpChallenge :: PU [Node] (Maybe Text.Text) xpChallenge = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" @@ -108,19 +134,20 @@ quote :: BS.ByteString -> BS.ByteString quote x = BS.concat ["\"",x,"\""] -saslInit :: Text.Text -> Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) Bool +saslInit :: Text.Text -> Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) () saslInit mechanism payload = do r <- lift . pushElement . saslInitE mechanism $ Text.decodeUtf8 . B64.encode <$> payload case r of - Left e -> throwError $ AuthStreamFailure e - Right b -> return b + Right True -> return () + Right False -> throwError $ AuthStreamFailure XmppNoStream + Left e -> throwError $ AuthStreamFailure e -- | Pull the next element. pullSaslElement :: ErrorT AuthFailure (StateT StreamState IO) SaslElement pullSaslElement = do - r <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement) - case r of + mbse <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement) + case mbse of Left e -> throwError $ AuthStreamFailure e Right (Left e) -> throwError $ AuthSaslFailure e Right (Right r) -> return r @@ -173,13 +200,13 @@ Right r -> return r -- | Send a SASL response element. The content will be base64-encoded. -respond :: Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) Bool +respond :: Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) () respond m = do r <- lift . pushElement . saslResponseE . fmap (Text.decodeUtf8 . B64.encode) $ m case r of Left e -> throwError $ AuthStreamFailure e - Right b -> return b - + Right False -> throwError $ AuthStreamFailure XmppNoStream + Right True -> return () -- | Run the appropriate stringprep profiles on the credentials. -- May fail with 'AuthStringPrepFailure' @@ -190,12 +217,12 @@ Just creds -> return creds where credentials = do - ac <- normalizeUsername authcid - az <- case authzid of - Nothing -> Just Nothing - Just az' -> Just <$> normalizeUsername az' - pw <- normalizePassword password - return (ac, az, pw) + ac <- normalizeUsername authcid + az <- case authzid of + Nothing -> Just Nothing + Just az' -> Just <$> normalizeUsername az' + pw <- normalizePassword password + return (ac, az, pw) -- | Bit-wise xor of byte strings xorBS :: BS.ByteString -> BS.ByteString -> BS.ByteString diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs --- a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs @@ -5,37 +5,21 @@ ( digestMd5 ) where -import Control.Applicative -import Control.Arrow (left) -import Control.Monad import Control.Monad.Error import Control.Monad.State.Strict -import Data.Maybe (fromJust, isJust) - import qualified Crypto.Classes as CC - import qualified Data.Binary as Binary +import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BL import qualified Data.Digest.Pure.MD5 as MD5 import qualified Data.List as L - -import qualified Data.Text as Text import Data.Text (Text) import qualified Data.Text.Encoding as Text - -import Data.XML.Pickle - -import qualified Data.ByteString as BS - -import Data.XML.Types - -import Network.Xmpp.Stream -import Network.Xmpp.Types import Network.Xmpp.Sasl.Common -import Network.Xmpp.Sasl.StringPrep import Network.Xmpp.Sasl.Types +import Network.Xmpp.Types @@ -43,19 +27,19 @@ -> Maybe Text -- ^ Authorization identity (authcid) -> Text -- ^ Password (authzid) -> ErrorT AuthFailure (StateT StreamState IO) () -xmppDigestMd5 authcid authzid password = do - (ac, az, pw) <- prepCredentials authcid authzid password +xmppDigestMd5 authcid' authzid' password' = do + (ac, az, pw) <- prepCredentials authcid' authzid' password' Just address <- gets streamAddress xmppDigestMd5' address ac az pw where xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> ErrorT AuthFailure (StateT StreamState IO) () - xmppDigestMd5' hostname authcid authzid password = do + xmppDigestMd5' hostname authcid _authzid password = do -- TODO: use authzid? -- Push element and receive the challenge. _ <- saslInit "DIGEST-MD5" Nothing -- TODO: Check boolean? - pairs <- toPairs =<< saslFromJust =<< pullChallenge + prs <- toPairs =<< saslFromJust =<< pullChallenge cnonce <- liftIO $ makeNonce - _b <- respond . Just $ createResponse hostname pairs cnonce - challenge2 <- pullFinalMessage + _b <- respond . Just $ createResponse hostname prs cnonce + _challenge2 <- pullFinalMessage return () where -- Produce the response to the challenge. @@ -63,19 +47,19 @@ -> Pairs -> BS.ByteString -- nonce -> BS.ByteString - createResponse hostname pairs cnonce = let - Just qop = L.lookup "qop" pairs -- TODO: proper handling - Just nonce = L.lookup "nonce" pairs + createResponse hname prs cnonce = let + Just qop = L.lookup "qop" prs -- TODO: proper handling + Just nonce = L.lookup "nonce" prs uname_ = Text.encodeUtf8 authcid passwd_ = Text.encodeUtf8 password -- Using Int instead of Word8 for random 1.0.0.0 (GHC 7) -- compatibility. nc = "00000001" - digestURI = "xmpp/" `BS.append` Text.encodeUtf8 hostname + digestURI = "xmpp/" `BS.append` Text.encodeUtf8 hname digest = md5Digest uname_ - (lookup "realm" pairs) + (lookup "realm" prs) passwd_ digestURI nc @@ -84,7 +68,7 @@ cnonce response = BS.intercalate "," . map (BS.intercalate "=") $ [["username", quote uname_]] ++ - case L.lookup "realm" pairs of + case L.lookup "realm" prs of Just realm -> [["realm" , quote realm ]] Nothing -> [] ++ [ ["nonce" , quote nonce ] @@ -115,8 +99,8 @@ -> BS8.ByteString -> BS8.ByteString -> BS8.ByteString - md5Digest uname realm password digestURI nc qop nonce cnonce = - let ha1 = hash [ hashRaw [uname, maybe "" id realm, password] + md5Digest uname realm pwd digestURI nc qop nonce cnonce = + let ha1 = hash [ hashRaw [uname, maybe "" id realm, pwd] , nonce , cnonce ] diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs --- a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs @@ -8,51 +8,22 @@ ( plain ) where -import Control.Applicative -import Control.Arrow (left) -import Control.Monad import Control.Monad.Error import Control.Monad.State.Strict -import Data.Maybe (fromJust, isJust) - -import qualified Crypto.Classes as CC - -import qualified Data.Binary as Binary -import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as BL -import qualified Data.Digest.Pure.MD5 as MD5 -import qualified Data.List as L -import Data.Word (Word8) - -import qualified Data.Text as Text -import Data.Text (Text) -import qualified Data.Text.Encoding as Text - -import Data.XML.Pickle - import qualified Data.ByteString as BS - -import Data.XML.Types - -import Network.Xmpp.Stream -import Network.Xmpp.Types - -import qualified System.Random as Random - -import Data.Maybe (fromMaybe) import qualified Data.Text as Text - +import qualified Data.Text.Encoding as Text import Network.Xmpp.Sasl.Common import Network.Xmpp.Sasl.Types +import Network.Xmpp.Types -- TODO: stringprep xmppPlain :: Text.Text -- ^ Password -> Maybe Text.Text -- ^ Authorization identity (authzid) -> Text.Text -- ^ Authentication identity (authcid) -> ErrorT AuthFailure (StateT StreamState IO) () -xmppPlain authcid authzid password = do - (ac, az, pw) <- prepCredentials authcid authzid password +xmppPlain authcid' authzid' password = do + (ac, az, pw) <- prepCredentials authcid' authzid' password _ <- saslInit "PLAIN" ( Just $ plainMessage ac az pw) _ <- pullSuccess return () @@ -63,15 +34,15 @@ -> Maybe Text.Text -- Authentication identity (authcid) -> Text.Text -- Password -> BS.ByteString -- The PLAIN message - plainMessage authcid authzid passwd = BS.concat $ - [ authzid' - , "\NUL" - , Text.encodeUtf8 $ authcid - , "\NUL" - , Text.encodeUtf8 $ passwd - ] + plainMessage authcid _authzid passwd = BS.concat $ + [ authzid'' + , "\NUL" + , Text.encodeUtf8 $ authcid + , "\NUL" + , Text.encodeUtf8 $ passwd + ] where - authzid' = maybe "" Text.encodeUtf8 authzid + authzid'' = maybe "" Text.encodeUtf8 authzid' plain :: Text.Text -- ^ authentication ID (username) -> Maybe Text.Text -- ^ authorization ID diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs --- a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs @@ -8,32 +8,20 @@ import Control.Applicative ((<$>)) import Control.Monad.Error -import Control.Monad.Trans (liftIO) -import qualified Crypto.Classes as Crypto -import qualified Crypto.HMAC as Crypto -import qualified Crypto.Hash.SHA1 as Crypto -import Data.Binary(Binary,encode) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64 as B64 -import Data.ByteString.Char8 as BS8 (unpack) -import qualified Data.ByteString.Lazy as LBS +import Control.Monad.State.Strict +import qualified Crypto.Classes as Crypto +import qualified Crypto.HMAC as Crypto +import qualified Crypto.Hash.CryptoAPI as Crypto +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import Data.ByteString.Char8 as BS8 (unpack) import Data.List (foldl1', genericTake) - -import qualified Data.Binary.Builder as Build - -import Data.Maybe (maybeToList) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Data.Word(Word8) - +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import Network.Xmpp.Sasl.Common -import Network.Xmpp.Sasl.StringPrep import Network.Xmpp.Sasl.Types import Network.Xmpp.Types - -import Control.Monad.State.Strict - -- | A nicer name for undefined, for use as a dummy token to determin -- the hash function to use hashToken :: (Crypto.Hash ctx hash) => hash @@ -50,18 +38,18 @@ -> Maybe Text.Text -- ^ Authorization ID -> Text.Text -- ^ Password -> ErrorT AuthFailure (StateT StreamState IO) () -scram hashToken authcid authzid password = do +scram hToken authcid authzid password = do (ac, az, pw) <- prepCredentials authcid authzid password - scramhelper hashToken ac az pw + scramhelper ac az pw where - scramhelper hashToken authcid authzid' password = do - cnonce <- liftIO $ makeNonce - saslInit "SCRAM-SHA-1" (Just $ cFirstMessage cnonce) + scramhelper authcid' authzid' pwd = do + cnonce <- liftIO makeNonce + _ <- saslInit "SCRAM-SHA-1" (Just $ cFirstMessage cnonce) sFirstMessage <- saslFromJust =<< pullChallenge - pairs <- toPairs sFirstMessage - (nonce, salt, ic) <- fromPairs pairs cnonce + prs <- toPairs sFirstMessage + (nonce, salt, ic) <- fromPairs prs cnonce let (cfm, v) = cFinalMessageAndVerifier nonce salt ic sFirstMessage cnonce - respond $ Just cfm + _ <- respond $ Just cfm finalPairs <- toPairs =<< saslFromJust =<< pullFinalMessage unless (lookup "v" finalPairs == Just v) $ throwError AuthOtherFailure -- TODO: Log return () @@ -71,27 +59,27 @@ encode _hashtoken = Crypto.encode hash :: BS.ByteString -> BS.ByteString - hash str = encode hashToken $ Crypto.hash' str + hash str = encode hToken $ Crypto.hash' str hmac :: BS.ByteString -> BS.ByteString -> BS.ByteString - hmac key str = encode hashToken $ Crypto.hmac' (Crypto.MacKey key) str + hmac key str = encode hToken $ Crypto.hmac' (Crypto.MacKey key) str - authzid :: Maybe BS.ByteString - authzid = (\z -> "a=" +++ Text.encodeUtf8 z) <$> authzid' + authzid'' :: Maybe BS.ByteString + authzid'' = (\z -> "a=" +++ Text.encodeUtf8 z) <$> authzid' gs2CbindFlag :: BS.ByteString gs2CbindFlag = "n" -- we don't support channel binding yet gs2Header :: BS.ByteString gs2Header = merge $ [ gs2CbindFlag - , maybe "" id authzid - , "" - ] - cbindData :: BS.ByteString - cbindData = "" -- we don't support channel binding yet + , maybe "" id authzid'' + , "" + ] + -- cbindData :: BS.ByteString + -- cbindData = "" -- we don't support channel binding yet cFirstMessageBare :: BS.ByteString -> BS.ByteString - cFirstMessageBare cnonce = merge [ "n=" +++ Text.encodeUtf8 authcid + cFirstMessageBare cnonce = merge [ "n=" +++ Text.encodeUtf8 authcid' , "r=" +++ cnonce] cFirstMessage :: BS.ByteString -> BS.ByteString cFirstMessage cnonce = gs2Header +++ cFirstMessageBare cnonce @@ -99,13 +87,13 @@ fromPairs :: Pairs -> BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) (BS.ByteString, BS.ByteString, Integer) - fromPairs pairs cnonce | Just nonce <- lookup "r" pairs - , cnonce `BS.isPrefixOf` nonce - , Just salt' <- lookup "s" pairs - , Right salt <- B64.decode salt' - , Just ic <- lookup "i" pairs - , [(i,"")] <- reads $ BS8.unpack ic - = return (nonce, salt, i) + fromPairs prs cnonce | Just nonce <- lookup "r" prs + , cnonce `BS.isPrefixOf` nonce + , Just salt' <- lookup "s" prs + , Right salt <- B64.decode salt' + , Just ic <- lookup "i" prs + , [(i,"")] <- reads $ BS8.unpack ic + = return (nonce, salt, i) fromPairs _ _ = throwError $ AuthOtherFailure -- TODO: Log cFinalMessageAndVerifier :: BS.ByteString @@ -126,7 +114,7 @@ , "r=" +++ nonce] saltedPassword :: BS.ByteString - saltedPassword = hi (Text.encodeUtf8 password) salt ic + saltedPassword = hi (Text.encodeUtf8 pwd) salt ic clientKey :: BS.ByteString clientKey = hmac saltedPassword "Client Key" @@ -154,9 +142,9 @@ -- helper hi :: BS.ByteString -> BS.ByteString -> Integer -> BS.ByteString - hi str salt ic = foldl1' xorBS (genericTake ic us) + hi str slt ic' = foldl1' xorBS (genericTake ic' us) where - u1 = hmac str (salt +++ (BS.pack [0,0,0,1])) + u1 = hmac str (slt +++ (BS.pack [0,0,0,1])) us = iterate (hmac str) u1 scramSha1 :: Text.Text -- ^ username diff --git a/source/Network/Xmpp/Sasl/StringPrep.hs b/source/Network/Xmpp/Sasl/StringPrep.hs --- a/source/Network/Xmpp/Sasl/StringPrep.hs +++ b/source/Network/Xmpp/Sasl/StringPrep.hs @@ -4,27 +4,34 @@ import Text.StringPrep import qualified Data.Set as Set -import Data.Text(singleton) +import Data.Text(Text, singleton) +nonAsciiSpaces :: Set.Set Char nonAsciiSpaces = Set.fromList [ '\x00A0', '\x1680', '\x2000', '\x2001', '\x2002' , '\x2003', '\x2004', '\x2005', '\x2006', '\x2007' , '\x2008', '\x2009', '\x200A', '\x200B', '\x202F' , '\x205F', '\x3000' ] +toSpace :: Char -> Text toSpace x = if x `Set.member` nonAsciiSpaces then " " else singleton x +saslPrepQuery :: StringPrepProfile saslPrepQuery = Profile [b1, toSpace] True [c12, c21, c22, c3, c4, c5, c6, c7, c8, c9] True +saslPrepStore :: StringPrepProfile saslPrepStore = Profile [b1, toSpace] True [a1, c12, c21, c22, c3, c4, c5, c6, c7, c8, c9] True +normalizePassword :: Text -> Maybe Text normalizePassword = runStringPrep saslPrepStore + +normalizeUsername :: Text -> Maybe Text normalizeUsername = runStringPrep saslPrepQuery diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -1,30 +1,10 @@ {-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Sasl.Types where -import Control.Monad.Error import Control.Monad.State.Strict import Data.ByteString(ByteString) import qualified Data.Text as Text import Network.Xmpp.Types - --- | Signals a (non-fatal) SASL authentication error condition. -data AuthFailure = -- | No mechanism offered by the server was matched - -- by the provided acceptable mechanisms; wraps the - -- mechanisms offered by the server - AuthNoAcceptableMechanism [Text.Text] - | AuthStreamFailure XmppFailure -- TODO: Remove - -- | A SASL failure element was encountered - | AuthSaslFailure SaslFailure - -- | The credentials provided did not conform to - -- the SASLprep Stringprep profile - | AuthIllegalCredentials - -- | Other failure; more information is available - -- in the log - | AuthOtherFailure - deriving Show - -instance Error AuthFailure where - noMsg = AuthOtherFailure data SaslElement = SaslSuccess (Maybe Text.Text) | SaslChallenge (Maybe Text.Text) 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,56 @@ +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_HADDOCK hide #-} + +-- | Stanza related functions and constants +-- + +module Network.Xmpp.Stanza where + +import Data.XML.Types +import Network.Xmpp.Types + +-- | Request subscription with an entity. +presenceSubscribe :: Jid -> Presence +presenceSubscribe to = presence { presenceTo = Just to + , presenceType = Subscribe + } + +-- | Approve a subscripton of an entity. +presenceSubscribed :: Jid -> Presence +presenceSubscribed to = presence { presenceTo = Just to + , presenceType = Subscribed + } + +-- | End a subscription with an entity. +presenceUnsubscribe :: Jid -> Presence +presenceUnsubscribe to = presence { presenceTo = Just to + , presenceType = Unsubscribed + } + +-- | Signal to the server that the client is available for communication. +presenceOnline :: Presence +presenceOnline = presence + +-- | Signal to the server that the client is no longer available for +-- communication. +presenceOffline :: Presence +presenceOffline = presence {presenceType = Unavailable} + +-- | Produce an answer message with the given payload, setting "from" to the +-- "to" attributes in the original message. Produces a 'Nothing' value of the +-- provided message message has no "from" attribute. Sets the "from" attribute +-- to 'Nothing' to let the server assign one. +answerMessage :: Message -> [Element] -> Maybe Message +answerMessage Message{messageFrom = Just frm, ..} payload = + Just Message{ messageFrom = Nothing + , messageID = Nothing + , messageTo = Just frm + , messagePayload = payload + , .. + } +answerMessage _ _ = Nothing + +-- | Add a recipient to a presence notification. +presTo :: Presence -> Jid -> Presence +presTo pres to = pres{presenceTo = Just to} diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -7,54 +7,46 @@ module Network.Xmpp.Stream where -import Control.Applicative ((<$>), (<*>)) +import Control.Applicative ((<$>)) import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.STM import qualified Control.Exception as Ex -import Control.Exception.Base import qualified Control.Exception.Lifted as ExL import Control.Monad import Control.Monad.Error -import Control.Monad.IO.Class -import Control.Monad.Reader import Control.Monad.State.Strict -import Control.Monad.Trans.Class +import Control.Monad.Trans.Resource as R +import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import Data.ByteString.Base64 -import Data.ByteString.Char8 as BSC8 +import qualified Data.ByteString.Char8 as BSC8 +import Data.Char (isSpace) import Data.Conduit -import Data.Conduit.Binary as CB import qualified Data.Conduit.Internal as DCI import qualified Data.Conduit.List as CL -import Data.Maybe (fromJust, isJust, isNothing) +import Data.IP +import Data.List +import Data.Maybe +import Data.Ord import Data.Text (Text) import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import Data.Void (Void) import Data.XML.Pickle import Data.XML.Types import qualified GHC.IO.Exception as GIE import Network +import Network.DNS hiding (encode, lookup) import Network.Xmpp.Marshal import Network.Xmpp.Types import System.IO -import System.IO.Error (tryIOError) +-- import System.IO.Error (tryIOError) <- Only available in base >=4.4 import System.Log.Logger +import System.Random (randomRIO) import Text.XML.Stream.Parse as XP import Text.XML.Unresolved(InvalidEventStream(..)) -import Control.Monad.Trans.Resource as R import Network.Xmpp.Utilities -import Network.DNS hiding (encode, lookup) - -import Data.Ord -import Data.Maybe -import Data.List -import Data.IP -import System.Random - -import qualified Network.Socket as NS - -- "readMaybe" definition, as readMaybe is not introduced in the `base' package -- until version 4.6. readMaybe_ :: (Read a) => String -> Maybe a @@ -72,6 +64,17 @@ lmb [] = Nothing lmb x = Just x +pushing :: MonadIO m => + m (Either XmppFailure Bool) + -> ErrorT XmppFailure m () +pushing m = do + res <- ErrorT m + case res of + True -> return () + False -> do + liftIO $ debugM "Pontarius.Xmpp" "Failed to send data." + throwError XmppOtherFailure + -- Unpickles and returns a stream element. streamUnpickleElem :: PU [Node] a -> Element @@ -85,7 +88,7 @@ -- This is the conduit sink that handles the stream XML events. We extend it -- with ErrorT capabilities. -type StreamSink a = ErrorT XmppFailure (Pipe Event Event Void () IO) a +type StreamSink a = ErrorT XmppFailure (ConduitM Event Void IO) a -- Discards all events before the first EventBeginElement. throwOutJunk :: Monad m => Sink Event m () @@ -114,55 +117,63 @@ startStream :: StateT StreamState IO (Either XmppFailure ()) startStream = runErrorT $ do lift $ lift $ debugM "Pontarius.Xmpp" "Starting stream..." - state <- lift $ get + st <- lift $ get -- Set the `from' (which is also the expected to) attribute depending on the -- state of the stream. - let expectedTo = case ( streamConnectionState state - , toJid $ streamConfiguration state) of - (Plain, (Just (jid, True))) -> Just jid - (Secured, (Just (jid, _))) -> Just jid - (Plain, Nothing) -> Nothing - (Secured, Nothing) -> Nothing - case streamAddress state of + let expectedTo = case ( streamConnectionState st + , toJid $ streamConfiguration st) of + (Plain , (Just (jid, True))) -> Just jid + (Plain , _ ) -> Nothing + (Secured , (Just (jid, _ ))) -> Just jid + (Secured , Nothing ) -> Nothing + (Closed , _ ) -> Nothing + (Finished , _ ) -> Nothing + case streamAddress st of Nothing -> do - lift $ lift $ errorM "Pontarius.XMPP" "Server sent no hostname." + lift $ lift $ errorM "Pontarius.Xmpp" "Server sent no hostname." throwError XmppOtherFailure - Just address -> lift $ do - pushXmlDecl - pushOpenElement $ + Just address -> do + pushing pushXmlDecl + pushing . pushOpenElement . streamNSHack $ pickleElem xpStream ( "1.0" , expectedTo , Just (Jid Nothing address Nothing) , Nothing - , preferredLang $ streamConfiguration state + , preferredLang $ streamConfiguration st ) response <- ErrorT $ runEventsSink $ runErrorT $ streamS expectedTo case response of - Left e -> throwError e - -- Successful unpickling of stream element. - Right (Right (ver, from, to, id, lt, features)) + Right (ver, from, to, sid, lt, features) | (Text.unpack ver) /= "1.0" -> closeStreamWithError StreamUnsupportedVersion Nothing "Unknown version" - | lt == Nothing -> - closeStreamWithError StreamInvalidXml Nothing - "Stream has no language tag" - -- If `from' is set, we verify that it's the correct one. TODO: Should we check against the realm instead? - | isJust from && (from /= Just (Jid Nothing (fromJust $ streamAddress state) Nothing)) -> + + -- HACK: We ignore MUST-strength requirement (section 4.7.4. of RFC + -- 6120) for the sake of compatibility with jabber.org + -- | lt == Nothing -> + -- closeStreamWithError StreamInvalidXml Nothing + -- "Stream has no language tag" + + -- If `from' is set, we verify that it's the correct one. TODO: Should we + -- check against the realm instead? + | isJust from && (from /= Just (Jid Nothing (fromJust $ streamAddress st) Nothing)) -> closeStreamWithError StreamInvalidFrom Nothing "Stream from is invalid" | to /= expectedTo -> closeStreamWithError StreamUndefinedCondition (Just $ Element "invalid-to" [] []) "Stream to invalid"-- TODO: Suitable? | otherwise -> do + -- HACK: (ignore section 4.7.4. of RFC 6120), see above + unless (isJust lt) $ liftIO $ warningM "Pontariusm.Xmpp" + "Stream has no language tag" modify (\s -> s{ streamFeatures = features , streamLang = lt - , streamId = id + , streamId = sid , streamFrom = from } ) return () -- Unpickling failed - we investigate the element. - Right (Left (Element name attrs children)) + Left (Element name attrs _children) | (nameLocalName name /= "stream") -> closeStreamWithError StreamInvalidXml Nothing "Root element is not stream" @@ -174,21 +185,23 @@ "Root name prefix set and not stream" | otherwise -> ErrorT $ checkchildren (flattenAttrs attrs) where - -- closeStreamWithError :: MonadIO m => Stream -> StreamErrorCondition -> - -- Maybe Element -> ErrorT XmppFailure m () + -- HACK: We include the default namespace to make isode's M-LINK server happy. + streamNSHack e = e{elementAttributes = elementAttributes e + ++ [( "xmlns" + , [ContentText "jabber:client"])]} closeStreamWithError :: StreamErrorCondition -> Maybe Element -> String -> ErrorT XmppFailure (StateT StreamState IO) () closeStreamWithError sec el msg = do - lift . pushElement . pickleElem xpStreamError + void . lift . pushElement . pickleElem xpStreamError $ StreamErrorInfo sec Nothing el - lift $ closeStreams' - lift $ lift $ errorM "Pontarius.XMPP" $ "closeStreamWithError: " ++ msg + void . lift $ closeStreams' + liftIO $ errorM "Pontarius.Xmpp" $ "closeStreamWithError: " ++ msg throwError XmppOtherFailure checkchildren children = let to' = lookup "to" children ver' = lookup "version" children xl = lookup xmlLang children - in case () of () | Just (Nothing :: Maybe Jid) == (safeRead <$> to') -> + in case () of () | Just Nothing == fmap jidFromText to' -> runErrorT $ closeStreamWithError StreamBadNamespacePrefix Nothing "stream to not a valid JID" @@ -206,12 +219,12 @@ "" safeRead x = case reads $ Text.unpack x of [] -> Nothing - [(y,_),_] -> Just y + ((y,_):_) -> Just y flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)] -flattenAttrs attrs = Prelude.map (\(name, content) -> +flattenAttrs attrs = Prelude.map (\(name, cont) -> ( name - , Text.concat $ Prelude.map uncontentify content) + , Text.concat $ Prelude.map uncontentify cont) ) attrs where @@ -222,19 +235,50 @@ -- and calls xmppStartStream. restartStream :: StateT StreamState IO (Either XmppFailure ()) restartStream = do - lift $ debugM "Pontarius.XMPP" "Restarting stream..." - raw <- gets (streamReceive . streamHandle) - let newSource = DCI.ResumableSource (loopRead raw $= XP.parseBytes def) - (return ()) - modify (\s -> s{streamEventSource = newSource }) + liftIO $ debugM "Pontarius.Xmpp" "Restarting stream..." + raw <- gets streamHandle + let newSource = sourceStreamHandle raw $= XP.parseBytes def + buffered <- liftIO . bufferSrc $ newSource + modify (\s -> s{streamEventSource = buffered }) startStream + + +sourceStreamHandle :: MonadIO m => StreamHandle -> ConduitM i ByteString m () +sourceStreamHandle s = loopRead $ streamReceive s where - loopRead read = do - bs <- liftIO (read 4096) + loopRead rd = do + bs <- liftIO (rd 4096) if BS.null bs then return () - else yield bs >> loopRead read + else do + liftIO $ debugM "Pontarius.Xmpp" $ "in: " ++ + (Text.unpack . Text.decodeUtf8 $ bs) + yield bs + loopRead rd +-- We buffer sources because we don't want to lose data when multiple +-- xml-entities are sent with the same packet and we don't want to eternally +-- block the StreamState while waiting for data to arrive +bufferSrc :: MonadIO m => Source IO o -> IO (ConduitM i o m ()) +bufferSrc src = do + ref <- newTMVarIO $ DCI.ResumableSource src (return ()) + let go = do + dt <- liftIO $ Ex.bracketOnError (atomically $ takeTMVar ref) + (\_ -> atomically . putTMVar ref $ + DCI.ResumableSource zeroSource + (return ()) + ) + (\s -> do + (s', dt) <- s $$++ CL.head + atomically $ putTMVar ref s' + return dt + ) + case dt of + Nothing -> return () + Just d -> yield d >> go + return go + + -- Reads the (partial) stream:stream and the server features from the stream. -- Returns the (unvalidated) stream attributes, the unparsed element, or -- throwError throws a `XmppOtherFailure' (if something other than an element @@ -247,12 +291,12 @@ , Maybe Text , Maybe LangTag , StreamFeatures )) -streamS expectedTo = do - header <- xmppStreamHeader - case header of - Right (version, from, to, id, langTag) -> do +streamS _expectedTo = do -- TODO: check expectedTo + streamHeader <- xmppStreamHeader + case streamHeader of + Right (version, from, to, sid, lTag) -> do features <- xmppStreamFeatures - return $ Right (version, from, to, id, langTag, features) + return $ Right (version, from, to, sid, lTag, features) Left el -> return $ Left el where xmppStreamHeader :: StreamSink (Either Element (Text, Maybe Jid, Maybe Jid, Maybe Text.Text, Maybe LangTag)) @@ -270,7 +314,7 @@ e <- lift $ elements =$ CL.head case e of Nothing -> do - lift $ lift $ errorM "Pontarius.XMPP" "streamS: Stream ended." + lift $ lift $ errorM "Pontarius.Xmpp" "streamS: Stream ended." throwError XmppOtherFailure Just r -> streamUnpickleElem xpStreamFeatures r @@ -278,39 +322,49 @@ -- realm. openStream :: HostName -> StreamConfiguration -> IO (Either XmppFailure (Stream)) openStream realm config = runErrorT $ do - lift $ debugM "Pontarius.XMPP" "Opening stream..." + lift $ debugM "Pontarius.Xmpp" "Opening stream..." stream' <- createStream realm config - result <- liftIO $ withStream startStream stream' + ErrorT . liftIO $ withStream startStream stream' return stream' --- | Send "" and wait for the server to finish processing and to --- close the connection. Any remaining elements from the server are returned. --- Surpresses StreamEndFailure exceptions, but may throw a StreamCloseError. -closeStreams :: Stream -> IO (Either XmppFailure [Element]) +-- | Send \"\" and wait for the server to finish processing and +-- to close the connection. Any remaining elements from the server are returned. +-- Surpresses 'StreamEndFailure' exceptions, but may throw a 'StreamCloseError'. +closeStreams :: Stream -> IO () closeStreams = withStream closeStreams' +closeStreams' :: StateT StreamState IO () closeStreams' = do - lift $ debugM "Pontarius.XMPP" "Closing stream..." + lift $ debugM "Pontarius.Xmpp" "Closing stream" send <- gets (streamSend . streamHandle) cc <- gets (streamClose . streamHandle) - liftIO $ send "" + 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 - (Ex.try cc) :: IO (Either Ex.SomeException ()) + void ((Ex.try cc) :: IO (Either Ex.SomeException ())) return () - collectElems [] - where - -- Pulls elements from the stream until the stream ends, or an error is - -- raised. - collectElems :: [Element] -> StateT StreamState IO (Either XmppFailure [Element]) - collectElems es = do - result <- pullElement - case result of - Left StreamEndFailure -> return $ Right es - Left e -> return $ Left $ StreamCloseError (es, e) - Right e -> collectElems (e:es) + put xmppNoStream{ streamConnectionState = Finished } +-- lift $ debugM "Pontarius.Xmpp" "Collecting remaining elements" +-- es <- collectElems [] + -- lift $ debugM "Pontarius.Xmpp" "Stream sucessfully closed" + -- return es + -- where + -- -- Pulls elements from the stream until the stream ends, or an error is + -- -- raised. + -- collectElems :: [Element] -> StateT StreamState IO (Either XmppFailure [Element]) + -- collectElems es = do + -- result <- pullElement + -- case result of + -- Left StreamEndFailure -> return $ Right es + -- Left e -> return $ Left $ StreamCloseError (es, e) + -- Right e -> collectElems (e:es) -- TODO: Can the TLS send/recv functions throw something other than an IO error? +debugOut :: MonadIO m => ByteString -> m () +debugOut outData = liftIO $ debugM "Pontarius.Xmpp" + ("Out: " ++ (Text.unpack . Text.decodeUtf8 $ outData)) wrapIOException :: IO a -> StateT StreamState IO (Either XmppFailure a) wrapIOException action = do @@ -318,14 +372,32 @@ case r of Right b -> return $ Right b Left e -> do - lift $ warningM "Pontarius.XMPP" $ "wrapIOException: Exception wrapped: " ++ (show e) + lift $ warningM "Pontarius.Xmpp" $ "wrapIOException: Exception wrapped: " ++ (show e) return $ Left $ XmppIOException e pushElement :: Element -> StateT StreamState IO (Either XmppFailure Bool) pushElement x = do send <- gets (streamSend . streamHandle) - wrapIOException $ send $ renderElement x + let outData = renderElement $ nsHack x + debugOut outData + wrapIOException $ send outData + where + -- HACK: We remove the "jabber:client" namespace because it is set as + -- default in the stream. This is to make isode's M-LINK server happy and + -- should be removed once jabber.org accepts prefix-free canonicalization +nsHack :: Element -> Element +nsHack e@(Element{elementName = n}) + | nameNamespace n == Just "jabber:client" = + e{ elementName = Name (nameLocalName n) Nothing Nothing + , elementNodes = map mapNSHack $ elementNodes e + } + | otherwise = e + where + mapNSHack :: Node -> Node + mapNSHack (NodeElement el) = NodeElement $ nsHack el + mapNSHack nd = nd + -- | Encode and send stanza pushStanza :: Stanza -> Stream -> IO (Either XmppFailure Bool) pushStanza s = withStream' . pushElement $ pickleElem xpStanza s @@ -341,57 +413,57 @@ pushOpenElement :: Element -> StateT StreamState IO (Either XmppFailure Bool) pushOpenElement e = do - sink <- gets (streamSend . streamHandle) - wrapIOException $ sink $ renderOpenElement e + send <- gets (streamSend . streamHandle) + let outData = renderOpenElement e + debugOut outData + wrapIOException $ send outData -- `Connect-and-resumes' the given sink to the stream source, and pulls a -- `b' value. -runEventsSink :: Sink Event IO b -> StateT StreamState IO (Either XmppFailure b) +runEventsSink :: Sink Event IO b -> StateT StreamState IO b runEventsSink snk = do -- TODO: Wrap exceptions? src <- gets streamEventSource - (src', r) <- lift $ src $$++ snk - modify (\s -> s{streamEventSource = src'}) - return $ Right r + r <- liftIO $ src $$ snk + return r pullElement :: StateT StreamState IO (Either XmppFailure Element) pullElement = do ExL.catches (do e <- runEventsSink (elements =$ await) case e of - Left f -> return $ Left f - Right Nothing -> do - lift $ errorM "Pontarius.XMPP" "pullElement: No element." + Nothing -> do + lift $ errorM "Pontarius.Xmpp" "pullElement: Stream ended." return . Left $ XmppOtherFailure - Right (Just r) -> return $ Right r + Just r -> return $ Right r ) [ ExL.Handler (\StreamEnd -> return $ Left StreamEndFailure) , ExL.Handler (\(InvalidXmppXml s) -- Invalid XML `Event' encountered, or missing element close tag -> do - lift $ errorM "Pontarius.XMPP" $ "pullElement: Invalid XML: " ++ (show s) + lift $ errorM "Pontarius.Xmpp" $ "pullElement: Invalid XML: " ++ (show s) return . Left $ XmppOtherFailure) , ExL.Handler $ \(e :: InvalidEventStream) -> do - lift $ errorM "Pontarius.XMPP" $ "pullElement: Invalid event stream: " ++ (show e) + lift $ errorM "Pontarius.Xmpp" $ "pullElement: Invalid event stream: " ++ (show e) return . Left $ XmppOtherFailure ] -- Pulls an element and unpickles it. pullUnpickle :: PU [Node] a -> StateT StreamState IO (Either XmppFailure a) pullUnpickle p = do - elem <- pullElement - case elem of + el <- pullElement + case el of Left e -> return $ Left e Right elem' -> do let res = unpickleElem p elem' case res of Left e -> do - lift $ errorM "Pontarius.XMPP" $ "pullUnpickle: Unpickle failed: " ++ (ppUnpickleError e) + lift $ errorM "Pontarius.Xmpp" $ "pullUnpickle: Unpickle failed: " ++ (ppUnpickleError e) return . Left $ XmppOtherFailure Right r -> return $ Right r -- | Pulls a stanza (or stream error) from the stream. pullStanza :: Stream -> IO (Either XmppFailure Stanza) -pullStanza = withStream $ do +pullStanza = withStream' $ do res <- pullUnpickle xpStreamStanza case res of Left e -> return $ Left e @@ -409,20 +481,23 @@ _ -> ExL.throwIO e ) +zeroHandle :: StreamHandle +zeroHandle = StreamHandle { streamSend = \_ -> return False + , streamReceive = \_ -> do + errorM "Pontarius.Xmpp" + "xmppNoStream: Stream is closed." + ExL.throwIO XmppOtherFailure + , streamFlush = return () + , streamClose = return () + } + -- Stream state used when there is no connection. xmppNoStream :: StreamState xmppNoStream = StreamState { streamConnectionState = Closed - , streamHandle = StreamHandle { streamSend = \_ -> return False - , streamReceive = \_ -> do - errorM "Pontarius.XMPP" "xmppNoStream: No stream on receive." - ExL.throwIO $ - XmppOtherFailure - , streamFlush = return () - , streamClose = return () - } - , streamEventSource = DCI.ResumableSource zeroSource (return ()) - , streamFeatures = StreamFeatures Nothing [] [] + , streamHandle = zeroHandle + , streamEventSource = zeroSource + , streamFeatures = StreamFeatures Nothing [] Nothing [] , streamAddress = Nothing , streamFrom = Nothing , streamId = Nothing @@ -430,33 +505,34 @@ , streamJid = Nothing , streamConfiguration = def } - where - zeroSource :: Source IO output - zeroSource = liftIO $ do - errorM "Pontarius.XMPP" "zeroSource utilized." - ExL.throwIO XmppOtherFailure +zeroSource :: Source IO output +zeroSource = liftIO $ do + debugM "Pontarius.Xmpp" "zeroSource" + ExL.throwIO XmppOtherFailure + +handleToStreamHandle :: Handle -> StreamHandle +handleToStreamHandle h = StreamHandle { streamSend = \d -> catchPush $ BS.hPut h d + , streamReceive = \n -> BS.hGetSome h n + , streamFlush = hFlush h + , streamClose = hClose h + } + createStream :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (Stream) createStream realm config = do result <- connect realm config case result of - Just h -> ErrorT $ do + Just hand -> ErrorT $ do debugM "Pontarius.Xmpp" "Acquired handle." debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle." - hSetBuffering h NoBuffering - let eSource = DCI.ResumableSource - ((sourceHandle h $= logConduit) $= XP.parseBytes def) - (return ()) - let hand = StreamHandle { streamSend = \d -> catchPush $ BS.hPut h d - , streamReceive = \n -> BS.hGetSome h n - , streamFlush = hFlush h - , streamClose = hClose h - } + eSource <- liftIO . bufferSrc $ + (sourceStreamHandle hand $= logConduit) + $= XP.parseBytes def let stream = StreamState { streamConnectionState = Plain , streamHandle = hand , streamEventSource = eSource - , streamFeatures = StreamFeatures Nothing [] [] + , streamFeatures = StreamFeatures Nothing [] Nothing [] , streamAddress = Just $ Text.pack realm , streamFrom = Nothing , streamId = Nothing @@ -472,7 +548,7 @@ where logConduit :: Conduit ByteString IO ByteString logConduit = CL.mapM $ \d -> do - debugM "Pontarius.Xmpp" $ "Received TCP data: " ++ (BSC8.unpack d) ++ + debugM "Pontarius.Xmpp" $ "In: " ++ (BSC8.unpack d) ++ "." return d @@ -481,81 +557,100 @@ -- case that address is used instead). If an A(AAA) record results are -- encountered, all IP addresses will be tried until a successful connection -- attempt has been made. Will return the Handle acquired, if any. -connect :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (Maybe Handle) +connect :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO + (Maybe StreamHandle) connect realm config = do - case socketDetails config of - -- Just (_, NS.SockAddrUnix _) -> do - -- lift $ errorM "Pontarius.Xmpp" "SockAddrUnix address provided." - -- throwError XmppIllegalTcpDetails - Just socketDetails' -> lift $ do - debugM "Pontarius.Xmpp" "Connecting to configured SockAddr address..." - connectTcp $ Left socketDetails' + case connectionDetails config of + UseHost host port -> lift $ do + debugM "Pontarius.Xmpp" "Connecting to configured address." + h <- connectTcp $ [(host, port)] + case h of + Nothing -> return Nothing + Just h' -> do + liftIO $ hSetBuffering h' NoBuffering + return . Just $ handleToStreamHandle h' + UseSrv host -> do + h <- connectSrv (resolvConf config) host + case h of + Nothing -> return Nothing + Just h' -> do + liftIO $ hSetBuffering h' NoBuffering + return . Just $ handleToStreamHandle h' + UseRealm -> do + h <- connectSrv (resolvConf config) realm + case h of + Nothing -> return Nothing + Just h' -> do + liftIO $ hSetBuffering h' NoBuffering + return . Just $ handleToStreamHandle h' + UseConnection mkC -> Just <$> mkC + +connectSrv :: ResolvConf -> String -> ErrorT XmppFailure IO (Maybe Handle) +connectSrv config host = do + case checkHostName (Text.pack host) of + Just host' -> do + resolvSeed <- lift $ makeResolvSeed config + lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..." + srvRecords <- srvLookup host' resolvSeed + case srvRecords of + Nothing -> do + lift $ debugM "Pontarius.Xmpp" + "No SRV records, using fallback process." + lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ host) + 5222 + Just srvRecords' -> do + lift $ debugM "Pontarius.Xmpp" + "SRV records found, performing A/AAAA lookups." + lift $ resolvSrvsAndConnectTcp resolvSeed srvRecords' Nothing -> do - case (readMaybe_ realm :: Maybe IPv6, readMaybe_ realm :: Maybe IPv4, hostname (Text.pack realm) :: Maybe Hostname) of - (Just ipv6, Nothing, _) -> lift $ connectTcp $ Right [(show ipv6, 5222)] - (Nothing, Just ipv4, _) -> lift $ connectTcp $ Right [(show ipv4, 5222)] - (Nothing, Nothing, Just (Hostname realm')) -> do - resolvSeed <- lift $ makeResolvSeed (resolvConf config) - lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..." - srvRecords <- srvLookup realm' resolvSeed - case srvRecords of - -- No SRV records. Try fallback lookup. - Nothing -> do - lift $ debugM "Pontarius.Xmpp" "No SRV records, using fallback process..." - lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ realm) 5222 - Just srvRecords' -> do - lift $ debugM "Pontarius.Xmpp" "SRV records found, performing A/AAAA lookups..." - lift $ resolvSrvsAndConnectTcp resolvSeed srvRecords' - (Nothing, Nothing, Nothing) -> do - lift $ errorM "Pontarius.Xmpp" "The hostname could not be validated." - throwError XmppIllegalTcpDetails + lift $ errorM "Pontarius.Xmpp" + "The hostname could not be validated." + throwError XmppIllegalTcpDetails -- Connects to a list of addresses and ports. Surpresses any exceptions from -- connectTcp. -connectTcp :: Either (NS.Socket, NS.SockAddr) [(HostName, Int)] -> IO (Maybe Handle) -connectTcp (Right []) = return Nothing -connectTcp (Right ((address, port):remainder)) = do - result <- try $ (do - debugM "Pontarius.Xmpp" $ "Connecting to " ++ (address) ++ " on port " ++ +connectTcp :: [(HostName, PortID)] -> IO (Maybe Handle) +connectTcp [] = return Nothing +connectTcp ((address, port):remainder) = do + result <- Ex.try $ (do + debugM "Pontarius.Xmpp" $ "Connecting to " ++ address ++ " on port " ++ (show port) ++ "." - connectTo address (PortNumber $ fromIntegral port)) :: IO (Either IOException Handle) + connectTo address port) :: IO (Either Ex.IOException Handle) case result of Right handle -> do debugM "Pontarius.Xmpp" "Successfully connected to HostName." return $ Just handle Left _ -> do debugM "Pontarius.Xmpp" "Connection to HostName could not be established." - connectTcp $ Right remainder -connectTcp (Left (sock, sockAddr)) = do - result <- try $ (do - NS.connect sock sockAddr - NS.socketToHandle sock ReadWriteMode) :: IO (Either IOException Handle) - case result of - Right handle -> do - debugM "Pontarius.Xmpp" "Successfully connected to SockAddr." - return $ Just handle - Left _ -> do - debugM "Pontarius.Xmpp" "Connection to SockAddr could not be established." - return Nothing + connectTcp remainder -- Makes an AAAA query to acquire a IPs, and tries to connect to all of them. If -- a handle can not be acquired this way, an analogous A query is performed. -- Surpresses all IO exceptions. resolvAndConnectTcp :: ResolvSeed -> Domain -> Int -> IO (Maybe Handle) resolvAndConnectTcp resolvSeed domain port = do - aaaaResults <- (try $ rethrowErrorCall $ withResolver resolvSeed $ - \resolver -> lookupAAAA resolver domain) :: IO (Either IOException (Maybe [IPv6])) + aaaaResults <- (Ex.try $ rethrowErrorCall $ withResolver resolvSeed $ + \resolver -> lookupAAAA resolver domain) :: IO (Either Ex.IOException (Maybe [IPv6])) handle <- case aaaaResults of Right Nothing -> return Nothing - Right (Just ipv6s) -> connectTcp $ Right $ Data.List.map (\ipv6 -> (show ipv6, port)) ipv6s - Left e -> return Nothing + Right (Just ipv6s) -> connectTcp $ + map (\ip -> ( show ip + , PortNumber $ fromIntegral port)) + ipv6s + Left _e -> return Nothing case handle of Nothing -> do - aResults <- (try $ rethrowErrorCall $ withResolver resolvSeed $ - \resolver -> lookupA resolver domain) :: IO (Either IOException (Maybe [IPv4])) + aResults <- (Ex.try $ rethrowErrorCall $ withResolver resolvSeed $ + \resolver -> lookupA resolver domain) :: IO (Either Ex.IOException (Maybe [IPv4])) handle' <- case aResults of + Left _ -> return Nothing Right Nothing -> return Nothing - Right (Just ipv4s) -> connectTcp $ Right $ Data.List.map (\ipv4 -> (show ipv4, port)) ipv4s + + Right (Just ipv4s) -> connectTcp $ + map (\ip -> (show ip + , PortNumber + $ fromIntegral port)) + ipv4s case handle' of Nothing -> return Nothing Just handle'' -> return $ Just handle'' @@ -576,29 +671,30 @@ -- exceptions and rethrows them as IOExceptions. rethrowErrorCall :: IO a -> IO a rethrowErrorCall action = do - result <- try action + result <- Ex.try action case result of Right result' -> return result' - Left (ErrorCall e) -> ioError $ userError $ "rethrowErrorCall: " ++ e - Left e -> throwIO e + Left (Ex.ErrorCall e) -> Ex.ioError $ userError + $ "rethrowErrorCall: " ++ e -- Provides a list of A(AAA) names and port numbers upon a successful -- DNS-SRV request, or `Nothing' if the DNS-SRV request failed. srvLookup :: Text -> ResolvSeed -> ErrorT XmppFailure IO (Maybe [(Domain, Int)]) srvLookup realm resolvSeed = ErrorT $ do - result <- try $ rethrowErrorCall $ withResolver resolvSeed $ \resolver -> do + result <- Ex.try $ rethrowErrorCall $ withResolver resolvSeed + $ \resolver -> do srvResult <- lookupSRV resolver $ BSC8.pack $ "_xmpp-client._tcp." ++ (Text.unpack realm) ++ "." case srvResult of - Just srvResult -> do - debugM "Pontarius.Xmpp" $ "SRV result: " ++ (show srvResult) - -- Get [(Domain, PortNumber)] of SRV request, if any. - srvResult' <- orderSrvResult srvResult - return $ Just $ Prelude.map (\(_, _, port, domain) -> (domain, port)) srvResult' - -- The service is not available at this domain. - -- Sorts the records based on the priority value. Just [(_, _, _, ".")] -> do debugM "Pontarius.Xmpp" $ "\".\" SRV result returned." return $ Just [] + Just srvResult' -> do + debugM "Pontarius.Xmpp" $ "SRV result: " ++ (show srvResult') + -- Get [(Domain, PortNumber)] of SRV request, if any. + orderedSrvResult <- orderSrvResult srvResult' + return $ Just $ Prelude.map (\(_, _, port, domain) -> (domain, port)) orderedSrvResult + -- The service is not available at this domain. + -- Sorts the records based on the priority value. Nothing -> do debugM "Pontarius.Xmpp" "No SRV result returned." return Nothing @@ -629,7 +725,7 @@ orderSublist sublist = do -- Compute the running sum, as well as the total sum of -- the sublist. Add the running sum to the SRV tuples. - let (total, sublist') = Data.List.mapAccumL (\total (priority, weight, port, domain) -> (total + weight, (priority, weight, port, domain, total + weight))) 0 sublist + let (total, sublist') = Data.List.mapAccumL (\total' (priority, weight, port, domain) -> (total' + weight, (priority, weight, port, domain, total' + weight))) 0 sublist -- Choose a random number between 0 and the total sum -- (inclusive). randomNumber <- randomRIO (0, total) @@ -638,55 +734,56 @@ let (beginning, ((priority, weight, port, domain, _):end)) = Data.List.break (\(_, _, _, _, running) -> randomNumber <= running) sublist' -- Remove the running total number from the remaining -- elements. - let sublist'' = Data.List.map (\(priority, weight, port, domain, _) -> (priority, weight, port, domain)) (Data.List.concat [beginning, end]) + let sublist'' = Data.List.map (\(priority', weight', port', domain', _) -> (priority', weight', port', domain')) (Data.List.concat [beginning, end]) -- Repeat the ordering procedure on the remaining -- elements. - tail <- orderSublist sublist'' - return $ ((priority, weight, port, domain):tail) + rest <- orderSublist sublist'' + return $ ((priority, weight, port, domain):rest) --- Closes the connection and updates the XmppConMonad Stream state. --- killStream :: Stream -> IO (Either ExL.SomeException ()) +-- | Close the connection and updates the XmppConMonad Stream state. Does +-- not send the stream end tag. killStream :: Stream -> IO (Either XmppFailure ()) killStream = withStream $ do cc <- gets (streamClose . streamHandle) err <- wrapIOException cc -- (ExL.try cc :: IO (Either ExL.SomeException ())) - put xmppNoStream + put xmppNoStream{ streamConnectionState = Finished } return err -- Sends an IQ request and waits for the response. If the response ID does not -- match the outgoing ID, an error is thrown. -pushIQ :: StanzaID +pushIQ :: Text -> Maybe Jid -> IQRequestType -> Maybe LangTag -> Element -> Stream -> IO (Either XmppFailure (Either IQError IQResult)) -pushIQ iqID to tp lang body stream = do - pushStanza (IQRequestS $ IQRequest iqID Nothing to lang tp body) stream - res <- pullStanza stream +pushIQ iqID to tp lang body stream = runErrorT $ do + pushing $ pushStanza + (IQRequestS $ IQRequest iqID Nothing to lang tp body) stream + res <- lift $ pullStanza stream case res of - Left e -> return $ Left e - Right (IQErrorS e) -> return $ Right $ Left e + Left e -> throwError e + Right (IQErrorS e) -> return $ Left e Right (IQResultS r) -> do unless (iqID == iqResultID r) $ liftIO $ do - errorM "Pontarius.XMPP" $ "pushIQ: ID mismatch (" ++ (show iqID) ++ " /= " ++ (show $ iqResultID r) ++ ")." - ExL.throwIO XmppOtherFailure + liftIO $ errorM "Pontarius.Xmpp" $ "pushIQ: ID mismatch (" ++ (show iqID) ++ " /= " ++ (show $ iqResultID r) ++ ")." + liftIO $ ExL.throwIO XmppOtherFailure -- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++ -- " /= " ++ show (iqResultID r) ++ " .") - return $ Right $ Right r + return $ Right r _ -> do - errorM "Pontarius.XMPP" $ "pushIQ: Unexpected stanza type." - return . Left $ XmppOtherFailure + liftIO $ errorM "Pontarius.Xmpp" $ "pushIQ: Unexpected stanza type." + throwError XmppOtherFailure -debugConduit :: Pipe l ByteString ByteString u IO b +debugConduit :: (Show o, MonadIO m) => ConduitM o o m b debugConduit = forever $ do s' <- await case s' of Just s -> do - liftIO $ debugM "Pontarius.XMPP" $ "debugConduit: In: " ++ (show s) + liftIO $ debugM "Pontarius.Xmpp" $ "debugConduit: In: " ++ (show s) yield s Nothing -> return () @@ -697,7 +794,11 @@ Just (EventBeginElement n as) -> do goE n as >>= yield elements - Just (EventEndElement streamName) -> lift $ R.monadThrow StreamEnd + -- This might be an XML error if the end element tag is not + -- "". TODO: We might want to check this at a later time + Just (EventEndElement _) -> lift $ R.monadThrow StreamEnd + Just (EventContent (ContentText ct)) | Text.all isSpace ct -> + elements Nothing -> return () _ -> lift $ R.monadThrow $ InvalidXmppXml $ "not an element: " ++ show x where @@ -707,8 +808,8 @@ go front = do x <- f case x of - Left x -> return $ (x, front []) - Right y -> go (front . (:) y) + Left l -> return $ (l, front []) + Right r -> go (front . (:) r) goE n as = do (y, ns) <- many' goN if y == Just (EventEndElement n) @@ -732,11 +833,8 @@ compressNodes $ NodeContent (ContentText $ x `Text.append` y) : z compressNodes (x:xs) = x : compressNodes xs - streamName :: Name - streamName = (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) - -withStream :: StateT StreamState IO (Either XmppFailure c) -> Stream -> IO (Either XmppFailure c) -withStream action (Stream stream) = bracketOnError +withStream :: StateT StreamState IO a -> Stream -> IO a +withStream action (Stream stream) = Ex.bracketOnError (atomically $ takeTMVar stream ) (atomically . putTMVar stream) (\s -> do @@ -746,12 +844,16 @@ ) -- nonblocking version. Changes to the connection are ignored! -withStream' :: StateT StreamState IO (Either XmppFailure b) -> Stream -> IO (Either XmppFailure b) +withStream' :: StateT StreamState IO a -> Stream -> IO a withStream' action (Stream stream) = do stream_ <- atomically $ readTMVar stream (r, _) <- runStateT action stream_ return r -mkStream :: StreamState -> IO (Stream) -mkStream con = Stream `fmap` (atomically $ newTMVar con) +mkStream :: StreamState -> IO Stream +mkStream con = Stream `fmap` atomically (newTMVar con) + +-- "Borrowed" from base-4.4 for compatibility with GHC 7.0.1. +tryIOError :: IO a -> IO (Either IOError a) +tryIOError f = Ex.catch (Right <$> f) (return . Left) diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -4,7 +4,6 @@ module Network.Xmpp.Tls where -import Control.Concurrent.STM.TMVar import qualified Control.Exception.Lifted as Ex import Control.Monad import Control.Monad.Error @@ -14,21 +13,31 @@ import qualified Data.ByteString.Char8 as BSC8 import qualified Data.ByteString.Lazy as BL import Data.Conduit -import qualified Data.Conduit.Binary as CB import Data.IORef -import Data.Typeable import Data.XML.Types +import Network.DNS.Resolver (ResolvConf) import Network.TLS -import Network.TLS.Extra import Network.Xmpp.Stream import Network.Xmpp.Types -import System.Log.Logger (debugM, errorM) +import System.Log.Logger (debugM, errorM, infoM) +mkBackend :: StreamHandle -> Backend mkBackend con = Backend { backendSend = \bs -> void (streamSend con bs) - , backendRecv = streamReceive con + , backendRecv = bufferReceive (streamReceive con) , backendFlush = streamFlush con , backendClose = streamClose con } + where + bufferReceive _ 0 = return BS.empty + bufferReceive recv n = BS.concat `liftM` (go n) + where + go m = do + bs <- recv m + case BS.length bs of + 0 -> return [] + l -> if l < m + then (bs :) `liftM` go (m - l) + else return [bs] starttlsE :: Element starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] @@ -43,49 +52,63 @@ case sState of Plain -> return () Closed -> do - liftIO $ errorM "Pontarius.XMPP" "startTls: The stream is closed." + liftIO $ errorM "Pontarius.Xmpp.Tls" "The stream is closed." throwError XmppNoStream + Finished -> do + liftIO $ errorM "Pontarius.Xmpp.Tls" "The stream is finished." + throwError XmppNoStream Secured -> do - liftIO $ errorM "Pontarius.XMPP" "startTls: The stream is already secured." + liftIO $ errorM "Pontarius.Xmpp.Tls" "The stream is already secured." throwError TlsStreamSecured features <- lift $ gets streamFeatures case (tlsBehaviour conf, streamTls features) of (RequireTls , Just _ ) -> startTls (RequireTls , Nothing ) -> throwError TlsNoServerSupport (PreferTls , Just _ ) -> startTls - (PreferTls , Nothing ) -> return () + (PreferTls , Nothing ) -> skipTls (PreferPlain , Just True) -> startTls - (PreferPlain , _ ) -> return () + (PreferPlain , _ ) -> skipTls (RefuseTls , Just True) -> throwError XmppOtherFailure - (RefuseTls , _ ) -> return () + (RefuseTls , _ ) -> skipTls where + skipTls = liftIO $ infoM "Pontarius.Xmpp.Tls" "Skipping TLS negotiation" startTls = do + liftIO $ infoM "Pontarius.Xmpp.Tls" "Running StartTLS" params <- gets $ tlsParams . streamConfiguration - lift $ pushElement starttlsE + sent <- ErrorT $ pushElement starttlsE + unless sent $ do + liftIO $ errorM "Pontarius.Xmpp.Tls" "Could not sent stanza." + throwError XmppOtherFailure answer <- lift $ pullElement case answer of - Left e -> return $ Left e + Left e -> throwError e Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] []) -> - return $ Right () + return () Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _) -> do - liftIO $ errorM "Pontarius.XMPP" "startTls: TLS initiation failed." - return . Left $ XmppOtherFailure + liftIO $ errorM "Pontarius.Xmpp" "startTls: TLS initiation failed." + throwError XmppOtherFailure + Right r -> + liftIO $ errorM "Pontarius.Xmpp.Tls" $ + "Unexpected element: " ++ show r hand <- gets streamHandle - (raw, _snk, psh, read, ctx) <- lift $ tlsinit params (mkBackend hand) + (_raw, _snk, psh, recv, ctx) <- lift $ tlsinit params (mkBackend hand) let newHand = StreamHandle { streamSend = catchPush . psh - , streamReceive = read - , streamFlush = contextFlush ctx - , streamClose = bye ctx >> streamClose hand - } + , streamReceive = recv + , streamFlush = contextFlush ctx + , streamClose = bye ctx >> streamClose hand + } lift $ modify ( \x -> x {streamHandle = newHand}) + liftIO $ infoM "Pontarius.Xmpp.Tls" "Stream Secured." either (lift . Ex.throwIO) return =<< lift restartStream modify (\s -> s{streamConnectionState = Secured}) return () +client :: (MonadIO m, CPRG rng) => Params -> rng -> Backend -> m Context client params gen backend = do contextNew backend params gen -defaultParams = defaultParamsClient +xmppDefaultParams :: Params +xmppDefaultParams = defaultParamsClient tlsinit :: (MonadIO m, MonadIO m1) => TLSParams @@ -96,14 +119,14 @@ , Int -> m1 BS.ByteString , Context ) -tlsinit tlsParams backend = do - liftIO $ debugM "Pontarius.Xmpp.TLS" "TLS with debug mode enabled." +tlsinit params backend = do + liftIO $ debugM "Pontarius.Xmpp.Tls" "TLS with debug mode enabled." gen <- liftIO $ getSystemRandomGen -- TODO: Find better random source? - con <- client tlsParams gen backend + con <- client params gen backend handshake con let src = forever $ do dt <- liftIO $ recvData con - liftIO $ debugM "Pontarius.Xmpp.TLS" ("in :" ++ BSC8.unpack dt) + liftIO $ debugM "Pontarius.Xmpp.Tls" ("In :" ++ BSC8.unpack dt) yield dt let snk = do d <- await @@ -111,27 +134,44 @@ Nothing -> return () Just x -> do sendData con (BL.fromChunks [x]) - liftIO $ debugM "Pontarius.Xmpp.TLS" - ("out :" ++ BSC8.unpack x) snk - read <- liftIO $ mkReadBuffer (recvData con) + readWithBuffer <- liftIO $ mkReadBuffer (recvData con) return ( src , snk - , \s -> do - liftIO $ debugM "Pontarius.Xmpp.TLS" ("out :" ++ BSC8.unpack s) - sendData con $ BL.fromChunks [s] - , liftIO . read + -- Note: sendData already sends the data to the debug output + , \s -> sendData con $ BL.fromChunks [s] + , liftIO . readWithBuffer , con ) mkReadBuffer :: IO BS.ByteString -> IO (Int -> IO BS.ByteString) -mkReadBuffer read = do +mkReadBuffer recv = do buffer <- newIORef BS.empty let read' n = do nc <- readIORef buffer - bs <- if BS.null nc then read + bs <- if BS.null nc then recv else return nc let (result, rest) = BS.splitAt n bs writeIORef buffer rest return result return read' + +-- | Connect to an XMPP server and secure the connection with TLS before +-- starting the XMPP streams +connectTls :: ResolvConf -- ^ Resolv conf to use (try defaultResolvConf as a + -- default) + -> TLSParams -- ^ TLS parameters to use when securing the connection + -> String -- ^ Host to use when connecting (will be resolved + -- using SRV records) + -> ErrorT XmppFailure IO StreamHandle +connectTls config params host = do + h <- connectSrv config host >>= \h' -> case h' of + Nothing -> throwError TcpConnectionFailure + Just h'' -> return h'' + let hand = handleToStreamHandle h + (_raw, _snk, psh, recv, ctx) <- tlsinit params $ mkBackend hand + return $ StreamHandle { streamSend = catchPush . psh + , streamReceive = recv + , streamFlush = contextFlush ctx + , streamClose = bye ctx >> streamClose hand + } diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -1,3 +1,9 @@ +{-# LANGUAGE CPP #-} + +#if WITH_TEMPLATE_HASKELL +{-# LANGUAGE TemplateHaskell #-} +#endif + {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -12,12 +18,16 @@ , IQRequestType(..) , IQResponse(..) , IQResult(..) - , IdGenerator(..) , LangTag (..) + , langTagFromText + , langTagToText + , parseLangTag , Message(..) + , message , MessageError(..) , MessageType(..) , Presence(..) + , presence , PresenceError(..) , PresenceType(..) , SaslError(..) @@ -27,7 +37,6 @@ , StanzaError(..) , StanzaErrorCondition(..) , StanzaErrorType(..) - , StanzaID(..) , XmppFailure(..) , StreamErrorCondition(..) , Version(..) @@ -37,23 +46,31 @@ , ConnectionState(..) , StreamErrorInfo(..) , StanzaHandler + , ConnectionDetails(..) , StreamConfiguration(..) - , langTag , Jid(..) +#if WITH_TEMPLATE_HASKELL + , jidQ +#endif , isBare , isFull , jidFromText , jidFromTexts + , jidToText + , jidToTexts + , toBare + , localpart + , domainpart + , resourcepart + , parseJid , StreamEnd(..) , InvalidXmppXml(..) - , Hostname(..) - , hostname - , SessionConfiguration(..) , TlsBehaviour(..) + , AuthFailure(..) ) where -import Control.Applicative ((<$>), (<|>), many) +import Control.Applicative ((<|>), many) import Control.Concurrent.STM import Control.Exception import Control.Monad.Error @@ -61,36 +78,22 @@ import qualified Data.ByteString as BS import Data.Conduit import Data.Default -import Data.Maybe (fromJust, maybeToList) import qualified Data.Set as Set -import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as Text import Data.Typeable(Typeable) import Data.XML.Types +#if WITH_TEMPLATE_HASKELL +import Language.Haskell.TH +import Language.Haskell.TH.Quote +#endif import Network import Network.DNS -import Network.Socket import Network.TLS hiding (Version) import Network.TLS.Extra import qualified Text.NamePrep as SP import qualified Text.StringPrep as SP --- | --- Wraps a string of random characters that, when using an appropriate --- @IdGenerator@, is guaranteed to be unique for the Xmpp session. - -data StanzaID = StanzaID !Text deriving (Eq, Ord) - -instance Show StanzaID where - show (StanzaID s) = Text.unpack s - -instance Read StanzaID where - readsPrec _ x = [(StanzaID $ Text.pack x, "")] - -instance IsString StanzaID where - fromString = StanzaID . Text.pack - -- | The Xmpp communication primities (Message, Presence and Info/Query) are -- called stanzas. data Stanza = IQRequestS !IQRequest @@ -104,7 +107,7 @@ -- | A "request" Info/Query (IQ) stanza is one with either "get" or "set" as -- type. It always contains an xml payload. -data IQRequest = IQRequest { iqRequestID :: !StanzaID +data IQRequest = IQRequest { iqRequestID :: !Text , iqRequestFrom :: !(Maybe Jid) , iqRequestTo :: !(Maybe Jid) , iqRequestLangTag :: !(Maybe LangTag) @@ -113,16 +116,7 @@ } deriving Show -- | The type of IQ request that is made. -data IQRequestType = Get | Set deriving (Eq, Ord) - -instance Show IQRequestType where - show Get = "get" - show Set = "set" - -instance Read IQRequestType where - readsPrec _ "get" = [(Get, "")] - readsPrec _ "set" = [(Set, "")] - readsPrec _ _ = [] +data IQRequestType = Get | Set deriving (Eq, Ord, Read, Show) -- | A "response" Info/Query (IQ) stanza is either an 'IQError', an IQ stanza -- of type "result" ('IQResult') or a Timeout. @@ -132,7 +126,7 @@ deriving Show -- | The (non-error) answer to an IQ request. -data IQResult = IQResult { iqResultID :: !StanzaID +data IQResult = IQResult { iqResultID :: !Text , iqResultFrom :: !(Maybe Jid) , iqResultTo :: !(Maybe Jid) , iqResultLangTag :: !(Maybe LangTag) @@ -140,7 +134,7 @@ } deriving Show -- | The answer to an IQ request that generated an error. -data IQError = IQError { iqErrorID :: !StanzaID +data IQError = IQError { iqErrorID :: !Text , iqErrorFrom :: !(Maybe Jid) , iqErrorTo :: !(Maybe Jid) , iqErrorLangTag :: !(Maybe LangTag) @@ -149,7 +143,7 @@ } deriving Show -- | The message stanza. Used for /push/ type communication. -data Message = Message { messageID :: !(Maybe StanzaID) +data Message = Message { messageID :: !(Maybe Text) , messageFrom :: !(Maybe Jid) , messageTo :: !(Maybe Jid) , messageLangTag :: !(Maybe LangTag) @@ -157,8 +151,23 @@ , messagePayload :: ![Element] } deriving Show + + +-- | An empty message +message :: Message +message = Message { messageID = Nothing + , messageFrom = Nothing + , messageTo = Nothing + , messageLangTag = Nothing + , messageType = Normal + , messagePayload = [] + } + +instance Default Message where + def = message + -- | An error stanza generated in response to a 'Message'. -data MessageError = MessageError { messageErrorID :: !(Maybe StanzaID) +data MessageError = MessageError { messageErrorID :: !(Maybe Text) , messageErrorFrom :: !(Maybe Jid) , messageErrorTo :: !(Maybe Jid) , messageErrorLangTag :: !(Maybe LangTag) @@ -202,33 +211,32 @@ -- -- This is the /default/ value. | Normal - deriving (Eq) - -instance Show MessageType where - show Chat = "chat" - show GroupChat = "groupchat" - show Headline = "headline" - show Normal = "normal" - -instance Read MessageType where - readsPrec _ "chat" = [(Chat, "")] - readsPrec _ "groupchat" = [(GroupChat, "")] - readsPrec _ "headline" = [(Headline, "")] - readsPrec _ "normal" = [(Normal, "")] - readsPrec _ _ = [(Normal, "")] + deriving (Eq, Read, Show) -- | The presence stanza. Used for communicating status updates. -data Presence = Presence { presenceID :: !(Maybe StanzaID) +data Presence = Presence { presenceID :: !(Maybe Text) , presenceFrom :: !(Maybe Jid) , presenceTo :: !(Maybe Jid) , presenceLangTag :: !(Maybe LangTag) - , presenceType :: !(Maybe PresenceType) + , presenceType :: !PresenceType , presencePayload :: ![Element] } deriving Show +-- | An empty presence. +presence :: Presence +presence = Presence { presenceID = Nothing + , presenceFrom = Nothing + , presenceTo = Nothing + , presenceLangTag = Nothing + , presenceType = Available + , presencePayload = [] + } +instance Default Presence where + def = presence + -- | An error stanza generated in response to a 'Presence'. -data PresenceError = PresenceError { presenceErrorID :: !(Maybe StanzaID) +data PresenceError = PresenceError { presenceErrorID :: !(Maybe Text) , presenceErrorFrom :: !(Maybe Jid) , presenceErrorTo :: !(Maybe Jid) , presenceErrorLangTag :: !(Maybe LangTag) @@ -245,28 +253,9 @@ -- subscription Probe | -- ^ Sender requests current presence; -- should only be used by servers - Default | - Unavailable deriving (Eq) - -instance Show PresenceType where - show Subscribe = "subscribe" - show Subscribed = "subscribed" - show Unsubscribe = "unsubscribe" - show Unsubscribed = "unsubscribed" - show Probe = "probe" - show Default = "" - show Unavailable = "unavailable" - -instance Read PresenceType where - readsPrec _ "" = [(Default, "")] - readsPrec _ "available" = [(Default, "")] - readsPrec _ "unavailable" = [(Unavailable, "")] - readsPrec _ "subscribe" = [(Subscribe, "")] - readsPrec _ "subscribed" = [(Subscribed, "")] - readsPrec _ "unsubscribe" = [(Unsubscribe, "")] - readsPrec _ "unsubscribed" = [(Unsubscribed, "")] - readsPrec _ "probe" = [(Probe, "")] - readsPrec _ _ = [] + Available | -- ^ Sender wants to express availability + -- (no type attribute is defined) + Unavailable deriving (Eq, Read, Show) -- | All stanzas (IQ, message, presence) can cause errors, which in the Xmpp -- stream looks like . These errors are @@ -285,22 +274,7 @@ Modify | -- ^ Change the data and retry Auth | -- ^ Provide credentials and retry Wait -- ^ Error is temporary - wait and retry - deriving (Eq) - -instance Show StanzaErrorType where - show Cancel = "cancel" - show Continue = "continue" - show Modify = "modify" - show Auth = "auth" - show Wait = "wait" - -instance Read StanzaErrorType where - readsPrec _ "auth" = [( Auth , "")] - readsPrec _ "cancel" = [( Cancel , "")] - readsPrec _ "continue" = [( Continue, "")] - readsPrec _ "modify" = [( Modify , "")] - readsPrec _ "wait" = [( Wait , "")] - readsPrec _ _ = [] + deriving (Eq, Read, Show) -- | Stanza errors are accommodated with one of the error conditions listed -- below. @@ -337,56 +311,7 @@ | UndefinedCondition -- ^ Application-specific -- condition. | UnexpectedRequest -- ^ Badly timed request. - deriving Eq - -instance Show StanzaErrorCondition where - show BadRequest = "bad-request" - show Conflict = "conflict" - show FeatureNotImplemented = "feature-not-implemented" - show Forbidden = "forbidden" - show Gone = "gone" - show InternalServerError = "internal-server-error" - show ItemNotFound = "item-not-found" - show JidMalformed = "jid-malformed" - show NotAcceptable = "not-acceptable" - show NotAllowed = "not-allowed" - show NotAuthorized = "not-authorized" - show PaymentRequired = "payment-required" - show RecipientUnavailable = "recipient-unavailable" - show Redirect = "redirect" - show RegistrationRequired = "registration-required" - show RemoteServerNotFound = "remote-server-not-found" - show RemoteServerTimeout = "remote-server-timeout" - show ResourceConstraint = "resource-constraint" - show ServiceUnavailable = "service-unavailable" - show SubscriptionRequired = "subscription-required" - show UndefinedCondition = "undefined-condition" - show UnexpectedRequest = "unexpected-request" - -instance Read StanzaErrorCondition where - readsPrec _ "bad-request" = [(BadRequest , "")] - readsPrec _ "conflict" = [(Conflict , "")] - readsPrec _ "feature-not-implemented" = [(FeatureNotImplemented, "")] - readsPrec _ "forbidden" = [(Forbidden , "")] - readsPrec _ "gone" = [(Gone , "")] - readsPrec _ "internal-server-error" = [(InternalServerError , "")] - readsPrec _ "item-not-found" = [(ItemNotFound , "")] - readsPrec _ "jid-malformed" = [(JidMalformed , "")] - readsPrec _ "not-acceptable" = [(NotAcceptable , "")] - readsPrec _ "not-allowed" = [(NotAllowed , "")] - readsPrec _ "not-authorized" = [(NotAuthorized , "")] - readsPrec _ "payment-required" = [(PaymentRequired , "")] - readsPrec _ "recipient-unavailable" = [(RecipientUnavailable , "")] - readsPrec _ "redirect" = [(Redirect , "")] - readsPrec _ "registration-required" = [(RegistrationRequired , "")] - readsPrec _ "remote-server-not-found" = [(RemoteServerNotFound , "")] - readsPrec _ "remote-server-timeout" = [(RemoteServerTimeout , "")] - readsPrec _ "resource-constraint" = [(ResourceConstraint , "")] - readsPrec _ "service-unavailable" = [(ServiceUnavailable , "")] - readsPrec _ "subscription-required" = [(SubscriptionRequired , "")] - readsPrec _ "unexpected-request" = [(UnexpectedRequest , "")] - readsPrec _ "undefined-condition" = [(UndefinedCondition , "")] - readsPrec _ _ = [(UndefinedCondition , "")] + deriving (Eq, Read, Show) -- ============================================================================= -- OTHER STUFF @@ -396,7 +321,7 @@ , saslFailureText :: Maybe ( Maybe LangTag , Text ) - } deriving Show + } deriving (Eq, Show) data SaslError = SaslAborted -- ^ Client aborted. | SaslAccountDisabled -- ^ The account has been temporarily @@ -425,33 +350,7 @@ -- temporary error condition; the -- initiating entity is recommended -- to try again later. - -instance Show SaslError where - show SaslAborted = "aborted" - show SaslAccountDisabled = "account-disabled" - show SaslCredentialsExpired = "credentials-expired" - show SaslEncryptionRequired = "encryption-required" - show SaslIncorrectEncoding = "incorrect-encoding" - show SaslInvalidAuthzid = "invalid-authzid" - show SaslInvalidMechanism = "invalid-mechanism" - show SaslMalformedRequest = "malformed-request" - show SaslMechanismTooWeak = "mechanism-too-weak" - show SaslNotAuthorized = "not-authorized" - show SaslTemporaryAuthFailure = "temporary-auth-failure" - -instance Read SaslError where - readsPrec _ "aborted" = [(SaslAborted , "")] - readsPrec _ "account-disabled" = [(SaslAccountDisabled , "")] - readsPrec _ "credentials-expired" = [(SaslCredentialsExpired , "")] - readsPrec _ "encryption-required" = [(SaslEncryptionRequired , "")] - readsPrec _ "incorrect-encoding" = [(SaslIncorrectEncoding , "")] - readsPrec _ "invalid-authzid" = [(SaslInvalidAuthzid , "")] - readsPrec _ "invalid-mechanism" = [(SaslInvalidMechanism , "")] - readsPrec _ "malformed-request" = [(SaslMalformedRequest , "")] - readsPrec _ "mechanism-too-weak" = [(SaslMechanismTooWeak , "")] - readsPrec _ "not-authorized" = [(SaslNotAuthorized , "")] - readsPrec _ "temporary-auth-failure" = [(SaslTemporaryAuthFailure , "")] - readsPrec _ _ = [] + deriving (Eq, Read, Show) -- The documentation of StreamErrorConditions is copied from -- http://xmpp.org/rfcs/rfc6120.html#streams-error-conditions @@ -492,11 +391,11 @@ -- Server Dialback, or (2) between a client and a server -- via SASL authentication and resource binding. | StreamInvalidNamespace -- ^ The stream namespace name is something other - -- than "http://etherx.jabber.org/streams" (see + -- than \"http://etherx.jabber.org/streams\" (see -- Section 11.2) or the content namespace declared -- as the default namespace is not supported (e.g., -- something other than "jabber:client" or - -- "jabber:server"). + -- \"jabber:server\"). | StreamInvalidXml -- ^ The entity has sent invalid XML over the stream to a -- server that performs validation | StreamNotAuthorized -- ^ The entity has attempted to send XML stanzas or @@ -568,63 +467,7 @@ -- initiating entity in the stream header -- specifies a version of XMPP that is not -- supported by the server. - deriving Eq - -instance Show StreamErrorCondition where - show StreamBadFormat = "bad-format" - show StreamBadNamespacePrefix = "bad-namespace-prefix" - show StreamConflict = "conflict" - show StreamConnectionTimeout = "connection-timeout" - show StreamHostGone = "host-gone" - show StreamHostUnknown = "host-unknown" - show StreamImproperAddressing = "improper-addressing" - show StreamInternalServerError = "internal-server-error" - show StreamInvalidFrom = "invalid-from" - show StreamInvalidNamespace = "invalid-namespace" - show StreamInvalidXml = "invalid-xml" - show StreamNotAuthorized = "not-authorized" - show StreamNotWellFormed = "not-well-formed" - show StreamPolicyViolation = "policy-violation" - show StreamRemoteConnectionFailed = "remote-connection-failed" - show StreamReset = "reset" - show StreamResourceConstraint = "resource-constraint" - show StreamRestrictedXml = "restricted-xml" - show StreamSeeOtherHost = "see-other-host" - show StreamSystemShutdown = "system-shutdown" - show StreamUndefinedCondition = "undefined-condition" - show StreamUnsupportedEncoding = "unsupported-encoding" - show StreamUnsupportedFeature = "unsupported-feature" - show StreamUnsupportedStanzaType = "unsupported-stanza-type" - show StreamUnsupportedVersion = "unsupported-version" - -instance Read StreamErrorCondition where - readsPrec _ "bad-format" = [(StreamBadFormat , "")] - readsPrec _ "bad-namespace-prefix" = [(StreamBadNamespacePrefix , "")] - readsPrec _ "conflict" = [(StreamConflict , "")] - readsPrec _ "connection-timeout" = [(StreamConnectionTimeout , "")] - readsPrec _ "host-gone" = [(StreamHostGone , "")] - readsPrec _ "host-unknown" = [(StreamHostUnknown , "")] - readsPrec _ "improper-addressing" = [(StreamImproperAddressing , "")] - readsPrec _ "internal-server-error" = [(StreamInternalServerError , "")] - readsPrec _ "invalid-from" = [(StreamInvalidFrom , "")] - readsPrec _ "invalid-namespace" = [(StreamInvalidNamespace , "")] - readsPrec _ "invalid-xml" = [(StreamInvalidXml , "")] - readsPrec _ "not-authorized" = [(StreamNotAuthorized , "")] - readsPrec _ "not-well-formed" = [(StreamNotWellFormed , "")] - readsPrec _ "policy-violation" = [(StreamPolicyViolation , "")] - readsPrec _ "remote-connection-failed" = - [(StreamRemoteConnectionFailed, "")] - readsPrec _ "reset" = [(StreamReset , "")] - readsPrec _ "resource-constraint" = [(StreamResourceConstraint , "")] - readsPrec _ "restricted-xml" = [(StreamRestrictedXml , "")] - readsPrec _ "see-other-host" = [(StreamSeeOtherHost , "")] - readsPrec _ "system-shutdown" = [(StreamSystemShutdown , "")] - readsPrec _ "undefined-condition" = [(StreamUndefinedCondition , "")] - readsPrec _ "unsupported-encoding" = [(StreamUnsupportedEncoding , "")] - readsPrec _ "unsupported-feature" = [(StreamUnsupportedFeature , "")] - readsPrec _ "unsupported-stanza-type" = [(StreamUnsupportedStanzaType, "")] - readsPrec _ "unsupported-version" = [(StreamUnsupportedVersion , "")] - readsPrec _ _ = [(StreamUndefinedCondition , "")] + deriving (Eq, Read, Show) -- | Encapsulates information about an XMPP stream error. data StreamErrorInfo = StreamErrorInfo @@ -661,8 +504,8 @@ | XmppNoStream -- ^ An action that required an active -- stream were performed when the -- 'StreamState' was 'Closed' - | XmppAuthFailure -- ^ Authentication with the server failed - -- unrecoverably + | XmppAuthFailure AuthFailure -- ^ Authentication with the + -- server failed (unrecoverably) | TlsStreamSecured -- ^ Connection already secured | XmppOtherFailure -- ^ Undefined condition. More -- information should be available in @@ -674,23 +517,34 @@ instance Exception XmppFailure instance Error XmppFailure where noMsg = XmppOtherFailure +-- | Signals a SASL authentication error condition. +data AuthFailure = -- | No mechanism offered by the server was matched + -- by the provided acceptable mechanisms; wraps the + -- mechanisms offered by the server + AuthNoAcceptableMechanism [Text.Text] + | AuthStreamFailure XmppFailure -- TODO: Remove + -- | A SASL failure element was encountered + | AuthSaslFailure SaslFailure + -- | The credentials provided did not conform to + -- the SASLprep Stringprep profile + | AuthIllegalCredentials + -- | Other failure; more information is available + -- in the log + | AuthOtherFailure + deriving (Eq, Show) + +instance Error AuthFailure where + noMsg = AuthOtherFailure + -- ============================================================================= -- XML TYPES -- ============================================================================= - --- | Wraps a function that MUST generate a stream of unique Ids. The --- strings MUST be appropriate for use in the stanza id attirubte. --- For a default implementation, see @idGenerator@. - -newtype IdGenerator = IdGenerator (IO Text) - - --- | XMPP version number. Displayed as ".". 2.4 is lesser than +-- | 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) + , minorVersion :: !Integer } deriving (Eq, Read, Show) -- If the major version numbers are not equal, compare them. Otherwise, compare -- the minor version numbers. @@ -699,11 +553,11 @@ | amajor /= bmajor = compare amajor bmajor | otherwise = compare aminor bminor -instance Read Version where - readsPrec _ txt = (,"") <$> maybeToList (versionFromText $ Text.pack txt) +-- instance Read Version where +-- readsPrec _ txt = (,"") <$> maybeToList (versionFromText $ Text.pack txt) -instance Show Version where - show (Version major minor) = (show major) ++ "." ++ (show minor) +-- instance Show Version where +-- show (Version major minor) = (show major) ++ "." ++ (show minor) -- Converts a "." numeric version number to a @Version@ object. versionFromText :: Text.Text -> Maybe Version @@ -726,24 +580,21 @@ data LangTag = LangTag { primaryTag :: !Text , subtags :: ![Text] } +-- Equals for language tags is not case-sensitive. instance Eq LangTag where LangTag p s == LangTag q t = Text.toLower p == Text.toLower q && map Text.toLower s == map Text.toLower t -instance Read LangTag where - readsPrec _ txt = (,"") <$> maybeToList (langTag $ Text.pack txt) - -instance Show LangTag where - show (LangTag p []) = Text.unpack p - show (LangTag p s) = Text.unpack . Text.concat $ - [p, "-", Text.intercalate "-" s] - -- | Parses, validates, and possibly constructs a "LangTag" object. -langTag :: Text.Text -> Maybe LangTag -langTag s = case AP.parseOnly langTagParser s of - Right tag -> Just tag - Left _ -> Nothing +langTagFromText :: Text.Text -> Maybe LangTag +langTagFromText s = case AP.parseOnly langTagParser s of + Right tag -> Just tag + Left _ -> Nothing +langTagToText :: LangTag -> Text.Text +langTagToText (LangTag p []) = p +langTagToText (LangTag p s) = Text.concat $ [p, "-", Text.intercalate "-" s] + -- Parses a language tag as defined by RFC 1766 and constructs a LangTag object. langTagParser :: AP.Parser LangTag langTagParser = do @@ -768,6 +619,12 @@ data StreamFeatures = StreamFeatures { streamTls :: !(Maybe Bool) , streamSaslMechanisms :: ![Text.Text] + , rosterVer :: !(Maybe Bool) -- ^ @Nothing@ for no roster + -- versioning, @Just False@ for + -- roster versioning and @Just True@ + -- when the server sends the + -- non-standard "optional" element + -- (observed with prosody). , streamOtherFeatures :: ![Element] -- TODO: All feature elements instead? } deriving Show @@ -776,12 +633,14 @@ = Closed -- ^ No stream has been established | Plain -- ^ Stream established, but not secured via TLS | Secured -- ^ Stream established and secured via TLS + | Finished -- ^ Stream is closed deriving (Show, Eq, Typeable) -- | Defines operations for sending, receiving, flushing, and closing on a -- stream. data StreamHandle = - StreamHandle { streamSend :: BS.ByteString -> IO Bool + StreamHandle { streamSend :: BS.ByteString -> IO Bool -- ^ Sends may not + -- interleave , streamReceive :: Int -> IO BS.ByteString -- This is to hold the state of the XML parser (otherwise we -- will receive EventBeginDocument events and forget about @@ -792,11 +651,11 @@ data StreamState = StreamState { -- | State of the stream - 'Closed', 'Plain', or 'Secured' - streamConnectionState :: !ConnectionState -- ^ State of connection - -- | Functions to send, receive, flush, and close on the stream + streamConnectionState :: !ConnectionState + -- | Functions to send, receive, flush, and close the stream , streamHandle :: StreamHandle -- | Event conduit source, and its associated finalizer - , streamEventSource :: ResumableSource IO Event + , streamEventSource :: Source IO Event -- | Stream features advertised by the server , streamFeatures :: !StreamFeatures -- TODO: Maybe? -- | The hostname or IP specified for the connection @@ -826,53 +685,156 @@ -- | A JID is XMPP\'s native format for addressing entities in the network. It -- is somewhat similar to an e-mail address but contains three parts instead of --- two. -data Jid = Jid { -- | The @localpart@ of a JID is an optional identifier placed - -- before the domainpart and separated from the latter by a - -- \'\@\' character. Typically a localpart uniquely identifies - -- the entity requesting and using network access provided by a - -- server (i.e., a local account), although it can also - -- represent other kinds of entities (e.g., a chat room - -- associated with a multi-user chat service). The entity - -- represented by an XMPP localpart is addressed within the - -- context of a specific domain (i.e., - -- @localpart\@domainpart@). - localpart :: !(Maybe Text) - - -- | The domainpart typically identifies the /home/ server to - -- which clients connect for XML routing and data management - -- functionality. However, it is not necessary for an XMPP - -- domainpart to identify an entity that provides core XMPP - -- server functionality (e.g., a domainpart can identify an - -- entity such as a multi-user chat service, a - -- publish-subscribe service, or a user directory). - , domainpart :: !Text +-- two: localpart, domainpart, and resourcepart. +-- +-- The @localpart@ of a JID is an optional identifier placed +-- before the domainpart and separated from the latter by a +-- \'\@\' character. Typically a localpart uniquely identifies +-- the entity requesting and using network access provided by a +-- server (i.e., a local account), although it can also +-- represent other kinds of entities (e.g., a chat room +-- associated with a multi-user chat service). The entity +-- represented by an XMPP localpart is addressed within the +-- context of a specific domain (i.e., +-- @localpart\@domainpart@). +-- +-- The domainpart typically identifies the /home/ server to +-- which clients connect for XML routing and data management +-- functionality. However, it is not necessary for an XMPP +-- domainpart to identify an entity that provides core XMPP +-- server functionality (e.g., a domainpart can identify an +-- entity such as a multi-user chat service, a +-- publish-subscribe service, or a user directory). +-- +-- The resourcepart of a JID is an optional identifier placed +-- after the domainpart and separated from the latter by the +-- \'\/\' character. A resourcepart can modify either a +-- @localpart\@domainpart@ address or a mere @domainpart@ +-- address. Typically a resourcepart uniquely identifies a +-- specific connection (e.g., a device or location) or object +-- (e.g., an occupant in a multi-user chat room) belonging to +-- the entity associated with an XMPP localpart at a domain +-- (i.e., @localpart\@domainpart/resourcepart@). - -- | The resourcepart of a JID is an optional identifier placed - -- after the domainpart and separated from the latter by the - -- \'\/\' character. A resourcepart can modify either a - -- @localpart\@domainpart@ address or a mere @domainpart@ - -- address. Typically a resourcepart uniquely identifies a - -- specific connection (e.g., a device or location) or object - -- (e.g., an occupant in a multi-user chat room) belonging to - -- the entity associated with an XMPP localpart at a domain - -- (i.e., @localpart\@domainpart/resourcepart@). - , resourcepart :: !(Maybe Text) +data Jid = Jid { localpart_ :: !(Maybe Text) + , domainpart_ :: !Text + , resourcepart_ :: !(Maybe Text) } deriving (Eq, Ord) +-- | Converts a JID to a Text. +jidToText :: Jid -> Text +jidToText (Jid nd dmn res) = + Text.pack $ (maybe "" ((++ "@") . Text.unpack) nd) ++ (Text.unpack dmn) ++ + maybe "" (('/' :) . Text.unpack) res + +-- | Converts a JID to up to three Text values: (the optional) localpart, the +-- domainpart, and (the optional) resourcepart. +jidToTexts :: Jid -> (Maybe Text, Text, Maybe Text) +jidToTexts (Jid nd dmn res) = (nd, dmn, res) + +-- Produces a Jid value in the format "parseJid \"\"". instance Show Jid where - show (Jid nd dmn res) = - maybe "" ((++ "@") . Text.unpack) nd ++ Text.unpack dmn ++ - maybe "" (('/' :) . Text.unpack) res + show j = "parseJid " ++ show (jidToText j) +-- The string must be in the format "parseJid \"\"". +-- TODO: This function should produce its error values in a uniform way. +-- TODO: Do we need to care about precedence here? instance Read Jid where - readsPrec _ x = case jidFromText (Text.pack x) of - Nothing -> [] - Just j -> [(j,"")] + readsPrec _ s = do + -- Verifies that the first word is "parseJid", parses the second word and + -- the remainder, if any, and produces these two values or fails. + let (s', r) = case lex s of + [] -> error "Expected `parseJid \"\"'" + [("parseJid", r')] -> case lex r' of + [] -> error "Expected `parseJid \"\"'" + [(s'', r'')] -> (s'', r'') + _ -> error "Expected `parseJid \"\"'" + _ -> error "Expected `parseJid \"\"'" + -- Read the JID string (removes the quotes), validate, and return. + [(parseJid (read s' :: String), r)] -- May fail with "Prelude.read: no parse" + -- or the `parseJid' error message (see below) -instance IsString Jid where - fromString = fromJust . jidFromText . Text.pack +#if WITH_TEMPLATE_HASKELL +-- | Constructs a @Jid@ value at compile time. +-- +-- Syntax: +-- @ +-- [jidQ|localpart\@domainpart/resourcepart|] +-- @ +jidQ :: QuasiQuoter +jidQ = QuasiQuoter { quoteExp = \s -> do + when (head s == ' ') . fail $ "Leading whitespaces in JID" ++ show s + let t = Text.pack s + when (Text.last t == ' ') . reportWarning $ "Trailing whitespace in JID " ++ show s + case jidFromText t of + Nothing -> fail $ "Could not parse JID " ++ s + Just j -> [| Jid $(mbTextE $ localpart_ j) + $(textE $ domainpart_ j) + $(mbTextE $ resourcepart_ j) + |] + , quotePat = fail "Jid patterns aren't implemented" + , quoteType = fail "jid QQ can't be used in type context" + , quoteDec = fail "jid QQ can't be used in declaration context" + } + where + textE t = [| Text.pack $(stringE $ Text.unpack t) |] + mbTextE Nothing = [| Nothing |] + mbTextE (Just s) = [| Just $(textE s) |] +#endif +-- Produces a LangTag value in the format "parseLangTag \"\"". +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 = fail $ "LanguageTag patterns aren't" + ++ " implemented" + , quoteType = fail $ "LanguageTag QQ can't be used" + ++ " in type context" + , quoteDec = fail $ "LanguageTag QQ can't be used" + ++ " in declaration context" + + } + where + textE t = [| Text.pack $(stringE $ Text.unpack t) |] +#endif +-- | Parses a JID string. +-- +-- Note: This function is only meant to be used to reverse @Jid@ Show +-- operations; it will produce an 'undefined' value if the JID does not +-- validate; please refer to @jidFromText@ for a safe equivalent. +parseJid :: String -> Jid +parseJid s = case jidFromText $ Text.pack s of + Just j -> j + Nothing -> error $ "Jid value (" ++ s ++ ") did not validate" + -- | Converts a Text to a JID. jidFromText :: Text -> Maybe Jid jidFromText t = do @@ -918,6 +880,22 @@ isFull :: Jid -> Bool isFull = not . isBare +-- | Returns the @Jid@ without the resourcepart (if any). +toBare :: Jid -> Jid +toBare j = j{resourcepart_ = Nothing} + +-- | Returns the localpart of the @Jid@ (if any). +localpart :: Jid -> Maybe Text +localpart = localpart_ + +-- | Returns the domainpart of the @Jid@. +domainpart :: Jid -> Text +domainpart = domainpart_ + +-- | Returns the resourcepart of the @Jid@ (if any). +resourcepart :: Jid -> Maybe Text +resourcepart = resourcepart_ + -- Parses an JID string and returns its three parts. It performs no validation -- or transformations. jidParts :: AP.Parser (Maybe Text, Text, Maybe Text) @@ -1012,6 +990,11 @@ instance Exception InvalidXmppXml +data ConnectionDetails = UseRealm -- ^ Use realm to resolv host + | UseSrv HostName -- ^ Use this hostname for a SRV lookup + | UseHost HostName PortID -- ^ Use specified host + | UseConnection (ErrorT XmppFailure IO StreamHandle) + -- | Configuration settings related to the stream. data StreamConfiguration = StreamConfiguration { -- | Default language when no language tag is set @@ -1026,7 +1009,7 @@ -- of the realm, as well as specify the use of a -- non-standard port when connecting by IP or -- connecting to a domain without SRV records. - , socketDetails :: Maybe (Socket, SockAddr) + , connectionDetails :: ConnectionDetails -- | DNS resolver configuration , resolvConf :: ResolvConf -- | Whether or not to perform the legacy @@ -1039,82 +1022,22 @@ , tlsParams :: TLSParams } - instance Default StreamConfiguration where def = StreamConfiguration { preferredLang = Nothing , toJid = Nothing - , socketDetails = Nothing + , connectionDetails = UseRealm , resolvConf = defaultResolvConf , establishSession = True , tlsBehaviour = PreferTls - , tlsParams = defaultParamsClient { pConnectVersion = TLS12 - , pAllowedVersions = [TLS12] + , tlsParams = defaultParamsClient { pConnectVersion = TLS10 + , pAllowedVersions = [TLS10, TLS11, TLS12] , pCiphers = ciphersuite_strong } } -data Hostname = Hostname Text deriving (Eq, Show) - -instance Read Hostname where - readsPrec _ x = case hostname (Text.pack x) of - Nothing -> [] - Just h -> [(h,"")] - -instance IsString Hostname where - fromString = fromJust . hostname . Text.pack - --- | Validates the hostname string in accordance with RFC 1123. -hostname :: Text -> Maybe Hostname -hostname t = do - eitherToMaybeHostname $ AP.parseOnly hostnameP t - where - eitherToMaybeHostname = either (const Nothing) (Just . Hostname) - --- Validation of RFC 1123 hostnames. -hostnameP :: AP.Parser Text -hostnameP = do - -- Hostnames may not begin with a hyphen. - h <- AP.satisfy $ AP.inClass $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] - t <- AP.takeWhile $ AP.inClass $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ ['-'] - let label = Text.concat [Text.pack [h], t] - if Text.length label > 63 - then fail "Label too long." - else do - AP.endOfInput - return label - <|> do - _ <- AP.satisfy (== '.') - r <- hostnameP - if (Text.length label) + 1 + (Text.length r) > 255 - then fail "Hostname too long." - else return $ Text.concat [label, Text.pack ".", r] - -type StanzaHandler = TChan Stanza -- ^ outgoing stanza +type StanzaHandler = TMVar (BS.ByteString -> IO Bool) -- ^ outgoing stanza -> Stanza -- ^ stanza to handle -> IO Bool -- ^ True when processing should continue - --- | Configuration for the @Session@ object. -data SessionConfiguration = SessionConfiguration - { -- | Configuration for the @Stream@ object. - sessionStreamConfiguration :: StreamConfiguration - -- | Handler to be run when the session ends (for whatever reason). - , sessionClosedHandler :: XmppFailure -> IO () - -- | Function to generate the stream of stanza identifiers. - , sessionStanzaIDs :: IO (IO StanzaID) - , extraStanzaHandlers :: [StanzaHandler] - } - -instance Default SessionConfiguration where - def = SessionConfiguration { sessionStreamConfiguration = def - , sessionClosedHandler = \_ -> return () - , sessionStanzaIDs = do - idRef <- newTVarIO 1 - return . atomically $ do - curId <- readTVar idRef - writeTVar idRef (curId + 1 :: Integer) - return . StanzaID . Text.pack . show $ curId - , extraStanzaHandlers = [] - } -- | How the client should behave in regards to TLS. data TlsBehaviour = RequireTls -- ^ Require the use of TLS; disconnect if it's diff --git a/source/Network/Xmpp/Utilities.hs b/source/Network/Xmpp/Utilities.hs --- a/source/Network/Xmpp/Utilities.hs +++ b/source/Network/Xmpp/Utilities.hs @@ -1,104 +1,44 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_HADDOCK hide #-} -module Network.Xmpp.Utilities (presTo, message, answerMessage, openElementToEvents, renderOpenElement, renderElement) where -import Network.Xmpp.Types - -import Control.Monad.STM -import Control.Concurrent.STM.TVar -import Prelude - -import Data.XML.Types +module Network.Xmpp.Utilities + ( openElementToEvents + , renderOpenElement + , renderElement + , checkHostName + , withTMVar + ) + where +import Control.Applicative ((<|>)) +import Control.Concurrent.STM +import Control.Exception +import Control.Monad.State.Strict import qualified Data.Attoparsec.Text as AP -import qualified Data.Text as Text - import qualified Data.ByteString as BS +import Data.Conduit as C +import Data.Conduit.List as CL import qualified Data.Text as Text +import Data.Text(Text) import qualified Data.Text.Encoding as Text -import System.IO.Unsafe(unsafePerformIO) -import Data.Conduit.List as CL --- import Data.Typeable -import Control.Applicative ((<$>)) -import Control.Exception -import Control.Monad.Trans.Class - -import Data.Conduit as C import Data.XML.Types - +import Prelude +import System.IO.Unsafe(unsafePerformIO) import qualified Text.XML.Stream.Render as TXSR import Text.XML.Unresolved as TXU - --- TODO: Not used, and should probably be removed. --- | Creates a new @IdGenerator@. Internally, it will maintain an infinite list --- of IDs ('[\'a\', \'b\', \'c\'...]'). The argument is a prefix to prepend the --- IDs with. Calling the function will extract an ID and update the generator's --- internal state so that the same ID will not be generated again. -idGenerator :: Text.Text -> IO IdGenerator -idGenerator prefix = atomically $ do - tvar <- newTVar $ ids prefix - return $ IdGenerator $ next tvar - where - -- Transactionally extract the next ID from the infinite list of IDs. - next :: TVar [Text.Text] -> IO Text.Text - next tvar = atomically $ do - list <- readTVar tvar - case list of - [] -> error "empty list in Utilities.hs" - (x:xs) -> do - writeTVar tvar xs - return x - - -- Generates an infinite and predictable list of IDs, all beginning with the - -- provided prefix. Adds the prefix to all combinations of IDs (ids'). - ids :: Text.Text -> [Text.Text] - ids p = Prelude.map (\ id -> Text.append p id) ids' - where - -- Generate all combinations of IDs, with increasing length. - ids' :: [Text.Text] - ids' = Prelude.map Text.pack $ Prelude.concatMap ids'' [1..] - -- Generates all combinations of IDs with the given length. - ids'' :: Integer -> [String] - ids'' 0 = [""] - ids'' l = [x:xs | x <- repertoire, xs <- ids'' (l - 1)] - -- Characters allowed in IDs. - repertoire :: String - repertoire = ['a'..'z'] - --- Constructs a "Version" based on the major and minor version numbers. -versionFromNumbers :: Integer -> Integer -> Version -versionFromNumbers major minor = Version major minor - --- | Add a recipient to a presence notification. -presTo :: Presence -> Jid -> Presence -presTo pres to = pres{presenceTo = Just to} - --- | An empty message. -message :: Message -message = Message { messageID = Nothing - , messageFrom = Nothing - , messageTo = Nothing - , messageLangTag = Nothing - , messageType = Normal - , messagePayload = [] - } - --- | Produce an answer message with the given payload, switching the "from" and --- "to" attributes in the original message. Produces a 'Nothing' value of the --- provided message message has no from attribute. -answerMessage :: Message -> [Element] -> Maybe Message -answerMessage Message{messageFrom = Just frm, ..} payload = - Just Message{ messageFrom = messageTo - , messageID = Nothing - , messageTo = Just frm - , messagePayload = payload - , .. - } -answerMessage _ _ = Nothing +-- | Apply f with the content of tv as state, restoring the original value when an +-- exception occurs +withTMVar :: TMVar a -> (a -> IO (c, a)) -> IO c +withTMVar tv f = bracketOnError (atomically $ takeTMVar tv) + (atomically . putTMVar tv) + (\s -> do + (x, s') <- f s + atomically $ putTMVar tv s' + return x + ) openElementToEvents :: Element -> [Event] openElementToEvents (Element name as ns) = EventBeginElement name as : goN ns [] @@ -124,4 +64,31 @@ $ CL.sourceList (elementToEvents e) $$ TXSR.renderText def =$ CL.consume where elementToEvents :: Element -> [Event] - elementToEvents e@(Element name _ _) = openElementToEvents e ++ [EventEndElement name] + elementToEvents el@(Element name _ _) = openElementToEvents el + ++ [EventEndElement name] + +-- | Validates the hostname string in accordance with RFC 1123. +checkHostName :: Text -> Maybe Text +checkHostName t = + eitherToMaybeHostName $ AP.parseOnly hostnameP t + where + eitherToMaybeHostName = either (const Nothing) Just + +-- Validation of RFC 1123 hostnames. +hostnameP :: AP.Parser Text +hostnameP = do + -- Hostnames may not begin with a hyphen. + h <- AP.satisfy $ AP.inClass $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] + t <- AP.takeWhile $ AP.inClass $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ ['-'] + let label = Text.concat [Text.pack [h], t] + if Text.length label > 63 + then fail "Label too long." + else do + AP.endOfInput + return label + <|> do + _ <- AP.satisfy (== '.') + r <- hostnameP + if Text.length label + 1 + Text.length r > 255 + then fail "Hostname too long." + else return $ Text.concat [label, Text.pack ".", r]