{-# LANGUAGE TupleSections #-}
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.Xmpp.Concurrent
( module Network.Xmpp.Concurrent.Monad
, module Network.Xmpp.Concurrent.Threads
, module Network.Xmpp.Concurrent.Basic
, module Network.Xmpp.Concurrent.Types
, module Network.Xmpp.Concurrent.Message
, module Network.Xmpp.Concurrent.Presence
, module Network.Xmpp.Concurrent.IQ
, newSession
, session
, newStanzaID
, reconnect
, reconnect'
, reconnectNow
, simpleAuth
) where
import Control.Applicative ((<$>))
import Control.Arrow (second)
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM
import qualified Control.Exception as Ex
import Control.Monad
import Control.Monad.Except
import qualified Data.List as List
import qualified Data.Map as Map
import Data.Maybe
import Data.Text as Text
import Data.XML.Types
import Network.Socket
import Network.Xmpp.Concurrent.Basic
import Network.Xmpp.Concurrent.IQ
import Network.Xmpp.Concurrent.Message
import Network.Xmpp.Concurrent.Monad
import Network.Xmpp.Concurrent.Presence
import Network.Xmpp.Concurrent.Threads
import Network.Xmpp.Concurrent.Types
import Network.Xmpp.IM.Roster
import Network.Xmpp.IM.Roster.Types
import Network.Xmpp.IM.PresenceTracker
import Network.Xmpp.IM.PresenceTracker.Types
import Network.Xmpp.Sasl
import Network.Xmpp.Sasl.Types
import Network.Xmpp.Stream
import Network.Xmpp.Tls
import Network.Xmpp.Types
import System.Log.Logger
import System.Random (randomRIO)
import Control.Monad.State.Strict
runHandlers :: [ XmppElement
-> [Annotation]
-> IO [Annotated XmppElement]
]
-> XmppElement
-> IO ()
runHandlers :: [XmppElement -> [Annotation] -> IO [Annotated XmppElement]]
-> XmppElement -> IO ()
runHandlers [] XmppElement
sta = do
String -> String -> IO ()
errorM String
"Pontarius.Xmpp" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"No stanza handlers set, discarding stanza" String -> String -> String
forall a. [a] -> [a] -> [a]
++ XmppElement -> String
forall a. Show a => a -> String
show XmppElement
sta
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runHandlers [XmppElement -> [Annotation] -> IO [Annotated XmppElement]]
hs XmppElement
sta = [XmppElement -> [Annotation] -> IO [Annotated XmppElement]]
-> XmppElement -> [Annotation] -> IO ()
forall (m :: * -> *) (t :: * -> *) t a.
(Monad m, Foldable t) =>
[t -> [a] -> m (t (t, [a]))] -> t -> [a] -> m ()
go [XmppElement -> [Annotation] -> IO [Annotated XmppElement]]
hs XmppElement
sta []
where go :: [t -> [a] -> m (t (t, [a]))] -> t -> [a] -> m ()
go [] t
_ [a]
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go (t -> [a] -> m (t (t, [a]))
h:[t -> [a] -> m (t (t, [a]))]
hands) t
sta' [a]
as = do
t (t, [a])
res <- t -> [a] -> m (t (t, [a]))
h t
sta' [a]
as
t (t, [a]) -> ((t, [a]) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t (t, [a])
res (((t, [a]) -> m ()) -> m ()) -> ((t, [a]) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(t
sta'', [a]
as') -> [t -> [a] -> m (t (t, [a]))] -> t -> [a] -> m ()
go [t -> [a] -> m (t (t, [a]))]
hands t
sta'' ([a]
as [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
as')
toChan :: TChan (Annotated Stanza) -> StanzaHandler
toChan :: TChan (Annotated Stanza) -> StanzaHandler
toChan TChan (Annotated Stanza)
stanzaC XmppElement -> IO (Either XmppFailure ())
_ XmppElement
sta [Annotation]
as = do
case XmppElement
sta of
XmppStanza Stanza
s -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan (Annotated Stanza) -> Annotated Stanza -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan (Annotated Stanza)
stanzaC (Stanza
s, [Annotation]
as)
XmppElement
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[Annotated XmppElement] -> IO [Annotated XmppElement]
forall (m :: * -> *) a. Monad m => a -> m a
return [(XmppElement
sta, [])]
handleIQ :: TVar IQHandlers
-> StanzaHandler
handleIQ :: TVar IQHandlers -> StanzaHandler
handleIQ TVar IQHandlers
_ XmppElement -> IO (Either XmppFailure ())
_ s :: XmppElement
s@XmppNonza{} [Annotation]
_ = [Annotated XmppElement] -> IO [Annotated XmppElement]
forall (m :: * -> *) a. Monad m => a -> m a
return [(XmppElement
s, [])]
handleIQ TVar IQHandlers
iqHands XmppElement -> IO (Either XmppFailure ())
out s :: XmppElement
s@(XmppStanza Stanza
sta) [Annotation]
as = do
case Stanza
sta of
IQRequestS IQRequest
i -> TVar IQHandlers -> IQRequest -> IO ()
handleIQRequest TVar IQHandlers
iqHands IQRequest
i IO () -> IO [Annotated XmppElement] -> IO [Annotated XmppElement]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Annotated XmppElement] -> IO [Annotated XmppElement]
forall (m :: * -> *) a. Monad m => a -> m a
return []
IQResultS IQResult
i -> TVar IQHandlers -> Either IQError IQResult -> IO ()
handleIQResponse TVar IQHandlers
iqHands (IQResult -> Either IQError IQResult
forall a b. b -> Either a b
Right IQResult
i) IO () -> IO [Annotated XmppElement] -> IO [Annotated XmppElement]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Annotated XmppElement] -> IO [Annotated XmppElement]
forall (m :: * -> *) a. Monad m => a -> m a
return []
IQErrorS IQError
i -> TVar IQHandlers -> Either IQError IQResult -> IO ()
handleIQResponse TVar IQHandlers
iqHands (IQError -> Either IQError IQResult
forall a b. a -> Either a b
Left IQError
i) IO () -> IO [Annotated XmppElement] -> IO [Annotated XmppElement]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Annotated XmppElement] -> IO [Annotated XmppElement]
forall (m :: * -> *) a. Monad m => a -> m a
return []
Stanza
_ -> [Annotated XmppElement] -> IO [Annotated XmppElement]
forall (m :: * -> *) a. Monad m => a -> m a
return [(XmppElement
s, [])]
where
handleIQRequest :: TVar IQHandlers -> IQRequest -> IO ()
handleIQRequest :: TVar IQHandlers -> IQRequest -> IO ()
handleIQRequest TVar IQHandlers
handlers IQRequest
iq = do
Maybe Stanza
res <- STM (Maybe Stanza) -> IO (Maybe Stanza)
forall a. STM a -> IO a
atomically (STM (Maybe Stanza) -> IO (Maybe Stanza))
-> STM (Maybe Stanza) -> IO (Maybe Stanza)
forall a b. (a -> b) -> a -> b
$ do
(Map (IQRequestType, Text) (TChan IQRequestTicket)
byNS, Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
_) <- TVar IQHandlers -> STM IQHandlers
forall a. TVar a -> STM a
readTVar TVar IQHandlers
handlers
let iqNS :: Text
iqNS = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Name -> Maybe Text
nameNamespace (Name -> Maybe Text) -> (Element -> Name) -> Element -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Name
elementName
(Element -> Maybe Text) -> Element -> Maybe Text
forall a b. (a -> b) -> a -> b
$ IQRequest -> Element
iqRequestPayload IQRequest
iq)
case (IQRequestType, Text)
-> Map (IQRequestType, Text) (TChan IQRequestTicket)
-> Maybe (TChan IQRequestTicket)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (IQRequest -> IQRequestType
iqRequestType IQRequest
iq, Text
iqNS) Map (IQRequestType, Text) (TChan IQRequestTicket)
byNS of
Maybe (TChan IQRequestTicket)
Nothing -> Maybe Stanza -> STM (Maybe Stanza)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Stanza -> STM (Maybe Stanza))
-> (Stanza -> Maybe Stanza) -> Stanza -> STM (Maybe Stanza)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stanza -> Maybe Stanza
forall a. a -> Maybe a
Just (Stanza -> STM (Maybe Stanza)) -> Stanza -> STM (Maybe Stanza)
forall a b. (a -> b) -> a -> b
$ IQRequest -> Stanza
serviceUnavailable IQRequest
iq
Just TChan IQRequestTicket
ch -> do
TMVar Bool
sentRef <- Bool -> STM (TMVar Bool)
forall a. a -> STM (TMVar a)
newTMVar Bool
False
let answerT :: Either StanzaError (Maybe Element)
-> [ExtendedAttribute] -> IO (Maybe (Either XmppFailure ()))
answerT Either StanzaError (Maybe Element)
answer [ExtendedAttribute]
attrs = do
let IQRequest Text
iqid Maybe Jid
from Maybe Jid
_to Maybe LangTag
lang IQRequestType
_tp Element
bd [ExtendedAttribute]
_attrs = IQRequest
iq
response :: Stanza
response = case Either StanzaError (Maybe Element)
answer of
Left er -> IQError -> Stanza
IQErrorS (IQError -> Stanza) -> IQError -> Stanza
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Jid
-> Maybe Jid
-> Maybe LangTag
-> StanzaError
-> Maybe Element
-> [ExtendedAttribute]
-> IQError
IQError Text
iqid Maybe Jid
forall a. Maybe a
Nothing
Maybe Jid
from Maybe LangTag
lang StanzaError
er
(Element -> Maybe Element
forall a. a -> Maybe a
Just Element
bd) [ExtendedAttribute]
attrs
Right res -> IQResult -> Stanza
IQResultS (IQResult -> Stanza) -> IQResult -> Stanza
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Jid
-> Maybe Jid
-> Maybe LangTag
-> Maybe Element
-> [ExtendedAttribute]
-> IQResult
IQResult Text
iqid Maybe Jid
forall a. Maybe a
Nothing
Maybe Jid
from Maybe LangTag
lang Maybe Element
res
[ExtendedAttribute]
attrs
IO Bool
-> (Bool -> IO Bool)
-> (Bool -> IO (Maybe (Either XmppFailure ())))
-> IO (Maybe (Either XmppFailure ()))
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Ex.bracketOnError (STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TMVar Bool -> STM Bool
forall a. TMVar a -> STM a
takeTMVar TMVar Bool
sentRef)
(STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> (Bool -> STM Bool) -> Bool -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar Bool -> Bool -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar Bool
sentRef)
((Bool -> IO (Maybe (Either XmppFailure ())))
-> IO (Maybe (Either XmppFailure ())))
-> (Bool -> IO (Maybe (Either XmppFailure ())))
-> IO (Maybe (Either XmppFailure ()))
forall a b. (a -> b) -> a -> b
$ \Bool
wasSent -> do
case Bool
wasSent of
Bool
True -> do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar Bool -> Bool -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar Bool
sentRef Bool
True
Maybe (Either XmppFailure ()) -> IO (Maybe (Either XmppFailure ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either XmppFailure ())
forall a. Maybe a
Nothing
Bool
False -> do
Either XmppFailure ()
didSend <- XmppElement -> IO (Either XmppFailure ())
out (XmppElement -> IO (Either XmppFailure ()))
-> XmppElement -> IO (Either XmppFailure ())
forall a b. (a -> b) -> a -> b
$ Stanza -> XmppElement
XmppStanza Stanza
response
case Either XmppFailure ()
didSend of
Right () -> do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar Bool -> Bool -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar Bool
sentRef Bool
True
Maybe (Either XmppFailure ()) -> IO (Maybe (Either XmppFailure ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either XmppFailure ())
-> IO (Maybe (Either XmppFailure ())))
-> Maybe (Either XmppFailure ())
-> IO (Maybe (Either XmppFailure ()))
forall a b. (a -> b) -> a -> b
$ Either XmppFailure () -> Maybe (Either XmppFailure ())
forall a. a -> Maybe a
Just (() -> Either XmppFailure ()
forall a b. b -> Either a b
Right ())
er :: Either XmppFailure ()
er@Left{} -> do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar Bool -> Bool -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar Bool
sentRef Bool
False
Maybe (Either XmppFailure ()) -> IO (Maybe (Either XmppFailure ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either XmppFailure ())
-> IO (Maybe (Either XmppFailure ())))
-> Maybe (Either XmppFailure ())
-> IO (Maybe (Either XmppFailure ()))
forall a b. (a -> b) -> a -> b
$ Either XmppFailure () -> Maybe (Either XmppFailure ())
forall a. a -> Maybe a
Just Either XmppFailure ()
er
TChan IQRequestTicket -> IQRequestTicket -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan IQRequestTicket
ch (IQRequestTicket -> STM ()) -> IQRequestTicket -> STM ()
forall a b. (a -> b) -> a -> b
$ (Either StanzaError (Maybe Element)
-> [ExtendedAttribute] -> IO (Maybe (Either XmppFailure ())))
-> IQRequest -> [Annotation] -> IQRequestTicket
IQRequestTicket Either StanzaError (Maybe Element)
-> [ExtendedAttribute] -> IO (Maybe (Either XmppFailure ()))
answerT IQRequest
iq [Annotation]
as
Maybe Stanza -> STM (Maybe Stanza)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Stanza
forall a. Maybe a
Nothing
IO () -> (Stanza -> IO ()) -> Maybe Stanza -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (IO (Either XmppFailure ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either XmppFailure ()) -> IO ())
-> (Stanza -> IO (Either XmppFailure ())) -> Stanza -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmppElement -> IO (Either XmppFailure ())
out (XmppElement -> IO (Either XmppFailure ()))
-> (Stanza -> XmppElement) -> Stanza -> IO (Either XmppFailure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stanza -> XmppElement
XmppStanza) Maybe Stanza
res
serviceUnavailable :: IQRequest -> Stanza
serviceUnavailable (IQRequest Text
iqid Maybe Jid
from Maybe Jid
_to Maybe LangTag
lang IQRequestType
_tp Element
bd [ExtendedAttribute]
_attrs) =
IQError -> Stanza
IQErrorS (IQError -> Stanza) -> IQError -> Stanza
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Jid
-> Maybe Jid
-> Maybe LangTag
-> StanzaError
-> Maybe Element
-> [ExtendedAttribute]
-> IQError
IQError Text
iqid Maybe Jid
forall a. Maybe a
Nothing Maybe Jid
from Maybe LangTag
lang StanzaError
err (Element -> Maybe Element
forall a. a -> Maybe a
Just Element
bd) []
err :: StanzaError
err = StanzaErrorType
-> StanzaErrorCondition
-> Maybe (Maybe LangTag, NonemptyText)
-> Maybe Element
-> StanzaError
StanzaError StanzaErrorType
Cancel StanzaErrorCondition
ServiceUnavailable Maybe (Maybe LangTag, NonemptyText)
forall a. Maybe a
Nothing Maybe Element
forall a. Maybe a
Nothing
handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> IO ()
handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> IO ()
handleIQResponse TVar IQHandlers
handlers Either IQError IQResult
iq = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
(Map (IQRequestType, Text) (TChan IQRequestTicket)
byNS, Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
byID) <- TVar IQHandlers -> STM IQHandlers
forall a. TVar a -> STM a
readTVar TVar IQHandlers
handlers
case (Text
-> (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
-> Maybe
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
-> Text
-> Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
-> (Maybe
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\Text
_ (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
_ -> Maybe
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
forall a. Maybe a
Nothing) (Either IQError IQResult -> Text
iqID Either IQError IQResult
iq) Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
byID of
(Maybe
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
Nothing, Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
_) -> () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Just (Either (Maybe Jid) Jid
expectedJid, TMVar (Maybe (Annotated IQResponse))
tmvar), Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
byID') -> do
let expected :: Bool
expected = case Either (Maybe Jid) Jid
expectedJid of
Left Maybe Jid
Nothing -> Bool
True
Left (Just Jid
j) -> case Either IQError IQResult -> Maybe Jid
iqFrom Either IQError IQResult
iq of
Maybe Jid
Nothing -> Bool
True
Just Jid
jf -> Jid
jf Jid -> Jid -> Bool
<~ Jid
j
Right Jid
j -> Either IQError IQResult -> Maybe Jid
iqFrom Either IQError IQResult
iq Maybe Jid -> Maybe Jid -> Bool
forall a. Eq a => a -> a -> Bool
== Jid -> Maybe Jid
forall a. a -> Maybe a
Just Jid
j
case Bool
expected of
Bool
True -> do
let answer :: Maybe (Annotated IQResponse)
answer = Annotated IQResponse -> Maybe (Annotated IQResponse)
forall a. a -> Maybe a
Just ((IQError -> IQResponse)
-> (IQResult -> IQResponse)
-> Either IQError IQResult
-> IQResponse
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either IQError -> IQResponse
IQResponseError
IQResult -> IQResponse
IQResponseResult Either IQError IQResult
iq, [Annotation]
as)
Bool
_ <- TMVar (Maybe (Annotated IQResponse))
-> Maybe (Annotated IQResponse) -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar (Maybe (Annotated IQResponse))
tmvar Maybe (Annotated IQResponse)
answer
TVar IQHandlers -> IQHandlers -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar IQHandlers
handlers (Map (IQRequestType, Text) (TChan IQRequestTicket)
byNS, Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
byID')
Bool
False -> () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
iqID :: Either IQError IQResult -> Text
iqID (Left IQError
err') = IQError -> Text
iqErrorID IQError
err'
iqID (Right IQResult
iq') = IQResult -> Text
iqResultID IQResult
iq'
iqFrom :: Either IQError IQResult -> Maybe Jid
iqFrom (Left IQError
err') = IQError -> Maybe Jid
iqErrorFrom IQError
err'
iqFrom (Right IQResult
iq') = IQResult -> Maybe Jid
iqResultFrom IQResult
iq'
newSession :: Stream
-> SessionConfiguration
-> HostName
-> Maybe (ConnectionState -> [SaslHandler] , Maybe Text)
-> IO (Either XmppFailure Session)
newSession :: Stream
-> SessionConfiguration
-> String
-> Maybe (ConnectionState -> [SaslHandler], Maybe Text)
-> IO (Either XmppFailure Session)
newSession Stream
stream SessionConfiguration
config String
realm Maybe (ConnectionState -> [SaslHandler], Maybe Text)
mbSasl = ExceptT XmppFailure IO Session -> IO (Either XmppFailure Session)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XmppFailure IO Session -> IO (Either XmppFailure Session))
-> ExceptT XmppFailure IO Session
-> IO (Either XmppFailure Session)
forall a b. (a -> b) -> a -> b
$ do
ByteString -> IO (Either XmppFailure ())
write' <- IO (ByteString -> IO (Either XmppFailure ()))
-> ExceptT
XmppFailure IO (ByteString -> IO (Either XmppFailure ()))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ByteString -> IO (Either XmppFailure ()))
-> ExceptT
XmppFailure IO (ByteString -> IO (Either XmppFailure ())))
-> IO (ByteString -> IO (Either XmppFailure ()))
-> ExceptT
XmppFailure IO (ByteString -> IO (Either XmppFailure ()))
forall a b. (a -> b) -> a -> b
$ StateT StreamState IO (ByteString -> IO (Either XmppFailure ()))
-> Stream -> IO (ByteString -> IO (Either XmppFailure ()))
forall a. StateT StreamState IO a -> Stream -> IO a
withStream' ((StreamState -> ByteString -> IO (Either XmppFailure ()))
-> StateT StreamState IO (ByteString -> IO (Either XmppFailure ()))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((StreamState -> ByteString -> IO (Either XmppFailure ()))
-> StateT
StreamState IO (ByteString -> IO (Either XmppFailure ())))
-> (StreamState -> ByteString -> IO (Either XmppFailure ()))
-> StateT StreamState IO (ByteString -> IO (Either XmppFailure ()))
forall a b. (a -> b) -> a -> b
$ StreamHandle -> ByteString -> IO (Either XmppFailure ())
streamSend (StreamHandle -> ByteString -> IO (Either XmppFailure ()))
-> (StreamState -> StreamHandle)
-> StreamState
-> ByteString
-> IO (Either XmppFailure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamHandle
streamHandle) Stream
stream
TMVar (ByteString -> IO (Either XmppFailure ()))
writeSem <- IO (TMVar (ByteString -> IO (Either XmppFailure ())))
-> ExceptT
XmppFailure IO (TMVar (ByteString -> IO (Either XmppFailure ())))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TMVar (ByteString -> IO (Either XmppFailure ())))
-> ExceptT
XmppFailure IO (TMVar (ByteString -> IO (Either XmppFailure ()))))
-> IO (TMVar (ByteString -> IO (Either XmppFailure ())))
-> ExceptT
XmppFailure IO (TMVar (ByteString -> IO (Either XmppFailure ())))
forall a b. (a -> b) -> a -> b
$ (ByteString -> IO (Either XmppFailure ()))
-> IO (TMVar (ByteString -> IO (Either XmppFailure ())))
forall a. a -> IO (TMVar a)
newTMVarIO ByteString -> IO (Either XmppFailure ())
write'
TChan (Annotated Stanza)
stanzaChan <- IO (TChan (Annotated Stanza))
-> ExceptT XmppFailure IO (TChan (Annotated Stanza))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO (TChan (Annotated Stanza))
forall a. IO (TChan a)
newTChanIO
TVar IQHandlers
iqHands <- IO (TVar IQHandlers) -> ExceptT XmppFailure IO (TVar IQHandlers)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (TVar IQHandlers) -> ExceptT XmppFailure IO (TVar IQHandlers))
-> IO (TVar IQHandlers) -> ExceptT XmppFailure IO (TVar IQHandlers)
forall a b. (a -> b) -> a -> b
$ IQHandlers -> IO (TVar IQHandlers)
forall a. a -> IO (TVar a)
newTVarIO (Map (IQRequestType, Text) (TChan IQRequestTicket)
forall k a. Map k a
Map.empty, Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
forall k a. Map k a
Map.empty)
TMVar EventHandlers
eh <- IO (TMVar EventHandlers)
-> ExceptT XmppFailure IO (TMVar EventHandlers)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (TMVar EventHandlers)
-> ExceptT XmppFailure IO (TMVar EventHandlers))
-> IO (TMVar EventHandlers)
-> ExceptT XmppFailure IO (TMVar EventHandlers)
forall a b. (a -> b) -> a -> b
$ IO (TMVar EventHandlers)
forall a. IO (TMVar a)
newEmptyTMVarIO
Roster
ros <- case SessionConfiguration -> Bool
enableRoster SessionConfiguration
config of
Bool
False -> Roster -> ExceptT XmppFailure IO Roster
forall (m :: * -> *) a. Monad m => a -> m a
return (Roster -> ExceptT XmppFailure IO Roster)
-> Roster -> ExceptT XmppFailure IO Roster
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Map Jid Item -> Roster
Roster Maybe Text
forall a. Maybe a
Nothing Map Jid Item
forall k a. Map k a
Map.empty
Bool
True -> do
Maybe Roster
mbRos <- IO (Maybe Roster) -> ExceptT XmppFailure IO (Maybe Roster)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Roster) -> ExceptT XmppFailure IO (Maybe Roster))
-> IO (Maybe Roster) -> ExceptT XmppFailure IO (Maybe Roster)
forall a b. (a -> b) -> a -> b
$ SessionConfiguration -> IO (Maybe Roster)
initialRoster SessionConfiguration
config
Roster -> ExceptT XmppFailure IO Roster
forall (m :: * -> *) a. Monad m => a -> m a
return (Roster -> ExceptT XmppFailure IO Roster)
-> Roster -> ExceptT XmppFailure IO Roster
forall a b. (a -> b) -> a -> b
$ case Maybe Roster
mbRos of
Maybe Roster
Nothing -> Maybe Text -> Map Jid Item -> Roster
Roster Maybe Text
forall a. Maybe a
Nothing Map Jid Item
forall k a. Map k a
Map.empty
Just Roster
r -> Roster
r
TVar Roster
rosRef <- IO (TVar Roster) -> ExceptT XmppFailure IO (TVar Roster)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar Roster) -> ExceptT XmppFailure IO (TVar Roster))
-> IO (TVar Roster) -> ExceptT XmppFailure IO (TVar Roster)
forall a b. (a -> b) -> a -> b
$ Roster -> IO (TVar Roster)
forall a. a -> IO (TVar a)
newTVarIO Roster
ros
TVar Peers
peers <- IO (TVar Peers) -> ExceptT XmppFailure IO (TVar Peers)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar Peers) -> ExceptT XmppFailure IO (TVar Peers))
-> (Peers -> IO (TVar Peers))
-> Peers
-> ExceptT XmppFailure IO (TVar Peers)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Peers -> IO (TVar Peers)
forall a. a -> IO (TVar a)
newTVarIO (Peers -> ExceptT XmppFailure IO (TVar Peers))
-> Peers -> ExceptT XmppFailure IO (TVar Peers)
forall a b. (a -> b) -> a -> b
$ Map Jid (Map Jid (Maybe IMPresence)) -> Peers
Peers Map Jid (Map Jid (Maybe IMPresence))
forall k a. Map k a
Map.empty
TVar Int
rew <- IO (TVar Int) -> ExceptT XmppFailure IO (TVar Int)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (TVar Int) -> ExceptT XmppFailure IO (TVar Int))
-> IO (TVar Int) -> ExceptT XmppFailure IO (TVar Int)
forall a b. (a -> b) -> a -> b
$ Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
60
let out :: XmppElement -> IO (Either XmppFailure ())
out = TMVar (ByteString -> IO (Either XmppFailure ()))
-> XmppElement -> IO (Either XmppFailure ())
writeXmppElem TMVar (ByteString -> IO (Either XmppFailure ()))
writeSem
Maybe Jid
boundJid <- IO (Maybe Jid) -> ExceptT XmppFailure IO (Maybe Jid)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Jid) -> ExceptT XmppFailure IO (Maybe Jid))
-> IO (Maybe Jid) -> ExceptT XmppFailure IO (Maybe Jid)
forall a b. (a -> b) -> a -> b
$ StateT StreamState IO (Maybe Jid) -> Stream -> IO (Maybe Jid)
forall a. StateT StreamState IO a -> Stream -> IO a
withStream' ((StreamState -> Maybe Jid) -> StateT StreamState IO (Maybe Jid)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StreamState -> Maybe Jid
streamJid) Stream
stream
let rosterH :: [XmppElement -> [Annotation] -> IO [Annotated XmppElement]]
rosterH = if (SessionConfiguration -> Bool
enableRoster SessionConfiguration
config)
then [Maybe Jid -> TVar Roster -> RosterPushCallback -> StanzaHandler
handleRoster Maybe Jid
boundJid TVar Roster
rosRef
(RosterPushCallback
-> Maybe RosterPushCallback -> RosterPushCallback
forall a. a -> Maybe a -> a
fromMaybe (\Roster
_ RosterUpdate
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Maybe RosterPushCallback -> RosterPushCallback)
-> Maybe RosterPushCallback -> RosterPushCallback
forall a b. (a -> b) -> a -> b
$ SessionConfiguration -> Maybe RosterPushCallback
onRosterPush SessionConfiguration
config)
(XmppElement -> IO (Either XmppFailure ())
out)]
else []
let presenceH :: [XmppElement -> [Annotation] -> IO [Annotated XmppElement]]
presenceH = if (SessionConfiguration -> Bool
enablePresenceTracking SessionConfiguration
config)
then [Maybe (Jid -> PeerStatus -> PeerStatus -> IO ())
-> TVar Peers -> StanzaHandler
handlePresence (SessionConfiguration
-> Maybe (Jid -> PeerStatus -> PeerStatus -> IO ())
onPresenceChange SessionConfiguration
config) TVar Peers
peers XmppElement -> IO (Either XmppFailure ())
out]
else []
(XmppElement -> IO (Either XmppFailure ())
sXmppElement, [Plugin']
ps) <- (XmppElement -> IO (Either XmppFailure ()))
-> [(XmppElement -> IO (Either XmppFailure ()))
-> ExceptT XmppFailure IO Plugin']
-> ExceptT
XmppFailure
IO
(XmppElement -> IO (Either XmppFailure ()), [Plugin'])
forall (m :: * -> *).
Monad m =>
(XmppElement -> IO (Either XmppFailure ()))
-> [(XmppElement -> IO (Either XmppFailure ())) -> m Plugin']
-> m (XmppElement -> IO (Either XmppFailure ()), [Plugin'])
initPlugins XmppElement -> IO (Either XmppFailure ())
out ([(XmppElement -> IO (Either XmppFailure ()))
-> ExceptT XmppFailure IO Plugin']
-> ExceptT
XmppFailure
IO
(XmppElement -> IO (Either XmppFailure ()), [Plugin']))
-> [(XmppElement -> IO (Either XmppFailure ()))
-> ExceptT XmppFailure IO Plugin']
-> ExceptT
XmppFailure
IO
(XmppElement -> IO (Either XmppFailure ()), [Plugin'])
forall a b. (a -> b) -> a -> b
$ SessionConfiguration
-> [(XmppElement -> IO (Either XmppFailure ()))
-> ExceptT XmppFailure IO Plugin']
plugins SessionConfiguration
config
let stanzaHandler :: XmppElement -> IO ()
stanzaHandler = [XmppElement -> [Annotation] -> IO [Annotated XmppElement]]
-> XmppElement -> IO ()
runHandlers ([XmppElement -> [Annotation] -> IO [Annotated XmppElement]]
-> XmppElement -> IO ())
-> [XmppElement -> [Annotation] -> IO [Annotated XmppElement]]
-> XmppElement
-> IO ()
forall a b. (a -> b) -> a -> b
$ [[XmppElement -> [Annotation] -> IO [Annotated XmppElement]]]
-> [XmppElement -> [Annotation] -> IO [Annotated XmppElement]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
List.concat
[ Plugin'
-> XmppElement -> [Annotation] -> IO [Annotated XmppElement]
inHandler (Plugin'
-> XmppElement -> [Annotation] -> IO [Annotated XmppElement])
-> [Plugin']
-> [XmppElement -> [Annotation] -> IO [Annotated XmppElement]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Plugin']
ps
, [ TChan (Annotated Stanza) -> StanzaHandler
toChan TChan (Annotated Stanza)
stanzaChan XmppElement -> IO (Either XmppFailure ())
sXmppElement]
, [XmppElement -> [Annotation] -> IO [Annotated XmppElement]]
presenceH
, [XmppElement -> [Annotation] -> IO [Annotated XmppElement]]
rosterH
, [ TVar IQHandlers -> StanzaHandler
handleIQ TVar IQHandlers
iqHands XmppElement -> IO (Either XmppFailure ())
sXmppElement]
]
(IO ()
kill, TMVar Stream
sState, ThreadId
reader) <- IO (Either XmppFailure (IO (), TMVar Stream, ThreadId))
-> ExceptT XmppFailure IO (IO (), TMVar Stream, ThreadId)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either XmppFailure (IO (), TMVar Stream, ThreadId))
-> ExceptT XmppFailure IO (IO (), TMVar Stream, ThreadId))
-> IO (Either XmppFailure (IO (), TMVar Stream, ThreadId))
-> ExceptT XmppFailure IO (IO (), TMVar Stream, ThreadId)
forall a b. (a -> b) -> a -> b
$ TMVar (ByteString -> IO (Either XmppFailure ()))
-> (XmppElement -> IO ())
-> TMVar EventHandlers
-> Stream
-> Maybe Int
-> IO (Either XmppFailure (IO (), TMVar Stream, ThreadId))
startThreadsWith TMVar (ByteString -> IO (Either XmppFailure ()))
writeSem XmppElement -> IO ()
stanzaHandler
TMVar EventHandlers
eh Stream
stream
(SessionConfiguration -> Maybe Int
keepAlive SessionConfiguration
config)
IO Text
idGen <- IO (IO Text) -> ExceptT XmppFailure IO (IO Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IO Text) -> ExceptT XmppFailure IO (IO Text))
-> IO (IO Text) -> ExceptT XmppFailure IO (IO Text)
forall a b. (a -> b) -> a -> b
$ SessionConfiguration -> IO (IO Text)
sessionStanzaIDs SessionConfiguration
config
let sess :: Session
sess = Session :: TChan (Annotated Stanza)
-> TVar IQHandlers
-> TMVar (ByteString -> IO (Either XmppFailure ()))
-> ThreadId
-> IO Text
-> TMVar Stream
-> TMVar EventHandlers
-> IO ()
-> TVar Roster
-> TVar Peers
-> SessionConfiguration
-> (Stanza -> IO (Either XmppFailure ()))
-> String
-> Maybe (ConnectionState -> [SaslHandler], Maybe Text)
-> TVar Int
-> Session
Session { stanzaCh :: TChan (Annotated Stanza)
stanzaCh = TChan (Annotated Stanza)
stanzaChan
, iqHandlers :: TVar IQHandlers
iqHandlers = TVar IQHandlers
iqHands
, writeSemaphore :: TMVar (ByteString -> IO (Either XmppFailure ()))
writeSemaphore = TMVar (ByteString -> IO (Either XmppFailure ()))
writeSem
, readerThread :: ThreadId
readerThread = ThreadId
reader
, idGenerator :: IO Text
idGenerator = IO Text
idGen
, streamRef :: TMVar Stream
streamRef = TMVar Stream
sState
, eventHandlers :: TMVar EventHandlers
eventHandlers = TMVar EventHandlers
eh
, stopThreads :: IO ()
stopThreads = IO ()
kill
, conf :: SessionConfiguration
conf = SessionConfiguration
config
, rosterRef :: TVar Roster
rosterRef = TVar Roster
rosRef
, presenceRef :: TVar Peers
presenceRef = TVar Peers
peers
, sendStanza' :: Stanza -> IO (Either XmppFailure ())
sendStanza' = XmppElement -> IO (Either XmppFailure ())
sXmppElement (XmppElement -> IO (Either XmppFailure ()))
-> (Stanza -> XmppElement) -> Stanza -> IO (Either XmppFailure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stanza -> XmppElement
XmppStanza
, sRealm :: String
sRealm = String
realm
, sSaslCredentials :: Maybe (ConnectionState -> [SaslHandler], Maybe Text)
sSaslCredentials = Maybe (ConnectionState -> [SaslHandler], Maybe Text)
mbSasl
, reconnectWait :: TVar Int
reconnectWait = TVar Int
rew
}
IO () -> ExceptT XmppFailure IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XmppFailure IO ())
-> (STM () -> IO ()) -> STM () -> ExceptT XmppFailure IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> ExceptT XmppFailure IO ())
-> STM () -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ TMVar EventHandlers -> EventHandlers -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar EventHandlers
eh (EventHandlers -> STM ()) -> EventHandlers -> STM ()
forall a b. (a -> b) -> a -> b
$
EventHandlers :: (XmppFailure -> IO ()) -> EventHandlers
EventHandlers { connectionClosedHandler :: XmppFailure -> IO ()
connectionClosedHandler = SessionConfiguration -> Session -> XmppFailure -> IO ()
onConnectionClosed SessionConfiguration
config Session
sess }
IO () -> ExceptT XmppFailure IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XmppFailure IO ())
-> ((Plugin' -> IO ()) -> IO ())
-> (Plugin' -> IO ())
-> ExceptT XmppFailure IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Plugin'] -> (Plugin' -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Plugin']
ps ((Plugin' -> IO ()) -> ExceptT XmppFailure IO ())
-> (Plugin' -> IO ()) -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ \Plugin'
p -> Plugin' -> Session -> IO ()
onSessionUp Plugin'
p Session
sess
Session -> ExceptT XmppFailure IO Session
forall (m :: * -> *) a. Monad m => a -> m a
return Session
sess
where
initPlugins :: (XmppElement -> IO (Either XmppFailure ()))
-> [(XmppElement -> IO (Either XmppFailure ())) -> m Plugin']
-> m (XmppElement -> IO (Either XmppFailure ()), [Plugin'])
initPlugins XmppElement -> IO (Either XmppFailure ())
out' = (XmppElement -> IO (Either XmppFailure ()))
-> [Plugin']
-> [(XmppElement -> IO (Either XmppFailure ())) -> m Plugin']
-> m (XmppElement -> IO (Either XmppFailure ()), [Plugin'])
forall (m :: * -> *).
Monad m =>
(XmppElement -> IO (Either XmppFailure ()))
-> [Plugin']
-> [(XmppElement -> IO (Either XmppFailure ())) -> m Plugin']
-> m (XmppElement -> IO (Either XmppFailure ()), [Plugin'])
go XmppElement -> IO (Either XmppFailure ())
out' []
where
go :: (XmppElement -> IO (Either XmppFailure ()))
-> [Plugin']
-> [(XmppElement -> IO (Either XmppFailure ())) -> m Plugin']
-> m (XmppElement -> IO (Either XmppFailure ()), [Plugin'])
go XmppElement -> IO (Either XmppFailure ())
out [Plugin']
ps' [] = (XmppElement -> IO (Either XmppFailure ()), [Plugin'])
-> m (XmppElement -> IO (Either XmppFailure ()), [Plugin'])
forall (m :: * -> *) a. Monad m => a -> m a
return (XmppElement -> IO (Either XmppFailure ())
out, [Plugin']
ps')
go XmppElement -> IO (Either XmppFailure ())
out [Plugin']
ps' ((XmppElement -> IO (Either XmppFailure ())) -> m Plugin'
p:[(XmppElement -> IO (Either XmppFailure ())) -> m Plugin']
ps) = do
Plugin'
p' <- (XmppElement -> IO (Either XmppFailure ())) -> m Plugin'
p XmppElement -> IO (Either XmppFailure ())
out
(XmppElement -> IO (Either XmppFailure ()))
-> [Plugin']
-> [(XmppElement -> IO (Either XmppFailure ())) -> m Plugin']
-> m (XmppElement -> IO (Either XmppFailure ()), [Plugin'])
go (Plugin' -> XmppElement -> IO (Either XmppFailure ())
outHandler Plugin'
p') (Plugin'
p' Plugin' -> [Plugin'] -> [Plugin']
forall a. a -> [a] -> [a]
: [Plugin']
ps') [(XmppElement -> IO (Either XmppFailure ())) -> m Plugin']
ps
connectStream :: HostName
-> SessionConfiguration
-> AuthData
-> IO (Either XmppFailure Stream)
connectStream :: String
-> SessionConfiguration
-> Maybe (ConnectionState -> [SaslHandler], Maybe Text)
-> IO (Either XmppFailure Stream)
connectStream String
realm SessionConfiguration
config Maybe (ConnectionState -> [SaslHandler], Maybe Text)
mbSasl = do
IO (Either XmppFailure Stream)
-> (Either XmppFailure Stream -> IO ())
-> (Either XmppFailure Stream -> IO (Either XmppFailure Stream))
-> IO (Either XmppFailure Stream)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Ex.bracketOnError (String -> StreamConfiguration -> IO (Either XmppFailure Stream)
openStream String
realm (SessionConfiguration -> StreamConfiguration
sessionStreamConfiguration SessionConfiguration
config))
(\Either XmppFailure Stream
s -> case Either XmppFailure Stream
s of
Left XmppFailure
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Right Stream
stream -> Stream -> IO ()
closeStreams Stream
stream)
(\Either XmppFailure Stream
stream' -> case Either XmppFailure Stream
stream' of
Left XmppFailure
e -> Either XmppFailure Stream -> IO (Either XmppFailure Stream)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure Stream -> IO (Either XmppFailure Stream))
-> Either XmppFailure Stream -> IO (Either XmppFailure Stream)
forall a b. (a -> b) -> a -> b
$ XmppFailure -> Either XmppFailure Stream
forall a b. a -> Either a b
Left XmppFailure
e
Right Stream
stream -> do
Either XmppFailure Stream
res <- ExceptT XmppFailure IO Stream -> IO (Either XmppFailure Stream)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XmppFailure IO Stream -> IO (Either XmppFailure Stream))
-> ExceptT XmppFailure IO Stream -> IO (Either XmppFailure Stream)
forall a b. (a -> b) -> a -> b
$ do
IO (Either XmppFailure ()) -> ExceptT XmppFailure IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either XmppFailure ()) -> ExceptT XmppFailure IO ())
-> IO (Either XmppFailure ()) -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ Stream -> IO (Either XmppFailure ())
tls Stream
stream
ConnectionState
cs <- IO ConnectionState -> ExceptT XmppFailure IO ConnectionState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ConnectionState -> ExceptT XmppFailure IO ConnectionState)
-> IO ConnectionState -> ExceptT XmppFailure IO ConnectionState
forall a b. (a -> b) -> a -> b
$ StateT StreamState IO ConnectionState
-> Stream -> IO ConnectionState
forall a. StateT StreamState IO a -> Stream -> IO a
withStream ((StreamState -> ConnectionState)
-> StateT StreamState IO ConnectionState
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StreamState -> ConnectionState
streamConnectionState)
Stream
stream
Maybe AuthFailure
mbAuthError <- case Maybe (ConnectionState -> [SaslHandler], Maybe Text)
mbSasl of
Maybe (ConnectionState -> [SaslHandler], Maybe Text)
Nothing -> Maybe AuthFailure -> ExceptT XmppFailure IO (Maybe AuthFailure)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthFailure
forall a. Maybe a
Nothing
Just (ConnectionState -> [SaslHandler]
handlers, Maybe Text
resource) -> IO (Either XmppFailure (Maybe AuthFailure))
-> ExceptT XmppFailure IO (Maybe AuthFailure)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either XmppFailure (Maybe AuthFailure))
-> ExceptT XmppFailure IO (Maybe AuthFailure))
-> IO (Either XmppFailure (Maybe AuthFailure))
-> ExceptT XmppFailure IO (Maybe AuthFailure)
forall a b. (a -> b) -> a -> b
$ [SaslHandler]
-> Maybe Text
-> Stream
-> IO (Either XmppFailure (Maybe AuthFailure))
auth (ConnectionState -> [SaslHandler]
handlers ConnectionState
cs)
Maybe Text
resource Stream
stream
case Maybe AuthFailure
mbAuthError of
Maybe AuthFailure
Nothing -> () -> ExceptT XmppFailure IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just AuthFailure
e -> XmppFailure -> ExceptT XmppFailure IO ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (XmppFailure -> ExceptT XmppFailure IO ())
-> XmppFailure -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ AuthFailure -> XmppFailure
XmppAuthFailure AuthFailure
e
Stream -> ExceptT XmppFailure IO Stream
forall (m :: * -> *) a. Monad m => a -> m a
return Stream
stream
case Either XmppFailure Stream
res of
Left XmppFailure
e -> do
String -> String -> IO ()
debugM String
"Pontarius.Xmpp" String
"Closing stream after error"
Stream -> IO ()
closeStreams Stream
stream
Either XmppFailure Stream -> IO (Either XmppFailure Stream)
forall (m :: * -> *) a. Monad m => a -> m a
return (XmppFailure -> Either XmppFailure Stream
forall a b. a -> Either a b
Left XmppFailure
e)
Right Stream
r -> Either XmppFailure Stream -> IO (Either XmppFailure Stream)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure Stream -> IO (Either XmppFailure Stream))
-> Either XmppFailure Stream -> IO (Either XmppFailure Stream)
forall a b. (a -> b) -> a -> b
$ Stream -> Either XmppFailure Stream
forall a b. b -> Either a b
Right Stream
r
)
session :: HostName
-> AuthData
-> SessionConfiguration
-> IO (Either XmppFailure Session)
session :: String
-> Maybe (ConnectionState -> [SaslHandler], Maybe Text)
-> SessionConfiguration
-> IO (Either XmppFailure Session)
session String
realm Maybe (ConnectionState -> [SaslHandler], Maybe Text)
mbSasl SessionConfiguration
config = ExceptT XmppFailure IO Session -> IO (Either XmppFailure Session)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XmppFailure IO Session -> IO (Either XmppFailure Session))
-> ExceptT XmppFailure IO Session
-> IO (Either XmppFailure Session)
forall a b. (a -> b) -> a -> b
$ do
Stream
stream <- IO (Either XmppFailure Stream) -> ExceptT XmppFailure IO Stream
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either XmppFailure Stream) -> ExceptT XmppFailure IO Stream)
-> IO (Either XmppFailure Stream) -> ExceptT XmppFailure IO Stream
forall a b. (a -> b) -> a -> b
$ String
-> SessionConfiguration
-> Maybe (ConnectionState -> [SaslHandler], Maybe Text)
-> IO (Either XmppFailure Stream)
connectStream String
realm SessionConfiguration
config Maybe (ConnectionState -> [SaslHandler], Maybe Text)
mbSasl
Session
ses <- IO (Either XmppFailure Session) -> ExceptT XmppFailure IO Session
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either XmppFailure Session) -> ExceptT XmppFailure IO Session)
-> IO (Either XmppFailure Session)
-> ExceptT XmppFailure IO Session
forall a b. (a -> b) -> a -> b
$ Stream
-> SessionConfiguration
-> String
-> Maybe (ConnectionState -> [SaslHandler], Maybe Text)
-> IO (Either XmppFailure Session)
newSession Stream
stream SessionConfiguration
config String
realm Maybe (ConnectionState -> [SaslHandler], Maybe Text)
mbSasl
IO () -> ExceptT XmppFailure IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XmppFailure IO ())
-> IO () -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SessionConfiguration -> Bool
enableRoster SessionConfiguration
config) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Session -> IO ()
initRoster Session
ses
Session -> ExceptT XmppFailure IO Session
forall (m :: * -> *) a. Monad m => a -> m a
return Session
ses
simpleAuth :: Username -> Password -> AuthData
simpleAuth :: Text
-> Text -> Maybe (ConnectionState -> [SaslHandler], Maybe Text)
simpleAuth Text
uname Text
pwd = (ConnectionState -> [SaslHandler], Maybe Text)
-> Maybe (ConnectionState -> [SaslHandler], Maybe Text)
forall a. a -> Maybe a
Just (\ConnectionState
cstate ->
[ Text -> Maybe Text -> Text -> SaslHandler
scramSha1 Text
uname Maybe Text
forall a. Maybe a
Nothing Text
pwd
, Text -> Maybe Text -> Text -> SaslHandler
digestMd5 Text
uname Maybe Text
forall a. Maybe a
Nothing Text
pwd
] [SaslHandler] -> [SaslHandler] -> [SaslHandler]
forall a. [a] -> [a] -> [a]
++
if (ConnectionState
cstate ConnectionState -> ConnectionState -> Bool
forall a. Eq a => a -> a -> Bool
== ConnectionState
Secured)
then [Text -> Maybe Text -> Text -> SaslHandler
plain Text
uname Maybe Text
forall a. Maybe a
Nothing Text
pwd]
else []
, Maybe Text
forall a. Maybe a
Nothing)
reconnectNow :: Session
-> IO (Maybe XmppFailure)
reconnectNow :: Session -> IO (Maybe XmppFailure)
reconnectNow sess :: Session
sess@Session{conf :: Session -> SessionConfiguration
conf = SessionConfiguration
config, reconnectWait :: Session -> TVar Int
reconnectWait = TVar Int
rw} = do
String -> String -> IO ()
debugM String
"Pontarius.Xmpp" String
"reconnecting"
Either XmppFailure (Either XmppFailure ())
res <- ((Stream -> IO (Either XmppFailure (), Stream))
-> Session -> IO (Either XmppFailure (Either XmppFailure ())))
-> Session
-> (Stream -> IO (Either XmppFailure (), Stream))
-> IO (Either XmppFailure (Either XmppFailure ()))
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Stream -> IO (Either XmppFailure (), Stream))
-> Session -> IO (Either XmppFailure (Either XmppFailure ()))
forall b.
(Stream -> IO (b, Stream)) -> Session -> IO (Either XmppFailure b)
withConnection Session
sess ((Stream -> IO (Either XmppFailure (), Stream))
-> IO (Either XmppFailure (Either XmppFailure ())))
-> (Stream -> IO (Either XmppFailure (), Stream))
-> IO (Either XmppFailure (Either XmppFailure ()))
forall a b. (a -> b) -> a -> b
$ \Stream
oldStream -> do
String -> String -> IO ()
debugM String
"Pontarius.Xmpp" String
"reconnect: closing stream"
Stream -> IO ()
closeStreams Stream
oldStream
String -> String -> IO ()
debugM String
"Pontarius.Xmpp" String
"reconnect: opening stream"
Either XmppFailure Stream
s <- String
-> SessionConfiguration
-> Maybe (ConnectionState -> [SaslHandler], Maybe Text)
-> IO (Either XmppFailure Stream)
connectStream (Session -> String
sRealm Session
sess) SessionConfiguration
config (Session -> Maybe (ConnectionState -> [SaslHandler], Maybe Text)
sSaslCredentials Session
sess)
case Either XmppFailure Stream
s of
Left XmppFailure
e -> do
String -> String -> IO ()
errorM String
"Pontarius.Xmpp" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"reconnect failed" String -> String -> String
forall a. [a] -> [a] -> [a]
++ XmppFailure -> String
forall a. Show a => a -> String
show XmppFailure
e
(Either XmppFailure (), Stream)
-> IO (Either XmppFailure (), Stream)
forall (m :: * -> *) a. Monad m => a -> m a
return (XmppFailure -> Either XmppFailure ()
forall a b. a -> Either a b
Left XmppFailure
e , Stream
oldStream )
Right Stream
r -> (Either XmppFailure (), Stream)
-> IO (Either XmppFailure (), Stream)
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either XmppFailure ()
forall a b. b -> Either a b
Right () , Stream
r )
case Either XmppFailure (Either XmppFailure ())
res of
Left XmppFailure
e -> Maybe XmppFailure -> IO (Maybe XmppFailure)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe XmppFailure -> IO (Maybe XmppFailure))
-> Maybe XmppFailure -> IO (Maybe XmppFailure)
forall a b. (a -> b) -> a -> b
$ XmppFailure -> Maybe XmppFailure
forall a. a -> Maybe a
Just XmppFailure
e
Right (Left XmppFailure
e) -> Maybe XmppFailure -> IO (Maybe XmppFailure)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe XmppFailure -> IO (Maybe XmppFailure))
-> Maybe XmppFailure -> IO (Maybe XmppFailure)
forall a b. (a -> b) -> a -> b
$ XmppFailure -> Maybe XmppFailure
forall a. a -> Maybe a
Just XmppFailure
e
Right (Right ()) -> do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
rw Int
60
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SessionConfiguration -> Bool
enableRoster SessionConfiguration
config) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Session -> IO ()
initRoster Session
sess
Maybe XmppFailure -> IO (Maybe XmppFailure)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe XmppFailure
forall a. Maybe a
Nothing
reconnect :: Integer
-> Session
-> IO (Bool, [XmppFailure])
reconnect :: Integer -> Session -> IO (Bool, [XmppFailure])
reconnect Integer
maxTries Session
sess = Integer -> IO (Bool, [XmppFailure])
forall t. (Ord t, Num t) => t -> IO (Bool, [XmppFailure])
go Integer
maxTries
where
go :: t -> IO (Bool, [XmppFailure])
go t
t = do
Maybe XmppFailure
res <- Session -> IO (Maybe XmppFailure)
doRetry Session
sess
case Maybe XmppFailure
res of
Maybe XmppFailure
Nothing -> (Bool, [XmppFailure]) -> IO (Bool, [XmppFailure])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, [])
Just XmppFailure
e -> if (t
t t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> t
1) then (([XmppFailure] -> [XmppFailure])
-> (Bool, [XmppFailure]) -> (Bool, [XmppFailure])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (XmppFailure
eXmppFailure -> [XmppFailure] -> [XmppFailure]
forall a. a -> [a] -> [a]
:)) ((Bool, [XmppFailure]) -> (Bool, [XmppFailure]))
-> IO (Bool, [XmppFailure]) -> IO (Bool, [XmppFailure])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> IO (Bool, [XmppFailure])
go (t
t t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
else (Bool, [XmppFailure]) -> IO (Bool, [XmppFailure])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, [XmppFailure]) -> IO (Bool, [XmppFailure]))
-> (Bool, [XmppFailure]) -> IO (Bool, [XmppFailure])
forall a b. (a -> b) -> a -> b
$ (Bool
False, [XmppFailure
e])
reconnect' :: Session
-> IO Integer
reconnect' :: Session -> IO Integer
reconnect' Session
sess = Integer -> IO Integer
forall t. Num t => t -> IO t
go Integer
0
where
go :: t -> IO t
go t
i = do
Maybe XmppFailure
res <- Session -> IO (Maybe XmppFailure)
doRetry Session
sess
case Maybe XmppFailure
res of
Maybe XmppFailure
Nothing -> t -> IO t
forall (m :: * -> *) a. Monad m => a -> m a
return t
i
Just XmppFailure
_e -> t -> IO t
go (t
it -> t -> t
forall a. Num a => a -> a -> a
+t
1)
doRetry :: Session -> IO (Maybe XmppFailure)
doRetry :: Session -> IO (Maybe XmppFailure)
doRetry sess :: Session
sess@Session{reconnectWait :: Session -> TVar Int
reconnectWait = TVar Int
rw} = do
Int
wait <- STM Int -> IO Int
forall a. STM a -> IO a
atomically (STM Int -> IO Int) -> STM Int -> IO Int
forall a b. (a -> b) -> a -> b
$ do
Int
wt <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
rw
TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
rw (Int -> STM ()) -> Int -> STM ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
300 (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
wt)
Int -> STM Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
wt
Int
t <- (Int, Int) -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
wait Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
30, Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
60 Int
wait)
String -> String -> IO ()
debugM String
"Pontarius.Xmpp" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"Waiting " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" seconds before reconnecting"
Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6 :: Int)
Session -> IO (Maybe XmppFailure)
reconnectNow Session
sess
newStanzaID :: Session -> IO Text
newStanzaID :: Session -> IO Text
newStanzaID = Session -> IO Text
idGenerator