{-# OPTIONS_HADDOCK hide #-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}

module Network.Xmpp.Stream where

import           Control.Applicative ((<$>))
import           Control.Concurrent (forkIO, threadDelay)
import           Control.Concurrent.STM
import qualified Control.Exception as Ex
import qualified Control.Exception.Lifted as ExL
import           Control.Monad
import           Control.Monad.Except
import           Control.Monad.State.Strict
import           Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC8
import           Data.Char (isSpace)
import           Data.Conduit hiding (connect)
import qualified Data.Conduit.Internal as DCI
import qualified Data.Conduit.List as CL
import           Data.IP
import           Data.List
import           Data.Maybe
import           Data.Ord
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Encoding.Error as Text
import           Data.Void (Void)
import           Data.Word (Word16)
import           Data.XML.Pickle
import           Data.XML.Types
import qualified GHC.IO.Exception as GIE
import           Network.Socket hiding (Closed, Stream, connect)
import           Network.DNS hiding (encode, lookup)
import qualified Network.Socket as S
import           Network.Socket (AddrInfo)
import           Network.Xmpp.Marshal
import           Network.Xmpp.Types
import           System.IO
-- import           System.IO.Error (tryIOError) <- Only available in base >=4.4
import           System.Log.Logger
import           System.Random (randomRIO)
import           Text.XML.Stream.Parse as XP
import           Lens.Family2 (over)

import           Network.Xmpp.Utilities
import qualified Network.Xmpp.Lens as L

-- "readMaybe" definition, as readMaybe is not introduced in the `base' package
-- until version 4.6.
readMaybe_ :: (Read a) => String -> Maybe a
readMaybe_ :: forall a. Read a => [Char] -> Maybe a
readMaybe_ [Char]
string = case forall a. Read a => ReadS a
reads [Char]
string of
                        [(a
a, [Char]
"")] -> forall a. a -> Maybe a
Just a
a
                        [(a, [Char])]
_ -> forall a. Maybe a
Nothing

-- import Text.XML.Stream.Elements

mbl :: Maybe [a] -> [a]
mbl :: forall a. Maybe [a] -> [a]
mbl (Just [a]
l) = [a]
l
mbl Maybe [a]
Nothing = []

lmb :: [t] -> Maybe [t]
lmb :: forall t. [t] -> Maybe [t]
lmb [] = forall a. Maybe a
Nothing
lmb [t]
x = forall a. a -> Maybe a
Just [t]
x

-- Unpickles and returns a stream element.
streamUnpickleElem :: PU [Node] a
                   -> Element
                   -> StreamSink a
streamUnpickleElem :: forall a. PU [Node] a -> Element -> StreamSink a
streamUnpickleElem PU [Node] a
p Element
x = do
    case forall a. PU [Node] a -> Element -> Either UnpickleError a
unpickleElem PU [Node] a
p Element
x of
        Left UnpickleError
l -> do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
warningM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"streamUnpickleElem: Unpickle error: " forall a. [a] -> [a] -> [a]
++ UnpickleError -> [Char]
ppUnpickleError UnpickleError
l
            forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ XmppFailure
XmppOtherFailure
        Right a
r -> forall (m :: * -> *) a. Monad m => a -> m a
return a
r

-- This is the conduit sink that handles the stream XML events. We extend it
-- with ExceptT capabilities.
type StreamSink a = ConduitM Event Void (ExceptT XmppFailure IO) a

-- Discards all events before the first EventBeginElement.
throwOutJunk :: Monad m => ConduitM Event a m ()
throwOutJunk :: forall (m :: * -> *) a. Monad m => ConduitM Event a m ()
throwOutJunk = do
    Maybe Event
next <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.peek
    case Maybe Event
next of
        Maybe Event
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return () -- This will only happen if the stream is closed.
        Just (EventBeginElement Name
_ [(Name, [Content])]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Maybe Event
_ -> forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
CL.drop Int
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => ConduitM Event a m ()
throwOutJunk

-- Returns an (empty) Element from a stream of XML events.
openElementFromEvents :: StreamSink Element
openElementFromEvents :: StreamSink Element
openElementFromEvents = do
    forall (m :: * -> *) a. Monad m => ConduitM Event a m ()
throwOutJunk
    Maybe Event
hd <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
await
    case Maybe Event
hd of
        Just (EventBeginElement Name
name [(Name, [Content])]
attrs) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> [(Name, [Content])] -> [Node] -> Element
Element Name
name [(Name, [Content])]
attrs []
        Maybe Event
_ -> do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
warningM [Char]
"Pontarius.Xmpp" [Char]
"openElementFromEvents: Stream ended."
            forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppOtherFailure

-- Sends the initial stream:stream element and pulls the server features. If the
-- server responds in a way that is invalid, an appropriate stream error will be
-- generated, the connection to the server will be closed, and a XmppFailure
-- will be produced.
startStream :: StateT StreamState IO (Either XmppFailure ())
startStream :: StateT StreamState IO (Either XmppFailure ())
startStream = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Starting stream..."
    StreamState
st <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => m s
get
    -- Set the `from' (which is also the expected to) attribute depending on the
    -- state of the stream.
    let expectedTo :: Maybe Jid
expectedTo = case ( StreamState -> ConnectionState
streamConnectionState StreamState
st
                          , StreamConfiguration -> Maybe (Jid, Bool)
toJid forall a b. (a -> b) -> a -> b
$ StreamState -> StreamConfiguration
streamConfiguration StreamState
st) of
          (ConnectionState
Plain    , (Just (Jid
j, Bool
True)))  -> forall a. a -> Maybe a
Just Jid
j
          (ConnectionState
Plain    , Maybe (Jid, Bool)
_               )  -> forall a. Maybe a
Nothing
          (ConnectionState
Secured  , (Just (Jid
j, Bool
_   )))  -> forall a. a -> Maybe a
Just Jid
j
          (ConnectionState
Secured  , Maybe (Jid, Bool)
Nothing         )  -> forall a. Maybe a
Nothing
          (ConnectionState
Closed   , Maybe (Jid, Bool)
_               )  -> forall a. Maybe a
Nothing
          (ConnectionState
Finished , Maybe (Jid, Bool)
_               )  -> forall a. Maybe a
Nothing
    case StreamState -> Maybe Text
streamAddress StreamState
st of
        Maybe Text
Nothing -> do
            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" [Char]
"Server sent no hostname."
            forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppOtherFailure
        Just Text
address -> do
            forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ StateT StreamState IO (Either XmppFailure ())
pushXmlDecl
            forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> StateT StreamState IO (Either XmppFailure ())
pushOpenElement forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Element
streamNSHack forall a b. (a -> b) -> a -> b
$
                forall a. PU [Node] a -> a -> Element
pickleElem PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
xpStream ( Text
"1.0"
                                    , Maybe Jid
expectedTo
                                    , forall a. a -> Maybe a
Just (Maybe NonemptyText -> NonemptyText -> Maybe NonemptyText -> Jid
Jid forall a. Maybe a
Nothing (Text -> NonemptyText
Nonempty Text
address) forall a. Maybe a
Nothing)
                                    , forall a. Maybe a
Nothing
                                    , StreamConfiguration -> Maybe LangTag
preferredLang forall a b. (a -> b) -> a -> b
$ StreamState -> StreamConfiguration
streamConfiguration StreamState
st
                                    )
    Either
  Element
  (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
   StreamFeatures)
response <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall b.
ConduitT Event Void (ExceptT XmppFailure IO) b
-> StateT StreamState IO (Either XmppFailure b)
runEventsSink forall a b. (a -> b) -> a -> b
$ Maybe Jid
-> StreamSink
     (Either
        Element
        (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
         StreamFeatures))
streamS Maybe Jid
expectedTo
    case Either
  Element
  (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
   StreamFeatures)
response of
      Right (Text
ver, Maybe Jid
from, Maybe Jid
to, Maybe Text
sid, Maybe LangTag
lt, StreamFeatures
features)
        | Text -> Maybe Version
versionFromText Text
ver forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing -> StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError
                                            StreamErrorCondition
StreamUnsupportedVersion forall a. Maybe a
Nothing
                                            [Char]
"Unspecified version"
        | let v :: Maybe Version
v = Text -> Maybe Version
versionFromText Text
ver
          in forall a. Maybe a -> Bool
isJust Maybe Version
v Bool -> Bool -> Bool
&& Version -> Integer
majorVersion (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Version
v) forall a. Ord a => a -> a -> Bool
>= Integer
2 ->
            StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
StreamUnsupportedVersion forall a. Maybe a
Nothing
              [Char]
"Non-1.x version"
    -- HACK: We ignore MUST-strength requirement (section 4.7.4. of RFC
    -- 6120) for the sake of compatibility with jabber.org
        --  | lt == Nothing ->
        --     closeStreamWithError StreamInvalidXml Nothing
        --         "Stream has no language tag"

    -- If `from' is set, we verify that it's the correct one. TODO: Should we
    -- check against the realm instead?
        | forall a. Maybe a -> Bool
isJust Maybe Jid
from Bool -> Bool -> Bool
&& (Maybe Jid
from forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just (Maybe NonemptyText -> NonemptyText -> Maybe NonemptyText -> Jid
Jid forall a. Maybe a
Nothing (Text -> NonemptyText
Nonempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ StreamState -> Maybe Text
streamAddress StreamState
st) forall a. Maybe a
Nothing)) ->
            StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
StreamInvalidFrom forall a. Maybe a
Nothing
                [Char]
"Stream from is invalid"
        | Maybe Jid
to forall a. Eq a => a -> a -> Bool
/= Maybe Jid
expectedTo ->
            StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
StreamUndefinedCondition (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> [(Name, [Content])] -> [Node] -> Element
Element Name
"invalid-to" [] [])
                [Char]
"Stream to invalid"-- TODO: Suitable?
        | Bool
otherwise -> do
            -- HACK: (ignore section 4.7.4. of RFC 6120), see above
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Maybe a -> Bool
isJust Maybe LangTag
lt) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
warningM [Char]
"Pontariusm.Xmpp"
                [Char]
"Stream has no language tag"
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\StreamState
s -> StreamState
s{ streamFeatures :: StreamFeatures
streamFeatures = StreamFeatures
features
                           , streamLang :: Maybe LangTag
streamLang = Maybe LangTag
lt
                           , streamId :: Maybe Text
streamId = Maybe Text
sid
                           , streamFrom :: Maybe Jid
streamFrom = Maybe Jid
from
                         } )
            forall (m :: * -> *) a. Monad m => a -> m a
return ()
      -- Unpickling failed - we investigate the element.
      Left (Element Name
name [(Name, [Content])]
attrs [Node]
_children)
        | (Name -> Text
nameLocalName Name
name forall a. Eq a => a -> a -> Bool
/= Text
"stream") ->
            StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
StreamInvalidXml forall a. Maybe a
Nothing
               [Char]
"Root element is not stream"
        | (Name -> Maybe Text
nameNamespace Name
name forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Text
"http://etherx.jabber.org/streams") ->
            StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
StreamInvalidNamespace forall a. Maybe a
Nothing
               [Char]
"Wrong root element name space"
        | (forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ Name -> Maybe Text
namePrefix Name
name) Bool -> Bool -> Bool
&& (forall a. HasCallStack => Maybe a -> a
fromJust (Name -> Maybe Text
namePrefix Name
name) forall a. Eq a => a -> a -> Bool
/= Text
"stream") ->
            StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
StreamBadNamespacePrefix forall a. Maybe a
Nothing
                [Char]
"Root name prefix set and not stream"
        | Bool
otherwise -> forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ [(Name, Text)] -> StateT StreamState IO (Either XmppFailure ())
checkchildren ([(Name, [Content])] -> [(Name, Text)]
flattenAttrs [(Name, [Content])]
attrs)
  where
    -- HACK: We include the default namespace to make isode's M-LINK server happy.
    streamNSHack :: Element -> Element
streamNSHack Element
e = Element
e{elementAttributes :: [(Name, [Content])]
elementAttributes = Element -> [(Name, [Content])]
elementAttributes Element
e
                                           forall a. [a] -> [a] -> [a]
++ [( Name
"xmlns"
                                               , [Text -> Content
ContentText Text
"jabber:client"])]}
    closeStreamWithError  :: StreamErrorCondition -> Maybe Element -> String
                          -> ExceptT XmppFailure (StateT StreamState IO) ()
    closeStreamWithError :: StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
sec Maybe Element
el [Char]
msg = do
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> StateT StreamState IO (Either XmppFailure ())
pushElement forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PU [Node] a -> a -> Element
pickleElem PU [Node] StreamErrorInfo
xpStreamError
            forall a b. (a -> b) -> a -> b
$ StreamErrorCondition
-> Maybe (Maybe LangTag, NonemptyText)
-> Maybe Element
-> StreamErrorInfo
StreamErrorInfo StreamErrorCondition
sec forall a. Maybe a
Nothing Maybe Element
el
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ StateT StreamState IO ()
closeStreams'
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"closeStreamWithError: " forall a. [a] -> [a] -> [a]
++ [Char]
msg
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppOtherFailure
    checkchildren :: [(Name, Text)] -> StateT StreamState IO (Either XmppFailure ())
checkchildren [(Name, Text)]
children =
        let to' :: Maybe Text
to'  = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
"to"      [(Name, Text)]
children
            ver' :: Maybe Text
ver' = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
"version" [(Name, Text)]
children
            xl :: Maybe Text
xl   = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
xmlLang   [(Name, Text)]
children
          in case () of () | forall a. a -> Maybe a
Just forall a. Maybe a
Nothing forall a. Eq a => a -> a -> Bool
== forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Maybe Jid
jidFromText Maybe Text
to' ->
                               forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError
                                   StreamErrorCondition
StreamBadNamespacePrefix forall a. Maybe a
Nothing
                                   [Char]
"stream to not a valid JID"
                           | forall a. Maybe a
Nothing forall a. Eq a => a -> a -> Bool
== Maybe Text
ver' ->
                               forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError
                                   StreamErrorCondition
StreamUnsupportedVersion forall a. Maybe a
Nothing
                                   [Char]
"stream no version"
                           | forall a. a -> Maybe a
Just (forall a. Maybe a
Nothing :: Maybe LangTag) forall a. Eq a => a -> a -> Bool
== (forall {a}. Read a => Text -> Maybe a
safeRead forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
xl) ->
                               forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError
                                   StreamErrorCondition
StreamInvalidXml forall a. Maybe a
Nothing
                                   [Char]
"stream no language tag"
                           | Bool
otherwise ->
                               forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError
                                   StreamErrorCondition
StreamBadFormat forall a. Maybe a
Nothing
                                   [Char]
""
    safeRead :: Text -> Maybe a
safeRead Text
x = case forall a. Read a => ReadS a
reads forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Text.unpack Text
x of
        [] -> forall a. Maybe a
Nothing
        ((a
y,[Char]
_):[(a, [Char])]
_) -> forall a. a -> Maybe a
Just a
y

flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)]
flattenAttrs :: [(Name, [Content])] -> [(Name, Text)]
flattenAttrs [(Name, [Content])]
attrs = forall a b. (a -> b) -> [a] -> [b]
Prelude.map (\(Name
name, [Content]
cont) ->
                             ( Name
name
                             , [Text] -> Text
Text.concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
Prelude.map Content -> Text
uncontentify [Content]
cont)
                             )
                         [(Name, [Content])]
attrs
  where
    uncontentify :: Content -> Text
uncontentify (ContentText Text
t) = Text
t
    uncontentify Content
_ = Text
""

-- Sets a new Event source using the raw source (of bytes)
-- and calls xmppStartStream.
restartStream :: StateT StreamState IO (Either XmppFailure ())
restartStream :: StateT StreamState IO (Either XmppFailure ())
restartStream = do
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Restarting stream..."
    StreamHandle
raw <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StreamState -> StreamHandle
streamHandle
    let newSource :: ConduitT a Event m ()
newSource = forall (m :: * -> *) i.
(MonadIO m, MonadError XmppFailure m) =>
StreamHandle -> ConduitM i Domain m ()
sourceStreamHandle StreamHandle
raw forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
$= forall (m :: * -> *).
MonadThrow m =>
ParseSettings -> ConduitT Domain Event m ()
XP.parseBytes forall a. Default a => a
def
    ConduitM () Event (ExceptT XmppFailure IO) ()
buffered <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o i.
ConduitT () o (ExceptT XmppFailure IO) ()
-> IO (ConduitM i o (ExceptT XmppFailure IO) ())
bufferSrc forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a}.
(MonadIO m, MonadError XmppFailure m, MonadThrow m) =>
ConduitT a Event m ()
newSource
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\StreamState
s -> StreamState
s{streamEventSource :: ConduitM () Event (ExceptT XmppFailure IO) ()
streamEventSource = ConduitM () Event (ExceptT XmppFailure IO) ()
buffered })
    StateT StreamState IO (Either XmppFailure ())
startStream


-- Creates a conduit from a StreamHandle
sourceStreamHandleRaw :: (MonadIO m, MonadError XmppFailure m)
                      => StreamHandle -> ConduitM i ByteString m ()
sourceStreamHandleRaw :: forall (m :: * -> *) i.
(MonadIO m, MonadError XmppFailure m) =>
StreamHandle -> ConduitM i Domain m ()
sourceStreamHandleRaw StreamHandle
s = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {m :: * -> *} {t} {e} {o} {i}.
(MonadIO m, Num t, MonadError e m) =>
(t -> IO (Either e o)) -> ConduitT i o m ()
read forall a b. (a -> b) -> a -> b
$ StreamHandle -> Int -> IO (Either XmppFailure Domain)
streamReceive StreamHandle
s
  where
    read :: (t -> IO (Either e o)) -> ConduitT i o m ()
read t -> IO (Either e o)
rd = do
        Either e o
bs' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (t -> IO (Either e o)
rd t
4096)
        o
bs <- case Either e o
bs' of
            Left e
e -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
            Right o
r -> forall (m :: * -> *) a. Monad m => a -> m a
return o
r
        forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield o
bs

sourceStreamHandle :: (MonadIO m, MonadError XmppFailure m)
                      => StreamHandle -> ConduitM i ByteString m ()
sourceStreamHandle :: forall (m :: * -> *) i.
(MonadIO m, MonadError XmppFailure m) =>
StreamHandle -> ConduitM i Domain m ()
sourceStreamHandle StreamHandle
sh = forall (m :: * -> *) i.
(MonadIO m, MonadError XmppFailure m) =>
StreamHandle -> ConduitM i Domain m ()
sourceStreamHandleRaw StreamHandle
sh forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
$= forall (m :: * -> *). MonadIO m => ConduitM Domain Domain m ()
logInput

logInput :: MonadIO m => ConduitM ByteString ByteString m ()
logInput :: forall (m :: * -> *). MonadIO m => ConduitM Domain Domain m ()
logInput = forall {m :: * -> *}.
MonadIO m =>
Maybe (Domain -> Decoding) -> ConduitT Domain Domain m ()
go forall a. Maybe a
Nothing
  where
    go :: Maybe (Domain -> Decoding) -> ConduitT Domain Domain m ()
go Maybe (Domain -> Decoding)
mbDec = do
        Maybe Domain
mbBs <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
await
        case Maybe Domain
mbBs of
         Maybe Domain
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
         Just Domain
bs -> do
           let decode :: Domain -> Decoding
decode = case Maybe (Domain -> Decoding)
mbDec of
                         Maybe (Domain -> Decoding)
Nothing -> OnDecodeError -> Domain -> Decoding
Text.streamDecodeUtf8With OnDecodeError
Text.lenientDecode
                         Just Domain -> Decoding
d -> Domain -> Decoding
d
               (Text.Some Text
out Domain
leftover Domain -> Decoding
cont) = Domain -> Decoding
decode Domain
bs
               cont' :: Maybe (Domain -> Decoding)
cont' = if Domain -> Bool
BS.null Domain
leftover
                       then forall a. Maybe a
Nothing
                       else forall a. a -> Maybe a
Just Domain -> Decoding
cont
           forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Text.null Text
out) forall a b. (a -> b) -> a -> b
$
               forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp"
                                forall a b. (a -> b) -> a -> b
$ [Char]
"in: " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Text.unpack Text
out
           forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Domain
bs
           Maybe (Domain -> Decoding) -> ConduitT Domain Domain m ()
go Maybe (Domain -> Decoding)
cont'

-- We buffer sources because we don't want to lose data when multiple
-- xml-entities are sent with the same packet and we don't want to eternally
-- block the StreamState while waiting for data to arrive
bufferSrc :: ConduitT () o (ExceptT XmppFailure IO) ()
          -> IO (ConduitM i o (ExceptT XmppFailure IO) ())
bufferSrc :: forall o i.
ConduitT () o (ExceptT XmppFailure IO) ()
-> IO (ConduitM i o (ExceptT XmppFailure IO) ())
bufferSrc ConduitT () o (ExceptT XmppFailure IO) ()
src = do
    TMVar (SealedConduitT () o (ExceptT XmppFailure IO) ())
ref <- forall a. a -> IO (TMVar a)
newTMVarIO forall a b. (a -> b) -> a -> b
$ forall i o (m :: * -> *) r.
ConduitT i o m r -> SealedConduitT i o m r
DCI.sealConduitT ConduitT () o (ExceptT XmppFailure IO) ()
src
    let go :: ConduitT i o m ()
go = do
            Either XmppFailure (Maybe o)
dt <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 (SealedConduitT () o (ExceptT XmppFailure IO) ())
ref)
                      (\SealedConduitT () o (ExceptT XmppFailure IO) ()
_ -> forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TMVar a -> a -> STM ()
putTMVar TMVar (SealedConduitT () o (ExceptT XmppFailure IO) ())
ref forall a b. (a -> b) -> a -> b
$ forall {o}. SealedConduitT () o (ExceptT XmppFailure IO) ()
zeroResumableSource)
                      (\SealedConduitT () o (ExceptT XmppFailure IO) ()
s -> do
                            Either
  XmppFailure
  (SealedConduitT () o (ExceptT XmppFailure IO) (), Maybe o)
res <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (SealedConduitT () o (ExceptT XmppFailure IO) ()
s forall (m :: * -> *) a b.
Monad m =>
SealedConduitT () a m ()
-> ConduitT a Void m b -> m (SealedConduitT () a m (), b)
$$++ forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
await)
                            case Either
  XmppFailure
  (SealedConduitT () o (ExceptT XmppFailure IO) (), Maybe o)
res of
                                Left XmppFailure
e -> do
                                    forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar (SealedConduitT () o (ExceptT XmppFailure IO) ())
ref forall {o}. SealedConduitT () o (ExceptT XmppFailure IO) ()
zeroResumableSource
                                    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 (SealedConduitT () o (ExceptT XmppFailure IO) ()
s',Maybe o
b) -> do
                                    forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar (SealedConduitT () o (ExceptT XmppFailure IO) ())
ref SealedConduitT () o (ExceptT XmppFailure IO) ()
s'
                                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Maybe o
b
                      )
            case Either XmppFailure (Maybe o)
dt of
                Left XmppFailure
e -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
e
                Right Maybe o
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Right (Just o
d) -> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield o
d forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConduitT i o m ()
go
    forall (m :: * -> *) a. Monad m => a -> m a
return forall {m :: * -> *} {i}.
(MonadIO m, MonadError XmppFailure m) =>
ConduitT i o m ()
go
  where
    zeroResumableSource :: SealedConduitT () o (ExceptT XmppFailure IO) ()
zeroResumableSource = forall i o (m :: * -> *) r.
ConduitT i o m r -> SealedConduitT i o m r
DCI.sealConduitT forall a. ConduitT () a (ExceptT XmppFailure IO) ()
zeroSource

-- Reads the (partial) stream:stream and the server features from the stream.
-- Returns the (unvalidated) stream attributes, the unparsed element, or
-- throwError throws a `XmppOtherFailure' (if something other than an element
-- was encountered at first, or if something other than stream features was
-- encountered second).
-- TODO: from.
streamS :: Maybe Jid -> StreamSink (Either Element ( Text
                                                   , Maybe Jid
                                                   , Maybe Jid
                                                   , Maybe Text
                                                   , Maybe LangTag
                                                   , StreamFeatures ))
streamS :: Maybe Jid
-> StreamSink
     (Either
        Element
        (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
         StreamFeatures))
streamS Maybe Jid
_expectedTo = do -- TODO: check expectedTo
    Either
  Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
streamHeader <- StreamSink
  (Either
     Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag))
xmppStreamHeader
    case Either
  Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
streamHeader of
      Right (Text
version, Maybe Jid
from, Maybe Jid
to, Maybe Text
sid, Maybe LangTag
lTag) -> do
        StreamFeatures
features <- StreamSink StreamFeatures
xmppStreamFeatures
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (Text
version, Maybe Jid
from, Maybe Jid
to, Maybe Text
sid, Maybe LangTag
lTag, StreamFeatures
features)
      Left Element
el -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Element
el
  where
    xmppStreamHeader :: StreamSink (Either Element (Text, Maybe Jid, Maybe Jid, Maybe Text.Text, Maybe LangTag))
    xmppStreamHeader :: StreamSink
  (Either
     Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag))
xmppStreamHeader = do
        forall (m :: * -> *) a. Monad m => ConduitM Event a m ()
throwOutJunk
        -- Get the stream:stream element (or whatever it is) from the server,
        -- and validate what we get.
        Element
el <- StreamSink Element
openElementFromEvents -- May throw `XmppOtherFailure' if an
                                    -- element is not received
        case forall a. PU [Node] a -> Element -> Either UnpickleError a
unpickleElem PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
xpStream Element
el of
            Left UnpickleError
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Element
el
            Right (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
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 (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
r
    xmppStreamFeatures :: StreamSink StreamFeatures
    xmppStreamFeatures :: StreamSink StreamFeatures
xmppStreamFeatures = do
        Maybe Element
e <- forall (m :: * -> *).
MonadError XmppFailure m =>
ConduitT Event Element m ()
elements forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
=$ forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
await
        case Maybe Element
e of
            Maybe Element
Nothing -> do
                forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" [Char]
"streamS: Stream ended."
                forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppOtherFailure
            Just Element
r -> forall a. PU [Node] a -> Element -> StreamSink a
streamUnpickleElem PU [Node] StreamFeatures
xpStreamFeatures Element
r

-- | Connects to the XMPP server and opens the XMPP stream against the given
-- realm.
openStream :: HostName -> StreamConfiguration -> IO (Either XmppFailure (Stream))
openStream :: [Char] -> StreamConfiguration -> IO (Either XmppFailure Stream)
openStream [Char]
realm StreamConfiguration
config = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Opening stream..."
    Stream
stream' <- [Char] -> StreamConfiguration -> ExceptT XmppFailure IO Stream
createStream [Char]
realm StreamConfiguration
config
    forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 StateT StreamState IO (Either XmppFailure ())
startStream Stream
stream'
    forall (m :: * -> *) a. Monad m => a -> m a
return Stream
stream'

-- | Send \"</stream:stream>\" and wait for the server to finish processing and
-- to close the connection. Any remaining elements from the server are returned.
-- Surpresses 'StreamEndFailure' exceptions, but may throw a 'StreamCloseError'.
closeStreams :: Stream -> IO ()
closeStreams :: Stream -> IO ()
closeStreams = forall a. StateT StreamState IO a -> Stream -> IO a
withStream StateT StreamState IO ()
closeStreams'

closeStreams' :: StateT StreamState IO ()
closeStreams' :: StateT StreamState IO ()
closeStreams' = do
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Closing stream"
    Domain -> IO (Either XmppFailure ())
send <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StreamHandle -> Domain -> IO (Either XmppFailure ())
streamSend forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamHandle
streamHandle)
    IO ()
cc <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StreamHandle -> IO ()
streamClose forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamHandle
streamHandle)
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Sending closing tag"
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Domain -> IO (Either XmppFailure ())
send Domain
"</stream:stream>"
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Waiting for stream to close"
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
        Int -> IO ()
threadDelay Int
3000000 -- TODO: Configurable value
        forall (f :: * -> *) a. Functor f => f a -> f ()
void ((forall e a. Exception e => IO a -> IO (Either e a)
Ex.try IO ()
cc) :: IO (Either Ex.SomeException ()))
        forall (m :: * -> *) a. Monad m => a -> m a
return ()
    forall s (m :: * -> *). MonadState s m => s -> m ()
put StreamState
xmppNoStream{ streamConnectionState :: ConnectionState
streamConnectionState = ConnectionState
Finished }
--     lift $ debugM "Pontarius.Xmpp" "Collecting remaining elements"
--     es <- collectElems []
    -- lift $ debugM "Pontarius.Xmpp" "Stream sucessfully closed"
    -- return es
  -- where
  --   -- Pulls elements from the stream until the stream ends, or an error is
  --   -- raised.
  --   collectElems :: [Element] -> StateT StreamState IO (Either XmppFailure [Element])
  --   collectElems es = do
  --       result <- pullElement
  --       case result of
  --           Left StreamEndFailure -> return $ Right es
  --           Left e -> return $ Left $ StreamCloseError (es, e)
  --           Right e -> collectElems (e:es)

-- TODO: Can the TLS send/recv functions throw something other than an IO error?
debugOut :: MonadIO m => ByteString -> m ()
debugOut :: forall (m :: * -> *). MonadIO m => Domain -> m ()
debugOut Domain
outData = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp"
             ([Char]
"Out: " forall a. [a] -> [a] -> [a]
++ (Text -> [Char]
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domain -> Text
Text.decodeUtf8 forall a b. (a -> b) -> a -> b
$ Domain
outData))

wrapIOException :: MonadIO m =>
                   String
                -> IO a
                -> m (Either XmppFailure a)
wrapIOException :: forall (m :: * -> *) a.
MonadIO m =>
[Char] -> IO a -> m (Either XmppFailure a)
wrapIOException [Char]
tag IO a
action = do
    Either IOException a
r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Either IOException a)
tryIOError IO a
action
    case Either IOException a
r of
        Right a
b -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right a
b
        Left IOException
e -> do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
warningM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [ [Char]
"wrapIOException ("
                , [Char]
tag
                , [Char]
") : Exception wrapped: "
                , forall a. Show a => a -> [Char]
show IOException
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 forall a b. (a -> b) -> a -> b
$ IOException -> XmppFailure
XmppIOException IOException
e

pushElement :: Element -> StateT StreamState IO (Either XmppFailure ())
pushElement :: Element -> StateT StreamState IO (Either XmppFailure ())
pushElement Element
x = do
    Domain -> IO (Either XmppFailure ())
send <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StreamHandle -> Domain -> IO (Either XmppFailure ())
streamSend forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamHandle
streamHandle)
    let outData :: Domain
outData = Element -> Domain
renderElement forall a b. (a -> b) -> a -> b
$ Element -> Element
nsHack Element
x
    forall (m :: * -> *). MonadIO m => Domain -> m ()
debugOut Domain
outData
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Domain -> IO (Either XmppFailure ())
send Domain
outData

-- HACK: We remove the "jabber:client" namespace because it is set as
-- default in the stream. This is to make isode's M-LINK server happy and
-- should be removed once jabber.org accepts prefix-free canonicalization
nsHack :: Element -> Element
nsHack :: Element -> Element
nsHack e :: Element
e@(Element{elementName :: Element -> Name
elementName = Name
n})
    | Name -> Maybe Text
nameNamespace Name
n forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
"jabber:client" =
        Element
e{ elementName :: Name
elementName = Text -> Maybe Text -> Maybe Text -> Name
Name (Name -> Text
nameLocalName Name
n) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
         , elementNodes :: [Node]
elementNodes = forall a b. (a -> b) -> [a] -> [b]
map Node -> Node
mapNSHack forall a b. (a -> b) -> a -> b
$ Element -> [Node]
elementNodes Element
e
         }
    | Bool
otherwise = Element
e
  where
    mapNSHack :: Node -> Node
    mapNSHack :: Node -> Node
mapNSHack (NodeElement Element
el) = Element -> Node
NodeElement forall a b. (a -> b) -> a -> b
$ Element -> Element
nsHack Element
el
    mapNSHack Node
nd = Node
nd

-- | Encode and send stanza
pushStanza :: Stanza -> Stream -> IO (Either XmppFailure ())
pushStanza :: Stanza -> Stream -> IO (Either XmppFailure ())
pushStanza Stanza
s = forall a. StateT StreamState IO a -> Stream -> IO a
withStream' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> StateT StreamState IO (Either XmppFailure ())
pushElement forall a b. (a -> b) -> a -> b
$ forall a. PU [Node] a -> a -> Element
pickleElem PU [Node] Stanza
xpStanza Stanza
s

-- XML documents and XMPP streams SHOULD be preceeded by an XML declaration.
-- UTF-8 is the only supported XMPP encoding. The standalone document
-- declaration (matching "SDDecl" in the XML standard) MUST NOT be included in
-- XMPP streams. RFC 6120 defines XMPP only in terms of XML 1.0.
pushXmlDecl :: StateT StreamState IO (Either XmppFailure ())
pushXmlDecl :: StateT StreamState IO (Either XmppFailure ())
pushXmlDecl = do
    StreamHandle
con <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StreamState -> StreamHandle
streamHandle
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ StreamHandle -> Domain -> IO (Either XmppFailure ())
streamSend StreamHandle
con Domain
"<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"

pushOpenElement :: Element -> StateT StreamState IO (Either XmppFailure ())
pushOpenElement :: Element -> StateT StreamState IO (Either XmppFailure ())
pushOpenElement Element
e = do
    Domain -> IO (Either XmppFailure ())
send <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StreamHandle -> Domain -> IO (Either XmppFailure ())
streamSend forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamHandle
streamHandle)
    let outData :: Domain
outData = Element -> Domain
renderOpenElement Element
e
    forall (m :: * -> *). MonadIO m => Domain -> m ()
debugOut Domain
outData
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Domain -> IO (Either XmppFailure ())
send Domain
outData

-- `Connect-and-resumes' the given sink to the stream source, and pulls a
-- `b' value.
runEventsSink :: ConduitT Event Void (ExceptT XmppFailure IO) b
              -> StateT StreamState IO (Either XmppFailure b)
runEventsSink :: forall b.
ConduitT Event Void (ExceptT XmppFailure IO) b
-> StateT StreamState IO (Either XmppFailure b)
runEventsSink ConduitT Event Void (ExceptT XmppFailure IO) b
snk = do -- TODO: Wrap exceptions?
    ConduitM () Event (ExceptT XmppFailure IO) ()
src <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StreamState -> ConduitM () Event (ExceptT XmppFailure IO) ()
streamEventSource
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ ConduitM () Event (ExceptT XmppFailure IO) ()
src forall (m :: * -> *) a b.
Monad m =>
Source m a -> Sink a m b -> m b
$$ ConduitT Event Void (ExceptT XmppFailure IO) b
snk

pullElement :: StateT StreamState IO (Either XmppFailure Element)
pullElement :: StateT StreamState IO (Either XmppFailure Element)
pullElement = do
    Either XmppFailure (Maybe Element)
e <- forall b.
ConduitT Event Void (ExceptT XmppFailure IO) b
-> StateT StreamState IO (Either XmppFailure b)
runEventsSink (forall (m :: * -> *).
MonadError XmppFailure m =>
ConduitT Event Element m ()
elements forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
=$ forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
await)
    case Either XmppFailure (Maybe Element)
e of
        Left XmppFailure
l -> do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
.  [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$
                  [Char]
"Error while retrieving XML element: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show XmppFailure
l
            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
l

        Right Maybe Element
Nothing -> do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" [Char]
"pullElement: Stream ended."
            forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ XmppFailure
XmppOtherFailure
        Right (Just Element
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 Element
r

-- Pulls an element and unpickles it.
pullUnpickle :: PU [Node] a -> StateT StreamState IO (Either XmppFailure a)
pullUnpickle :: forall a.
PU [Node] a -> StateT StreamState IO (Either XmppFailure a)
pullUnpickle PU [Node] a
p = do
    Either XmppFailure Element
el <- StateT StreamState IO (Either XmppFailure Element)
pullElement
    case Either XmppFailure Element
el 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 Element
elem' -> do
            let res :: Either UnpickleError a
res = forall a. PU [Node] a -> Element -> Either UnpickleError a
unpickleElem PU [Node] a
p Element
elem'
            case Either UnpickleError a
res of
                Left UnpickleError
e -> do
                    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"pullUnpickle: Unpickle failed: " forall a. [a] -> [a] -> [a]
++ (UnpickleError -> [Char]
ppUnpickleError UnpickleError
e)
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ XmppFailure
XmppOtherFailure
                Right a
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 a
r

-- | Pulls a stanza (or stream error) from the stream.
pullStanza :: Stream -> IO (Either XmppFailure Stanza)
pullStanza :: Stream -> IO (Either XmppFailure Stanza)
pullStanza = forall a. StateT StreamState IO a -> Stream -> IO a
withStream' forall a b. (a -> b) -> a -> b
$ do
    Either XmppFailure (Either StreamErrorInfo Stanza)
res <- forall a.
PU [Node] a -> StateT StreamState IO (Either XmppFailure a)
pullUnpickle PU [Node] (Either StreamErrorInfo Stanza)
xpStreamStanza
    case Either XmppFailure (Either StreamErrorInfo Stanza)
res 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 (Left StreamErrorInfo
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 forall a b. (a -> b) -> a -> b
$ StreamErrorInfo -> XmppFailure
StreamErrorFailure StreamErrorInfo
e
        Right (Right Stanza
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 Stanza
r

-- | Pulls a stanza, nonza or stream error from the stream.
pullXmppElement :: Stream -> IO (Either XmppFailure XmppElement)
pullXmppElement :: Stream -> IO (Either XmppFailure XmppElement)
pullXmppElement = forall a. StateT StreamState IO a -> Stream -> IO a
withStream' forall a b. (a -> b) -> a -> b
$ do
    Either XmppFailure (Either StreamErrorInfo XmppElement)
res <- forall a.
PU [Node] a -> StateT StreamState IO (Either XmppFailure a)
pullUnpickle PU [Node] (Either StreamErrorInfo XmppElement)
xpStreamElement
    case Either XmppFailure (Either StreamErrorInfo XmppElement)
res 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 (Left StreamErrorInfo
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 forall a b. (a -> b) -> a -> b
$ StreamErrorInfo -> XmppFailure
StreamErrorFailure StreamErrorInfo
e
        Right (Right XmppElement
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 XmppElement
r

-- Performs the given IO operation, catches any errors and re-throws everything
-- except 'ResourceVanished' and IllegalOperation, which it will return.
catchPush :: IO () -> IO (Either XmppFailure ())
catchPush :: IO () -> IO (Either XmppFailure ())
catchPush IO ()
p = forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
ExL.catch
    (IO ()
p forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right ()))
    (\IOException
e -> case IOException -> IOErrorType
GIE.ioe_type IOException
e of
         IOErrorType
GIE.ResourceVanished -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ IOException -> XmppFailure
XmppIOException IOException
e
         IOErrorType
GIE.IllegalOperation -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ IOException -> XmppFailure
XmppIOException IOException
e
         IOErrorType
_ -> forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
ExL.throwIO IOException
e
    )

zeroHandle :: StreamHandle
zeroHandle :: StreamHandle
zeroHandle = StreamHandle { streamSend :: Domain -> IO (Either XmppFailure ())
streamSend = \Domain
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left XmppFailure
XmppNoStream)
                          , streamReceive :: Int -> IO (Either XmppFailure Domain)
streamReceive = \Int
_ -> do
                                 [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp"
                                        [Char]
"xmppNoStream: Stream is closed."
                                 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
XmppNoStream
                          , streamFlush :: IO ()
streamFlush = forall (m :: * -> *) a. Monad m => a -> m a
return ()
                          , streamClose :: IO ()
streamClose = forall (m :: * -> *) a. Monad m => a -> m a
return ()
                          }

-- Stream state used when there is no connection.
xmppNoStream :: StreamState
xmppNoStream :: StreamState
xmppNoStream = StreamState {
      streamConnectionState :: ConnectionState
streamConnectionState = ConnectionState
Closed
    , streamHandle :: StreamHandle
streamHandle = StreamHandle
zeroHandle
    , streamEventSource :: ConduitM () Event (ExceptT XmppFailure IO) ()
streamEventSource = forall a. ConduitT () a (ExceptT XmppFailure IO) ()
zeroSource
    , streamFeatures :: StreamFeatures
streamFeatures = forall a. Monoid a => a
mempty
    , streamAddress :: Maybe Text
streamAddress = forall a. Maybe a
Nothing
    , streamFrom :: Maybe Jid
streamFrom = forall a. Maybe a
Nothing
    , streamId :: Maybe Text
streamId = forall a. Maybe a
Nothing
    , streamLang :: Maybe LangTag
streamLang = forall a. Maybe a
Nothing
    , streamJid :: Maybe Jid
streamJid = forall a. Maybe a
Nothing
    , streamConfiguration :: StreamConfiguration
streamConfiguration = forall a. Default a => a
def
    }

zeroSource :: ConduitT () a (ExceptT XmppFailure IO) ()
zeroSource :: forall a. ConduitT () a (ExceptT XmppFailure IO) ()
zeroSource = do
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"zeroSource"
    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppNoStream

handleToStreamHandle :: Handle -> StreamHandle
handleToStreamHandle :: Handle -> StreamHandle
handleToStreamHandle Handle
h = StreamHandle { streamSend :: Domain -> IO (Either XmppFailure ())
streamSend = \Domain
d ->
                                         forall (m :: * -> *) a.
MonadIO m =>
[Char] -> IO a -> m (Either XmppFailure a)
wrapIOException [Char]
"streamSend"
                                           forall a b. (a -> b) -> a -> b
$ Handle -> Domain -> IO ()
BS.hPut Handle
h Domain
d
                                      , streamReceive :: Int -> IO (Either XmppFailure Domain)
streamReceive = \Int
n ->
                                         forall (m :: * -> *) a.
MonadIO m =>
[Char] -> IO a -> m (Either XmppFailure a)
wrapIOException [Char]
"streamReceive"
                                           forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO Domain
BS.hGetSome Handle
h Int
n
                                      , streamFlush :: IO ()
streamFlush = Handle -> IO ()
hFlush Handle
h
                                      , streamClose :: IO ()
streamClose = Handle -> IO ()
hClose Handle
h
                                      }

createStream :: HostName -> StreamConfiguration -> ExceptT XmppFailure IO (Stream)
createStream :: [Char] -> StreamConfiguration -> ExceptT XmppFailure IO Stream
createStream [Char]
realm StreamConfiguration
config = do
    Maybe StreamHandle
result <- [Char]
-> StreamConfiguration
-> ExceptT XmppFailure IO (Maybe StreamHandle)
connect [Char]
realm StreamConfiguration
config
    case Maybe StreamHandle
result of
        Just StreamHandle
hand -> forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ do
            [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Acquired handle."
            [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Setting NoBuffering mode on handle."
            ConduitM () Event (ExceptT XmppFailure IO) ()
eSource <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o i.
ConduitT () o (ExceptT XmppFailure IO) ()
-> IO (ConduitM i o (ExceptT XmppFailure IO) ())
bufferSrc forall a b. (a -> b) -> a -> b
$
                         (forall (m :: * -> *) i.
(MonadIO m, MonadError XmppFailure m) =>
StreamHandle -> ConduitM i Domain m ()
sourceStreamHandle StreamHandle
hand forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
$= forall (m :: * -> *). MonadIO m => ConduitM Domain Domain m ()
logConduit)
                           forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
$= forall (m :: * -> *).
MonadThrow m =>
ParseSettings -> ConduitT Domain Event m ()
XP.parseBytes forall a. Default a => a
def
            let stream :: StreamState
stream = StreamState
                  { streamConnectionState :: ConnectionState
streamConnectionState = ConnectionState
Plain
                  , streamHandle :: StreamHandle
streamHandle = StreamHandle
hand
                  , streamEventSource :: ConduitM () Event (ExceptT XmppFailure IO) ()
streamEventSource = ConduitM () Event (ExceptT XmppFailure IO) ()
eSource
                  , streamFeatures :: StreamFeatures
streamFeatures = forall a. Monoid a => a
mempty
                  , streamAddress :: Maybe Text
streamAddress = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Text
Text.pack [Char]
realm
                  , streamFrom :: Maybe Jid
streamFrom = forall a. Maybe a
Nothing
                  , streamId :: Maybe Text
streamId = forall a. Maybe a
Nothing
                  , streamLang :: Maybe LangTag
streamLang = forall a. Maybe a
Nothing
                  , streamJid :: Maybe Jid
streamJid = forall a. Maybe a
Nothing
                  , streamConfiguration :: StreamConfiguration
streamConfiguration = [Char] -> StreamConfiguration -> StreamConfiguration
maybeSetTlsHost [Char]
realm StreamConfiguration
config
                  }
            Stream
stream' <- StreamState -> IO Stream
mkStream StreamState
stream
            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
stream'
        Maybe StreamHandle
Nothing -> do
            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Did not acquire handle."
            forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
TcpConnectionFailure
  where
    logConduit :: MonadIO m => ConduitT ByteString ByteString m ()
    logConduit :: forall (m :: * -> *). MonadIO m => ConduitM Domain Domain m ()
logConduit = forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
CL.mapM forall a b. (a -> b) -> a -> b
$ \Domain
d -> do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"In: " forall a. [a] -> [a] -> [a]
++ (Domain -> [Char]
BSC8.unpack Domain
d) forall a. [a] -> [a] -> [a]
++
            [Char]
"."
        forall (m :: * -> *) a. Monad m => a -> m a
return Domain
d
    tlsIdentL :: (([Char], Domain) -> f ([Char], Domain))
-> StreamConfiguration -> f StreamConfiguration
tlsIdentL = Lens StreamConfiguration ClientParams
L.tlsParamsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens ClientParams ([Char], Domain)
L.clientServerIdentificationL
    updateHost :: a -> (a, b) -> (a, b)
updateHost a
host (a
"", b
_) = (a
host, b
"")
    updateHost a
_ (a, b)
hst = (a, b)
hst
    maybeSetTlsHost :: [Char] -> StreamConfiguration -> StreamConfiguration
maybeSetTlsHost [Char]
host = forall s t a b. Setter s t a b -> (a -> b) -> s -> t
over forall {f :: * -> *}.
Functor f =>
(([Char], Domain) -> f ([Char], Domain))
-> StreamConfiguration -> f StreamConfiguration
tlsIdentL (forall {a} {b}.
(Eq a, IsString a, IsString b) =>
a -> (a, b) -> (a, b)
updateHost [Char]
host)

-- Connects using the specified method. Returns the Handle acquired, if any.
connect :: HostName -> StreamConfiguration -> ExceptT XmppFailure IO
           (Maybe StreamHandle)
connect :: [Char]
-> StreamConfiguration
-> ExceptT XmppFailure IO (Maybe StreamHandle)
connect [Char]
realm StreamConfiguration
config = do
    case StreamConfiguration -> ConnectionDetails
connectionDetails StreamConfiguration
config of
        UseHost [Char]
host PortNumber
port -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
            [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Connecting to configured address."
            Maybe Handle
h <- [Char] -> PortNumber -> IO (Maybe Handle)
resolveAndConnectTcp [Char]
host PortNumber
port
            case Maybe Handle
h of
                Maybe Handle
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                Just Handle
h' -> do
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
h' BufferMode
NoBuffering
                    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
$ Handle -> StreamHandle
handleToStreamHandle Handle
h'
        UseSrv [Char]
host -> do
            Maybe Handle
h <- ResolvConf -> [Char] -> ExceptT XmppFailure IO (Maybe Handle)
connectSrv (StreamConfiguration -> ResolvConf
resolvConf StreamConfiguration
config) [Char]
host
            case Maybe Handle
h of
                Maybe Handle
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                Just Handle
h' -> do
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
h' BufferMode
NoBuffering
                    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
$ Handle -> StreamHandle
handleToStreamHandle Handle
h'
        ConnectionDetails
UseRealm -> do
            Maybe Handle
h <- ResolvConf -> [Char] -> ExceptT XmppFailure IO (Maybe Handle)
connectSrv (StreamConfiguration -> ResolvConf
resolvConf StreamConfiguration
config) [Char]
realm
            case Maybe Handle
h of
                Maybe Handle
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                Just Handle
h' -> do
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
h' BufferMode
NoBuffering
                    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
$ Handle -> StreamHandle
handleToStreamHandle Handle
h'
        UseConnection ExceptT XmppFailure IO StreamHandle
mkC -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT XmppFailure IO StreamHandle
mkC

connectSrv :: ResolvConf -> String -> ExceptT XmppFailure IO (Maybe Handle)
connectSrv :: ResolvConf -> [Char] -> ExceptT XmppFailure IO (Maybe Handle)
connectSrv ResolvConf
config [Char]
host = do
    case Text -> Maybe Text
checkHostName ([Char] -> Text
Text.pack [Char]
host) of
        Just Text
host' -> do
            ResolvSeed
resolvSeed <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ ResolvConf -> IO ResolvSeed
makeResolvSeed ResolvConf
config
            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Performing SRV lookup..."
            Maybe [(Domain, Word16)]
srvRecords <- Text
-> ResolvSeed -> ExceptT XmppFailure IO (Maybe [(Domain, Word16)])
srvLookup Text
host' ResolvSeed
resolvSeed
            case Maybe [(Domain, Word16)]
srvRecords of
                Maybe [(Domain, Word16)]
Nothing -> do
                    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp"
                        [Char]
"No SRV records, using fallback process."
                    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> PortNumber -> IO (Maybe Handle)
resolveAndConnectTcp [Char]
host PortNumber
5222
                Just [(Domain
".", Word16
_)] -> do
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
infoM [Char]
"Pontarius.Xmpp"
                                [Char]
"SRV lookup returned \".\"; service not available"
                    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
TcpConnectionFailure
                Just [(Domain, Word16)]
srvRecords' -> do
                    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp"
                        [Char]
"SRV records found, looking up host."
                    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [([Char], PortNumber)] -> IO (Maybe Handle)
resolvSrvsAndConnectTcp
                           ( forall {f :: * -> *} {a} {b}. Functor f => f a -> (a -> b) -> f b
for [(Domain, Word16)]
srvRecords' forall a b. (a -> b) -> a -> b
$
                              \(Domain
domain, Word16
port) -> ( Domain -> [Char]
BSC8.unpack Domain
domain
                                                 , forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
port))
        Maybe Text
Nothing -> do
                forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp"
                    [Char]
"The hostname could not be validated."
                forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppIllegalTcpDetails
  where for :: f a -> (a -> b) -> f b
for = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

connectHandle :: AddrInfo -> IO Handle
connectHandle :: AddrInfo -> IO Handle
connectHandle AddrInfo
addrInfo = do
    Socket
s <- Family -> SocketType -> ProtocolNumber -> IO Socket
S.socket (AddrInfo -> Family
S.addrFamily AddrInfo
addrInfo) SocketType
S.Stream ProtocolNumber
S.defaultProtocol
    Socket -> SockAddr -> IO ()
S.connect Socket
s (AddrInfo -> SockAddr
S.addrAddress AddrInfo
addrInfo)
    Socket -> IOMode -> IO Handle
S.socketToHandle Socket
s IOMode
ReadWriteMode

-- Connects to a list of addresses and ports. Surpresses any exceptions from
-- connectTcp.
connectTcp :: [AddrInfo] -> IO (Maybe Handle)
connectTcp :: [AddrInfo] -> IO (Maybe Handle)
connectTcp [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
connectTcp (AddrInfo
addrInfo:[AddrInfo]
remainder) = do
    let addr :: [Char]
addr = (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ AddrInfo -> SockAddr
S.addrAddress AddrInfo
addrInfo)
    Either IOException Handle
result <- forall e a. Exception e => IO a -> IO (Either e a)
Ex.try forall a b. (a -> b) -> a -> b
$ (do
        [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"Connecting to " forall a. [a] -> [a] -> [a]
++ [Char]
addr
        AddrInfo -> IO Handle
connectHandle AddrInfo
addrInfo) :: IO (Either Ex.IOException Handle)
    case Either IOException Handle
result of
        Right Handle
handle -> do
            [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"Successfully connected to " forall a. [a] -> [a] -> [a]
++ [Char]
addr
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Handle
handle
        Left IOException
_ -> do
            [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$
                [Char]
"Connection to " forall a. [a] -> [a] -> [a]
++ [Char]
addr forall a. [a] -> [a] -> [a]
++ [Char]
" could not be established."
            [AddrInfo] -> IO (Maybe Handle)
connectTcp [AddrInfo]
remainder

#if MIN_VERSION_dns(1, 0, 0)
fixDnsResult :: Either e a -> Maybe a
fixDnsResult :: forall e a. Either e a -> Maybe a
fixDnsResult = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just
#else
fixDnsResult :: Maybe a -> Maybe a
fixDnsResult = id
#endif

-- Makes an AAAA query to acquire a IPs, and tries to connect to all of them. If
-- a handle can not be acquired this way, an analogous A query is performed.
-- Surpresses all IO exceptions.
resolveAndConnectTcp :: HostName -> PortNumber -> IO (Maybe Handle)
resolveAndConnectTcp :: [Char] -> PortNumber -> IO (Maybe Handle)
resolveAndConnectTcp [Char]
hostName PortNumber
port = do
    [AddrInfo]
ais <- Maybe AddrInfo -> Maybe [Char] -> Maybe [Char] -> IO [AddrInfo]
S.getAddrInfo forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just [Char]
hostName) forall a. Maybe a
Nothing
    [AddrInfo] -> IO (Maybe Handle)
connectTcp forall a b. (a -> b) -> a -> b
$ AddrInfo -> AddrInfo
setPort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AddrInfo]
ais
  where
    setPort :: AddrInfo -> AddrInfo
setPort AddrInfo
ai = AddrInfo
ai {addrAddress :: SockAddr
S.addrAddress = PortNumber -> SockAddr -> SockAddr
setAddressPort PortNumber
port (AddrInfo -> SockAddr
S.addrAddress AddrInfo
ai)}
    setAddressPort :: PortNumber -> SockAddr -> SockAddr
setAddressPort PortNumber
port (S.SockAddrInet PortNumber
_ HostAddress
addr) = PortNumber -> HostAddress -> SockAddr
S.SockAddrInet PortNumber
port HostAddress
addr
    setAddressPort PortNumber
port (S.SockAddrInet6 PortNumber
_ HostAddress
flow HostAddress6
addr HostAddress
scope) =
        PortNumber
-> HostAddress -> HostAddress6 -> HostAddress -> SockAddr
S.SockAddrInet6 PortNumber
port HostAddress
flow HostAddress6
addr HostAddress
scope
    setAddressPort PortNumber
_ SockAddr
addr = SockAddr
addr

-- Tries `resolvAndConnectTcp' for every SRV record, stopping if a handle is
-- acquired.
resolvSrvsAndConnectTcp :: [(HostName, PortNumber)] -> IO (Maybe Handle)
resolvSrvsAndConnectTcp :: [([Char], PortNumber)] -> IO (Maybe Handle)
resolvSrvsAndConnectTcp [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
resolvSrvsAndConnectTcp (([Char]
domain, PortNumber
port):[([Char], PortNumber)]
remaining) = do
    Maybe Handle
result <- [Char] -> PortNumber -> IO (Maybe Handle)
resolveAndConnectTcp [Char]
domain PortNumber
port
    case Maybe Handle
result of
        Just Handle
handle -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Handle
handle
        Maybe Handle
Nothing -> [([Char], PortNumber)] -> IO (Maybe Handle)
resolvSrvsAndConnectTcp [([Char], PortNumber)]
remaining


-- The DNS functions may make error calls. This function catches any such
-- exceptions and rethrows them as IOExceptions.
rethrowErrorCall :: IO a -> IO a
rethrowErrorCall :: forall a. IO a -> IO a
rethrowErrorCall IO a
action = do
    Either ErrorCall a
result <- forall e a. Exception e => IO a -> IO (Either e a)
Ex.try IO a
action
    case Either ErrorCall a
result of
        Right a
result' -> forall (m :: * -> *) a. Monad m => a -> m a
return a
result'
        Left (Ex.ErrorCall [Char]
e) -> forall a. IOException -> IO a
Ex.ioError forall a b. (a -> b) -> a -> b
$ [Char] -> IOException
userError
                                 forall a b. (a -> b) -> a -> b
$ [Char]
"rethrowErrorCall: " forall a. [a] -> [a] -> [a]
++ [Char]
e

-- Provides a list of A(AAA) names and port numbers upon a successful
-- DNS-SRV request, or `Nothing' if the DNS-SRV request failed.
srvLookup :: Text -> ResolvSeed -> ExceptT XmppFailure IO (Maybe [(Domain, Word16)])
srvLookup :: Text
-> ResolvSeed -> ExceptT XmppFailure IO (Maybe [(Domain, Word16)])
srvLookup Text
realm ResolvSeed
resolvSeed = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ do
    Either IOException (Maybe [(Domain, Word16)])
result <- forall e a. Exception e => IO a -> IO (Either e a)
Ex.try forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
rethrowErrorCall forall a b. (a -> b) -> a -> b
$ forall a. ResolvSeed -> (Resolver -> IO a) -> IO a
withResolver ResolvSeed
resolvSeed
              forall a b. (a -> b) -> a -> b
$ \Resolver
resolver -> do
        Either DNSError [(Word16, Word16, Word16, Domain)]
srvResult <- Resolver
-> Domain
-> IO (Either DNSError [(Word16, Word16, Word16, Domain)])
lookupSRV Resolver
resolver forall a b. (a -> b) -> a -> b
$ [Char] -> Domain
BSC8.pack forall a b. (a -> b) -> a -> b
$ [Char]
"_xmpp-client._tcp." forall a. [a] -> [a] -> [a]
++ (Text -> [Char]
Text.unpack Text
realm) forall a. [a] -> [a] -> [a]
++ [Char]
"."
        case forall e a. Either e a -> Maybe a
fixDnsResult Either DNSError [(Word16, Word16, Word16, Domain)]
srvResult of
            Just [] -> do
                [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"No SRV result returned."
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just [(Word16
_, Word16
_, Word16
_, Domain
".")] -> do
                [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"\".\" SRV result returned."
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just []
            Just [(Word16, Word16, Word16, Domain)]
srvResult' -> do
                [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"SRV result: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show [(Word16, Word16, Word16, Domain)]
srvResult')
                -- Get [(Domain, PortNumber)] of SRV request, if any.
                [(Word16, Word16, Word16, Domain)]
orderedSrvResult <- [(Word16, Word16, Word16, Domain)]
-> IO [(Word16, Word16, Word16, Domain)]
orderSrvResult [(Word16, Word16, Word16, Domain)]
srvResult'
                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. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
Prelude.map (\(Word16
_, Word16
_, Word16
port, Domain
domain) -> (Domain
domain, Word16
port)) [(Word16, Word16, Word16, Domain)]
orderedSrvResult
            -- The service is not available at this domain.
            -- Sorts the records based on the priority value.
            Maybe [(Word16, Word16, Word16, Domain)]
Nothing -> do
                [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"No SRV result returned."
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    case Either IOException (Maybe [(Domain, Word16)])
result of
        Right Maybe [(Domain, Word16)]
result' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Maybe [(Domain, Word16)]
result'
        Left IOException
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 forall a b. (a -> b) -> a -> b
$ IOException -> XmppFailure
XmppIOException IOException
e
  where
    -- This function orders the SRV result in accordance with RFC
    -- 2782. It sorts the SRV results in order of priority, and then
    -- uses a random process to order the records with the same
    -- priority based on their weight.
    orderSrvResult :: [(Word16, Word16, Word16, Domain)] -> IO [(Word16, Word16, Word16, Domain)]
    orderSrvResult :: [(Word16, Word16, Word16, Domain)]
-> IO [(Word16, Word16, Word16, Domain)]
orderSrvResult [(Word16, Word16, Word16, Domain)]
srvResult = do
        -- Order the result set by priority.
        let srvResult' :: [(Word16, Word16, Word16, Domain)]
srvResult' = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (\(Word16
priority, Word16
_, Word16
_, Domain
_) -> Word16
priority)) [(Word16, Word16, Word16, Domain)]
srvResult
        -- Group elements in sublists based on their priority. The
        -- type is `[[(Word16, Word16, Word16, Domain)]]'.
        let srvResult'' :: [[(Word16, Word16, Word16, Domain)]]
srvResult'' = forall a. (a -> a -> Bool) -> [a] -> [[a]]
Data.List.groupBy (\(Word16
priority, Word16
_, Word16
_, Domain
_) (Word16
priority', Word16
_, Word16
_, Domain
_) -> Word16
priority forall a. Eq a => a -> a -> Bool
== Word16
priority') [(Word16, Word16, Word16, Domain)]
srvResult' :: [[(Word16, Word16, Word16, Domain)]]
        -- For each sublist, put records with a weight of zero first.
        let srvResult''' :: [[(Word16, Word16, Word16, Domain)]]
srvResult''' = forall a b. (a -> b) -> [a] -> [b]
Data.List.map (\[(Word16, Word16, Word16, Domain)]
sublist -> let ([(Word16, Word16, Word16, Domain)]
a, [(Word16, Word16, Word16, Domain)]
b) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(Word16
_, Word16
weight, Word16
_, Domain
_) -> Word16
weight forall a. Eq a => a -> a -> Bool
== Word16
0) [(Word16, Word16, Word16, Domain)]
sublist in forall (t :: * -> *) a. Foldable t => t [a] -> [a]
Data.List.concat [[(Word16, Word16, Word16, Domain)]
a, [(Word16, Word16, Word16, Domain)]
b]) [[(Word16, Word16, Word16, Domain)]]
srvResult''
        -- Order each sublist.
        [[(Word16, Word16, Word16, Domain)]]
srvResult'''' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [(Word16, Word16, Word16, Domain)]
-> IO [(Word16, Word16, Word16, Domain)]
orderSublist [[(Word16, Word16, Word16, Domain)]]
srvResult'''
        -- Concatinated the results.
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
Data.List.concat [[(Word16, Word16, Word16, Domain)]]
srvResult''''
      where
        orderSublist :: [(Word16, Word16, Word16, Domain)] -> IO [(Word16, Word16, Word16, Domain)]
        orderSublist :: [(Word16, Word16, Word16, Domain)]
-> IO [(Word16, Word16, Word16, Domain)]
orderSublist [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
        orderSublist [(Word16, Word16, Word16, Domain)]
sublist = do
            -- Compute the running sum, as well as the total sum of
            -- the sublist. Add the running sum to the SRV tuples.
            let (Word16
total, [(Word16, Word16, Word16, Domain, Word16)]
sublist') = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
Data.List.mapAccumL (\Word16
total' (Word16
priority, Word16
weight, Word16
port, Domain
domain) -> (Word16
total' forall a. Num a => a -> a -> a
+ Word16
weight, (Word16
priority, Word16
weight, Word16
port, Domain
domain, Word16
total' forall a. Num a => a -> a -> a
+ Word16
weight))) Word16
0 [(Word16, Word16, Word16, Domain)]
sublist
            -- Choose a random number between 0 and the total sum
            -- (inclusive).
            Word16
randomNumber <- forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Word16
0, Word16
total)
            -- Select the first record with its running sum greater
            -- than or equal to the random number.
            let ([(Word16, Word16, Word16, Domain, Word16)]
beginning, ((Word16
priority, Word16
weight, Word16
port, Domain
domain, Word16
_):[(Word16, Word16, Word16, Domain, Word16)]
end)) = forall a. (a -> Bool) -> [a] -> ([a], [a])
Data.List.break (\(Word16
_, Word16
_, Word16
_, Domain
_, Word16
running) -> Word16
randomNumber forall a. Ord a => a -> a -> Bool
<= Word16
running) [(Word16, Word16, Word16, Domain, Word16)]
sublist'
            -- Remove the running total number from the remaining
            -- elements.
            let sublist'' :: [(Word16, Word16, Word16, Domain)]
sublist'' = forall a b. (a -> b) -> [a] -> [b]
Data.List.map (\(Word16
priority', Word16
weight', Word16
port', Domain
domain', Word16
_) -> (Word16
priority', Word16
weight', Word16
port', Domain
domain')) (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
Data.List.concat [[(Word16, Word16, Word16, Domain, Word16)]
beginning, [(Word16, Word16, Word16, Domain, Word16)]
end])
            -- Repeat the ordering procedure on the remaining
            -- elements.
            [(Word16, Word16, Word16, Domain)]
rest <- [(Word16, Word16, Word16, Domain)]
-> IO [(Word16, Word16, Word16, Domain)]
orderSublist [(Word16, Word16, Word16, Domain)]
sublist''
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ((Word16
priority, Word16
weight, Word16
port, Domain
domain)forall a. a -> [a] -> [a]
:[(Word16, Word16, Word16, Domain)]
rest)

-- | Close the connection and updates the XmppConMonad Stream state. Does
-- not send the stream end tag.
killStream :: Stream -> IO (Either XmppFailure ())
killStream :: Stream -> IO (Either XmppFailure ())
killStream = forall a. StateT StreamState IO a -> Stream -> IO a
withStream forall a b. (a -> b) -> a -> b
$ do
    IO ()
cc <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StreamHandle -> IO ()
streamClose forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamHandle
streamHandle)
    Either XmppFailure ()
err <- forall (m :: * -> *) a.
MonadIO m =>
[Char] -> IO a -> m (Either XmppFailure a)
wrapIOException [Char]
"killStream" IO ()
cc
    -- (ExL.try cc :: IO (Either ExL.SomeException ()))
    forall s (m :: * -> *). MonadState s m => s -> m ()
put StreamState
xmppNoStream{ streamConnectionState :: ConnectionState
streamConnectionState = ConnectionState
Finished }
    forall (m :: * -> *) a. Monad m => a -> m a
return Either XmppFailure ()
err

-- Sends an IQ request and waits for the response. If the response ID does not
-- match the outgoing ID, an error is thrown.
pushIQ :: Text
       -> Maybe Jid
       -> IQRequestType
       -> Maybe LangTag
       -> Element
       -> Stream
       -> IO (Either XmppFailure (Either IQError IQResult))
pushIQ :: Text
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> Stream
-> IO (Either XmppFailure (Either IQError IQResult))
pushIQ Text
iqID Maybe Jid
to IQRequestType
tp Maybe LangTag
lang Element
body Stream
stream = 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
$ Stanza -> Stream -> IO (Either XmppFailure ())
pushStanza
        (IQRequest -> Stanza
IQRequestS forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Jid
-> Maybe Jid
-> Maybe LangTag
-> IQRequestType
-> Element
-> [(Name, Text)]
-> IQRequest
IQRequest Text
iqID forall a. Maybe a
Nothing Maybe Jid
to Maybe LangTag
lang IQRequestType
tp Element
body []) Stream
stream
    Either XmppFailure Stanza
res <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Stream -> IO (Either XmppFailure Stanza)
pullStanza Stream
stream
    case Either XmppFailure Stanza
res of
        Left XmppFailure
e -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
e
        Right (IQErrorS IQError
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 IQError
e
        Right (IQResultS IQResult
r) -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
                (Text
iqID forall a. Eq a => a -> a -> Bool
== IQResult -> Text
iqResultID IQResult
r) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"pushIQ: ID mismatch (" forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show Text
iqID) forall a. [a] -> [a] -> [a]
++ [Char]
" /= " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ IQResult -> Text
iqResultID IQResult
r) forall a. [a] -> [a] -> [a]
++ [Char]
")."
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
ExL.throwIO XmppFailure
XmppOtherFailure
                -- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++
                -- " /= " ++ show (iqResultID 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 IQResult
r
        Either XmppFailure Stanza
_ -> do
                 forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"pushIQ: Unexpected stanza type."
                 forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppOtherFailure

debugConduit :: (Show o, MonadIO m) => ConduitM o o m b
debugConduit :: forall o (m :: * -> *) b. (Show o, MonadIO m) => ConduitM o o m b
debugConduit = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
    Maybe o
s' <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
await
    case Maybe o
s' of
        Just o
s ->  do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"debugConduit: In: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show o
s)
            forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield o
s
        Maybe o
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

elements :: MonadError XmppFailure m => ConduitT Event Element m ()
elements :: forall (m :: * -> *).
MonadError XmppFailure m =>
ConduitT Event Element m ()
elements = do
        Maybe Event
x <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
await
        case Maybe Event
x of
            Just (EventBeginElement Name
n [(Name, [Content])]
as) -> do
                                                 forall {m :: * -> *} {o}.
MonadError XmppFailure m =>
Name -> [(Name, [Content])] -> ConduitT Event o m Element
goE Name
n [(Name, [Content])]
as forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield
                                                 forall (m :: * -> *).
MonadError XmppFailure m =>
ConduitT Event Element m ()
elements
            -- This might be an XML error if the end element tag is not
            -- "</stream>". TODO: We might want to check this at a later time
            Just EventEndElement{} -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
StreamEndFailure
            -- This happens when the connection to the server is closed without
            -- the stream being properly terminated
            Just Event
EventEndDocument -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
StreamEndFailure
            Just (EventContent (ContentText Text
ct)) | (Char -> Bool) -> Text -> Bool
Text.all Char -> Bool
isSpace Text
ct ->
                forall (m :: * -> *).
MonadError XmppFailure m =>
ConduitT Event Element m ()
elements
            Maybe Event
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Maybe Event
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ [Char] -> XmppFailure
XmppInvalidXml forall a b. (a -> b) -> a -> b
$ [Char]
"not an element: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Maybe Event
x
  where
    many' :: m (Either a a) -> m (a, [a])
many' m (Either a a)
f =
        forall {c}. ([a] -> c) -> m (a, c)
go forall a. a -> a
id
      where
        go :: ([a] -> c) -> m (a, c)
go [a] -> c
front = do
            Either a a
x <- m (Either a a)
f
            case Either a a
x of
                Left a
l -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (a
l, [a] -> c
front [])
                Right a
r -> ([a] -> c) -> m (a, c)
go ([a] -> c
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) a
r)
    goE :: Name -> [(Name, [Content])] -> ConduitT Event o m Element
goE Name
n [(Name, [Content])]
as = do
        (Maybe Event
y, [Node]
ns) <- forall {m :: * -> *} {a} {a}.
Monad m =>
m (Either a a) -> m (a, [a])
many' ConduitT Event o m (Either (Maybe Event) Node)
goN
        if Maybe Event
y forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (Name -> Event
EventEndElement Name
n)
            then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> [(Name, [Content])] -> [Node] -> Element
Element Name
n (forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> a
id forall {t} {a} {t} {b}. (t -> a) -> (t -> b) -> (t, t) -> (a, b)
>< [Content] -> [Content]
compressContents) [(Name, [Content])]
as)
                                    ([Node] -> [Node]
compressNodes [Node]
ns)
            else forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> XmppFailure
XmppInvalidXml forall a b. (a -> b) -> a -> b
$ [Char]
"Missing close tag: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Name
n
    goN :: ConduitT Event o m (Either (Maybe Event) Node)
goN = do
        Maybe Event
x <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
await
        case Maybe Event
x of
            Just (EventBeginElement Name
n [(Name, [Content])]
as) -> (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Node
NodeElement) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> [(Name, [Content])] -> ConduitT Event o m Element
goE Name
n [(Name, [Content])]
as
            Just (EventInstruction Instruction
i) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Instruction -> Node
NodeInstruction Instruction
i
            Just (EventContent Content
c) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Content -> Node
NodeContent Content
c
            Just (EventComment Text
t) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Node
NodeComment Text
t
            Just (EventCDATA Text
t) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Content -> Node
NodeContent forall a b. (a -> b) -> a -> b
$ Text -> Content
ContentText Text
t
            Maybe Event
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Maybe Event
x

    compressNodes :: [Node] -> [Node]
    compressNodes :: [Node] -> [Node]
compressNodes [] = []
    compressNodes [Node
x] = [Node
x]
    compressNodes (NodeContent (ContentText Text
x) : NodeContent (ContentText Text
y) : [Node]
z) =
        [Node] -> [Node]
compressNodes forall a b. (a -> b) -> a -> b
$ Content -> Node
NodeContent (Text -> Content
ContentText forall a b. (a -> b) -> a -> b
$ Text
x Text -> Text -> Text
`Text.append` Text
y) forall a. a -> [a] -> [a]
: [Node]
z
    compressNodes (Node
x:[Node]
xs) = Node
x forall a. a -> [a] -> [a]
: [Node] -> [Node]
compressNodes [Node]
xs

    compressContents :: [Content] -> [Content]
    compressContents :: [Content] -> [Content]
compressContents [Content]
cs = [Text -> Content
ContentText forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.concat (forall a b. (a -> b) -> [a] -> [b]
map Content -> Text
unwrap [Content]
cs)]
        where unwrap :: Content -> Text
unwrap (ContentText Text
t) = Text
t
              unwrap (ContentEntity Text
t) = Text
t

    >< :: (t -> a) -> (t -> b) -> (t, t) -> (a, b)
(><) t -> a
f t -> b
g (t
x, t
y) = (t -> a
f t
x, t -> b
g t
y)

withStream :: StateT StreamState IO a -> Stream -> IO a
withStream :: forall a. StateT StreamState IO a -> Stream -> IO a
withStream StateT StreamState IO a
action (Stream TMVar StreamState
stream) = 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 StreamState
stream )
                                         (forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TMVar a -> a -> STM ()
putTMVar TMVar StreamState
stream)
                                         (\StreamState
s -> do
                                               (a
r, StreamState
s') <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT StreamState IO a
action StreamState
s
                                               forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar StreamState
stream StreamState
s'
                                               forall (m :: * -> *) a. Monad m => a -> m a
return a
r
                                         )

-- nonblocking version. Changes to the connection are ignored!
withStream' :: StateT StreamState IO a -> Stream -> IO a
withStream' :: forall a. StateT StreamState IO a -> Stream -> IO a
withStream' StateT StreamState IO a
action (Stream TMVar StreamState
stream) = do
    StreamState
stream_ <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> STM a
readTMVar TMVar StreamState
stream
    (a
r, StreamState
_) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT StreamState IO a
action StreamState
stream_
    forall (m :: * -> *) a. Monad m => a -> m a
return a
r


mkStream :: StreamState -> IO Stream
mkStream :: StreamState -> IO Stream
mkStream StreamState
con = TMVar StreamState -> Stream
Stream forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. STM a -> IO a
atomically (forall a. a -> STM (TMVar a)
newTMVar StreamState
con)

-- "Borrowed" from base-4.4 for compatibility with GHC 7.0.1.
tryIOError :: IO a -> IO (Either IOError a)
tryIOError :: forall a. IO a -> IO (Either IOException a)
tryIOError IO a
f = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Ex.catch (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
f) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)