{-# 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_ :: String -> Maybe a
readMaybe_ String
string = case ReadS a
forall a. Read a => ReadS a
reads String
string of
                        [(a
a, String
"")] -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
                        [(a, String)]
_ -> Maybe a
forall a. Maybe a
Nothing

-- import Text.XML.Stream.Elements

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

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

-- Unpickles and returns a stream element.
streamUnpickleElem :: PU [Node] a
                   -> Element
                   -> StreamSink a
streamUnpickleElem :: PU [Node] a -> Element -> StreamSink a
streamUnpickleElem PU [Node] a
p Element
x = do
    case PU [Node] a -> Element -> Either UnpickleError a
forall a. PU [Node] a -> Element -> Either UnpickleError a
unpickleElem PU [Node] a
p Element
x of
        Left UnpickleError
l -> do
            IO () -> ConduitT Event Void (ExceptT XmppFailure IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitT Event Void (ExceptT XmppFailure IO) ())
-> IO () -> ConduitT Event Void (ExceptT XmppFailure IO) ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
warningM String
"Pontarius.Xmpp" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"streamUnpickleElem: Unpickle error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnpickleError -> String
ppUnpickleError UnpickleError
l
            XmppFailure -> StreamSink a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (XmppFailure -> StreamSink a) -> XmppFailure -> StreamSink a
forall a b. (a -> b) -> a -> b
$ XmppFailure
XmppOtherFailure
        Right a
r -> a -> StreamSink a
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 :: ConduitM Event a m ()
throwOutJunk = do
    Maybe Event
next <- ConduitT Event a m (Maybe Event)
forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.peek
    case Maybe Event
next of
        Maybe Event
Nothing -> () -> ConduitM Event a m ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- This will only happen if the stream is closed.
        Just (EventBeginElement Name
_ [(Name, [Content])]
_) -> () -> ConduitM Event a m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Maybe Event
_ -> Int -> ConduitM Event a m ()
forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
CL.drop Int
1 ConduitM Event a m ()
-> ConduitM Event a m () -> ConduitM Event a m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConduitM Event a m ()
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
    ConduitT Event Void (ExceptT XmppFailure IO) ()
forall (m :: * -> *) a. Monad m => ConduitM Event a m ()
throwOutJunk
    Maybe Event
hd <- ConduitT Event Void (ExceptT XmppFailure IO) (Maybe Event)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await
    case Maybe Event
hd of
        Just (EventBeginElement Name
name [(Name, [Content])]
attrs) -> Element -> StreamSink Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> StreamSink Element) -> Element -> StreamSink Element
forall a b. (a -> b) -> a -> b
$ Name -> [(Name, [Content])] -> [Node] -> Element
Element Name
name [(Name, [Content])]
attrs []
        Maybe Event
_ -> do
            IO () -> ConduitT Event Void (ExceptT XmppFailure IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitT Event Void (ExceptT XmppFailure IO) ())
-> IO () -> ConduitT Event Void (ExceptT XmppFailure IO) ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
warningM String
"Pontarius.Xmpp" String
"openElementFromEvents: Stream ended."
            XmppFailure -> StreamSink Element
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 = ExceptT XmppFailure (StateT StreamState IO) ()
-> StateT StreamState IO (Either XmppFailure ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XmppFailure (StateT StreamState IO) ()
 -> StateT StreamState IO (Either XmppFailure ()))
-> ExceptT XmppFailure (StateT StreamState IO) ()
-> StateT StreamState IO (Either XmppFailure ())
forall a b. (a -> b) -> a -> b
$ do
    StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT StreamState IO ()
 -> ExceptT XmppFailure (StateT StreamState IO) ())
-> StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ IO () -> StateT StreamState IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT StreamState IO ())
-> IO () -> StateT StreamState IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
debugM String
"Pontarius.Xmpp" String
"Starting stream..."
    StreamState
st <- StateT StreamState IO StreamState
-> ExceptT XmppFailure (StateT StreamState IO) StreamState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT StreamState IO StreamState
 -> ExceptT XmppFailure (StateT StreamState IO) StreamState)
-> StateT StreamState IO StreamState
-> ExceptT XmppFailure (StateT StreamState IO) StreamState
forall a b. (a -> b) -> a -> b
$ StateT StreamState IO StreamState
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 (StreamConfiguration -> Maybe (Jid, Bool))
-> StreamConfiguration -> Maybe (Jid, Bool)
forall a b. (a -> b) -> a -> b
$ StreamState -> StreamConfiguration
streamConfiguration StreamState
st) of
          (ConnectionState
Plain    , (Just (Jid
j, Bool
True)))  -> Jid -> Maybe Jid
forall a. a -> Maybe a
Just Jid
j
          (ConnectionState
Plain    , Maybe (Jid, Bool)
_               )  -> Maybe Jid
forall a. Maybe a
Nothing
          (ConnectionState
Secured  , (Just (Jid
j, Bool
_   )))  -> Jid -> Maybe Jid
forall a. a -> Maybe a
Just Jid
j
          (ConnectionState
Secured  , Maybe (Jid, Bool)
Nothing         )  -> Maybe Jid
forall a. Maybe a
Nothing
          (ConnectionState
Closed   , Maybe (Jid, Bool)
_               )  -> Maybe Jid
forall a. Maybe a
Nothing
          (ConnectionState
Finished , Maybe (Jid, Bool)
_               )  -> Maybe Jid
forall a. Maybe a
Nothing
    case StreamState -> Maybe Text
streamAddress StreamState
st of
        Maybe Text
Nothing -> do
            StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT StreamState IO ()
 -> ExceptT XmppFailure (StateT StreamState IO) ())
-> StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ IO () -> StateT StreamState IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT StreamState IO ())
-> IO () -> StateT StreamState IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM String
"Pontarius.Xmpp" String
"Server sent no hostname."
            XmppFailure -> ExceptT XmppFailure (StateT StreamState IO) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppOtherFailure
        Just Text
address -> do
            StateT StreamState IO (Either XmppFailure ())
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (StateT StreamState IO (Either XmppFailure ())
 -> ExceptT XmppFailure (StateT StreamState IO) ())
-> StateT StreamState IO (Either XmppFailure ())
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ StateT StreamState IO (Either XmppFailure ())
pushXmlDecl
            StateT StreamState IO (Either XmppFailure ())
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (StateT StreamState IO (Either XmppFailure ())
 -> ExceptT XmppFailure (StateT StreamState IO) ())
-> (Element -> StateT StreamState IO (Either XmppFailure ()))
-> Element
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> StateT StreamState IO (Either XmppFailure ())
pushOpenElement (Element -> StateT StreamState IO (Either XmppFailure ()))
-> (Element -> Element)
-> Element
-> StateT StreamState IO (Either XmppFailure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Element
streamNSHack (Element -> ExceptT XmppFailure (StateT StreamState IO) ())
-> Element -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$
                PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
-> (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
-> Element
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
                                    , Jid -> Maybe Jid
forall a. a -> Maybe a
Just (Maybe NonemptyText -> NonemptyText -> Maybe NonemptyText -> Jid
Jid Maybe NonemptyText
forall a. Maybe a
Nothing (Text -> NonemptyText
Nonempty Text
address) Maybe NonemptyText
forall a. Maybe a
Nothing)
                                    , Maybe Text
forall a. Maybe a
Nothing
                                    , StreamConfiguration -> Maybe LangTag
preferredLang (StreamConfiguration -> Maybe LangTag)
-> StreamConfiguration -> Maybe LangTag
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 <- StateT
  StreamState
  IO
  (Either
     XmppFailure
     (Either
        Element
        (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
         StreamFeatures)))
-> ExceptT
     XmppFailure
     (StateT StreamState IO)
     (Either
        Element
        (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
         StreamFeatures))
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (StateT
   StreamState
   IO
   (Either
      XmppFailure
      (Either
         Element
         (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
          StreamFeatures)))
 -> ExceptT
      XmppFailure
      (StateT StreamState IO)
      (Either
         Element
         (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
          StreamFeatures)))
-> StateT
     StreamState
     IO
     (Either
        XmppFailure
        (Either
           Element
           (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
            StreamFeatures)))
-> ExceptT
     XmppFailure
     (StateT StreamState IO)
     (Either
        Element
        (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
         StreamFeatures))
forall a b. (a -> b) -> a -> b
$ ConduitT
  Event
  Void
  (ExceptT XmppFailure IO)
  (Either
     Element
     (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
      StreamFeatures))
-> StateT
     StreamState
     IO
     (Either
        XmppFailure
        (Either
           Element
           (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
            StreamFeatures)))
forall b.
ConduitT Event Void (ExceptT XmppFailure IO) b
-> StateT StreamState IO (Either XmppFailure b)
runEventsSink (ConduitT
   Event
   Void
   (ExceptT XmppFailure IO)
   (Either
      Element
      (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
       StreamFeatures))
 -> StateT
      StreamState
      IO
      (Either
         XmppFailure
         (Either
            Element
            (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
             StreamFeatures))))
-> ConduitT
     Event
     Void
     (ExceptT XmppFailure IO)
     (Either
        Element
        (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
         StreamFeatures))
-> StateT
     StreamState
     IO
     (Either
        XmppFailure
        (Either
           Element
           (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
            StreamFeatures)))
forall a b. (a -> b) -> a -> b
$ Maybe Jid
-> ConduitT
     Event
     Void
     (ExceptT XmppFailure IO)
     (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 Maybe Version -> Maybe Version -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Version
forall a. Maybe a
Nothing -> StreamErrorCondition
-> Maybe Element
-> String
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError
                                            StreamErrorCondition
StreamUnsupportedVersion Maybe Element
forall a. Maybe a
Nothing
                                            String
"Unspecified version"
        | let v :: Maybe Version
v = Text -> Maybe Version
versionFromText Text
ver
          in Maybe Version -> Bool
forall a. Maybe a -> Bool
isJust Maybe Version
v Bool -> Bool -> Bool
&& Version -> Integer
majorVersion (Maybe Version -> Version
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Version
v) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
2 ->
            StreamErrorCondition
-> Maybe Element
-> String
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
StreamUnsupportedVersion Maybe Element
forall a. Maybe a
Nothing
              String
"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?
        | Maybe Jid -> Bool
forall a. Maybe a -> Bool
isJust Maybe Jid
from Bool -> Bool -> Bool
&& (Maybe Jid
from Maybe Jid -> Maybe Jid -> Bool
forall a. Eq a => a -> a -> Bool
/= Jid -> Maybe Jid
forall a. a -> Maybe a
Just (Maybe NonemptyText -> NonemptyText -> Maybe NonemptyText -> Jid
Jid Maybe NonemptyText
forall a. Maybe a
Nothing (Text -> NonemptyText
Nonempty (Text -> NonemptyText)
-> (Maybe Text -> Text) -> Maybe Text -> NonemptyText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Text -> NonemptyText) -> Maybe Text -> NonemptyText
forall a b. (a -> b) -> a -> b
$ StreamState -> Maybe Text
streamAddress StreamState
st) Maybe NonemptyText
forall a. Maybe a
Nothing)) ->
            StreamErrorCondition
-> Maybe Element
-> String
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
StreamInvalidFrom Maybe Element
forall a. Maybe a
Nothing
                String
"Stream from is invalid"
        | Maybe Jid
to Maybe Jid -> Maybe Jid -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Jid
expectedTo ->
            StreamErrorCondition
-> Maybe Element
-> String
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
StreamUndefinedCondition (Element -> Maybe Element
forall a. a -> Maybe a
Just (Element -> Maybe Element) -> Element -> Maybe Element
forall a b. (a -> b) -> a -> b
$ Name -> [(Name, [Content])] -> [Node] -> Element
Element Name
"invalid-to" [] [])
                String
"Stream to invalid"-- TODO: Suitable?
        | Bool
otherwise -> do
            -- HACK: (ignore section 4.7.4. of RFC 6120), see above
            Bool
-> ExceptT XmppFailure (StateT StreamState IO) ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe LangTag -> Bool
forall a. Maybe a -> Bool
isJust Maybe LangTag
lt) (ExceptT XmppFailure (StateT StreamState IO) ()
 -> ExceptT XmppFailure (StateT StreamState IO) ())
-> ExceptT XmppFailure (StateT StreamState IO) ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ IO () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XmppFailure (StateT StreamState IO) ())
-> IO () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
warningM String
"Pontariusm.Xmpp"
                String
"Stream has no language tag"
            (StreamState -> StreamState)
-> ExceptT XmppFailure (StateT StreamState IO) ()
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
                         } )
            () -> ExceptT XmppFailure (StateT StreamState IO) ()
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 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"stream") ->
            StreamErrorCondition
-> Maybe Element
-> String
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
StreamInvalidXml Maybe Element
forall a. Maybe a
Nothing
               String
"Root element is not stream"
        | (Name -> Maybe Text
nameNamespace Name
name Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"http://etherx.jabber.org/streams") ->
            StreamErrorCondition
-> Maybe Element
-> String
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
StreamInvalidNamespace Maybe Element
forall a. Maybe a
Nothing
               String
"Wrong root element name space"
        | (Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Text -> Bool) -> Maybe Text -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Text
namePrefix Name
name) Bool -> Bool -> Bool
&& (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust (Name -> Maybe Text
namePrefix Name
name) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"stream") ->
            StreamErrorCondition
-> Maybe Element
-> String
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
StreamBadNamespacePrefix Maybe Element
forall a. Maybe a
Nothing
                String
"Root name prefix set and not stream"
        | Bool
otherwise -> StateT StreamState IO (Either XmppFailure ())
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (StateT StreamState IO (Either XmppFailure ())
 -> ExceptT XmppFailure (StateT StreamState IO) ())
-> StateT StreamState IO (Either XmppFailure ())
-> ExceptT XmppFailure (StateT StreamState IO) ()
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
                                           [(Name, [Content])] -> [(Name, [Content])] -> [(Name, [Content])]
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
-> String
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
sec Maybe Element
el String
msg = do
        ExceptT XmppFailure (StateT StreamState IO) (Either XmppFailure ())
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   XmppFailure (StateT StreamState IO) (Either XmppFailure ())
 -> ExceptT XmppFailure (StateT StreamState IO) ())
-> (StreamErrorInfo
    -> ExceptT
         XmppFailure (StateT StreamState IO) (Either XmppFailure ()))
-> StreamErrorInfo
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT StreamState IO (Either XmppFailure ())
-> ExceptT
     XmppFailure (StateT StreamState IO) (Either XmppFailure ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT StreamState IO (Either XmppFailure ())
 -> ExceptT
      XmppFailure (StateT StreamState IO) (Either XmppFailure ()))
-> (StreamErrorInfo
    -> StateT StreamState IO (Either XmppFailure ()))
-> StreamErrorInfo
-> ExceptT
     XmppFailure (StateT StreamState IO) (Either XmppFailure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> StateT StreamState IO (Either XmppFailure ())
pushElement (Element -> StateT StreamState IO (Either XmppFailure ()))
-> (StreamErrorInfo -> Element)
-> StreamErrorInfo
-> StateT StreamState IO (Either XmppFailure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PU [Node] StreamErrorInfo -> StreamErrorInfo -> Element
forall a. PU [Node] a -> a -> Element
pickleElem PU [Node] StreamErrorInfo
xpStreamError
            (StreamErrorInfo -> ExceptT XmppFailure (StateT StreamState IO) ())
-> StreamErrorInfo
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ StreamErrorCondition
-> Maybe (Maybe LangTag, NonemptyText)
-> Maybe Element
-> StreamErrorInfo
StreamErrorInfo StreamErrorCondition
sec Maybe (Maybe LangTag, NonemptyText)
forall a. Maybe a
Nothing Maybe Element
el
        ExceptT XmppFailure (StateT StreamState IO) ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT XmppFailure (StateT StreamState IO) ()
 -> ExceptT XmppFailure (StateT StreamState IO) ())
-> (StateT StreamState IO ()
    -> ExceptT XmppFailure (StateT StreamState IO) ())
-> StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT StreamState IO ()
 -> ExceptT XmppFailure (StateT StreamState IO) ())
-> StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ StateT StreamState IO ()
closeStreams'
        IO () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XmppFailure (StateT StreamState IO) ())
-> IO () -> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM String
"Pontarius.Xmpp" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"closeStreamWithError: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
        XmppFailure -> ExceptT XmppFailure (StateT StreamState IO) ()
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'  = Name -> [(Name, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
"to"      [(Name, Text)]
children
            ver' :: Maybe Text
ver' = Name -> [(Name, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
"version" [(Name, Text)]
children
            xl :: Maybe Text
xl   = Name -> [(Name, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
xmlLang   [(Name, Text)]
children
          in case () of () | Maybe Jid -> Maybe (Maybe Jid)
forall a. a -> Maybe a
Just Maybe Jid
forall a. Maybe a
Nothing Maybe (Maybe Jid) -> Maybe (Maybe Jid) -> Bool
forall a. Eq a => a -> a -> Bool
== (Text -> Maybe Jid) -> Maybe Text -> Maybe (Maybe Jid)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Maybe Jid
jidFromText Maybe Text
to' ->
                               ExceptT XmppFailure (StateT StreamState IO) ()
-> StateT StreamState IO (Either XmppFailure ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XmppFailure (StateT StreamState IO) ()
 -> StateT StreamState IO (Either XmppFailure ()))
-> ExceptT XmppFailure (StateT StreamState IO) ()
-> StateT StreamState IO (Either XmppFailure ())
forall a b. (a -> b) -> a -> b
$ StreamErrorCondition
-> Maybe Element
-> String
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError
                                   StreamErrorCondition
StreamBadNamespacePrefix Maybe Element
forall a. Maybe a
Nothing
                                   String
"stream to not a valid JID"
                           | Maybe Text
forall a. Maybe a
Nothing Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
ver' ->
                               ExceptT XmppFailure (StateT StreamState IO) ()
-> StateT StreamState IO (Either XmppFailure ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XmppFailure (StateT StreamState IO) ()
 -> StateT StreamState IO (Either XmppFailure ()))
-> ExceptT XmppFailure (StateT StreamState IO) ()
-> StateT StreamState IO (Either XmppFailure ())
forall a b. (a -> b) -> a -> b
$ StreamErrorCondition
-> Maybe Element
-> String
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError
                                   StreamErrorCondition
StreamUnsupportedVersion Maybe Element
forall a. Maybe a
Nothing
                                   String
"stream no version"
                           | Maybe LangTag -> Maybe (Maybe LangTag)
forall a. a -> Maybe a
Just (Maybe LangTag
forall a. Maybe a
Nothing :: Maybe LangTag) Maybe (Maybe LangTag) -> Maybe (Maybe LangTag) -> Bool
forall a. Eq a => a -> a -> Bool
== (Text -> Maybe LangTag
forall a. Read a => Text -> Maybe a
safeRead (Text -> Maybe LangTag) -> Maybe Text -> Maybe (Maybe LangTag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
xl) ->
                               ExceptT XmppFailure (StateT StreamState IO) ()
-> StateT StreamState IO (Either XmppFailure ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XmppFailure (StateT StreamState IO) ()
 -> StateT StreamState IO (Either XmppFailure ()))
-> ExceptT XmppFailure (StateT StreamState IO) ()
-> StateT StreamState IO (Either XmppFailure ())
forall a b. (a -> b) -> a -> b
$ StreamErrorCondition
-> Maybe Element
-> String
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError
                                   StreamErrorCondition
StreamInvalidXml Maybe Element
forall a. Maybe a
Nothing
                                   String
"stream no language tag"
                           | Bool
otherwise ->
                               ExceptT XmppFailure (StateT StreamState IO) ()
-> StateT StreamState IO (Either XmppFailure ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XmppFailure (StateT StreamState IO) ()
 -> StateT StreamState IO (Either XmppFailure ()))
-> ExceptT XmppFailure (StateT StreamState IO) ()
-> StateT StreamState IO (Either XmppFailure ())
forall a b. (a -> b) -> a -> b
$ StreamErrorCondition
-> Maybe Element
-> String
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError
                                   StreamErrorCondition
StreamBadFormat Maybe Element
forall a. Maybe a
Nothing
                                   String
""
    safeRead :: Text -> Maybe a
safeRead Text
x = case ReadS a
forall a. Read a => ReadS a
reads ReadS a -> ReadS a
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
x of
        [] -> Maybe a
forall a. Maybe a
Nothing
        ((a
y,String
_):[(a, String)]
_) -> a -> Maybe a
forall a. a -> Maybe a
Just a
y

flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)]
flattenAttrs :: [(Name, [Content])] -> [(Name, Text)]
flattenAttrs [(Name, [Content])]
attrs = ((Name, [Content]) -> (Name, Text))
-> [(Name, [Content])] -> [(Name, Text)]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map (\(Name
name, [Content]
cont) ->
                             ( Name
name
                             , [Text] -> Text
Text.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Content -> Text) -> [Content] -> [Text]
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
    IO () -> StateT StreamState IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT StreamState IO ())
-> IO () -> StateT StreamState IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
debugM String
"Pontarius.Xmpp" String
"Restarting stream..."
    StreamHandle
raw <- (StreamState -> StreamHandle) -> StateT StreamState IO StreamHandle
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StreamState -> StreamHandle
streamHandle
    let newSource :: ConduitT a Event m ()
newSource = StreamHandle -> ConduitM a ByteString m ()
forall (m :: * -> *) i.
(MonadIO m, MonadError XmppFailure m) =>
StreamHandle -> ConduitM i ByteString m ()
sourceStreamHandle StreamHandle
raw ConduitM a ByteString m ()
-> ConduitT ByteString Event m () -> ConduitT a Event m ()
forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
$= ParseSettings -> ConduitT ByteString Event m ()
forall (m :: * -> *).
MonadThrow m =>
ParseSettings -> ConduitT ByteString Event m ()
XP.parseBytes ParseSettings
forall a. Default a => a
def
    ConduitM () Event (ExceptT XmppFailure IO) ()
buffered <- IO (ConduitM () Event (ExceptT XmppFailure IO) ())
-> StateT
     StreamState IO (ConduitM () Event (ExceptT XmppFailure IO) ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ConduitM () Event (ExceptT XmppFailure IO) ())
 -> StateT
      StreamState IO (ConduitM () Event (ExceptT XmppFailure IO) ()))
-> (ConduitM () Event (ExceptT XmppFailure IO) ()
    -> IO (ConduitM () Event (ExceptT XmppFailure IO) ()))
-> ConduitM () Event (ExceptT XmppFailure IO) ()
-> StateT
     StreamState IO (ConduitM () Event (ExceptT XmppFailure IO) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConduitM () Event (ExceptT XmppFailure IO) ()
-> IO (ConduitM () Event (ExceptT XmppFailure IO) ())
forall o i.
ConduitT () o (ExceptT XmppFailure IO) ()
-> IO (ConduitM i o (ExceptT XmppFailure IO) ())
bufferSrc (ConduitM () Event (ExceptT XmppFailure IO) ()
 -> StateT
      StreamState IO (ConduitM () Event (ExceptT XmppFailure IO) ()))
-> ConduitM () Event (ExceptT XmppFailure IO) ()
-> StateT
     StreamState IO (ConduitM () Event (ExceptT XmppFailure IO) ())
forall a b. (a -> b) -> a -> b
$ ConduitM () Event (ExceptT XmppFailure IO) ()
forall (m :: * -> *) a.
(MonadIO m, MonadError XmppFailure m, MonadThrow m) =>
ConduitT a Event m ()
newSource
    (StreamState -> StreamState) -> StateT StreamState IO ()
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 :: StreamHandle -> ConduitM i ByteString m ()
sourceStreamHandleRaw StreamHandle
s = ConduitM i ByteString m () -> ConduitM i ByteString m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (ConduitM i ByteString m () -> ConduitM i ByteString m ())
-> ((Int -> IO (Either XmppFailure ByteString))
    -> ConduitM i ByteString m ())
-> (Int -> IO (Either XmppFailure ByteString))
-> ConduitM i ByteString m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> IO (Either XmppFailure ByteString))
-> ConduitM i ByteString m ()
forall (m :: * -> *) t e o i.
(MonadIO m, Num t, MonadError e m) =>
(t -> IO (Either e o)) -> ConduitT i o m ()
read ((Int -> IO (Either XmppFailure ByteString))
 -> ConduitM i ByteString m ())
-> (Int -> IO (Either XmppFailure ByteString))
-> ConduitM i ByteString m ()
forall a b. (a -> b) -> a -> b
$ StreamHandle -> Int -> IO (Either XmppFailure ByteString)
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' <- IO (Either e o) -> ConduitT i o m (Either e o)
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 -> e -> ConduitT i o m o
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
            Right o
r -> o -> ConduitT i o m o
forall (m :: * -> *) a. Monad m => a -> m a
return o
r
        o -> ConduitT i o m ()
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 :: StreamHandle -> ConduitM i ByteString m ()
sourceStreamHandle StreamHandle
sh = StreamHandle -> ConduitM i ByteString m ()
forall (m :: * -> *) i.
(MonadIO m, MonadError XmppFailure m) =>
StreamHandle -> ConduitM i ByteString m ()
sourceStreamHandleRaw StreamHandle
sh ConduitM i ByteString m ()
-> ConduitT ByteString ByteString m ()
-> ConduitM i ByteString m ()
forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
$= ConduitT ByteString ByteString m ()
forall (m :: * -> *).
MonadIO m =>
ConduitM ByteString ByteString m ()
logInput

logInput :: MonadIO m => ConduitM ByteString ByteString m ()
logInput :: ConduitM ByteString ByteString m ()
logInput = Maybe (ByteString -> Decoding)
-> ConduitM ByteString ByteString m ()
forall (m :: * -> *).
MonadIO m =>
Maybe (ByteString -> Decoding)
-> ConduitT ByteString ByteString m ()
go Maybe (ByteString -> Decoding)
forall a. Maybe a
Nothing
  where
    go :: Maybe (ByteString -> Decoding)
-> ConduitT ByteString ByteString m ()
go Maybe (ByteString -> Decoding)
mbDec = do
        Maybe ByteString
mbBs <- ConduitT ByteString ByteString m (Maybe ByteString)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await
        case Maybe ByteString
mbBs of
         Maybe ByteString
Nothing -> () -> ConduitT ByteString ByteString m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         Just ByteString
bs -> do
           let decode :: ByteString -> Decoding
decode = case Maybe (ByteString -> Decoding)
mbDec of
                         Maybe (ByteString -> Decoding)
Nothing -> OnDecodeError -> ByteString -> Decoding
Text.streamDecodeUtf8With OnDecodeError
Text.lenientDecode
                         Just d -> ByteString -> Decoding
d
               (Text.Some Text
out ByteString
leftover ByteString -> Decoding
cont) = ByteString -> Decoding
decode ByteString
bs
               cont' :: Maybe (ByteString -> Decoding)
cont' = if ByteString -> Bool
BS.null ByteString
leftover
                       then Maybe (ByteString -> Decoding)
forall a. Maybe a
Nothing
                       else (ByteString -> Decoding) -> Maybe (ByteString -> Decoding)
forall a. a -> Maybe a
Just ByteString -> Decoding
cont
           Bool
-> ConduitT ByteString ByteString m ()
-> ConduitT ByteString ByteString m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Text.null Text
out) (ConduitT ByteString ByteString m ()
 -> ConduitT ByteString ByteString m ())
-> ConduitT ByteString ByteString m ()
-> ConduitT ByteString ByteString m ()
forall a b. (a -> b) -> a -> b
$
               IO () -> ConduitT ByteString ByteString m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitT ByteString ByteString m ())
-> IO () -> ConduitT ByteString ByteString m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
debugM String
"Pontarius.Xmpp"
                                (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"in: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
out
           ByteString -> ConduitT ByteString ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bs
           Maybe (ByteString -> Decoding)
-> ConduitT ByteString ByteString m ()
go Maybe (ByteString -> 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 :: 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 <- SealedConduitT () o (ExceptT XmppFailure IO) ()
-> IO (TMVar (SealedConduitT () o (ExceptT XmppFailure IO) ()))
forall a. a -> IO (TMVar a)
newTMVarIO (SealedConduitT () o (ExceptT XmppFailure IO) ()
 -> IO (TMVar (SealedConduitT () o (ExceptT XmppFailure IO) ())))
-> SealedConduitT () o (ExceptT XmppFailure IO) ()
-> IO (TMVar (SealedConduitT () o (ExceptT XmppFailure IO) ()))
forall a b. (a -> b) -> a -> b
$ ConduitT () o (ExceptT XmppFailure IO) ()
-> SealedConduitT () o (ExceptT XmppFailure IO) ()
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 <- IO (Either XmppFailure (Maybe o))
-> ConduitT i o m (Either XmppFailure (Maybe o))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either XmppFailure (Maybe o))
 -> ConduitT i o m (Either XmppFailure (Maybe o)))
-> IO (Either XmppFailure (Maybe o))
-> ConduitT i o m (Either XmppFailure (Maybe o))
forall a b. (a -> b) -> a -> b
$ IO (SealedConduitT () o (ExceptT XmppFailure IO) ())
-> (SealedConduitT () o (ExceptT XmppFailure IO) () -> IO ())
-> (SealedConduitT () o (ExceptT XmppFailure IO) ()
    -> IO (Either XmppFailure (Maybe o)))
-> IO (Either XmppFailure (Maybe o))
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Ex.bracketOnError
                      (STM (SealedConduitT () o (ExceptT XmppFailure IO) ())
-> IO (SealedConduitT () o (ExceptT XmppFailure IO) ())
forall a. STM a -> IO a
atomically (STM (SealedConduitT () o (ExceptT XmppFailure IO) ())
 -> IO (SealedConduitT () o (ExceptT XmppFailure IO) ()))
-> STM (SealedConduitT () o (ExceptT XmppFailure IO) ())
-> IO (SealedConduitT () o (ExceptT XmppFailure IO) ())
forall a b. (a -> b) -> a -> b
$ TMVar (SealedConduitT () o (ExceptT XmppFailure IO) ())
-> STM (SealedConduitT () o (ExceptT XmppFailure IO) ())
forall a. TMVar a -> STM a
takeTMVar TMVar (SealedConduitT () o (ExceptT XmppFailure IO) ())
ref)
                      (\SealedConduitT () o (ExceptT XmppFailure IO) ()
_ -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> (SealedConduitT () o (ExceptT XmppFailure IO) () -> STM ())
-> SealedConduitT () o (ExceptT XmppFailure IO) ()
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar (SealedConduitT () o (ExceptT XmppFailure IO) ())
-> SealedConduitT () o (ExceptT XmppFailure IO) () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (SealedConduitT () o (ExceptT XmppFailure IO) ())
ref (SealedConduitT () o (ExceptT XmppFailure IO) () -> IO ())
-> SealedConduitT () o (ExceptT XmppFailure IO) () -> IO ()
forall a b. (a -> b) -> a -> b
$ SealedConduitT () o (ExceptT XmppFailure IO) ()
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 <- ExceptT
  XmppFailure
  IO
  (SealedConduitT () o (ExceptT XmppFailure IO) (), Maybe o)
-> IO
     (Either
        XmppFailure
        (SealedConduitT () o (ExceptT XmppFailure IO) (), Maybe o))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (SealedConduitT () o (ExceptT XmppFailure IO) ()
s SealedConduitT () o (ExceptT XmppFailure IO) ()
-> Sink o (ExceptT XmppFailure IO) (Maybe o)
-> ExceptT
     XmppFailure
     IO
     (SealedConduitT () o (ExceptT XmppFailure IO) (), Maybe o)
forall (m :: * -> *) a b.
Monad m =>
SealedConduitT () a m ()
-> Sink a m b -> m (SealedConduitT () a m (), b)
$$++ Sink o (ExceptT XmppFailure IO) (Maybe o)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await)
                            case Either
  XmppFailure
  (SealedConduitT () o (ExceptT XmppFailure IO) (), Maybe o)
res of
                                Left XmppFailure
e -> do
                                    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar (SealedConduitT () o (ExceptT XmppFailure IO) ())
-> SealedConduitT () o (ExceptT XmppFailure IO) () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (SealedConduitT () o (ExceptT XmppFailure IO) ())
ref SealedConduitT () o (ExceptT XmppFailure IO) ()
forall o. SealedConduitT () o (ExceptT XmppFailure IO) ()
zeroResumableSource
                                    Either XmppFailure (Maybe o) -> IO (Either XmppFailure (Maybe o))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure (Maybe o) -> IO (Either XmppFailure (Maybe o)))
-> Either XmppFailure (Maybe o)
-> IO (Either XmppFailure (Maybe o))
forall a b. (a -> b) -> a -> b
$ XmppFailure -> Either XmppFailure (Maybe o)
forall a b. a -> Either a b
Left XmppFailure
e
                                Right (SealedConduitT () o (ExceptT XmppFailure IO) ()
s',Maybe o
b) -> do
                                    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar (SealedConduitT () o (ExceptT XmppFailure IO) ())
-> SealedConduitT () o (ExceptT XmppFailure IO) () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (SealedConduitT () o (ExceptT XmppFailure IO) ())
ref SealedConduitT () o (ExceptT XmppFailure IO) ()
s'
                                    Either XmppFailure (Maybe o) -> IO (Either XmppFailure (Maybe o))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure (Maybe o) -> IO (Either XmppFailure (Maybe o)))
-> Either XmppFailure (Maybe o)
-> IO (Either XmppFailure (Maybe o))
forall a b. (a -> b) -> a -> b
$ Maybe o -> Either XmppFailure (Maybe o)
forall a b. b -> Either a b
Right Maybe o
b
                      )
            case Either XmppFailure (Maybe o)
dt of
                Left XmppFailure
e -> XmppFailure -> ConduitT i o m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
e
                Right Maybe o
Nothing -> () -> ConduitT i o m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Right (Just o
d) -> o -> ConduitT i o m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield o
d ConduitT i o m () -> ConduitT i o m () -> ConduitT i o m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConduitT i o m ()
go
    ConduitM i o (ExceptT XmppFailure IO) ()
-> IO (ConduitM i o (ExceptT XmppFailure IO) ())
forall (m :: * -> *) a. Monad m => a -> m a
return ConduitM i o (ExceptT XmppFailure IO) ()
forall (m :: * -> *) i.
(MonadIO m, MonadError XmppFailure m) =>
ConduitT i o m ()
go
  where
    zeroResumableSource :: SealedConduitT () o (ExceptT XmppFailure IO) ()
zeroResumableSource = ConduitT () o (ExceptT XmppFailure IO) ()
-> SealedConduitT () o (ExceptT XmppFailure IO) ()
forall i o (m :: * -> *) r.
ConduitT i o m r -> SealedConduitT i o m r
DCI.sealConduitT ConduitT () o (ExceptT XmppFailure IO) ()
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
-> ConduitT
     Event
     Void
     (ExceptT XmppFailure IO)
     (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
        Either
  Element
  (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
   StreamFeatures)
-> ConduitT
     Event
     Void
     (ExceptT XmppFailure IO)
     (Either
        Element
        (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
         StreamFeatures))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   Element
   (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
    StreamFeatures)
 -> ConduitT
      Event
      Void
      (ExceptT XmppFailure IO)
      (Either
         Element
         (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
          StreamFeatures)))
-> Either
     Element
     (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
      StreamFeatures)
-> ConduitT
     Event
     Void
     (ExceptT XmppFailure IO)
     (Either
        Element
        (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
         StreamFeatures))
forall a b. (a -> b) -> a -> b
$ (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
 StreamFeatures)
-> Either
     Element
     (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
      StreamFeatures)
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 -> Either
  Element
  (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
   StreamFeatures)
-> ConduitT
     Event
     Void
     (ExceptT XmppFailure IO)
     (Either
        Element
        (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
         StreamFeatures))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   Element
   (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
    StreamFeatures)
 -> ConduitT
      Event
      Void
      (ExceptT XmppFailure IO)
      (Either
         Element
         (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
          StreamFeatures)))
-> Either
     Element
     (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
      StreamFeatures)
-> ConduitT
     Event
     Void
     (ExceptT XmppFailure IO)
     (Either
        Element
        (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
         StreamFeatures))
forall a b. (a -> b) -> a -> b
$ Element
-> Either
     Element
     (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
      StreamFeatures)
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
        ConduitT Event Void (ExceptT XmppFailure IO) ()
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 PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
-> Element
-> Either
     UnpickleError
     (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
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
_ -> Either
  Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
-> StreamSink
     (Either
        Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
 -> StreamSink
      (Either
         Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)))
-> Either
     Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
-> StreamSink
     (Either
        Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag))
forall a b. (a -> b) -> a -> b
$ Element
-> Either
     Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
forall a b. a -> Either a b
Left Element
el
            Right (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
r -> Either
  Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
-> StreamSink
     (Either
        Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
 -> StreamSink
      (Either
         Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)))
-> Either
     Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
-> StreamSink
     (Either
        Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag))
forall a b. (a -> b) -> a -> b
$ (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
-> Either
     Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
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 <- ConduitT Event Element (ExceptT XmppFailure IO) ()
forall (m :: * -> *).
MonadError XmppFailure m =>
ConduitT Event Element m ()
elements ConduitT Event Element (ExceptT XmppFailure IO) ()
-> ConduitT Element Void (ExceptT XmppFailure IO) (Maybe Element)
-> ConduitT Event Void (ExceptT XmppFailure IO) (Maybe Element)
forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
=$ ConduitT Element Void (ExceptT XmppFailure IO) (Maybe Element)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await
        case Maybe Element
e of
            Maybe Element
Nothing -> do
                ExceptT XmppFailure IO ()
-> ConduitT Event Void (ExceptT XmppFailure IO) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT XmppFailure IO ()
 -> ConduitT Event Void (ExceptT XmppFailure IO) ())
-> ExceptT XmppFailure IO ()
-> ConduitT Event Void (ExceptT XmppFailure IO) ()
forall a b. (a -> b) -> a -> b
$ IO () -> ExceptT XmppFailure IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT XmppFailure IO ())
-> IO () -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM String
"Pontarius.Xmpp" String
"streamS: Stream ended."
                XmppFailure -> StreamSink StreamFeatures
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppOtherFailure
            Just Element
r -> PU [Node] StreamFeatures -> Element -> StreamSink StreamFeatures
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 :: String -> StreamConfiguration -> IO (Either XmppFailure Stream)
openStream String
realm StreamConfiguration
config = ExceptT XmppFailure IO Stream -> IO (Either XmppFailure Stream)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XmppFailure IO Stream -> IO (Either XmppFailure Stream))
-> ExceptT XmppFailure IO Stream -> IO (Either XmppFailure Stream)
forall a b. (a -> b) -> a -> b
$ do
    IO () -> ExceptT XmppFailure IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT XmppFailure IO ())
-> IO () -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
debugM String
"Pontarius.Xmpp" String
"Opening stream..."
    Stream
stream' <- String -> StreamConfiguration -> ExceptT XmppFailure IO Stream
createStream String
realm StreamConfiguration
config
    IO (Either XmppFailure ()) -> ExceptT XmppFailure IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either XmppFailure ()) -> ExceptT XmppFailure IO ())
-> (IO (Either XmppFailure ()) -> IO (Either XmppFailure ()))
-> IO (Either XmppFailure ())
-> ExceptT XmppFailure IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either XmppFailure ()) -> IO (Either XmppFailure ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either XmppFailure ()) -> ExceptT XmppFailure IO ())
-> IO (Either XmppFailure ()) -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ StateT StreamState IO (Either XmppFailure ())
-> Stream -> IO (Either XmppFailure ())
forall a. StateT StreamState IO a -> Stream -> IO a
withStream StateT StreamState IO (Either XmppFailure ())
startStream Stream
stream'
    Stream -> ExceptT XmppFailure IO 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 = StateT StreamState IO () -> Stream -> IO ()
forall a. StateT StreamState IO a -> Stream -> IO a
withStream StateT StreamState IO ()
closeStreams'

closeStreams' :: StateT StreamState IO ()
closeStreams' :: StateT StreamState IO ()
closeStreams' = do
    IO () -> StateT StreamState IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT StreamState IO ())
-> IO () -> StateT StreamState IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
debugM String
"Pontarius.Xmpp" String
"Closing stream"
    ByteString -> IO (Either XmppFailure ())
send <- (StreamState -> ByteString -> IO (Either XmppFailure ()))
-> StateT StreamState IO (ByteString -> IO (Either XmppFailure ()))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StreamHandle -> ByteString -> IO (Either XmppFailure ())
streamSend (StreamHandle -> ByteString -> IO (Either XmppFailure ()))
-> (StreamState -> StreamHandle)
-> StreamState
-> ByteString
-> IO (Either XmppFailure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamHandle
streamHandle)
    IO ()
cc <- (StreamState -> IO ()) -> StateT StreamState IO (IO ())
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StreamHandle -> IO ()
streamClose (StreamHandle -> IO ())
-> (StreamState -> StreamHandle) -> StreamState -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamHandle
streamHandle)
    IO () -> StateT StreamState IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT StreamState IO ())
-> IO () -> StateT StreamState IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
debugM String
"Pontarius.Xmpp" String
"Sending closing tag"
    StateT StreamState IO (Either XmppFailure ())
-> StateT StreamState IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT StreamState IO (Either XmppFailure ())
 -> StateT StreamState IO ())
-> (IO (Either XmppFailure ())
    -> StateT StreamState IO (Either XmppFailure ()))
-> IO (Either XmppFailure ())
-> StateT StreamState IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either XmppFailure ())
-> StateT StreamState IO (Either XmppFailure ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either XmppFailure ()) -> StateT StreamState IO ())
-> IO (Either XmppFailure ()) -> StateT StreamState IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO (Either XmppFailure ())
send ByteString
"</stream:stream>"
    IO () -> StateT StreamState IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT StreamState IO ())
-> IO () -> StateT StreamState IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
debugM String
"Pontarius.Xmpp" String
"Waiting for stream to close"
    StateT StreamState IO ThreadId -> StateT StreamState IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT StreamState IO ThreadId -> StateT StreamState IO ())
-> StateT StreamState IO ThreadId -> StateT StreamState IO ()
forall a b. (a -> b) -> a -> b
$ IO ThreadId -> StateT StreamState IO ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> StateT StreamState IO ThreadId)
-> IO ThreadId -> StateT StreamState IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
        Int -> IO ()
threadDelay Int
3000000 -- TODO: Configurable value
        IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
Ex.try IO ()
cc) :: IO (Either Ex.SomeException ()))
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    StreamState -> StateT StreamState IO ()
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 :: ByteString -> m ()
debugOut ByteString
outData = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
debugM String
"Pontarius.Xmpp"
             (String
"Out: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Text -> String
Text.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.decodeUtf8 (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString
outData))

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

pushElement :: Element -> StateT StreamState IO (Either XmppFailure ())
pushElement :: Element -> StateT StreamState IO (Either XmppFailure ())
pushElement Element
x = do
    ByteString -> IO (Either XmppFailure ())
send <- (StreamState -> ByteString -> IO (Either XmppFailure ()))
-> StateT StreamState IO (ByteString -> IO (Either XmppFailure ()))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StreamHandle -> ByteString -> IO (Either XmppFailure ())
streamSend (StreamHandle -> ByteString -> IO (Either XmppFailure ()))
-> (StreamState -> StreamHandle)
-> StreamState
-> ByteString
-> IO (Either XmppFailure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamHandle
streamHandle)
    let outData :: ByteString
outData = Element -> ByteString
renderElement (Element -> ByteString) -> Element -> ByteString
forall a b. (a -> b) -> a -> b
$ Element -> Element
nsHack Element
x
    ByteString -> StateT StreamState IO ()
forall (m :: * -> *). MonadIO m => ByteString -> m ()
debugOut ByteString
outData
    IO (Either XmppFailure ())
-> StateT StreamState IO (Either XmppFailure ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Either XmppFailure ())
 -> StateT StreamState IO (Either XmppFailure ()))
-> IO (Either XmppFailure ())
-> StateT StreamState IO (Either XmppFailure ())
forall a b. (a -> b) -> a -> b
$ ByteString -> IO (Either XmppFailure ())
send ByteString
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 Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
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) Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing
         , elementNodes :: [Node]
elementNodes = (Node -> Node) -> [Node] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map Node -> Node
mapNSHack ([Node] -> [Node]) -> [Node] -> [Node]
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 (Element -> Node) -> Element -> Node
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 = StateT StreamState IO (Either XmppFailure ())
-> Stream -> IO (Either XmppFailure ())
forall a. StateT StreamState IO a -> Stream -> IO a
withStream' (StateT StreamState IO (Either XmppFailure ())
 -> Stream -> IO (Either XmppFailure ()))
-> (Element -> StateT StreamState IO (Either XmppFailure ()))
-> Element
-> Stream
-> IO (Either XmppFailure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> StateT StreamState IO (Either XmppFailure ())
pushElement (Element -> Stream -> IO (Either XmppFailure ()))
-> Element -> Stream -> IO (Either XmppFailure ())
forall a b. (a -> b) -> a -> b
$ PU [Node] Stanza -> Stanza -> Element
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 <- (StreamState -> StreamHandle) -> StateT StreamState IO StreamHandle
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StreamState -> StreamHandle
streamHandle
    IO (Either XmppFailure ())
-> StateT StreamState IO (Either XmppFailure ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Either XmppFailure ())
 -> StateT StreamState IO (Either XmppFailure ()))
-> IO (Either XmppFailure ())
-> StateT StreamState IO (Either XmppFailure ())
forall a b. (a -> b) -> a -> b
$ StreamHandle -> ByteString -> IO (Either XmppFailure ())
streamSend StreamHandle
con ByteString
"<?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
    ByteString -> IO (Either XmppFailure ())
send <- (StreamState -> ByteString -> IO (Either XmppFailure ()))
-> StateT StreamState IO (ByteString -> IO (Either XmppFailure ()))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StreamHandle -> ByteString -> IO (Either XmppFailure ())
streamSend (StreamHandle -> ByteString -> IO (Either XmppFailure ()))
-> (StreamState -> StreamHandle)
-> StreamState
-> ByteString
-> IO (Either XmppFailure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamHandle
streamHandle)
    let outData :: ByteString
outData = Element -> ByteString
renderOpenElement Element
e
    ByteString -> StateT StreamState IO ()
forall (m :: * -> *). MonadIO m => ByteString -> m ()
debugOut ByteString
outData
    IO (Either XmppFailure ())
-> StateT StreamState IO (Either XmppFailure ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Either XmppFailure ())
 -> StateT StreamState IO (Either XmppFailure ()))
-> IO (Either XmppFailure ())
-> StateT StreamState IO (Either XmppFailure ())
forall a b. (a -> b) -> a -> b
$ ByteString -> IO (Either XmppFailure ())
send ByteString
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 :: 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 <- (StreamState -> ConduitM () Event (ExceptT XmppFailure IO) ())
-> StateT
     StreamState IO (ConduitM () Event (ExceptT XmppFailure IO) ())
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StreamState -> ConduitM () Event (ExceptT XmppFailure IO) ()
streamEventSource
    IO (Either XmppFailure b)
-> StateT StreamState IO (Either XmppFailure b)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Either XmppFailure b)
 -> StateT StreamState IO (Either XmppFailure b))
-> (ExceptT XmppFailure IO b -> IO (Either XmppFailure b))
-> ExceptT XmppFailure IO b
-> StateT StreamState IO (Either XmppFailure b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT XmppFailure IO b -> IO (Either XmppFailure b)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XmppFailure IO b
 -> StateT StreamState IO (Either XmppFailure b))
-> ExceptT XmppFailure IO b
-> StateT StreamState IO (Either XmppFailure b)
forall a b. (a -> b) -> a -> b
$ ConduitM () Event (ExceptT XmppFailure IO) ()
src ConduitM () Event (ExceptT XmppFailure IO) ()
-> ConduitT Event Void (ExceptT XmppFailure IO) b
-> ExceptT XmppFailure IO b
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 <- ConduitT Event Void (ExceptT XmppFailure IO) (Maybe Element)
-> StateT StreamState IO (Either XmppFailure (Maybe Element))
forall b.
ConduitT Event Void (ExceptT XmppFailure IO) b
-> StateT StreamState IO (Either XmppFailure b)
runEventsSink (ConduitT Event Element (ExceptT XmppFailure IO) ()
forall (m :: * -> *).
MonadError XmppFailure m =>
ConduitT Event Element m ()
elements ConduitT Event Element (ExceptT XmppFailure IO) ()
-> ConduitT Element Void (ExceptT XmppFailure IO) (Maybe Element)
-> ConduitT Event Void (ExceptT XmppFailure IO) (Maybe Element)
forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
=$ ConduitT Element Void (ExceptT XmppFailure IO) (Maybe Element)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await)
    case Either XmppFailure (Maybe Element)
e of
        Left XmppFailure
l -> do
            IO () -> StateT StreamState IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT StreamState IO ())
-> (String -> IO ()) -> String -> StateT StreamState IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  String -> String -> IO ()
errorM String
"Pontarius.Xmpp" (String -> StateT StreamState IO ())
-> String -> StateT StreamState IO ()
forall a b. (a -> b) -> a -> b
$
                  String
"Error while retrieving XML element: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ XmppFailure -> String
forall a. Show a => a -> String
show XmppFailure
l
            Either XmppFailure Element
-> StateT StreamState IO (Either XmppFailure Element)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure Element
 -> StateT StreamState IO (Either XmppFailure Element))
-> Either XmppFailure Element
-> StateT StreamState IO (Either XmppFailure Element)
forall a b. (a -> b) -> a -> b
$ XmppFailure -> Either XmppFailure Element
forall a b. a -> Either a b
Left XmppFailure
l

        Right Maybe Element
Nothing -> do
            IO () -> StateT StreamState IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT StreamState IO ())
-> IO () -> StateT StreamState IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM String
"Pontarius.Xmpp" String
"pullElement: Stream ended."
            Either XmppFailure Element
-> StateT StreamState IO (Either XmppFailure Element)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure Element
 -> StateT StreamState IO (Either XmppFailure Element))
-> (XmppFailure -> Either XmppFailure Element)
-> XmppFailure
-> StateT StreamState IO (Either XmppFailure Element)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmppFailure -> Either XmppFailure Element
forall a b. a -> Either a b
Left (XmppFailure -> StateT StreamState IO (Either XmppFailure Element))
-> XmppFailure
-> StateT StreamState IO (Either XmppFailure Element)
forall a b. (a -> b) -> a -> b
$ XmppFailure
XmppOtherFailure
        Right (Just Element
r) -> Either XmppFailure Element
-> StateT StreamState IO (Either XmppFailure Element)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure Element
 -> StateT StreamState IO (Either XmppFailure Element))
-> Either XmppFailure Element
-> StateT StreamState IO (Either XmppFailure Element)
forall a b. (a -> b) -> a -> b
$ Element -> Either XmppFailure Element
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 :: 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 -> Either XmppFailure a
-> StateT StreamState IO (Either XmppFailure a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure a
 -> StateT StreamState IO (Either XmppFailure a))
-> Either XmppFailure a
-> StateT StreamState IO (Either XmppFailure a)
forall a b. (a -> b) -> a -> b
$ XmppFailure -> Either XmppFailure a
forall a b. a -> Either a b
Left XmppFailure
e
        Right Element
elem' -> do
            let res :: Either UnpickleError a
res = PU [Node] a -> Element -> Either UnpickleError a
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
                    IO () -> StateT StreamState IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT StreamState IO ())
-> IO () -> StateT StreamState IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM String
"Pontarius.Xmpp" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"pullUnpickle: Unpickle failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (UnpickleError -> String
ppUnpickleError UnpickleError
e)
                    Either XmppFailure a
-> StateT StreamState IO (Either XmppFailure a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure a
 -> StateT StreamState IO (Either XmppFailure a))
-> (XmppFailure -> Either XmppFailure a)
-> XmppFailure
-> StateT StreamState IO (Either XmppFailure a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmppFailure -> Either XmppFailure a
forall a b. a -> Either a b
Left (XmppFailure -> StateT StreamState IO (Either XmppFailure a))
-> XmppFailure -> StateT StreamState IO (Either XmppFailure a)
forall a b. (a -> b) -> a -> b
$ XmppFailure
XmppOtherFailure
                Right a
r -> Either XmppFailure a
-> StateT StreamState IO (Either XmppFailure a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure a
 -> StateT StreamState IO (Either XmppFailure a))
-> Either XmppFailure a
-> StateT StreamState IO (Either XmppFailure a)
forall a b. (a -> b) -> a -> b
$ a -> Either XmppFailure a
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 = StateT StreamState IO (Either XmppFailure Stanza)
-> Stream -> IO (Either XmppFailure Stanza)
forall a. StateT StreamState IO a -> Stream -> IO a
withStream' (StateT StreamState IO (Either XmppFailure Stanza)
 -> Stream -> IO (Either XmppFailure Stanza))
-> StateT StreamState IO (Either XmppFailure Stanza)
-> Stream
-> IO (Either XmppFailure Stanza)
forall a b. (a -> b) -> a -> b
$ do
    Either XmppFailure (Either StreamErrorInfo Stanza)
res <- PU [Node] (Either StreamErrorInfo Stanza)
-> StateT
     StreamState IO (Either XmppFailure (Either StreamErrorInfo Stanza))
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 -> Either XmppFailure Stanza
-> StateT StreamState IO (Either XmppFailure Stanza)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure Stanza
 -> StateT StreamState IO (Either XmppFailure Stanza))
-> Either XmppFailure Stanza
-> StateT StreamState IO (Either XmppFailure Stanza)
forall a b. (a -> b) -> a -> b
$ XmppFailure -> Either XmppFailure Stanza
forall a b. a -> Either a b
Left XmppFailure
e
        Right (Left StreamErrorInfo
e) -> Either XmppFailure Stanza
-> StateT StreamState IO (Either XmppFailure Stanza)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure Stanza
 -> StateT StreamState IO (Either XmppFailure Stanza))
-> Either XmppFailure Stanza
-> StateT StreamState IO (Either XmppFailure Stanza)
forall a b. (a -> b) -> a -> b
$ XmppFailure -> Either XmppFailure Stanza
forall a b. a -> Either a b
Left (XmppFailure -> Either XmppFailure Stanza)
-> XmppFailure -> Either XmppFailure Stanza
forall a b. (a -> b) -> a -> b
$ StreamErrorInfo -> XmppFailure
StreamErrorFailure StreamErrorInfo
e
        Right (Right Stanza
r) -> Either XmppFailure Stanza
-> StateT StreamState IO (Either XmppFailure Stanza)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure Stanza
 -> StateT StreamState IO (Either XmppFailure Stanza))
-> Either XmppFailure Stanza
-> StateT StreamState IO (Either XmppFailure Stanza)
forall a b. (a -> b) -> a -> b
$ Stanza -> Either XmppFailure Stanza
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 = StateT StreamState IO (Either XmppFailure XmppElement)
-> Stream -> IO (Either XmppFailure XmppElement)
forall a. StateT StreamState IO a -> Stream -> IO a
withStream' (StateT StreamState IO (Either XmppFailure XmppElement)
 -> Stream -> IO (Either XmppFailure XmppElement))
-> StateT StreamState IO (Either XmppFailure XmppElement)
-> Stream
-> IO (Either XmppFailure XmppElement)
forall a b. (a -> b) -> a -> b
$ do
    Either XmppFailure (Either StreamErrorInfo XmppElement)
res <- PU [Node] (Either StreamErrorInfo XmppElement)
-> StateT
     StreamState
     IO
     (Either XmppFailure (Either StreamErrorInfo XmppElement))
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 -> Either XmppFailure XmppElement
-> StateT StreamState IO (Either XmppFailure XmppElement)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure XmppElement
 -> StateT StreamState IO (Either XmppFailure XmppElement))
-> Either XmppFailure XmppElement
-> StateT StreamState IO (Either XmppFailure XmppElement)
forall a b. (a -> b) -> a -> b
$ XmppFailure -> Either XmppFailure XmppElement
forall a b. a -> Either a b
Left XmppFailure
e
        Right (Left StreamErrorInfo
e) -> Either XmppFailure XmppElement
-> StateT StreamState IO (Either XmppFailure XmppElement)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure XmppElement
 -> StateT StreamState IO (Either XmppFailure XmppElement))
-> Either XmppFailure XmppElement
-> StateT StreamState IO (Either XmppFailure XmppElement)
forall a b. (a -> b) -> a -> b
$ XmppFailure -> Either XmppFailure XmppElement
forall a b. a -> Either a b
Left (XmppFailure -> Either XmppFailure XmppElement)
-> XmppFailure -> Either XmppFailure XmppElement
forall a b. (a -> b) -> a -> b
$ StreamErrorInfo -> XmppFailure
StreamErrorFailure StreamErrorInfo
e
        Right (Right XmppElement
r) -> Either XmppFailure XmppElement
-> StateT StreamState IO (Either XmppFailure XmppElement)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure XmppElement
 -> StateT StreamState IO (Either XmppFailure XmppElement))
-> Either XmppFailure XmppElement
-> StateT StreamState IO (Either XmppFailure XmppElement)
forall a b. (a -> b) -> a -> b
$ XmppElement -> Either XmppFailure XmppElement
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 = IO (Either XmppFailure ())
-> (IOError -> IO (Either XmppFailure ()))
-> IO (Either XmppFailure ())
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
ExL.catch
    (IO ()
p IO () -> IO (Either XmppFailure ()) -> IO (Either XmppFailure ())
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either XmppFailure () -> IO (Either XmppFailure ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either XmppFailure ()
forall a b. b -> Either a b
Right ()))
    (\IOError
e -> case IOError -> IOErrorType
GIE.ioe_type IOError
e of
         IOErrorType
GIE.ResourceVanished -> Either XmppFailure () -> IO (Either XmppFailure ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure () -> IO (Either XmppFailure ()))
-> (XmppFailure -> Either XmppFailure ())
-> XmppFailure
-> IO (Either XmppFailure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmppFailure -> Either XmppFailure ()
forall a b. a -> Either a b
Left (XmppFailure -> IO (Either XmppFailure ()))
-> XmppFailure -> IO (Either XmppFailure ())
forall a b. (a -> b) -> a -> b
$ IOError -> XmppFailure
XmppIOException IOError
e
         IOErrorType
GIE.IllegalOperation -> Either XmppFailure () -> IO (Either XmppFailure ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure () -> IO (Either XmppFailure ()))
-> (XmppFailure -> Either XmppFailure ())
-> XmppFailure
-> IO (Either XmppFailure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmppFailure -> Either XmppFailure ()
forall a b. a -> Either a b
Left (XmppFailure -> IO (Either XmppFailure ()))
-> XmppFailure -> IO (Either XmppFailure ())
forall a b. (a -> b) -> a -> b
$ IOError -> XmppFailure
XmppIOException IOError
e
         IOErrorType
_ -> IOError -> IO (Either XmppFailure ())
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
ExL.throwIO IOError
e
    )

zeroHandle :: StreamHandle
zeroHandle :: StreamHandle
zeroHandle = StreamHandle :: (ByteString -> IO (Either XmppFailure ()))
-> (Int -> IO (Either XmppFailure ByteString))
-> IO ()
-> IO ()
-> StreamHandle
StreamHandle { streamSend :: ByteString -> IO (Either XmppFailure ())
streamSend = \ByteString
_ -> Either XmppFailure () -> IO (Either XmppFailure ())
forall (m :: * -> *) a. Monad m => a -> m a
return (XmppFailure -> Either XmppFailure ()
forall a b. a -> Either a b
Left XmppFailure
XmppNoStream)
                          , streamReceive :: Int -> IO (Either XmppFailure ByteString)
streamReceive = \Int
_ -> do
                                 String -> String -> IO ()
errorM String
"Pontarius.Xmpp"
                                        String
"xmppNoStream: Stream is closed."
                                 Either XmppFailure ByteString -> IO (Either XmppFailure ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure ByteString
 -> IO (Either XmppFailure ByteString))
-> Either XmppFailure ByteString
-> IO (Either XmppFailure ByteString)
forall a b. (a -> b) -> a -> b
$ XmppFailure -> Either XmppFailure ByteString
forall a b. a -> Either a b
Left XmppFailure
XmppNoStream
                          , streamFlush :: IO ()
streamFlush = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                          , streamClose :: IO ()
streamClose = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                          }

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

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

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

-- Connects using the specified method. Returns the Handle acquired, if any.
connect :: HostName -> StreamConfiguration -> ExceptT XmppFailure IO
           (Maybe StreamHandle)
connect :: String
-> StreamConfiguration
-> ExceptT XmppFailure IO (Maybe StreamHandle)
connect String
realm StreamConfiguration
config = do
    case StreamConfiguration -> ConnectionDetails
connectionDetails StreamConfiguration
config of
        UseHost String
host PortNumber
port -> IO (Maybe StreamHandle)
-> ExceptT XmppFailure IO (Maybe StreamHandle)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe StreamHandle)
 -> ExceptT XmppFailure IO (Maybe StreamHandle))
-> IO (Maybe StreamHandle)
-> ExceptT XmppFailure IO (Maybe StreamHandle)
forall a b. (a -> b) -> a -> b
$ do
            String -> String -> IO ()
debugM String
"Pontarius.Xmpp" String
"Connecting to configured address."
            Maybe Handle
h <- String -> PortNumber -> IO (Maybe Handle)
resolveAndConnectTcp String
host PortNumber
port
            case Maybe Handle
h of
                Maybe Handle
Nothing -> Maybe StreamHandle -> IO (Maybe StreamHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe StreamHandle
forall a. Maybe a
Nothing
                Just Handle
h' -> do
                    IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
h' BufferMode
NoBuffering
                    Maybe StreamHandle -> IO (Maybe StreamHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe StreamHandle -> IO (Maybe StreamHandle))
-> (StreamHandle -> Maybe StreamHandle)
-> StreamHandle
-> IO (Maybe StreamHandle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamHandle -> Maybe StreamHandle
forall a. a -> Maybe a
Just (StreamHandle -> IO (Maybe StreamHandle))
-> StreamHandle -> IO (Maybe StreamHandle)
forall a b. (a -> b) -> a -> b
$ Handle -> StreamHandle
handleToStreamHandle Handle
h'
        UseSrv String
host -> do
            Maybe Handle
h <- ResolvConf -> String -> ExceptT XmppFailure IO (Maybe Handle)
connectSrv (StreamConfiguration -> ResolvConf
resolvConf StreamConfiguration
config) String
host
            case Maybe Handle
h of
                Maybe Handle
Nothing -> Maybe StreamHandle -> ExceptT XmppFailure IO (Maybe StreamHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe StreamHandle
forall a. Maybe a
Nothing
                Just Handle
h' -> do
                    IO () -> ExceptT XmppFailure IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XmppFailure IO ())
-> IO () -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
h' BufferMode
NoBuffering
                    Maybe StreamHandle -> ExceptT XmppFailure IO (Maybe StreamHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe StreamHandle -> ExceptT XmppFailure IO (Maybe StreamHandle))
-> (StreamHandle -> Maybe StreamHandle)
-> StreamHandle
-> ExceptT XmppFailure IO (Maybe StreamHandle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamHandle -> Maybe StreamHandle
forall a. a -> Maybe a
Just (StreamHandle -> ExceptT XmppFailure IO (Maybe StreamHandle))
-> StreamHandle -> ExceptT XmppFailure IO (Maybe StreamHandle)
forall a b. (a -> b) -> a -> b
$ Handle -> StreamHandle
handleToStreamHandle Handle
h'
        ConnectionDetails
UseRealm -> do
            Maybe Handle
h <- ResolvConf -> String -> ExceptT XmppFailure IO (Maybe Handle)
connectSrv (StreamConfiguration -> ResolvConf
resolvConf StreamConfiguration
config) String
realm
            case Maybe Handle
h of
                Maybe Handle
Nothing -> Maybe StreamHandle -> ExceptT XmppFailure IO (Maybe StreamHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe StreamHandle
forall a. Maybe a
Nothing
                Just Handle
h' -> do
                    IO () -> ExceptT XmppFailure IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XmppFailure IO ())
-> IO () -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
h' BufferMode
NoBuffering
                    Maybe StreamHandle -> ExceptT XmppFailure IO (Maybe StreamHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe StreamHandle -> ExceptT XmppFailure IO (Maybe StreamHandle))
-> (StreamHandle -> Maybe StreamHandle)
-> StreamHandle
-> ExceptT XmppFailure IO (Maybe StreamHandle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamHandle -> Maybe StreamHandle
forall a. a -> Maybe a
Just (StreamHandle -> ExceptT XmppFailure IO (Maybe StreamHandle))
-> StreamHandle -> ExceptT XmppFailure IO (Maybe StreamHandle)
forall a b. (a -> b) -> a -> b
$ Handle -> StreamHandle
handleToStreamHandle Handle
h'
        UseConnection ExceptT XmppFailure IO StreamHandle
mkC -> StreamHandle -> Maybe StreamHandle
forall a. a -> Maybe a
Just (StreamHandle -> Maybe StreamHandle)
-> ExceptT XmppFailure IO StreamHandle
-> ExceptT XmppFailure IO (Maybe StreamHandle)
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 -> String -> ExceptT XmppFailure IO (Maybe Handle)
connectSrv ResolvConf
config String
host = do
    case Text -> Maybe Text
checkHostName (String -> Text
Text.pack String
host) of
        Just Text
host' -> do
            ResolvSeed
resolvSeed <- IO ResolvSeed -> ExceptT XmppFailure IO ResolvSeed
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO ResolvSeed -> ExceptT XmppFailure IO ResolvSeed)
-> IO ResolvSeed -> ExceptT XmppFailure IO ResolvSeed
forall a b. (a -> b) -> a -> b
$ ResolvConf -> IO ResolvSeed
makeResolvSeed ResolvConf
config
            IO () -> ExceptT XmppFailure IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT XmppFailure IO ())
-> IO () -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
debugM String
"Pontarius.Xmpp" String
"Performing SRV lookup..."
            Maybe [(ByteString, Word16)]
srvRecords <- Text
-> ResolvSeed
-> ExceptT XmppFailure IO (Maybe [(ByteString, Word16)])
srvLookup Text
host' ResolvSeed
resolvSeed
            case Maybe [(ByteString, Word16)]
srvRecords of
                Maybe [(ByteString, Word16)]
Nothing -> do
                    IO () -> ExceptT XmppFailure IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT XmppFailure IO ())
-> IO () -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
debugM String
"Pontarius.Xmpp"
                        String
"No SRV records, using fallback process."
                    IO (Maybe Handle) -> ExceptT XmppFailure IO (Maybe Handle)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe Handle) -> ExceptT XmppFailure IO (Maybe Handle))
-> IO (Maybe Handle) -> ExceptT XmppFailure IO (Maybe Handle)
forall a b. (a -> b) -> a -> b
$ String -> PortNumber -> IO (Maybe Handle)
resolveAndConnectTcp String
host PortNumber
5222
                Just [(ByteString
".", Word16
_)] -> do
                    IO () -> ExceptT XmppFailure IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XmppFailure IO ())
-> IO () -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
infoM String
"Pontarius.Xmpp"
                                String
"SRV lookup returned \".\"; service not available"
                    XmppFailure -> ExceptT XmppFailure IO (Maybe Handle)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
TcpConnectionFailure
                Just [(ByteString, Word16)]
srvRecords' -> do
                    IO () -> ExceptT XmppFailure IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT XmppFailure IO ())
-> IO () -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
debugM String
"Pontarius.Xmpp"
                        String
"SRV records found, looking up host."
                    IO (Maybe Handle) -> ExceptT XmppFailure IO (Maybe Handle)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe Handle) -> ExceptT XmppFailure IO (Maybe Handle))
-> IO (Maybe Handle) -> ExceptT XmppFailure IO (Maybe Handle)
forall a b. (a -> b) -> a -> b
$ [(String, PortNumber)] -> IO (Maybe Handle)
resolvSrvsAndConnectTcp
                           ( [(ByteString, Word16)]
-> ((ByteString, Word16) -> (String, PortNumber))
-> [(String, PortNumber)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
for [(ByteString, Word16)]
srvRecords' (((ByteString, Word16) -> (String, PortNumber))
 -> [(String, PortNumber)])
-> ((ByteString, Word16) -> (String, PortNumber))
-> [(String, PortNumber)]
forall a b. (a -> b) -> a -> b
$
                              \(ByteString
domain, Word16
port) -> ( ByteString -> String
BSC8.unpack ByteString
domain
                                                 , Word16 -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
port))
        Maybe Text
Nothing -> do
                IO () -> ExceptT XmppFailure IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT XmppFailure IO ())
-> IO () -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM String
"Pontarius.Xmpp"
                    String
"The hostname could not be validated."
                XmppFailure -> ExceptT XmppFailure IO (Maybe Handle)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppIllegalTcpDetails
  where for :: f a -> (a -> b) -> f b
for = ((a -> b) -> f a -> f b) -> f a -> (a -> b) -> f b
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> b) -> f a -> f b
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 [] = Maybe Handle -> IO (Maybe Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Handle
forall a. Maybe a
Nothing
connectTcp (AddrInfo
addrInfo:[AddrInfo]
remainder) = do
    let addr :: String
addr = (SockAddr -> String
forall a. Show a => a -> String
show (SockAddr -> String) -> SockAddr -> String
forall a b. (a -> b) -> a -> b
$ AddrInfo -> SockAddr
S.addrAddress AddrInfo
addrInfo)
    Either IOError Handle
result <- IO Handle -> IO (Either IOError Handle)
forall e a. Exception e => IO a -> IO (Either e a)
Ex.try (IO Handle -> IO (Either IOError Handle))
-> IO Handle -> IO (Either IOError Handle)
forall a b. (a -> b) -> a -> b
$ (do
        String -> String -> IO ()
debugM String
"Pontarius.Xmpp" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Connecting to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
addr
        AddrInfo -> IO Handle
connectHandle AddrInfo
addrInfo) :: IO (Either Ex.IOException Handle)
    case Either IOError Handle
result of
        Right Handle
handle -> do
            String -> String -> IO ()
debugM String
"Pontarius.Xmpp" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Successfully connected to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
addr
            Maybe Handle -> IO (Maybe Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Handle -> IO (Maybe Handle))
-> Maybe Handle -> IO (Maybe Handle)
forall a b. (a -> b) -> a -> b
$ Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
handle
        Left IOError
_ -> do
            String -> String -> IO ()
debugM String
"Pontarius.Xmpp" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                String
"Connection to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
addr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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 :: Either e a -> Maybe a
fixDnsResult = (e -> Maybe a) -> (a -> Maybe a) -> Either e a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> e -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
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 :: String -> PortNumber -> IO (Maybe Handle)
resolveAndConnectTcp String
hostName PortNumber
port = do
    [AddrInfo]
ais <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
S.getAddrInfo Maybe AddrInfo
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
hostName) Maybe String
forall a. Maybe a
Nothing
    [AddrInfo] -> IO (Maybe Handle)
connectTcp ([AddrInfo] -> IO (Maybe Handle))
-> [AddrInfo] -> IO (Maybe Handle)
forall a b. (a -> b) -> a -> b
$ AddrInfo -> AddrInfo
setPort (AddrInfo -> AddrInfo) -> [AddrInfo] -> [AddrInfo]
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 :: [(String, PortNumber)] -> IO (Maybe Handle)
resolvSrvsAndConnectTcp [] = Maybe Handle -> IO (Maybe Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Handle
forall a. Maybe a
Nothing
resolvSrvsAndConnectTcp ((String
domain, PortNumber
port):[(String, PortNumber)]
remaining) = do
    Maybe Handle
result <- String -> PortNumber -> IO (Maybe Handle)
resolveAndConnectTcp String
domain PortNumber
port
    case Maybe Handle
result of
        Just Handle
handle -> Maybe Handle -> IO (Maybe Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Handle -> IO (Maybe Handle))
-> Maybe Handle -> IO (Maybe Handle)
forall a b. (a -> b) -> a -> b
$ Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
handle
        Maybe Handle
Nothing -> [(String, PortNumber)] -> IO (Maybe Handle)
resolvSrvsAndConnectTcp [(String, 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 :: IO a -> IO a
rethrowErrorCall IO a
action = do
    Either ErrorCall a
result <- IO a -> IO (Either ErrorCall a)
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' -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result'
        Left (Ex.ErrorCall String
e) -> IOError -> IO a
forall a. IOError -> IO a
Ex.ioError (IOError -> IO a) -> IOError -> IO a
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError
                                 (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ String
"rethrowErrorCall: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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 [(ByteString, Word16)])
srvLookup Text
realm ResolvSeed
resolvSeed = IO (Either XmppFailure (Maybe [(ByteString, Word16)]))
-> ExceptT XmppFailure IO (Maybe [(ByteString, Word16)])
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either XmppFailure (Maybe [(ByteString, Word16)]))
 -> ExceptT XmppFailure IO (Maybe [(ByteString, Word16)]))
-> IO (Either XmppFailure (Maybe [(ByteString, Word16)]))
-> ExceptT XmppFailure IO (Maybe [(ByteString, Word16)])
forall a b. (a -> b) -> a -> b
$ do
    Either IOError (Maybe [(ByteString, Word16)])
result <- IO (Maybe [(ByteString, Word16)])
-> IO (Either IOError (Maybe [(ByteString, Word16)]))
forall e a. Exception e => IO a -> IO (Either e a)
Ex.try (IO (Maybe [(ByteString, Word16)])
 -> IO (Either IOError (Maybe [(ByteString, Word16)])))
-> IO (Maybe [(ByteString, Word16)])
-> IO (Either IOError (Maybe [(ByteString, Word16)]))
forall a b. (a -> b) -> a -> b
$ IO (Maybe [(ByteString, Word16)])
-> IO (Maybe [(ByteString, Word16)])
forall a. IO a -> IO a
rethrowErrorCall (IO (Maybe [(ByteString, Word16)])
 -> IO (Maybe [(ByteString, Word16)]))
-> IO (Maybe [(ByteString, Word16)])
-> IO (Maybe [(ByteString, Word16)])
forall a b. (a -> b) -> a -> b
$ ResolvSeed
-> (Resolver -> IO (Maybe [(ByteString, Word16)]))
-> IO (Maybe [(ByteString, Word16)])
forall a. ResolvSeed -> (Resolver -> IO a) -> IO a
withResolver ResolvSeed
resolvSeed
              ((Resolver -> IO (Maybe [(ByteString, Word16)]))
 -> IO (Maybe [(ByteString, Word16)]))
-> (Resolver -> IO (Maybe [(ByteString, Word16)]))
-> IO (Maybe [(ByteString, Word16)])
forall a b. (a -> b) -> a -> b
$ \Resolver
resolver -> do
        Either DNSError [(Word16, Word16, Word16, ByteString)]
srvResult <- Resolver
-> ByteString
-> IO (Either DNSError [(Word16, Word16, Word16, ByteString)])
lookupSRV Resolver
resolver (ByteString
 -> IO (Either DNSError [(Word16, Word16, Word16, ByteString)]))
-> ByteString
-> IO (Either DNSError [(Word16, Word16, Word16, ByteString)])
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BSC8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"_xmpp-client._tcp." String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Text -> String
Text.unpack Text
realm) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
        case Either DNSError [(Word16, Word16, Word16, ByteString)]
-> Maybe [(Word16, Word16, Word16, ByteString)]
forall e a. Either e a -> Maybe a
fixDnsResult Either DNSError [(Word16, Word16, Word16, ByteString)]
srvResult of
            Just [] -> do
                String -> String -> IO ()
debugM String
"Pontarius.Xmpp" String
"No SRV result returned."
                Maybe [(ByteString, Word16)] -> IO (Maybe [(ByteString, Word16)])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [(ByteString, Word16)]
forall a. Maybe a
Nothing
            Just [(Word16
_, Word16
_, Word16
_, ByteString
".")] -> do
                String -> String -> IO ()
debugM String
"Pontarius.Xmpp" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\".\" SRV result returned."
                Maybe [(ByteString, Word16)] -> IO (Maybe [(ByteString, Word16)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [(ByteString, Word16)] -> IO (Maybe [(ByteString, Word16)]))
-> Maybe [(ByteString, Word16)]
-> IO (Maybe [(ByteString, Word16)])
forall a b. (a -> b) -> a -> b
$ [(ByteString, Word16)] -> Maybe [(ByteString, Word16)]
forall a. a -> Maybe a
Just []
            Just [(Word16, Word16, Word16, ByteString)]
srvResult' -> do
                String -> String -> IO ()
debugM String
"Pontarius.Xmpp" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"SRV result: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([(Word16, Word16, Word16, ByteString)] -> String
forall a. Show a => a -> String
show [(Word16, Word16, Word16, ByteString)]
srvResult')
                -- Get [(Domain, PortNumber)] of SRV request, if any.
                [(Word16, Word16, Word16, ByteString)]
orderedSrvResult <- [(Word16, Word16, Word16, ByteString)]
-> IO [(Word16, Word16, Word16, ByteString)]
orderSrvResult [(Word16, Word16, Word16, ByteString)]
srvResult'
                Maybe [(ByteString, Word16)] -> IO (Maybe [(ByteString, Word16)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [(ByteString, Word16)] -> IO (Maybe [(ByteString, Word16)]))
-> Maybe [(ByteString, Word16)]
-> IO (Maybe [(ByteString, Word16)])
forall a b. (a -> b) -> a -> b
$ [(ByteString, Word16)] -> Maybe [(ByteString, Word16)]
forall a. a -> Maybe a
Just ([(ByteString, Word16)] -> Maybe [(ByteString, Word16)])
-> [(ByteString, Word16)] -> Maybe [(ByteString, Word16)]
forall a b. (a -> b) -> a -> b
$ ((Word16, Word16, Word16, ByteString) -> (ByteString, Word16))
-> [(Word16, Word16, Word16, ByteString)] -> [(ByteString, Word16)]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map (\(Word16
_, Word16
_, Word16
port, ByteString
domain) -> (ByteString
domain, Word16
port)) [(Word16, Word16, Word16, ByteString)]
orderedSrvResult
            -- The service is not available at this domain.
            -- Sorts the records based on the priority value.
            Maybe [(Word16, Word16, Word16, ByteString)]
Nothing -> do
                String -> String -> IO ()
debugM String
"Pontarius.Xmpp" String
"No SRV result returned."
                Maybe [(ByteString, Word16)] -> IO (Maybe [(ByteString, Word16)])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [(ByteString, Word16)]
forall a. Maybe a
Nothing
    case Either IOError (Maybe [(ByteString, Word16)])
result of
        Right Maybe [(ByteString, Word16)]
result' -> Either XmppFailure (Maybe [(ByteString, Word16)])
-> IO (Either XmppFailure (Maybe [(ByteString, Word16)]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure (Maybe [(ByteString, Word16)])
 -> IO (Either XmppFailure (Maybe [(ByteString, Word16)])))
-> Either XmppFailure (Maybe [(ByteString, Word16)])
-> IO (Either XmppFailure (Maybe [(ByteString, Word16)]))
forall a b. (a -> b) -> a -> b
$ Maybe [(ByteString, Word16)]
-> Either XmppFailure (Maybe [(ByteString, Word16)])
forall a b. b -> Either a b
Right Maybe [(ByteString, Word16)]
result'
        Left IOError
e -> Either XmppFailure (Maybe [(ByteString, Word16)])
-> IO (Either XmppFailure (Maybe [(ByteString, Word16)]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure (Maybe [(ByteString, Word16)])
 -> IO (Either XmppFailure (Maybe [(ByteString, Word16)])))
-> Either XmppFailure (Maybe [(ByteString, Word16)])
-> IO (Either XmppFailure (Maybe [(ByteString, Word16)]))
forall a b. (a -> b) -> a -> b
$ XmppFailure -> Either XmppFailure (Maybe [(ByteString, Word16)])
forall a b. a -> Either a b
Left (XmppFailure -> Either XmppFailure (Maybe [(ByteString, Word16)]))
-> XmppFailure -> Either XmppFailure (Maybe [(ByteString, Word16)])
forall a b. (a -> b) -> a -> b
$ IOError -> XmppFailure
XmppIOException IOError
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, ByteString)]
-> IO [(Word16, Word16, Word16, ByteString)]
orderSrvResult [(Word16, Word16, Word16, ByteString)]
srvResult = do
        -- Order the result set by priority.
        let srvResult' :: [(Word16, Word16, Word16, ByteString)]
srvResult' = ((Word16, Word16, Word16, ByteString)
 -> (Word16, Word16, Word16, ByteString) -> Ordering)
-> [(Word16, Word16, Word16, ByteString)]
-> [(Word16, Word16, Word16, ByteString)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Word16, Word16, Word16, ByteString) -> Word16)
-> (Word16, Word16, Word16, ByteString)
-> (Word16, Word16, Word16, ByteString)
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (\(Word16
priority, Word16
_, Word16
_, ByteString
_) -> Word16
priority)) [(Word16, Word16, Word16, ByteString)]
srvResult
        -- Group elements in sublists based on their priority. The
        -- type is `[[(Word16, Word16, Word16, Domain)]]'.
        let srvResult'' :: [[(Word16, Word16, Word16, ByteString)]]
srvResult'' = ((Word16, Word16, Word16, ByteString)
 -> (Word16, Word16, Word16, ByteString) -> Bool)
-> [(Word16, Word16, Word16, ByteString)]
-> [[(Word16, Word16, Word16, ByteString)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
Data.List.groupBy (\(Word16
priority, Word16
_, Word16
_, ByteString
_) (Word16
priority', Word16
_, Word16
_, ByteString
_) -> Word16
priority Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
priority') [(Word16, Word16, Word16, ByteString)]
srvResult' :: [[(Word16, Word16, Word16, Domain)]]
        -- For each sublist, put records with a weight of zero first.
        let srvResult''' :: [[(Word16, Word16, Word16, ByteString)]]
srvResult''' = ([(Word16, Word16, Word16, ByteString)]
 -> [(Word16, Word16, Word16, ByteString)])
-> [[(Word16, Word16, Word16, ByteString)]]
-> [[(Word16, Word16, Word16, ByteString)]]
forall a b. (a -> b) -> [a] -> [b]
Data.List.map (\[(Word16, Word16, Word16, ByteString)]
sublist -> let ([(Word16, Word16, Word16, ByteString)]
a, [(Word16, Word16, Word16, ByteString)]
b) = ((Word16, Word16, Word16, ByteString) -> Bool)
-> [(Word16, Word16, Word16, ByteString)]
-> ([(Word16, Word16, Word16, ByteString)],
    [(Word16, Word16, Word16, ByteString)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(Word16
_, Word16
weight, Word16
_, ByteString
_) -> Word16
weight Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
0) [(Word16, Word16, Word16, ByteString)]
sublist in [[(Word16, Word16, Word16, ByteString)]]
-> [(Word16, Word16, Word16, ByteString)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
Data.List.concat [[(Word16, Word16, Word16, ByteString)]
a, [(Word16, Word16, Word16, ByteString)]
b]) [[(Word16, Word16, Word16, ByteString)]]
srvResult''
        -- Order each sublist.
        [[(Word16, Word16, Word16, ByteString)]]
srvResult'''' <- ([(Word16, Word16, Word16, ByteString)]
 -> IO [(Word16, Word16, Word16, ByteString)])
-> [[(Word16, Word16, Word16, ByteString)]]
-> IO [[(Word16, Word16, Word16, ByteString)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [(Word16, Word16, Word16, ByteString)]
-> IO [(Word16, Word16, Word16, ByteString)]
orderSublist [[(Word16, Word16, Word16, ByteString)]]
srvResult'''
        -- Concatinated the results.
        [(Word16, Word16, Word16, ByteString)]
-> IO [(Word16, Word16, Word16, ByteString)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Word16, Word16, Word16, ByteString)]
 -> IO [(Word16, Word16, Word16, ByteString)])
-> [(Word16, Word16, Word16, ByteString)]
-> IO [(Word16, Word16, Word16, ByteString)]
forall a b. (a -> b) -> a -> b
$ [[(Word16, Word16, Word16, ByteString)]]
-> [(Word16, Word16, Word16, ByteString)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
Data.List.concat [[(Word16, Word16, Word16, ByteString)]]
srvResult''''
      where
        orderSublist :: [(Word16, Word16, Word16, Domain)] -> IO [(Word16, Word16, Word16, Domain)]
        orderSublist :: [(Word16, Word16, Word16, ByteString)]
-> IO [(Word16, Word16, Word16, ByteString)]
orderSublist [] = [(Word16, Word16, Word16, ByteString)]
-> IO [(Word16, Word16, Word16, ByteString)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        orderSublist [(Word16, Word16, Word16, ByteString)]
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, ByteString, Word16)]
sublist') = (Word16
 -> (Word16, Word16, Word16, ByteString)
 -> (Word16, (Word16, Word16, Word16, ByteString, Word16)))
-> Word16
-> [(Word16, Word16, Word16, ByteString)]
-> (Word16, [(Word16, Word16, Word16, ByteString, Word16)])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
Data.List.mapAccumL (\Word16
total' (Word16
priority, Word16
weight, Word16
port, ByteString
domain) -> (Word16
total' Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
weight, (Word16
priority, Word16
weight, Word16
port, ByteString
domain, Word16
total' Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
weight))) Word16
0 [(Word16, Word16, Word16, ByteString)]
sublist
            -- Choose a random number between 0 and the total sum
            -- (inclusive).
            Word16
randomNumber <- (Word16, Word16) -> IO Word16
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, ByteString, Word16)]
beginning, ((Word16
priority, Word16
weight, Word16
port, ByteString
domain, Word16
_):[(Word16, Word16, Word16, ByteString, Word16)]
end)) = ((Word16, Word16, Word16, ByteString, Word16) -> Bool)
-> [(Word16, Word16, Word16, ByteString, Word16)]
-> ([(Word16, Word16, Word16, ByteString, Word16)],
    [(Word16, Word16, Word16, ByteString, Word16)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
Data.List.break (\(Word16
_, Word16
_, Word16
_, ByteString
_, Word16
running) -> Word16
randomNumber Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word16
running) [(Word16, Word16, Word16, ByteString, Word16)]
sublist'
            -- Remove the running total number from the remaining
            -- elements.
            let sublist'' :: [(Word16, Word16, Word16, ByteString)]
sublist'' = ((Word16, Word16, Word16, ByteString, Word16)
 -> (Word16, Word16, Word16, ByteString))
-> [(Word16, Word16, Word16, ByteString, Word16)]
-> [(Word16, Word16, Word16, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
Data.List.map (\(Word16
priority', Word16
weight', Word16
port', ByteString
domain', Word16
_) -> (Word16
priority', Word16
weight', Word16
port', ByteString
domain')) ([[(Word16, Word16, Word16, ByteString, Word16)]]
-> [(Word16, Word16, Word16, ByteString, Word16)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
Data.List.concat [[(Word16, Word16, Word16, ByteString, Word16)]
beginning, [(Word16, Word16, Word16, ByteString, Word16)]
end])
            -- Repeat the ordering procedure on the remaining
            -- elements.
            [(Word16, Word16, Word16, ByteString)]
rest <- [(Word16, Word16, Word16, ByteString)]
-> IO [(Word16, Word16, Word16, ByteString)]
orderSublist [(Word16, Word16, Word16, ByteString)]
sublist''
            [(Word16, Word16, Word16, ByteString)]
-> IO [(Word16, Word16, Word16, ByteString)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Word16, Word16, Word16, ByteString)]
 -> IO [(Word16, Word16, Word16, ByteString)])
-> [(Word16, Word16, Word16, ByteString)]
-> IO [(Word16, Word16, Word16, ByteString)]
forall a b. (a -> b) -> a -> b
$ ((Word16
priority, Word16
weight, Word16
port, ByteString
domain)(Word16, Word16, Word16, ByteString)
-> [(Word16, Word16, Word16, ByteString)]
-> [(Word16, Word16, Word16, ByteString)]
forall a. a -> [a] -> [a]
:[(Word16, Word16, Word16, ByteString)]
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 = StateT StreamState IO (Either XmppFailure ())
-> Stream -> IO (Either XmppFailure ())
forall a. StateT StreamState IO a -> Stream -> IO a
withStream (StateT StreamState IO (Either XmppFailure ())
 -> Stream -> IO (Either XmppFailure ()))
-> StateT StreamState IO (Either XmppFailure ())
-> Stream
-> IO (Either XmppFailure ())
forall a b. (a -> b) -> a -> b
$ do
    IO ()
cc <- (StreamState -> IO ()) -> StateT StreamState IO (IO ())
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StreamHandle -> IO ()
streamClose (StreamHandle -> IO ())
-> (StreamState -> StreamHandle) -> StreamState -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamHandle
streamHandle)
    Either XmppFailure ()
err <- String -> IO () -> StateT StreamState IO (Either XmppFailure ())
forall (m :: * -> *) a.
MonadIO m =>
String -> IO a -> m (Either XmppFailure a)
wrapIOException String
"killStream" IO ()
cc
    -- (ExL.try cc :: IO (Either ExL.SomeException ()))
    StreamState -> StateT StreamState IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put StreamState
xmppNoStream{ streamConnectionState :: ConnectionState
streamConnectionState = ConnectionState
Finished }
    Either XmppFailure ()
-> StateT StreamState IO (Either XmppFailure ())
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 = ExceptT XmppFailure IO (Either IQError IQResult)
-> IO (Either XmppFailure (Either IQError IQResult))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XmppFailure IO (Either IQError IQResult)
 -> IO (Either XmppFailure (Either IQError IQResult)))
-> ExceptT XmppFailure IO (Either IQError IQResult)
-> IO (Either XmppFailure (Either IQError IQResult))
forall a b. (a -> b) -> a -> b
$ do
    IO (Either XmppFailure ()) -> ExceptT XmppFailure IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either XmppFailure ()) -> ExceptT XmppFailure IO ())
-> IO (Either XmppFailure ()) -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ Stanza -> Stream -> IO (Either XmppFailure ())
pushStanza
        (IQRequest -> Stanza
IQRequestS (IQRequest -> Stanza) -> IQRequest -> Stanza
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Jid
-> Maybe Jid
-> Maybe LangTag
-> IQRequestType
-> Element
-> [(Name, Text)]
-> IQRequest
IQRequest Text
iqID Maybe Jid
forall a. Maybe a
Nothing Maybe Jid
to Maybe LangTag
lang IQRequestType
tp Element
body []) Stream
stream
    Either XmppFailure Stanza
res <- IO (Either XmppFailure Stanza)
-> ExceptT XmppFailure IO (Either XmppFailure Stanza)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Either XmppFailure Stanza)
 -> ExceptT XmppFailure IO (Either XmppFailure Stanza))
-> IO (Either XmppFailure Stanza)
-> ExceptT XmppFailure IO (Either XmppFailure Stanza)
forall a b. (a -> b) -> a -> b
$ Stream -> IO (Either XmppFailure Stanza)
pullStanza Stream
stream
    case Either XmppFailure Stanza
res of
        Left XmppFailure
e -> XmppFailure -> ExceptT XmppFailure IO (Either IQError IQResult)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
e
        Right (IQErrorS IQError
e) -> Either IQError IQResult
-> ExceptT XmppFailure IO (Either IQError IQResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either IQError IQResult
 -> ExceptT XmppFailure IO (Either IQError IQResult))
-> Either IQError IQResult
-> ExceptT XmppFailure IO (Either IQError IQResult)
forall a b. (a -> b) -> a -> b
$ IQError -> Either IQError IQResult
forall a b. a -> Either a b
Left IQError
e
        Right (IQResultS IQResult
r) -> do
            Bool -> ExceptT XmppFailure IO () -> ExceptT XmppFailure IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
                (Text
iqID Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== IQResult -> Text
iqResultID IQResult
r) (ExceptT XmppFailure IO () -> ExceptT XmppFailure IO ())
-> ExceptT XmppFailure IO () -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> ExceptT XmppFailure IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XmppFailure IO ())
-> IO () -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ do
                    IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM String
"Pontarius.Xmpp" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"pushIQ: ID mismatch (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Text -> String
forall a. Show a => a -> String
show Text
iqID) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" /= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Text -> String
forall a. Show a => a -> String
show (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ IQResult -> Text
iqResultID IQResult
r) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")."
                    IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ XmppFailure -> IO ()
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) ++ " .")
            Either IQError IQResult
-> ExceptT XmppFailure IO (Either IQError IQResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either IQError IQResult
 -> ExceptT XmppFailure IO (Either IQError IQResult))
-> Either IQError IQResult
-> ExceptT XmppFailure IO (Either IQError IQResult)
forall a b. (a -> b) -> a -> b
$ IQResult -> Either IQError IQResult
forall a b. b -> Either a b
Right IQResult
r
        Either XmppFailure Stanza
_ -> do
                 IO () -> ExceptT XmppFailure IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT XmppFailure IO ())
-> IO () -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM String
"Pontarius.Xmpp" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"pushIQ: Unexpected stanza type."
                 XmppFailure -> ExceptT XmppFailure IO (Either IQError IQResult)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppOtherFailure

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

elements :: MonadError XmppFailure m => ConduitT Event Element m ()
elements :: ConduitT Event Element m ()
elements = do
        Maybe Event
x <- ConduitT Event Element m (Maybe Event)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await
        case Maybe Event
x of
            Just (EventBeginElement Name
n [(Name, [Content])]
as) -> do
                                                 Name -> [(Name, [Content])] -> ConduitT Event Element m Element
forall (m :: * -> *) o.
MonadError XmppFailure m =>
Name -> [(Name, [Content])] -> ConduitT Event o m Element
goE Name
n [(Name, [Content])]
as ConduitT Event Element m Element
-> (Element -> ConduitT Event Element m ())
-> ConduitT Event Element m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Element -> ConduitT Event Element m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield
                                                 ConduitT Event Element m ()
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{} -> XmppFailure -> ConduitT Event Element m ()
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 -> XmppFailure -> ConduitT Event Element m ()
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 ->
                ConduitT Event Element m ()
forall (m :: * -> *).
MonadError XmppFailure m =>
ConduitT Event Element m ()
elements
            Maybe Event
Nothing -> () -> ConduitT Event Element m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Maybe Event
_ -> XmppFailure -> ConduitT Event Element m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (XmppFailure -> ConduitT Event Element m ())
-> XmppFailure -> ConduitT Event Element m ()
forall a b. (a -> b) -> a -> b
$ String -> XmppFailure
XmppInvalidXml (String -> XmppFailure) -> String -> XmppFailure
forall a b. (a -> b) -> a -> b
$ String
"not an element: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe Event -> String
forall a. Show a => a -> String
show Maybe Event
x
  where
    many' :: m (Either a a) -> m (a, [a])
many' m (Either a a)
f =
        ([a] -> [a]) -> m (a, [a])
forall c. ([a] -> c) -> m (a, c)
go [a] -> [a]
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 -> (a, c) -> m (a, c)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, c) -> m (a, c)) -> (a, c) -> m (a, c)
forall a b. (a -> b) -> a -> b
$ (a
l, [a] -> c
front [])
                Right a
r -> ([a] -> c) -> m (a, c)
go ([a] -> c
front ([a] -> c) -> ([a] -> [a]) -> [a] -> c
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) <- ConduitT Event o m (Either (Maybe Event) Node)
-> ConduitT Event o m (Maybe Event, [Node])
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 Maybe Event -> Maybe Event -> Bool
forall a. Eq a => a -> a -> Bool
== Event -> Maybe Event
forall a. a -> Maybe a
Just (Name -> Event
EventEndElement Name
n)
            then Element -> ConduitT Event o m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> ConduitT Event o m Element)
-> Element -> ConduitT Event o m Element
forall a b. (a -> b) -> a -> b
$ Name -> [(Name, [Content])] -> [Node] -> Element
Element Name
n (((Name, [Content]) -> (Name, [Content]))
-> [(Name, [Content])] -> [(Name, [Content])]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Name
forall a. a -> a
id (Name -> Name)
-> ([Content] -> [Content])
-> (Name, [Content])
-> (Name, [Content])
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 XmppFailure -> ConduitT Event o m Element
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (XmppFailure -> ConduitT Event o m Element)
-> (String -> XmppFailure) -> String -> ConduitT Event o m Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> XmppFailure
XmppInvalidXml (String -> ConduitT Event o m Element)
-> String -> ConduitT Event o m Element
forall a b. (a -> b) -> a -> b
$ String
"Missing close tag: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n
    goN :: ConduitT Event o m (Either (Maybe Event) Node)
goN = do
        Maybe Event
x <- ConduitT Event o m (Maybe Event)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await
        case Maybe Event
x of
            Just (EventBeginElement Name
n [(Name, [Content])]
as) -> (Node -> Either (Maybe Event) Node
forall a b. b -> Either a b
Right (Node -> Either (Maybe Event) Node)
-> (Element -> Node) -> Element -> Either (Maybe Event) Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Node
NodeElement) (Element -> Either (Maybe Event) Node)
-> ConduitT Event o m Element
-> ConduitT Event o m (Either (Maybe Event) Node)
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) -> Either (Maybe Event) Node
-> ConduitT Event o m (Either (Maybe Event) Node)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Maybe Event) Node
 -> ConduitT Event o m (Either (Maybe Event) Node))
-> Either (Maybe Event) Node
-> ConduitT Event o m (Either (Maybe Event) Node)
forall a b. (a -> b) -> a -> b
$ Node -> Either (Maybe Event) Node
forall a b. b -> Either a b
Right (Node -> Either (Maybe Event) Node)
-> Node -> Either (Maybe Event) Node
forall a b. (a -> b) -> a -> b
$ Instruction -> Node
NodeInstruction Instruction
i
            Just (EventContent Content
c) -> Either (Maybe Event) Node
-> ConduitT Event o m (Either (Maybe Event) Node)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Maybe Event) Node
 -> ConduitT Event o m (Either (Maybe Event) Node))
-> Either (Maybe Event) Node
-> ConduitT Event o m (Either (Maybe Event) Node)
forall a b. (a -> b) -> a -> b
$ Node -> Either (Maybe Event) Node
forall a b. b -> Either a b
Right (Node -> Either (Maybe Event) Node)
-> Node -> Either (Maybe Event) Node
forall a b. (a -> b) -> a -> b
$ Content -> Node
NodeContent Content
c
            Just (EventComment Text
t) -> Either (Maybe Event) Node
-> ConduitT Event o m (Either (Maybe Event) Node)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Maybe Event) Node
 -> ConduitT Event o m (Either (Maybe Event) Node))
-> Either (Maybe Event) Node
-> ConduitT Event o m (Either (Maybe Event) Node)
forall a b. (a -> b) -> a -> b
$ Node -> Either (Maybe Event) Node
forall a b. b -> Either a b
Right (Node -> Either (Maybe Event) Node)
-> Node -> Either (Maybe Event) Node
forall a b. (a -> b) -> a -> b
$ Text -> Node
NodeComment Text
t
            Just (EventCDATA Text
t) -> Either (Maybe Event) Node
-> ConduitT Event o m (Either (Maybe Event) Node)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Maybe Event) Node
 -> ConduitT Event o m (Either (Maybe Event) Node))
-> Either (Maybe Event) Node
-> ConduitT Event o m (Either (Maybe Event) Node)
forall a b. (a -> b) -> a -> b
$ Node -> Either (Maybe Event) Node
forall a b. b -> Either a b
Right (Node -> Either (Maybe Event) Node)
-> Node -> Either (Maybe Event) Node
forall a b. (a -> b) -> a -> b
$ Content -> Node
NodeContent (Content -> Node) -> Content -> Node
forall a b. (a -> b) -> a -> b
$ Text -> Content
ContentText Text
t
            Maybe Event
_ -> Either (Maybe Event) Node
-> ConduitT Event o m (Either (Maybe Event) Node)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Maybe Event) Node
 -> ConduitT Event o m (Either (Maybe Event) Node))
-> Either (Maybe Event) Node
-> ConduitT Event o m (Either (Maybe Event) Node)
forall a b. (a -> b) -> a -> b
$ Maybe Event -> Either (Maybe Event) Node
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 ([Node] -> [Node]) -> [Node] -> [Node]
forall a b. (a -> b) -> a -> b
$ Content -> Node
NodeContent (Text -> Content
ContentText (Text -> Content) -> Text -> Content
forall a b. (a -> b) -> a -> b
$ Text
x Text -> Text -> Text
`Text.append` Text
y) Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: [Node]
z
    compressNodes (Node
x:[Node]
xs) = Node
x Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: [Node] -> [Node]
compressNodes [Node]
xs

    compressContents :: [Content] -> [Content]
    compressContents :: [Content] -> [Content]
compressContents [Content]
cs = [Text -> Content
ContentText (Text -> Content) -> Text -> Content
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.concat ((Content -> Text) -> [Content] -> [Text]
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 :: StateT StreamState IO a -> Stream -> IO a
withStream StateT StreamState IO a
action (Stream TMVar StreamState
stream) = IO StreamState
-> (StreamState -> IO ()) -> (StreamState -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Ex.bracketOnError
                                         (STM StreamState -> IO StreamState
forall a. STM a -> IO a
atomically (STM StreamState -> IO StreamState)
-> STM StreamState -> IO StreamState
forall a b. (a -> b) -> a -> b
$ TMVar StreamState -> STM StreamState
forall a. TMVar a -> STM a
takeTMVar TMVar StreamState
stream )
                                         (STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> (StreamState -> STM ()) -> StreamState -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar StreamState -> StreamState -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar StreamState
stream)
                                         (\StreamState
s -> do
                                               (a
r, StreamState
s') <- StateT StreamState IO a -> StreamState -> IO (a, StreamState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT StreamState IO a
action StreamState
s
                                               STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar StreamState -> StreamState -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar StreamState
stream StreamState
s'
                                               a -> IO a
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' :: StateT StreamState IO a -> Stream -> IO a
withStream' StateT StreamState IO a
action (Stream TMVar StreamState
stream) = do
    StreamState
stream_ <- STM StreamState -> IO StreamState
forall a. STM a -> IO a
atomically (STM StreamState -> IO StreamState)
-> STM StreamState -> IO StreamState
forall a b. (a -> b) -> a -> b
$ TMVar StreamState -> STM StreamState
forall a. TMVar a -> STM a
readTMVar TMVar StreamState
stream
    (a
r, StreamState
_) <- StateT StreamState IO a -> StreamState -> IO (a, StreamState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT StreamState IO a
action StreamState
stream_
    a -> IO a
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 (TMVar StreamState -> Stream)
-> IO (TMVar StreamState) -> IO Stream
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` STM (TMVar StreamState) -> IO (TMVar StreamState)
forall a. STM a -> IO a
atomically (StreamState -> STM (TMVar StreamState)
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 :: IO a -> IO (Either IOError a)
tryIOError IO a
f = IO (Either IOError a)
-> (IOError -> IO (Either IOError a)) -> IO (Either IOError a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Ex.catch (a -> Either IOError a
forall a b. b -> Either a b
Right (a -> Either IOError a) -> IO a -> IO (Either IOError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
f) (Either IOError a -> IO (Either IOError a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either IOError a -> IO (Either IOError a))
-> (IOError -> Either IOError a)
-> IOError
-> IO (Either IOError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Either IOError a
forall a b. a -> Either a b
Left)