packages feed

pontarius-xmpp 0.3.0.3 → 0.4.0.0

raw patch · 37 files changed

+2042/−627 lines, 37 filesdep +Cabaldep +QuickCheckdep +asyncdep ~basedep ~conduitdep ~containersbuild-type:Customsetup-changed

Dependencies added: Cabal, QuickCheck, async, criterion, derive, directory, doctest, filepath, hspec, hspec-expectations, lens, pontarius-xmpp, quickcheck-instances, ranges, smallcheck, tasty, tasty-hspec, tasty-hunit, tasty-quickcheck, tasty-th, unbounded-delays

Dependency ranges changed: base, conduit, containers, data-default, hslogger, network, stm, stringprep, text, transformers, xml-picklers, xml-types

Files

+ ChangeLog.md view
@@ -0,0 +1,23 @@+# 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
README.md view
@@ -94,7 +94,7 @@ []</code>.  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:+back to the sender. This can be done like so:      forever $ do         msg <- getMessage sess@@ -117,3 +117,5 @@  Feel free to [contact Jon Kristensen](http://www.jonkri.com/contact/) if you have any questions or comments.++You are also welcome to join the #pontarius IRC channel at Freenode.
Setup.hs view
@@ -1,2 +1,42 @@-import Distribution.Simple-main = defaultMain+-- pilfered from lens package+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref))+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )+import Distribution.Text ( display )+import Distribution.Verbosity ( Verbosity, normal )+import System.FilePath ( (</>) )++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+  { buildHook = \pkg lbi hooks flags -> do+     generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi+     buildHook simpleUserHooks pkg lbi hooks flags+  }++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule verbosity pkg lbi = do+  let dir = autogenModulesDir lbi+  createDirectoryIfMissingVerbose verbosity True dir+  withLibLBI pkg lbi $ \_ libcfg -> do+    withTestLBI pkg lbi $ \suite suitecfg -> do+      rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines+        [ "module Build_" ++ testName suite ++ " where"+        , "deps :: [String]"+        , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))+        ]+  where+    formatdeps = map (formatone . snd)+    formatone p = case packageName p of+      PackageName n -> n ++ "-" ++ showVersion (packageVersion p)++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys
+ benchmarks/Bench.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Criterion.Main+import Network.Xmpp.Types++bench_jidFromTexts = whnf (\(a,b,c) -> jidFromTexts a b c)+                            ( Just "+\227\161[\\3\8260\&4"+                            , "\242|8e3\EOTrf6\DLEp\\\a"+                            , Just ")\211\226")++main = do defaultMain [bench "jidFromTexts 2" bench_jidFromTexts]
pontarius-xmpp.cabal view
@@ -1,7 +1,7 @@ Name:          pontarius-xmpp-Version:       0.3.0.3-Cabal-Version: >= 1.6-Build-Type:    Simple+Version:       0.4.0.0+Cabal-Version: >= 1.9.2+Build-Type:    Custom License:       BSD3 License-File:  LICENSE.md Copyright:     Dmitry Astapov, Pierre Kovalev, Mahdi Abdinejadi, Jon Kristensen,@@ -11,16 +11,17 @@ Stability:     alpha 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.3.tar.gz+Package-URL:   http://www.jonkri.com/releases/pontarius-xmpp-0.4.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.1 && <=7.6.3+Tested-With:   GHC ==7.6.3  Extra-Source-Files: README.md+                  , ChangeLog.md                   , examples/echoclient/echoclient.cabal                   , examples/echoclient/LICENSE.md                   , examples/echoclient/Main.hs@@ -62,11 +63,12 @@                , random               >=1.0.0.0                , split                >=0.1.2.3                , stm                  >=2.1.2.1-               , stringprep           >=1.0+               , stringprep           >=1.0.0                , text                 >=0.11.1.5                , tls                  >=1.1.3                , tls-extra            >=0.6.0                , transformers         >=0.2.2.0+               , unbounded-delays     >=0.1                , void                 >=0.5.5                , xml-types            >=0.3.1                , xml-conduit          >=1.1.0.7@@ -83,37 +85,98 @@   Exposed-modules: Network.Xmpp                  , Network.Xmpp.IM                  , Network.Xmpp.Internal-  Other-modules: Network.Xmpp.Concurrent-               , Network.Xmpp.Concurrent.Basic-               , Network.Xmpp.Concurrent.IQ-               , Network.Xmpp.Concurrent.Message-               , Network.Xmpp.Concurrent.Monad-               , Network.Xmpp.Concurrent.Presence-               , Network.Xmpp.Concurrent.Threads-               , Network.Xmpp.Concurrent.Types-               , Network.Xmpp.IM.Message-               , Network.Xmpp.IM.Presence-               , Network.Xmpp.IM.Roster-               , Network.Xmpp.IM.Roster.Types-               , Network.Xmpp.Marshal-               , Network.Xmpp.Sasl-               , Network.Xmpp.Sasl.Common-               , Network.Xmpp.Sasl.Mechanisms-               , Network.Xmpp.Sasl.Mechanisms.DigestMd5-               , Network.Xmpp.Sasl.Mechanisms.Plain-               , Network.Xmpp.Sasl.Mechanisms.Scram-               , Network.Xmpp.Sasl.StringPrep-               , Network.Xmpp.Sasl.Types-               , Network.Xmpp.Stanza-               , Network.Xmpp.Stream-               , Network.Xmpp.Tls-               , Network.Xmpp.Types-               , Network.Xmpp.Utilities+                 , Network.Xmpp.Concurrent+                 , Network.Xmpp.Concurrent.Basic+                 , Network.Xmpp.Concurrent.IQ+                 , Network.Xmpp.Concurrent.Message+                 , Network.Xmpp.Concurrent.Monad+                 , Network.Xmpp.Concurrent.Presence+                 , Network.Xmpp.Concurrent.Threads+                 , Network.Xmpp.Concurrent.Types+                 , Network.Xmpp.IM.Message+                 , Network.Xmpp.IM.Presence+                 , Network.Xmpp.IM.Roster+                 , Network.Xmpp.IM.Roster.Types+                 , Network.Xmpp.Lens+                 , Network.Xmpp.Marshal+                 , Network.Xmpp.Sasl+                 , Network.Xmpp.Sasl.Common+                 , Network.Xmpp.Sasl.Mechanisms+                 , Network.Xmpp.Sasl.Mechanisms.DigestMd5+                 , Network.Xmpp.Sasl.Mechanisms.Plain+                 , Network.Xmpp.Sasl.Mechanisms.Scram+                 , Network.Xmpp.Sasl.StringPrep+                 , Network.Xmpp.Sasl.Types+                 , Network.Xmpp.Stanza+                 , Network.Xmpp.Stream+                 , Network.Xmpp.Tls+                 , Network.Xmpp.Types+                 , Network.Xmpp.Utilities    if flag(with-th) && impl(ghc >= 7.6.1)     CPP-Options: -DWITH_TEMPLATE_HASKELL-  GHC-Options: -Wall+  GHC-Options: -Wall -fwarn-tabs +Test-Suite tests+  Type: exitcode-stdio-1.0+  main-is: Main.hs+  Build-Depends: base+               , Cabal+               , QuickCheck+               , async+               , async+               , conduit+               , containers+               , data-default+               , derive+               , hslogger+               , hspec+               , hspec-expectations+               , lens+               , network+               , pontarius-xmpp+               , quickcheck-instances+               , ranges+               , smallcheck+               , stm+               , stringprep >= 1.0.0+               , tasty+               , tasty-hspec+               , tasty-hunit+               , tasty-quickcheck+               , tasty-th+               , text+               , transformers+               , xml-picklers+               , xml-types+  HS-Source-Dirs: tests+  Other-modules: Tests.Arbitrary+               , Tests.Arbitrary.Xml+               , Tests.Arbitrary.Xmpp+  ghc-options: -Wall -O2 -fno-warn-orphans++Test-Suite doctest+  Type: exitcode-stdio-1.0+  hs-source-dirs: tests+  main-is: Doctest.hs+  GHC-Options: -Wall -threaded+  Build-Depends: base+               , doctest+               , directory+               , filepath+               , QuickCheck+               , derive+               , quickcheck-instances++benchmark benchmarks+  type: exitcode-stdio-1.0+  build-depends: base+               , criterion+               , pontarius-xmpp+  hs-source-dirs: benchmarks+  main-is: Bench.hs+  ghc-options: -O2+ Source-Repository head   Type: git   Location: git://github.com/pontarius/pontarius-xmpp.git@@ -121,4 +184,4 @@ Source-Repository this   Type: git   Location: git://github.com/pontarius/pontarius-xmpp.git-  Tag: 0.3.0.3+  Tag: 0.4.0.0
source/Network/Xmpp.hs view
@@ -15,12 +15,32 @@ -- presence-aware clients and servers. -- -- Pontarius XMPP is an XMPP client library, implementing the core capabilities--- of XMPP (RFC 6120): setup and teardown of XML streams, channel encryption,+-- of XMPP (RFC 6120): setup and tear-down of XML streams, channel encryption, -- authentication, error handling, and communication primitives for messaging. -- -- For low-level access to Pontarius XMPP, see the "Network.Xmpp.Internal" -- module.-+--+-- Getting Started+--+-- We use 'session' to create a session object and connect to a server. Here we+-- use the default 'SessionConfiguration'.+--+-- @+-- sess <- session realm (simpleAuth \"myUsername\" \"mypassword\") def+-- @+--+-- Defining 'AuthData' can be a bit unwieldy, so 'simpleAuth' gives us a+-- reasonable default. Though, for improved security, we should consider+-- restricting the mechanisms to 'scramSha1' whenever we can.+--+-- Next we have to set the presence to online, otherwise we won't be able to+-- send or receive stanzas to/from other entities.+--+-- @+-- sendPresence presenceOnline sess+-- @+-- {-# LANGUAGE CPP, NoMonomorphismRestriction, OverloadedStrings #-}  module Network.Xmpp@@ -34,13 +54,19 @@   , StreamConfiguration(..)   , SessionConfiguration(..)   , ConnectionDetails(..)+  , ConnectionState(..)   , closeConnection   , endSession   , waitForStream-    -- TODO: Close session, etc.     -- ** Authentication handlers     -- | The use of 'scramSha1' is /recommended/, but 'digestMd5' might be     -- useful for interaction with older implementations.+  , SaslHandler+  , AuthData+  , Username+  , Password+  , AuthZID+  , simpleAuth   , scramSha1   , plain   , digestMd5@@ -50,6 +76,7 @@   -- address, but contains three parts instead of two.   , Jid #if WITH_TEMPLATE_HASKELL+  , jid   , jidQ #endif   , isBare@@ -100,7 +127,7 @@   -- | 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+  -- an 'InstantMessage'   , Message(..)   , message   , MessageError(..)@@ -112,9 +139,13 @@   -- *** Receiving   , pullMessage   , getMessage+  , getMessageA   , waitForMessage+  , waitForMessageA   , waitForMessageError+  , waitForMessageErrorA   , filterMessages+  , filterMessagesA   -- ** Presence   -- | XMPP includes the ability for an entity to advertise its network   -- availability, or "presence", to other entities. In XMPP, this availability@@ -130,6 +161,7 @@   , presenceSubscribe   , presenceSubscribed   , presenceUnsubscribe+  , presenceUnsubscribed   , presTo   -- *** Sending   -- | Sends a presence stanza. In general, the presence stanza should have no@@ -164,20 +196,36 @@   , sendIQ   , sendIQ'   , answerIQ-  , listenIQChan-  , dropIQChan+  , iqResult+  , listenIQ+  , unlistenIQ   -- * Errors-  , StanzaError(..)   , StanzaErrorType(..)+  , StanzaError(..)+  , associatedErrorType+  , mkStanzaError   , StanzaErrorCondition(..)   , SaslFailure(..)+  , IQSendError(..)   -- * Threads   , dupSession-  -- * Miscellaneous+  -- * Lenses+  -- | Network.Xmpp doesn't re-export the accessors to avoid name+  -- clashes. To use them import Network.Xmpp.Lens+  , module Network.Xmpp.Lens+  -- * Plugins+  -- Plugins modify incoming and outgoing stanzas. They can, for example, handle+  -- encryption, compression or other protocol extensions.+  , Annotated+  , Annotation(..)+  , Plugin+  , Plugin'(..)+  -- * LangTag   , LangTag   , langTagFromText   , langTagToText   , parseLangTag+  -- * Miscellaneous   , XmppFailure(..)   , StreamErrorInfo(..)   , StreamErrorCondition(..)@@ -185,9 +233,8 @@                , AuthSaslFailure                , AuthIllegalCredentials                , AuthOtherFailure )-  , SaslHandler-  , ConnectionState(..)   , connectTls+  , def   ) where  import Network.Xmpp.Concurrent@@ -196,3 +243,5 @@ import Network.Xmpp.Stanza import Network.Xmpp.Types import Network.Xmpp.Tls+import Network.Xmpp.Lens hiding (view, set, modify)+import Data.Default (def)
source/Network/Xmpp/Concurrent.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-} {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings #-} module Network.Xmpp.Concurrent@@ -8,13 +9,13 @@   , module Network.Xmpp.Concurrent.Message   , module Network.Xmpp.Concurrent.Presence   , module Network.Xmpp.Concurrent.IQ-  , StanzaHandler   , newSession   , session   , newStanzaID   , reconnect   , reconnect'   , reconnectNow+  , simpleAuth   ) where  import           Control.Applicative ((<$>))@@ -24,6 +25,7 @@ import qualified Control.Exception as Ex import           Control.Monad import           Control.Monad.Error+import qualified Data.List as List import qualified Data.Map as Map import           Data.Maybe import           Data.Text as Text@@ -48,33 +50,36 @@  import           Control.Monad.State.Strict -runHandlers :: WriteSemaphore -> [StanzaHandler] -> Stanza -> IO ()-runHandlers _    []        _   = return ()-runHandlers  sem (h:hands) sta = do-    res <- h sem sta-    case res of-        True -> runHandlers sem hands sta-        False -> return () -toChan :: TChan Stanza -> StanzaHandler-toChan stanzaC _ sta = do-    atomically $ writeTChan stanzaC sta-    return True+runHandlers :: [Stanza -> [Annotation] -> IO [Annotated Stanza]] -> Stanza -> IO ()+runHandlers [] sta = do+    errorM "Pontarius.Xmpp" $+           "No stanza handlers set, discarding stanza" ++ show sta+    return ()+runHandlers hs sta = go hs sta []+  where go []        _  _   = return ()+        go (h:hands) sta' as = do+            res <- h sta' as+            forM_ res $ \(sta'', as') -> go hands sta'' (as ++ as') +toChan :: TChan (Annotated Stanza) -> StanzaHandler+toChan stanzaC _ sta as = do+    atomically $ writeTChan stanzaC (sta, as)+    return [(sta, [])]  handleIQ :: TVar IQHandlers          -> StanzaHandler-handleIQ iqHands writeSem sta = do+handleIQ iqHands out sta as = do         case sta of-            IQRequestS     i -> handleIQRequest iqHands i >> return False-            IQResultS      i -> handleIQResponse iqHands (Right i) >> return False-            IQErrorS       i -> handleIQResponse iqHands (Left i) >> return False-            _                -> return True+            IQRequestS     i -> handleIQRequest iqHands i >> return []+            IQResultS      i -> handleIQResponse iqHands (Right i) >> return []+            IQErrorS       i -> handleIQResponse iqHands (Left i)  >> return []+            _                -> return [(sta, [])]   where     -- If the IQ request has a namespace, send it through the appropriate channel.     handleIQRequest :: TVar IQHandlers -> IQRequest -> IO ()     handleIQRequest handlers iq = do-        out <- atomically $ do+        res <- atomically $ do             (byNS, _) <- readTVar handlers             let iqNS = fromMaybe "" (nameNamespace . elementName                                                  $ iqRequestPayload iq)@@ -91,24 +96,24 @@                                   Right res -> IQResultS $ IQResult iqid Nothing                                                                     from lang res                           Ex.bracketOnError (atomically $ takeTMVar sentRef)-                                            (atomically .  putTMVar sentRef)+                                            (atomically .  tryPutTMVar sentRef)                                             $ \wasSent -> do                               case wasSent of                                   True -> do                                       atomically $ putTMVar sentRef True                                       return Nothing                                   False -> do-                                      didSend <- writeStanza writeSem response+                                      didSend <- out response                                       case didSend of-                                          True -> do+                                          Right () -> do                                               atomically $ putTMVar sentRef True-                                              return $ Just True-                                          False -> do+                                              return $ Just (Right ())+                                          er@Left{} -> do                                               atomically $ putTMVar sentRef False-                                              return $ Just False-                  writeTChan ch $ IQRequestTicket answerT iq+                                              return $ Just er+                  writeTChan ch $ IQRequestTicket answerT iq as                   return Nothing-        maybe (return ()) (void . writeStanza writeSem) out+        maybe (return ()) (void . out) res     serviceUnavailable (IQRequest iqid from _to lang _tp bd) =         IQErrorS $ IQError iqid Nothing from lang err (Just bd)     err = StanzaError Cancel ServiceUnavailable Nothing Nothing@@ -117,14 +122,34 @@     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.-            (Just tmvar, byID') -> do-                let answer = either IQResponseError IQResponseResult iq-                _ <- tryPutTMVar tmvar answer -- Don't block.-                writeTVar handlers (byNS, byID')+            (Nothing, _) -> return () -- The handler might be removed due to+                                      -- timeout+            (Just (expectedJid, tmvar), byID') -> do+                let expected = case expectedJid of+                    -- IQ was sent to the server and we didn't have a bound JID+                    -- We just accept any matching response+                        Left Nothing -> True+                    -- IQ was sent to the server and we had a bound JID. Valid+                    -- responses might have no to attribute, the domain of the+                    -- server, our bare JID or our full JID+                        Left (Just j) -> case iqFrom iq of+                            Nothing -> True+                            Just jf -> jf <~ j+                    -- IQ was sent to a (full) JID. The answer has to come from+                    -- the same exact JID.+                        Right j -> iqFrom iq == Just j+                case expected of+                    True -> do+                        let answer = Just (either IQResponseError+                                                  IQResponseResult iq, as)+                        _ <- tryPutTMVar tmvar answer -- Don't block.+                        writeTVar handlers (byNS, byID')+                    False -> return ()       where         iqID (Left err') = iqErrorID err'         iqID (Right iq') = iqResultID iq'+        iqFrom (Left err') = iqErrorFrom err'+        iqFrom (Right iq') = iqResultFrom iq'  -- | Creates and initializes a new Xmpp context. newSession :: Stream@@ -140,39 +165,49 @@     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+    let out = writeStanza writeSem+    let rosterH = if (enableRoster config) then [handleRoster ros out]+                                           else []+    (sStanza, ps) <- initPlugins out $ plugins config+    let stanzaHandler = runHandlers $ List.concat+                        [ inHandler <$> ps+                        , [ toChan stanzaChan out+                          , handleIQ iqHands out+                          ]+                        , rosterH+                        ]+    (kill, streamState, reader) <- ErrorT $ startThreadsWith writeSem stanzaHandler eh stream     idGen <- liftIO $ sessionStanzaIDs config     let sess = Session { stanzaCh = stanzaChan-                     , iqHandlers = iqHands-                     , writeSemaphore = wLock-                     , readerThread = reader-                     , idGenerator = idGen-                     , streamRef = streamState-                     , eventHandlers = eh-                     , stopThreads = kill-                     , conf = config-                     , rosterRef = ros-                     , sRealm = realm-                     , sSaslCredentials = mbSasl-                     , reconnectWait = rew-                     }+                       , iqHandlers = iqHands+                       , writeSemaphore = writeSem+                       , readerThread = reader+                       , idGenerator = idGen+                       , streamRef = streamState+                       , eventHandlers = eh+                       , stopThreads = kill+                       , conf = config+                       , rosterRef = ros+                       , sendStanza' = sStanza+                       , sRealm = realm+                       , sSaslCredentials = mbSasl+                       , reconnectWait = rew+                       }     liftIO . atomically $ putTMVar eh $ EventHandlers { connectionClosedHandler =                                                  onConnectionClosed config sess }+    liftIO . forM_ ps $ \p -> onSessionUp p sess     return sess+  where+    initPlugins out' = go out' []+      where+        go out ps' [] = return (out, ps')+        go out ps' (p:ps) = do+            p' <- p out+            go (outHandler p') (p' : ps') ps  connectStream :: HostName               -> SessionConfiguration-              -> Maybe (ConnectionState -> [SaslHandler], Maybe Text)+              -> AuthData               -> IO (Either XmppFailure Stream) connectStream realm config mbSasl = do     Ex.bracketOnError (openStream realm (sessionStreamConfiguration config))@@ -209,9 +244,7 @@ -- 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)+        -> AuthData         -> SessionConfiguration              -- ^ configuration details         -> IO (Either XmppFailure Session) session realm mbSasl config = runErrorT $ do@@ -219,6 +252,23 @@     ses <- ErrorT $ newSession stream config realm mbSasl     liftIO $ when (enableRoster config) $ initRoster ses     return ses++-- | Authenticate using, in order of preference, 'scramSha1', 'digestMd5' and+-- finally, if both of those are not support and the stream is 'Secured' with+-- TLS, try 'plain'+--+-- The resource will be decided by the server+simpleAuth :: Username -> Password -> AuthData+simpleAuth uname pwd = Just (\cstate ->+                              [ scramSha1 uname Nothing pwd+                              , digestMd5 uname Nothing pwd+                              ] +++                              if (cstate == Secured)+                              then [plain uname Nothing pwd]+                              else []+                            , Nothing)++  -- | Reconnect immediately with the stored settings. Returns @Just@ the error -- when the reconnect attempt fails and Nothing when no failure was encountered.
source/Network/Xmpp/Concurrent/Basic.hs view
@@ -11,33 +11,41 @@ import           Network.Xmpp.Types import           Network.Xmpp.Utilities -semWrite :: WriteSemaphore -> BS.ByteString -> IO Bool+semWrite :: WriteSemaphore -> BS.ByteString -> IO (Either XmppFailure ()) semWrite sem bs = Ex.bracket (atomically $ takeTMVar sem)                           (atomically . putTMVar sem)                           ($ bs) -writeStanza :: WriteSemaphore -> Stanza -> IO Bool+writeStanza :: WriteSemaphore -> Stanza -> IO (Either XmppFailure ()) writeStanza sem a = do     let outData = renderElement $ nsHack (pickleElem xpStanza a)     semWrite sem outData --- | Send a stanza to the server.-sendStanza :: Stanza -> Session -> IO Bool-sendStanza a session = writeStanza (writeSemaphore session) a +-- | Send a stanza to the server without running plugins. (The stanza is sent as+-- is)+sendRawStanza :: Stanza -> Session -> IO (Either XmppFailure ())+sendRawStanza a session = writeStanza (writeSemaphore session) a +-- | Send a stanza to the server, managed by plugins+sendStanza :: Stanza -> Session -> IO (Either XmppFailure ())+sendStanza = flip sendStanza'+ -- | Get the channel of incoming stanzas.-getStanzaChan :: Session -> TChan Stanza+getStanzaChan :: Session -> TChan (Stanza, [Annotation]) getStanzaChan session = stanzaCh session  -- | Get the next incoming stanza-getStanza :: Session -> IO Stanza+getStanza :: Session -> IO (Stanza, [Annotation]) getStanza session = atomically . readTChan $ stanzaCh session --- | Create a new session object with the inbound channel duplicated+-- | Duplicate the inbound channel of the session object. Most receiving+-- functions discard stanzas they are not interested in from the inbound+-- channel. Duplicating the channel ensures that those stanzas can aren't lost+-- and can still be handled somewhere else. dupSession :: Session -> IO Session dupSession session = do-    stanzaCh' <- atomically $ dupTChan (stanzaCh session)+    stanzaCh' <- atomically $ cloneTChan (stanzaCh session)     return $ session {stanzaCh = stanzaCh'}  -- | Return the JID assigned to us by the server
source/Network/Xmpp/Concurrent/IQ.hs view
@@ -1,86 +1,97 @@ {-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Concurrent.IQ where -import           Control.Concurrent (forkIO, threadDelay)+import           Control.Applicative ((<$>))+import           Control.Concurrent (forkIO) import           Control.Concurrent.STM+import           Control.Concurrent.Thread.Delay (delay) import           Control.Monad- import qualified Data.Map as Map import           Data.Text (Text) import           Data.XML.Types- import           Network.Xmpp.Concurrent.Basic import           Network.Xmpp.Concurrent.Types import           Network.Xmpp.Types --- | 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+-- | Sends an IQ, returns an STM action that returns the first inbound IQ with a+-- matching ID that has type @result@ or @error@ or Nothing if the timeout was+-- reached.+--+-- When sending the action fails, an XmppFailure is returned.+sendIQ :: Maybe Integer -- ^ Timeout . When the timeout is reached the response+                        -- TMVar will be filled with 'IQResponseTimeout' and the+                        -- id is removed from the list of IQ handlers. 'Nothing'+                        -- deactivates the timeout        -> Maybe Jid -- ^ Recipient (to)        -> IQRequestType  -- ^ IQ type (@Get@ or @Set@)        -> Maybe LangTag  -- ^ Language tag of the payload (@Nothing@ for                          -- default)        -> Element -- ^ The IQ body (there has to be exactly one)        -> Session-       -> IO (Maybe (TMVar IQResponse))-sendIQ timeOut to tp lang body session = do -- TODO: Add timeout+       -> IO (Either XmppFailure (STM (Maybe (Annotated IQResponse))))+sendIQ timeOut to tp lang body session = do     newId <- idGenerator session+    j <- case to of+        Just t -> return $ Right t+        Nothing -> Left <$> getJid session     ref <- atomically $ do         resRef <- newEmptyTMVar+        let value = (j, resRef)         (byNS, byId) <- readTVar (iqHandlers session)-        writeTVar (iqHandlers session) (byNS, Map.insert newId resRef byId)-          -- TODO: Check for id collisions (shouldn't happen?)+        writeTVar (iqHandlers session) (byNS, Map.insert newId value byId)         return resRef     res <- sendStanza (IQRequestS $ IQRequest newId Nothing to lang tp body) session-    if res-        then do+    case res of+        Right () -> do             case timeOut of                 Nothing -> return ()                 Just t -> void . forkIO $ do-                          threadDelay t+                          delay t                           doTimeOut (iqHandlers session) newId ref-            return $ Just ref-        else return Nothing+            return . Right $ readTMVar ref+        Left e -> return $ Left e   where     doTimeOut handlers iqid var = atomically $ do-      p <- tryPutTMVar var IQResponseTimeout+      p <- tryPutTMVar var Nothing       when p $ do           (byNS, byId) <- readTVar (iqHandlers session)           writeTVar handlers (byNS, Map.delete iqid byId)       return () ---- | Like 'sendIQ', but waits for the answer IQ. Times out after 30 seconds-sendIQ' :: Maybe Jid+-- | Like 'sendIQ', but waits for the answer IQ.+sendIQA' :: Maybe Integer+        -> Maybe Jid         -> IQRequestType         -> Maybe LangTag         -> Element         -> Session-        -> IO (Maybe IQResponse)-sendIQ' to tp lang body session = do-    ref <- sendIQ (Just 30000000) to tp lang body session-    maybe (return Nothing) (fmap Just . atomically . takeTMVar) ref+        -> IO (Either IQSendError (Annotated IQResponse))+sendIQA' timeout to tp lang body session = do+    ref <- sendIQ timeout to tp lang body session+    either (return . Left . IQSendError) (fmap (maybe (Left IQTimeOut) Right)+                                     . atomically) ref +-- | Like 'sendIQ', but waits for the answer IQ. Discards plugin Annotations+sendIQ' :: Maybe Integer+        -> Maybe Jid+        -> IQRequestType+        -> Maybe LangTag+        -> Element+        -> Session+        -> IO (Either IQSendError IQResponse)+sendIQ' timeout to tp lang body session = fmap fst <$> sendIQA' timeout to tp lang body session --- | 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. The 'Left' channel might need to be duplicated in order not--- to interfere with existing consumers.+-- | Register your interest in inbound IQ stanzas of a specific type and+-- namespace. The returned STM action yields the received, matching IQ stanzas. ----- 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))-listenIQChan tp ns session = do+-- If a handler for IQ stanzas with the given type and namespace is already+-- registered, the producer will be wrapped in Left. In this case the returned+-- request tickets may already be processed elsewhere.+listenIQ :: IQRequestType  -- ^ Type of IQs to receive ('Get' or 'Set')+         -> Text -- ^ Namespace of the child element+         -> Session+         -> IO (Either (STM IQRequestTicket) (STM IQRequestTicket))+listenIQ tp ns session = do     let handlers = (iqHandlers session)     atomically $ do         (byNS, byID) <- readTVar handlers@@ -91,18 +102,20 @@                 iqCh                 byNS         writeTVar handlers (byNS', byID)-        return $ case present of-            Nothing -> Right iqCh-            Just iqCh' -> Left iqCh'+        case present of+            Nothing -> return . Right $ readTChan iqCh+            Just iqCh' -> do+                clonedChan <- cloneTChan iqCh'+                return . Left $ readTChan clonedChan --- | 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++-- | Unregister a previously registered IQ handler. No more IQ stanzas will be+-- delivered to any of the returned producers.+unlistenIQ :: IQRequestType  -- ^ Type of IQ ('Get' or 'Set')+           -> Text -- ^ Namespace of the child element+           -> Session+           -> IO ()+unlistenIQ tp ns session = do     let handlers = (iqHandlers session)     atomically $ do         (byNS, byID) <- readTVar handlers@@ -117,5 +130,5 @@ -- (False is returned in that case) answerIQ :: IQRequestTicket          -> Either StanzaError (Maybe Element)-         -> IO (Maybe Bool)+         -> IO (Maybe (Either XmppFailure ())) answerIQ ticket = answerTicket ticket
source/Network/Xmpp/Concurrent/Message.hs view
@@ -1,58 +1,96 @@ {-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Concurrent.Message where +import Control.Applicative((<$>)) import Network.Xmpp.Concurrent.Types import Control.Concurrent.STM import Network.Xmpp.Types import Network.Xmpp.Concurrent.Basic --- | Read an element from the inbound stanza channel, discardes any--- non-Message stanzas from the channel-pullMessage :: Session -> IO (Either MessageError Message)-pullMessage session = do-    stanza <- atomically . readTChan $ stanzaCh session+-- | Draw and discard stanzas from the inbound channel until a message or+-- message error is found. Returns the message or message error with annotations.+pullMessageA :: Session -> IO (Either (Annotated MessageError) (Annotated Message))+pullMessageA session = do+    (stanza, as) <- atomically . readTChan $ stanzaCh session     case stanza of-        MessageS m -> return $ Right m-        MessageErrorS e -> return $ Left e-        _ -> pullMessage session+        MessageS m      -> return $ Right (m, as)+        MessageErrorS e -> return $ Left  (e, as)+        _ -> pullMessageA session --- | Get the next received message+-- | Draw and discard stanzas from the inbound channel until a message or+-- message error is found. Returns the message or message error.+pullMessage :: Session -> IO (Either MessageError Message)+pullMessage s = either (Left . fst) (Right . fst) <$> pullMessageA s++-- | Draw and discard stanzas from the inbound channel until a message is+-- found. Returns the message with annotations.+getMessageA :: Session -> IO (Annotated Message)+getMessageA = waitForMessageA (const True)++-- | Draw and discard stanzas from the inbound channel until a message is+-- found. Returns the message. getMessage :: Session -> IO Message-getMessage = waitForMessage (const True)+getMessage s = fst <$> getMessageA s --- | Pulls a (non-error) message and returns it if the given predicate returns--- @True@.-waitForMessage :: (Message -> Bool) -> Session -> IO Message-waitForMessage f session = do-    s <- pullMessage session+-- | Draw and discard stanzas from the inbound channel until a message matching+-- the given predicate is found. Returns the matching message with annotations.+waitForMessageA :: (Annotated Message -> Bool) -> Session -> IO (Annotated Message)+waitForMessageA f session = do+    s <- pullMessageA session     case s of-        Left _ -> waitForMessage f session+        Left _ -> waitForMessageA f session         Right m | f m -> return m-                | otherwise -> waitForMessage f session+                | otherwise -> waitForMessageA f session --- | Pulls an error message and returns it if the given predicate returns @True@.-waitForMessageError :: (MessageError -> Bool) -> Session -> IO MessageError-waitForMessageError f session = do-    s <- pullMessage session+-- | Draw and discard stanzas from the inbound channel until a message matching+-- the given predicate is found. Returns the matching message.+waitForMessage :: (Message -> Bool) -> Session -> IO Message+waitForMessage f s  = fst <$> waitForMessageA (f . fst) s++-- | Draw and discard stanzas from the inbound channel until a message error+-- matching the given predicate is found. Returns the matching message error with+-- annotations.+waitForMessageErrorA :: (Annotated MessageError -> Bool)+                    -> Session+                    -> IO (Annotated MessageError)+waitForMessageErrorA f session = do+    s <- pullMessageA session     case s of-        Right _ -> waitForMessageError f session+        Right _ -> waitForMessageErrorA f session         Left  m | f m -> return m-                | otherwise -> waitForMessageError f session+                | otherwise -> waitForMessageErrorA f session +-- | Draw and discard stanzas from the inbound channel until a message error+-- matching the given predicate is found. Returns the matching message error+waitForMessageError :: (MessageError -> Bool) -> Session -> IO MessageError+waitForMessageError f s  = fst <$> waitForMessageErrorA (f . fst) s --- | Pulls a message and returns it if the given predicate returns @True@.-filterMessages :: (MessageError -> Bool)-               -> (Message -> Bool)-               -> Session -> IO (Either MessageError Message)-filterMessages f g session = do-    s <- pullMessage session+-- | Draw and discard stanzas from the inbound channel until a message or+-- message error matching the given respective predicate is found. Returns the+-- matching message or message error with annotations+filterMessagesA :: (Annotated MessageError -> Bool)+               -> (Annotated Message -> Bool)+               -> Session -> IO (Either (Annotated MessageError)+                                        (Annotated Message))+filterMessagesA f g session = do+    s <- pullMessageA session     case s of         Left  e | f e -> return $ Left e-                | otherwise -> filterMessages f g session+                | otherwise -> filterMessagesA f g session         Right m | g m -> return $ Right m-                | otherwise -> filterMessages f g session+                | otherwise -> filterMessagesA f g session +-- | Draw and discard stanzas from the inbound channel until a message or+-- message error matching the given respective predicate is found. Returns the+-- matching message or message error.+filterMessages :: (MessageError -> Bool)+               -> (Message -> Bool)+               -> Session+               -> IO (Either MessageError Message)+filterMessages f g s = either (Left . fst) (Right . fst) <$>+                          filterMessagesA (f . fst) (g . fst) s+ -- | Send a message stanza. Returns @False@ when the 'Message' could not be -- sent.-sendMessage :: Message -> Session -> IO Bool+sendMessage :: Message -> Session -> IO (Either XmppFailure ()) sendMessage m session = sendStanza (MessageS m) session
source/Network/Xmpp/Concurrent/Monad.hs view
@@ -93,7 +93,7 @@ -- | End the current XMPP session. Kills the associated threads and closes the -- connection. ----- Note that XMPP clients (that has signalled availability) should send+-- Note that XMPP clients (that have signalled availability) should send -- \"Unavailable\" presence prior to disconnecting. -- -- The connectionClosedHandler will not be called (to avoid possibly
source/Network/Xmpp/Concurrent/Presence.hs view
@@ -1,31 +1,43 @@ {-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Concurrent.Presence where +import Control.Applicative ((<$>)) import Control.Concurrent.STM import Network.Xmpp.Types import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Basic --- | Read an element from the inbound stanza channel, discardes any non-Presence--- stanzas from the channel-pullPresence :: Session -> IO (Either PresenceError Presence)-pullPresence session = do-    stanza <- atomically . readTChan $ stanzaCh session+-- | Read a presence stanza from the inbound stanza channel, discards any other+-- stanzas. Returns the presence stanza with annotations.+pullPresenceA :: Session -> IO (Either (Annotated PresenceError)+                                      (Annotated Presence))+pullPresenceA session = do+    (stanza, as) <- atomically . readTChan $ stanzaCh session     case stanza of-        PresenceS p -> return $ Right p-        PresenceErrorS e -> return $ Left e-        _ -> pullPresence session+        PresenceS p -> return $ Right (p, as)+        PresenceErrorS e -> return $ Left (e, as)+        _ -> pullPresenceA session --- | Pulls a (non-error) presence and returns it if the given predicate returns--- @True@.-waitForPresence :: (Presence -> Bool) -> Session -> IO Presence-waitForPresence f session = do-    s <- pullPresence session+-- | Read a presence stanza from the inbound stanza channel, discards any other+-- stanzas. Returns the presence stanza.+pullPresence :: Session -> IO (Either PresenceError Presence)+pullPresence s = either (Left . fst) (Right . fst) <$> pullPresenceA s++-- | Draw and discard stanzas from the inbound channel until a presence stanza matching the given predicate is found. Return the presence stanza with annotations.+waitForPresenceA :: (Annotated Presence -> Bool)+                -> Session+                -> IO (Annotated Presence)+waitForPresenceA f session = do+    s <- pullPresenceA session     case s of-        Left _ -> waitForPresence f session+        Left _ -> waitForPresenceA f session         Right m | f m -> return m-                | otherwise -> waitForPresence f session+                | otherwise -> waitForPresenceA f session +-- | Draw and discard stanzas from the inbound channel until a presence stanza matching the given predicate is found. Return the presence stanza with annotations.+waitForPresence :: (Presence -> Bool) -> Session -> IO Presence+waitForPresence f s = fst <$> waitForPresenceA (f . fst) s+ -- | Send a presence stanza.-sendPresence :: Presence -> Session -> IO Bool+sendPresence :: Presence -> Session -> IO (Either XmppFailure ()) sendPresence p session = sendStanza (PresenceS p) session
source/Network/Xmpp/Concurrent/Threads.hs view
@@ -45,26 +45,24 @@         Just s -> do             res <- Ex.catches (do                              allowInterrupt-                             Just <$> pullStanza s+                             res <- pullStanza s+                             case res of+                                 Left e -> do+                                     errorM "Pontarius.Xmpp" $ "Read error: "+                                         ++ show e+                                     _ <- closeStreams s+                                     onCClosed e+                                     return Nothing+                                 Right r -> return $ Just r                               )                        [ Ex.Handler $ \(Interrupt t) -> do                               void $ handleInterrupts [t]                               return Nothing-                       , 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+                Just sta -> void $ onStanza sta   where     -- Defining an Control.Exception.allowInterrupt equivalent for GHC 7     -- compatibility.@@ -89,14 +87,13 @@ -- | Runs thread in XmppState monad. Returns channel of incoming and outgoing -- stances, respectively, and an Action to stop the Threads and close the -- connection.-startThreadsWith :: TMVar (BS.ByteString -> IO Bool)+startThreadsWith :: TMVar (BS.ByteString -> IO (Either XmppFailure ()))                  -> (Stanza -> IO ())                  -> TMVar EventHandlers                  -> Stream                  -> IO (Either XmppFailure (IO (),-                  TMVar (BS.ByteString -> IO Bool),-                  TMVar Stream,-                  ThreadId))+                                            TMVar Stream,+                                            ThreadId)) startThreadsWith writeSem stanzaHandler eh con = do     -- read' <- withStream' (gets $ streamSend . streamHandle) con     -- writeSem <- newTMVarIO read'@@ -104,7 +101,6 @@     cp <- forkIO $ connPersist writeSem     rdw <- forkIO $ readWorker stanzaHandler (noCon eh) conS     return $ Right ( killConnection [rdw, cp]-                   , writeSem                    , conS                    , rdw                    )@@ -112,7 +108,7 @@     killConnection threads = liftIO $ do         _ <- atomically $ do             _ <- takeTMVar writeSem-            putTMVar writeSem $ \_ -> return False+            putTMVar writeSem $ \_ -> return $ Left XmppNoStream         _ <- forM threads killThread         return ()     -- Call the connection closed handlers.@@ -124,7 +120,7 @@  -- 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 :: TMVar (BS.ByteString -> IO a) -> IO () connPersist sem = forever $ do     pushBS <- atomically $ takeTMVar sem     _ <- pushBS " "
source/Network/Xmpp/Concurrent/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ExistentialQuantification #-} {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -6,6 +7,7 @@ import           Control.Concurrent import           Control.Concurrent.STM import qualified Control.Exception.Lifted as Ex+import           Control.Monad.Error import qualified Data.ByteString as BS import           Data.Default import qualified Data.Map as Map@@ -15,19 +17,72 @@ import           Data.XML.Types (Element) import           Network import           Network.Xmpp.IM.Roster.Types-import           Network.Xmpp.Types import           Network.Xmpp.Sasl.Types+import           Network.Xmpp.Types +type StanzaHandler =  (Stanza -> IO (Either XmppFailure ()) ) -- ^ outgoing stanza+                   -> Stanza       -- ^ stanza to handle+                   -> [Annotation] -- ^ annotations added by previous handlers+                   -> IO [(Stanza, [Annotation])]  -- ^ modified stanzas and+                                                   -- /additional/ annotations +type Resource = Text++-- | SASL handlers and the desired JID resource+--+-- Nothing to disable authentication+--+-- The allowed SASL mecahnism can depend on the connection state. For example,+-- 'plain' should be avoided unless the connection state is 'Secured'+--+-- It is recommended to leave the resource up to the server+type AuthData = Maybe (ConnectionState -> [SaslHandler] , Maybe Resource)++-- | Annotations are auxiliary data attached to received stanzas by 'Plugin's to+-- convey information regarding their operation. For example, a plugin for+-- encryption might attach information about whether a received stanza was+-- encrypted and which algorithm was used.+data Annotation = forall f.(Typeable f, Show f) => Annotation{fromAnnotation :: f}++instance Show Annotation where+    show (Annotation x) = "Annotation{ fromAnnotation = " ++ show x ++ "}"++type Annotated a = (a, [Annotation])++-- | Retrieve the first matching annotation+getAnnotation :: Typeable b => Annotated a -> Maybe b+getAnnotation = foldr (\(Annotation a) b -> maybe b Just $ cast a) Nothing . snd++data Plugin' = Plugin'+    { -- | Resulting stanzas and additional Annotations+      inHandler :: Stanza+                -> [Annotation]+                -> IO [(Stanza, [Annotation])]+    , outHandler :: Stanza -> 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+              -> ErrorT XmppFailure IO Plugin'+ -- | 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).+      -- | Handler to be run when the conection to the XMPP server is+      -- closed. See also 'reconnect' and 'reconnect\'' for easy+      -- reconnection. The default does nothing     , onConnectionClosed         :: Session -> XmppFailure -> IO ()-      -- | Function to generate the stream of stanza identifiers.+      -- | Function to generate new stanza identifiers.     , sessionStanzaIDs           :: IO (IO Text)-    , extraStanzaHandlers        :: [StanzaHandler]+      -- | Plugins can modify incoming and outgoing stanzas, for example to en-+      -- and decrypt them, respectively+    , plugins                    :: [Plugin]+      -- | Enable roster handling according to rfc 6121. See 'getRoster' to+      -- acquire the current roster     , enableRoster               :: Bool     } @@ -40,7 +95,7 @@                                          curId <- readTVar idRef                                          writeTVar idRef (curId + 1 :: Integer)                                          return . Text.pack . show $ curId-                               , extraStanzaHandlers = []+                               , plugins = []                                , enableRoster = True                                } @@ -56,11 +111,12 @@  instance Ex.Exception Interrupt -type WriteSemaphore = TMVar (BS.ByteString -> IO Bool)+type WriteSemaphore = TMVar (BS.ByteString -> IO (Either XmppFailure ())) --- | A concurrent interface to Pontarius XMPP.+-- | The Session object represents a single session with an XMPP server. You can+-- use 'session' to establish a session data Session = Session-    { stanzaCh :: TChan Stanza -- All stanzas+    { stanzaCh :: TChan (Stanza, [Annotation]) -- All stanzas     , iqHandlers :: TVar IQHandlers       -- Writing lock, so that only one thread could write to the stream at any       -- given time.@@ -75,6 +131,7 @@     , stopThreads :: IO ()     , rosterRef :: TVar Roster     , conf :: SessionConfiguration+    , sendStanza' :: Stanza -> IO (Either XmppFailure ())     , sRealm :: HostName     , sSaslCredentials :: Maybe (ConnectionState -> [SaslHandler] , Maybe Text)     , reconnectWait :: TVar Int@@ -83,18 +140,26 @@ -- | IQHandlers holds the registered channels for incoming IQ requests and -- TMVars of and TMVars for expected IQ responses (the second Text represent a -- stanza identifier.-type IQHandlers = (Map.Map (IQRequestType, Text) (TChan IQRequestTicket)-                  , Map.Map Text (TMVar IQResponse)+type IQHandlers = ( Map.Map (IQRequestType, Text) (TChan IQRequestTicket)+                  , Map.Map Text (Either (Maybe Jid) Jid,+                                  TMVar (Maybe (Annotated IQResponse)))                   ) --- | Contains whether or not a reply has been sent, and the IQ request body to--- reply to.-+-- | A received and wrapped up IQ request. Prevents you from (illegally)+-- answering a single IQ request multiple times data IQRequestTicket = IQRequestTicket-    { 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)+    {   -- | Send an answer to an IQ request once. Subsequent calls will do+        -- nothing and return Nothing+      answerTicket :: Either StanzaError (Maybe Element)+                      -> IO (Maybe (Either XmppFailure ()))+      -- | The actual IQ request that created this ticket.     , iqRequestBody :: IQRequest+      -- | Annotations set by plugins in receive+    , iqRequestAnnotations :: [Annotation]     }++-- | Error that can occur during sendIQ'+data IQSendError = IQSendError XmppFailure -- There was an error sending the IQ+                                           -- stanza+                 | IQTimeOut -- No answer was received during the allotted time+                   deriving (Show, Eq)
source/Network/Xmpp/IM/Message.hs view
@@ -30,6 +30,7 @@                                      , imBody    :: [MessageBody]                                      } +-- | Empty instant message. instantMessage :: InstantMessage instantMessage = InstantMessage { imThread  = Nothing                                 , imSubject = []@@ -47,7 +48,8 @@ sanitizeIM :: InstantMessage -> InstantMessage sanitizeIM im = im{imBody = nubBy ((==) `on` bodyLang) $ imBody im} --- | Append IM data to a message+-- | Append IM data to a message. Additional IM bodies with the same Langtag are+-- discarded. withIM :: Message -> InstantMessage -> Message withIM m im = m{ messagePayload = messagePayload m                                  ++ pickleTree xpIM (sanitizeIM im) }@@ -63,12 +65,11 @@                        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,+-- 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.+-- thread are inherited. ----- If multiple message bodies are given they MUST have different language tags+-- Additional IM bodies with the same Langtag are discarded. answerIM :: [MessageBody] -> Message -> Maybe Message answerIM bd msg = case getIM msg of     Nothing -> Nothing
source/Network/Xmpp/IM/Presence.hs view
@@ -29,8 +29,8 @@ 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+-- | 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
source/Network/Xmpp/IM/Roster.hs view
@@ -27,21 +27,25 @@ import           Network.Xmpp.Marshal import           Network.Xmpp.Types +-- | Timeout to use with IQ requests+timeout :: Maybe Integer+timeout = Just 3000000 -- 3 seconds+ -- | 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)+-- ignored and all values for subsciption except "remove" are ignored.+rosterPush :: Item -> Session -> IO (Either IQSendError (Annotated IQResponse)) rosterPush item session = do     let el = pickleElem xpQuery (Query Nothing [fromItem item])-    sendIQ'  Nothing Set Nothing el session+    sendIQA' timeout 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+-- 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)+          -> IO (Either IQSendError (Annotated IQResponse)) rosterAdd j n gs session = do     let el = pickleElem xpQuery (Query Nothing                                  [QueryItem { qiApproved = Nothing@@ -51,9 +55,9 @@                                             , qiSubscription = Nothing                                             , qiGroups = nub gs                                             }])-    sendIQ'  Nothing Set Nothing el session+    sendIQA' timeout Nothing Set Nothing el session --- | Remove an item from the roster. Return True when the item is sucessfully+-- | 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@@ -63,14 +67,15 @@         Just _ -> do             res <- rosterPush (Item False False j Nothing Remove []) sess             case res of-                Just (IQResponseResult IQResult{}) -> return True+                Right (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+-- | Get the initial roster or refresh the roster. You don't need to call this+-- on your own. initRoster :: Session -> IO () initRoster session = do     oldRoster <- getRoster session@@ -78,29 +83,29 @@                                                           else Nothing ) session     case mbRoster of         Nothing -> errorM "Pontarius.Xmpp"-                          "Server did not return a roster"+                          "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+handleRoster :: TVar Roster -> StanzaHandler+handleRoster ref out 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+                Just _from -> return [(sta, [])] -- 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+                        _ <- out $ result iqr+                        return []                     _ -> do                         errorM "Pontarius.Xmpp" "Invalid roster query"-                        _ <- writeStanza sem $ badRequest iqr-                        return False-    _ -> return True+                        _ <- out $ badRequest iqr+                        return []+    _ -> return [(sta, [])]   where     handleUpdate v' update = atomically $ modifyTVar ref $ \(Roster v is) ->         Roster (v' `mplus` v) $ case qiSubscription update of@@ -121,26 +126,23 @@                       Nothing -> Just ""                       Just oldRoster -> ver oldRoster                 else Nothing-    res <- sendIQ' Nothing Get Nothing-        (pickleElem xpQuery (Query version []))-        sess+    res <- sendIQ' timeout Nothing Get Nothing+                   (pickleElem xpQuery (Query version []))+                   sess     case res of-        Nothing -> do-            errorM "Pontarius.Xmpp.Roster" "getRoster: sending stanza failed"+        Left e -> do+            errorM "Pontarius.Xmpp.Roster" $ "getRoster: " ++ show e             return Nothing-        Just (IQResponseResult (IQResult{iqResultPayload = Just ros}))+        Right (IQResponseResult IQResult{iqResultPayload = Just ros})             -> case unpickleElem xpQuery ros of             Left _e -> do                 errorM "Pontarius.Xmpp.Roster" "getRoster: invalid query element"                 return Nothing             Right ros' -> return . Just $ toRoster ros'-        Just (IQResponseResult (IQResult{iqResultPayload = Nothing})) -> do+        Right (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+        Right (IQResponseError e) -> do             errorM "Pontarius.Xmpp.Roster" $ "getRoster: server returned error"                    ++ show e             return Nothing
source/Network/Xmpp/IM/Roster/Types.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.IM.Roster.Types where  import qualified Data.Map as Map@@ -9,8 +10,8 @@ data Subscription = None | To | From | Both | Remove deriving (Eq, Read, Show)  data Roster = Roster { ver :: Maybe Text-                     , items :: Map.Map Jid Item } deriving Show-+                     , items :: Map.Map Jid Item+                     } deriving Show  -- | Roster Items data Item = Item { riApproved :: Bool
source/Network/Xmpp/Internal.hs view
@@ -17,27 +17,43 @@ -- top of this API.  module Network.Xmpp.Internal-  ( Stream(..)+  ( -- * Stream+    Stream(..)   , StreamConfiguration(..)   , StreamState(..)   , StreamHandle(..)   , StreamFeatures(..)   , openStream   , withStream+    -- * TLS   , tls+  , TlsBehaviour(..)+    -- * Auth+  , SaslHandler   , auth+    -- * Stanzas+  , Stanza(..)   , pushStanza   , pullStanza+  , writeStanza+    -- ** IQ   , pushIQ-  , SaslHandler-  , Stanza(..)-  , TlsBehaviour(..)+  , iqError+  , iqResult+  , associatedErrorType+    -- * Plugins+  , Plugin+  , Plugin'(..)+  , Annotation(..)+  , connectTls  )-        where -import Network.Xmpp.Stream+import Network.Xmpp.Concurrent.Basic+import Network.Xmpp.Concurrent.Types import Network.Xmpp.Sasl import Network.Xmpp.Sasl.Types+import Network.Xmpp.Stanza+import Network.Xmpp.Stream import Network.Xmpp.Tls import Network.Xmpp.Types
+ source/Network/Xmpp/Lens.hs view
@@ -0,0 +1,532 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}++-- | Van Laarhoven lenses for XMPP types. The lenses are designed to work with+-- the lens library. This module also provides a few simple accessors ('view',+-- 'modify', 'set' and 'getAll') so you don't need to pull in the+-- lens library to get some use out of them.+--+-- The name of the lenses corresponds to the field name of the data types with+-- an upper-case L appended. For documentation of the fields refer to the documentation of the data types (linked in the section header)++module Network.Xmpp.Lens+       ( Lens+       , Traversal+         -- * Accessors+         -- | Reimplementation of the basic lens functions so you don't have to+         -- bring in all of lens library in to use the lenses++         -- ** Lenses+       , view+       , modify+       , set+         -- * Traversals+       , getAll+         -- * Lenses++         -- ** Stanzas+       , IsStanza(..)+       , HasStanzaPayload(..)+       , IsErrorStanza(..)+       , messageTypeL+       , presenceTypeL+       , iqRequestTypeL+         -- *** 'StanzaError'+       , stanzaErrorTypeL+       , stanzaErrorConditionL+       , stanzaErrorTextL+       , stanzaErrorApplL+         -- *** 'StreamConfiguration'+       , preferredLangL+       , toJidL+       , connectionDetailsL+       , resolvConfL+       , establishSessionL+       , tlsBehaviourL+       , tlsParamsL+         -- *** 'SessionConfiguration'+       , streamConfigurationL+       , onConnectionClosedL+       , sessionStanzaIDsL+       , ensableRosterL+       , pluginsL+         -- ** IM+         -- *** Roster+         -- **** 'Roster'+       , verL+       , itemsL+         -- **** 'Item'+       , riApprovedL+       , riAskL+       , riJidL+       , riNameL+       , riSubscriptionL+       , riGroupsL+         -- **** 'QueryItem'+       , qiApprovedL+       , qiAskL+       , qiJidL+       , qiNameL+       , qiSubscriptionL+       , qiGroupsL+         -- **** 'Query'+       , queryVerL+       , queryItemsL+         -- ** IM Message+         -- *** 'MessageBody'+       , bodyLangL+       , bodyContentL+         -- *** 'MessageThread'+       , threadIdL+       , threadParentL+         -- *** 'MessageSubject'+       , subjectLangL+       , subjectContentL+         -- *** 'InstantMessage'+       , imThreadL+       , imSubjectL+       , imBodyL+         -- ** 'IMPresence'+       , showStatusL+       , statusL+       , priorityL++       )+       where++import           Control.Applicative+import           Data.Functor.Identity(Identity(..))+import qualified Data.Map as Map+import qualified Data.Text as Text+import           Data.Text(Text)+import           Data.XML.Types(Element)+import           Network.DNS(ResolvConf)+import           Network.TLS (TLSParams)+import           Network.Xmpp.Concurrent.Types+import           Network.Xmpp.IM.Roster.Types+import           Network.Xmpp.IM.Message+import           Network.Xmpp.IM.Presence+import           Network.Xmpp.Types++-- | Van-Laarhoven lenses.+type Lens a b = Functor f => (b -> f b) -> a -> f a++type Traversal a b = Applicative f => (b -> f b) -> a -> f a+++-- Accessors+---------------+++-- | Read the value the lens is pointing to+view :: Lens a b -> a -> b+view l x = getConst $ l Const x++-- | Replace the value the lens is pointing to+set :: Lens a b -> b -> a -> a+set l b x = modify l (const b) x++-- | modify the Value(s) a Lens or Traversal is pointing to+modify :: Traversal a b -> (b -> b) -> a -> a+modify t f = runIdentity . t (Identity . f)++newtype Collect a b = Collect {getCollection :: [a]} deriving Functor++instance Applicative (Collect a) where+    pure _ = Collect []+    Collect xs <*> Collect ys = Collect $ xs ++ ys++-- | Return all the values a Traversal is pointing to in a list+getAll :: Traversal a b -> a -> [b]+getAll t = getCollection . t (Collect . pure)+++-- Xmpp Lenses+--------------------++class IsStanza s where+    -- | From-attribute of the stanza+    from :: Lens s (Maybe Jid)+    -- | To-attribute of the stanza+    to   :: Lens s (Maybe Jid)+    -- | Langtag of the stanza+    lang :: Lens s (Maybe LangTag)+    -- | Stanza ID. Setting this to /Nothing/ for IQ* stanzas will set the id to+    -- the empty Text.+    sid :: Lens s (Maybe Text)+    -- | Traversal over the payload elements.+    payloadT :: Traversal s Element++traverseList :: Traversal [a] a+traverseList _inj [] = pure []+traverseList inj  (x:xs) = (:) <$> inj x <*> traverseList inj xs++instance IsStanza Message where+    from inj m@(Message{messageFrom=f}) = (\f' -> m{messageFrom = f'}) <$> inj f+    to inj m@(Message{messageTo=t}) = (\t' -> m{messageTo = t'}) <$> inj t+    lang inj m@(Message{messageLangTag=t}) =+        (\t' -> m{messageLangTag = t'}) <$> inj t+    sid inj m@(Message{messageID = i}) =+        ((\i' -> m{messageID = i'}) <$> inj i)+    payloadT inj m@(Message{messagePayload=pl}) =+        (\pl' -> m{messagePayload=pl'}) <$> traverseList inj pl+++instance IsStanza MessageError where+    from inj m@(MessageError{messageErrorFrom=f}) =+        (\f' -> m{messageErrorFrom = f'}) <$> inj f+    to inj m@(MessageError{messageErrorTo=t}) =+        (\t' -> m{messageErrorTo = t'}) <$> inj t+    lang inj m@(MessageError{messageErrorLangTag=t}) =+        (\t' -> m{messageErrorLangTag = t'}) <$> inj t+    sid inj m@(MessageError{messageErrorID = i}) =+        ((\i' -> m{messageErrorID = i'}) <$> inj i)+    payloadT inj m@(MessageError{messageErrorPayload=pl}) =+        (\pl' -> m{messageErrorPayload=pl'}) <$> traverseList inj pl++instance IsStanza Presence where+    from inj m@(Presence{presenceFrom=f}) = (\f' -> m{presenceFrom = f'}) <$> inj f+    to inj m@(Presence{presenceTo=t}) = (\t' -> m{presenceTo = t'}) <$> inj t+    lang inj m@(Presence{presenceLangTag=t}) =+        (\t' -> m{presenceLangTag = t'}) <$> inj t+    sid inj m@(Presence{presenceID = i}) =+        ((\i' -> m{presenceID = i'}) <$> inj i)+    payloadT inj m@(Presence{presencePayload=pl}) =+        (\pl' -> m{presencePayload=pl'}) <$> traverseList inj pl++instance IsStanza PresenceError where+    from inj m@(PresenceError{presenceErrorFrom=f}) =+        (\f' -> m{presenceErrorFrom = f'}) <$> inj f+    to inj m@(PresenceError{presenceErrorTo=t}) =+        (\t' -> m{presenceErrorTo = t'}) <$> inj t+    lang inj m@(PresenceError{presenceErrorLangTag=t}) =+        (\t' -> m{presenceErrorLangTag = t'}) <$> inj t+    sid inj m@(PresenceError{presenceErrorID = i}) =+        ((\i' -> m{presenceErrorID = i'}) <$> inj i)+    payloadT inj m@(PresenceError{presenceErrorPayload=pl}) =+        (\pl' -> m{presenceErrorPayload=pl'}) <$> traverseList inj pl++instance IsStanza IQRequest where+    from inj m@(IQRequest{iqRequestFrom=f}) =+        (\f' -> m{iqRequestFrom = f'}) <$> inj f+    to inj m@(IQRequest{iqRequestTo=t}) =+        (\t' -> m{iqRequestTo = t'}) <$> inj t+    lang inj m@(IQRequest{iqRequestLangTag=t}) =+        (\t' -> m{iqRequestLangTag = t'}) <$> inj t+    sid inj m@(IQRequest{iqRequestID = i}) =+        ((\i' -> m{iqRequestID = i'}) <$> maybeNonempty inj i)+    payloadT inj m@(IQRequest{iqRequestPayload=pl}) =+        (\pl' -> m{iqRequestPayload=pl'}) <$> inj pl++instance IsStanza IQResult where+    from inj m@(IQResult{iqResultFrom=f}) =+        (\f' -> m{iqResultFrom = f'}) <$> inj f+    to inj m@(IQResult{iqResultTo=t}) =+        (\t' -> m{iqResultTo = t'}) <$> inj t+    lang inj m@(IQResult{iqResultLangTag=t}) =+        (\t' -> m{iqResultLangTag = t'}) <$> inj t+    sid inj m@(IQResult{iqResultID = i}) =+        ((\i' -> m{iqResultID = i'}) <$> maybeNonempty inj i)+    payloadT inj m@(IQResult{iqResultPayload=pl}) =+        (\pl' -> m{iqResultPayload=pl'}) <$> maybe (pure Nothing)+                                                   (fmap Just . inj) pl++instance IsStanza IQError where+    from inj m@(IQError{iqErrorFrom=f}) =+        (\f' -> m{iqErrorFrom = f'}) <$> inj f+    to inj m@(IQError{iqErrorTo=t}) =+        (\t' -> m{iqErrorTo = t'}) <$> inj t+    lang inj m@(IQError{iqErrorLangTag=t}) =+        (\t' -> m{iqErrorLangTag = t'}) <$> inj t+    sid inj m@(IQError{iqErrorID = i}) =+        ((\i' -> m{iqErrorID = i'}) <$> maybeNonempty inj i)+    payloadT inj m@(IQError{iqErrorPayload=pl}) =+        (\pl' -> m{iqErrorPayload=pl'}) <$> maybe (pure Nothing)+                                                  (fmap Just . inj) pl++liftLens :: (forall s. IsStanza s => Lens s a) -> Lens Stanza a+liftLens f inj (IQRequestS     s) = IQRequestS     <$> f inj s+liftLens f inj (IQResultS      s) = IQResultS      <$> f inj s+liftLens f inj (IQErrorS       s) = IQErrorS       <$> f inj s+liftLens f inj (MessageS       s) = MessageS       <$> f inj s+liftLens f inj (MessageErrorS  s) = MessageErrorS  <$> f inj s+liftLens f inj (PresenceS      s) = PresenceS      <$> f inj s+liftLens f inj (PresenceErrorS s) = PresenceErrorS <$> f inj s++liftTraversal :: (forall s. IsStanza s => Traversal s a) -> Traversal Stanza a+liftTraversal f inj (IQRequestS     s) = IQRequestS     <$> f inj s+liftTraversal f inj (IQResultS      s) = IQResultS      <$> f inj s+liftTraversal f inj (IQErrorS       s) = IQErrorS       <$> f inj s+liftTraversal f inj (MessageS       s) = MessageS       <$> f inj s+liftTraversal f inj (MessageErrorS  s) = MessageErrorS  <$> f inj s+liftTraversal f inj (PresenceS      s) = PresenceS      <$> f inj s+liftTraversal f inj (PresenceErrorS s) = PresenceErrorS <$> f inj s++instance IsStanza Stanza where+    from     = liftLens from+    to       = liftLens to+    lang     = liftLens lang+    sid      = liftLens sid+    payloadT = liftTraversal payloadT++maybeNonempty :: Lens Text (Maybe Text)+maybeNonempty inj x = (maybe Text.empty id)+                      <$> inj (if Text.null x then Nothing else Just x)+++class IsErrorStanza s where+    -- | Error element of the stanza+    stanzaError :: Lens s StanzaError++instance IsErrorStanza IQError where+    stanzaError inj m@IQError{iqErrorStanzaError = i} =+        (\i' -> m{iqErrorStanzaError = i'}) <$> inj i++instance IsErrorStanza MessageError where+    stanzaError inj m@MessageError{messageErrorStanzaError = i} =+        (\i' -> m{messageErrorStanzaError = i'}) <$> inj i++instance IsErrorStanza PresenceError where+    stanzaError inj m@PresenceError{presenceErrorStanzaError = i} =+        (\i' -> m{presenceErrorStanzaError = i'}) <$> inj i++class HasStanzaPayload s p | s -> p where+    -- | Payload element(s) of the stanza. Since the amount of elements possible+    -- in a stanza vary by type, this lens can't be used with a general+    -- 'Stanza'. There is, however, a more general Traversable that works with+    -- all stanzas (including 'Stanza'): 'payloadT'+    payload :: Lens s p++instance HasStanzaPayload IQRequest Element where+    payload inj m@IQRequest{iqRequestPayload = i} =+        (\i' -> m{iqRequestPayload = i'}) <$> inj i++instance HasStanzaPayload IQResult (Maybe Element) where+    payload inj m@IQResult{iqResultPayload = i} =+        (\i' -> m{iqResultPayload = i'}) <$> inj i++instance HasStanzaPayload IQError (Maybe Element) where+    payload inj m@IQError{iqErrorPayload = i} =+        (\i' -> m{iqErrorPayload = i'}) <$> inj i++instance HasStanzaPayload Message [Element] where+    payload inj m@Message{messagePayload = i} =+        (\i' -> m{messagePayload = i'}) <$> inj i++instance HasStanzaPayload MessageError [Element] where+    payload inj m@MessageError{messageErrorPayload = i} =+        (\i' -> m{messageErrorPayload = i'}) <$> inj i++instance HasStanzaPayload Presence [Element] where+    payload inj m@Presence{presencePayload = i} =+        (\i' -> m{presencePayload = i'}) <$> inj i++instance HasStanzaPayload PresenceError [Element] where+    payload inj m@PresenceError{presenceErrorPayload = i} =+        (\i' -> m{presenceErrorPayload = i'}) <$> inj i++iqRequestTypeL :: Lens IQRequest IQRequestType+iqRequestTypeL inj p@IQRequest{iqRequestType = tp} =+    (\tp' -> p{iqRequestType = tp'}) <$> inj tp+++messageTypeL :: Lens Message MessageType+messageTypeL inj p@Message{messageType = tp} =+    (\tp' -> p{messageType = tp'}) <$> inj tp++presenceTypeL :: Lens Presence PresenceType+presenceTypeL inj p@Presence{presenceType = tp} =+    (\tp' -> p{presenceType = tp'}) <$> inj tp+++-- StanzaError+-----------------------++stanzaErrorTypeL :: Lens StanzaError StanzaErrorType+stanzaErrorTypeL inj se@StanzaError{stanzaErrorType = x} =+    (\x' -> se{stanzaErrorType = x'}) <$> inj x++stanzaErrorConditionL :: Lens StanzaError StanzaErrorCondition+stanzaErrorConditionL inj se@StanzaError{stanzaErrorCondition = x} =+    (\x' -> se{stanzaErrorCondition = x'}) <$> inj x++stanzaErrorTextL :: Lens StanzaError (Maybe (Maybe LangTag, NonemptyText))+stanzaErrorTextL inj se@StanzaError{stanzaErrorText = x} =+    (\x' -> se{stanzaErrorText = x'}) <$> inj x++stanzaErrorApplL  :: Lens StanzaError (Maybe Element)+stanzaErrorApplL inj se@StanzaError{stanzaErrorApplicationSpecificCondition = x} =+    (\x' -> se{stanzaErrorApplicationSpecificCondition = x'}) <$> inj x+++-- StreamConfiguration+-----------------------++preferredLangL :: Lens StreamConfiguration (Maybe LangTag)+preferredLangL inj sc@StreamConfiguration{preferredLang = x}+    = (\x' -> sc{preferredLang = x'}) <$> inj x++toJidL :: Lens StreamConfiguration (Maybe (Jid, Bool))+toJidL inj sc@StreamConfiguration{toJid = x}+    = (\x' -> sc{toJid = x'}) <$> inj x++connectionDetailsL :: Lens StreamConfiguration ConnectionDetails+connectionDetailsL inj sc@StreamConfiguration{connectionDetails = x}+    = (\x' -> sc{connectionDetails = x'}) <$> inj x++resolvConfL :: Lens StreamConfiguration ResolvConf+resolvConfL inj sc@StreamConfiguration{resolvConf = x}+    = (\x' -> sc{resolvConf = x'}) <$> inj x++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}+    = (\x' -> sc{tlsBehaviour = x'}) <$> inj x++tlsParamsL :: Lens StreamConfiguration TLSParams+tlsParamsL inj sc@StreamConfiguration{tlsParams = x}+    = (\x' -> sc{tlsParams = x'}) <$> inj x++-- SessioConfiguration+-----------------------+streamConfigurationL :: Lens SessionConfiguration StreamConfiguration+streamConfigurationL inj sc@SessionConfiguration{sessionStreamConfiguration = x}+    = (\x' -> sc{sessionStreamConfiguration = x'}) <$> inj x++onConnectionClosedL :: Lens SessionConfiguration (Session -> XmppFailure -> IO ())+onConnectionClosedL inj sc@SessionConfiguration{onConnectionClosed = x}+    = (\x' -> sc{onConnectionClosed = x'}) <$> inj x++sessionStanzaIDsL :: Lens SessionConfiguration (IO (IO Text))+sessionStanzaIDsL inj sc@SessionConfiguration{sessionStanzaIDs = x}+    = (\x' -> sc{sessionStanzaIDs = x'}) <$> inj x++ensableRosterL :: Lens SessionConfiguration Bool+ensableRosterL inj sc@SessionConfiguration{enableRoster = x}+    = (\x' -> sc{enableRoster = x'}) <$> inj x++pluginsL :: Lens SessionConfiguration [Plugin]+pluginsL inj sc@SessionConfiguration{plugins = x}+    = (\x' -> sc{plugins = x'}) <$> inj x++-- Roster+------------------++verL :: Lens Roster (Maybe Text)+verL inj r@Roster{ver = x} = (\x' -> r{ver = x'}) <$> inj x++itemsL :: Lens Roster (Map.Map Jid Item)+itemsL inj r@Roster{items = x} = (\x' -> r{items = x'}) <$> inj x++-- Item+----------------------++riApprovedL :: Lens Item Bool+riApprovedL inj i@Item{riApproved = x} = (\x' -> i{riApproved = x'}) <$> inj x++riAskL :: Lens Item Bool+riAskL inj i@Item{riAsk = x} = (\x' -> i{riAsk = x'}) <$> inj x++riJidL :: Lens Item Jid+riJidL inj i@Item{riJid = x} = (\x' -> i{riJid = x'}) <$> inj x++riNameL :: Lens Item (Maybe Text)+riNameL inj i@Item{riName = x} = (\x' -> i{riName = x'}) <$> inj x++riSubscriptionL :: Lens Item Subscription+riSubscriptionL inj i@Item{riSubscription = x} =+    (\x' -> i{riSubscription = x'}) <$> inj x++riGroupsL :: Lens Item [Text]+riGroupsL inj i@Item{riGroups = x} = (\x' -> i{riGroups = x'}) <$> inj x+++-- QueryItem+-------------------+qiApprovedL :: Lens QueryItem (Maybe Bool)+qiApprovedL inj i@QueryItem{qiApproved = x} =+    (\x' -> i{qiApproved = x'}) <$> inj x++qiAskL :: Lens QueryItem Bool+qiAskL inj i@QueryItem{qiAsk = x} = (\x' -> i{qiAsk = x'}) <$> inj x++qiJidL :: Lens QueryItem Jid+qiJidL inj i@QueryItem{qiJid = x} = (\x' -> i{qiJid = x'}) <$> inj x++qiNameL :: Lens QueryItem (Maybe Text)+qiNameL inj i@QueryItem{qiName = x} = (\x' -> i{qiName = x'}) <$> inj x++qiSubscriptionL :: Lens QueryItem (Maybe Subscription)+qiSubscriptionL inj i@QueryItem{qiSubscription = x} =+    (\x' -> i{qiSubscription = x'}) <$> inj x++qiGroupsL :: Lens QueryItem [Text]+qiGroupsL inj i@QueryItem{qiGroups = x} = (\x' -> i{qiGroups = x'}) <$> inj x++queryVerL :: Lens Query (Maybe Text)+queryVerL inj i@Query{queryVer = x} = (\x' -> i{queryVer = x'}) <$> inj x++queryItemsL :: Lens Query [QueryItem]+queryItemsL inj i@Query{queryItems = x} = (\x' -> i{queryItems = x'}) <$> inj x+++-- IM+-------------------+++bodyLangL :: Lens MessageBody (Maybe LangTag)+bodyLangL inj m@MessageBody{bodyLang = bl} = (\bl' -> m{bodyLang = bl'}) <$> inj bl++bodyContentL :: Lens MessageBody Text+bodyContentL inj m@MessageBody{bodyContent = bc} =+    (\bc' -> m{bodyContent = bc'}) <$> inj bc++threadIdL :: Lens MessageThread Text+threadIdL inj m@MessageThread{threadID = bc} =+    (\bc' -> m{threadID = bc'}) <$> inj bc++threadParentL :: Lens MessageThread (Maybe Text)+threadParentL inj m@MessageThread{threadParent = bc} =+    (\bc' -> m{threadParent = bc'}) <$> inj bc++subjectLangL :: Lens MessageSubject (Maybe LangTag)+subjectLangL inj m@MessageSubject{subjectLang = bc} =+    (\bc' -> m{subjectLang = bc'}) <$> inj bc++subjectContentL :: Lens MessageSubject Text+subjectContentL inj m@MessageSubject{subjectContent = bc} =+    (\bc' -> m{subjectContent = bc'}) <$> inj bc++imThreadL :: Lens InstantMessage (Maybe MessageThread)+imThreadL inj m@InstantMessage{imThread = bc} =+    (\bc' -> m{imThread = bc'}) <$> inj bc++imSubjectL :: Lens InstantMessage [MessageSubject]+imSubjectL inj m@InstantMessage{imSubject = bc} =+    (\bc' -> m{imSubject = bc'}) <$> inj bc++imBodyL :: Lens InstantMessage [MessageBody]+imBodyL inj m@InstantMessage{imBody = bc} =+    (\bc' -> m{imBody = bc'}) <$> inj bc++-- IM Presence+------------------++showStatusL :: Lens IMPresence (Maybe ShowStatus)+showStatusL inj m@IMP{showStatus = bc} =+    (\bc' -> m{showStatus = bc'}) <$> inj bc++statusL :: Lens IMPresence (Maybe Text)+statusL inj m@IMP{status = bc} =+    (\bc' -> m{status = bc'}) <$> inj bc++priorityL :: Lens IMPresence (Maybe Int)+priorityL inj m@IMP{priority = bc} =+    (\bc' -> m{priority = bc'}) <$> inj bc
source/Network/Xmpp/Marshal.hs view
@@ -1,6 +1,6 @@ -- Picklers and unpicklers convert Haskell data to XML and XML to Haskell data,--- respectively. By convensions, pickler/unpickler ("PU") function names start--- out with "xp".+-- respectively. By convention, pickler/unpickler ("PU") function names start+-- with "xp".  {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-}@@ -17,6 +17,9 @@  import Network.Xmpp.Types +xpNonemptyText :: PU Text NonemptyText+xpNonemptyText = ("xpNonemptyText" , "") <?+> xpWrap Nonempty fromNonempty xpText+ xpStreamStanza :: PU [Node] (Either StreamErrorInfo Stanza) xpStreamStanza = xpEither xpStreamError xpStanza @@ -106,17 +109,83 @@ -- Errors ---------------------------------------------------------- -xpErrorCondition :: PU [Node] StanzaErrorCondition-xpErrorCondition = ("xpErrorCondition" , "") <?+> xpWrap-    (\(cond, (), ()) -> cond)-    (\cond -> (cond, (), ()))+xpStanzaErrorCondition :: PU [Node] StanzaErrorCondition+xpStanzaErrorCondition = ("xpErrorCondition" , "") <?+> xpWrapEither+                   (\(cond, (),cont) -> case (cond, cont) of+                         (Gone _, x) -> Right $ Gone x+                         (Redirect _, x) -> Right $ Redirect x+                         (x , Nothing) -> Right x+                         _ -> Left+                              ("Only Gone and Redirect may have character data"+                                 :: String)+                              )+                   (\x -> case x of+                         (Gone t) -> (Gone Nothing, (),  t)+                         (Redirect t) -> (Redirect Nothing, () , t)+                         c -> (c, (), Nothing))     (xpElemByNamespace         "urn:ietf:params:xml:ns:xmpp-stanzas"-        xpStanzaErrorCondition-        xpUnit+        xpStanzaErrorConditionShape         xpUnit+        (xpOption $ xpContent xpNonemptyText)     )+  where+    -- Create the "shape" of the error condition. In case of Gone and Redirect+    -- the optional field is left empty and must be filled in by the caller+    xpStanzaErrorConditionShape :: PU Text StanzaErrorCondition+    xpStanzaErrorConditionShape = ("xpStanzaErrorCondition", "") <?>+            xpPartial ( \input -> case stanzaErrorConditionFromText input of+                                       Nothing -> Left "Could not parse stanza error condition."+                                       Just j -> Right j)+                      stanzaErrorConditionToText+    stanzaErrorConditionToText BadRequest = "bad-request"+    stanzaErrorConditionToText Conflict = "conflict"+    stanzaErrorConditionToText FeatureNotImplemented = "feature-not-implemented"+    stanzaErrorConditionToText Forbidden = "forbidden"+    stanzaErrorConditionToText (Gone _) = "gone"+    stanzaErrorConditionToText InternalServerError = "internal-server-error"+    stanzaErrorConditionToText ItemNotFound = "item-not-found"+    stanzaErrorConditionToText JidMalformed = "jid-malformed"+    stanzaErrorConditionToText NotAcceptable = "not-acceptable"+    stanzaErrorConditionToText NotAllowed = "not-allowed"+    stanzaErrorConditionToText NotAuthorized = "not-authorized"+    stanzaErrorConditionToText PolicyViolation = "policy-violation"+    stanzaErrorConditionToText RecipientUnavailable = "recipient-unavailable"+    stanzaErrorConditionToText (Redirect _) = "redirect"+    stanzaErrorConditionToText RegistrationRequired = "registration-required"+    stanzaErrorConditionToText RemoteServerNotFound = "remote-server-not-found"+    stanzaErrorConditionToText RemoteServerTimeout = "remote-server-timeout"+    stanzaErrorConditionToText ResourceConstraint = "resource-constraint"+    stanzaErrorConditionToText ServiceUnavailable = "service-unavailable"+    stanzaErrorConditionToText SubscriptionRequired = "subscription-required"+    stanzaErrorConditionToText UndefinedCondition = "undefined-condition"+    stanzaErrorConditionToText UnexpectedRequest = "unexpected-request"+    stanzaErrorConditionFromText "bad-request" = Just BadRequest+    stanzaErrorConditionFromText "conflict" = Just Conflict+    stanzaErrorConditionFromText "feature-not-implemented" = Just FeatureNotImplemented+    stanzaErrorConditionFromText "forbidden" = Just Forbidden+    stanzaErrorConditionFromText "gone" = Just $ Gone Nothing+    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 "policy-violation" = Just PolicyViolation+    stanzaErrorConditionFromText "recipient-unavailable" = Just RecipientUnavailable+    stanzaErrorConditionFromText "redirect" = Just $ Redirect Nothing+    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 ++ xpStanzaError :: PU [Node] StanzaError xpStanzaError = ("xpStanzaError" , "") <?+> xpWrap     (\(tp, (cond, txt, ext)) -> StanzaError tp cond txt ext)@@ -124,10 +193,10 @@     (xpElem "{jabber:client}error"          (xpAttr "type" xpStanzaErrorType)          (xp3Tuple-              xpErrorCondition+              xpStanzaErrorCondition               (xpOption $ xpElem "{jabber:client}text"                    (xpAttrImplied xmlLang xpLang)-                   (xpContent xpId)+                   (xpContent xpNonemptyText)               )               (xpOption xpElemVerbatim)          )@@ -205,7 +274,7 @@               (xpOption $ xpElem                    "{urn:ietf:params:xml:ns:xmpp-streams}text"                    xpLangTag-                   (xpContent xpId)+                   (xpContent xpNonemptyText)               )               (xpOption xpElemVerbatim) -- Application specific error conditions          )@@ -365,58 +434,6 @@     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", "") <?>
source/Network/Xmpp/Sasl.hs view
@@ -102,8 +102,8 @@     case answer of         Right IQResult{iqResultPayload = Just b} -> do             lift $ debugM "Pontarius.Xmpp" "xmppBind: IQ result received; unpickling JID..."-            let jid = unpickleElem xpJid' b-            case jid of+            let j = unpickleElem xpJid' b+            case j of                 Right jid' -> do                     lift $ infoM "Pontarius.Xmpp" $ "Bound JID: " ++ show jid'                     _ <- lift $ withStream ( do modify $ \s ->
source/Network/Xmpp/Sasl/Common.hs view
@@ -139,8 +139,7 @@     r <- lift . pushElement . saslInitE mechanism $         Text.decodeUtf8 . B64.encode <$> payload     case r of-        Right True -> return ()-        Right False -> throwError $ AuthStreamFailure XmppNoStream+        Right () -> return ()         Left e  -> throwError $ AuthStreamFailure e  -- | Pull the next element.@@ -205,8 +204,7 @@     r <- lift . pushElement . saslResponseE . fmap (Text.decodeUtf8 . B64.encode) $ m     case r of         Left e -> throwError $ AuthStreamFailure e-        Right False -> throwError $ AuthStreamFailure XmppNoStream-        Right True -> return ()+        Right () -> return ()  -- | Run the appropriate stringprep profiles on the credentials. -- May fail with 'AuthStringPrepFailure'
source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs view
@@ -107,9 +107,9 @@               ha2 = hash ["AUTHENTICATE", digestURI]           in hash [ha1, nonce, nc, cnonce, qop, ha2] -digestMd5 :: Text -- ^ Authentication identity (authcid or username)-          -> Maybe Text -- ^ Authorization identity (authzid)-          -> Text -- ^ Password+digestMd5 :: Username -- ^ Authentication identity (authcid or username)+          -> Maybe AuthZID -- ^ Authorization identity (authzid)+          -> Password -- ^ Password           -> SaslHandler digestMd5 authcid authzid password =     ( "DIGEST-MD5"
source/Network/Xmpp/Sasl/Mechanisms/Plain.hs view
@@ -44,9 +44,9 @@       where         authzid'' = maybe "" Text.encodeUtf8 authzid' -plain :: Text.Text -- ^ authentication ID (username)-      -> Maybe Text.Text -- ^ authorization ID-      -> Text.Text -- ^ password+plain :: Username -- ^ authentication ID (username)+      -> Maybe AuthZID -- ^ authorization ID+      -> Password -- ^ password       -> SaslHandler plain authcid authzid passwd =     ( "PLAIN"
source/Network/Xmpp/Sasl/Mechanisms/Scram.hs view
@@ -147,9 +147,9 @@                 u1 = hmac str (slt +++ (BS.pack [0,0,0,1]))                 us = iterate (hmac str) u1 -scramSha1 :: Text.Text  -- ^ username-          -> Maybe Text.Text -- ^ authorization ID-          -> Text.Text   -- ^ password+scramSha1 :: Username  -- ^ username+          -> Maybe AuthZID -- ^ authorization ID+          -> Password   -- ^ password           -> SaslHandler scramSha1 authcid authzid passwd =     ( "SCRAM-SHA-1"
source/Network/Xmpp/Sasl/Types.hs view
@@ -6,6 +6,10 @@ import qualified Data.Text as Text import           Network.Xmpp.Types +type Username = Text.Text+type Password = Text.Text+type AuthZID  = Text.Text+ data SaslElement = SaslSuccess   (Maybe Text.Text)                  | SaslChallenge (Maybe Text.Text)
source/Network/Xmpp/Stanza.hs view
@@ -9,25 +9,33 @@  import Data.XML.Types import Network.Xmpp.Types+import Network.Xmpp.Lens  -- | Request subscription with an entity. presenceSubscribe :: Jid -> Presence-presenceSubscribe to = presence { presenceTo = Just to-                                , presenceType = Subscribe-                                }+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-                                 }+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-                                  }+presenceUnsubscribe to' = presence { presenceTo = Just to'+                                   , presenceType = Unsubscribe+                                   } +-- | Deny a not-yet approved or terminate a previously approved subscription of+-- an entity+presenceUnsubscribed :: Jid -> Presence+presenceUnsubscribed to' = presence { presenceTo = Just to'+                                    , presenceType = Unsubscribed+                                    }+ -- | Signal to the server that the client is available for communication. presenceOnline :: Presence presenceOnline = presence@@ -42,15 +50,74 @@ -- 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 =+answerMessage Message{messageFrom = Just frm, ..} payload' =     Just Message{ messageFrom    = Nothing                 , messageID      = Nothing                 , messageTo      = Just frm-                , messagePayload = payload+                , messagePayload = payload'                 , ..                 } answerMessage _ _ = Nothing  -- | Add a recipient to a presence notification. presTo :: Presence -> Jid -> Presence-presTo pres to = pres{presenceTo = Just to}+presTo pres to' = pres{presenceTo = Just to'}++-- | Create a StanzaError with @condition@ and the 'associatedErrorType'. Leave+-- the error text and the application specific condition empty+mkStanzaError :: StanzaErrorCondition -- ^ condition+              -> StanzaError+mkStanzaError condition = StanzaError (associatedErrorType condition)+                                      condition Nothing Nothing++-- | Create an IQ error response to an IQ request using the given condition. The+-- error type is derived from the condition using 'associatedErrorType' and+-- both text and the application specific condition are left empty+iqError :: StanzaErrorCondition -> IQRequest -> IQError+iqError condition (IQRequest iqid from' _to lang' _tp _bd) =+    IQError iqid Nothing from' lang' (mkStanzaError condition) Nothing+++-- | Create an IQ Result matching an IQ request+iqResult ::  Maybe Element -> IQRequest -> IQResult+iqResult pl iqr = IQResult+              { iqResultID   = iqRequestID iqr+              , iqResultFrom = Nothing+              , iqResultTo   = view from iqr+              , iqResultLangTag = view lang iqr+              , iqResultPayload = pl+              }++-- | The RECOMMENDED error type associated with an error condition. The+-- following conditions allow for multiple types+--+-- * 'FeatureNotImplemented': 'Cancel' or 'Modify' (returns 'Cancel')+--+-- * 'PolicyViolation': 'Modify' or 'Wait' ('Modify')+--+-- * 'RemoteServerTimeout': 'Wait' or unspecified other ('Wait')+--+-- * 'UndefinedCondition': Any condition ('Cancel')+associatedErrorType :: StanzaErrorCondition -> StanzaErrorType+associatedErrorType BadRequest            = Modify+associatedErrorType Conflict              = Cancel+associatedErrorType FeatureNotImplemented = Cancel -- Or Modify+associatedErrorType Forbidden             = Auth+associatedErrorType Gone{}                = Cancel+associatedErrorType InternalServerError   = Cancel+associatedErrorType ItemNotFound          = Cancel+associatedErrorType JidMalformed          = Modify+associatedErrorType NotAcceptable         = Modify+associatedErrorType NotAllowed            = Cancel+associatedErrorType NotAuthorized         = Auth+associatedErrorType PolicyViolation       = Modify -- Or Wait+associatedErrorType RecipientUnavailable  = Wait+associatedErrorType Redirect{}            = Modify+associatedErrorType RegistrationRequired  = Auth+associatedErrorType RemoteServerNotFound  = Cancel+associatedErrorType RemoteServerTimeout   = Wait -- Possibly Others+associatedErrorType ResourceConstraint    = Wait+associatedErrorType ServiceUnavailable    = Cancel+associatedErrorType SubscriptionRequired  = Auth+associatedErrorType UndefinedCondition    = Cancel -- This can be anything+associatedErrorType UnexpectedRequest     = Modify
source/Network/Xmpp/Stream.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}  module Network.Xmpp.Stream where @@ -16,7 +17,6 @@ import           Control.Monad import           Control.Monad.Error import           Control.Monad.State.Strict-import           Control.Monad.Trans.Resource as R import           Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC8@@ -44,7 +44,6 @@ import           System.Log.Logger import           System.Random (randomRIO) import           Text.XML.Stream.Parse as XP-import           Text.XML.Unresolved(InvalidEventStream(..))  import           Network.Xmpp.Utilities @@ -65,17 +64,6 @@ 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@@ -89,10 +77,10 @@  -- This is the conduit sink that handles the stream XML events. We extend it -- with ErrorT capabilities.-type StreamSink a = ErrorT XmppFailure (ConduitM Event Void IO) a+type StreamSink a = ConduitM Event Void (ErrorT XmppFailure IO) a  -- Discards all events before the first EventBeginElement.-throwOutJunk :: Monad m => Sink Event m ()+throwOutJunk :: Monad m => ConduitM Event a m () throwOutJunk = do     next <- CL.peek     case next of@@ -103,8 +91,8 @@ -- Returns an (empty) Element from a stream of XML events. openElementFromEvents :: StreamSink Element openElementFromEvents = do-    lift throwOutJunk-    hd <- lift CL.head+    throwOutJunk+    hd <- await     case hd of         Just (EventBeginElement name attrs) -> return $ Element name attrs []         _ -> do@@ -123,26 +111,26 @@     -- state of the stream.     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+          (Plain    , (Just (j, True)))  -> Just j+          (Plain    , _               )  -> Nothing+          (Secured  , (Just (j, _   )))  -> Just j+          (Secured  , Nothing         )  -> Nothing+          (Closed   , _               )  -> Nothing+          (Finished , _               )  -> Nothing     case streamAddress st of         Nothing -> do             lift $ lift $ errorM "Pontarius.Xmpp" "Server sent no hostname."             throwError XmppOtherFailure         Just address -> do-            pushing pushXmlDecl-            pushing . pushOpenElement . streamNSHack $+            ErrorT $ pushXmlDecl+            ErrorT . pushOpenElement . streamNSHack $                 pickleElem xpStream ( "1.0"                                     , expectedTo-                                    , Just (Jid Nothing address Nothing)+                                    , Just (Jid Nothing (Nonempty address) Nothing)                                     , Nothing                                     , preferredLang $ streamConfiguration st                                     )-    response <- ErrorT $ runEventsSink $ runErrorT $ streamS expectedTo+    response <- ErrorT $ runEventsSink $ streamS expectedTo     case response of       Right (ver, from, to, sid, lt, features)         | (Text.unpack ver) /= "1.0" ->@@ -157,7 +145,7 @@      -- 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)) ->+        | isJust from && (from /= Just (Jid Nothing (Nonempty . fromJust $ streamAddress st) Nothing)) ->             closeStreamWithError StreamInvalidFrom Nothing                 "Stream from is invalid"         | to /= expectedTo ->@@ -244,11 +232,15 @@     startStream  -sourceStreamHandle :: MonadIO m => StreamHandle -> ConduitM i ByteString m ()+sourceStreamHandle :: (MonadIO m, MonadError XmppFailure m)+                      => StreamHandle -> ConduitM i ByteString m () sourceStreamHandle s = loopRead $ streamReceive s   where     loopRead rd = do-        bs <- liftIO (rd 4096)+        bs' <- liftIO (rd 4096)+        bs <- case bs' of+            Left e -> throwError e+            Right r -> return r         if BS.null bs             then return ()             else do@@ -260,25 +252,31 @@ -- 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 :: Source (ErrorT XmppFailure IO) o+          -> IO (ConduitM i o (ErrorT XmppFailure IO) ()) 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-                                          )+            dt <- liftIO $ Ex.bracketOnError+                      (atomically $ takeTMVar ref)+                      (\_ -> atomically . putTMVar ref $ zeroResumableSource)+                      (\s -> do+                            res <- runErrorT (s $$++ await)+                            case res of+                                Left e -> do+                                    atomically $ putTMVar ref zeroResumableSource+                                    return $ Left e+                                Right (s',b) -> do+                                    atomically $ putTMVar ref s'+                                    return $ Right b+                      )             case dt of-                Nothing -> return ()-                Just d -> yield d >> go+                Left e -> throwError e+                Right Nothing -> return ()+                Right (Just d) -> yield d >> go     return go-+  where+    zeroResumableSource = DCI.ResumableSource zeroSource (return ())  -- Reads the (partial) stream:stream and the server features from the stream. -- Returns the (unvalidated) stream attributes, the unparsed element, or@@ -302,7 +300,7 @@   where     xmppStreamHeader :: StreamSink (Either Element (Text, Maybe Jid, Maybe Jid, Maybe Text.Text, Maybe LangTag))     xmppStreamHeader = do-        lift throwOutJunk+        throwOutJunk         -- Get the stream:stream element (or whatever it is) from the server,         -- and validate what we get.         el <- openElementFromEvents -- May throw `XmppOtherFailure' if an@@ -312,7 +310,7 @@             Right r -> return $ Right r     xmppStreamFeatures :: StreamSink StreamFeatures     xmppStreamFeatures = do-        e <- lift $ elements =$ CL.head+        e <- elements =$ await         case e of             Nothing -> do                 lift $ lift $ errorM "Pontarius.Xmpp" "streamS: Stream ended."@@ -367,21 +365,22 @@ debugOut outData = liftIO $ debugM "Pontarius.Xmpp"              ("Out: " ++ (Text.unpack . Text.decodeUtf8 $ outData)) -wrapIOException :: IO a -> StateT StreamState IO (Either XmppFailure a)+wrapIOException :: MonadIO m =>+                   IO a -> m (Either XmppFailure a) wrapIOException action = do     r <- liftIO $ tryIOError action     case r of         Right b -> return $ Right b         Left e -> do-            lift $ warningM "Pontarius.Xmpp" $ "wrapIOException: Exception wrapped: " ++ (show e)+            liftIO $ warningM "Pontarius.Xmpp" $ "wrapIOException: Exception wrapped: " ++ (show e)             return $ Left $ XmppIOException e -pushElement :: Element -> StateT StreamState IO (Either XmppFailure Bool)+pushElement :: Element -> StateT StreamState IO (Either XmppFailure ()) pushElement x = do     send <- gets (streamSend . streamHandle)     let outData = renderElement $ nsHack x     debugOut outData-    wrapIOException $ send  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@@ -400,54 +399,47 @@     mapNSHack nd = nd  -- | Encode and send stanza-pushStanza :: Stanza -> Stream -> IO (Either XmppFailure Bool)+pushStanza :: Stanza -> Stream -> IO (Either XmppFailure ()) pushStanza s = withStream' . pushElement $ pickleElem xpStanza s  -- XML documents and XMPP streams SHOULD be preceeded by an XML declaration. -- UTF-8 is the only supported XMPP encoding. The standalone document -- declaration (matching "SDDecl" in the XML standard) MUST NOT be included in -- XMPP streams. RFC 6120 defines XMPP only in terms of XML 1.0.-pushXmlDecl :: StateT StreamState IO (Either XmppFailure Bool)+pushXmlDecl :: StateT StreamState IO (Either XmppFailure ()) pushXmlDecl = do     con <- gets streamHandle-    wrapIOException $ (streamSend con) "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"+    lift $ streamSend con "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>" -pushOpenElement :: Element -> StateT StreamState IO (Either XmppFailure Bool)+pushOpenElement :: Element -> StateT StreamState IO (Either XmppFailure ()) pushOpenElement e = do     send <- gets (streamSend . streamHandle)     let outData = renderOpenElement e     debugOut outData-    wrapIOException $ send outData+    lift $ 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 b+runEventsSink :: Sink Event (ErrorT XmppFailure IO) b+              -> StateT StreamState IO (Either XmppFailure b) runEventsSink snk = do -- TODO: Wrap exceptions?     src <- gets streamEventSource-    r <- liftIO $ src $$ snk-    return  r+    lift . runErrorT $ src $$ snk  pullElement :: StateT StreamState IO (Either XmppFailure Element) pullElement = do-    ExL.catches (do-        e <- runEventsSink (elements =$ await)-        case e of-            Nothing -> do-                lift $ errorM "Pontarius.Xmpp" "pullElement: Stream ended."-                return . Left $ XmppOtherFailure-            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)-                            return . Left $ XmppOtherFailure)-        , ExL.Handler $ \(e :: InvalidEventStream)-                     -> do-                            lift $ errorM "Pontarius.Xmpp" $ "pullElement: Invalid event stream: " ++ (show e)-                            return . Left $ XmppOtherFailure-        ]+    e <- runEventsSink (elements =$ await)+    case e of+        Left l -> do+            liftIO .  errorM "Pontarius.Xmpp" $+                  "Error while retrieving XML element: " ++ show l+            return $ Left l +        Right Nothing -> do+            liftIO $ errorM "Pontarius.Xmpp" "pullElement: Stream ended."+            return . Left $ XmppOtherFailure+        Right (Just r) -> return $ Right r+ -- Pulls an element and unpickles it. pullUnpickle :: PU [Node] a -> StateT StreamState IO (Either XmppFailure a) pullUnpickle p = do@@ -473,21 +465,21 @@  -- Performs the given IO operation, catches any errors and re-throws everything -- except 'ResourceVanished' and IllegalOperation, in which case it will return False instead-catchPush :: IO () -> IO Bool+catchPush :: IO () -> IO (Either XmppFailure ()) catchPush p = ExL.catch-    (p >> return True)+    (p >> return (Right ()))     (\e -> case GIE.ioe_type e of-         GIE.ResourceVanished -> return False-         GIE.IllegalOperation -> return False+         GIE.ResourceVanished -> return . Left $ XmppIOException e+         GIE.IllegalOperation -> return . Left $ XmppIOException e          _ -> ExL.throwIO e     )  zeroHandle :: StreamHandle-zeroHandle = StreamHandle { streamSend = \_ -> return False+zeroHandle = StreamHandle { streamSend = \_ -> return (Left XmppNoStream)                           , streamReceive = \_ -> do                                  errorM "Pontarius.Xmpp"                                         "xmppNoStream: Stream is closed."-                                 ExL.throwIO XmppOtherFailure+                                 return $ Left XmppNoStream                           , streamFlush = return ()                           , streamClose = return ()                           }@@ -507,14 +499,16 @@     , streamConfiguration = def     } -zeroSource :: Source IO output-zeroSource = liftIO $ do-    debugM "Pontarius.Xmpp" "zeroSource"-    ExL.throwIO XmppOtherFailure+zeroSource :: Source (ErrorT XmppFailure IO) a+zeroSource = do+    liftIO $ debugM "Pontarius.Xmpp" "zeroSource"+    throwError XmppNoStream  handleToStreamHandle :: Handle -> StreamHandle-handleToStreamHandle h = StreamHandle { streamSend = \d -> catchPush $ BS.hPut h d-                                      , streamReceive = \n -> BS.hGetSome h n+handleToStreamHandle h = StreamHandle { streamSend = \d ->+                                         wrapIOException $ BS.hPut h d+                                      , streamReceive = \n ->+                                         wrapIOException $ BS.hGetSome h n                                       , streamFlush = hFlush h                                       , streamClose = hClose h                                       }@@ -547,9 +541,9 @@             lift $ debugM "Pontarius.Xmpp" "Did not acquire handle."             throwError TcpConnectionFailure   where-    logConduit :: Conduit ByteString IO ByteString+    logConduit :: MonadIO m => Conduit ByteString m ByteString     logConduit = CL.mapM $ \d -> do-        debugM "Pontarius.Xmpp" $ "In: " ++ (BSC8.unpack d) +++        liftIO . debugM "Pontarius.Xmpp" $ "In: " ++ (BSC8.unpack d) ++             "."         return d @@ -780,7 +774,7 @@        -> Stream        -> IO (Either XmppFailure (Either IQError IQResult)) pushIQ iqID to tp lang body stream = runErrorT $ do-    pushing $ pushStanza+    ErrorT $ pushStanza         (IQRequestS $ IQRequest iqID Nothing to lang tp body) stream     res <- lift $ pullStanza stream     case res of@@ -807,7 +801,7 @@             yield s         Nothing -> return () -elements :: R.MonadThrow m => Conduit Event m Element+elements :: MonadError XmppFailure m => Conduit Event m Element elements = do         x <- await         case x of@@ -816,11 +810,11 @@                                                  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 _) -> lift $ R.monadThrow StreamEnd+            Just (EventEndElement _) -> throwError StreamEndFailure             Just (EventContent (ContentText ct)) | Text.all isSpace ct ->                 elements             Nothing -> return ()-            _ -> lift $ R.monadThrow $ InvalidXmppXml $ "not an element: " ++ show x+            _ -> throwError $ XmppInvalidXml $ "not an element: " ++ show x   where     many' f =         go id@@ -833,9 +827,9 @@     goE n as = do         (y, ns) <- many' goN         if y == Just (EventEndElement n)-            then return $ Element n as $ compressNodes ns-            else lift $ R.monadThrow $ InvalidXmppXml $-                                         "Missing close tag: " ++ show n+            then return $ Element n (map (id >< compressContents) as)+                                    (compressNodes ns)+            else throwError . XmppInvalidXml $ "Missing close tag: " ++ show n     goN = do         x <- await         case x of@@ -852,6 +846,13 @@     compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) =         compressNodes $ NodeContent (ContentText $ x `Text.append` y) : z     compressNodes (x:xs) = x : compressNodes xs++    compressContents :: [Content] -> [Content]+    compressContents cs = [ContentText $ Text.concat (map unwrap cs)]+        where unwrap (ContentText t) = t+              unwrap (ContentEntity t) = t++    (><) f g (x, y) = (f x, g y)  withStream :: StateT StreamState IO a -> Stream -> IO a withStream action (Stream stream) = Ex.bracketOnError
source/Network/Xmpp/Tls.hs view
@@ -34,7 +34,10 @@     bufferReceive recv n = BS.concat `liftM` (go n)       where         go m = do-            bs <- recv m+            mbBs <- recv m+            bs <- case mbBs of+                Left e -> Ex.throwIO e+                Right r -> return r             case BS.length bs of                 0 -> return []                 l -> if l < m@@ -46,9 +49,11 @@  -- | Checks for TLS support and run starttls procedure if applicable tls :: Stream -> IO (Either XmppFailure ())-tls con = Ex.handle (return . Left . TlsError)-                      . flip withStream con-                      . runErrorT $ do+tls con = fmap join -- We can have Left values both from exceptions and the+                    -- error monad. Join unifies them into one error layer+          . wrapExceptions+          . flip withStream con+          . runErrorT $ do     conf <- gets $ streamConfiguration     sState <- gets streamConnectionState     case sState of@@ -77,10 +82,7 @@     startTls = do         liftIO $ infoM "Pontarius.Xmpp.Tls" "Running StartTLS"         params <- gets $ tlsParams . streamConfiguration-        sent <- ErrorT $ pushElement starttlsE-        unless sent $ do-            liftIO $ errorM "Pontarius.Xmpp.Tls" "Could not sent stanza."-            throwError XmppOtherFailure+        ErrorT $ pushElement starttlsE         answer <- lift $ pullElement         case answer of             Left e -> throwError e@@ -95,7 +97,7 @@         hand <- gets streamHandle         (_raw, _snk, psh, recv, ctx) <- lift $ tlsinit params (mkBackend hand)         let newHand = StreamHandle { streamSend = catchPush . psh-                                   , streamReceive = recv+                                   , streamReceive = wrapExceptions . recv                                    , streamFlush = contextFlush ctx                                    , streamClose = bye ctx >> streamClose hand                                    }@@ -109,9 +111,6 @@ client params gen backend  = do     contextNew backend params gen -xmppDefaultParams :: Params-xmppDefaultParams = defaultParamsClient- tlsinit :: (MonadIO m, MonadIO m1) =>         TLSParams      -> Backend@@ -160,7 +159,10 @@  -- | 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+--+-- /NB/ RFC 6120 does not specify this method, but some servers, notably GCS,+-- seem to use it.+connectTls :: ResolvConf -- ^ Resolv conf to use (try 'defaultResolvConf' as a                          -- default)            -> TLSParams  -- ^ TLS parameters to use when securing the connection            -> String     -- ^ Host to use when connecting (will be resolved@@ -173,7 +175,19 @@     let hand = handleToStreamHandle h     (_raw, _snk, psh, recv, ctx) <- tlsinit params $ mkBackend hand     return $ StreamHandle { streamSend = catchPush . psh-                          , streamReceive = recv+                          , streamReceive = wrapExceptions . recv                           , streamFlush = contextFlush ctx                           , streamClose = bye ctx >> streamClose hand                           }++wrapExceptions :: IO a -> IO (Either XmppFailure a)+wrapExceptions f = Ex.catches (liftM Right $ f)+                 [ Ex.Handler $ return . Left . XmppIOException+                 , Ex.Handler $ wrap . XmppTlsError+                 , Ex.Handler $ wrap . XmppTlsConnectionNotEstablished+                 , Ex.Handler $ wrap . XmppTlsTerminated+                 , Ex.Handler $ wrap . XmppTlsHandshakeFailed+                 , Ex.Handler $ return . Left+                 ]+  where+    wrap = return . Left . TlsError
source/Network/Xmpp/Types.hs view
@@ -13,7 +13,10 @@ {-# OPTIONS_HADDOCK hide #-}  module Network.Xmpp.Types-    ( IQError(..)+    ( NonemptyText(..)+    , nonEmpty+    , text+    , IQError(..)     , IQRequest(..)     , IQRequestType(..)     , IQResponse(..)@@ -38,6 +41,7 @@     , StanzaErrorCondition(..)     , StanzaErrorType(..)     , XmppFailure(..)+    , XmppTlsError(..)     , StreamErrorCondition(..)     , Version(..)     , StreamHandle(..)@@ -45,17 +49,19 @@     , StreamState(..)     , ConnectionState(..)     , StreamErrorInfo(..)-    , StanzaHandler     , ConnectionDetails(..)     , StreamConfiguration(..)+    , xmppDefaultParams     , Jid(..) #if WITH_TEMPLATE_HASKELL     , jidQ+    , jid #endif     , isBare     , isFull     , jidFromText     , jidFromTexts+    , (<~)     , nodeprepProfile     , resourceprepProfile     , jidToText@@ -65,22 +71,21 @@     , domainpart     , resourcepart     , parseJid-    , StreamEnd(..)-    , InvalidXmppXml(..)     , TlsBehaviour(..)     , AuthFailure(..)-    )-       where+    ) where -import           Control.Applicative ((<|>), many)+import           Control.Applicative ((<$>), (<|>), many) import           Control.Concurrent.STM import           Control.Exception import           Control.Monad.Error import qualified Data.Attoparsec.Text as AP import qualified Data.ByteString as BS+import           Data.Char (isSpace) import           Data.Conduit import           Data.Default import qualified Data.Set as Set+import           Data.String (IsString, fromString) import           Data.Text (Text) import qualified Data.Text as Text import           Data.Typeable(Typeable)@@ -88,6 +93,7 @@ #if WITH_TEMPLATE_HASKELL import           Language.Haskell.TH import           Language.Haskell.TH.Quote+import qualified Language.Haskell.TH.Syntax as TH #endif import           Network import           Network.DNS@@ -96,6 +102,31 @@ import qualified Text.StringPrep as SP import qualified Text.StringPrep.Profiles as SP ++-- $setup+-- :set -itests+-- >>> :add tests/Tests/Arbitrary.hs+-- >>> import Network.Xmpp.Types+-- >>> import Control.Applicative((<$>))++-- | Type of Texts that contain at least on non-space character+newtype NonemptyText = Nonempty {fromNonempty :: Text}+                       deriving (Show, Read, Eq, Ord)++instance IsString NonemptyText where+    fromString str = case nonEmpty (Text.pack str) of+        Nothing -> error $ "NonemptyText fromString called on empty or " +++                            "all-whitespace string"+        Just r -> r++-- | Check that Text contains at least one non-space character and wrap it+nonEmpty :: Text -> Maybe NonemptyText+nonEmpty txt = if Text.all isSpace txt then Nothing else Just (Nonempty txt)++-- | Same as 'fromNonempty'+text :: NonemptyText -> Text+text (Nonempty txt) = txt+ -- | The Xmpp communication primities (Message, Presence and Info/Query) are -- called stanzas. data Stanza = IQRequestS     !IQRequest@@ -121,10 +152,9 @@ 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.+-- of  type "result" ('IQResult') data IQResponse = IQResponseError IQError                 | IQResponseResult IQResult-                | IQResponseTimeout                 deriving (Eq, Show)  -- | The (non-error) answer to an IQ request.@@ -153,9 +183,17 @@                        , messagePayload :: ![Element]                        } deriving (Eq, Show) -- -- | An empty message+--+-- @+-- message = Message { messageID      = Nothing+--                   , messageFrom    = Nothing+--                   , messageTo      = Nothing+--                   , messageLangTag = Nothing+--                   , messageType    = Normal+--                   , messagePayload = []+--                   }+-- @ message :: Message message = Message { messageID      = Nothing                   , messageFrom    = Nothing@@ -165,6 +203,12 @@                   , messagePayload = []                   } +-- | Empty message stanza+--+-- @messageS = 'MessageS' 'message'@+messageS :: Stanza+messageS = MessageS message+ instance Default Message where     def = message @@ -234,6 +278,10 @@                     , presencePayload  = []                     } +-- | Empty presence stanza+presenceS :: Stanza+presenceS = PresenceS presence+ instance Default Presence where     def = presence @@ -260,13 +308,13 @@                     Unavailable deriving (Eq, Read, Show)  -- | All stanzas (IQ, message, presence) can cause errors, which in the Xmpp--- stream looks like <stanza-kind to='sender' type='error'>. These errors are--- wrapped in the @StanzaError@ type.--- TODO: Sender XML is (optional and is) not yet included.+-- stream looks like @\<stanza-kind to=\'sender\' type=\'error\'\>@ . These+-- errors are wrapped in the @StanzaError@ type.  TODO: Sender XML is (optional+-- and is) not yet included. data StanzaError = StanzaError-    { stanzaErrorType :: StanzaErrorType-    , stanzaErrorCondition :: StanzaErrorCondition-    , stanzaErrorText :: Maybe (Maybe LangTag, Text)+    { stanzaErrorType                         :: StanzaErrorType+    , stanzaErrorCondition                    :: StanzaErrorCondition+    , stanzaErrorText                         :: Maybe (Maybe LangTag, NonemptyText)     , stanzaErrorApplicationSpecificCondition :: Maybe Element     } deriving (Eq, Show) @@ -285,9 +333,9 @@                                                   --   name already exists.                           | FeatureNotImplemented                           | Forbidden             -- ^ Insufficient permissions.-                          | Gone                  -- ^ Entity can no longer be-                                                  --   contacted at this-                                                  --   address.+                          | Gone (Maybe NonemptyText) -- ^ Entity can no longer+                                                      -- be contacted at this+                                                      -- address.                           | InternalServerError                           | ItemNotFound                           | JidMalformed@@ -297,11 +345,16 @@                                                   --   this action.                           | NotAuthorized         -- ^ Must provide proper                                                   --   credentials.-                          | PaymentRequired+                          | PolicyViolation       -- ^ The entity has violated+                                                  -- some local service policy+                                                  -- (e.g., a message contains+                                                  -- words that are prohibited+                                                  -- by the service)                           | RecipientUnavailable  -- ^ Temporarily unavailable.-                          | Redirect              -- ^ Redirecting to other-                                                  --   entity, usually-                                                  --   temporarily.+                          | Redirect (Maybe NonemptyText) -- ^ Redirecting to+                                                          -- other entity,+                                                          -- usually+                                                          -- temporarily.                           | RegistrationRequired                           | RemoteServerNotFound                           | RemoteServerTimeout@@ -396,7 +449,7 @@                              -- 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+                             -- something other than \"jabber:client\" or                              -- \"jabber:server\").     | StreamInvalidXml -- ^ The entity has sent invalid XML over the stream to a                        -- server that performs validation@@ -421,8 +474,8 @@                                    -- not to be used when the cause of the error                                    -- is within the administrative domain of the                                    -- XMPP service provider, in which case the-                                   -- <internal-server-error/> condition is more-                                   -- appropriate.+                                   -- \<internal-server-error /\> condition is+                                   -- more appropriate.     | StreamReset -- ^ The server is closing the stream because it has new                   -- (typically security-critical) features to offer, because                   -- the keys or certificates used to establish a secure context@@ -474,10 +527,16 @@ -- | Encapsulates information about an XMPP stream error. data StreamErrorInfo = StreamErrorInfo     { errorCondition :: !StreamErrorCondition-    , errorText      :: !(Maybe (Maybe LangTag, Text))+    , errorText      :: !(Maybe (Maybe LangTag, NonemptyText))     , errorXml       :: !(Maybe Element)     } deriving (Show, Eq) +data XmppTlsError = XmppTlsError TLSError+                  | XmppTlsConnectionNotEstablished ConnectionNotEstablished+                  | XmppTlsTerminated Terminated+                  | XmppTlsHandshakeFailed HandshakeFailed+                    deriving (Show, Eq, Typeable)+ -- | Signals an XMPP stream error or another unpredicted stream-related -- situation. This error is fatal, and closes the XMPP stream. data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream@@ -499,7 +558,7 @@                                         -- failed.                  | XmppIllegalTcpDetails -- ^ The TCP details provided did not                                          -- validate.-                 | TlsError TLSError -- ^ An error occurred in the+                 | TlsError XmppTlsError -- ^ An error occurred in the                                      -- TLS layer                  | TlsNoServerSupport -- ^ The server does not support                                       -- the use of TLS@@ -514,6 +573,7 @@                                     -- the log.                  | XmppIOException IOException -- ^ An 'IOException'                                                -- occurred+                 | XmppInvalidXml String -- ^ Received data is not valid XML                  deriving (Show, Eq, Typeable)  instance Exception XmppFailure@@ -628,7 +688,7 @@                                             -- non-standard "optional" element                                             -- (observed with prosody).     , streamOtherFeatures  :: ![Element] -- TODO: All feature elements instead?-    } deriving Show+    } deriving (Eq, Show)  -- | Signals the state of the stream connection. data ConnectionState@@ -641,9 +701,10 @@ -- | Defines operations for sending, receiving, flushing, and closing on a -- stream. data StreamHandle =-    StreamHandle { streamSend :: BS.ByteString -> IO Bool -- ^ Sends may not+    StreamHandle { streamSend :: BS.ByteString+                                 -> IO (Either XmppFailure ()) -- ^ Sends may not                                                           -- interleave-                 , streamReceive :: Int -> IO BS.ByteString+                 , streamReceive :: Int -> IO (Either XmppFailure BS.ByteString)                    -- This is to hold the state of the XML parser (otherwise we                    -- will receive EventBeginDocument events and forget about                    -- name prefixes). (TODO: Clarify)@@ -657,7 +718,7 @@       -- | Functions to send, receive, flush, and close the stream     , streamHandle :: StreamHandle       -- | Event conduit source, and its associated finalizer-    , streamEventSource :: Source IO Event+    , streamEventSource :: Source (ErrorT XmppFailure IO) Event       -- | Stream features advertised by the server     , streamFeatures :: !StreamFeatures -- TODO: Maybe?       -- | The hostname or IP specified for the connection@@ -717,22 +778,37 @@ -- (e.g., an occupant in a multi-user chat room) belonging to -- the entity associated with an XMPP localpart at a domain -- (i.e., @localpart\@domainpart/resourcepart@).+--+-- For more details see RFC 6122 <http://xmpp.org/rfcs/rfc6122.html> -data Jid = Jid { localpart_ :: !(Maybe Text)-               , domainpart_ :: !Text-               , resourcepart_ :: !(Maybe Text)+data Jid = Jid { localpart_    :: !(Maybe NonemptyText)+               , domainpart_   :: !NonemptyText+               , resourcepart_ :: !(Maybe NonemptyText)                } deriving (Eq, Ord)  -- | Converts a JID to a Text. jidToText :: Jid -> Text-jidToText (Jid nd dmn res) =-    Text.pack $ (maybe "" ((++ "@") . Text.unpack) nd) ++ (Text.unpack dmn) ++-        maybe "" (('/' :) . Text.unpack) res+jidToText (Jid nd dmn res) = Text.concat . concat $+                             [ maybe [] (:["@"]) (text <$> nd)+                             , [text dmn]+                             , maybe [] (\r -> ["/",r]) (text <$> res)+                             ]  -- | Converts a JID to up to three Text values: (the optional) localpart, the -- domainpart, and (the optional) resourcepart.+--+-- >>> jidToTexts [jid|foo@bar/quux|]+-- (Just "foo","bar",Just "quux")+--+-- >>> jidToTexts [jid|bar/quux|]+-- (Nothing,"bar",Just "quux")+--+-- >>> jidToTexts [jid|foo@bar|]+-- (Just "foo","bar",Nothing)+--+-- prop> jidToTexts j == (localpart j, domainpart j, resourcepart j) jidToTexts :: Jid -> (Maybe Text, Text, Maybe Text)-jidToTexts (Jid nd dmn res) = (nd, dmn, res)+jidToTexts (Jid nd dmn res) = (text <$> nd, text dmn, text <$> res)  -- Produces a Jid value in the format "parseJid \"<jid>\"". instance Show Jid where@@ -757,33 +833,65 @@                                             -- or the `parseJid' error message (see below)  #if WITH_TEMPLATE_HASKELL--- | Constructs a @Jid@ value at compile time.++instance TH.Lift Jid where+    lift (Jid lp dp rp) = [| Jid $(mbTextE $ text <$> lp)+                                 $(textE   $ text dp)+                                 $(mbTextE $ text <$> rp)+                           |]+     where+        textE t = [| Nonempty $ Text.pack $(stringE $ Text.unpack t) |]+        mbTextE Nothing = [| Nothing |]+        mbTextE (Just s) = [| Just $(textE s) |]++-- | Constructs and validates a @Jid@ at compile time. -- -- Syntax: -- @---     [jidQ|localpart\@domainpart/resourcepart|]+--     [jid|localpart\@domainpart/resourcepart|] -- @-jidQ :: QuasiQuoter-jidQ = QuasiQuoter { quoteExp = \s -> do+--+-- >>> [jid|foo@bar/quux|]+-- parseJid "foo@bar/quux"+--+-- >>> Just [jid|foo@bar/quux|] == jidFromTexts (Just "foo") "bar" (Just "quux")+-- True+--+-- >>> Just [jid|foo@bar/quux|] == jidFromText "foo@bar/quux"+-- True+--+-- See also 'jidFromText'+jid :: QuasiQuoter+jid = QuasiQuoter { quoteExp = \s -> do                           when (head s == ' ') . fail $ "Leading whitespaces in JID" ++ show s                           let t = Text.pack s                           when (Text.last t == ' ') . reportWarning $ "Trailing whitespace in JID " ++ show s                           case jidFromText t of                               Nothing -> fail $ "Could not parse JID " ++ s-                              Just j -> [| Jid $(mbTextE $ localpart_ j)-                                               $(textE   $ domainpart_ j)-                                               $(mbTextE $ resourcepart_ j)-                                        |]+                              Just j -> TH.lift 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) |]++-- | Synonym for 'jid'+jidQ :: QuasiQuoter+jidQ = jidQ #endif +-- | The partial order of "definiteness". JID1 is less than or equal JID2 iff+-- the domain parts are equal and JID1's local part and resource part each are+-- either Nothing or equal to Jid2's+(<~) :: Jid -> Jid -> Bool+(Jid lp1 dp1 rp1) <~ (Jid lp2 dp2 rp2) =+    dp1 ==  dp2 &&+    lp1 ~<~ lp2 &&+    rp1 ~<~ rp2+  where+   Nothing  ~<~ _ = True+   Just x  ~<~ Just y = x == y+   _  ~<~ _ = False+ -- Produces a LangTag value in the format "parseLangTag \"<jid>\"". instance Show LangTag where   show l = "parseLangTag " ++ show (langTagToText l)@@ -837,7 +945,45 @@                  Just j -> j                  Nothing -> error $ "Jid value (" ++ s ++ ") did not validate" --- | Converts a Text to a JID.+-- | Parse a JID+--+-- >>> localpart <$> jidFromText "foo@bar/quux"+-- Just (Just "foo")+--+-- >>> domainpart <$> jidFromText "foo@bar/quux"+-- Just "bar"+--+-- >>> resourcepart <$> jidFromText "foo@bar/quux"+-- Just (Just "quux")+--+-- * Counterexamples+--+-- A JID must only have one \'\@\':+--+-- >>> jidFromText "foo@bar@quux"+-- Nothing+--+-- \'\@\' must come before \'/\':+--+-- >>> jidFromText "foo/bar@quux"+-- Nothing+--+-- The domain part can\'t be empty:+--+-- >>> jidFromText "foo@/quux"+-- Nothing+--+-- Both the local part and the resource part can be omitted (but the+-- \'\@\' and \'\/\', must also be removed):+--+-- >>> jidToTexts <$> jidFromText "bar"+-- Just (Nothing,"bar",Nothing)+--+-- >>> jidToTexts <$> jidFromText "@bar"+-- Nothing+--+-- >>> jidToTexts <$> jidFromText "bar/"+-- Nothing jidFromText :: Text -> Maybe Jid jidFromText t = do     (l, d, r) <- eitherToMaybe $ AP.parseOnly jidParts t@@ -845,8 +991,13 @@   where     eitherToMaybe = either (const Nothing) Just --- | Converts localpart, domainpart, and resourcepart strings to a JID. Runs the+-- | Convert localpart, domainpart, and resourcepart to a JID. Runs the -- appropriate stringprep profiles and validates the parts.+--+-- >>> jidFromTexts (Just "foo") "bar" (Just "baz") == jidFromText "foo@bar/baz"+-- True+--+-- prop> jidFromTexts (localpart j) (domainpart j) (resourcepart j) == Just j jidFromTexts :: Maybe Text -> Text -> Maybe Text -> Maybe Jid jidFromTexts l d r = do     localPart <- case l of@@ -856,92 +1007,100 @@             guard $ validPartLength l''             let prohibMap = Set.fromList nodeprepExtraProhibitedCharacters             guard $ Text.all (`Set.notMember` prohibMap) l''-            return $ Just l''-    domainPart <- SP.runStringPrep (SP.namePrepProfile False) d-    guard $ validDomainPart domainPart+            l''' <- nonEmpty l''+            return $ Just l'''+    domainPart' <- SP.runStringPrep (SP.namePrepProfile False) d+    guard $ validDomainPart domainPart'+    domainPart <- nonEmpty domainPart'     resourcePart <- case r of         Nothing -> return Nothing         Just r' -> do             r'' <- SP.runStringPrep resourceprepProfile r'             guard $ validPartLength r''-            return $ Just r''+            r''' <- nonEmpty r''+            return $ Just r'''     return $ Jid localPart domainPart resourcePart   where     validDomainPart :: Text -> Bool-    validDomainPart _s = True -- TODO+    validDomainPart s = not $ Text.null s -- TODO: implement more stringent+                                          -- checks      validPartLength :: Text -> Bool     validPartLength p = Text.length p > 0 && Text.length p < 1024 --- | Returns 'True' if the JID is /bare/, and 'False' otherwise.+-- | Returns 'True' if the JID is /bare/, that is, it doesn't have a resource+-- part, and 'False' otherwise.+--+-- >>> isBare [jid|foo@bar|]+-- True+--+-- >>> isBare [jid|foo@bar/quux|]+-- False isBare :: Jid -> Bool isBare j | resourcepart j == Nothing = True          | otherwise                 = False  -- | Returns 'True' if the JID is /full/, and 'False' otherwise.+--+-- @isFull = not . isBare@+--+-- >>> isBare [jid|foo@bar|]+-- True+--+-- >>> isBare [jid|foo@bar/quux|]+-- False isFull :: Jid -> Bool isFull = not . isBare  -- | Returns the @Jid@ without the resourcepart (if any).+--+-- >>> toBare [jid|foo@bar/quux|] == [jid|foo@bar|]+-- True toBare :: Jid -> Jid toBare j  = j{resourcepart_ = Nothing}  -- | Returns the localpart of the @Jid@ (if any).+--+-- >>> localpart [jid|foo@bar/quux|]+-- Just "foo" localpart :: Jid -> Maybe Text-localpart = localpart_+localpart = fmap text . localpart_  -- | Returns the domainpart of the @Jid@.+--+-- >>> domainpart [jid|foo@bar/quux|]+-- "bar" domainpart :: Jid -> Text-domainpart = domainpart_+domainpart = text . domainpart_  -- | Returns the resourcepart of the @Jid@ (if any).+--+-- >>> resourcepart [jid|foo@bar/quux|]+-- Just "quux" resourcepart :: Jid -> Maybe Text-resourcepart = resourcepart_+resourcepart = fmap text . resourcepart_ --- Parses an JID string and returns its three parts. It performs no validation--- or transformations.+-- | Parse the parts of a JID. The parts need to be validated with stringprep+-- before the JID can be constructed jidParts :: AP.Parser (Maybe Text, Text, Maybe Text) jidParts = do-    -- Read until we reach an '@', a '/', or EOF.-    a <- AP.takeWhile1 (AP.notInClass ['@', '/'])-    -- Case 1: We found an '@', and thus the localpart. At least the domainpart-    -- is remaining. Read the '@' and until a '/' or EOF.-    do-        b <- domainPartP-        -- Case 1A: We found a '/' and thus have all the JID parts. Read the '/'-        -- and until EOF.-        do-            c <- resourcePartP -- Parse resourcepart-            return (Just a, b, Just c)-        -- Case 1B: We have reached EOF; the JID is in the form-        -- localpart@domainpart.-            <|> do-                AP.endOfInput-                return (Just a, b, Nothing)-          -- Case 2: We found a '/'; the JID is in the form-          -- domainpart/resourcepart.-          <|> do-              b' <- resourcePartP-              AP.endOfInput-              return (Nothing, a, Just b')-          -- Case 3: We have reached EOF; we have an JID consisting of only a-          -- domainpart.-        <|> do-            AP.endOfInput-            return (Nothing, a, Nothing)+    maybeLocalPart <- Just <$> localPart <|> return Nothing+    domainPart <- AP.takeWhile1 (AP.notInClass ['@', '/'])+    maybeResourcePart <- Just <$> resourcePart <|> return Nothing+    AP.endOfInput+    return (maybeLocalPart, domainPart, maybeResourcePart)   where-    -- Read an '@' and everything until a '/'.-    domainPartP :: AP.Parser Text-    domainPartP = do+    localPart = do+        bytes <- AP.takeWhile1 (AP.notInClass ['@', '/'])         _ <- AP.char '@'-        AP.takeWhile1 (/= '/')-    -- Read everything until a '/'.-    resourcePartP :: AP.Parser Text-    resourcePartP = do+        return bytes+    resourcePart = do         _ <- AP.char '/'-        AP.takeText+        AP.takeWhile1 (AP.notInClass ['@', '/']) --- The `nodeprep' StringPrep profile.+++-- | The `nodeprep' StringPrep profile. nodeprepProfile :: SP.StringPrepProfile nodeprepProfile = SP.Profile { SP.maps = [SP.b1, SP.b2]                              , SP.shouldNormalize = True@@ -961,12 +1120,12 @@                              , SP.shouldCheckBidi = True                              } --- These characters needs to be checked for after normalization.+-- | These characters needs to be checked for after normalization. nodeprepExtraProhibitedCharacters :: [Char] nodeprepExtraProhibitedCharacters = ['\x22', '\x26', '\x27', '\x2F', '\x3A',                                      '\x3C', '\x3E', '\x40'] --- The `resourceprep' StringPrep profile.+-- | The `resourceprep' StringPrep profile. resourceprepProfile :: SP.StringPrepProfile resourceprepProfile = SP.Profile { SP.maps = [SP.b1]                                  , SP.shouldNormalize = True@@ -984,18 +1143,17 @@                                                    ]                                  , SP.shouldCheckBidi = True                                  }--data StreamEnd = StreamEnd deriving (Typeable, Show)-instance Exception StreamEnd--data InvalidXmppXml = InvalidXmppXml String deriving (Show, Typeable)--instance Exception InvalidXmppXml--data ConnectionDetails = UseRealm -- ^ Use realm to resolv host+-- | Specify the method with which the connection is (re-)established+data ConnectionDetails = UseRealm -- ^ Use realm to resolv host. This is the+                                  -- default.                        | UseSrv HostName -- ^ Use this hostname for a SRV lookup                        | UseHost HostName PortID -- ^ Use specified host                        | UseConnection (ErrorT XmppFailure IO StreamHandle)+                         -- ^ Use custom method to create a StreamHandle. This+                         -- will also be used by reconnect. For example, to+                         -- establish TLS before starting the stream as done by+                         -- GCM, see 'connectTls'. You can also return an+                         -- already established connection.  -- | Configuration settings related to the stream. data StreamConfiguration =@@ -1024,22 +1182,23 @@                         , tlsParams :: TLSParams                         } +-- | Default parameters for TLS. Those are the default client parameters from the tls package with the ciphers set to ciphersuite_strong+xmppDefaultParams :: Params+xmppDefaultParams = defaultParamsClient{ pCiphers = ciphersuite_strong+                                                    ++ [ cipher_AES256_SHA1+                                                       , cipher_AES128_SHA1+                                                       ]+                                       }+ instance Default StreamConfiguration where-    def = StreamConfiguration { preferredLang = Nothing-                              , toJid = Nothing+    def = StreamConfiguration { preferredLang     = Nothing+                              , toJid             = Nothing                               , connectionDetails = UseRealm-                              , resolvConf = defaultResolvConf-                              , establishSession = True-                              , tlsBehaviour = PreferTls-                              , tlsParams = defaultParamsClient { pConnectVersion = TLS10-                                                                , pAllowedVersions = [TLS10, TLS11, TLS12]-                                                                , pCiphers = ciphersuite_strong-                                                                }+                              , resolvConf        = defaultResolvConf+                              , establishSession  = True+                              , tlsBehaviour      = PreferTls+                              , tlsParams         = xmppDefaultParams                               }--type StanzaHandler =  TMVar (BS.ByteString -> IO Bool) -- ^ outgoing stanza-                   -> Stanza       -- ^ stanza to handle-                   -> IO Bool      -- ^ True when processing should continue  -- | How the client should behave in regards to TLS. data TlsBehaviour = RequireTls -- ^ Require the use of TLS; disconnect if it's
source/Network/Xmpp/Utilities.hs view
@@ -1,7 +1,6 @@+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}--  module Network.Xmpp.Utilities     ( openElementToEvents
+ tests/Doctest.hs view
@@ -0,0 +1,40 @@+-- pilfered from lens package++module Main(main) where++import Build_doctest (deps)++import Control.Applicative+import Control.Monad+import Data.List+import System.Directory+import System.FilePath+import Test.DocTest++main :: IO ()+main = doctest $+    "-isource"+  : "-itests"+  : "-idist/build/autogen"+  : "-hide-all-packages"+  : "-XQuasiQuotes"+  : "-XOverloadedStrings"+  : "-DWITH_TEMPLATE_HASKELL"+  : "-optP-includedist/build/autogen/cabal_macros.h"+  : map ("-package="++) deps+    ++ sources++sources :: [String]+sources = ["Network.Xmpp.Types"] -- ["source/Network/Xmpp/Types.hs"]++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "source"+  where+    go dir = do+      (dirs, files) <- getFilesAndDirectories dir+      (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+  c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+  (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
+ tests/Main.hs view
@@ -0,0 +1,11 @@+module Main where++import Test.Tasty++import Tests.Parsers+import Tests.Picklers++main :: IO ()+main = defaultMain $ testGroup "root" [ parserTests+                                      , picklerTests+                                      ]
+ tests/Tests/Arbitrary.hs view
@@ -0,0 +1,6 @@+module Tests.Arbitrary  where++import Tests.Arbitrary.Xml ()+import Tests.Arbitrary.Xmpp ()++-- $derive makeArbitrary IQRequestType
+ tests/Tests/Arbitrary/Xml.hs view
@@ -0,0 +1,85 @@+module Tests.Arbitrary.Xml where++import           Control.Applicative ((<$>), (<*>))+import           Test.QuickCheck+import           Test.QuickCheck.Instances()+-- import Data.DeriveTH+import qualified Data.Text as Text+import           Data.XML.Types+import           Tests.Arbitrary.Common+import           Text.CharRanges+++selectFromRange :: Range -> Gen Char+selectFromRange (Single a) = return a+selectFromRange (Range a b) = choose (a, b)++nameStartChar :: [Range]+nameStartChar =+    [ -- Single ':'+      Single '_'+    , Range 'A' 'Z'+    , Range 'a' 'z'+    , Range '\xC0' '\xD6'+    , Range '\xD8' '\xF6'+    , Range '\xF8' '\x2FF'+    , Range '\x370' '\x37D'+    , Range '\x37F' '\x1FFF'+    , Range '\x200C' '\x200D'+    , Range '\x2070' '\x218F'+    , Range '\x2C00' '\x2FEF'+    , Range '\x3001' '\xD7FF'+    , Range '\xF900' '\xFDCF'+    , Range '\xFDF0' '\xFFFD'+    , Range '\x10000' '\xEFFFF'+    ]++nameChar :: [Range]+nameChar =+      Single '-'+    : Single '.'+    : Single '\xB7'+    : Range '0' '9'+    : Range '\x0300' '\x036F'+    : Range '\x203F' '\x2040'+    : nameStartChar+++genNCName :: Gen Text.Text+genNCName = do+    sc <- elements nameStartChar >>= selectFromRange+    ncs <- listOf $ elements nameChar >>= selectFromRange+    return . Text.pack $ sc:ncs++-- | Cap the size of child elements.+slow :: Gen a -> Gen a+slow g = sized $ \n -> resize (min 5 (n `div` 4))  g++instance Arbitrary Name where+    arbitrary = Name <$> genNCName <*> genMaybe genNCName <*> genMaybe genNCName+      where+        genMaybe g = oneof [return Nothing, Just <$> g]+    shrink (Name a b c) = [ Name a' b c | a' <- shrinkText1 a]+                        ++[ Name a b' c | b' <- shrinkTextMaybe b]+                        ++[ Name a b c' | c' <- shrinkTextMaybe c]++instance Arbitrary Content where+    arbitrary = ContentText <$> arbitrary+    shrink (ContentText txt) = ContentText <$> shrinkText1 txt+    shrink _ = []+++instance Arbitrary Node where+    arbitrary = oneof [ NodeElement <$> arbitrary+                      , NodeContent <$> arbitrary+                      ]+    shrink (NodeElement e) = NodeElement <$> shrink e+    shrink (NodeContent c) = NodeContent <$> shrink c+    shrink _ = []++instance Arbitrary Element where+    arbitrary = Element <$> arbitrary <*> slow arbitrary <*> slow arbitrary+    shrink (Element a b c) =+          [ Element a' b c | a' <- shrink a]+        ++[ Element a b' c | b' <- shrink b]+        ++[ Element a b c' | c' <- shrink c]
+ tests/Tests/Arbitrary/Xmpp.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE TemplateHaskell #-}+module Tests.Arbitrary.Xmpp where++import           Control.Applicative ((<$>), (<*>))+import           Data.Char+import           Data.Maybe+import qualified Data.Text as Text+import           Network.Xmpp.Types+import           Test.QuickCheck+import           Test.QuickCheck.Instances()+import qualified Text.CharRanges as Ranges+import qualified Text.StringPrep as SP+import qualified Text.StringPrep.Profiles as SP++import           Tests.Arbitrary.Common+import           Tests.Arbitrary.Xml ()++import           Data.Derive.Arbitrary+import           Data.DeriveTH+++instance Arbitrary NonemptyText where+    arbitrary = Nonempty . Text.pack <$> listOf1+                  (arbitrary `suchThat` (not . isSpace))+    shrink (Nonempty txt) = map Nonempty+                            . filter (not . Text.all isSpace) $ shrink txt++instance Arbitrary Jid where+    arbitrary = do+        Just jid <- tryJid `suchThat` isJust+        return jid+      where+        tryJid = jidFromTexts <$> maybeGen (genString nodeprepProfile)+                              <*> genString (SP.namePrepProfile False)+                              <*> maybeGen (genString resourceprepProfile)++        genString profile = 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` "@/"++    shrink (Jid lp dp rp) = [ Jid lp' dp  rp  | lp' <- shrinkMaybe shrink lp]+                         ++ [ Jid lp  dp' rp  | dp' <- shrink dp]+                         ++ [ Jid lp  dp  rp' | rp' <- shrinkMaybe shrink rp]+++string :: SP.StringPrepProfile -> Gen [Char]+string profile = take 1024 <$> listOf1 genChar+  where+    genChar = arbitrary `suchThat` (not . isProhibited)+    prohibited = Ranges.toSet $ concat (SP.prohibited profile)+    isProhibited x = Ranges.member x prohibited+                     || x `elem` "@/"++instance Arbitrary LangTag where+    arbitrary = LangTag <$> genTag <*> listOf genTag+        where genTag = fmap Text.pack . listOf1 . elements $ ['a'..'z'] ++ ['A'..'Z']+    shrink (LangTag lt lts) = [LangTag lt' lts | lt' <- shrinkText1 lt] +++                              [LangTag lt lts' | lts' <- filter (not . Text.null)+                                                         <$> shrink lts]++-- Auto-derive trivial instances+concat <$> mapM (derive makeArbitrary) [ ''StanzaErrorType+                                       , ''StanzaErrorCondition+                                       , ''StanzaError+                                       , ''StreamErrorInfo+                                       , ''IQRequestType+                                       , ''IQRequest+                                       , ''IQResult+                                       , ''IQError+                                       , ''MessageType+                                       , ''Message+                                       , ''MessageError+                                       , ''PresenceType+                                       , ''Presence+                                       , ''PresenceError+                                       , ''Stanza++                                       , ''SaslError+                                       , ''SaslFailure+                                       , ''StreamErrorCondition++                                       -- , ''HandshakeFailed+                                       -- , ''XmppTlsError+--                                       , ''AuthFailure+                                       , ''Version+                                       , ''ConnectionState+                                       , ''TlsBehaviour+                                       ]