{-# 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
    -- 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 <- 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 () -- 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 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 -- Don't block.
                        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'

-- | Creates and initializes a new Xmpp context.
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 }
    -- Pass the new session to the plugins so they can "tie the knot"
    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
    -- 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' = (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
                  )

-- | 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 :: 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

-- | 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 = (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)

-- | 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
    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 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 = 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 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 = 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

-- | 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