diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,23 +1,7 @@ -# 0.3 to 0.4 - -## Major changes -* Added Lenses -* Added Plugins - -## newly exported functions -* simpleAuth -* jid (QuasiQuoter) -* presenceUnsubscribed -* associatedErrorType -* mkStanzaError - -## major bugs fixed -* Didn't check jid of IQResults - -## incompatible changes -### IQ -* sendIQ returns an STM action rather than a TMVar -* sendIQ' takes a timeout parameter -* removed IQResponseTimeout from IQResponse data type -* renamed listenIQChan to listenIQ and changed return type from TChan to STM -* renamed dropIQChan to unlistenIQ +# 0.4.5 to 0.5.0 +* Support for the session element is now determined from stream features, the + establishSession option was removed +* The parser can now handle nonzas. Nonzas can be handled with a plugin +* An initial roster can now be set with the initialRoster session configuration + option +* The JID parser can now handle "/" and "@" characters in the resource part diff --git a/examples/echoclient/Main.hs b/examples/echoclient/Main.hs --- a/examples/echoclient/Main.hs +++ b/examples/echoclient/Main.hs @@ -12,17 +12,24 @@ import Control.Monad import Data.Default +import Lens.Family2 import Network.Xmpp +import Network.Xmpp.Internal (TlsBehaviour(..)) import System.Log.Logger + main :: IO () main = do updateGlobalLogger "Pontarius.Xmpp" $ setLevel DEBUG result <- session - "example.com" - (Just (\_ -> ( [scramSha1 "username" Nothing "password"]) + "test.pontarius.org" + (Just (\_ -> ( [scramSha1 "testuser1" Nothing "pwd1"]) , Nothing)) - def + $ def & streamConfigurationL . tlsBehaviourL .~ PreferPlain + & streamConfigurationL . connectionDetailsL .~ + UseHost "localhost" 5222 + & onConnectionClosedL .~ reconnectSession + sess <- case result of Right s -> return s Left e -> error $ "XmppFailure: " ++ (show e) @@ -32,3 +39,5 @@ case answerMessage msg (messagePayload msg) of Just answer -> sendMessage answer sess >> return () Nothing -> putStrLn "Received message with no sender." + where + reconnectSession sess failure = reconnect' sess >> return () diff --git a/examples/echoclient/echoclient.cabal b/examples/echoclient/echoclient.cabal --- a/examples/echoclient/echoclient.cabal +++ b/examples/echoclient/echoclient.cabal @@ -13,5 +13,12 @@ Synopsis: Echo client test program for Pontarius XMPP Executable echoclient - Build-Depends: base, data-default, hslogger, mtl, pontarius-xmpp, text, tls + Build-Depends: base + , data-default + , hslogger + , lens-family + , mtl + , pontarius-xmpp + , text + , tls Main-Is: Main.hs diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -1,12 +1,12 @@ Name: pontarius-xmpp -Version: 0.4.5 +Version: 0.5.0 Cabal-Version: >= 1.9.2 Build-Type: Custom License: BSD3 License-File: LICENSE.md Copyright: Dmitry Astapov, Pierre Kovalev, Mahdi Abdinejadi, Jon Kristensen, IETF Trust, Philipp Balzarek -Author: Jon Kristensen, Philipp Balzarek +Author: Philipp Balzarek Maintainer: info@jonkri.com Stability: alpha Homepage: https://github.com/pontarius/pontarius-xmpp/ @@ -48,7 +48,7 @@ , cryptohash-cryptoapi >=0.1 , data-default >=0.2 , dns >=0.3.0 - , exceptions >= 0.6 + , exceptions >=0.6 , hslogger >=1.1.0 , iproute >=1.2.4 , lens-family 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 @@ -53,7 +53,12 @@ import Control.Monad.State.Strict -runHandlers :: [Stanza -> [Annotation] -> IO [Annotated Stanza]] -> Stanza -> IO () +runHandlers :: [ XmppElement + -> [Annotation] + -> IO [Annotated XmppElement] + ] + -> XmppElement + -> IO () runHandlers [] sta = do errorM "Pontarius.Xmpp" $ "No stanza handlers set, discarding stanza" ++ show sta @@ -66,17 +71,20 @@ toChan :: TChan (Annotated Stanza) -> StanzaHandler toChan stanzaC _ sta as = do - atomically $ writeTChan stanzaC (sta, as) + case sta of + XmppStanza s -> atomically $ writeTChan stanzaC (s, as) + _ -> return () return [(sta, [])] handleIQ :: TVar IQHandlers -> StanzaHandler -handleIQ iqHands out sta as = do +handleIQ _ _ s@XmppNonza{} _ = return [(s, [])] +handleIQ iqHands out s@(XmppStanza sta) as = do case sta of IQRequestS i -> handleIQRequest iqHands i >> return [] IQResultS i -> handleIQResponse iqHands (Right i) >> return [] IQErrorS i -> handleIQResponse iqHands (Left i) >> return [] - _ -> return [(sta, [])] + _ -> return [(s, [])] where -- If the IQ request has a namespace, send it through the appropriate channel. handleIQRequest :: TVar IQHandlers -> IQRequest -> IO () @@ -106,7 +114,7 @@ atomically $ putTMVar sentRef True return Nothing False -> do - didSend <- out response + didSend <- out $ XmppStanza response case didSend of Right () -> do atomically $ putTMVar sentRef True @@ -116,7 +124,7 @@ return $ Just er writeTChan ch $ IQRequestTicket answerT iq as return Nothing - maybe (return ()) (void . out) res + maybe (return ()) (void . out . XmppStanza) res serviceUnavailable (IQRequest iqid from _to lang _tp bd _attrs) = IQErrorS $ IQError iqid Nothing from lang err (Just bd) [] err = StanzaError Cancel ServiceUnavailable Nothing Nothing @@ -166,24 +174,33 @@ stanzaChan <- lift newTChanIO iqHands <- lift $ newTVarIO (Map.empty, Map.empty) eh <- lift $ newEmptyTMVarIO - ros <- liftIO . newTVarIO $ Roster Nothing Map.empty + ros <- case enableRoster config of + False -> return $ Roster Nothing Map.empty + True -> do + mbRos <- liftIO $ initialRoster config + return $ case mbRos of + Nothing -> Roster Nothing Map.empty + Just r -> r + rosRef <- liftIO $ newTVarIO ros peers <- liftIO . newTVarIO $ Peers Map.empty rew <- lift $ newTVarIO 60 - let out = writeStanza writeSem + let out = writeXmppElem writeSem boundJid <- liftIO $ withStream' (gets streamJid) stream let rosterH = if (enableRoster config) - then [handleRoster boundJid ros out] + then [handleRoster boundJid rosRef + (fromMaybe (\_ -> return ()) $ onRosterPush config) + (out)] else [] let presenceH = if (enablePresenceTracking config) then [handlePresence (onPresenceChange config) peers out] else [] - (sStanza, ps) <- initPlugins out $ plugins config + (sXmppElement, ps) <- initPlugins out $ plugins config let stanzaHandler = runHandlers $ List.concat [ inHandler <$> ps - , [ toChan stanzaChan sStanza] + , [ toChan stanzaChan sXmppElement] , presenceH , rosterH - , [ handleIQ iqHands sStanza] + , [ handleIQ iqHands sXmppElement] ] (kill, sState, reader) <- ErrorT $ startThreadsWith writeSem stanzaHandler eh stream @@ -198,15 +215,15 @@ , eventHandlers = eh , stopThreads = kill , conf = config - , rosterRef = ros + , rosterRef = rosRef , presenceRef = peers - , sendStanza' = sStanza + , sendStanza' = sXmppElement . XmppStanza , sRealm = realm , sSaslCredentials = mbSasl , reconnectWait = rew } - liftIO . atomically $ putTMVar eh $ EventHandlers { connectionClosedHandler = - onConnectionClosed config sess } + liftIO . atomically $ putTMVar eh $ + EventHandlers { connectionClosedHandler = onConnectionClosed config sess } -- Pass the new session to the plugins so they can "tie the knot" liftIO . forM_ ps $ \p -> onSessionUp p sess return sess @@ -308,7 +325,6 @@ atomically $ writeTVar rw 60 when (enableRoster config) $ initRoster sess return Nothing - -- | Reconnect with the stored settings. -- 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 @@ -17,6 +17,15 @@ (atomically . putTMVar sem) ($ bs) +writeXmppElem :: WriteSemaphore -> XmppElement -> IO (Either XmppFailure ()) +writeXmppElem sem a = do + let el = case a of + XmppStanza s -> pickleElem xpStanza s + XmppNonza n -> n + outData = renderElement $ nsHack el + debugOut outData + semWrite sem outData + writeStanza :: WriteSemaphore -> Stanza -> IO (Either XmppFailure ()) writeStanza sem a = do let outData = renderElement $ nsHack (pickleElem xpStanza a) 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 @@ -29,7 +29,7 @@ -- 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. + -- fetch an updated state. s <- Ex.catch (atomically $ do _ <- takeTMVar (writeSemaphore 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 @@ -19,12 +19,11 @@ -- Worker to read stanzas from the stream and concurrently distribute them to -- all listener threads. -readWorker :: (Stanza -> IO ()) +readWorker :: (XmppElement -> IO ()) -> (XmppFailure -> IO ()) -> TMVar Stream -> IO a -readWorker onStanza onCClosed stateRef = forever . Ex.mask_ $ do - +readWorker onElement onCClosed stateRef = forever . Ex.mask_ $ do s' <- Ex.catches ( do atomically $ do s@(Stream con) <- readTMVar stateRef @@ -38,14 +37,14 @@ return Nothing ] - case s' of + case s' of -- Maybe Stream Nothing -> return () - Just s -> do + Just s -> do -- Stream res <- Ex.catches (do -- we don't know whether pull will -- necessarily be interruptible allowInterrupt - res <- pullStanza s + res <- pullXmppElement s case res of Left e -> do errorM "Pontarius.Xmpp" $ "Read error: " @@ -62,7 +61,7 @@ case res of Nothing -> return () -- Caught an exception, nothing to -- do. TODO: Can this happen? - Just sta -> void $ onStanza sta + Just sta -> void $ onElement sta where -- Defining an Control.Exception.allowInterrupt equivalent for GHC 7 -- compatibility. @@ -83,7 +82,7 @@ -- stances, respectively, and an Action to stop the Threads and close the -- connection. startThreadsWith :: TMVar (BS.ByteString -> IO (Either XmppFailure ())) - -> (Stanza -> IO ()) + -> (XmppElement -> IO ()) -> TMVar EventHandlers -> Stream -> Maybe Int @@ -95,16 +94,22 @@ -- writeSem <- newTMVarIO read' conS <- newTMVarIO con cp <- forkIO $ connPersist keepAlive writeSem - rdw <- forkIO $ readWorker stanzaHandler (noCon eh) conS + let onConClosed failure = do + stopWrites + noCon eh failure + rdw <- forkIO $ readWorker stanzaHandler onConClosed conS return $ Right ( killConnection [rdw, cp] , conS , rdw ) where + stopWrites = atomically $ do + _ <- takeTMVar writeSem + putTMVar writeSem $ \_ -> return $ Left XmppNoStream killConnection threads = liftIO $ do - _ <- atomically $ do - _ <- takeTMVar writeSem - putTMVar writeSem $ \_ -> return $ Left XmppNoStream + debugM "Pontarius.Xmpp" "killing connection" + stopWrites + debugM "Pontarius.Xmpp" "killing threads" _ <- forM threads killThread return () -- Call the connection closed handlers. @@ -115,7 +120,7 @@ return () -- Acquires the write lock, pushes a space, and releases the lock. --- | Sends a blank space every 30 seconds to keep the connection alive. +-- | Sends a blank space every seconds to keep the connection alive. connPersist :: Maybe Int -> TMVar (BS.ByteString -> IO a) -> IO () connPersist (Just delay) sem = forever $ do pushBS <- atomically $ takeTMVar sem 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 @@ -21,11 +21,12 @@ import Network.Xmpp.Sasl.Types import Network.Xmpp.Types -type StanzaHandler = (Stanza -> IO (Either XmppFailure ()) ) -- ^ outgoing stanza - -> Stanza -- ^ stanza to handle +type StanzaHandler = (XmppElement -> IO (Either XmppFailure ()) ) -- ^ outgoing + -- stanza + -> XmppElement -- ^ stanza to handle -> [Annotation] -- ^ annotations added by previous handlers - -> IO [(Stanza, [Annotation])] -- ^ modified stanzas and - -- /additional/ annotations + -> IO [(XmppElement, [Annotation])] -- ^ modified stanzas and + -- /additional/ annotations type Resource = Text @@ -56,17 +57,17 @@ data Plugin' = Plugin' { -- | Resulting stanzas and additional Annotations - inHandler :: Stanza + inHandler :: XmppElement -> [Annotation] - -> IO [(Stanza, [Annotation])] - , outHandler :: Stanza -> IO (Either XmppFailure ()) + -> IO [(XmppElement, [Annotation])] + , outHandler :: XmppElement -> IO (Either XmppFailure ()) -- | In order to allow plugins to tie the knot (Plugin / Session) we pass -- the plugin the completed Session once it exists , onSessionUp :: Session -> IO () } -type Plugin = (Stanza -> IO (Either XmppFailure ())) -- ^ pass stanza to next - -- plugin +type Plugin = (XmppElement -> IO (Either XmppFailure ())) -- ^ pass stanza to + -- next plugin -> ErrorT XmppFailure IO Plugin' -- | Configuration for the @Session@ object. @@ -85,6 +86,11 @@ -- | Enable roster handling according to rfc 6121. See 'getRoster' to -- acquire the current roster , enableRoster :: Bool + -- | Initial Roster to user when versioned rosters are supported + , initialRoster :: IO (Maybe Roster) + -- | Callback called on a roster Push. The callback is called after the + -- roster is updated + , onRosterPush :: Maybe (QueryItem -> IO ()) -- | Track incomming presence stancas. , enablePresenceTracking :: Bool -- | Callback that is invoked when the presence status of a peer changes, @@ -112,6 +118,8 @@ return . Text.pack . show $ curId , plugins = [] , enableRoster = True + , initialRoster = return Nothing + , onRosterPush = Nothing , enablePresenceTracking = True , onPresenceChange = Nothing , keepAlive = Just 30 diff --git a/source/Network/Xmpp/IM/PresenceTracker.hs b/source/Network/Xmpp/IM/PresenceTracker.hs --- a/source/Network/Xmpp/IM/PresenceTracker.hs +++ b/source/Network/Xmpp/IM/PresenceTracker.hs @@ -64,7 +64,7 @@ -> StanzaHandler handlePresence onChange peers _ st _ = do let mbPr = do - pr <- st ^? _Presence -- Only act on presence stanzas + pr <- st ^? _Stanza . _Presence -- Only act on presence stanzas fr <- pr ^? from . _Just . _isFull -- Only act on full JIDs return (pr, fr) Foldable.forM_ mbPr $ \(pr, fr) -> diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs --- a/source/Network/Xmpp/IM/Roster.hs +++ b/source/Network/Xmpp/IM/Roster.hs @@ -98,11 +98,14 @@ "Server did not return a roster: " Just roster -> atomically $ writeTVar (rosterRef session) roster -handleRoster :: Maybe Jid -> TVar Roster -> StanzaHandler -handleRoster mbBoundJid ref out sta _ = do +handleRoster :: Maybe Jid + -> TVar Roster + -> (QueryItem -> IO ()) + -> StanzaHandler +handleRoster mbBoundJid ref onUpdate out sta _ = do case sta of - IQRequestS (iqr@IQRequest{iqRequestPayload = - iqb@Element{elementName = en}}) + XmppStanza (IQRequestS (iqr@IQRequest{iqRequestPayload = + iqb@Element{elementName = en}})) | nameNamespace en == Just "jabber:iq:roster" -> do let doHandle = case (iqRequestFrom iqr, mbBoundJid) of -- We don't need to check our own JID when the IQ @@ -120,11 +123,12 @@ , queryItems = [update] } -> do handleUpdate v update - _ <- out $ result iqr + onUpdate update + _ <- out . XmppStanza $ result iqr return [] _ -> do errorM "Pontarius.Xmpp" "Invalid roster query" - _ <- out $ badRequest iqr + _ <- out . XmppStanza $ badRequest iqr return [] -- Don't handle roster pushes from unauthorized sources else return [(sta, [])] diff --git a/source/Network/Xmpp/Lens.hs b/source/Network/Xmpp/Lens.hs --- a/source/Network/Xmpp/Lens.hs +++ b/source/Network/Xmpp/Lens.hs @@ -51,7 +51,9 @@ , _isFull , _isBare - -- ** Stanzas + -- ** Stanzas and Nonzas + , _Stanza + , _Nonza , _IQRequest , _IQResult , _IQError @@ -83,7 +85,6 @@ , toJidL , connectionDetailsL , resolvConfL - , establishSessionL , tlsBehaviourL , tlsParamsL -- **** TLS parameters @@ -213,6 +214,17 @@ _isBare :: Prism Jid Jid _isBare = prism' toBare (\j -> if isBare j then Just j else Nothing) +_Stanza :: Prism XmppElement Stanza +_Stanza = prism' XmppStanza (\v -> case v of + XmppStanza s -> Just s + _ -> Nothing) + +_Nonza :: Prism XmppElement Element +_Nonza = prism' XmppNonza (\v -> case v of + XmppNonza n -> Just n + _ -> Nothing) + + class IsStanza s where -- | From-attribute of the stanza from :: Lens s (Maybe Jid) @@ -488,10 +500,6 @@ resolvConfL :: Lens StreamConfiguration ResolvConf resolvConfL inj sc@StreamConfiguration{resolvConf = x} = (\x' -> sc{resolvConf = x'}) <$> inj x - -establishSessionL :: Lens StreamConfiguration Bool -establishSessionL inj sc@StreamConfiguration{establishSession = x} - = (\x' -> sc{establishSession = x'}) <$> inj x tlsBehaviourL :: Lens StreamConfiguration TlsBehaviour tlsBehaviourL inj sc@StreamConfiguration{tlsBehaviour = x} 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 @@ -22,6 +22,17 @@ xpNonemptyText :: PU Text NonemptyText xpNonemptyText = ("xpNonemptyText" , "") xpWrap Nonempty fromNonempty xpText +xpStreamElement :: PU [Node] (Either StreamErrorInfo XmppElement) +xpStreamElement = xpEither xpStreamError $ + xpWrap (\v -> case v of + Left l -> XmppStanza l + Right r -> XmppNonza r + ) + ( \v -> case v of + XmppStanza l -> Left l + XmppNonza r -> Right r) + $ xpEither xpStanza xpElemVerbatim + xpStreamStanza :: PU [Node] (Either StreamErrorInfo Stanza) xpStreamStanza = xpEither xpStreamError xpStanza @@ -350,21 +361,22 @@ -- Pickler/Unpickler for the stream features - TLS, SASL, and the rest. xpStreamFeatures :: PU [Node] StreamFeatures xpStreamFeatures = ("xpStreamFeatures","") xpWrap - (\(tls, sasl, ver, preAppr, rest) - -> StreamFeatures tls (mbl sasl) ver preAppr rest) - (\(StreamFeatures tls sasl ver preAppr rest) - -> (tls, lmb sasl, ver, preAppr, rest)) + (\(tls, sasl, ver, preAppr, session, rest) + -> StreamFeatures tls (mbl sasl) ver preAppr session rest ) + (\(StreamFeatures tls sasl ver preAppr session rest) + -> (tls, lmb sasl, ver, preAppr, session, rest)) (xpElemNodes (Name "features" (Just "http://etherx.jabber.org/streams") (Just "stream") ) - (xp5Tuple + (xp6Tuple (xpOption pickleTlsFeature) (xpOption pickleSaslFeature) (xpOption pickleRosterVer) picklePreApproval + (xpOption pickleSessionFeature) (xpAll xpElemVerbatim) ) ) @@ -381,6 +393,10 @@ pickleRosterVer = xpElemNodes "{urn:xmpp:features:rosterver}ver" $ xpElemExists "{urn:xmpp:features:rosterver}optional" picklePreApproval = xpElemExists "{urn:xmpp:features:pre-approval}sub" + pickleSessionFeature :: PU [Node] Bool + pickleSessionFeature = ("pickleSessionFeature", "") + xpElemNodes "{urn:ietf:params:xml:ns:xmpp-session}session" + (xpElemExists "{urn:ietf:params:xml:ns:xmpp-session}optional") xpJid :: PU Text Jid 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 @@ -77,12 +77,19 @@ _jid <- ErrorT $ xmppBind resource con ErrorT $ flip withStream' con $ do s <- get - case establishSession $ streamConfiguration s of + + case sendStreamElement s of False -> return $ Right Nothing True -> do - _ <-liftIO $ startSession con + _ <- liftIO $ startSession con return $ Right Nothing f -> return f + where + sendStreamElement s = + and [ -- Check that the stream feature is set and not optional + streamFeaturesSession (streamFeatures s) == Just False + ] + -- Produces a `bind' element, optionally wrapping a resource. bindBody :: Maybe Text -> Element 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 @@ -239,6 +239,7 @@ startStream +-- Creates a conduit from a StreamHandle sourceStreamHandle :: (MonadIO m, MonadError XmppFailure m) => StreamHandle -> ConduitM i ByteString m () sourceStreamHandle s = loopRead $ streamReceive s @@ -373,13 +374,20 @@ ("Out: " ++ (Text.unpack . Text.decodeUtf8 $ outData)) wrapIOException :: MonadIO m => - IO a -> m (Either XmppFailure a) -wrapIOException action = do + String + -> IO a + -> m (Either XmppFailure a) +wrapIOException tag action = do r <- liftIO $ tryIOError action case r of Right b -> return $ Right b Left e -> do - liftIO $ warningM "Pontarius.Xmpp" $ "wrapIOException: Exception wrapped: " ++ (show e) + liftIO $ warningM "Pontarius.Xmpp" $ concat + [ "wrapIOException (" + , tag + , ") : Exception wrapped: " + , show e + ] return $ Left $ XmppIOException e pushElement :: Element -> StateT StreamState IO (Either XmppFailure ()) @@ -388,11 +396,10 @@ let outData = renderElement $ nsHack x debugOut outData lift $ 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 +-- 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" = @@ -470,6 +477,15 @@ Right (Left e) -> return $ Left $ StreamErrorFailure e Right (Right r) -> return $ Right r +-- | Pulls a stanza, nonza or stream error from the stream. +pullXmppElement :: Stream -> IO (Either XmppFailure XmppElement) +pullXmppElement = withStream' $ do + res <- pullUnpickle xpStreamElement + case res of + Left e -> return $ Left e + Right (Left e) -> return $ Left $ StreamErrorFailure e + Right (Right r) -> return $ Right r + -- Performs the given IO operation, catches any errors and re-throws everything -- except 'ResourceVanished' and IllegalOperation, which it will return. catchPush :: IO () -> IO (Either XmppFailure ()) @@ -513,9 +529,11 @@ handleToStreamHandle :: Handle -> StreamHandle handleToStreamHandle h = StreamHandle { streamSend = \d -> - wrapIOException $ BS.hPut h d + wrapIOException "streamSend" + $ BS.hPut h d , streamReceive = \n -> - wrapIOException $ BS.hGetSome h n + wrapIOException "streamReceive" + $ BS.hGetSome h n , streamFlush = hFlush h , streamClose = hClose h } @@ -762,7 +780,7 @@ killStream :: Stream -> IO (Either XmppFailure ()) killStream = withStream $ do cc <- gets (streamClose . streamHandle) - err <- wrapIOException cc + err <- wrapIOException "killStream" cc -- (ExL.try cc :: IO (Either ExL.SomeException ())) put xmppNoStream{ streamConnectionState = Finished } return err @@ -813,7 +831,10 @@ elements -- This might be an XML error if the end element tag is not -- "". TODO: We might want to check this at a later time - Just (EventEndElement _) -> throwError StreamEndFailure + Just EventEndElement{} -> throwError StreamEndFailure + -- This happens when the connection to the server is closed without + -- the stream being properly terminated + Just EventEndDocument -> throwError StreamEndFailure Just (EventContent (ContentText ct)) | Text.all isSpace ct -> elements Nothing -> return () 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 @@ -42,6 +42,7 @@ , SaslFailure(..) , StreamFeatures(..) , Stanza(..) + , XmppElement(..) , messageS , messageErrorS , presenceS @@ -138,7 +139,11 @@ text :: NonemptyText -> Text text (Nonempty txt) = txt --- | The Xmpp communication primities (Message, Presence and Info/Query) are +data XmppElement = XmppStanza !Stanza + | XmppNonza !Element + deriving (Eq, Show) + +-- | The Xmpp communication primitives (Message, Presence and Info/Query) are -- called stanzas. data Stanza = IQRequestS !IQRequest | IQResultS !IQResult @@ -727,6 +732,9 @@ -- versioning and @Just True@ when the server sends the non-standard -- "optional" element (observed with prosody). , streamFeaturesPreApproval :: !Bool -- ^ Does the server support pre-approval + , streamFeaturesSession :: !(Maybe Bool) + -- ^ Does this server allow the stream elelemt? (See + -- https://tools.ietf.org/html/draft-cridland-xmpp-session-01) , streamFeaturesOther :: ![Element] -- TODO: All feature elements instead? } deriving (Eq, Show) @@ -737,6 +745,7 @@ , streamFeaturesMechanisms = [] , streamFeaturesRosterVer = Nothing , streamFeaturesPreApproval = False + , streamFeaturesSession = Nothing , streamFeaturesOther = [] } mappend sf1 sf2 = @@ -747,6 +756,7 @@ , streamFeaturesPreApproval = streamFeaturesPreApproval sf1 || streamFeaturesPreApproval sf2 + , streamFeaturesSession = mplusOn streamFeaturesSession , streamFeaturesOther = mplusOn streamFeaturesOther } @@ -1019,6 +1029,11 @@ -- >>> resourcepart <$> jidFromText "foo@bar/quux" -- Just (Just "quux") -- +-- @ and / can occur in the domain part +-- +-- >>> jidFromText "foo/bar@quux/foo" +-- Just parseJid "foo/bar@quux/foo" +-- -- * Counterexamples -- -- A JID must only have one \'\@\': @@ -1026,11 +1041,6 @@ -- >>> jidFromText "foo@bar@quux" -- Nothing -- --- \'\@\' must come before \'/\': --- --- >>> jidFromText "foo/bar@quux" --- Nothing --- -- The domain part can\'t be empty: -- -- >>> jidFromText "foo@/quux" @@ -1047,6 +1057,7 @@ -- -- >>> jidToTexts <$> jidFromText "bar/" -- Nothing +-- jidFromText :: Text -> Maybe Jid jidFromText t = do (l, d, r) <- eitherToMaybe $ AP.parseOnly jidParts t @@ -1163,7 +1174,7 @@ return bytes resourcePart = do _ <- AP.char '/' - AP.takeWhile1 (AP.notInClass ['@', '/']) + AP.takeText @@ -1245,8 +1256,6 @@ -- | Whether or not to perform the legacy -- session bind as defined in the (outdated) -- RFC 3921 specification - , establishSession :: Bool - -- | How the client should behave in regards to TLS. , tlsBehaviour :: TlsBehaviour -- | Settings to be used for TLS negotitation , tlsParams :: ClientParams @@ -1271,13 +1280,11 @@ } } - instance Default StreamConfiguration where def = StreamConfiguration { preferredLang = Nothing , toJid = Nothing , connectionDetails = UseRealm , resolvConf = defaultResolvConf - , establishSession = True , tlsBehaviour = PreferTls , tlsParams = xmppDefaultParams } diff --git a/tests/Doctest.hs b/tests/Doctest.hs --- a/tests/Doctest.hs +++ b/tests/Doctest.hs @@ -15,6 +15,7 @@ main = doctest $ "-isource" : "-itests" + : "-w" : "-idist/build/autogen" : "-hide-all-packages" : "-XQuasiQuotes" diff --git a/tests/Tests/Arbitrary/Xmpp.hs b/tests/Tests/Arbitrary/Xmpp.hs --- a/tests/Tests/Arbitrary/Xmpp.hs +++ b/tests/Tests/Arbitrary/Xmpp.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} module Tests.Arbitrary.Xmpp where import Control.Applicative ((<$>), (<*>)) @@ -30,29 +31,31 @@ Just jid <- tryJid `suchThat` isJust return jid where - tryJid = jidFromTexts <$> maybeGen (genString nodeprepProfile) - <*> genString (SP.namePrepProfile False) - <*> maybeGen (genString resourceprepProfile) + tryJid = jidFromTexts <$> maybeGen (genString nodeprepProfile False) + <*> genString (SP.namePrepProfile False) False + <*> maybeGen (genString resourceprepProfile True) - genString profile = Text.pack . take 1024 <$> listOf1 genChar + genString profile node = Text.pack . take 1024 <$> listOf1 genChar where genChar = arbitrary `suchThat` (not . isProhibited) prohibited = Ranges.toSet $ concat (SP.prohibited profile) isProhibited x = Ranges.member x prohibited - || x `elem` "@/" + || if node + then False + else x `elem` ['@','/'] shrink (Jid lp dp rp) = [ Jid lp' dp rp | lp' <- shrinkMaybe shrink lp] ++ [ Jid lp dp' rp | dp' <- shrink dp] ++ [ Jid lp dp rp' | rp' <- shrinkMaybe shrink rp] -string :: SP.StringPrepProfile -> Gen [Char] -string profile = take 1024 <$> listOf1 genChar - where - genChar = arbitrary `suchThat` (not . isProhibited) - prohibited = Ranges.toSet $ concat (SP.prohibited profile) - isProhibited x = Ranges.member x prohibited - || x `elem` "@/" +-- string :: SP.StringPrepProfile -> Gen [Char] +-- string profile = take 1024 <$> listOf1 genChar +-- where +-- genChar = arbitrary `suchThat` (not . isProhibited) +-- prohibited = Ranges.toSet $ concat (SP.prohibited profile) +-- isProhibited x = Ranges.member x prohibited +-- || x `elem` "@/" instance Arbitrary LangTag where arbitrary = LangTag <$> genTag <*> listOf genTag diff --git a/tests/Tests/Parsers.hs b/tests/Tests/Parsers.hs --- a/tests/Tests/Parsers.hs +++ b/tests/Tests/Parsers.hs @@ -33,9 +33,15 @@ "bar.com" (Just "quux")) it "rejects multiple '@'" $ shouldReject "foo@bar@baz" - it "rejects multiple '/'" $ shouldReject "foo/bar/baz" - it "rejects multiple '/' after '@'" $ shouldReject "quux@foo/bar/baz" - it "rejects '@' after '/'" $ shouldReject "foo/bar@baz" + it "parses multiple '/'" $ jidFromText "foo/bar/baz" + `shouldBe` + (Just (Jid Nothing "foo" (Just "bar/baz"))) + it "parses multiple '/' after '@'" $ jidFromText "quux@foo/bar/baz" + `shouldBe` + (Just (Jid (Just "quux") "foo" (Just "bar/baz"))) + it "parses '@' after '/'" $ jidFromText "foo/bar@baz" + `shouldBe` + (Just (Jid Nothing "foo" (Just "bar@baz"))) it "rejects empty local part" $ shouldReject "@bar/baz" it "rejects empty resource part" $ shouldReject "foo@bar/" it "rejects empty domain part" $ shouldReject "foo@/baz"