{-# 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
    -- If the IQ request has a namespace, send it through the appropriate channel.
    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 () -- The handler might be removed due to
                                      -- timeout
            (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
                    -- IQ was sent to the server and we didn't have a bound JID
                    -- We just accept any matching response
                        Left Maybe Jid
Nothing -> Bool
True
                    -- IQ was sent to the server and we had a bound JID. Valid
                    -- responses might have no to attribute, the domain of the
                    -- server, our bare JID or our full JID
                        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
                    -- IQ was sent to a (full) JID. The answer has to come from
                    -- the same exact JID.
                        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 -- Don't block.
                        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'

-- | Creates and initializes a new Xmpp context.
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 }
    -- Pass the new session to the plugins so they can "tie the knot"
    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
    -- Pass the stanza out action to each plugin
    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
                  )

-- | Creates a 'Session' object by setting up a connection with an XMPP server.
--
-- Will connect to the specified host with the provided configuration. If the
-- third parameter is a 'Just' value, @session@ will attempt to authenticate and
-- acquire an XMPP resource.
session :: HostName                          -- ^ The hostname / realm
        -> AuthData
        -> SessionConfiguration              -- ^ configuration details
        -> 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

-- | Authenticate using, in order of preference, 'scramSha1', 'digestMd5' and
-- finally, if both of those are not support and the stream is 'Secured' with
-- TLS, try 'plain'
--
-- The resource will be decided by the server
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)

-- | Reconnect immediately with the stored settings. Returns @Just@ the error
-- when the reconnect attempt fails and Nothing when no failure was encountered.
--
-- This function does not set your presence to online, so you will have to do
-- this yourself.
reconnectNow :: Session -- ^ session to reconnect
          -> 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 with the stored settings.
--
-- Waits a random amount of seconds (between 0 and 60 inclusive) before the
-- first attempt and an increasing amount after each attempt after that. Caps
-- out at 2-5 minutes.
--
-- This function does not set your presence to online, so you will have to do
-- this yourself.
reconnect :: Integer -- ^ Maximum number of retries (numbers of 1 or less will
                     -- perform exactly one retry)
          -> Session -- ^ Session to reconnect
          -> IO (Bool, [XmppFailure]) -- ^ Whether or not the reconnect attempt
                                      -- was successful, and a list of failure
                                      -- modes encountered
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 with the stored settings with an unlimited number of retries.
--
-- Waits a random amount of seconds (between 0 and 60 inclusive) before the
-- first attempt and an increasing amount after each attempt after that. Caps
-- out at 2-5 minutes.
--
-- This function does not set your presence to online, so you will have to do
-- this yourself.
reconnect' :: Session -- ^ Session to reconnect
          -> IO Integer -- ^ Number of failed retries before connection could be
                        -- established
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

-- | Generates a new stanza identifier based on the 'sessionStanzaIDs' field of
-- 'SessionConfiguration'.
newStanzaID :: Session -> IO Text
newStanzaID :: Session -> IO Text
newStanzaID = Session -> IO Text
idGenerator