pontarius-xmpp 0.4.5 → 0.5.0

raw patch · 19 files changed

+238/−127 lines, 19 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−23
• examples/echoclient/Main.hs +12/−3
• examples/echoclient/echoclient.cabal +8/−1
• pontarius-xmpp.cabal +3/−3
• source/Network/Xmpp/Concurrent.hs +33/−17
• source/Network/Xmpp/Concurrent/Basic.hs +9/−0
• source/Network/Xmpp/Concurrent/Monad.hs +1/−1
• source/Network/Xmpp/Concurrent/Threads.hs +18/−13
• source/Network/Xmpp/Concurrent/Types.hs +17/−9
• source/Network/Xmpp/IM/PresenceTracker.hs +1/−1
• source/Network/Xmpp/IM/Roster.hs +10/−6
• source/Network/Xmpp/Lens.hs +14/−6
• source/Network/Xmpp/Marshal.hs +21/−5
• source/Network/Xmpp/Sasl.hs +9/−2
• source/Network/Xmpp/Stream.hs +32/−11
• source/Network/Xmpp/Types.hs +18/−11
• tests/Doctest.hs +1/−0
• tests/Tests/Arbitrary/Xmpp.hs +15/−12
• tests/Tests/Parsers.hs +9/−3

@@ -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

@@ -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 ()

@@ -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

@@ -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

@@ -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. --

@@ -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)

@@ -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)

@@ -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 <delay> seconds to keep the connection alive. connPersist :: Maybe Int -> TMVar (BS.ByteString -> IO a) -> IO () connPersist (Just delay) sem = forever $ do     pushBS <- atomically $ takeTMVar sem

@@ -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

@@ -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) ->

@@ -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, [])]

@@ -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}

@@ -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

@@ -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

@@ -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             -- "</stream>". 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 ()

@@ -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                               }

@@ -15,6 +15,7 @@ main = doctest $     "-isource"   : "-itests"+  : "-w"   : "-idist/build/autogen"   : "-hide-all-packages"   : "-XQuasiQuotes"

@@ -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

@@ -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"