diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs index c98a8ff..452aa4c 100644 --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -37,7 +37,7 @@ readWorker onStanza onConnectionClosed stateRef = -- necessarily be interruptible s <- atomically $ do con <- readTMVar stateRef - state <- cState <$> readTMVar con + state <- streamState <$> readTMVar con when (state == Closed) retry return con @@ -83,7 +83,7 @@ startThreadsWith :: (Stanza -> IO ()) TMVar (TMVar Stream), ThreadId)) startThreadsWith stanzaHandler eh con = do - read <- withStream' (gets $ cSend . cHandle >>= \d -> return $ Right d) con + read <- withStream' (gets $ streamSend . streamHandle >>= \d -> return $ Right d) con case read of Left e -> return $ Left e Right read' -> do diff --git a/source/Network/Xmpp/Internal.hs b/source/Network/Xmpp/Internal.hs index 99f8fad..d775dc3 100644 --- a/source/Network/Xmpp/Internal.hs +++ b/source/Network/Xmpp/Internal.hs @@ -20,7 +20,7 @@ module Network.Xmpp.Internal ( Stream(..) , StreamState(..) , StreamHandle(..) - , ServerFeatures(..) + , StreamFeatures(..) , openStream , withStream , startTls diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs index 93fcdc6..198c684 100644 --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -253,10 +253,10 @@ xpStream = xpElemAttrs ) -- Pickler/Unpickler for the stream features - TLS, SASL, and the rest. -xpStreamFeatures :: PU [Node] ServerFeatures +xpStreamFeatures :: PU [Node] StreamFeatures xpStreamFeatures = xpWrap - (\(tls, sasl, rest) -> SF tls (mbl sasl) rest) - (\(SF tls sasl rest) -> (tls, lmb sasl, rest)) + (\(tls, sasl, rest) -> StreamFeatures tls (mbl sasl) rest) + (\(StreamFeatures tls sasl rest) -> (tls, lmb sasl, rest)) (xpElemNodes (Name "features" diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index e6511a3..aedc51f 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -71,11 +71,11 @@ xmppSasl :: [SaslHandler] -- ^ Acceptable authentication mechanisms and their xmppSasl handlers = withStream $ do -- Chooses the first mechanism that is acceptable by both the client and the -- server. - mechanisms <- gets $ saslMechanisms . cFeatures + mechanisms <- gets $ streamSaslMechanisms . streamFeatures case (filter (\(name, _) -> name `elem` mechanisms)) handlers of [] -> return $ Right $ Just $ AuthNoAcceptableMechanism mechanisms (_name, handler):_ -> do - cs <- gets cState + cs <- gets streamState case cs of Closed -> return . Right $ Just AuthNoStream _ -> do @@ -134,7 +134,7 @@ xmppBind rsrc c = runErrorT $ do case jid of Right jid' -> do ErrorT $ withStream (do - modify $ \s -> s{cJid = Just jid'} + modify $ \s -> s{streamJid = Just jid'} return $ Right jid') c -- not pretty return jid' otherwise -> throwError XmppOtherFailure diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs index 015086b..8d83d40 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs @@ -45,7 +45,7 @@ xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username) -> SaslM () xmppDigestMd5 authcid authzid password = do (ac, az, pw) <- prepCredentials authcid authzid password - hn <- gets cHostName + hn <- gets streamHostname xmppDigestMd5' (fromJust hn) ac az pw where xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> SaslM () diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index f947692..b44d270 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -1,4 +1,5 @@ {-# OPTIONS_HADDOCK hide #-} + {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -92,11 +93,11 @@ startStream = runErrorT $ do stream <- liftIO $ mkStream state -- Set the `from' (which is also the expected to) attribute depending on the -- state of the stream. - let expectedTo = case cState state of - Plain -> if cJidWhenPlain state - then cJid state else Nothing - Secured -> cJid state - case cHostName state of + let expectedTo = case streamState state of + Plain -> if includeJidWhenPlain state + then toJid state else Nothing + Secured -> toJid state + case streamHostname state of Nothing -> throwError XmppOtherFailure -- TODO: When does this happen? Just hostname -> lift $ do pushXmlDecl @@ -105,7 +106,7 @@ startStream = runErrorT $ do , expectedTo , Just (Jid Nothing hostname Nothing) , Nothing - , cPreferredLang state + , preferredLang state ) response <- ErrorT $ runEventsSink $ runErrorT $ streamS expectedTo case response of @@ -117,15 +118,15 @@ startStream = runErrorT $ do | lt == Nothing -> closeStreamWithError stream StreamInvalidXml Nothing -- If `from' is set, we verify that it's the correct one. TODO: Should we check against the realm instead? - | isJust from && (from /= Just (Jid Nothing (fromJust $ cHostName state) Nothing)) -> + | isJust from && (from /= Just (Jid Nothing (fromJust $ streamHostname state) Nothing)) -> closeStreamWithError stream StreamInvalidFrom Nothing | to /= expectedTo -> closeStreamWithError stream StreamUndefinedCondition (Just $ Element "invalid-to" [] []) -- TODO: Suitable? | otherwise -> do - modify (\s -> s{ cFeatures = features - , cStreamLang = lt - , cStreamId = id - , cFrom = from + modify (\s -> s{ streamFeatures = features + , streamLang = lt + , streamId = id + , streamFrom = from } ) return () -- Unpickling failed - we investigate the element. @@ -180,10 +181,10 @@ flattenAttrs attrs = Prelude.map (\(name, content) -> -- and calls xmppStartStream. restartStream :: StateT Stream IO (Either XmppFailure ()) restartStream = do - raw <- gets (cRecv . cHandle) + raw <- gets (streamReceive . streamHandle) let newSource = DCI.ResumableSource (loopRead raw $= XP.parseBytes def) (return ()) - modify (\s -> s{cEventSource = newSource }) + modify (\s -> s{streamEventSource = newSource }) startStream where loopRead read = do @@ -203,7 +204,7 @@ streamS :: Maybe Jid -> StreamSink (Either Element ( Text , Maybe Jid , Maybe Text , Maybe LangTag - , ServerFeatures )) + , StreamFeatures )) streamS expectedTo = do header <- xmppStreamHeader case header of @@ -222,7 +223,7 @@ streamS expectedTo = do case unpickleElem xpStream el of Left _ -> return $ Left el Right r -> return $ Right r - xmppStreamFeatures :: StreamSink ServerFeatures + xmppStreamFeatures :: StreamSink StreamFeatures xmppStreamFeatures = do e <- lift $ elements =$ CL.head case e of @@ -246,8 +247,8 @@ openStream address port hostname = do -- Surpresses StreamEndFailure exceptions, but may throw a StreamCloseError. closeStreams :: TMVar Stream -> IO (Either XmppFailure [Element]) closeStreams = withStream $ do - send <- gets (cSend . cHandle) - cc <- gets (cClose . cHandle) + send <- gets (streamSend . streamHandle) + cc <- gets (streamClose . streamHandle) liftIO $ send "" void $ liftIO $ forkIO $ do threadDelay 3000000 -- TODO: Configurable value @@ -282,7 +283,7 @@ wrapIOException action = do pushElement :: Element -> StateT Stream IO (Either XmppFailure Bool) pushElement x = do - send <- gets (cSend . cHandle) + send <- gets (streamSend . streamHandle) wrapIOException $ send $ renderElement x -- | Encode and send stanza @@ -295,21 +296,21 @@ pushStanza s = withStream' . pushElement $ pickleElem xpStanza s -- XMPP streams. RFC 6120 defines XMPP only in terms of XML 1.0. pushXmlDecl :: StateT Stream IO (Either XmppFailure Bool) pushXmlDecl = do - con <- gets cHandle - wrapIOException $ (cSend con) "" + con <- gets streamHandle + wrapIOException $ (streamSend con) "" pushOpenElement :: Element -> StateT Stream IO (Either XmppFailure Bool) pushOpenElement e = do - sink <- gets (cSend . cHandle) + sink <- gets (streamSend . streamHandle) wrapIOException $ sink $ renderOpenElement e -- `Connect-and-resumes' the given sink to the stream source, and pulls a -- `b' value. runEventsSink :: Sink Event IO b -> StateT Stream IO (Either XmppFailure b) runEventsSink snk = do -- TODO: Wrap exceptions? - source <- gets cEventSource + source <- gets streamEventSource (src', r) <- lift $ source $$++ snk - modify (\s -> s{cEventSource = src'}) + modify (\s -> s{streamEventSource = src'}) return $ Right r pullElement :: StateT Stream IO (Either XmppFailure Element) @@ -362,25 +363,25 @@ catchPush p = ExL.catch -- Stream state used when there is no connection. xmppNoStream :: Stream -xmppNoStream = Stream - { cHandle = StreamHandle { cSend = \_ -> return False - , cRecv = \_ -> ExL.throwIO - XmppOtherFailure - , cFlush = return () - , cClose = return () - } - , cEventSource = DCI.ResumableSource zeroSource (return ()) - , cFeatures = SF Nothing [] [] - , cState = Closed - , cHostName = Nothing - , cJid = Nothing - , cStreamLang = Nothing - , cStreamId = Nothing - , cPreferredLang = Nothing - , cToJid = Nothing - , cJidWhenPlain = False - , cFrom = Nothing - } +xmppNoStream = Stream { + streamState = Closed + , streamHandle = StreamHandle { streamSend = \_ -> return False + , streamReceive = \_ -> ExL.throwIO + XmppOtherFailure + , streamFlush = return () + , streamClose = return () + } + , streamEventSource = DCI.ResumableSource zeroSource (return ()) + , streamFeatures = StreamFeatures Nothing [] [] + , streamHostname = Nothing + , streamFrom = Nothing + , streamId = Nothing + , streamLang = Nothing + , streamJid = Nothing + , preferredLang = Nothing + , toJid = Nothing + , includeJidWhenPlain = False + } where zeroSource :: Source IO output zeroSource = liftIO . ExL.throwIO $ XmppOtherFailure @@ -396,35 +397,35 @@ connectTcp host port hostname = do let eSource = DCI.ResumableSource ((sourceHandle h $= logConduit) $= XP.parseBytes def) (return ()) - let hand = StreamHandle { cSend = \d -> do + let hand = StreamHandle { streamSend = \d -> do let d64 = encode d debugM "Pontarius.Xmpp" $ "Sending TCP data: " ++ (BSC8.unpack d64) ++ "." catchPush $ BS.hPut h d - , cRecv = \n -> do + , streamReceive = \n -> do d <- BS.hGetSome h n let d64 = encode d debugM "Pontarius.Xmpp" $ "Received TCP data: " ++ (BSC8.unpack d64) ++ "." return d - , cFlush = hFlush h - , cClose = hClose h + , streamFlush = hFlush h + , streamClose = hClose h } let stream = Stream - { cHandle = hand - , cEventSource = eSource - , cFeatures = (SF Nothing [] []) - , cState = Plain - , cHostName = (Just hostname) - , cJid = Nothing - , cPreferredLang = Nothing -- TODO: Allow user to set - , cStreamLang = Nothing - , cStreamId = Nothing - , cToJid = Nothing -- TODO: Allow user to set - , cJidWhenPlain = False -- TODO: Allow user to set - , cFrom = Nothing + { streamState = Plain + , streamHandle = hand + , streamEventSource = eSource + , streamFeatures = StreamFeatures Nothing [] [] + , streamHostname = (Just hostname) + , streamFrom = Nothing + , streamId = Nothing + , streamLang = Nothing + , streamJid = Nothing + , preferredLang = Nothing -- TODO: Allow user to set + , toJid = Nothing -- TODO: Allow user to set + , includeJidWhenPlain = False -- TODO: Allow user to set } stream' <- mkStream stream return $ Right stream' @@ -441,7 +442,7 @@ connectTcp host port hostname = do -- killStream :: TMVar Stream -> IO (Either ExL.SomeException ()) killStream :: TMVar Stream -> IO (Either XmppFailure ()) killStream = withStream $ do - cc <- gets (cClose . cHandle) + cc <- gets (streamClose . streamHandle) err <- wrapIOException cc -- (ExL.try cc :: IO (Either ExL.SomeException ())) put xmppNoStream diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs index 80ab2f7..eccfb93 100644 --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -22,10 +22,10 @@ import Network.Xmpp.Types import Control.Concurrent.STM.TMVar -mkBackend con = Backend { backendSend = \bs -> void (cSend con bs) - , backendRecv = cRecv con - , backendFlush = cFlush con - , backendClose = cClose con +mkBackend con = Backend { backendSend = \bs -> void (streamSend con bs) + , backendRecv = streamReceive con + , backendFlush = streamFlush con + , backendClose = streamClose con } where cutBytes n = do @@ -78,14 +78,14 @@ startTls :: TLS.TLSParams -> TMVar Stream -> IO (Either XmppFailure ()) startTls params con = Ex.handle (return . Left . TlsError) . flip withStream con . runErrorT $ do - features <- lift $ gets cFeatures - state <- gets cState + features <- lift $ gets streamFeatures + state <- gets streamState case state of Plain -> return () Closed -> throwError XmppNoStream Secured -> throwError TlsStreamSecured - con <- lift $ gets cHandle - when (stls features == Nothing) $ throwError TlsNoServerSupport + con <- lift $ gets streamHandle + when (streamTls features == Nothing) $ throwError TlsNoServerSupport lift $ pushElement starttlsE answer <- lift $ pullElement case answer of @@ -93,12 +93,12 @@ startTls params con = Ex.handle (return . Left . TlsError) Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] []) -> return $ Right () Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _) -> return $ Left XmppOtherFailure (raw, _snk, psh, read, ctx) <- lift $ TLS.tlsinit debug params (mkBackend con) - let newHand = StreamHandle { cSend = catchPush . psh - , cRecv = read - , cFlush = contextFlush ctx - , cClose = bye ctx >> cClose con + let newHand = StreamHandle { streamSend = catchPush . psh + , streamReceive = read + , streamFlush = contextFlush ctx + , streamClose = bye ctx >> streamClose con } - lift $ modify ( \x -> x {cHandle = newHand}) + lift $ modify ( \x -> x {streamHandle = newHand}) either (lift . Ex.throwIO) return =<< lift restartStream - modify (\s -> s{cState = Secured}) + modify (\s -> s{streamState = Secured}) return () diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 0a686cd..5697ac9 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -22,7 +22,7 @@ module Network.Xmpp.Types , PresenceType(..) , SaslError(..) , SaslFailure(..) - , ServerFeatures(..) + , StreamFeatures(..) , Stanza(..) , StanzaError(..) , StanzaErrorCondition(..) @@ -755,52 +755,63 @@ langTagParser = do tagChars :: [Char] tagChars = ['a'..'z'] ++ ['A'..'Z'] -data ServerFeatures = SF - { stls :: !(Maybe Bool) - , saslMechanisms :: ![Text.Text] - , other :: ![Element] +data StreamFeatures = StreamFeatures + { streamTls :: !(Maybe Bool) + , streamSaslMechanisms :: ![Text.Text] + , streamOtherFeatures :: ![Element] -- TODO: All feature elements instead? } deriving Show --- | Signals the state of the connection. +-- | Signals the state of the stream connection. data StreamState - = Closed -- ^ No stream at this point. - | Plain -- ^ Stream established, but not secured. - | Secured -- ^ Stream established and secured via TLS. + = Closed -- ^ No stream has been established + | Plain -- ^ Stream established, but not secured via TLS + | Secured -- ^ Stream established and secured via TLS deriving (Show, Eq, Typeable) -- | Defines operations for sending, receiving, flushing, and closing on a --- connection. +-- stream. data StreamHandle = - StreamHandle { cSend :: BS.ByteString -> IO Bool - , cRecv :: Int -> IO BS.ByteString - -- This is to hold the state of the XML parser (otherwise - -- we will receive EventBeginDocument events and forget - -- about name prefixes). - , cFlush :: IO () - , cClose :: IO () + StreamHandle { streamSend :: BS.ByteString -> IO Bool + , streamReceive :: Int -> IO BS.ByteString + -- This is to hold the state of the XML parser (otherwise we + -- will receive EventBeginDocument events and forget about + -- name prefixes). (TODO: Clarify) + , streamFlush :: IO () + , streamClose :: IO () } data Stream = Stream - { cState :: !StreamState -- ^ State of connection - , cHandle :: StreamHandle -- ^ Handle to send, receive, flush, and close - -- on the connection. - , cEventSource :: ResumableSource IO Event -- ^ Event conduit source, and - -- its associated finalizer - , cFeatures :: !ServerFeatures -- ^ Features as advertised by the server - , cHostName :: !(Maybe Text) -- ^ Hostname of the server - , cJid :: !(Maybe Jid) -- ^ Our JID - , cPreferredLang :: !(Maybe LangTag) -- ^ Default language when no explicit + { -- | State of the stream - 'Closed', 'Plain', or 'Secured' + streamState :: !StreamState -- ^ State of connection + -- | Functions to send, receive, flush, and close on the stream + , streamHandle :: StreamHandle + -- | Event conduit source, and its associated finalizer + , streamEventSource :: ResumableSource IO Event + -- | Stream features advertised by the server + , streamFeatures :: !StreamFeatures -- TODO: Maybe? + -- | The hostname we specified for the connection + , streamHostname :: !(Maybe Text) + -- | The hostname specified in the server's stream element's + -- `from' attribute + , streamFrom :: !(Maybe Jid) + -- | The identifier specified in the server's stream element's + -- `id' attribute + , streamId :: !(Maybe Text) + -- | The language tag value specified in the server's stream + -- element's `langtag' attribute; will be a `Just' value once + -- connected to the server + -- TODO: Verify + , streamLang :: !(Maybe LangTag) + -- | Our JID as assigned by the server + , streamJid :: !(Maybe Jid) + -- TODO: Move the below fields to a configuration record + , preferredLang :: !(Maybe LangTag) -- ^ Default language when no explicit -- language tag is set - , cStreamLang :: !(Maybe LangTag) -- ^ Will be a `Just' value once connected - -- to the server. - , cStreamId :: !(Maybe Text) -- ^ Stream ID as specified by the server. - , cToJid :: !(Maybe Jid) -- ^ JID to include in the stream element's `to' + , toJid :: !(Maybe Jid) -- ^ JID to include in the stream element's `to' -- attribute when the connection is secured. See -- also below. - , cJidWhenPlain :: !Bool -- ^ Whether or not to also include the Jid when + , includeJidWhenPlain :: !Bool -- ^ Whether or not to also include the Jid when -- the connection is plain. - , cFrom :: !(Maybe Jid) -- ^ From as specified by the server in the stream - -- element's `from' attribute. } withStream :: StateT Stream IO (Either XmppFailure c) -> TMVar Stream -> IO (Either XmppFailure c)