Browse Source
We can treat all functions related to SASL negotiation as a submodule
to Pontarius XMPP if there are no dependencies from the internal
Network.Xmpp modules to the SASL functionality. Because of this,
`auth' and `authSimple' were moved from Session.hs to Sasl.hs. As the
bind and the `{urn:ietf:params:xml:ns:xmpp-session}session'
functionality are related only to the SASL negotation functionality,
these functions has been moved to the SASL submodule as well.
As these changes only leaves `connect' in the Session module, it seems
fitting to move `connect' to Network.Xmpp.Stream (not
Network.Xmpp.Connection, as `connect' depends on `startStream').
The internal Network.Xmpp modules (Connection.hs) no longer depend on
the Concurrent submodule. This will decrease the coupling between
Network.Xmpp and the concurrent implementation, making it easier for
developers to replace the concurrent implementation if they wanted to.
As Network.Xmpp.Connection is really a module that breaks the
encapsulation that is Network.Xmpp and the concurrent interface, I
have renamed it Network.Xmpp.Internal. As this frees up the
Network.Xmpp.Connection name, Network.Xmpp.Connection_ can reclaim it.
The high-level "utility" functions of Network.Xmpp.Utilities,
Network.Xmpp.Presence, and Network.Xmpp.Message has been moved to
Network.Xmpp.Utilities. This module contains functions that at most
only depend on the internal Network.Xmpp.Types module, and doesn't
belong in any other module.
The functionality of Jid.hs was moved to Types.hs.
Moved some of the functions of Network.Xmpp.Pickle to
Network.Xmpp.Marshal, and removed the Network.Xmpp.Pickle module.
A module imports diagram corresponding to the one of my last patch
shows the new module structure. I also include a diagram showing
the `Sasl' and `Concurrent' module imports.
master
Jon Kristensen
13 years ago
28 changed files with 763 additions and 865 deletions
|
After Width: | Height: | Size: 326 KiB |
|
After Width: | Height: | Size: 81 KiB |
@ -1,57 +0,0 @@ |
|||||||
{-# LANGUAGE OverloadedStrings #-} |
|
||||||
|
|
||||||
{-# OPTIONS_HADDOCK hide #-} |
|
||||||
|
|
||||||
module Network.Xmpp.Bind where |
|
||||||
|
|
||||||
import Control.Exception |
|
||||||
|
|
||||||
import Data.Text as Text |
|
||||||
import Data.XML.Pickle |
|
||||||
import Data.XML.Types |
|
||||||
|
|
||||||
import Network.Xmpp.Connection_ |
|
||||||
import Network.Xmpp.Pickle |
|
||||||
import Network.Xmpp.Types |
|
||||||
|
|
||||||
import Control.Monad.State(modify) |
|
||||||
|
|
||||||
import Control.Concurrent.STM.TMVar |
|
||||||
|
|
||||||
import Control.Monad.Error |
|
||||||
|
|
||||||
-- Produces a `bind' element, optionally wrapping a resource. |
|
||||||
bindBody :: Maybe Text -> Element |
|
||||||
bindBody = pickleElem $ |
|
||||||
-- Pickler to produce a |
|
||||||
-- "<bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'/>" |
|
||||||
-- element, with a possible "<resource>[JID]</resource>" |
|
||||||
-- child. |
|
||||||
xpBind . xpOption $ xpElemNodes "resource" (xpContent xpId) |
|
||||||
|
|
||||||
-- Sends a (synchronous) IQ set request for a (`Just') given or server-generated |
|
||||||
-- resource and extract the JID from the non-error response. |
|
||||||
xmppBind :: Maybe Text -> TMVar Connection -> IO (Either XmppFailure Jid) |
|
||||||
xmppBind rsrc c = runErrorT $ do |
|
||||||
answer <- ErrorT $ pushIQ' "bind" Nothing Set Nothing (bindBody rsrc) c |
|
||||||
case answer of |
|
||||||
Right IQResult{iqResultPayload = Just b} -> do |
|
||||||
let jid = unpickleElem xpJid b |
|
||||||
case jid of |
|
||||||
Right jid' -> do |
|
||||||
ErrorT $ withConnection (do |
|
||||||
modify $ \s -> s{cJid = Just jid'} |
|
||||||
return $ Right jid') c -- not pretty |
|
||||||
return jid' |
|
||||||
otherwise -> throwError XmppOtherFailure |
|
||||||
-- TODO: Log: ("Bind couldn't unpickle JID from " ++ show answer) |
|
||||||
otherwise -> throwError XmppOtherFailure |
|
||||||
where |
|
||||||
-- Extracts the character data in the `jid' element. |
|
||||||
xpJid :: PU [Node] Jid |
|
||||||
xpJid = xpBind $ xpElemNodes jidName (xpContent xpPrim) |
|
||||||
jidName = "{urn:ietf:params:xml:ns:xmpp-bind}jid" |
|
||||||
|
|
||||||
-- A `bind' element pickler. |
|
||||||
xpBind :: PU [Node] b -> PU [Node] b |
|
||||||
xpBind c = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-bind}bind" c |
|
||||||
@ -1,41 +1,284 @@ |
|||||||
-- | |
{-# OPTIONS_HADDOCK hide #-} |
||||||
-- Module: $Header$ |
{-# LANGUAGE ScopedTypeVariables #-} |
||||||
-- |
{-# LANGUAGE OverloadedStrings #-} |
||||||
-- Maintainer: info@jonkri.com |
|
||||||
-- Stability: unstable |
module Network.Xmpp.Connection where |
||||||
-- Portability: portable |
|
||||||
-- |
import Control.Applicative((<$>)) |
||||||
-- This module allows for low-level access to Pontarius XMPP. Generally, the |
import Control.Concurrent (forkIO, threadDelay) |
||||||
-- "Network.Xmpp" module should be used instead. |
import System.IO.Error (tryIOError) |
||||||
-- |
import Control.Monad |
||||||
-- The 'Connection' object provides the most low-level access to the XMPP |
import Control.Monad.IO.Class |
||||||
-- stream: a simple and single-threaded interface which exposes the conduit |
import Control.Monad.Trans.Class |
||||||
-- 'Event' source, as well as the input and output byte streams. Custom stateful |
--import Control.Monad.Trans.Resource |
||||||
-- 'Connection' functions can be executed using 'withConnection'. |
import qualified Control.Exception.Lifted as Ex |
||||||
-- |
import qualified GHC.IO.Exception as GIE |
||||||
-- The TLS, SASL, and 'Session' functionalities of Pontarius XMPP are built on |
import Control.Monad.State.Strict |
||||||
-- top of this API. |
|
||||||
|
import Data.ByteString as BS |
||||||
module Network.Xmpp.Connection |
import Data.ByteString.Char8 as BSC8 |
||||||
( Connection(..) |
import Data.Conduit |
||||||
, ConnectionState(..) |
import Data.Conduit.Binary as CB |
||||||
, ConnectionHandle(..) |
import Data.Conduit.Internal as DCI |
||||||
, ServerFeatures(..) |
import qualified Data.Conduit.List as CL |
||||||
, connect |
import Data.IORef |
||||||
, withConnection |
import Data.Text(Text) |
||||||
, startTls |
import qualified Data.Text as T |
||||||
, simpleAuth |
import Data.XML.Pickle |
||||||
, auth |
import Data.XML.Types |
||||||
, pushStanza |
|
||||||
, pullStanza |
import Network |
||||||
, closeConnection |
import Network.Xmpp.Types |
||||||
, newSession |
import Network.Xmpp.Marshal |
||||||
|
|
||||||
|
import System.IO |
||||||
|
|
||||||
|
import Text.Xml.Stream.Elements |
||||||
|
import Text.XML.Stream.Parse as XP |
||||||
|
import Text.XML.Unresolved(InvalidEventStream(..)) |
||||||
|
|
||||||
|
import System.Log.Logger |
||||||
|
import Data.ByteString.Base64 |
||||||
|
|
||||||
|
import Control.Concurrent.STM.TMVar |
||||||
|
import Control.Monad.Error |
||||||
|
|
||||||
|
-- Enable/disable debug output |
||||||
|
-- This will dump all incoming and outgoing network taffic to the console, |
||||||
|
-- prefixed with "in: " and "out: " respectively |
||||||
|
debug :: Bool |
||||||
|
debug = False |
||||||
|
|
||||||
|
-- TODO: Can the TLS send/recv functions throw something other than an IO error? |
||||||
|
|
||||||
|
wrapIOException :: IO a -> StateT Connection IO (Either XmppFailure a) |
||||||
|
wrapIOException action = do |
||||||
|
r <- liftIO $ tryIOError action |
||||||
|
case r of |
||||||
|
Right b -> return $ Right b |
||||||
|
Left e -> return $ Left $ XmppIOException e |
||||||
|
|
||||||
|
pushElement :: Element -> StateT Connection IO (Either XmppFailure Bool) |
||||||
|
pushElement x = do |
||||||
|
send <- gets (cSend . cHandle) |
||||||
|
wrapIOException $ send $ renderElement x |
||||||
|
|
||||||
|
-- | Encode and send stanza |
||||||
|
pushStanza :: Stanza -> TMVar Connection -> IO (Either XmppFailure Bool) |
||||||
|
pushStanza s = withConnection' . pushElement $ pickleElem xpStanza s |
||||||
|
|
||||||
|
-- XML documents and XMPP streams SHOULD be preceeded by an XML declaration. |
||||||
|
-- UTF-8 is the only supported XMPP encoding. The standalone document |
||||||
|
-- declaration (matching "SDDecl" in the XML standard) MUST NOT be included in |
||||||
|
-- XMPP streams. RFC 6120 defines XMPP only in terms of XML 1.0. |
||||||
|
pushXmlDecl :: StateT Connection IO (Either XmppFailure Bool) |
||||||
|
pushXmlDecl = do |
||||||
|
con <- gets cHandle |
||||||
|
wrapIOException $ (cSend con) "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>" |
||||||
|
|
||||||
|
pushOpenElement :: Element -> StateT Connection IO (Either XmppFailure Bool) |
||||||
|
pushOpenElement e = do |
||||||
|
sink <- gets (cSend . cHandle) |
||||||
|
wrapIOException $ sink $ renderOpenElement e |
||||||
|
|
||||||
|
-- `Connect-and-resumes' the given sink to the connection source, and pulls a |
||||||
|
-- `b' value. |
||||||
|
runEventsSink :: Sink Event IO b -> StateT Connection IO (Either XmppFailure b) |
||||||
|
runEventsSink snk = do -- TODO: Wrap exceptions? |
||||||
|
source <- gets cEventSource |
||||||
|
(src', r) <- lift $ source $$++ snk |
||||||
|
modify (\s -> s{cEventSource = src'}) |
||||||
|
return $ Right r |
||||||
|
|
||||||
|
pullElement :: StateT Connection IO (Either XmppFailure Element) |
||||||
|
pullElement = do |
||||||
|
Ex.catches (do |
||||||
|
e <- runEventsSink (elements =$ await) |
||||||
|
case e of |
||||||
|
Left f -> return $ Left f |
||||||
|
Right Nothing -> return $ Left XmppOtherFailure -- TODO |
||||||
|
Right (Just r) -> return $ Right r |
||||||
|
) |
||||||
|
[ Ex.Handler (\StreamEnd -> return $ Left StreamEndFailure) |
||||||
|
, Ex.Handler (\(InvalidXmppXml s) -- Invalid XML `Event' encountered, or missing element close tag |
||||||
|
-> return $ Left XmppOtherFailure) -- TODO: Log: s |
||||||
|
, Ex.Handler $ \(e :: InvalidEventStream) -- xml-conduit exception |
||||||
|
-> return $ Left XmppOtherFailure -- TODO: Log: (show e) |
||||||
|
] |
||||||
|
|
||||||
|
-- Pulls an element and unpickles it. |
||||||
|
pullUnpickle :: PU [Node] a -> StateT Connection IO (Either XmppFailure a) |
||||||
|
pullUnpickle p = do |
||||||
|
elem <- pullElement |
||||||
|
case elem of |
||||||
|
Left e -> return $ Left e |
||||||
|
Right elem' -> do |
||||||
|
let res = unpickleElem p elem' |
||||||
|
case res of |
||||||
|
Left e -> return $ Left XmppOtherFailure -- TODO: Log |
||||||
|
Right r -> return $ Right r |
||||||
|
|
||||||
|
-- | Pulls a stanza (or stream error) from the stream. |
||||||
|
pullStanza :: TMVar Connection -> IO (Either XmppFailure Stanza) |
||||||
|
pullStanza = withConnection' $ do |
||||||
|
res <- pullUnpickle xpStreamStanza |
||||||
|
case res of |
||||||
|
Left e -> return $ Left e |
||||||
|
Right (Left e) -> return $ Left $ StreamErrorFailure e |
||||||
|
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 |
||||||
|
catchPush :: IO () -> IO Bool |
||||||
|
catchPush p = Ex.catch |
||||||
|
(p >> return True) |
||||||
|
(\e -> case GIE.ioe_type e of |
||||||
|
GIE.ResourceVanished -> return False |
||||||
|
GIE.IllegalOperation -> return False |
||||||
|
_ -> Ex.throwIO e |
||||||
) |
) |
||||||
|
|
||||||
|
-- Connection state used when there is no connection. |
||||||
|
xmppNoConnection :: Connection |
||||||
|
xmppNoConnection = Connection |
||||||
|
{ cHandle = ConnectionHandle { cSend = \_ -> return False |
||||||
|
, cRecv = \_ -> Ex.throwIO |
||||||
|
XmppOtherFailure |
||||||
|
, cFlush = return () |
||||||
|
, cClose = return () |
||||||
|
} |
||||||
|
, cEventSource = DCI.ResumableSource zeroSource (return ()) |
||||||
|
, cFeatures = SF Nothing [] [] |
||||||
|
, cState = ConnectionClosed |
||||||
|
, cHostName = Nothing |
||||||
|
, cJid = Nothing |
||||||
|
, cStreamLang = Nothing |
||||||
|
, cStreamId = Nothing |
||||||
|
, cPreferredLang = Nothing |
||||||
|
, cToJid = Nothing |
||||||
|
, cJidWhenPlain = False |
||||||
|
, cFrom = Nothing |
||||||
|
} |
||||||
where |
where |
||||||
|
zeroSource :: Source IO output |
||||||
|
zeroSource = liftIO . Ex.throwIO $ XmppOtherFailure |
||||||
|
|
||||||
import Network.Xmpp.Connection_ |
connectTcp :: HostName -> PortID -> Text -> IO (Either XmppFailure (TMVar Connection)) |
||||||
import Network.Xmpp.Session |
connectTcp host port hostname = do |
||||||
import Network.Xmpp.Tls |
let PortNumber portNumber = port |
||||||
import Network.Xmpp.Types |
debugM "Pontarius.Xmpp" $ "Connecting to " ++ host ++ " on port " ++ |
||||||
import Network.Xmpp.Concurrent |
(show portNumber) ++ " through the realm " ++ (T.unpack hostname) ++ "." |
||||||
|
h <- connectTo host port |
||||||
|
debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle." |
||||||
|
hSetBuffering h NoBuffering |
||||||
|
let eSource = DCI.ResumableSource |
||||||
|
((sourceHandle h $= logConduit) $= XP.parseBytes def) |
||||||
|
(return ()) |
||||||
|
let hand = ConnectionHandle { cSend = \d -> do |
||||||
|
let d64 = encode d |
||||||
|
debugM "Pontarius.Xmpp" $ |
||||||
|
"Sending TCP data: " ++ (BSC8.unpack d64) |
||||||
|
++ "." |
||||||
|
catchPush $ BS.hPut h d |
||||||
|
, cRecv = \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 |
||||||
|
} |
||||||
|
let con = Connection |
||||||
|
{ cHandle = hand |
||||||
|
, cEventSource = eSource |
||||||
|
, cFeatures = (SF Nothing [] []) |
||||||
|
, cState = ConnectionPlain |
||||||
|
, 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 |
||||||
|
} |
||||||
|
con' <- mkConnection con |
||||||
|
return $ Right con' |
||||||
|
where |
||||||
|
logConduit :: Conduit ByteString IO ByteString |
||||||
|
logConduit = CL.mapM $ \d -> do |
||||||
|
let d64 = encode d |
||||||
|
debugM "Pontarius.Xmpp" $ "Received TCP data: " ++ (BSC8.unpack d64) ++ |
||||||
|
"." |
||||||
|
return d |
||||||
|
|
||||||
|
|
||||||
|
-- Closes the connection and updates the XmppConMonad Connection state. |
||||||
|
-- killConnection :: TMVar Connection -> IO (Either Ex.SomeException ()) |
||||||
|
killConnection :: TMVar Connection -> IO (Either XmppFailure ()) |
||||||
|
killConnection = withConnection $ do |
||||||
|
cc <- gets (cClose . cHandle) |
||||||
|
err <- wrapIOException cc |
||||||
|
-- (Ex.try cc :: IO (Either Ex.SomeException ())) |
||||||
|
put xmppNoConnection |
||||||
|
return err |
||||||
|
|
||||||
|
-- Sends an IQ request and waits for the response. If the response ID does not |
||||||
|
-- match the outgoing ID, an error is thrown. |
||||||
|
pushIQ' :: StanzaId |
||||||
|
-> Maybe Jid |
||||||
|
-> IQRequestType |
||||||
|
-> Maybe LangTag |
||||||
|
-> Element |
||||||
|
-> TMVar Connection |
||||||
|
-> IO (Either XmppFailure (Either IQError IQResult)) |
||||||
|
pushIQ' iqID to tp lang body con = do |
||||||
|
pushStanza (IQRequestS $ IQRequest iqID Nothing to lang tp body) con |
||||||
|
res <- pullStanza con |
||||||
|
case res of |
||||||
|
Left e -> return $ Left e |
||||||
|
Right (IQErrorS e) -> return $ Right $ Left e |
||||||
|
Right (IQResultS r) -> do |
||||||
|
unless |
||||||
|
(iqID == iqResultID r) . liftIO . Ex.throwIO $ |
||||||
|
XmppOtherFailure |
||||||
|
-- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++ |
||||||
|
-- " /= " ++ show (iqResultID r) ++ " .") |
||||||
|
return $ Right $ Right r |
||||||
|
_ -> return $ Left XmppOtherFailure |
||||||
|
-- TODO: Log: "sendIQ': unexpected stanza type " |
||||||
|
|
||||||
|
-- | Send "</stream:stream>" and wait for the server to finish processing and to |
||||||
|
-- close the connection. Any remaining elements from the server are returned. |
||||||
|
-- Surpresses StreamEndFailure exceptions, but may throw a StreamCloseError. |
||||||
|
closeStreams :: TMVar Connection -> IO (Either XmppFailure [Element]) |
||||||
|
closeStreams = withConnection $ do |
||||||
|
send <- gets (cSend . cHandle) |
||||||
|
cc <- gets (cClose . cHandle) |
||||||
|
liftIO $ send "</stream:stream>" |
||||||
|
void $ liftIO $ forkIO $ do |
||||||
|
threadDelay 3000000 -- TODO: Configurable value |
||||||
|
(Ex.try cc) :: IO (Either Ex.SomeException ()) |
||||||
|
return () |
||||||
|
collectElems [] |
||||||
|
where |
||||||
|
-- Pulls elements from the stream until the stream ends, or an error is |
||||||
|
-- raised. |
||||||
|
collectElems :: [Element] -> StateT Connection IO (Either XmppFailure [Element]) |
||||||
|
collectElems es = do |
||||||
|
result <- pullElement |
||||||
|
case result of |
||||||
|
Left StreamEndFailure -> return $ Right es |
||||||
|
Left e -> return $ Left $ StreamCloseError (es, e) |
||||||
|
Right e -> collectElems (e:es) |
||||||
|
|
||||||
|
debugConduit :: Pipe l ByteString ByteString u IO b |
||||||
|
debugConduit = forever $ do |
||||||
|
s' <- await |
||||||
|
case s' of |
||||||
|
Just s -> do |
||||||
|
liftIO $ BS.putStrLn (BS.append "in: " s) |
||||||
|
yield s |
||||||
|
Nothing -> return () |
||||||
|
|||||||
@ -1,285 +0,0 @@ |
|||||||
{-# OPTIONS_HADDOCK hide #-} |
|
||||||
{-# LANGUAGE ScopedTypeVariables #-} |
|
||||||
{-# LANGUAGE OverloadedStrings #-} |
|
||||||
|
|
||||||
module Network.Xmpp.Connection_ where |
|
||||||
|
|
||||||
import Control.Applicative((<$>)) |
|
||||||
import Control.Concurrent (forkIO, threadDelay) |
|
||||||
import System.IO.Error (tryIOError) |
|
||||||
import Control.Monad |
|
||||||
import Control.Monad.IO.Class |
|
||||||
import Control.Monad.Trans.Class |
|
||||||
--import Control.Monad.Trans.Resource |
|
||||||
import qualified Control.Exception.Lifted as Ex |
|
||||||
import qualified GHC.IO.Exception as GIE |
|
||||||
import Control.Monad.State.Strict |
|
||||||
|
|
||||||
import Data.ByteString as BS |
|
||||||
import Data.ByteString.Char8 as BSC8 |
|
||||||
import Data.Conduit |
|
||||||
import Data.Conduit.Binary as CB |
|
||||||
import Data.Conduit.Internal as DCI |
|
||||||
import qualified Data.Conduit.List as CL |
|
||||||
import Data.IORef |
|
||||||
import Data.Text(Text) |
|
||||||
import qualified Data.Text as T |
|
||||||
import Data.XML.Pickle |
|
||||||
import Data.XML.Types |
|
||||||
|
|
||||||
import Network |
|
||||||
import Network.Xmpp.Types |
|
||||||
import Network.Xmpp.Marshal |
|
||||||
import Network.Xmpp.Pickle |
|
||||||
|
|
||||||
import System.IO |
|
||||||
|
|
||||||
import Text.Xml.Stream.Elements |
|
||||||
import Text.XML.Stream.Parse as XP |
|
||||||
import Text.XML.Unresolved(InvalidEventStream(..)) |
|
||||||
|
|
||||||
import System.Log.Logger |
|
||||||
import Data.ByteString.Base64 |
|
||||||
|
|
||||||
import Control.Concurrent.STM.TMVar |
|
||||||
import Control.Monad.Error |
|
||||||
|
|
||||||
-- Enable/disable debug output |
|
||||||
-- This will dump all incoming and outgoing network taffic to the console, |
|
||||||
-- prefixed with "in: " and "out: " respectively |
|
||||||
debug :: Bool |
|
||||||
debug = False |
|
||||||
|
|
||||||
-- TODO: Can the TLS send/recv functions throw something other than an IO error? |
|
||||||
|
|
||||||
wrapIOException :: IO a -> StateT Connection IO (Either XmppFailure a) |
|
||||||
wrapIOException action = do |
|
||||||
r <- liftIO $ tryIOError action |
|
||||||
case r of |
|
||||||
Right b -> return $ Right b |
|
||||||
Left e -> return $ Left $ XmppIOException e |
|
||||||
|
|
||||||
pushElement :: Element -> StateT Connection IO (Either XmppFailure Bool) |
|
||||||
pushElement x = do |
|
||||||
send <- gets (cSend . cHandle) |
|
||||||
wrapIOException $ send $ renderElement x |
|
||||||
|
|
||||||
-- | Encode and send stanza |
|
||||||
pushStanza :: Stanza -> TMVar Connection -> IO (Either XmppFailure Bool) |
|
||||||
pushStanza s = withConnection' . pushElement $ pickleElem xpStanza s |
|
||||||
|
|
||||||
-- XML documents and XMPP streams SHOULD be preceeded by an XML declaration. |
|
||||||
-- UTF-8 is the only supported XMPP encoding. The standalone document |
|
||||||
-- declaration (matching "SDDecl" in the XML standard) MUST NOT be included in |
|
||||||
-- XMPP streams. RFC 6120 defines XMPP only in terms of XML 1.0. |
|
||||||
pushXmlDecl :: StateT Connection IO (Either XmppFailure Bool) |
|
||||||
pushXmlDecl = do |
|
||||||
con <- gets cHandle |
|
||||||
wrapIOException $ (cSend con) "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>" |
|
||||||
|
|
||||||
pushOpenElement :: Element -> StateT Connection IO (Either XmppFailure Bool) |
|
||||||
pushOpenElement e = do |
|
||||||
sink <- gets (cSend . cHandle) |
|
||||||
wrapIOException $ sink $ renderOpenElement e |
|
||||||
|
|
||||||
-- `Connect-and-resumes' the given sink to the connection source, and pulls a |
|
||||||
-- `b' value. |
|
||||||
runEventsSink :: Sink Event IO b -> StateT Connection IO (Either XmppFailure b) |
|
||||||
runEventsSink snk = do -- TODO: Wrap exceptions? |
|
||||||
source <- gets cEventSource |
|
||||||
(src', r) <- lift $ source $$++ snk |
|
||||||
modify (\s -> s{cEventSource = src'}) |
|
||||||
return $ Right r |
|
||||||
|
|
||||||
pullElement :: StateT Connection IO (Either XmppFailure Element) |
|
||||||
pullElement = do |
|
||||||
Ex.catches (do |
|
||||||
e <- runEventsSink (elements =$ await) |
|
||||||
case e of |
|
||||||
Left f -> return $ Left f |
|
||||||
Right Nothing -> return $ Left XmppOtherFailure -- TODO |
|
||||||
Right (Just r) -> return $ Right r |
|
||||||
) |
|
||||||
[ Ex.Handler (\StreamEnd -> return $ Left StreamEndFailure) |
|
||||||
, Ex.Handler (\(InvalidXmppXml s) -- Invalid XML `Event' encountered, or missing element close tag |
|
||||||
-> return $ Left XmppOtherFailure) -- TODO: Log: s |
|
||||||
, Ex.Handler $ \(e :: InvalidEventStream) -- xml-conduit exception |
|
||||||
-> return $ Left XmppOtherFailure -- TODO: Log: (show e) |
|
||||||
] |
|
||||||
|
|
||||||
-- Pulls an element and unpickles it. |
|
||||||
pullUnpickle :: PU [Node] a -> StateT Connection IO (Either XmppFailure a) |
|
||||||
pullUnpickle p = do |
|
||||||
elem <- pullElement |
|
||||||
case elem of |
|
||||||
Left e -> return $ Left e |
|
||||||
Right elem' -> do |
|
||||||
let res = unpickleElem p elem' |
|
||||||
case res of |
|
||||||
Left e -> return $ Left XmppOtherFailure -- TODO: Log |
|
||||||
Right r -> return $ Right r |
|
||||||
|
|
||||||
-- | Pulls a stanza (or stream error) from the stream. |
|
||||||
pullStanza :: TMVar Connection -> IO (Either XmppFailure Stanza) |
|
||||||
pullStanza = withConnection' $ do |
|
||||||
res <- pullUnpickle xpStreamStanza |
|
||||||
case res of |
|
||||||
Left e -> return $ Left e |
|
||||||
Right (Left e) -> return $ Left $ StreamErrorFailure e |
|
||||||
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 |
|
||||||
catchPush :: IO () -> IO Bool |
|
||||||
catchPush p = Ex.catch |
|
||||||
(p >> return True) |
|
||||||
(\e -> case GIE.ioe_type e of |
|
||||||
GIE.ResourceVanished -> return False |
|
||||||
GIE.IllegalOperation -> return False |
|
||||||
_ -> Ex.throwIO e |
|
||||||
) |
|
||||||
|
|
||||||
-- Connection state used when there is no connection. |
|
||||||
xmppNoConnection :: Connection |
|
||||||
xmppNoConnection = Connection |
|
||||||
{ cHandle = ConnectionHandle { cSend = \_ -> return False |
|
||||||
, cRecv = \_ -> Ex.throwIO |
|
||||||
XmppOtherFailure |
|
||||||
, cFlush = return () |
|
||||||
, cClose = return () |
|
||||||
} |
|
||||||
, cEventSource = DCI.ResumableSource zeroSource (return ()) |
|
||||||
, cFeatures = SF Nothing [] [] |
|
||||||
, cState = ConnectionClosed |
|
||||||
, cHostName = Nothing |
|
||||||
, cJid = Nothing |
|
||||||
, cStreamLang = Nothing |
|
||||||
, cStreamId = Nothing |
|
||||||
, cPreferredLang = Nothing |
|
||||||
, cToJid = Nothing |
|
||||||
, cJidWhenPlain = False |
|
||||||
, cFrom = Nothing |
|
||||||
} |
|
||||||
where |
|
||||||
zeroSource :: Source IO output |
|
||||||
zeroSource = liftIO . Ex.throwIO $ XmppOtherFailure |
|
||||||
|
|
||||||
connectTcp :: HostName -> PortID -> Text -> IO (Either XmppFailure (TMVar Connection)) |
|
||||||
connectTcp host port hostname = do |
|
||||||
let PortNumber portNumber = port |
|
||||||
debugM "Pontarius.Xmpp" $ "Connecting to " ++ host ++ " on port " ++ |
|
||||||
(show portNumber) ++ " through the realm " ++ (T.unpack hostname) ++ "." |
|
||||||
h <- connectTo host port |
|
||||||
debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle." |
|
||||||
hSetBuffering h NoBuffering |
|
||||||
let eSource = DCI.ResumableSource |
|
||||||
((sourceHandle h $= logConduit) $= XP.parseBytes def) |
|
||||||
(return ()) |
|
||||||
let hand = ConnectionHandle { cSend = \d -> do |
|
||||||
let d64 = encode d |
|
||||||
debugM "Pontarius.Xmpp" $ |
|
||||||
"Sending TCP data: " ++ (BSC8.unpack d64) |
|
||||||
++ "." |
|
||||||
catchPush $ BS.hPut h d |
|
||||||
, cRecv = \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 |
|
||||||
} |
|
||||||
let con = Connection |
|
||||||
{ cHandle = hand |
|
||||||
, cEventSource = eSource |
|
||||||
, cFeatures = (SF Nothing [] []) |
|
||||||
, cState = ConnectionPlain |
|
||||||
, 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 |
|
||||||
} |
|
||||||
con' <- mkConnection con |
|
||||||
return $ Right con' |
|
||||||
where |
|
||||||
logConduit :: Conduit ByteString IO ByteString |
|
||||||
logConduit = CL.mapM $ \d -> do |
|
||||||
let d64 = encode d |
|
||||||
debugM "Pontarius.Xmpp" $ "Received TCP data: " ++ (BSC8.unpack d64) ++ |
|
||||||
"." |
|
||||||
return d |
|
||||||
|
|
||||||
|
|
||||||
-- Closes the connection and updates the XmppConMonad Connection state. |
|
||||||
-- killConnection :: TMVar Connection -> IO (Either Ex.SomeException ()) |
|
||||||
killConnection :: TMVar Connection -> IO (Either XmppFailure ()) |
|
||||||
killConnection = withConnection $ do |
|
||||||
cc <- gets (cClose . cHandle) |
|
||||||
err <- wrapIOException cc |
|
||||||
-- (Ex.try cc :: IO (Either Ex.SomeException ())) |
|
||||||
put xmppNoConnection |
|
||||||
return err |
|
||||||
|
|
||||||
-- Sends an IQ request and waits for the response. If the response ID does not |
|
||||||
-- match the outgoing ID, an error is thrown. |
|
||||||
pushIQ' :: StanzaId |
|
||||||
-> Maybe Jid |
|
||||||
-> IQRequestType |
|
||||||
-> Maybe LangTag |
|
||||||
-> Element |
|
||||||
-> TMVar Connection |
|
||||||
-> IO (Either XmppFailure (Either IQError IQResult)) |
|
||||||
pushIQ' iqID to tp lang body con = do |
|
||||||
pushStanza (IQRequestS $ IQRequest iqID Nothing to lang tp body) con |
|
||||||
res <- pullStanza con |
|
||||||
case res of |
|
||||||
Left e -> return $ Left e |
|
||||||
Right (IQErrorS e) -> return $ Right $ Left e |
|
||||||
Right (IQResultS r) -> do |
|
||||||
unless |
|
||||||
(iqID == iqResultID r) . liftIO . Ex.throwIO $ |
|
||||||
XmppOtherFailure |
|
||||||
-- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++ |
|
||||||
-- " /= " ++ show (iqResultID r) ++ " .") |
|
||||||
return $ Right $ Right r |
|
||||||
_ -> return $ Left XmppOtherFailure |
|
||||||
-- TODO: Log: "sendIQ': unexpected stanza type " |
|
||||||
|
|
||||||
-- | Send "</stream:stream>" and wait for the server to finish processing and to |
|
||||||
-- close the connection. Any remaining elements from the server are returned. |
|
||||||
-- Surpresses StreamEndFailure exceptions, but may throw a StreamCloseError. |
|
||||||
closeStreams :: TMVar Connection -> IO (Either XmppFailure [Element]) |
|
||||||
closeStreams = withConnection $ do |
|
||||||
send <- gets (cSend . cHandle) |
|
||||||
cc <- gets (cClose . cHandle) |
|
||||||
liftIO $ send "</stream:stream>" |
|
||||||
void $ liftIO $ forkIO $ do |
|
||||||
threadDelay 3000000 -- TODO: Configurable value |
|
||||||
(Ex.try cc) :: IO (Either Ex.SomeException ()) |
|
||||||
return () |
|
||||||
collectElems [] |
|
||||||
where |
|
||||||
-- Pulls elements from the stream until the stream ends, or an error is |
|
||||||
-- raised. |
|
||||||
collectElems :: [Element] -> StateT Connection IO (Either XmppFailure [Element]) |
|
||||||
collectElems es = do |
|
||||||
result <- pullElement |
|
||||||
case result of |
|
||||||
Left StreamEndFailure -> return $ Right es |
|
||||||
Left e -> return $ Left $ StreamCloseError (es, e) |
|
||||||
Right e -> collectElems (e:es) |
|
||||||
|
|
||||||
debugConduit :: Pipe l ByteString ByteString u IO b |
|
||||||
debugConduit = forever $ do |
|
||||||
s' <- await |
|
||||||
case s' of |
|
||||||
Just s -> do |
|
||||||
liftIO $ BS.putStrLn (BS.append "in: " s) |
|
||||||
yield s |
|
||||||
Nothing -> return () |
|
||||||
@ -0,0 +1,39 @@ |
|||||||
|
-- | |
||||||
|
-- Module: $Header$ |
||||||
|
-- |
||||||
|
-- Maintainer: info@jonkri.com |
||||||
|
-- Stability: unstable |
||||||
|
-- Portability: portable |
||||||
|
-- |
||||||
|
-- This module allows for low-level access to Pontarius XMPP. Generally, the |
||||||
|
-- "Network.Xmpp" module should be used instead. |
||||||
|
-- |
||||||
|
-- The 'Connection' object provides the most low-level access to the XMPP |
||||||
|
-- stream: a simple and single-threaded interface which exposes the conduit |
||||||
|
-- 'Event' source, as well as the input and output byte streams. Custom stateful |
||||||
|
-- 'Connection' functions can be executed using 'withConnection'. |
||||||
|
-- |
||||||
|
-- The TLS, SASL, and 'Session' functionalities of Pontarius XMPP are built on |
||||||
|
-- top of this API. |
||||||
|
|
||||||
|
module Network.Xmpp.Internal |
||||||
|
( Connection(..) |
||||||
|
, ConnectionState(..) |
||||||
|
, ConnectionHandle(..) |
||||||
|
, ServerFeatures(..) |
||||||
|
, connect |
||||||
|
, withConnection |
||||||
|
, startTls |
||||||
|
, simpleAuth |
||||||
|
, auth |
||||||
|
, pushStanza |
||||||
|
, pullStanza |
||||||
|
) |
||||||
|
|
||||||
|
where |
||||||
|
|
||||||
|
import Network.Xmpp.Connection |
||||||
|
import Network.Xmpp.Sasl |
||||||
|
import Network.Xmpp.Tls |
||||||
|
import Network.Xmpp.Types |
||||||
|
import Network.Xmpp.Stream |
||||||
@ -1,205 +0,0 @@ |
|||||||
{-# OPTIONS_HADDOCK hide #-} |
|
||||||
|
|
||||||
-- This module deals with JIDs, also known as XMPP addresses. For more |
|
||||||
-- information on JIDs, see RFC 6122: XMPP: Address Format. |
|
||||||
|
|
||||||
module Network.Xmpp.Jid |
|
||||||
( Jid(..) |
|
||||||
, fromText |
|
||||||
, fromStrings |
|
||||||
, isBare |
|
||||||
, isFull |
|
||||||
) where |
|
||||||
|
|
||||||
import Control.Applicative ((<$>),(<|>)) |
|
||||||
import Control.Monad(guard) |
|
||||||
|
|
||||||
import qualified Data.Attoparsec.Text as AP |
|
||||||
import Data.Maybe(fromJust) |
|
||||||
import qualified Data.Set as Set |
|
||||||
import Data.String (IsString(..)) |
|
||||||
import Data.Text (Text) |
|
||||||
import qualified Data.Text as Text |
|
||||||
import qualified Text.NamePrep as SP |
|
||||||
import qualified Text.StringPrep as SP |
|
||||||
|
|
||||||
-- | A JID is XMPP\'s native format for addressing entities in the network. It |
|
||||||
-- is somewhat similar to an e-mail address but contains three parts instead of |
|
||||||
-- two. |
|
||||||
data Jid = Jid { -- | The @localpart@ of a JID is an optional identifier placed |
|
||||||
-- before the domainpart and separated from the latter by a |
|
||||||
-- \'\@\' character. Typically a localpart uniquely identifies |
|
||||||
-- the entity requesting and using network access provided by a |
|
||||||
-- server (i.e., a local account), although it can also |
|
||||||
-- represent other kinds of entities (e.g., a chat room |
|
||||||
-- associated with a multi-user chat service). The entity |
|
||||||
-- represented by an XMPP localpart is addressed within the |
|
||||||
-- context of a specific domain (i.e., |
|
||||||
-- @localpart\@domainpart@). |
|
||||||
localpart :: !(Maybe Text) |
|
||||||
|
|
||||||
-- | The domainpart typically identifies the /home/ server to |
|
||||||
-- which clients connect for XML routing and data management |
|
||||||
-- functionality. However, it is not necessary for an XMPP |
|
||||||
-- domainpart to identify an entity that provides core XMPP |
|
||||||
-- server functionality (e.g., a domainpart can identify an |
|
||||||
-- entity such as a multi-user chat service, a |
|
||||||
-- publish-subscribe service, or a user directory). |
|
||||||
, domainpart :: !Text |
|
||||||
|
|
||||||
-- | The resourcepart of a JID is an optional identifier placed |
|
||||||
-- after the domainpart and separated from the latter by the |
|
||||||
-- \'\/\' character. A resourcepart can modify either a |
|
||||||
-- @localpart\@domainpart@ address or a mere @domainpart@ |
|
||||||
-- address. Typically a resourcepart uniquely identifies a |
|
||||||
-- specific connection (e.g., a device or location) or object |
|
||||||
-- (e.g., an occupant in a multi-user chat room) belonging to |
|
||||||
-- the entity associated with an XMPP localpart at a domain |
|
||||||
-- (i.e., @localpart\@domainpart/resourcepart@). |
|
||||||
, resourcepart :: !(Maybe Text) |
|
||||||
} deriving Eq |
|
||||||
|
|
||||||
instance Show Jid where |
|
||||||
show (Jid nd dmn res) = |
|
||||||
maybe "" ((++ "@") . Text.unpack) nd ++ Text.unpack dmn ++ |
|
||||||
maybe "" (('/' :) . Text.unpack) res |
|
||||||
|
|
||||||
instance Read Jid where |
|
||||||
readsPrec _ x = case fromText (Text.pack x) of |
|
||||||
Nothing -> [] |
|
||||||
Just j -> [(j,"")] |
|
||||||
|
|
||||||
instance IsString Jid where |
|
||||||
fromString = fromJust . fromText . Text.pack |
|
||||||
|
|
||||||
-- | Converts a Text to a JID. |
|
||||||
fromText :: Text -> Maybe Jid |
|
||||||
fromText t = do |
|
||||||
(l, d, r) <- eitherToMaybe $ AP.parseOnly jidParts t |
|
||||||
fromStrings l d r |
|
||||||
where |
|
||||||
eitherToMaybe = either (const Nothing) Just |
|
||||||
|
|
||||||
-- | Converts localpart, domainpart, and resourcepart strings to a JID. Runs the |
|
||||||
-- appropriate stringprep profiles and validates the parts. |
|
||||||
fromStrings :: Maybe Text -> Text -> Maybe Text -> Maybe Jid |
|
||||||
fromStrings l d r = do |
|
||||||
localPart <- case l of |
|
||||||
Nothing -> return Nothing |
|
||||||
Just l'-> do |
|
||||||
l'' <- SP.runStringPrep nodeprepProfile l' |
|
||||||
guard $ validPartLength l'' |
|
||||||
let prohibMap = Set.fromList nodeprepExtraProhibitedCharacters |
|
||||||
guard $ Text.all (`Set.notMember` prohibMap) l'' |
|
||||||
return $ Just l'' |
|
||||||
domainPart <- SP.runStringPrep (SP.namePrepProfile False) d |
|
||||||
guard $ validDomainPart domainPart |
|
||||||
resourcePart <- case r of |
|
||||||
Nothing -> return Nothing |
|
||||||
Just r' -> do |
|
||||||
r'' <- SP.runStringPrep resourceprepProfile r' |
|
||||||
guard $ validPartLength r'' |
|
||||||
return $ Just r'' |
|
||||||
return $ Jid localPart domainPart resourcePart |
|
||||||
where |
|
||||||
validDomainPart :: Text -> Bool |
|
||||||
validDomainPart _s = True -- TODO |
|
||||||
|
|
||||||
validPartLength :: Text -> Bool |
|
||||||
validPartLength p = Text.length p > 0 && Text.length p < 1024 |
|
||||||
|
|
||||||
-- | Returns 'True' if the JID is /bare/, and 'False' otherwise. |
|
||||||
isBare :: Jid -> Bool |
|
||||||
isBare j | resourcepart j == Nothing = True |
|
||||||
| otherwise = False |
|
||||||
|
|
||||||
-- | Returns 'True' if the JID is /full/, and 'False' otherwise. |
|
||||||
isFull :: Jid -> Bool |
|
||||||
isFull = not . isBare |
|
||||||
|
|
||||||
-- Parses an JID string and returns its three parts. It performs no validation |
|
||||||
-- or transformations. |
|
||||||
jidParts :: AP.Parser (Maybe Text, Text, Maybe Text) |
|
||||||
jidParts = do |
|
||||||
-- Read until we reach an '@', a '/', or EOF. |
|
||||||
a <- AP.takeWhile1 (AP.notInClass ['@', '/']) |
|
||||||
-- Case 1: We found an '@', and thus the localpart. At least the domainpart |
|
||||||
-- is remaining. Read the '@' and until a '/' or EOF. |
|
||||||
do |
|
||||||
b <- domainPartP |
|
||||||
-- Case 1A: We found a '/' and thus have all the JID parts. Read the '/' |
|
||||||
-- and until EOF. |
|
||||||
do |
|
||||||
c <- resourcePartP -- Parse resourcepart |
|
||||||
return (Just a, b, Just c) |
|
||||||
-- Case 1B: We have reached EOF; the JID is in the form |
|
||||||
-- localpart@domainpart. |
|
||||||
<|> do |
|
||||||
AP.endOfInput |
|
||||||
return (Just a, b, Nothing) |
|
||||||
-- Case 2: We found a '/'; the JID is in the form |
|
||||||
-- domainpart/resourcepart. |
|
||||||
<|> do |
|
||||||
b <- resourcePartP |
|
||||||
AP.endOfInput |
|
||||||
return (Nothing, a, Just b) |
|
||||||
-- Case 3: We have reached EOF; we have an JID consisting of only a |
|
||||||
-- domainpart. |
|
||||||
<|> do |
|
||||||
AP.endOfInput |
|
||||||
return (Nothing, a, Nothing) |
|
||||||
where |
|
||||||
-- Read an '@' and everything until a '/'. |
|
||||||
domainPartP :: AP.Parser Text |
|
||||||
domainPartP = do |
|
||||||
_ <- AP.char '@' |
|
||||||
AP.takeWhile1 (/= '/') |
|
||||||
-- Read everything until a '/'. |
|
||||||
resourcePartP :: AP.Parser Text |
|
||||||
resourcePartP = do |
|
||||||
_ <- AP.char '/' |
|
||||||
AP.takeText |
|
||||||
|
|
||||||
-- The `nodeprep' StringPrep profile. |
|
||||||
nodeprepProfile :: SP.StringPrepProfile |
|
||||||
nodeprepProfile = SP.Profile { SP.maps = [SP.b1, SP.b2] |
|
||||||
, SP.shouldNormalize = True |
|
||||||
, SP.prohibited = [SP.a1 |
|
||||||
, SP.c11 |
|
||||||
, SP.c12 |
|
||||||
, SP.c21 |
|
||||||
, SP.c22 |
|
||||||
, SP.c3 |
|
||||||
, SP.c4 |
|
||||||
, SP.c5 |
|
||||||
, SP.c6 |
|
||||||
, SP.c7 |
|
||||||
, SP.c8 |
|
||||||
, SP.c9 |
|
||||||
] |
|
||||||
, SP.shouldCheckBidi = True |
|
||||||
} |
|
||||||
|
|
||||||
-- These characters needs to be checked for after normalization. |
|
||||||
nodeprepExtraProhibitedCharacters :: [Char] |
|
||||||
nodeprepExtraProhibitedCharacters = ['\x22', '\x26', '\x27', '\x2F', '\x3A', |
|
||||||
'\x3C', '\x3E', '\x40'] |
|
||||||
|
|
||||||
-- The `resourceprep' StringPrep profile. |
|
||||||
resourceprepProfile :: SP.StringPrepProfile |
|
||||||
resourceprepProfile = SP.Profile { SP.maps = [SP.b1] |
|
||||||
, SP.shouldNormalize = True |
|
||||||
, SP.prohibited = [ SP.a1 |
|
||||||
, SP.c12 |
|
||||||
, SP.c21 |
|
||||||
, SP.c22 |
|
||||||
, SP.c3 |
|
||||||
, SP.c4 |
|
||||||
, SP.c5 |
|
||||||
, SP.c6 |
|
||||||
, SP.c7 |
|
||||||
, SP.c8 |
|
||||||
, SP.c9 |
|
||||||
] |
|
||||||
, SP.shouldCheckBidi = True |
|
||||||
} |
|
||||||
@ -1,36 +0,0 @@ |
|||||||
{-# LANGUAGE RecordWildCards #-} |
|
||||||
{-# OPTIONS_HADDOCK hide #-} |
|
||||||
|
|
||||||
module Network.Xmpp.Message |
|
||||||
( Message(..) |
|
||||||
, MessageError(..) |
|
||||||
, MessageType(..) |
|
||||||
, answerMessage |
|
||||||
, message |
|
||||||
) where |
|
||||||
|
|
||||||
import Data.XML.Types |
|
||||||
|
|
||||||
import Network.Xmpp.Types |
|
||||||
|
|
||||||
-- | An empty message. |
|
||||||
message :: Message |
|
||||||
message = Message { messageID = Nothing |
|
||||||
, messageFrom = Nothing |
|
||||||
, messageTo = Nothing |
|
||||||
, messageLangTag = Nothing |
|
||||||
, messageType = Normal |
|
||||||
, messagePayload = [] |
|
||||||
} |
|
||||||
|
|
||||||
-- Produce an answer message with the given payload, switching the "from" and |
|
||||||
-- "to" attributes in the original message. |
|
||||||
answerMessage :: Message -> [Element] -> Maybe Message |
|
||||||
answerMessage Message{messageFrom = Just frm, ..} payload = |
|
||||||
Just Message{ messageFrom = messageTo |
|
||||||
, messageID = Nothing |
|
||||||
, messageTo = Just frm |
|
||||||
, messagePayload = payload |
|
||||||
, .. |
|
||||||
} |
|
||||||
answerMessage _ _ = Nothing |
|
||||||
@ -1,78 +0,0 @@ |
|||||||
{-# OPTIONS_HADDOCK hide #-} |
|
||||||
|
|
||||||
{-# LANGUAGE NoMonomorphismRestriction #-} |
|
||||||
{-# LANGUAGE OverloadedStrings #-} |
|
||||||
{-# LANGUAGE TupleSections #-} |
|
||||||
|
|
||||||
-- Marshalling between XML and Native Types |
|
||||||
|
|
||||||
|
|
||||||
module Network.Xmpp.Pickle |
|
||||||
( mbToBool |
|
||||||
, xmlLang |
|
||||||
, xpLangTag |
|
||||||
, xpNodeElem |
|
||||||
, ignoreAttrs |
|
||||||
, mbl |
|
||||||
, lmb |
|
||||||
, right |
|
||||||
, unpickleElem' |
|
||||||
, unpickleElem |
|
||||||
, pickleElem |
|
||||||
, ppElement |
|
||||||
) where |
|
||||||
|
|
||||||
import Data.XML.Types |
|
||||||
import Data.XML.Pickle |
|
||||||
|
|
||||||
import Network.Xmpp.Types |
|
||||||
|
|
||||||
import Text.Xml.Stream.Elements |
|
||||||
|
|
||||||
mbToBool :: Maybe t -> Bool |
|
||||||
mbToBool (Just _) = True |
|
||||||
mbToBool _ = False |
|
||||||
|
|
||||||
xmlLang :: Name |
|
||||||
xmlLang = Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml") |
|
||||||
|
|
||||||
xpLangTag :: PU [Attribute] (Maybe LangTag) |
|
||||||
xpLangTag = xpAttrImplied xmlLang xpPrim |
|
||||||
|
|
||||||
xpNodeElem :: PU [Node] a -> PU Element a |
|
||||||
xpNodeElem xp = PU { pickleTree = \x -> head $ (pickleTree xp x) >>= \y -> |
|
||||||
case y of |
|
||||||
NodeElement e -> [e] |
|
||||||
_ -> [] |
|
||||||
, unpickleTree = \x -> case unpickleTree xp $ [NodeElement x] of |
|
||||||
Left l -> Left l |
|
||||||
Right (a,(_,c)) -> Right (a,(Nothing,c)) |
|
||||||
} |
|
||||||
|
|
||||||
ignoreAttrs :: PU t ((), b) -> PU t b |
|
||||||
ignoreAttrs = xpWrap snd ((),) |
|
||||||
|
|
||||||
mbl :: Maybe [a] -> [a] |
|
||||||
mbl (Just l) = l |
|
||||||
mbl Nothing = [] |
|
||||||
|
|
||||||
lmb :: [t] -> Maybe [t] |
|
||||||
lmb [] = Nothing |
|
||||||
lmb x = Just x |
|
||||||
|
|
||||||
right :: Either [Char] t -> t |
|
||||||
right (Left l) = error l |
|
||||||
right (Right r) = r |
|
||||||
|
|
||||||
unpickleElem' :: PU [Node] c -> Element -> c |
|
||||||
unpickleElem' p x = case unpickle (xpNodeElem p) x of |
|
||||||
Left l -> error $ (show l) ++ "\n saw: " ++ ppElement x |
|
||||||
Right r -> r |
|
||||||
|
|
||||||
-- Given a pickler and an element, produces an object. |
|
||||||
unpickleElem :: PU [Node] a -> Element -> Either UnpickleError a |
|
||||||
unpickleElem p x = unpickle (xpNodeElem p) x |
|
||||||
|
|
||||||
-- Given a pickler and an object, produces an Element. |
|
||||||
pickleElem :: PU [Node] a -> a -> Element |
|
||||||
pickleElem p = pickle $ xpNodeElem p |
|
||||||
@ -1,10 +0,0 @@ |
|||||||
{-# OPTIONS_HADDOCK hide #-} |
|
||||||
|
|
||||||
module Network.Xmpp.Presence where |
|
||||||
|
|
||||||
import Data.Text(Text) |
|
||||||
import Network.Xmpp.Types |
|
||||||
|
|
||||||
-- | Add a recipient to a presence notification. |
|
||||||
presTo :: Presence -> Jid -> Presence |
|
||||||
presTo pres to = pres{presenceTo = Just to} |
|
||||||
@ -1,116 +0,0 @@ |
|||||||
{-# OPTIONS_HADDOCK hide #-} |
|
||||||
{-# LANGUAGE OverloadedStrings #-} |
|
||||||
module Network.Xmpp.Session where |
|
||||||
|
|
||||||
import qualified Control.Exception as Ex |
|
||||||
import Control.Monad.Error |
|
||||||
import Data.Text as Text |
|
||||||
import Data.XML.Pickle |
|
||||||
import Data.XML.Types(Element) |
|
||||||
import Network |
|
||||||
import qualified Network.TLS as TLS |
|
||||||
import Network.Xmpp.Bind |
|
||||||
import Network.Xmpp.Concurrent.Types |
|
||||||
import Network.Xmpp.Concurrent |
|
||||||
import Network.Xmpp.Connection_ |
|
||||||
import Network.Xmpp.Marshal |
|
||||||
import Network.Xmpp.Pickle |
|
||||||
import Network.Xmpp.Sasl |
|
||||||
import Network.Xmpp.Sasl.Mechanisms |
|
||||||
import Network.Xmpp.Sasl.Types |
|
||||||
import Network.Xmpp.Stream |
|
||||||
import Network.Xmpp.Tls |
|
||||||
import Network.Xmpp.Types |
|
||||||
import Control.Concurrent.STM.TMVar |
|
||||||
import Data.Maybe |
|
||||||
|
|
||||||
-- | Creates a 'Session' object by setting up a connection with an XMPP server. |
|
||||||
-- |
|
||||||
-- Will connect to the specified host. If the fourth parameters is a 'Just' |
|
||||||
-- value, @session@ will attempt to secure the connection with TLS. If the fifth |
|
||||||
-- parameters is a 'Just' value, @session@ will attempt to authenticate and |
|
||||||
-- acquire an XMPP resource. |
|
||||||
session :: HostName -- ^ Host to connect to |
|
||||||
-> Text -- ^ The realm host name (to |
|
||||||
-- distinguish the XMPP service) |
|
||||||
-> PortID -- ^ Port to connect to |
|
||||||
-> Maybe TLS.TLSParams -- ^ TLS settings, if securing the |
|
||||||
-- connection to the server is |
|
||||||
-- desired |
|
||||||
-> Maybe ([SaslHandler], Maybe Text) -- ^ SASL handlers and the desired |
|
||||||
-- JID resource (or Nothing to let |
|
||||||
-- the server decide) |
|
||||||
-> IO (Either XmppFailure (Session, Maybe AuthFailure)) |
|
||||||
session hostname realm port tls sasl = runErrorT $ do |
|
||||||
con <- ErrorT $ connect hostname port realm |
|
||||||
if isJust tls |
|
||||||
then ErrorT $ startTls (fromJust tls) con |
|
||||||
else return () |
|
||||||
aut <- if isJust sasl |
|
||||||
then ErrorT $ auth (fst $ fromJust sasl) (snd $ fromJust sasl) con |
|
||||||
else return Nothing |
|
||||||
ses <- ErrorT $ newSession con |
|
||||||
return (ses, aut) |
|
||||||
|
|
||||||
-- | Connects to the XMPP server and opens the XMPP stream against the given |
|
||||||
-- host name, port, and realm. |
|
||||||
connect :: HostName -> PortID -> Text -> IO (Either XmppFailure (TMVar Connection)) |
|
||||||
connect address port hostname = do |
|
||||||
con <- connectTcp address port hostname |
|
||||||
case con of |
|
||||||
Right con' -> do |
|
||||||
result <- withConnection startStream con' |
|
||||||
return $ Right con' |
|
||||||
Left e -> do |
|
||||||
return $ Left e |
|
||||||
|
|
||||||
sessionXml :: Element |
|
||||||
sessionXml = pickleElem |
|
||||||
(xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session") |
|
||||||
() |
|
||||||
|
|
||||||
sessionIQ :: Stanza |
|
||||||
sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" |
|
||||||
, iqRequestFrom = Nothing |
|
||||||
, iqRequestTo = Nothing |
|
||||||
, iqRequestLangTag = Nothing |
|
||||||
, iqRequestType = Set |
|
||||||
, iqRequestPayload = sessionXml |
|
||||||
} |
|
||||||
|
|
||||||
-- Sends the session IQ set element and waits for an answer. Throws an error if |
|
||||||
-- if an IQ error stanza is returned from the server. |
|
||||||
startSession :: TMVar Connection -> IO () |
|
||||||
startSession con = do |
|
||||||
answer <- pushIQ' "session" Nothing Set Nothing sessionXml con |
|
||||||
case answer of |
|
||||||
Left e -> error $ show e |
|
||||||
Right _ -> return () |
|
||||||
|
|
||||||
-- | Authenticate to the server using the first matching method and bind a |
|
||||||
-- resource. |
|
||||||
auth :: [SaslHandler] |
|
||||||
-> Maybe Text |
|
||||||
-> TMVar Connection |
|
||||||
-> IO (Either XmppFailure (Maybe AuthFailure)) |
|
||||||
auth mechanisms resource con = runErrorT $ do |
|
||||||
ErrorT $ xmppSasl mechanisms con |
|
||||||
jid <- lift $ xmppBind resource con |
|
||||||
lift $ startSession con |
|
||||||
return Nothing |
|
||||||
|
|
||||||
-- | Authenticate to the server with the given username and password |
|
||||||
-- and bind a resource. |
|
||||||
-- |
|
||||||
-- Prefers SCRAM-SHA1 over DIGEST-MD5. |
|
||||||
simpleAuth :: Text.Text -- ^ The username |
|
||||||
-> Text.Text -- ^ The password |
|
||||||
-> Maybe Text -- ^ The desired resource or 'Nothing' to let the |
|
||||||
-- server assign one |
|
||||||
-> TMVar Connection |
|
||||||
-> IO (Either XmppFailure (Maybe AuthFailure)) |
|
||||||
simpleAuth username passwd resource = flip auth resource $ |
|
||||||
[ -- TODO: scramSha1Plus |
|
||||||
scramSha1 username Nothing passwd |
|
||||||
, digestMd5 username Nothing passwd |
|
||||||
] |
|
||||||
Loading…
Reference in new issue