diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -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 diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -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 diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -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. diff --git a/source/Network/Xmpp/Concurrent/Basic.hs b/source/Network/Xmpp/Concurrent/Basic.hs --- a/source/Network/Xmpp/Concurrent/Basic.hs +++ b/source/Network/Xmpp/Concurrent/Basic.hs @@ -1,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) diff --git a/source/Network/Xmpp/Concurrent/IQ.hs b/source/Network/Xmpp/Concurrent/IQ.hs --- a/source/Network/Xmpp/Concurrent/IQ.hs +++ b/source/Network/Xmpp/Concurrent/IQ.hs @@ -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 ) [] diff --git a/source/Network/Xmpp/Concurrent/Presence.hs b/source/Network/Xmpp/Concurrent/Presence.hs --- a/source/Network/Xmpp/Concurrent/Presence.hs +++ b/source/Network/Xmpp/Concurrent/Presence.hs @@ -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 diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -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. diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -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 diff --git a/source/Network/Xmpp/IM.hs b/source/Network/Xmpp/IM.hs --- a/source/Network/Xmpp/IM.hs +++ b/source/Network/Xmpp/IM.hs @@ -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 diff --git a/source/Network/Xmpp/IM/Presence.hs b/source/Network/Xmpp/IM/Presence.hs --- a/source/Network/Xmpp/IM/Presence.hs +++ b/source/Network/Xmpp/IM/Presence.hs @@ -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" diff --git a/source/Network/Xmpp/IM/PresenceTracker.hs b/source/Network/Xmpp/IM/PresenceTracker.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/IM/PresenceTracker.hs @@ -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 diff --git a/source/Network/Xmpp/IM/PresenceTracker/Types.hs b/source/Network/Xmpp/IM/PresenceTracker/Types.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/IM/PresenceTracker/Types.hs @@ -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) diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs --- a/source/Network/Xmpp/IM/Roster.hs +++ b/source/Network/Xmpp/IM/Roster.hs @@ -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" diff --git a/source/Network/Xmpp/Internal.hs b/source/Network/Xmpp/Internal.hs --- a/source/Network/Xmpp/Internal.hs +++ b/source/Network/Xmpp/Internal.hs @@ -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 diff --git a/source/Network/Xmpp/Lens.hs b/source/Network/Xmpp/Lens.hs --- a/source/Network/Xmpp/Lens.hs +++ b/source/Network/Xmpp/Lens.hs @@ -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 ------------------ diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -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 diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -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 diff --git a/source/Network/Xmpp/Stanza.hs b/source/Network/Xmpp/Stanza.hs --- a/source/Network/Xmpp/Stanza.hs +++ b/source/Network/Xmpp/Stanza.hs @@ -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 diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -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 diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -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 diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -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 -- () 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 diff --git a/tests/Run.hs b/tests/Run.hs new file mode 100644 --- /dev/null +++ b/tests/Run.hs @@ -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 + ] diff --git a/tests/Run/Payload.hs b/tests/Run/Payload.hs new file mode 100644 --- /dev/null +++ b/tests/Run/Payload.hs @@ -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" diff --git a/tests/Tests/Arbitrary/Xmpp.hs b/tests/Tests/Arbitrary/Xmpp.hs --- a/tests/Tests/Arbitrary/Xmpp.hs +++ b/tests/Tests/Arbitrary/Xmpp.hs @@ -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