asakul
/
pontarius-xmpp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

Merge branch 'master' of https://github.com/nejla/pontarius

master
Philipp Balzarek 14 years ago
parent
5855d61e31 f0ebab5774
commit
3a2a1ac557
7 changed files with 245 additions and 233 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 85
      src/Network/XMPP.hs
  2. 4
      src/Network/XMPP/Marshal.hs
  3. 68
      src/Network/XMPP/Monad.hs
  4. 1
      src/Network/XMPP/Pickle.hs
  5. 6
      src/Network/XMPP/SASL.hs
  6. 66
      src/Network/XMPP/Stream.hs
  7. 28
      src/Network/XMPP/TLS.hs

85
src/Network/XMPP.hs
Unescape View File

@ -1,34 +1,23 @@
-- Copyright © 2010-2012 Jon Kristensen.
-- Copyright 2012 Philipp Balzarek
-- See the LICENSE file in the
-- Pontarius distribution for more details.
-- | -- |
-- Module: $Header$ -- Module: $Header$
-- Description: Pontarius API -- Description: A work in progress client implementation of RFC 6120 (XMPP:
-- Copyright: Copyright © 2010-2012 Jon Kristensen -- Core).
-- License: Apache License 2.0 -- License: Apache License 2.0
-- --
-- Maintainer: jon.kristensen@nejla.com -- Maintainer: jon.kristensen@nejla.com
-- Stability: unstable -- Stability: unstable
-- Portability: portable -- Portability: portable
-- --
-- The Extensible Messaging and Presence Protocol (XMPP) is an open technology for -- The Extensible Messaging and Presence Protocol (XMPP) is an open technology
-- real-time communication, which powers a wide range of applications including -- for real-time communication, which powers a wide range of applications
-- instant messaging, presence, multi-party chat, voice and video calls, -- including instant messaging, presence, multi-party chat, voice and video
-- collaboration, lightweight middleware, content syndication, and generalized -- calls, collaboration, lightweight middleware, content syndication, and
-- routing of XML data. -- generalized routing of XML data. Pontarius an XMPP client library,
-- Pontarius an XMPP client library, implementing the core capabilities of XMPP -- implementing the core capabilities of XMPP (RFC 6120).
-- (RFC 6120).
--
-- Developers using this library are assumed to understand how XMPP
-- works.
--
-- This module will be documented soon.
-- --
-- Note that we are not recommending anyone to use Pontarius XMPP at -- Note that we are not recommending anyone to use Pontarius XMPP at this time
-- this time as it's still in an experimental stage and will have its -- as it's still in an experimental stage and will have its API and data types
-- API and data types modified frequently. -- modified frequently.
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}
@ -46,37 +35,37 @@ module Network.XMPP
, setConnectionClosedHandler , setConnectionClosedHandler
-- * JID -- * JID
-- | A JID (historically: Jabber ID) is XMPPs native format -- | A JID (historically: Jabber ID) is XMPPs native format
-- for addressing entities in the network. It is somewhat similar to an -- for addressing entities in the network. It is somewhat similar to an e-mail
-- email-address but contains three parts instead of two: -- address but contains three parts instead of two:
, JID(..) , JID(..)
-- * Stanzas -- * Stanzas
-- | @Stanzas@ are the the smallest unit of communication in @XMPP@. They -- | @Stanzas@ are the the smallest unit of communication in @XMPP@. They come
-- come in 3 flavors: -- in 3 flavors:
-- --
-- * @'Message'@, for traditional IM-style message passing between peers -- * @'Message'@, for traditional push-style message passing between peers
-- --
-- * @'Presence'@, for communicating status updates -- * @'Presence'@, for communicating status updates
-- --
-- * IQ (info/query), with a request-response semantics -- * IQ (info/query), for request-response semantics communication
-- --
-- All stanza types have the following attributes in common: -- All stanza types have the following attributes in common:
-- --
-- * The /id/ attribute is used by the originating entity to track -- * The /id/ attribute is used by the originating entity to track any
-- any response or error stanza that it might receive in relation to -- response or error stanza that it might receive in relation to the
-- the generated stanza from another entity (such as an intermediate -- generated stanza from another entity (such as an intermediate server or
-- server or the intended recipient). It is up to the originating -- the intended recipient). It is up to the originating entity whether the
-- entity whether the value of the 'id' attribute is unique only -- value of the 'id' attribute is unique only within its current stream or
-- within its current stream or unique globally. -- unique globally.
-- --
-- * The /from/ attribute specifies the JID of the sender. -- * The /from/ attribute specifies the JID of the sender.
-- --
-- * The /to/ attribute specifies the JID of the intended recipient -- * The /to/ attribute specifies the JID of the intended recipient for the
-- for the stanza. -- stanza.
-- --
-- * The /type/ attribute specifies the purpose or context of the -- * The /type/ attribute specifies the purpose or context of the message,
-- message, presence, or IQ stanza. The particular allowable values -- presence, or IQ stanza. The particular allowable values for the 'type'
-- for the 'type' attribute vary depending on whether the stanza is -- attribute vary depending on whether the stanza is a message, presence,
-- a message, presence, or IQ stanza. -- or IQ stanza.
-- ** Messages -- ** Messages
-- | The /message/ stanza is a /push/ mechanism whereby one entity pushes -- | The /message/ stanza is a /push/ mechanism whereby one entity pushes
@ -97,10 +86,9 @@ module Network.XMPP
, waitForMessageError , waitForMessageError
, filterMessages , filterMessages
-- ** Presence -- ** Presence
-- | The /presence/ stanza is a specialized /broadcast/ -- | The /presence/ stanza is a specialized /broadcast/ or /publish-subscribe/
-- or /publish-subscribe/ mechanism, whereby multiple entities -- mechanism, whereby multiple entities receive information about an entity to
-- receive information about an entity to which they have -- which they have subscribed.
-- subscribed.
-- --
-- <http://xmpp.org/rfcs/rfc6120.html#stanzas-semantics-presence> -- <http://xmpp.org/rfcs/rfc6120.html#stanzas-semantics-presence>
, Presence(..) , Presence(..)
@ -118,11 +106,10 @@ module Network.XMPP
-- an entity to make a request of, and receive a response from, another -- an entity to make a request of, and receive a response from, another
-- entity. The data content and precise semantics of the request and response -- entity. The data content and precise semantics of the request and response
-- is defined by the schema or other structural definition associated with the -- is defined by the schema or other structural definition associated with the
-- XML namespace that -- XML namespace that qualifies the direct child element of the IQ element. IQ
-- qualifies the direct child element of the IQ element. IQ interactions -- interactions follow a common pattern of structured data exchange such as
-- follow a common pattern of structured data -- get/result or set/result (although an error can be returned in reply to a
-- exchange such as get/result or set/result (although an error can be returned -- request if appropriate)
-- in reply to a request if appropriate)
-- --
-- <http://xmpp.org/rfcs/rfc6120.html#stanzas-semantics-iq> -- <http://xmpp.org/rfcs/rfc6120.html#stanzas-semantics-iq>
, IQRequest(..) , IQRequest(..)

4
src/Network/XMPP/Marshal.hs
Unescape View File

@ -14,8 +14,8 @@ import Data.XML.Types
import Network.XMPP.Pickle import Network.XMPP.Pickle
import Network.XMPP.Types import Network.XMPP.Types
xpStreamEntity :: PU [Node] (Either XmppStreamError Stanza) xpStreamStanza :: PU [Node] (Either XmppStreamError Stanza)
xpStreamEntity = xpEither xpStreamError xpStanza xpStreamStanza = xpEither xpStreamError xpStanza
xpStanza :: PU [Node] Stanza xpStanza :: PU [Node] Stanza
xpStanza = xpAlt stanzaSel xpStanza = xpAlt stanzaSel

68
src/Network/XMPP/Monad.hs
Unescape View File

@ -32,21 +32,23 @@ import Text.XML.Stream.Elements
import Text.XML.Stream.Parse as XP import Text.XML.Stream.Parse as XP
import Text.XML.Unresolved(InvalidEventStream(..)) import Text.XML.Unresolved(InvalidEventStream(..))
pushN :: Element -> XMPPConMonad Bool pushElement :: Element -> XMPPConMonad Bool
pushN x = do pushElement x = do
sink <- gets sConPushBS sink <- gets sConPushBS
liftIO . sink $ renderElement x liftIO . sink $ renderElement x
push :: Stanza -> XMPPConMonad Bool pushStanza :: Stanza -> XMPPConMonad Bool
push = pushN . pickleElem xpStanza pushStanza = pushElement . pickleElem xpStanza
pushOpen :: Element -> XMPPConMonad Bool pushOpenElement :: Element -> XMPPConMonad Bool
pushOpen e = do pushOpenElement e = do
sink <- gets sConPushBS sink <- gets sConPushBS
liftIO . sink $ renderOpenElement e liftIO . sink $ renderOpenElement e
pullSink :: Sink Event IO b -> XMPPConMonad b -- `Connect-and-resumes' the given sink to the connection source, and pulls a
pullSink snk = do -- `b' value.
pullToSink :: Sink Event IO b -> XMPPConMonad b
pullToSink snk = do
source <- gets sConSrc source <- gets sConSrc
(_, r) <- lift $ source $$+ snk (_, r) <- lift $ source $$+ snk
return r return r
@ -54,14 +56,14 @@ pullSink snk = do
pullElement :: XMPPConMonad Element pullElement :: XMPPConMonad Element
pullElement = do pullElement = do
Ex.catch (do Ex.catch (do
e <- pullSink (elements =$ CL.head) e <- pullToSink (elements =$ CL.head)
case e of case e of
Nothing -> liftIO $ Ex.throwIO StreamConnectionError Nothing -> liftIO $ Ex.throwIO StreamConnectionError
Just r -> return r Just r -> return r
) )
(\(InvalidEventStream s) -> liftIO . Ex.throwIO $ StreamXMLError s) (\(InvalidEventStream s) -> liftIO . Ex.throwIO $ StreamXMLError s)
-- Pulls an element and unpickles it.
pullPickle :: PU [Node] a -> XMPPConMonad a pullPickle :: PU [Node] a -> XMPPConMonad a
pullPickle p = do pullPickle p = do
res <- unpickleElem p <$> pullElement res <- unpickleElem p <$> pullElement
@ -69,27 +71,30 @@ pullPickle p = do
Left e -> liftIO . Ex.throwIO $ StreamXMLError e Left e -> liftIO . Ex.throwIO $ StreamXMLError e
Right r -> return r Right r -> return r
-- Pulls a stanza from the stream. Throws an error on failure.
pullStanza :: XMPPConMonad Stanza pullStanza :: XMPPConMonad Stanza
pullStanza = do pullStanza = do
res <- pullPickle xpStreamEntity res <- pullPickle xpStreamStanza
case res of case res of
Left e -> liftIO . Ex.throwIO $ StreamError e Left e -> liftIO . Ex.throwIO $ StreamError e
Right r -> return r Right r -> return r
catchPush p = Ex.catch (p >> return True) -- Performs the given IO operation, catches any errors and re-throws everything
-- except the `ResourceVanished' error.
catchPush :: IO () -> IO Bool
catchPush p = Ex.catch
(p >> return True)
(\e -> case GIE.ioe_type e of (\e -> case GIE.ioe_type e of
GIE.ResourceVanished -> return False GIE.ResourceVanished -> return False
_ -> Ex.throwIO e _ -> Ex.throwIO e
) )
zeroSource :: Source IO output -- XmppConnection state used when there is no connection.
zeroSource = liftIO . Ex.throwIO $ StreamConnectionError
xmppNoConnection :: XmppConnection xmppNoConnection :: XmppConnection
xmppNoConnection = XmppConnection xmppNoConnection = XmppConnection
{ sConSrc = zeroSource { sConSrc = zeroSource
, sRawSrc = zeroSource , sRawSrc = zeroSource
, sConPushBS = \_ -> return False , sConPushBS = \_ -> return False -- Nothing has been sent.
, sConHandle = Nothing , sConHandle = Nothing
, sFeatures = SF Nothing [] [] , sFeatures = SF Nothing [] []
, sConnectionState = XmppConnectionClosed , sConnectionState = XmppConnectionClosed
@ -98,7 +103,12 @@ xmppNoConnection = XmppConnection
, sResource = Nothing , sResource = Nothing
, sCloseConnection = return () , sCloseConnection = return ()
} }
where
zeroSource :: Source IO output
zeroSource = liftIO . Ex.throwIO $ StreamConnectionError
-- Connects to the given hostname on port 5222 (TODO: Make this dynamic) and
-- updates the XMPPConMonad XmppConnection state.
xmppRawConnect :: HostName -> Text -> XMPPConMonad () xmppRawConnect :: HostName -> Text -> XMPPConMonad ()
xmppRawConnect host hostname = do xmppRawConnect host hostname = do
uname <- gets sUsername uname <- gets sUsername
@ -110,7 +120,7 @@ xmppRawConnect host hostname = do
src <- liftIO . bufferSource $ raw $= XP.parseBytes def src <- liftIO . bufferSource $ raw $= XP.parseBytes def
let st = XmppConnection let st = XmppConnection
src src
(raw) raw
(catchPush . BS.hPut con) (catchPush . BS.hPut con)
(Just con) (Just con)
(SF Nothing [] []) (SF Nothing [] [])
@ -121,28 +131,34 @@ xmppRawConnect host hostname = do
(hClose con) (hClose con)
put st put st
-- Execute a XMPPConMonad computation.
xmppNewSession :: XMPPConMonad a -> IO (a, XmppConnection) xmppNewSession :: XMPPConMonad a -> IO (a, XmppConnection)
xmppNewSession action = do xmppNewSession action = runStateT action xmppNoConnection
runStateT action xmppNoConnection
-- Closes the connection and updates the XMPPConMonad XmppConnection state.
xmppKillConnection :: XMPPConMonad () xmppKillConnection :: XMPPConMonad ()
xmppKillConnection = do xmppKillConnection = do
cc <- gets sCloseConnection cc <- gets sCloseConnection
void . liftIO $ (Ex.try cc :: IO (Either Ex.SomeException ())) void . liftIO $ (Ex.try cc :: IO (Either Ex.SomeException ()))
put xmppNoConnection put xmppNoConnection
xmppSendIQ' :: StanzaId -> Maybe JID -> IQRequestType -- Sends an IQ request and waits for the response. If the response ID does not
-> Maybe LangTag -> Element -- match the outgoing ID, an error is thrown.
xmppSendIQ' :: StanzaId
-> Maybe JID
-> IQRequestType
-> Maybe LangTag
-> Element
-> XMPPConMonad (Either IQError IQResult) -> XMPPConMonad (Either IQError IQResult)
xmppSendIQ' iqID to tp lang body = do xmppSendIQ' iqID to tp lang body = do
push . IQRequestS $ IQRequest iqID Nothing to lang tp body pushStanza . IQRequestS $ IQRequest iqID Nothing to lang tp body
res <- pullPickle $ xpEither xpIQError xpIQResult res <- pullPickle $ xpEither xpIQError xpIQResult
case res of case res of
Left e -> return $ Left e Left e -> return $ Left e
Right iq' -> do Right iq' -> do
unless (iqID == iqResultID iq') . liftIO . Ex.throwIO $ unless
(iqID == iqResultID iq') . liftIO . Ex.throwIO $
StreamXMLError StreamXMLError
("In xmppSendIQ' IDs don't match: " ++ show iqID ++ ("In xmppSendIQ' IDs don't match: " ++ show iqID ++ " /= " ++
" /= " ++ show (iqResultID iq') ++ " .") show (iqResultID iq') ++ " .")
return $ Right iq' return $ Right iq'

1
src/Network/XMPP/Pickle.hs
Unescape View File

@ -73,6 +73,7 @@ unpickleElem' p x = case unpickle (xpNodeElem p) x of
Left l -> error $ l ++ "\n saw: " ++ ppElement x Left l -> error $ l ++ "\n saw: " ++ ppElement x
Right r -> r Right r -> r
-- Given a pickler and an element, produces an object.
unpickleElem :: PU [Node] a -> Element -> Either String a unpickleElem :: PU [Node] a -> Element -> Either String a
unpickleElem p x = unpickle (xpNodeElem p) x unpickleElem p x = unpickle (xpNodeElem p) x

6
src/Network/XMPP/SASL.hs
Unescape View File

@ -66,7 +66,7 @@ xmppSASL uname passwd = runErrorT $ do
unless ("DIGEST-MD5" `elem` mechanisms) . unless ("DIGEST-MD5" `elem` mechanisms) .
throwError $ AuthMechanismError mechanisms throwError $ AuthMechanismError mechanisms
-- Push element and receive the challenge (in XMPPConMonad). -- Push element and receive the challenge (in XMPPConMonad).
_ <- lift . pushN $ saslInitE "DIGEST-MD5" -- TODO: Check boolean? _ <- lift . pushElement $ saslInitE "DIGEST-MD5" -- TODO: Check boolean?
challenge' <- lift $ B64.decode . Text.encodeUtf8 <$> challenge' <- lift $ B64.decode . Text.encodeUtf8 <$>
pullPickle challengePickle pullPickle challengePickle
challenge <- case challenge' of challenge <- case challenge' of
@ -76,13 +76,13 @@ xmppSASL uname passwd = runErrorT $ do
Left _ -> throwError AuthChallengeError Left _ -> throwError AuthChallengeError
Right p -> return p Right p -> return p
g <- liftIO Random.newStdGen g <- liftIO Random.newStdGen
_ <- lift . pushN . -- TODO: Check boolean? _ <- lift . pushElement . -- TODO: Check boolean?
saslResponseE $ createResponse g realm pairs saslResponseE $ createResponse g realm pairs
challenge2 <- lift $ pullPickle (xpEither failurePickle challengePickle) challenge2 <- lift $ pullPickle (xpEither failurePickle challengePickle)
case challenge2 of case challenge2 of
Left _x -> throwError AuthXmlError Left _x -> throwError AuthXmlError
Right _ -> return () Right _ -> return ()
lift $ pushN saslResponse2E lift $ pushElement saslResponse2E
e <- lift pullElement e <- lift pullElement
case e of case e of
Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] -> Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] ->

66
src/Network/XMPP/Stream.hs
Unescape View File

@ -24,6 +24,7 @@ import Text.XML.Stream.Parse as XP
-- import Text.XML.Stream.Elements -- import Text.XML.Stream.Elements
-- Unpickles and returns a stream element. Throws a StreamXMLError on failure.
streamUnpickleElem :: PU [Node] a streamUnpickleElem :: PU [Node] a
-> Element -> Element
-> ErrorT StreamError (Pipe Event Void IO) a -> ErrorT StreamError (Pipe Event Void IO) a
@ -32,16 +33,20 @@ streamUnpickleElem p x = do
Left l -> throwError $ StreamXMLError l Left l -> throwError $ StreamXMLError l
Right r -> return r Right r -> return r
-- This is the conduit sink that handles the stream XML events. We extend it
-- with ErrorT capabilities.
type StreamSink a = ErrorT StreamError (Pipe Event Void IO) a type StreamSink a = ErrorT StreamError (Pipe Event Void IO) a
-- Discards all events before the first EventBeginElement.
throwOutJunk :: Monad m => Sink Event m () throwOutJunk :: Monad m => Sink Event m ()
throwOutJunk = do throwOutJunk = do
next <- CL.peek next <- CL.peek
case next of case next of
Nothing -> return () Nothing -> return () -- This will only happen if the stream is closed.
Just (EventBeginElement _ _) -> return () Just (EventBeginElement _ _) -> return ()
_ -> CL.drop 1 >> throwOutJunk _ -> CL.drop 1 >> throwOutJunk
-- Returns an (empty) Element from a stream of XML events.
openElementFromEvents :: StreamSink Element openElementFromEvents :: StreamSink Element
openElementFromEvents = do openElementFromEvents = do
lift throwOutJunk lift throwOutJunk
@ -50,17 +55,20 @@ openElementFromEvents = do
Just (EventBeginElement name attrs) -> return $ Element name attrs [] Just (EventBeginElement name attrs) -> return $ Element name attrs []
_ -> throwError $ StreamConnectionError _ -> throwError $ StreamConnectionError
-- Sends the initial stream:stream element and pulls the server features.
xmppStartStream :: XMPPConMonad (Either StreamError ()) xmppStartStream :: XMPPConMonad (Either StreamError ())
xmppStartStream = runErrorT $ do xmppStartStream = runErrorT $ do
hostname' <- gets sHostname hostname' <- gets sHostname
case hostname' of case hostname' of
Nothing -> throwError StreamConnectionError Nothing -> throwError StreamConnectionError
Just hostname -> lift . pushOpen $ Just hostname -> lift . pushOpenElement $
pickleElem pickleStream ("1.0",Nothing, Just hostname) pickleElem pickleStream ("1.0", Nothing, Just hostname)
features <- ErrorT . pullSink $ runErrorT xmppStream features <- ErrorT . pullToSink $ runErrorT xmppStream
modify (\s -> s {sFeatures = features}) modify (\s -> s {sFeatures = features})
return () return ()
-- Creates a new connection source (of Events) using the raw source (of bytes)
-- and calls xmppStartStream.
xmppRestartStream :: XMPPConMonad (Either StreamError ()) xmppRestartStream :: XMPPConMonad (Either StreamError ())
xmppRestartStream = do xmppRestartStream = do
raw <- gets sRawSrc raw <- gets sRawSrc
@ -68,54 +76,54 @@ xmppRestartStream = do
modify (\s -> s{sConSrc = newsrc}) modify (\s -> s{sConSrc = newsrc})
xmppStartStream xmppStartStream
-- Reads the (partial) stream:stream and the server features from the stream.
xmppStream :: StreamSink ServerFeatures xmppStream :: StreamSink ServerFeatures
xmppStream = do xmppStream = do
xmppStreamHeader xmppStreamHeader
xmppStreamFeatures xmppStreamFeatures
where
xmppStreamHeader :: StreamSink () xmppStreamHeader :: StreamSink ()
xmppStreamHeader = do xmppStreamHeader = do
lift $ throwOutJunk lift $ throwOutJunk
(ver, _, _) <- streamUnpickleElem pickleStream =<< openElementFromEvents (ver, _, _) <- streamUnpickleElem pickleStream =<< openElementFromEvents
unless (ver == "1.0") . throwError $ StreamWrongVersion ver unless (ver == "1.0") . throwError $ StreamWrongVersion ver
return() return ()
xmppStreamFeatures :: StreamSink ServerFeatures
xmppStreamFeatures = do
xmppStreamFeatures :: StreamSink ServerFeatures
xmppStreamFeatures = do
e <- lift $ elements =$ CL.head e <- lift $ elements =$ CL.head
case e of case e of
Nothing -> liftIO $ Ex.throwIO StreamConnectionError Nothing -> liftIO $ Ex.throwIO StreamConnectionError
Just r -> streamUnpickleElem pickleStreamFeatures r Just r -> streamUnpickleElem pickleStreamFeatures r
-- Pickling -- Pickler/Unpickler for the stream, with the version, from and to attributes.
pickleStream :: PU [Node] (Text, Maybe Text, Maybe Text) pickleStream :: PU [Node] (Text, Maybe Text, Maybe Text)
pickleStream = xpElemAttrs (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) pickleStream = xpElemAttrs
(Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream"))
(xpTriple (xpTriple
(xpAttr "version" xpId) (xpAttr "version" xpId)
(xpOption $ xpAttr "from" xpId) (xpOption $ xpAttr "from" xpId)
(xpOption $ xpAttr "to" xpId) (xpOption $ xpAttr "to" xpId)
) )
pickleTLSFeature :: PU [Node] Bool -- Pickler/Unpickler for the stream features - TLS, SASL, and the rest.
pickleTLSFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls"
(xpElemExists "required")
pickleSaslFeature :: PU [Node] [Text]
pickleSaslFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms"
(xpAll $ xpElemNodes
"{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId) )
pickleStreamFeatures :: PU [Node] ServerFeatures pickleStreamFeatures :: PU [Node] ServerFeatures
pickleStreamFeatures = xpWrap ( \(tls, sasl, rest) -> SF tls (mbl sasl) rest) pickleStreamFeatures = xpWrap
(\(tls, sasl, rest) -> SF tls (mbl sasl) rest)
(\(SF tls sasl rest) -> (tls, lmb sasl, rest)) (\(SF tls sasl rest) -> (tls, lmb sasl, rest))
$ (xpElemNodes (Name
xpElemNodes (Name "features" (Just "http://etherx.jabber.org/streams") (Just "stream")) "features" (Just "http://etherx.jabber.org/streams") (Just "stream"))
(xpTriple (xpTriple
(xpOption pickleTLSFeature) (xpOption pickleTLSFeature)
(xpOption pickleSaslFeature) (xpOption pickleSaslFeature)
(xpAll xpElemVerbatim) (xpAll xpElemVerbatim)
) )
)
where
pickleTLSFeature :: PU [Node] Bool
pickleTLSFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls"
(xpElemExists "required")
pickleSaslFeature :: PU [Node] [Text]
pickleSaslFeature = xpElemNodes
"{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms"
(xpAll $ xpElemNodes
"{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId))

28
src/Network/XMPP/TLS.hs
Unescape View File

@ -18,12 +18,11 @@ import Network.XMPP.Stream
import Network.XMPP.Types import Network.XMPP.Types
starttlsE :: Element starttlsE :: Element
starttlsE = starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] []
Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] []
exampleParams :: TLS.TLSParams exampleParams :: TLS.TLSParams
exampleParams = TLS.defaultParams exampleParams = TLS.defaultParams
{pConnectVersion = TLS.TLS10 { pConnectVersion = TLS.TLS10
, pAllowedVersions = [TLS.SSL3, TLS.TLS10, TLS.TLS11] , pAllowedVersions = [TLS.SSL3, TLS.TLS10, TLS.TLS11]
, pCiphers = [TLS.cipher_AES128_SHA1] , pCiphers = [TLS.cipher_AES128_SHA1]
, pCompressions = [TLS.nullCompression] , pCompressions = [TLS.nullCompression]
@ -31,7 +30,7 @@ exampleParams = TLS.defaultParams
, pUseSecureRenegotiation = False -- No renegotiation , pUseSecureRenegotiation = False -- No renegotiation
, pCertificates = [] -- TODO , pCertificates = [] -- TODO
, pLogging = TLS.defaultLogging -- TODO , pLogging = TLS.defaultLogging -- TODO
, onCertificatesRecv = \ _certificate -> , onCertificatesRecv = \_certificate ->
return TLS.CertificateUsageAccept return TLS.CertificateUsageAccept
} }
@ -40,29 +39,31 @@ data XMPPTLSError = TLSError TLSError
| TLSNoServerSupport | TLSNoServerSupport
| TLSNoConnection | TLSNoConnection
| TLSStreamError StreamError | TLSStreamError StreamError
| XMPPTLSError -- General instance used for the Error instance
deriving (Show, Eq, Typeable) deriving (Show, Eq, Typeable)
instance Error XMPPTLSError where instance Error XMPPTLSError where
noMsg = TLSNoConnection -- TODO: What should we choose here? noMsg = XMPPTLSError
-- Pushes "<starttls/>, waits for "<proceed/>", performs the TLS handshake, and
-- restarts the stream. May throw errors.
startTLS :: TLS.TLSParams -> XMPPConMonad (Either XMPPTLSError ()) startTLS :: TLS.TLSParams -> XMPPConMonad (Either XMPPTLSError ())
startTLS params = Ex.handle (return . Left . TLSError) startTLS params = Ex.handle (return . Left . TLSError) . runErrorT $ do
. runErrorT $ do
features <- lift $ gets sFeatures features <- lift $ gets sFeatures
handle' <- lift $ gets sConHandle handle' <- lift $ gets sConHandle
handle <- maybe (throwError TLSNoConnection) return handle' handle <- maybe (throwError TLSNoConnection) return handle'
when (stls features == Nothing) $ throwError TLSNoServerSupport when (stls features == Nothing) $ throwError TLSNoServerSupport
lift $ pushN starttlsE lift $ pushElement starttlsE
answer <- lift $ pullElement answer <- lift $ pullElement
case answer of case answer of
Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return () Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return ()
Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _ Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _ ->
-> lift . Ex.throwIO $ StreamConnectionError lift . Ex.throwIO $ StreamConnectionError
-- TODO: find something more suitable -- TODO: find something more suitable
e -> lift . Ex.throwIO . StreamXMLError e -> lift . Ex.throwIO . StreamXMLError $
$ "Unexpected element: " ++ ppElement e "Unexpected element: " ++ ppElement e
(raw, _snk, psh, ctx) <- lift $ TLS.tlsinit params handle (raw, _snk, psh, ctx) <- lift $ TLS.tlsinit params handle
lift $ modify (\x -> x lift $ modify ( \x -> x
{ sRawSrc = raw { sRawSrc = raw
-- , sConSrc = -- Note: this momentarily leaves us in an -- , sConSrc = -- Note: this momentarily leaves us in an
-- inconsistent state -- inconsistent state
@ -72,4 +73,3 @@ startTLS params = Ex.handle (return . Left . TLSError)
either (lift . Ex.throwIO) return =<< lift xmppRestartStream either (lift . Ex.throwIO) return =<< lift xmppRestartStream
modify (\s -> s{sConnectionState = XmppConnectionSecured}) modify (\s -> s{sConnectionState = XmppConnectionSecured})
return () return ()

Write Preview
Loading…
Cancel
Save