{-# 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
[Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$
[Char]
"No stanza handlers set, discarding stanza" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show XmppElement
sta
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runHandlers [XmppElement -> [Annotation] -> IO [Annotated XmppElement]]
hs XmppElement
sta = 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]
_ = 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
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t (t, [a])
res 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 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 -> forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
writeTChan TChan (Annotated Stanza)
stanzaC (Stanza
s, [Annotation]
as)
XmppElement
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
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]
_ = 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
IQResultS IQResult
i -> TVar IQHandlers -> Either IQError IQResult -> IO ()
handleIQResponse TVar IQHandlers
iqHands (forall a b. b -> Either a b
Right IQResult
i) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
IQErrorS IQError
i -> TVar IQHandlers -> Either IQError IQResult -> IO ()
handleIQResponse TVar IQHandlers
iqHands (forall a b. a -> Either a b
Left IQError
i) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
Stanza
_ -> 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 <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
(Map (IQRequestType, Text) (TChan IQRequestTicket)
byNS, Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
_) <- forall a. TVar a -> STM a
readTVar TVar IQHandlers
handlers
let iqNS :: Text
iqNS = forall a. a -> Maybe a -> a
fromMaybe Text
"" (Name -> Maybe Text
nameNamespace forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Name
elementName
forall a b. (a -> b) -> a -> b
$ IQRequest -> Element
iqRequestPayload IQRequest
iq)
case 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ IQRequest -> Stanza
serviceUnavailable IQRequest
iq
Just TChan IQRequestTicket
ch -> do
TMVar Bool
sentRef <- 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 StanzaError
er -> IQError -> Stanza
IQErrorS forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Jid
-> Maybe Jid
-> Maybe LangTag
-> StanzaError
-> Maybe Element
-> [ExtendedAttribute]
-> IQError
IQError Text
iqid forall a. Maybe a
Nothing
Maybe Jid
from Maybe LangTag
lang StanzaError
er
(forall a. a -> Maybe a
Just Element
bd) [ExtendedAttribute]
attrs
Right Maybe Element
res -> IQResult -> Stanza
IQResultS forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Jid
-> Maybe Jid
-> Maybe LangTag
-> Maybe Element
-> [ExtendedAttribute]
-> IQResult
IQResult Text
iqid forall a. Maybe a
Nothing
Maybe Jid
from Maybe LangTag
lang Maybe Element
res
[ExtendedAttribute]
attrs
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Ex.bracketOnError (forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> STM a
takeTMVar TMVar Bool
sentRef)
(forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar Bool
sentRef)
forall a b. (a -> b) -> a -> b
$ \Bool
wasSent -> do
case Bool
wasSent of
Bool
True -> do
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar Bool
sentRef Bool
True
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Bool
False -> do
Either XmppFailure ()
didSend <- XmppElement -> IO (Either XmppFailure ())
out forall a b. (a -> b) -> a -> b
$ Stanza -> XmppElement
XmppStanza Stanza
response
case Either XmppFailure ()
didSend of
Right () -> do
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar Bool
sentRef Bool
True
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall a b. b -> Either a b
Right ())
er :: Either XmppFailure ()
er@Left{} -> do
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar Bool
sentRef Bool
False
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Either XmppFailure ()
er
forall a. TChan a -> a -> STM ()
writeTChan TChan IQRequestTicket
ch 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmppElement -> IO (Either XmppFailure ())
out 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 forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Jid
-> Maybe Jid
-> Maybe LangTag
-> StanzaError
-> Maybe Element
-> [ExtendedAttribute]
-> IQError
IQError Text
iqid forall a. Maybe a
Nothing Maybe Jid
from Maybe LangTag
lang StanzaError
err (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 forall a. Maybe a
Nothing 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 = forall a. STM a -> IO a
atomically 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) <- forall a. TVar a -> STM a
readTVar TVar IQHandlers
handlers
case 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)))
_ -> 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)))
_) -> 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 forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Jid
j
case Bool
expected of
Bool
True -> do
let answer :: Maybe (Annotated IQResponse)
answer = forall a. a -> Maybe a
Just (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
_ <- forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar (Maybe (Annotated IQResponse))
tmvar Maybe (Annotated IQResponse)
answer
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 -> 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
-> [Char]
-> Maybe (ConnectionState -> [SaslHandler], Maybe Text)
-> IO (Either XmppFailure Session)
newSession Stream
stream SessionConfiguration
config [Char]
realm Maybe (ConnectionState -> [SaslHandler], Maybe Text)
mbSasl = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
ByteString -> IO (Either XmppFailure ())
write' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. StateT StreamState IO a -> Stream -> IO a
withStream' (forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ StreamHandle -> ByteString -> IO (Either XmppFailure ())
streamSend forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamHandle
streamHandle) Stream
stream
TMVar (ByteString -> IO (Either XmppFailure ()))
writeSem <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (TMVar a)
newTMVarIO ByteString -> IO (Either XmppFailure ())
write'
TChan (Annotated Stanza)
stanzaChan <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. IO (TChan a)
newTChanIO
TVar IQHandlers
iqHands <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (TVar a)
newTVarIO (forall k a. Map k a
Map.empty, forall k a. Map k a
Map.empty)
TMVar EventHandlers
eh <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. IO (TMVar a)
newEmptyTMVarIO
Roster
ros <- case SessionConfiguration -> Bool
enableRoster SessionConfiguration
config of
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Text -> Map Jid Item -> Roster
Roster forall a. Maybe a
Nothing forall k a. Map k a
Map.empty
Bool
True -> do
Maybe Roster
mbRos <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ SessionConfiguration -> IO (Maybe Roster)
initialRoster SessionConfiguration
config
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe Roster
mbRos of
Maybe Roster
Nothing -> Maybe Text -> Map Jid Item -> Roster
Roster forall a. Maybe a
Nothing forall k a. Map k a
Map.empty
Just Roster
r -> Roster
r
TVar Roster
rosRef <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (TVar a)
newTVarIO Roster
ros
TVar Peers
peers <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> IO (TVar a)
newTVarIO forall a b. (a -> b) -> a -> b
$ Map Jid (Map Jid (Maybe IMPresence)) -> Peers
Peers forall k a. Map k a
Map.empty
TVar Int
rew <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. StateT StreamState IO a -> Stream -> IO a
withStream' (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
(forall a. a -> Maybe a -> a
fromMaybe (\Roster
_ RosterUpdate
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()) 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) <- 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 forall a b. (a -> b) -> a -> b
$ SessionConfiguration -> [Plugin]
plugins SessionConfiguration
config
let stanzaHandler :: XmppElement -> IO ()
stanzaHandler = [XmppElement -> [Annotation] -> IO [Annotated XmppElement]]
-> XmppElement -> IO ()
runHandlers forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
List.concat
[ Plugin'
-> XmppElement -> [Annotation] -> IO [Annotated XmppElement]
inHandler 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) <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ SessionConfiguration -> IO (IO Text)
sessionStanzaIDs SessionConfiguration
config
let sess :: Session
sess = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stanza -> XmppElement
XmppStanza
, sRealm :: [Char]
sRealm = [Char]
realm
, sSaslCredentials :: Maybe (ConnectionState -> [SaslHandler], Maybe Text)
sSaslCredentials = Maybe (ConnectionState -> [SaslHandler], Maybe Text)
mbSasl
, reconnectWait :: TVar Int
reconnectWait = TVar Int
rew
}
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar EventHandlers
eh forall a b. (a -> b) -> a -> b
$
EventHandlers { connectionClosedHandler :: XmppFailure -> IO ()
connectionClosedHandler = SessionConfiguration -> Session -> XmppFailure -> IO ()
onConnectionClosed SessionConfiguration
config Session
sess }
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Plugin']
ps forall a b. (a -> b) -> a -> b
$ \Plugin'
p -> Plugin' -> Session -> IO ()
onSessionUp Plugin'
p Session
sess
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' = 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' [] = 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' forall a. a -> [a] -> [a]
: [Plugin']
ps') [(XmppElement -> IO (Either XmppFailure ())) -> m Plugin']
ps
connectStream :: HostName
-> SessionConfiguration
-> AuthData
-> IO (Either XmppFailure Stream)
connectStream :: [Char]
-> SessionConfiguration
-> Maybe (ConnectionState -> [SaslHandler], Maybe Text)
-> IO (Either XmppFailure Stream)
connectStream [Char]
realm SessionConfiguration
config Maybe (ConnectionState -> [SaslHandler], Maybe Text)
mbSasl = do
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Ex.bracketOnError ([Char] -> StreamConfiguration -> IO (Either XmppFailure Stream)
openStream [Char]
realm (SessionConfiguration -> StreamConfiguration
sessionStreamConfiguration SessionConfiguration
config))
(\Either XmppFailure Stream
s -> case Either XmppFailure Stream
s of
Left XmppFailure
_ -> 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left XmppFailure
e
Right Stream
stream -> do
Either XmppFailure Stream
res <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ Stream -> IO (Either XmppFailure ())
tls Stream
stream
ConnectionState
cs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. StateT StreamState IO a -> Stream -> IO a
withStream (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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just (ConnectionState -> [SaslHandler]
handlers, Maybe Text
resource) -> forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just AuthFailure
e -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ AuthFailure -> XmppFailure
XmppAuthFailure AuthFailure
e
forall (m :: * -> *) a. Monad m => a -> m a
return Stream
stream
case Either XmppFailure Stream
res of
Left XmppFailure
e -> do
[Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Closing stream after error"
Stream -> IO ()
closeStreams Stream
stream
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left XmppFailure
e)
Right Stream
r -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Stream
r
)
session :: HostName
-> AuthData
-> SessionConfiguration
-> IO (Either XmppFailure Session)
session :: [Char]
-> Maybe (ConnectionState -> [SaslHandler], Maybe Text)
-> SessionConfiguration
-> IO (Either XmppFailure Session)
session [Char]
realm Maybe (ConnectionState -> [SaslHandler], Maybe Text)
mbSasl SessionConfiguration
config = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
Stream
stream <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ [Char]
-> SessionConfiguration
-> Maybe (ConnectionState -> [SaslHandler], Maybe Text)
-> IO (Either XmppFailure Stream)
connectStream [Char]
realm SessionConfiguration
config Maybe (ConnectionState -> [SaslHandler], Maybe Text)
mbSasl
Session
ses <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ Stream
-> SessionConfiguration
-> [Char]
-> Maybe (ConnectionState -> [SaslHandler], Maybe Text)
-> IO (Either XmppFailure Session)
newSession Stream
stream SessionConfiguration
config [Char]
realm Maybe (ConnectionState -> [SaslHandler], Maybe Text)
mbSasl
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SessionConfiguration -> Bool
enableRoster SessionConfiguration
config) forall a b. (a -> b) -> a -> b
$ Session -> IO ()
initRoster Session
ses
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 = forall a. a -> Maybe a
Just (\ConnectionState
cstate ->
[ Text -> Maybe Text -> Text -> SaslHandler
scramSha1 Text
uname forall a. Maybe a
Nothing Text
pwd
, Text -> Maybe Text -> Text -> SaslHandler
digestMd5 Text
uname forall a. Maybe a
Nothing Text
pwd
] forall a. [a] -> [a] -> [a]
++
if (ConnectionState
cstate forall a. Eq a => a -> a -> Bool
== ConnectionState
Secured)
then [Text -> Maybe Text -> Text -> SaslHandler
plain Text
uname forall a. Maybe a
Nothing Text
pwd]
else []
, 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
[Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"reconnecting"
Either XmppFailure (Either XmppFailure ())
res <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall b.
(Stream -> IO (b, Stream)) -> Session -> IO (Either XmppFailure b)
withConnection Session
sess forall a b. (a -> b) -> a -> b
$ \Stream
oldStream -> do
[Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"reconnect: closing stream"
Stream -> IO ()
closeStreams Stream
oldStream
[Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"reconnect: opening stream"
Either XmppFailure Stream
s <- [Char]
-> SessionConfiguration
-> Maybe (ConnectionState -> [SaslHandler], Maybe Text)
-> IO (Either XmppFailure Stream)
connectStream (Session -> [Char]
sRealm Session
sess) SessionConfiguration
config (Session -> Maybe (ConnectionState -> [SaslHandler], Maybe Text)
sSaslCredentials Session
sess)
case Either XmppFailure Stream
s of
Left XmppFailure
e -> do
[Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"reconnect failed" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show XmppFailure
e
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left XmppFailure
e , Stream
oldStream )
Right Stream
r -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right () , Stream
r )
case Either XmppFailure (Either XmppFailure ())
res of
Left XmppFailure
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just XmppFailure
e
Right (Left XmppFailure
e) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just XmppFailure
e
Right (Right ()) -> do
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar Int
rw Int
60
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SessionConfiguration -> Bool
enableRoster SessionConfiguration
config) forall a b. (a -> b) -> a -> b
$ Session -> IO ()
initRoster Session
sess
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
reconnect :: Integer
-> Session
-> IO (Bool, [XmppFailure])
reconnect :: Integer -> Session -> IO (Bool, [XmppFailure])
reconnect Integer
maxTries Session
sess = 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, [])
Just XmppFailure
e -> if (t
t forall a. Ord a => a -> a -> Bool
> t
1) then (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (XmppFailure
eforall a. a -> [a] -> [a]
:)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> IO (Bool, [XmppFailure])
go (t
t forall a. Num a => a -> a -> a
- t
1)
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Bool
False, [XmppFailure
e])
reconnect' :: Session
-> IO Integer
reconnect' :: Session -> IO Integer
reconnect' Session
sess = 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return t
i
Just XmppFailure
_e -> t -> IO t
go (t
iforall 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 <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
Int
wt <- forall a. TVar a -> STM a
readTVar TVar Int
rw
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
rw forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
min Int
300 (Int
2 forall a. Num a => a -> a -> a
* Int
wt)
forall (m :: * -> *) a. Monad m => a -> m a
return Int
wt
Int
t <- forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
wait forall a. Integral a => a -> a -> a
`div` Int
2 forall a. Num a => a -> a -> a
- Int
30, forall a. Ord a => a -> a -> a
max Int
60 Int
wait)
[Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$
[Char]
"Waiting " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
t forall a. [a] -> [a] -> [a]
++ [Char]
" seconds before reconnecting"
Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ Int
t forall a. Num a => a -> a -> a
* Int
10forall 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