Philipp Balzarek
13 years ago
6 changed files with 0 additions and 550 deletions
@ -1,23 +0,0 @@ |
|||||||
module Network.Xmpp.Basic |
|
||||||
( Connection(..) |
|
||||||
, ConnectionState(..) |
|
||||||
, connectTcp |
|
||||||
, simpleConnect |
|
||||||
, startTLS |
|
||||||
, exampleParams |
|
||||||
, simpleAuth |
|
||||||
, auth |
|
||||||
, scramSha1 |
|
||||||
, digestMd5 |
|
||||||
, plain |
|
||||||
, pushStanza |
|
||||||
, pullStanza |
|
||||||
) |
|
||||||
|
|
||||||
where |
|
||||||
|
|
||||||
import Network.Xmpp.Connection |
|
||||||
import Network.Xmpp.Sasl |
|
||||||
import Network.Xmpp.Session |
|
||||||
import Network.Xmpp.TLS |
|
||||||
import Network.Xmpp.Types |
|
||||||
@ -1,32 +0,0 @@ |
|||||||
{-# OPTIONS_HADDOCK hide #-} |
|
||||||
module Network.Xmpp.Concurrent.Channels.Types where |
|
||||||
|
|
||||||
import Control.Concurrent.STM |
|
||||||
import Data.IORef |
|
||||||
import qualified Data.Map as Map |
|
||||||
import Data.Text (Text) |
|
||||||
import Network.Xmpp.Concurrent.Types |
|
||||||
import Network.Xmpp.Types |
|
||||||
|
|
||||||
-- | An XMPP session context |
|
||||||
data Session = Session |
|
||||||
{ context :: Context |
|
||||||
, stanzaCh :: TChan Stanza -- All stanzas |
|
||||||
, outCh :: TChan Stanza |
|
||||||
, iqHandlers :: TVar IQHandlers |
|
||||||
-- Writing lock, so that only one thread could write to the stream at any |
|
||||||
-- given time. |
|
||||||
} |
|
||||||
|
|
||||||
-- | IQHandlers holds the registered channels for incomming IQ requests and |
|
||||||
-- TMVars of and TMVars for expected IQ responses |
|
||||||
type IQHandlers = (Map.Map (IQRequestType, Text) (TChan IQRequestTicket) |
|
||||||
, Map.Map StanzaID (TMVar IQResponse) |
|
||||||
) |
|
||||||
|
|
||||||
-- | Contains whether or not a reply has been sent, and the IQ request body to |
|
||||||
-- reply to. |
|
||||||
data IQRequestTicket = IQRequestTicket |
|
||||||
{ sentRef :: (TVar Bool) |
|
||||||
, iqRequestBody :: IQRequest |
|
||||||
} |
|
||||||
@ -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 () |
|
||||||
@ -1,49 +0,0 @@ |
|||||||
{-# LANGUAGE FlexibleContexts #-} |
|
||||||
{-# LANGUAGE OverloadedStrings #-} |
|
||||||
module Network.Xmpp.Errors where |
|
||||||
|
|
||||||
import Control.Applicative ((<$>)) |
|
||||||
import Control.Monad(unless) |
|
||||||
import Control.Monad.Error |
|
||||||
import Control.Monad.Error.Class |
|
||||||
import qualified Data.Text as Text |
|
||||||
import Data.XML.Types |
|
||||||
import Network.Xmpp.Types |
|
||||||
import Network.Xmpp.Pickle |
|
||||||
|
|
||||||
|
|
||||||
-- Finds unpickling problems. Not to be used for data validation |
|
||||||
findStreamErrors :: Element -> StreamError |
|
||||||
findStreamErrors (Element name attrs children) |
|
||||||
| (nameLocalName name /= "stream") |
|
||||||
= StreamNotStreamElement $ nameLocalName name |
|
||||||
| (nameNamespace name /= Just "http://etherx.jabber.org/streams") |
|
||||||
= StreamInvalidStreamNamespace $ nameNamespace name |
|
||||||
| otherwise = checkchildren (flattenAttrs attrs) |
|
||||||
where |
|
||||||
checkchildren children = |
|
||||||
let to' = lookup "to" children |
|
||||||
ver' = lookup "version" children |
|
||||||
xl = lookup xmlLang children |
|
||||||
in case () of () | Just (Nothing :: Maybe Jid) == (safeRead <$> to') |
|
||||||
-> StreamWrongTo to' |
|
||||||
| Nothing == ver' |
|
||||||
-> StreamWrongVersion Nothing |
|
||||||
| Just (Nothing :: Maybe LangTag) == |
|
||||||
(safeRead <$> xl) |
|
||||||
-> StreamWrongLangTag xl |
|
||||||
| otherwise |
|
||||||
-> StreamUnknownError |
|
||||||
safeRead x = case reads $ Text.unpack x of |
|
||||||
[] -> Nothing |
|
||||||
((y,_):_) -> Just y |
|
||||||
|
|
||||||
flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)] |
|
||||||
flattenAttrs attrs = map (\(name, content) -> |
|
||||||
( name |
|
||||||
, Text.concat $ map uncontentify content) |
|
||||||
) |
|
||||||
attrs |
|
||||||
where |
|
||||||
uncontentify (ContentText t) = t |
|
||||||
uncontentify _ = "" |
|
||||||
@ -1,45 +0,0 @@ |
|||||||
{-# OPTIONS_HADDOCK hide #-} |
|
||||||
|
|
||||||
{-# LANGUAGE NoMonomorphismRestriction #-} |
|
||||||
{-# LANGUAGE OverloadedStrings #-} |
|
||||||
{-# LANGUAGE TupleSections #-} |
|
||||||
|
|
||||||
-- Marshalling between XML and Native Types |
|
||||||
|
|
||||||
|
|
||||||
module Network.Xmpp.Pickle |
|
||||||
( xmlLang |
|
||||||
, xpLangTag |
|
||||||
, unpickleElem' |
|
||||||
, unpickleElem |
|
||||||
, pickleElem |
|
||||||
) |
|
||||||
where |
|
||||||
|
|
||||||
import Data.XML.Types |
|
||||||
import Data.XML.Pickle |
|
||||||
|
|
||||||
import Network.Xmpp.Types |
|
||||||
|
|
||||||
import Text.Xml.Stream.Elements |
|
||||||
|
|
||||||
xmlLang :: Name |
|
||||||
xmlLang = Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml") |
|
||||||
|
|
||||||
xpLangTag :: PU [Attribute] (Maybe LangTag) |
|
||||||
xpLangTag = xpAttrImplied xmlLang xpPrim |
|
||||||
|
|
||||||
-- Given a pickler and an element, produces an object. |
|
||||||
unpickleElem :: PU [Node] a -> Element -> Either UnpickleError a |
|
||||||
unpickleElem p x = unpickle p [NodeElement x] |
|
||||||
|
|
||||||
unpickleElem' :: PU [Node] c -> Element -> c |
|
||||||
unpickleElem' p x = case unpickleElem p x of |
|
||||||
Left l -> error $ (show l) ++ "\n saw: " ++ ppElement x |
|
||||||
Right r -> r |
|
||||||
|
|
||||||
-- Given a pickler and an object, produces an Element. |
|
||||||
pickleElem :: PU [Node] a -> a -> Element |
|
||||||
pickleElem p x = case pickle p x of |
|
||||||
[NodeElement e] -> e |
|
||||||
_ -> error "pickleElem: Pickler didn't return a single element." |
|
||||||
@ -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 |
|
||||||
case tls of |
|
||||||
Just tls' -> ErrorT $ startTls tls' con |
|
||||||
Nothing -> return () |
|
||||||
aut <- case sasl of |
|
||||||
Just sasl' -> ErrorT $ auth (fst sasl) (snd sasl) con |
|
||||||
Nothing -> 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