pontarius-xmpp 0.4.0.2 → 0.4.1.0

raw patch · 24 files changed

+1034/−320 lines, 24 filesdep +HUnitdep +configuratordep +exceptionsdep ~basedep ~hsloggerdep ~mtlnew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: HUnit, configurator, exceptions, lens-family, profunctors, x509-system

Dependency ranges changed: base, hslogger, mtl, network, stm, text, tls, transformers, xml-picklers, xml-types

API changes (from Hackage documentation)

Files

• pontarius-xmpp.cabal +37/−10
• source/Network/Xmpp.hs +6/−0
• source/Network/Xmpp/Concurrent.hs +25/−14
• source/Network/Xmpp/Concurrent/Basic.hs +7/−0
• source/Network/Xmpp/Concurrent/IQ.hs +91/−13
• source/Network/Xmpp/Concurrent/Presence.hs +13/−3
• source/Network/Xmpp/Concurrent/Threads.hs +3/−8
• source/Network/Xmpp/Concurrent/Types.hs +19/−1
• source/Network/Xmpp/IM.hs +9/−0
• source/Network/Xmpp/IM/Presence.hs +8/−7
• source/Network/Xmpp/IM/PresenceTracker.hs +110/−0
• source/Network/Xmpp/IM/PresenceTracker/Types.hs +20/−0
• source/Network/Xmpp/IM/Roster.hs +72/−46
• source/Network/Xmpp/Internal.hs +47/−32
• source/Network/Xmpp/Lens.hs +179/−27
• source/Network/Xmpp/Marshal.hs +122/−102
• source/Network/Xmpp/Sasl/Common.hs +19/−17
• source/Network/Xmpp/Stanza.hs +3/−2
• source/Network/Xmpp/Stream.hs +23/−13
• source/Network/Xmpp/Tls.hs +21/−11
• source/Network/Xmpp/Types.hs +68/−13
• tests/Run.hs +14/−0
• tests/Run/Payload.hs +117/−0
• tests/Tests/Arbitrary/Xmpp.hs +1/−1

@@ -1,5 +1,5 @@ Name:          pontarius-xmpp-Version:       0.4.0.2+Version:       0.4.1.0 Cabal-Version: >= 1.9.2 Build-Type:    Custom License:       BSD3@@ -36,11 +36,6 @@ Library   hs-source-dirs: source   Exposed: True--  -- The only different between the below two blocks is that the first one caps-  -- the range for the `bytestring' package, and that the second one includes-  -- `template-haskell' for GHC 7.6.1 and above.-   Build-Depends: attoparsec           >=0.10.0.3                , base                 >4 && <5                , base64-bytestring    >=0.1.0.0@@ -53,25 +48,29 @@                , cryptohash-cryptoapi >=0.1                , data-default         >=0.2                , dns                  >=0.3.0+               , exceptions >= 0.6                , hslogger             >=1.1.0                , iproute              >=1.2.4+               , lens-family                , lifted-base          >=0.1.0.1                , mtl                  >=2.0.0.0                , network              >=2.3.1.0+               , profunctors          >= 4                , pureMD5              >=2.1.2.1-               , resourcet            >=0.3.0                , random               >=1.0.0.0+               , resourcet            >=0.3.0                , split                >=0.1.2.3-               , stm                  >=2.1.2.1+               , stm                  >=2.4                , stringprep           >=1.0.0                , text                 >=0.11.1.5                , tls                  >=1.2-               , transformers         >=0.2.2.0+               , transformers         >=0.3                , unbounded-delays     >=0.1                , void                 >=0.5.5-               , xml-types            >=0.3.1+               , x509-system          >=1.4                , xml-conduit          >=1.1.0.7                , xml-picklers         >=0.3.3+               , xml-types            >=0.3.1    If impl(ghc ==7.0.1) {     Build-Depends: bytestring         >=0.9.1.9 && <=0.9.2.1@@ -95,8 +94,11 @@                  , Network.Xmpp.Concurrent.Types                  , Network.Xmpp.IM.Message                  , Network.Xmpp.IM.Presence+                 , Network.Xmpp.IM.PresenceTracker                  , Network.Xmpp.IM.Roster                  , Network.Xmpp.IM.Roster.Types+                 , Network.Xmpp.IM.PresenceTracker+                 , Network.Xmpp.IM.PresenceTracker.Types                  , Network.Xmpp.Marshal                  , Network.Xmpp.Sasl                  , Network.Xmpp.Sasl.Common@@ -166,6 +168,31 @@                , QuickCheck                , derive                , quickcheck-instances++Test-Suite runtests+  Type: exitcode-stdio-1.0+  hs-source-dirs: tests+  main-is: Run.hs+  other-modules: Run.Payload+  GHC-Options: -Wall -threaded+  Build-Depends: base+               , HUnit+               , configurator+               , directory+               , filepath+               , hslogger+               , hspec+               , hspec-expectations+               , mtl+               , network+               , pontarius-xmpp+               , stm+               , text+               , xml-picklers+               , xml-types+               , tasty+               , tasty-hunit+               , tls  benchmark benchmarks   type: exitcode-stdio-1.0

@@ -58,6 +58,7 @@   , closeConnection   , endSession   , waitForStream+  , streamState     -- ** Authentication handlers     -- | The use of 'scramSha1' is /recommended/, but 'digestMd5' might be     -- useful for interaction with older implementations.@@ -193,11 +194,15 @@   , IQResult(..)   , IQError(..)   , IQResponse(..)+  , IQRequestClass(..)+  , IQRequestHandler   , sendIQ   , sendIQ'+  , sendIQRequest   , answerIQ   , iqResult   , listenIQ+  , runIQHandler   , unlistenIQ   -- * Errors   , StanzaErrorType(..)@@ -207,6 +212,7 @@   , StanzaErrorCondition(..)   , SaslFailure(..)   , IQSendError(..)+  , IQRequestError(..)   -- * Threads   , dupSession   -- * Lenses

@@ -40,6 +40,8 @@ import           Network.Xmpp.Concurrent.Types import           Network.Xmpp.IM.Roster import           Network.Xmpp.IM.Roster.Types+import           Network.Xmpp.IM.PresenceTracker+import           Network.Xmpp.IM.PresenceTracker.Types import           Network.Xmpp.Sasl import           Network.Xmpp.Sasl.Types import           Network.Xmpp.Stream@@ -87,14 +89,15 @@                 Nothing -> return . Just $ serviceUnavailable iq                 Just ch -> do                   sentRef <- newTMVar False-                  let answerT answer = do-                          let IQRequest iqid from _to lang _tp bd = iq+                  let answerT answer attrs = do+                          let IQRequest iqid from _to lang _tp bd _attrs = iq                               response = case answer of                                   Left er  -> IQErrorS $ IQError iqid Nothing                                                                   from lang er-                                                                  (Just bd)+                                                                  (Just bd) attrs                                   Right res -> IQResultS $ IQResult iqid Nothing                                                                     from lang res+                                                                    attrs                           Ex.bracketOnError (atomically $ takeTMVar sentRef)                                             (atomically .  tryPutTMVar sentRef)                                             $ \wasSent -> do@@ -114,8 +117,8 @@                   writeTChan ch $ IQRequestTicket answerT iq as                   return Nothing         maybe (return ()) (void . out) res-    serviceUnavailable (IQRequest iqid from _to lang _tp bd) =-        IQErrorS $ IQError iqid Nothing from lang err (Just bd)+    serviceUnavailable (IQRequest iqid from _to lang _tp bd _attrs) =+        IQErrorS $ IQError iqid Nothing from lang err (Just bd) []     err = StanzaError Cancel ServiceUnavailable Nothing Nothing      handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> IO ()@@ -164,30 +167,38 @@     iqHands  <- lift $ newTVarIO (Map.empty, Map.empty)     eh <- lift $ newEmptyTMVarIO     ros <- liftIO . newTVarIO $ Roster Nothing Map.empty+    peers <- liftIO . newTVarIO $ Peers Map.empty     rew <- lift $ newTVarIO 60     let out = writeStanza writeSem-    let rosterH = if (enableRoster config) then [handleRoster ros out]-                                           else []+    boundJid <- liftIO $ withStream' (gets streamJid) stream+    let rosterH = if (enableRoster config)+                  then [handleRoster boundJid ros out]+                  else []+    let presenceH = if (enablePresenceTracking config)+                    then [handlePresence (onPresenceChange config) peers out]+                    else []     (sStanza, ps) <- initPlugins out $ plugins config     let stanzaHandler = runHandlers $ List.concat                         [ inHandler <$> ps-                        , [ toChan stanzaChan out-                          , handleIQ iqHands out-                          ]+                        , [ toChan stanzaChan sStanza]+                        , presenceH                         , rosterH+                        , [ handleIQ iqHands sStanza]                         ]-    (kill, streamState, reader) <- ErrorT $ startThreadsWith writeSem stanzaHandler eh stream+    (kill, sState, reader) <- ErrorT $ startThreadsWith writeSem stanzaHandler+                                                        eh stream     idGen <- liftIO $ sessionStanzaIDs config     let sess = Session { stanzaCh = stanzaChan                        , iqHandlers = iqHands                        , writeSemaphore = writeSem                        , readerThread = reader                        , idGenerator = idGen-                       , streamRef = streamState+                       , streamRef = sState                        , eventHandlers = eh                        , stopThreads = kill                        , conf = config                        , rosterRef = ros+                       , presenceRef = peers                        , sendStanza' = sStanza                        , sRealm = realm                        , sSaslCredentials = mbSasl@@ -195,9 +206,11 @@                        }     liftIO . atomically $ putTMVar eh $ EventHandlers { connectionClosedHandler =                                                  onConnectionClosed config sess }+    -- Pass the new session to the plugins so they can "tie the knot"     liftIO . forM_ ps $ \p -> onSessionUp p sess     return sess   where+    -- Pass the stanza out action to each plugin     initPlugins out' = go out' []       where         go out ps' [] = return (out, ps')@@ -267,8 +280,6 @@                               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.

@@ -1,6 +1,7 @@ {-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Concurrent.Basic where +import           Control.Applicative import           Control.Concurrent.STM import qualified Control.Exception as Ex import           Control.Monad.State.Strict@@ -19,6 +20,7 @@ writeStanza :: WriteSemaphore -> Stanza -> IO (Either XmppFailure ()) writeStanza sem a = do     let outData = renderElement $ nsHack (pickleElem xpStanza a)+    debugOut outData     semWrite sem outData  @@ -69,3 +71,8 @@         Plain -> return ()         Secured -> return ()         _ -> retry++streamState :: Session -> STM ConnectionState+streamState Session{streamRef = sr}  = do+    s <- readTMVar sr+    streamConnectionState <$> (readTMVar $ unStream s)

@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Concurrent.IQ where @@ -6,12 +9,20 @@ import           Control.Concurrent.STM import           Control.Concurrent.Thread.Delay (delay) import           Control.Monad+import           Control.Monad.Error+import           Control.Monad.Trans import qualified Data.Map as Map+import           Data.Maybe import           Data.Text (Text)+import           Data.XML.Pickle import           Data.XML.Types+import           Lens.Family2 (toListOf, (&), (^.)) import           Network.Xmpp.Concurrent.Basic import           Network.Xmpp.Concurrent.Types+import           Network.Xmpp.Lens+import           Network.Xmpp.Stanza import           Network.Xmpp.Types+import           System.Log.Logger  -- | Sends an IQ, returns an STM action that returns the first inbound IQ with a -- matching ID that has type @result@ or @error@ or Nothing if the timeout was@@ -27,11 +38,12 @@        -> Maybe LangTag  -- ^ Language tag of the payload (@Nothing@ for                          -- default)        -> Element -- ^ The IQ body (there has to be exactly one)+       -> [ExtendedAttribute] -- ^ Additional stanza attributes        -> Session        -> IO (Either XmppFailure (STM (Maybe (Annotated IQResponse))))-sendIQ timeOut to tp lang body session = do+sendIQ timeOut t tp lang body attrs session = do     newId <- idGenerator session-    j <- case to of+    j <- case t of         Just t -> return $ Right t         Nothing -> Left <$> getJid session     ref <- atomically $ do@@ -40,7 +52,8 @@         (byNS, byId) <- readTVar (iqHandlers session)         writeTVar (iqHandlers session) (byNS, Map.insert newId value byId)         return resRef-    res <- sendStanza (IQRequestS $ IQRequest newId Nothing to lang tp body) session+    res <- sendStanza (IQRequestS $ IQRequest newId Nothing t lang tp body attrs)+                      session     case res of         Right () -> do             case timeOut of@@ -60,14 +73,15 @@  -- | Like 'sendIQ', but waits for the answer IQ. sendIQA' :: Maybe Integer-        -> Maybe Jid-        -> IQRequestType-        -> Maybe LangTag-        -> Element-        -> Session-        -> IO (Either IQSendError (Annotated IQResponse))-sendIQA' timeout to tp lang body session = do-    ref <- sendIQ timeout to tp lang body session+         -> Maybe Jid+         -> IQRequestType+         -> Maybe LangTag+         -> Element+         -> [ExtendedAttribute]+         -> Session+         -> IO (Either IQSendError (Annotated IQResponse))+sendIQA' timeout to tp lang body attrs session = do+    ref <- sendIQ timeout to tp lang body attrs session     either (return . Left . IQSendError) (fmap (maybe (Left IQTimeOut) Right)                                      . atomically) ref @@ -77,9 +91,11 @@         -> IQRequestType         -> Maybe LangTag         -> Element+        -> [ExtendedAttribute]         -> Session         -> IO (Either IQSendError IQResponse)-sendIQ' timeout to tp lang body session = fmap fst <$> sendIQA' timeout to tp lang body session+sendIQ' timeout to tp lang body attrs session =+    fmap fst <$> sendIQA' timeout to tp lang body attrs session  -- | Register your interest in inbound IQ stanzas of a specific type and -- namespace. The returned STM action yields the received, matching IQ stanzas.@@ -130,5 +146,67 @@ -- (False is returned in that case) answerIQ :: IQRequestTicket          -> Either StanzaError (Maybe Element)+         -> [ExtendedAttribute]          -> IO (Maybe (Either XmppFailure ()))-answerIQ ticket = answerTicket ticket+answerIQ = answerTicket+++-- Class++class IQRequestClass a where+    data IQResponseType a+    pickleRequest :: PU Element a+    pickleResponse :: PU [Element] (IQResponseType a)+    requestType :: a -> IQRequestType+    requestNamespace :: a -> Text++data IQRequestError = IQRequestSendError XmppFailure+                    | IQRequestTimeout+                    | IQRequestUnpickleError UnpickleError+                      deriving Show++-- | Send an IQ request. May throw IQSendError, UnpickleError,++sendIQRequest  :: (IQRequestClass a, MonadError IQRequestError m, MonadIO m) =>+                  Maybe Integer+               -> Maybe Jid+               -> a+               -> Session+               -> m (Either IQError (IQResponseType a))+sendIQRequest timeout t req con = do+    mbRes <- liftIO $ sendIQ' timeout t (requestType req) Nothing+                              (pickle pickleRequest req) [] con+    case mbRes of+        Left (IQTimeOut) -> throwError IQRequestTimeout+        Left (IQSendError e) -> throwError $ IQRequestSendError e+        Right (IQResponseError e) -> return $ Left e+        Right (IQResponseResult res) ->+              case unpickle pickleResponse (res & toListOf payloadT) of+                   Left e -> throwError $ IQRequestUnpickleError e+                   Right r -> return $ Right r++type IQRequestHandler a = a -> IO (Either StanzaError (IQResponseType a))++runIQHandler :: IQRequestClass a =>+                IQRequestHandler a+             -> Session+             -> IO ()+runIQHandler (handler :: a -> IO (Either StanzaError (IQResponseType a)))+             sess = do+    let prx = undefined :: a+        ns = (requestNamespace prx)+    mbChan <- listenIQ (requestType prx) ns sess+    case mbChan of+        Left _ -> warningM "Pontarius.Xmpp" $ "IQ namespace " ++ show ns+                            ++ " is already handled"+        Right getNext -> forever $ do+            ticket <- atomically getNext+            case unpickle pickleRequest (iqRequestBody ticket ^. payload) of+                Left _ -> answerIQ ticket (Left $ mkStanzaError BadRequest) []+                Right req -> do+                    res <- handler req+                    case res of+                        Left e -> answerIQ ticket (Left e) []+                        Right r -> do+                            let answer = (pickle pickleResponse r)+                            answerIQ ticket (Right $ listToMaybe answer ) []

@@ -3,9 +3,12 @@  import Control.Applicative ((<$>)) import Control.Concurrent.STM-import Network.Xmpp.Types-import Network.Xmpp.Concurrent.Types+import Lens.Family2 hiding (to)+import Lens.Family2.Stock import Network.Xmpp.Concurrent.Basic+import Network.Xmpp.Concurrent.Types+import Network.Xmpp.Lens+import Network.Xmpp.Types  -- | Read a presence stanza from the inbound stanza channel, discards any other -- stanzas. Returns the presence stanza with annotations.@@ -40,4 +43,11 @@  -- | Send a presence stanza. sendPresence :: Presence -> Session -> IO (Either XmppFailure ())-sendPresence p session = sendStanza (PresenceS p) session+sendPresence p session = sendStanza (PresenceS checkedP) session+  where+    -- | RFC 6121 §3.1.1: When a user sends a presence subscription request to a+    -- potential instant messaging and presence contact, the value of the 'to'+    -- attribute MUST be a bare JID rather than a full JID+    checkedP = case presenceType p of+        Subscribe -> p & to . _Just %~ toBare+        _ -> p

@@ -26,8 +26,6 @@ readWorker onStanza onCClosed stateRef = forever . Ex.mask_ $ do      s' <- Ex.catches ( do-                   -- we don't know whether pull will-                   -- necessarily be interruptible                         atomically $ do                             s@(Stream con) <- readTMVar stateRef                             scs <- streamConnectionState <$> readTMVar con@@ -44,6 +42,8 @@         Nothing -> return ()         Just s -> do             res <- Ex.catches (do+                   -- we don't know whether pull will+                   -- necessarily be interruptible                              allowInterrupt                              res <- pullStanza s                              case res of@@ -70,9 +70,7 @@     allowInterrupt = unsafeUnmask $ return ()     -- While waiting for the first semaphore(s) to flip we might receive another     -- interrupt. When that happens we add it's semaphore to the list and retry-    -- waiting. We do this because we might receive another-    -- interrupt while we're waiting for a mutex to unlock; if that happens, the-    -- new interrupt is added to the list and is waited for as well.+    -- waiting.     handleInterrupts :: [TMVar ()] -> IO [()]     handleInterrupts ts =         Ex.catch (atomically $ forM ts takeTMVar)@@ -81,9 +79,6 @@     stateIsClosed Finished = True     stateIsClosed _        = False ---- Two streams: input and output. Threads read from input stream and write to--- output stream. -- | Runs thread in XmppState monad. Returns channel of incoming and outgoing -- stances, respectively, and an Action to stop the Threads and close the -- connection.

@@ -17,6 +17,7 @@ import           Data.XML.Types (Element) import           Network import           Network.Xmpp.IM.Roster.Types+import           Network.Xmpp.IM.PresenceTracker.Types import           Network.Xmpp.Sasl.Types import           Network.Xmpp.Types @@ -84,6 +85,17 @@       -- | Enable roster handling according to rfc 6121. See 'getRoster' to       -- acquire the current roster     , enableRoster               :: Bool+      -- | Track incomming presence stancas.+    , enablePresenceTracking     :: Bool+      -- | Callback that is invoked when the presence status of a peer changes,+      -- i.e. it comes online, goes offline or its IM presence changes. The+      -- arguments are the (full) JID of the peer, the old state and the new+      -- state. The function is called in a new thread to avoid blocking+      -- handling stanzas+    , onPresenceChange           :: Maybe ( Jid+                                          -> PeerStatus+                                          -> PeerStatus+                                          -> IO ())     }  instance Default SessionConfiguration where@@ -97,6 +109,8 @@                                          return . Text.pack . show $ curId                                , plugins = []                                , enableRoster = True+                               , enablePresenceTracking = True+                               , onPresenceChange = Nothing                                }  -- | Handlers to be run when the Xmpp session ends and when the Xmpp connection is@@ -130,6 +144,7 @@     , eventHandlers :: TMVar EventHandlers     , stopThreads :: IO ()     , rosterRef :: TVar Roster+    , presenceRef :: TVar Peers     , conf :: SessionConfiguration     , sendStanza' :: Stanza -> IO (Either XmppFailure ())     , sRealm :: HostName@@ -151,6 +166,7 @@     {   -- | Send an answer to an IQ request once. Subsequent calls will do         -- nothing and return Nothing       answerTicket :: Either StanzaError (Maybe Element)+                      -> [ExtendedAttribute]                       -> IO (Maybe (Either XmppFailure ()))       -- | The actual IQ request that created this ticket.     , iqRequestBody :: IQRequest@@ -162,4 +178,6 @@ data IQSendError = IQSendError XmppFailure -- There was an error sending the IQ                                            -- stanza                  | IQTimeOut -- No answer was received during the allotted time-                   deriving (Show, Eq)+                   deriving (Show, Eq, Typeable)++instance Ex.Exception IQSendError

@@ -22,11 +22,20 @@   , Roster(..)   , Item(..)   , getRoster+  , getRosterSTM   , rosterAdd   , rosterRemove+  -- * presenceTracker+  , PeerStatus(..)+  , isPeerAvailable+  , getEntityStatus+  , getAvailablePeers+  , getPeerEntities   ) where  import Network.Xmpp.IM.Message import Network.Xmpp.IM.Presence import Network.Xmpp.IM.Roster import Network.Xmpp.IM.Roster.Types+import Network.Xmpp.IM.PresenceTracker+import Network.Xmpp.IM.PresenceTracker.Types

@@ -4,21 +4,21 @@  module Network.Xmpp.IM.Presence where -import Data.Default-import Data.Text (Text)-import Data.XML.Pickle-import Data.XML.Types-import Network.Xmpp.Types+import           Data.Default+import           Data.Text (Text)+import           Data.XML.Pickle+import           Data.XML.Types+import           Network.Xmpp.Types  data ShowStatus = StatusAway                 | StatusChat                 | StatusDnd-                | StatusXa deriving (Read, Show)+                | StatusXa deriving (Read, Show, Eq)  data IMPresence = IMP { showStatus :: Maybe ShowStatus                       , status     :: Maybe Text                       , priority   :: Maybe Int-                      } deriving Show+                      } deriving (Show, Eq)  imPresence :: IMPresence imPresence = IMP { showStatus = Nothing@@ -53,6 +53,7 @@                xp3Tuple                   (xpOption $ xpElemNodes "{jabber:client}show"                      (xpContent xpShow))+                  -- TODO: Multiple status elements with different lang tags                   (xpOption $ xpElemNodes "{jabber:client}status"                      (xpContent xpText))                   (xpOption $ xpElemNodes "{jabber:client}priority"

@@ -0,0 +1,110 @@+{-# LANGUAGE RankNTypes #-}+module Network.Xmpp.IM.PresenceTracker where++import           Control.Applicative+import           Control.Concurrent+import           Control.Concurrent.STM+import           Control.Monad+import qualified Data.Foldable as Foldable+import           Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import           Data.Maybe+import           Lens.Family2+import           Lens.Family2.Stock+import           Network.Xmpp.Concurrent.Types+import           Network.Xmpp.IM.Presence+import           Network.Xmpp.Lens hiding (Lens, Traversal)+import           Network.Xmpp.Types+import           Prelude hiding (mapM)++import           Network.Xmpp.IM.PresenceTracker.Types++_peers :: Iso Peers (Map Jid (Map Jid (Maybe IMPresence)))+_peers = mkIso unPeers Peers++_PeerAvailable :: Prism PeerStatus (Maybe IMPresence)+_PeerAvailable = prism' PeerAvailable fromPeerAvailable+  where+    fromPeerAvailable (PeerAvailable pa) = Just pa+    fromPeerAvailable _  = Nothing++_PeerUnavailable :: Prism PeerStatus ()+_PeerUnavailable = prism' (const PeerUnavailable) fromPeerUnavailable+  where+    fromPeerUnavailable PeerUnavailable = Just ()+    fromPeerUnavailable _ = Nothing++_PeerStatus :: Iso (Maybe (Maybe IMPresence)) PeerStatus+_PeerStatus = mkIso toPeerStatus fromPeerStatus+  where+    toPeerStatus (Nothing) = PeerUnavailable+    toPeerStatus (Just imp) = PeerAvailable imp+    fromPeerStatus PeerUnavailable = Nothing+    fromPeerStatus (PeerAvailable imp) = Just imp++maybeMap :: Iso (Maybe (Map a b)) (Map a b)+maybeMap = mkIso maybeToMap mapToMaybe+  where+    maybeToMap Nothing = Map.empty+    maybeToMap (Just m) = m+    mapToMaybe m | Map.null m = Nothing+                 | otherwise = Just m+++-- | Status of give full JID+peerStatusL :: Jid -> Lens' Peers PeerStatus+peerStatusL j = _peers . at (toBare j)  . maybeMap . at j . _PeerStatus++peerMapPeerAvailable :: Jid -> Peers -> Bool+peerMapPeerAvailable j | isFull j = not . nullOf (peerStatusL j . _PeerAvailable)+                       | otherwise = not . nullOf (_peers . at j . _Just)++handlePresence :: Maybe (Jid -> PeerStatus -> PeerStatus -> IO ())+               -> TVar Peers+               -> StanzaHandler+handlePresence onChange peers _ st _  = do+        let mbPr = do+                pr <- st ^? _Presence -- Only act on presence stanzas+                fr <- pr ^? from . _Just . _isFull -- Only act on full JIDs+                return (pr, fr)+        Foldable.forM_ mbPr $ \(pr, fr) ->+            case presenceType pr of+                Available -> setStatus fr   (PeerAvailable (getIMPresence pr))+                Unavailable -> setStatus fr PeerUnavailable+                _ -> return ()+        return [(st, [])]+  where+    setStatus fr newStatus = do+        os <- atomically $ do+            ps <- readTVar peers+            let oldStatus = ps ^. peerStatusL fr+            writeTVar peers $ ps & set (peerStatusL fr) newStatus+            return oldStatus+        unless (os == newStatus) $ case onChange of+            Nothing -> return ()+            Just oc -> void . forkIO $ oc fr os newStatus+        return ()++-- | Check whether a given jid is available+isPeerAvailable :: Jid -> Session -> STM Bool+isPeerAvailable j sess = peerMapPeerAvailable j <$> readTVar (presenceRef sess)++-- | Get status of given full JID+getEntityStatus :: Jid -> Session -> STM PeerStatus+getEntityStatus j sess = do+    peers <- readTVar (presenceRef sess)+    return $ peers ^. peerStatusL j++-- | Get list of (bare) Jids with available entities+getAvailablePeers :: Session -> STM [Jid]+getAvailablePeers sess = do+    Peers peers <- readTVar (presenceRef sess)+    return $ Map.keys peers++-- | Get all available full JIDs to the given JID+getPeerEntities :: Jid -> Session -> STM (Map Jid (Maybe IMPresence))+getPeerEntities j sess = do+    Peers peers <- readTVar (presenceRef sess)+    case Map.lookup (toBare j) peers of+        Nothing -> return Map.empty+        Just js -> return js

@@ -0,0 +1,20 @@+module Network.Xmpp.IM.PresenceTracker.Types where++import           Data.Map (Map)++import           Network.Xmpp.Types+import           Network.Xmpp.IM.Presence++-- Map from bare JIDs to a map of full JIDs to show maybe status.+--+-- Invariants:+-- * The outer map should not have entries for bare JIDs that have no+--   available resource, i.e. the inner map should never be empty+--+-- * The inner map keys' local and domain part coincide with the outer keys'+newtype Peers = Peers { unPeers :: Map Jid (Map Jid (Maybe IMPresence))}+                deriving (Show)++data PeerStatus = PeerAvailable (Maybe IMPresence)+                | PeerUnavailable+                  deriving (Show, Eq)

@@ -31,22 +31,15 @@ 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 (Either IQSendError (Annotated IQResponse))-rosterPush item session = do-    let el = pickleElem xpQuery (Query Nothing [fromItem item])-    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.-rosterAdd :: Jid -- ^ JID of the item+rosterSet :: Jid -- ^ JID of the item           -> Maybe Text -- ^ Name alias           -> [Text] -- ^ Groups (duplicates will be removed)           -> Session           -> IO (Either IQSendError (Annotated IQResponse))-rosterAdd j n gs session = do+rosterSet j n gs session = do     let el = pickleElem xpQuery (Query Nothing                                  [QueryItem { qiApproved = Nothing                                             , qiAsk = False@@ -55,8 +48,16 @@                                             , qiSubscription = Nothing                                             , qiGroups = nub gs                                             }])-    sendIQA' timeout Nothing Set Nothing el session+    sendIQA' timeout Nothing Set Nothing el [] session +-- | Synonym to rosterSet+rosterAdd :: Jid+          -> Maybe Text+          -> [Text]+          -> Session+          -> IO (Either IQSendError (Annotated IQResponse))+rosterAdd = rosterSet+ -- | Remove an item from the roster. Return 'True' when the item is sucessfully -- removed or if it wasn't in the roster to begin with. rosterRemove :: Jid -> Session -> IO Bool@@ -69,10 +70,21 @@             case res of                 Right (IQResponseResult IQResult{}, _) -> return True                 _ -> return False+  where+    rosterPush :: Item+               -> Session+               -> IO (Either IQSendError (Annotated IQResponse))+    rosterPush item session = do+        let el = pickleElem xpQuery (Query Nothing [fromItem item])+        sendIQA' timeout Nothing Set Nothing el [] session +-- | Retrieve the current Roster state (STM version)+getRosterSTM :: Session -> STM Roster+getRosterSTM session = readTVar (rosterRef session)+ -- | Retrieve the current Roster state getRoster :: Session -> IO Roster-getRoster session = atomically $ readTVar (rosterRef session)+getRoster session = atomically $ getRosterSTM session  -- | Get the initial roster or refresh the roster. You don't need to call this -- on your own.@@ -86,37 +98,48 @@                           "Server did not return a roster: "         Just roster -> atomically $ writeTVar (rosterRef session) roster -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 [(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-                        _ <- out $ result iqr-                        return []-                    _ -> do-                        errorM "Pontarius.Xmpp" "Invalid roster query"-                        _ <- out $ badRequest iqr-                        return []-    _ -> return [(sta, [])]+handleRoster :: Maybe Jid -> TVar Roster -> StanzaHandler+handleRoster mbBoundJid ref out sta _ = do+    case sta of+        IQRequestS (iqr@IQRequest{iqRequestPayload =+                                       iqb@Element{elementName = en}})+            | nameNamespace en == Just "jabber:iq:roster" -> do+                let doHandle = case (iqRequestFrom iqr, mbBoundJid) of+                        -- We don't need to check our own JID when the IQ+                        -- request was sent without a from address+                        (Nothing, _) -> True+                        -- We don't have a Jid bound, so we can't verify that+                        -- the from address matches our bare jid+                        (Just _fr, Nothing) -> False+                        -- Check that the from address matches our bare jid+                        (Just fr, Just boundJid) | fr == toBare boundJid -> True+                                                 | otherwise -> False+                if doHandle+                    then case unpickleElem xpQuery iqb of+                        Right Query{ queryVer = v+                                   , queryItems = [update]+                                   } -> do+                            handleUpdate v update+                            _ <- out $ result iqr+                            return []+                        _ -> do+                            errorM "Pontarius.Xmpp" "Invalid roster query"+                            _ <- out $ badRequest iqr+                            return []+                    -- Don't handle roster pushes from unauthorized sources+                    else return [(sta, [])]+        _ -> return [(sta, [])]   where     handleUpdate v' update = atomically $ modifyTVar ref $ \(Roster v is) ->         Roster (v' `mplus` v) $ case qiSubscription update of             Just Remove -> Map.delete (qiJid update) is             _ -> Map.insert (qiJid update) (toItem update) is -    badRequest (IQRequest iqid from _to lang _tp bd) =-        IQErrorS $ IQError iqid Nothing from lang errBR (Just bd)+    badRequest (IQRequest iqid from _to lang _tp bd _attrs) =+        IQErrorS $ IQError iqid Nothing from lang errBR (Just bd) []     errBR = StanzaError Cancel BadRequest Nothing Nothing-    result (IQRequest iqid from _to lang _tp _bd) =-        IQResultS $ IQResult iqid Nothing from lang Nothing+    result (IQRequest iqid from _to lang _tp _bd _attrs) =+        IQResultS $ IQResult iqid Nothing from lang Nothing []  retrieveRoster :: Maybe Roster -> Session -> IO (Maybe Roster) retrieveRoster mbOldRoster sess = do@@ -128,6 +151,7 @@                 else Nothing     res <- sendIQ' timeout Nothing Get Nothing                    (pickleElem xpQuery (Query version []))+                   []                    sess     case res of         Left e -> do@@ -156,9 +180,13 @@                  , riAsk = qiAsk qi                  , riJid = qiJid qi                  , riName = qiName qi-                 , riSubscription = fromMaybe None (qiSubscription qi)+                 , riSubscription = fromSubscription (qiSubscription qi)                  , riGroups = nub $ qiGroups qi                  }+  where+    fromSubscription Nothing = None+    fromSubscription (Just s) | s `elem` [None, To, From, Both] = s+                              | otherwise = None  fromItem :: Item -> QueryItem fromItem i = QueryItem { qiApproved = Nothing@@ -197,17 +225,15 @@  xpSubscription :: PU Text Subscription xpSubscription = ("xpSubscription", "") <?>-        xpPartial ( \input -> case subscriptionFromText input of-                                   Nothing -> Left "Could not parse subscription."-                                   Just j -> Right j)-                  subscriptionToText+        xpIso subscriptionFromText+              subscriptionToText   where-    subscriptionFromText "none" = Just None-    subscriptionFromText "to" = Just To-    subscriptionFromText "from" = Just From-    subscriptionFromText "both" = Just Both-    subscriptionFromText "remove" = Just Remove-    subscriptionFromText _ = Nothing+    subscriptionFromText "none" = None+    subscriptionFromText "to" = To+    subscriptionFromText "from" = From+    subscriptionFromText "both" = Both+    subscriptionFromText "remove" = Remove+    subscriptionFromText _ = None     subscriptionToText None = "none"     subscriptionToText To = "to"     subscriptionToText From = "from"

@@ -17,43 +17,58 @@ -- top of this API.  module Network.Xmpp.Internal-  ( -- * Stream-    Stream(..)-  , StreamConfiguration(..)-  , StreamState(..)-  , StreamHandle(..)-  , StreamFeatures(..)-  , openStream-  , withStream-    -- * TLS-  , tls-  , TlsBehaviour(..)-    -- * Auth-  , SaslHandler-  , auth-    -- * Stanzas-  , Stanza(..)-  , pushStanza-  , pullStanza-  , writeStanza-    -- ** IQ-  , pushIQ-  , iqError-  , iqResult-  , associatedErrorType-    -- * Plugins-  , Plugin-  , Plugin'(..)-  , Annotation(..)-  , connectTls- )-       where+  ( module Network.Xmpp.Concurrent+  , module Network.Xmpp.Concurrent.Basic+  , module Network.Xmpp.Concurrent.IQ+  , module Network.Xmpp.Concurrent.Message+  , module Network.Xmpp.Concurrent.Monad+  , module Network.Xmpp.Concurrent.Presence+  , module Network.Xmpp.Concurrent.Threads+  , module Network.Xmpp.Concurrent.Types+  , module Network.Xmpp.IM.Message+  , module Network.Xmpp.IM.Presence+  , module Network.Xmpp.IM.Roster+  , module Network.Xmpp.IM.Roster.Types+  , module Network.Xmpp.Marshal+  , module Network.Xmpp.Sasl+  , module Network.Xmpp.Sasl.Common+  , module Network.Xmpp.Sasl.Mechanisms+  , module Network.Xmpp.Sasl.Mechanisms.DigestMd5+  , module Network.Xmpp.Sasl.Mechanisms.Plain+  , module Network.Xmpp.Sasl.Mechanisms.Scram+  , module Network.Xmpp.Sasl.StringPrep+  , module Network.Xmpp.Sasl.Types+  , module Network.Xmpp.Stanza+  , module Network.Xmpp.Stream+  , module Network.Xmpp.Tls+  , module Network.Xmpp.Types+  , module Network.Xmpp.Utilities+  ) where ++import Network.Xmpp.Concurrent import Network.Xmpp.Concurrent.Basic+import Network.Xmpp.Concurrent.IQ+import Network.Xmpp.Concurrent.Message+import Network.Xmpp.Concurrent.Monad+import Network.Xmpp.Concurrent.Presence+import Network.Xmpp.Concurrent.Threads import Network.Xmpp.Concurrent.Types+import Network.Xmpp.IM.Message+import Network.Xmpp.IM.Presence+import Network.Xmpp.IM.Roster+import Network.Xmpp.IM.Roster.Types+import Network.Xmpp.Marshal import Network.Xmpp.Sasl+import Network.Xmpp.Sasl.Common+import Network.Xmpp.Sasl.Mechanisms+import Network.Xmpp.Sasl.Mechanisms.DigestMd5+import Network.Xmpp.Sasl.Mechanisms.Plain+import Network.Xmpp.Sasl.Mechanisms.Scram+import Network.Xmpp.Sasl.StringPrep import Network.Xmpp.Sasl.Types import Network.Xmpp.Stanza-import Network.Xmpp.Stream+import Network.Xmpp.Stream hiding (mbl, lmb) import Network.Xmpp.Tls import Network.Xmpp.Types+import Network.Xmpp.Utilities

@@ -5,30 +5,60 @@ {-# 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.+-- | (More than just) Van Laarhoven lenses for XMPP types. The accessors in here+-- are designed to work with an optics library like lens or lens-family. This+-- module also provides a few simple functions ('view', 'modify', 'set' and+-- 'getAll') so you don't need to pull in another library to get some use out+-- of them. ----- The name of the lenses corresponds to the field name of the data types with+-- * The name of the lenses corresponds to the field name of the data types with -- an upper-case L appended. For documentation of the fields refer to the documentation of the data types (linked in the section header)+--+-- * Same goes for Traversals, except they are suffixed with a \'T\'+--+-- * Prism generally start with an underscore+--+-- /NB/ you do not need to import this module to get access to the optics+-- defined herein. They are also exported from Network.Xmpp. You only need to+-- import this module if you want to use the complementary accessor functions+-- without using an optics library like lens or lens-family  module Network.Xmpp.Lens        ( Lens        , Traversal+       , Prism+       , Iso          -- * Accessors          -- | Reimplementation of the basic lens functions so you don't have to-         -- bring in all of lens library in to use the lenses+         -- bring in a lens library to use the optics           -- ** Lenses-       , view+       , LF.view        , modify-       , set+       , LF.set          -- * Traversals        , getAll+         -- * Prisms++         -- ** Construction+       , prism'+       , mkLens+       , mkIso          -- * Lenses +         -- ** JID+       , _JidText+       , _isFull+       , _isBare+          -- ** Stanzas+       , _IQRequest+       , _IQResult+       , _IQError+       , _Message+       , _MessageError+       , _Presence+       , _PresenceError        , IsStanza(..)        , HasStanzaPayload(..)        , IsErrorStanza(..)@@ -48,12 +78,23 @@        , establishSessionL        , tlsBehaviourL        , tlsParamsL+         -- **** TLS parameters+       , clientServerIdentificationL+       , tlsServerIdentificationL+       , clientSupportedL+       , supportedCiphersL+       , supportedVersionsL+       , tlsSupportedCiphersL+       , tlsSupportedVersionsL+       , clientUseServerNameIndicationL+       , tlsUseNameIndicationL          -- *** 'SessionConfiguration'        , streamConfigurationL        , onConnectionClosedL        , sessionStanzaIDsL        , ensableRosterL        , pluginsL+       , onPresenceChangeL          -- ** IM          -- *** Roster          -- **** 'Roster'@@ -99,40 +140,43 @@        where  import           Control.Applicative-import           Data.Functor.Identity(Identity(..))+import qualified Data.ByteString as BS+import           Data.Functor.Identity (Identity(..)) import qualified Data.Map as Map+import           Data.Profunctor+import           Data.Text (Text) import qualified Data.Text as Text-import           Data.Text(Text)-import           Data.XML.Types(Element)-import           Network.DNS(ResolvConf)-import           Network.TLS (ClientParams)+import           Data.XML.Types (Element)+import qualified Lens.Family2 as LF+import           Network.DNS (ResolvConf)+import           Network.TLS as TLS import           Network.Xmpp.Concurrent.Types-import           Network.Xmpp.IM.Roster.Types import           Network.Xmpp.IM.Message import           Network.Xmpp.IM.Presence+import           Network.Xmpp.IM.PresenceTracker.Types+import           Network.Xmpp.IM.Roster.Types import           Network.Xmpp.Types  -- | Van-Laarhoven lenses.+{-# DEPRECATED Lens "Use Lens' from lens-family or lens" #-} type Lens a b = Functor f => (b -> f b) -> a -> f a +{-# DEPRECATED Traversal "Use Traversal' from lens-family or lens" #-} type Traversal a b = Applicative f => (b -> f b) -> a -> f a ---- Accessors----------------+type Prism a b = forall p f. (Choice p, Applicative f) => p b (f b) -> p a (f a) +type Iso a b = forall p f. (Profunctor p, Functor f) => p b (f b) -> p a (f a) --- | Read the value the lens is pointing to-view :: Lens a b -> a -> b-view l x = getConst $ l Const x+prism' :: (b -> s) -> (s -> Maybe b) -> Prism s b+prism' bs sma = dimap (\s -> maybe (Left s) Right (sma s))+                      (either pure (fmap bs)) . right' --- | Replace the value the lens is pointing to-set :: Lens a b -> b -> a -> a-set l b x = modify l (const b) x+mkLens :: (a -> b) -> (b -> a ->  a) -> Lens a b+mkLens get set = \inj x -> fmap (flip set x) (inj $ get 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)+mkIso :: (a -> b) -> (b -> a) -> Iso a b+mkIso t f = dimap t (fmap f)  newtype Collect a b = Collect {getCollection :: [a]} deriving Functor @@ -140,14 +184,27 @@     pure _ = Collect []     Collect xs <*> Collect ys = Collect $ xs ++ ys +{-# DEPRECATED getAll "use toListOf (lens-family), partsOf (lens) or similar" #-} -- | Return all the values a Traversal is pointing to in a list getAll :: Traversal a b -> a -> [b] getAll t = getCollection . t (Collect . pure) +{-# DEPRECATED modify "use over (lens-family, lens)" #-}+modify :: Traversal a b -> (b -> b) -> a -> a+modify t f = runIdentity . t (Identity . f)  -- Xmpp Lenses -------------------- +_JidText :: Prism Text Jid+_JidText = prism' jidToText jidFromText++_isFull :: Prism Jid Jid+_isFull = prism' id (\j -> if isFull j then Just j else Nothing)++_isBare :: Prism Jid Jid+_isBare = prism' toBare (\j -> if isBare j then Just j else Nothing)+ class IsStanza s where     -- | From-attribute of the stanza     from :: Lens s (Maybe Jid)@@ -278,6 +335,48 @@                       <$> inj (if Text.null x then Nothing else Just x)  +_IQRequest :: Prism Stanza IQRequest+_IQRequest = prism' IQRequestS fromIQRequestS+  where+    fromIQRequestS (IQRequestS s) = Just s+    fromIQRequestS _ = Nothing++_IQResult :: Prism Stanza IQResult+_IQResult = prism' IQResultS fromIQResultS+  where+    fromIQResultS (IQResultS s) = Just s+    fromIQResultS _ = Nothing++_IQError :: Prism Stanza IQError+_IQError = prism' IQErrorS fromIQErrorS+  where+    fromIQErrorS (IQErrorS s) = Just s+    fromIQErrorS _ = Nothing++_Message :: Prism Stanza Message+_Message = prism' MessageS fromMessageS+  where+    fromMessageS (MessageS s) = Just s+    fromMessageS _ = Nothing++_MessageError :: Prism Stanza MessageError+_MessageError = prism' MessageErrorS fromMessageErrorS+  where+    fromMessageErrorS (MessageErrorS s) = Just s+    fromMessageErrorS _ = Nothing++_Presence :: Prism Stanza Presence+_Presence = prism' PresenceS fromPresenceS+  where+    fromPresenceS (PresenceS s) = Just s+    fromPresenceS _ = Nothing++_PresenceError :: Prism Stanza PresenceError+_PresenceError = prism' PresenceErrorS fromPresenceErrorS+  where+    fromPresenceErrorS (PresenceErrorS s) = Just s+    fromPresenceErrorS _ = Nothing+ class IsErrorStanza s where     -- | Error element of the stanza     stanzaError :: Lens s StanzaError@@ -390,11 +489,36 @@ tlsBehaviourL inj sc@StreamConfiguration{tlsBehaviour = x}     = (\x' -> sc{tlsBehaviour = x'}) <$> inj x + tlsParamsL :: Lens StreamConfiguration ClientParams tlsParamsL inj sc@StreamConfiguration{tlsParams = x}     = (\x' -> sc{tlsParams = x'}) <$> inj x --- SessioConfiguration+-- TLS parameters+-----------------++clientServerIdentificationL  :: Lens ClientParams (String, BS.ByteString)+clientServerIdentificationL inj cp@ClientParams{clientServerIdentification = x}+    = (\x' -> cp{clientServerIdentification = x'}) <$> inj x++clientSupportedL  :: Lens ClientParams Supported+clientSupportedL inj cp@ClientParams{clientSupported = x}+    = (\x' -> cp{clientSupported = x'}) <$> inj x++clientUseServerNameIndicationL  :: Lens ClientParams Bool+clientUseServerNameIndicationL inj+    cp@ClientParams{clientUseServerNameIndication = x}+    = (\x' -> cp{clientUseServerNameIndication = x'}) <$> inj x++supportedCiphersL :: Lens Supported [Cipher]+supportedCiphersL inj s@Supported{supportedCiphers = x}+    = (\x' -> s{supportedCiphers = x'}) <$> inj x++supportedVersionsL :: Lens Supported [TLS.Version]+supportedVersionsL inj s@Supported{supportedVersions = x}+    = (\x' -> s{supportedVersions = x'}) <$> inj x++-- SessionConfiguration ----------------------- streamConfigurationL :: Lens SessionConfiguration StreamConfiguration streamConfigurationL inj sc@SessionConfiguration{sessionStreamConfiguration = x}@@ -415,6 +539,34 @@ pluginsL :: Lens SessionConfiguration [Plugin] pluginsL inj sc@SessionConfiguration{plugins = x}     = (\x' -> sc{plugins = x'}) <$> inj x++onPresenceChangeL :: Lens SessionConfiguration (Maybe ( Jid -> PeerStatus+                                                        -> PeerStatus -> IO ()))+onPresenceChangeL inj sc@SessionConfiguration{onPresenceChange = x}+    = (\x' -> sc{onPresenceChange = x'}) <$> inj x++-- | Access clientServerIdentification inside tlsParams inside streamConfiguration+tlsServerIdentificationL  :: Lens SessionConfiguration (String, BS.ByteString)+tlsServerIdentificationL = streamConfigurationL+                         . tlsParamsL+                         . clientServerIdentificationL++-- | Access clientUseServerNameIndication inside tlsParams+tlsUseNameIndicationL :: Lens SessionConfiguration Bool+tlsUseNameIndicationL = streamConfigurationL+                      . tlsParamsL+                      . clientUseServerNameIndicationL++-- | Access supportedCiphers inside clientSupported inside tlsParams+tlsSupportedCiphersL :: Lens SessionConfiguration [Cipher]+tlsSupportedCiphersL =  streamConfigurationL+                     .  tlsParamsL . clientSupportedL . supportedCiphersL++-- | Access supportedVersions inside clientSupported inside tlsParams+tlsSupportedVersionsL :: Lens SessionConfiguration [TLS.Version]+tlsSupportedVersionsL = streamConfigurationL+                      . tlsParamsL . clientSupportedL . supportedVersionsL+  -- Roster ------------------

@@ -10,12 +10,14 @@  module Network.Xmpp.Marshal where -import Data.XML.Pickle-import Data.XML.Types+import           Data.XML.Pickle+import           Data.XML.Types -import Data.Text+import qualified Control.Exception as Ex+import           Data.Text (Text)+import qualified Data.Text as Text -import Network.Xmpp.Types+import           Network.Xmpp.Types  xpNonemptyText :: PU Text NonemptyText xpNonemptyText = ("xpNonemptyText" , "") <?+> xpWrap Nonempty fromNonempty xpText@@ -23,6 +25,16 @@ xpStreamStanza :: PU [Node] (Either StreamErrorInfo Stanza) xpStreamStanza = xpEither xpStreamError xpStanza +xpExtendedAttrs :: PU [Attribute] [ExtendedAttribute]+xpExtendedAttrs = ("xpAttrVerbatim" , "") <?+>+                    xpIso (map (\(name, cs) -> (name, flattenContents cs)))+                          (map (\(name, c) -> (name, [ContentText c])))+  where+    flattenContents = Text.concat . filterContentText+    filterContentText = map (\c -> case c of+        ContentText t -> t+        ContentEntity{} -> Ex.throw UnresolvedEntityException )+ xpStanza :: PU [Node] Stanza xpStanza = ("xpStanza" , "") <?+> xpAlt stanzaSel     [ xpWrap IQRequestS     (\(IQRequestS     x) -> x) xpIQRequest@@ -46,15 +58,16 @@  xpMessage :: PU [Node] (Message) xpMessage = ("xpMessage" , "") <?+> xpWrap-    (\((tp, qid, from, to, lang), ext) -> Message qid from to lang tp ext)-    (\(Message qid from to lang tp ext) -> ((tp, qid, from, to, lang), ext))+    (\((tp, qid, from, to, lang, attrs), ext) -> Message qid from to lang tp ext attrs)+    (\(Message qid from to lang tp ext attrs) -> ((tp, qid, from, to, lang, attrs), ext))     (xpElem "{jabber:client}message"-         (xp5Tuple+         (xp6Tuple              (xpDefault Normal $ xpAttr "type" xpMessageType)              (xpAttrImplied "id"   xpId)              (xpAttrImplied "from" xpJid)              (xpAttrImplied "to"   xpJid)              xpLangTag+             xpExtendedAttrs              -- TODO: NS?          )          (xpAll xpElemVerbatim)@@ -62,45 +75,54 @@  xpPresence :: PU [Node] Presence xpPresence = ("xpPresence" , "") <?+> xpWrap-    (\((qid, from, to, lang, tp), ext) -> Presence qid from to lang tp ext)-    (\(Presence qid from to lang tp ext) -> ((qid, from, to, lang, tp), ext))+    (\((qid, from, to, lang, tp, attr), ext)+        -> Presence qid from to lang tp ext attr)+    (\(Presence qid from to lang tp ext attr)+       -> ((qid, from, to, lang, tp, attr), ext))     (xpElem "{jabber:client}presence"-         (xp5Tuple+         (xp6Tuple               (xpAttrImplied "id"   xpId)               (xpAttrImplied "from" xpJid)               (xpAttrImplied "to"   xpJid)               xpLangTag               (xpDefault Available $ xpAttr "type" xpPresenceType)+              xpExtendedAttrs          )          (xpAll xpElemVerbatim)     )  xpIQRequest :: PU [Node] IQRequest xpIQRequest = ("xpIQRequest" , "") <?+> xpWrap-    (\((qid, from, to, lang, tp),body) -> IQRequest qid from to lang tp body)-    (\(IQRequest qid from to lang tp body) -> ((qid, from, to, lang, tp), body))+    (\((qid, from, to, lang, tp, attr),body)+       -> IQRequest qid from to lang tp body attr)+    (\(IQRequest qid from to lang tp body attr)+        -> ((qid, from, to, lang, tp, attr), body))     (xpElem "{jabber:client}iq"-         (xp5Tuple+         (xp6Tuple              (xpAttr        "id"   xpId)              (xpAttrImplied "from" xpJid)              (xpAttrImplied "to"   xpJid)              xpLangTag              ((xpAttr        "type" xpIQRequestType))+             xpExtendedAttrs          )          xpElemVerbatim     )  xpIQResult :: PU [Node] IQResult xpIQResult = ("xpIQResult" , "") <?+> xpWrap-    (\((qid, from, to, lang, _tp),body) -> IQResult qid from to lang body)-    (\(IQResult qid from to lang body) -> ((qid, from, to, lang, ()), body))+    (\((qid, from, to, lang, _tp, attr),body)+        -> IQResult qid from to lang body attr)+    (\(IQResult qid from to lang body attr)+        -> ((qid, from, to, lang, (), attr ), body))     (xpElem "{jabber:client}iq"-         (xp5Tuple+         (xp6Tuple              (xpAttr        "id"   xpId)              (xpAttrImplied "from" xpJid)              (xpAttrImplied "to"   xpJid)              xpLangTag              ((xpAttrFixed "type" "result"))+             xpExtendedAttrs          )          (xpOption xpElemVerbatim)     )@@ -134,10 +156,8 @@     -- 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+            xpIso stanzaErrorConditionFromText+                  stanzaErrorConditionToText     stanzaErrorConditionToText BadRequest = "bad-request"     stanzaErrorConditionToText Conflict = "conflict"     stanzaErrorConditionToText FeatureNotImplemented = "feature-not-implemented"@@ -160,41 +180,43 @@     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+    stanzaErrorConditionFromText "bad-request" = BadRequest+    stanzaErrorConditionFromText "conflict" = Conflict+    stanzaErrorConditionFromText "feature-not-implemented" = FeatureNotImplemented+    stanzaErrorConditionFromText "forbidden" = Forbidden+    stanzaErrorConditionFromText "gone" = Gone Nothing+    stanzaErrorConditionFromText "internal-server-error" = InternalServerError+    stanzaErrorConditionFromText "item-not-found" = ItemNotFound+    stanzaErrorConditionFromText "jid-malformed" = JidMalformed+    stanzaErrorConditionFromText "not-acceptable" = NotAcceptable+    stanzaErrorConditionFromText "not-allowed" = NotAllowed+    stanzaErrorConditionFromText "not-authorized" = NotAuthorized+    stanzaErrorConditionFromText "policy-violation" = PolicyViolation+    stanzaErrorConditionFromText "recipient-unavailable" = RecipientUnavailable+    stanzaErrorConditionFromText "redirect" = Redirect Nothing+    stanzaErrorConditionFromText "registration-required" = RegistrationRequired+    stanzaErrorConditionFromText "remote-server-not-found" = RemoteServerNotFound+    stanzaErrorConditionFromText "remote-server-timeout" = RemoteServerTimeout+    stanzaErrorConditionFromText "resource-constraint" = ResourceConstraint+    stanzaErrorConditionFromText "service-unavailable" = ServiceUnavailable+    stanzaErrorConditionFromText "subscription-required" = SubscriptionRequired+    stanzaErrorConditionFromText "undefined-condition" = UndefinedCondition+    stanzaErrorConditionFromText "unexpected-request" = UnexpectedRequest+    stanzaErrorConditionFromText _ = UndefinedCondition    xpStanzaError :: PU [Node] StanzaError xpStanzaError = ("xpStanzaError" , "") <?+> xpWrap-    (\(tp, (cond, txt, ext)) -> StanzaError tp cond txt ext)-    (\(StanzaError tp cond txt ext) -> (tp, (cond, txt, ext)))+    (\((tp, _code), (cond, txt, ext)) -> StanzaError tp cond txt ext)+    (\(StanzaError tp cond txt ext) -> ((tp, Nothing), (cond, txt, ext)))     (xpElem "{jabber:client}error"-         (xpAttr "type" xpStanzaErrorType)+         (xp2Tuple+             (xpAttr "type" xpStanzaErrorType)+             (xpAttribute' "code" xpId))          (xp3Tuple               xpStanzaErrorCondition-              (xpOption $ xpElem "{jabber:client}text"+              (xpOption $ xpElem "{urn:ietf:params:xml:ns:xmpp-stanzas}text"                    (xpAttrImplied xmlLang xpLang)                    (xpContent xpNonemptyText)               )@@ -204,52 +226,54 @@  xpMessageError :: PU [Node] (MessageError) xpMessageError = ("xpMessageError" , "") <?+> xpWrap-    (\((_, qid, from, to, lang), (err, ext)) ->-        MessageError qid from to lang err ext)-    (\(MessageError qid from to lang err ext) ->-        (((), qid, from, to, lang), (err, ext)))+    (\((_, qid, from, to, lang, attr), (err, ext)) ->+        MessageError qid from to lang err ext attr)+    (\(MessageError qid from to lang err ext attr) ->+        (((), qid, from, to, lang, attr), (err, ext)))     (xpElem "{jabber:client}message"-         (xp5Tuple+         (xp6Tuple               (xpAttrFixed   "type" "error")               (xpAttrImplied "id"   xpId)               (xpAttrImplied "from" xpJid)               (xpAttrImplied "to"   xpJid)               (xpAttrImplied xmlLang xpLang)-              -- TODO: NS?+              xpExtendedAttrs          )          (xp2Tuple xpStanzaError (xpAll xpElemVerbatim))     )  xpPresenceError :: PU [Node] PresenceError xpPresenceError = ("xpPresenceError" , "") <?+> xpWrap-    (\((qid, from, to, lang, _),(err, ext)) ->-        PresenceError qid from to lang err ext)-    (\(PresenceError qid from to lang err ext) ->-        ((qid, from, to, lang, ()), (err, ext)))+    (\((qid, from, to, lang, _, attr),(err, ext)) ->+        PresenceError qid from to lang err ext attr)+    (\(PresenceError qid from to lang err ext attr) ->+        ((qid, from, to, lang, (), attr), (err, ext)))     (xpElem "{jabber:client}presence"-         (xp5Tuple+         (xp6Tuple               (xpAttrImplied "id"   xpId)               (xpAttrImplied "from" xpJid)               (xpAttrImplied "to"   xpJid)               xpLangTag               (xpAttrFixed "type" "error")+              xpExtendedAttrs          )          (xp2Tuple xpStanzaError (xpAll xpElemVerbatim))     )  xpIQError :: PU [Node] IQError xpIQError = ("xpIQError" , "") <?+> xpWrap-    (\((qid, from, to, lang, _tp),(err, body)) ->-        IQError qid from to lang err body)-    (\(IQError qid from to lang err body) ->-        ((qid, from, to, lang, ()), (err, body)))+    (\((qid, from, to, lang, _tp, attr),(err, body)) ->+        IQError qid from to lang err body attr)+    (\(IQError qid from to lang err body attr) ->+        ((qid, from, to, lang, (), attr), (err, body)))     (xpElem "{jabber:client}iq"-         (xp5Tuple+         (xp6Tuple               (xpAttr        "id"   xpId)               (xpAttrImplied "from" xpJid)               (xpAttrImplied "to"   xpJid)               xpLangTag               ((xpAttrFixed "type" "error"))+              xpExtendedAttrs          )          (xp2Tuple xpStanzaError (xpOption xpElemVerbatim))     )@@ -376,16 +400,14 @@  xpMessageType :: PU Text MessageType xpMessageType = ("xpMessageType", "") <?>-        xpPartial ( \input -> case messageTypeFromText input of-                                   Nothing -> Left "Could not parse message type."-                                   Just j -> Right j)-                  messageTypeToText+        xpIso messageTypeFromText+              messageTypeToText   where-    messageTypeFromText "chat" = Just Chat-    messageTypeFromText "groupchat" = Just GroupChat-    messageTypeFromText "headline" = Just Headline-    messageTypeFromText "normal" = Just Normal-    messageTypeFromText _ = Just Normal+    messageTypeFromText "chat" = Chat+    messageTypeFromText "groupchat" = GroupChat+    messageTypeFromText "headline" = Headline+    messageTypeFromText "normal" = Normal+    messageTypeFromText _ = Normal     messageTypeToText Chat = "chat"     messageTypeToText GroupChat = "groupchat"     messageTypeToText Headline = "headline"@@ -437,10 +459,8 @@  xpStreamErrorCondition :: PU Text StreamErrorCondition xpStreamErrorCondition = ("xpStreamErrorCondition", "") <?>-        xpPartial ( \input -> case streamErrorConditionFromText input of-                                   Nothing -> Left "Could not parse stream error condition."-                                   Just j -> Right j)-                  streamErrorConditionToText+        xpIso streamErrorConditionFromText+              streamErrorConditionToText   where     streamErrorConditionToText StreamBadFormat              = "bad-format"     streamErrorConditionToText StreamBadNamespacePrefix     = "bad-namespace-prefix"@@ -467,29 +487,29 @@     streamErrorConditionToText StreamUnsupportedFeature     = "unsupported-feature"     streamErrorConditionToText StreamUnsupportedStanzaType  = "unsupported-stanza-type"     streamErrorConditionToText StreamUnsupportedVersion     = "unsupported-version"-    streamErrorConditionFromText "bad-format" = Just StreamBadFormat-    streamErrorConditionFromText "bad-namespace-prefix" = Just StreamBadNamespacePrefix-    streamErrorConditionFromText "conflict" = Just StreamConflict-    streamErrorConditionFromText "connection-timeout" = Just StreamConnectionTimeout-    streamErrorConditionFromText "host-gone" = Just StreamHostGone-    streamErrorConditionFromText "host-unknown" = Just StreamHostUnknown-    streamErrorConditionFromText "improper-addressing" = Just StreamImproperAddressing-    streamErrorConditionFromText "internal-server-error" = Just StreamInternalServerError-    streamErrorConditionFromText "invalid-from" = Just StreamInvalidFrom-    streamErrorConditionFromText "invalid-namespace" = Just StreamInvalidNamespace-    streamErrorConditionFromText "invalid-xml" = Just StreamInvalidXml-    streamErrorConditionFromText "not-authorized" = Just StreamNotAuthorized-    streamErrorConditionFromText "not-well-formed" = Just StreamNotWellFormed-    streamErrorConditionFromText "policy-violation" = Just StreamPolicyViolation-    streamErrorConditionFromText "remote-connection-failed" = Just StreamRemoteConnectionFailed-    streamErrorConditionFromText "reset" = Just StreamReset-    streamErrorConditionFromText "resource-constraint" = Just StreamResourceConstraint-    streamErrorConditionFromText "restricted-xml" = Just StreamRestrictedXml-    streamErrorConditionFromText "see-other-host" = Just StreamSeeOtherHost-    streamErrorConditionFromText "system-shutdown" = Just StreamSystemShutdown-    streamErrorConditionFromText "undefined-condition" = Just StreamUndefinedCondition-    streamErrorConditionFromText "unsupported-encoding" = Just StreamUnsupportedEncoding-    streamErrorConditionFromText "unsupported-feature" = Just StreamUnsupportedFeature-    streamErrorConditionFromText "unsupported-stanza-type" = Just StreamUnsupportedStanzaType-    streamErrorConditionFromText "unsupported-version" = Just StreamUnsupportedVersion-    streamErrorConditionFromText _ = Nothing+    streamErrorConditionFromText "bad-format" = StreamBadFormat+    streamErrorConditionFromText "bad-namespace-prefix" = StreamBadNamespacePrefix+    streamErrorConditionFromText "conflict" = StreamConflict+    streamErrorConditionFromText "connection-timeout" = StreamConnectionTimeout+    streamErrorConditionFromText "host-gone" = StreamHostGone+    streamErrorConditionFromText "host-unknown" = StreamHostUnknown+    streamErrorConditionFromText "improper-addressing" = StreamImproperAddressing+    streamErrorConditionFromText "internal-server-error" = StreamInternalServerError+    streamErrorConditionFromText "invalid-from" = StreamInvalidFrom+    streamErrorConditionFromText "invalid-namespace" = StreamInvalidNamespace+    streamErrorConditionFromText "invalid-xml" = StreamInvalidXml+    streamErrorConditionFromText "not-authorized" = StreamNotAuthorized+    streamErrorConditionFromText "not-well-formed" = StreamNotWellFormed+    streamErrorConditionFromText "policy-violation" = StreamPolicyViolation+    streamErrorConditionFromText "remote-connection-failed" = StreamRemoteConnectionFailed+    streamErrorConditionFromText "reset" = StreamReset+    streamErrorConditionFromText "resource-constraint" = StreamResourceConstraint+    streamErrorConditionFromText "restricted-xml" = StreamRestrictedXml+    streamErrorConditionFromText "see-other-host" = StreamSeeOtherHost+    streamErrorConditionFromText "system-shutdown" = StreamSystemShutdown+    streamErrorConditionFromText "undefined-condition" = StreamUndefinedCondition+    streamErrorConditionFromText "unsupported-encoding" = StreamUnsupportedEncoding+    streamErrorConditionFromText "unsupported-feature" = StreamUnsupportedFeature+    streamErrorConditionFromText "unsupported-stanza-type" = StreamUnsupportedStanzaType+    streamErrorConditionFromText "unsupported-version" = StreamUnsupportedVersion+    streamErrorConditionFromText _ = StreamUndefinedCondition -- §4.9.2

@@ -1,6 +1,7 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}  module Network.Xmpp.Sasl.Common where @@ -86,10 +87,7 @@  xpSaslError :: PU Text.Text SaslError xpSaslError = ("xpSaslError", "") <?>-        xpPartial ( \input -> case saslErrorFromText input of-                                   Nothing -> Left "Could not parse SASL error."-                                   Just j -> Right j)-                  saslErrorToText+        xpIso saslErrorFromText saslErrorToText   where     saslErrorToText SaslAborted              = "aborted"     saslErrorToText SaslAccountDisabled      = "account-disabled"@@ -102,18 +100,18 @@     saslErrorToText SaslMechanismTooWeak     = "mechanism-too-weak"     saslErrorToText SaslNotAuthorized        = "not-authorized"     saslErrorToText SaslTemporaryAuthFailure = "temporary-auth-failure"-    saslErrorFromText "aborted" = Just SaslAborted-    saslErrorFromText "account-disabled" = Just SaslAccountDisabled-    saslErrorFromText "credentials-expired" = Just SaslCredentialsExpired-    saslErrorFromText "encryption-required" = Just SaslEncryptionRequired-    saslErrorFromText "incorrect-encoding" = Just SaslIncorrectEncoding-    saslErrorFromText "invalid-authzid" = Just SaslInvalidAuthzid-    saslErrorFromText "invalid-mechanism" = Just SaslInvalidMechanism-    saslErrorFromText "malformed-request" = Just SaslMalformedRequest-    saslErrorFromText "mechanism-too-weak" = Just SaslMechanismTooWeak-    saslErrorFromText "not-authorized" = Just SaslNotAuthorized-    saslErrorFromText "temporary-auth-failure" = Just SaslTemporaryAuthFailure-    saslErrorFromText _ = Nothing+    saslErrorFromText "aborted" = SaslAborted+    saslErrorFromText "account-disabled" = SaslAccountDisabled+    saslErrorFromText "credentials-expired" = SaslCredentialsExpired+    saslErrorFromText "encryption-required" = SaslEncryptionRequired+    saslErrorFromText "incorrect-encoding" = SaslIncorrectEncoding+    saslErrorFromText "invalid-authzid" = SaslInvalidAuthzid+    saslErrorFromText "invalid-mechanism" = SaslInvalidMechanism+    saslErrorFromText "malformed-request" = SaslMalformedRequest+    saslErrorFromText "mechanism-too-weak" = SaslMechanismTooWeak+    saslErrorFromText "not-authorized" = SaslNotAuthorized+    saslErrorFromText "temporary-auth-failure" = SaslTemporaryAuthFailure+    saslErrorFromText _ = SaslNotAuthorized  -- Challenge element pickler. xpChallenge :: PU [Node] (Maybe Text.Text)@@ -137,10 +135,14 @@ saslInit :: Text.Text -> Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) () saslInit mechanism payload = do     r <- lift . pushElement . saslInitE mechanism $-        Text.decodeUtf8 . B64.encode <$> payload+        Text.decodeUtf8 . encodeEmpty . B64.encode <$> payload     case r of         Right () -> return ()         Left e  -> throwError $ AuthStreamFailure e+  where+    -- §6.4.2+    encodeEmpty "" = "="+    encodeEmpty x = x  -- | Pull the next element. pullSaslElement :: ErrorT AuthFailure (StateT StreamState IO) SaslElement

@@ -74,8 +74,8 @@ -- 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+iqError condition (IQRequest iqid from' _to lang' _tp _bd _attr) =+    IQError iqid Nothing from' lang' (mkStanzaError condition) Nothing []   -- | Create an IQ Result matching an IQ request@@ -86,6 +86,7 @@               , iqResultTo   = view from iqr               , iqResultLangTag = view lang iqr               , iqResultPayload = pl+              , iqResultAttributes = []               }  -- | The RECOMMENDED error type associated with an error condition. The

@@ -44,8 +44,10 @@ import           System.Log.Logger import           System.Random (randomRIO) import           Text.XML.Stream.Parse as XP+import           Lens.Family2 (over)  import           Network.Xmpp.Utilities+import qualified Network.Xmpp.Lens as L  -- "readMaybe" definition, as readMaybe is not introduced in the `base' package -- until version 4.6.@@ -133,10 +135,13 @@     response <- ErrorT $ runEventsSink $ streamS expectedTo     case response of       Right (ver, from, to, sid, lt, features)-        | (Text.unpack ver) /= "1.0" ->+        | versionFromText ver == Nothing -> closeStreamWithError+                                            StreamUnsupportedVersion Nothing+                                            "Unspecified version"+        | let v = versionFromText ver+          in isJust v && majorVersion (fromJust v) >= 2 ->             closeStreamWithError StreamUnsupportedVersion Nothing-                "Unknown version"-+              "Non-1.x version"     -- HACK: We ignore MUST-strength requirement (section 4.7.4. of RFC     -- 6120) for the sake of compatibility with jabber.org         --  | lt == Nothing ->@@ -464,7 +469,7 @@         Right (Right r) -> return $ Right r  -- Performs the given IO operation, catches any errors and re-throws everything--- except 'ResourceVanished' and IllegalOperation, in which case it will return False instead+-- except 'ResourceVanished' and IllegalOperation, which it will return. catchPush :: IO () -> IO (Either XmppFailure ()) catchPush p = ExL.catch     (p >> return (Right ()))@@ -533,7 +538,7 @@                   , streamId = Nothing                   , streamLang = Nothing                   , streamJid = Nothing-                  , streamConfiguration = config+                  , streamConfiguration = maybeSetTlsHost realm config                   }             stream' <- mkStream stream             return $ Right stream'@@ -546,12 +551,12 @@         liftIO . debugM "Pontarius.Xmpp" $ "In: " ++ (BSC8.unpack d) ++             "."         return d+    tlsIdentL = L.tlsParamsL . L.clientServerIdentificationL+    updateHost host ("", _) = (host, "")+    updateHost _ hst = hst+    maybeSetTlsHost host = over tlsIdentL (updateHost host) --- Connects to the provided hostname or IP address. If a hostname is provided, a--- DNS-SRV lookup is performed (unless `sockAddr' has been specified, in which--- case that address is used instead). If an A(AAA) record results are--- encountered, all IP addresses will be tried until a successful connection--- attempt has been made. Will return the Handle acquired, if any.+-- Connects using the specified method. Returns the Handle acquired, if any. connect :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO            (Maybe StreamHandle) connect realm config = do@@ -593,6 +598,10 @@                         "No SRV records, using fallback process."                     lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ host)                                                5222+                Just [(".", _)] -> do+                    liftIO $ infoM "Pontarius.Xmpp"+                                "SRV lookup returned \".\"; service not available"+                    throwError TcpConnectionFailure                 Just srvRecords' -> do                     lift $ debugM "Pontarius.Xmpp"                         "SRV records found, performing A/AAAA lookups."@@ -624,10 +633,11 @@         connectTo address port) :: IO (Either Ex.IOException Handle)     case result of         Right handle -> do-            debugM "Pontarius.Xmpp" "Successfully connected to HostName."+            debugM "Pontarius.Xmpp" $ "Successfully connected to " ++ show address             return $ Just handle         Left _ -> do-            debugM "Pontarius.Xmpp" "Connection to HostName could not be established."+            debugM "Pontarius.Xmpp" $+                "Connection to " ++ show address ++ " could not be established."             connectTcp remainder  #if MIN_VERSION_dns(1, 0, 0)@@ -775,7 +785,7 @@        -> IO (Either XmppFailure (Either IQError IQResult)) pushIQ iqID to tp lang body stream = runErrorT $ do     ErrorT $ pushStanza-        (IQRequestS $ IQRequest iqID Nothing to lang tp body) stream+        (IQRequestS $ IQRequest iqID Nothing to lang tp body []) stream     res <- lift $ pullStanza stream     case res of         Left e -> throwError e

@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-}+{-# LANGUAGE FlexibleContexts #-}  module Network.Xmpp.Tls where @@ -16,12 +17,14 @@ import qualified       Data.ByteString.Lazy as BL import                 Data.Conduit import                 Data.IORef+import                 Data.Monoid import                 Data.XML.Types import                 Network.DNS.Resolver (ResolvConf) import                 Network.TLS import                 Network.Xmpp.Stream import                 Network.Xmpp.Types import                 System.Log.Logger (debugM, errorM, infoM)+import                 System.X509  mkBackend :: StreamHandle -> Backend mkBackend con = Backend { backendSend = \bs -> void (streamSend con bs)@@ -54,7 +57,7 @@           . wrapExceptions           . flip withStream con           . runErrorT $ do-    conf <- gets $ streamConfiguration+    conf <- gets streamConfiguration     sState <- gets streamConnectionState     case sState of         Plain -> return ()@@ -123,7 +126,11 @@ tlsinit params backend = do     liftIO $ debugM "Pontarius.Xmpp.Tls" "TLS with debug mode enabled."     gen <- liftIO (cprgCreate <$> createEntropyPool :: IO SystemRNG)-    con <- client params gen backend+    sysCStore <- liftIO getSystemCertificateStore+    let params' = params{clientShared =+                      (clientShared params){ sharedCAStore =+                          sysCStore <> sharedCAStore (clientShared params)}}+    con <- client params' gen backend     handshake con     let src = forever $ do             dt <- liftIO $ recvData con@@ -173,20 +180,23 @@         Nothing -> throwError TcpConnectionFailure         Just h'' -> return h''     let hand = handleToStreamHandle h-    (_raw, _snk, psh, recv, ctx) <- tlsinit params $ mkBackend hand-    return $ StreamHandle { streamSend = catchPush . psh-                          , streamReceive = wrapExceptions . recv-                          , streamFlush = contextFlush ctx-                          , streamClose = bye ctx >> streamClose hand-                          }+    let params' = params{clientServerIdentification+                   = case clientServerIdentification params of+                       ("", _) -> (host, "")+                       csi -> csi+                       }+    (_raw, _snk, psh, recv, ctx) <- tlsinit params' $ mkBackend hand+    return StreamHandle{ streamSend = catchPush . psh+                       , streamReceive = wrapExceptions . recv+                       , streamFlush = contextFlush ctx+                       , streamClose = bye ctx >> streamClose hand+                       }  wrapExceptions :: IO a -> IO (Either XmppFailure a) wrapExceptions f = Ex.catches (liftM Right $ f)                  [ Ex.Handler $ return . Left . XmppIOException                  , Ex.Handler $ wrap . XmppTlsError-                 , Ex.Handler $ wrap . XmppTlsConnectionNotEstablished-                 , Ex.Handler $ wrap . XmppTlsTerminated-                 , Ex.Handler $ wrap . XmppTlsHandshakeFailed+                 , Ex.Handler $ wrap . XmppTlsException                  , Ex.Handler $ return . Left                  ]   where

@@ -22,12 +22,15 @@     , IQResponse(..)     , IQResult(..)     , LangTag (..)+    , langTagQ     , langTagFromText     , langTagToText     , parseLangTag+    , ExtendedAttribute     , Message(..)     , message     , MessageError(..)+    , messageError     , MessageType(..)     , Presence(..)     , presence@@ -37,6 +40,9 @@     , SaslFailure(..)     , StreamFeatures(..)     , Stanza(..)+    , messageS+    , messageErrorS+    , presenceS     , StanzaError(..)     , StanzaErrorCondition(..)     , StanzaErrorType(..)@@ -44,6 +50,7 @@     , XmppTlsError(..)     , StreamErrorCondition(..)     , Version(..)+    , versionFromText     , StreamHandle(..)     , Stream(..)     , StreamState(..)@@ -52,6 +59,7 @@     , ConnectionDetails(..)     , StreamConfiguration(..)     , xmppDefaultParams+    , xmppDefaultParamsStrong     , Jid(..) #if WITH_TEMPLATE_HASKELL     , jidQ@@ -89,7 +97,8 @@ import           Data.Text (Text) import qualified Data.Text as Text import           Data.Typeable(Typeable)-import           Data.XML.Types+import           Data.XML.Types as XML+import qualified Data.Text.Encoding as Text #if WITH_TEMPLATE_HASKELL import           Language.Haskell.TH import           Language.Haskell.TH.Quote@@ -138,6 +147,8 @@             | PresenceErrorS !PresenceError               deriving (Eq, Show) +type ExtendedAttribute = (XML.Name, Text)+ -- | A "request" Info/Query (IQ) stanza is one with either "get" or "set" as -- type. It always contains an xml payload. data IQRequest = IQRequest { iqRequestID      :: !Text@@ -146,6 +157,7 @@                            , iqRequestLangTag :: !(Maybe LangTag)                            , iqRequestType    :: !IQRequestType                            , iqRequestPayload :: !Element+                           , iqRequestAttributes :: ![ExtendedAttribute]                            } deriving (Eq, Show)  -- | The type of IQ request that is made.@@ -163,6 +175,7 @@                          , iqResultTo      :: !(Maybe Jid)                          , iqResultLangTag :: !(Maybe LangTag)                          , iqResultPayload :: !(Maybe Element)+                         , iqResultAttributes :: ![ExtendedAttribute]                          } deriving (Eq, Show)  -- | The answer to an IQ request that generated an error.@@ -172,6 +185,7 @@                        , iqErrorLangTag     :: !(Maybe LangTag)                        , iqErrorStanzaError :: !StanzaError                        , iqErrorPayload     :: !(Maybe Element) -- should this be []?+                       , iqErrorAttributes  :: ![ExtendedAttribute]                        } deriving (Eq, Show)  -- | The message stanza. Used for /push/ type communication.@@ -181,6 +195,7 @@                        , messageLangTag :: !(Maybe LangTag)                        , messageType    :: !MessageType                        , messagePayload :: ![Element]+                       , messageAttributes :: ![ExtendedAttribute]                        } deriving (Eq, Show)  -- | An empty message@@ -201,6 +216,7 @@                   , messageLangTag = Nothing                   , messageType    = Normal                   , messagePayload = []+                  , messageAttributes = []                   }  -- | Empty message stanza@@ -219,9 +235,31 @@                                  , messageErrorLangTag     :: !(Maybe LangTag)                                  , messageErrorStanzaError :: !StanzaError                                  , messageErrorPayload     :: ![Element]+                                 , messageErrorAttributes  :: ![ExtendedAttribute]                                  } deriving (Eq, Show) +messageError :: MessageError+messageError = MessageError { messageErrorID          = Nothing+                            , messageErrorFrom        = Nothing+                            , messageErrorTo          = Nothing+                            , messageErrorLangTag     = Nothing+                            , messageErrorStanzaError =+                                StanzaError { stanzaErrorType = Cancel+                                            , stanzaErrorCondition =+                                                  ServiceUnavailable+                                            , stanzaErrorText = Nothing+                                            , stanzaErrorApplicationSpecificCondition = Nothing+                                            }+                            , messageErrorPayload     = []+                            , messageErrorAttributes  = []+                            } +instance Default MessageError where+    def = messageError++messageErrorS :: Stanza+messageErrorS = MessageErrorS def+ -- | The type of a Message being sent -- (<http://xmpp.org/rfcs/rfc6121.html#message-syntax-type>) data MessageType = -- | The message is sent in the context of a one-to-one chat@@ -266,6 +304,7 @@                          , presenceLangTag :: !(Maybe LangTag)                          , presenceType    :: !PresenceType                          , presencePayload :: ![Element]+                         , presenceAttributes :: ![ExtendedAttribute]                          } deriving (Eq, Show)  -- | An empty presence.@@ -276,6 +315,7 @@                     , presenceLangTag  = Nothing                     , presenceType     = Available                     , presencePayload  = []+                    , presenceAttributes = []                     }  -- | Empty presence stanza@@ -292,6 +332,7 @@                                    , presenceErrorLangTag     :: !(Maybe LangTag)                                    , presenceErrorStanzaError :: !StanzaError                                    , presenceErrorPayload     :: ![Element]+                                   , presenceErrorAttributes  :: ![ExtendedAttribute]                                    } deriving (Eq, Show)  -- | @PresenceType@ holds Xmpp presence types. The "error" message type is left@@ -532,9 +573,7 @@     } deriving (Show, Eq)  data XmppTlsError = XmppTlsError TLSError-                  | XmppTlsConnectionNotEstablished TLSException-                  | XmppTlsTerminated TLSException-                  | XmppTlsHandshakeFailed TLSException+                  | XmppTlsException TLSException                     deriving (Show, Eq, Typeable)  -- | Signals an XMPP stream error or another unpredicted stream-related@@ -692,10 +731,10 @@  -- | Signals the state of the stream connection. data ConnectionState-    = Closed  -- ^ No stream has been established+    = Closed  -- ^ Stream has not been established yet     | Plain   -- ^ Stream established, but not secured via TLS     | Secured -- ^ Stream established and secured via TLS-    | Finished -- ^ Stream is closed+    | Finished -- ^ Stream was closed       deriving (Show, Eq, Typeable)  -- | Defines operations for sending, receiving, flushing, and closing on a@@ -1009,8 +1048,9 @@             guard $ Text.all (`Set.notMember` prohibMap) l''             l''' <- nonEmpty l''             return $ Just l'''-    domainPart' <- SP.runStringPrep (SP.namePrepProfile False) d+    domainPart' <- SP.runStringPrep (SP.namePrepProfile False) (stripSuffix d)     guard $ validDomainPart domainPart'+    guard $ validPartLength domainPart'     domainPart <- nonEmpty domainPart'     resourcePart <- case r of         Nothing -> return Nothing@@ -1026,7 +1066,10 @@                                           -- checks      validPartLength :: Text -> Bool-    validPartLength p = Text.length p > 0 && Text.length p < 1024+    validPartLength p = Text.length p > 0+                        && BS.length (Text.encodeUtf8 p) < 1024+    -- RFC6122 §2.2+    stripSuffix t = if Text.last t == '.' then Text.init t else t  -- | Returns 'True' if the JID is /bare/, that is, it doesn't have a resource -- part, and 'False' otherwise.@@ -1149,11 +1192,14 @@                        | 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+                         -- ^ Use a custom method to create a StreamHandle. This                          -- will also be used by reconnect. For example, to                          -- establish TLS before starting the stream as done by                          -- GCM, see 'connectTls'. You can also return an-                         -- already established connection.+                         -- already established connection. This method should+                         -- also return a hostname that is used for TLS+                         -- signature verification. If startTLS is not used it+                         -- can be left empty  -- | Configuration settings related to the stream. data StreamConfiguration =@@ -1182,9 +1228,9 @@                         , tlsParams :: ClientParams                         } --- | Default parameters for TLS. Those are the default client parameters from the tls package with the ciphers set to ciphersuite_strong-xmppDefaultParams :: ClientParams-xmppDefaultParams = (defaultParamsClient "" BS.empty)+-- | Default parameters for TLS restricted to strong ciphers+xmppDefaultParamsStrong :: ClientParams+xmppDefaultParamsStrong = (defaultParamsClient "" BS.empty)                         { clientSupported = def                             { supportedCiphers = ciphersuite_strong                                                  ++ [ cipher_AES256_SHA1@@ -1192,6 +1238,15 @@                                                     ]                             }                         }++-- | Default parameters for TLS+xmppDefaultParams :: ClientParams+xmppDefaultParams = (defaultParamsClient "" BS.empty)+                        { clientSupported = def+                            { supportedCiphers = ciphersuite_all+                            }+                        }+  instance Default StreamConfiguration where     def = StreamConfiguration { preferredLang     = Nothing

@@ -0,0 +1,14 @@+module Main where++import Test.Tasty.HUnit+import Test.Tasty++import qualified Run.SendReceive as SendReceive+import qualified Run.Google as Google++sendReceiveTest = testCase "send and receive" SendReceive.run+googleTest = testCase "connect to google service" Google.connectGoogle++main = defaultMain $ testGroup "connection tests" [ sendReceiveTest+                                                  , googleTest+                                                  ]

@@ -0,0 +1,117 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE LambdaCase #-}+++module Run.Payload where++import           Control.Monad+import           Control.Monad.STM+import qualified Data.Text as Text+import           Data.XML.Pickle+import           Data.XML.Types+import           Network.Xmpp+import           Network.Xmpp.Internal+import           System.Log.Logger+import           Test.HUnit hiding (Node)+import           Test.Hspec.Expectations++data Payload = Payload+               { payloadCounter :: !Int+               , ignoreFlag     :: !Bool+               , errorFlag      :: !Bool+               , payloadText    :: !Text.Text+               } deriving (Eq, Show)++testNS :: Text.Text+testNS = "xmpp:library:test"++payloadP :: PU [Node] Payload+payloadP = xpWrap (\((counter,iFlag, eFlag) , message)+                      -> Payload counter iFlag eFlag message)+                  (\(Payload counter iFlag eFlag message)+                      ->((counter,iFlag, eFlag) , message)) $+                   xpElem (Name "request" (Just testNS) Nothing)+                      (xp3Tuple+                        (xpAttr "counter" xpPrim)+                        (xpAttr "ignoreFlag" xpPrim)+                        (xpAttr "errorFlag" xpPrim)+                      )+                      (xpElemNodes (Name "message" (Just testNS) Nothing)+                          (xpContent xpId))++invertPayload :: Payload -> Payload+invertPayload (Payload count _iFlag _eFlag message) =+    Payload (count + 1) False False (Text.reverse message)++iqResponder :: Session -> IO ()+iqResponder context = do+    chan' <- listenIQ Set testNS context+    chan <- case chan' of+        Left _ -> do+            assertFailure "Channel was already taken"+            undefined+        Right c -> return c+    forever $ do+        next <- atomically $ chan+        let Right payload = unpickleElem payloadP . iqRequestPayload $+                              iqRequestBody next+        let answerPayload = invertPayload payload+        let answerBody = pickleElem payloadP answerPayload+        unless (ignoreFlag payload) . void $+            case errorFlag payload of+                False -> answerIQ next (Right $ Just answerBody) []+                True -> answerIQ next (Left $ mkStanzaError NotAcceptable) []++testString :: Text.Text+testString = "abc ÄÖ>"++testPayload :: Jid -> Session -> IO ()+testPayload them session = do+    infoM "Pontarius.Xmpp" "Testing IQ send/receive"+    let pl1 = Payload 1 False False testString+        body1 = pickleElem payloadP pl1+    resp <- sendIQ' (Just 3000000) (Just them) Set Nothing body1 [] session++    case resp of+        Left e -> assertFailure $ "Could not send pl1" ++ show e+        Right (IQResponseError e) ->+            assertFailure $ "Unexpected IQ error" ++ show e+        Right (IQResponseResult IQResult{iqResultPayload = Just pl}) -> do+            case unpickleElem payloadP pl of+                Left e -> assertFailure $ "Error unpickling response p1"+                                           ++ ppUnpickleError e+                Right r -> do+                    payloadCounter r `shouldBe` 2+                    payloadText r `shouldBe` Text.reverse testString+        Right (IQResponseResult _) ->+            assertFailure "IQ result didn't contain payload"+    infoM "Pontarius.Xmpp" "Done testing IQ send/receive"+    ----------------------+    -- Timeout test+    ----------------------+    let pl2 = Payload 2 True False testString+        body2 = pickleElem payloadP pl2+    infoM "Pontarius.Xmpp" "Testing timeout"+    resp <- sendIQ' (Just 1000000) (Just them) Set Nothing body2 [] session+    case resp of+        Left IQTimeOut -> return ()+        Left e -> assertFailure $ "Unexpected send error" ++ show e+        Right r -> assertFailure $ "Unexpected IQ answer" ++ show r+    infoM "Pontarius.Xmpp" "IQ timed out (as expected)"+    ----------------------+    -- Error test+    ----------------------+    infoM "Pontarius.Xmpp" "Testing IQ error"+    let pl3 = Payload 3 False True testString+        body3 = pickleElem payloadP pl3+    resp <- sendIQ' (Just 3000000) (Just them) Set Nothing body3 [] session+    case resp of+        Left e -> assertFailure $ "Unexpected send error" ++ show e+        Right (IQResponseError e) ->+             stanzaErrorCondition (iqErrorStanzaError e) `shouldBe` NotAcceptable++        Right r -> assertFailure $ "Received unexpected IQ response" ++ show r+    infoM "Pontarius.Xmpp" "Received expected error"

@@ -5,7 +5,7 @@ import           Data.Char import           Data.Maybe import qualified Data.Text as Text-import           Network.Xmpp.Types+import           Network.Xmpp.Internal hiding (elements) import           Test.QuickCheck import           Test.QuickCheck.Instances() import qualified Text.CharRanges as Ranges