{-# 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.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_ :: (Read a) => String -> Maybe a
readMaybe_ :: forall a. Read a => [Char] -> Maybe a
readMaybe_ [Char]
string = case forall a. Read a => ReadS a
reads [Char]
string of
[(a
a, [Char]
"")] -> forall a. a -> Maybe a
Just a
a
[(a, [Char])]
_ -> forall a. Maybe a
Nothing
mbl :: Maybe [a] -> [a]
mbl :: forall a. Maybe [a] -> [a]
mbl (Just [a]
l) = [a]
l
mbl Maybe [a]
Nothing = []
lmb :: [t] -> Maybe [t]
lmb :: forall t. [t] -> Maybe [t]
lmb [] = forall a. Maybe a
Nothing
lmb [t]
x = forall a. a -> Maybe a
Just [t]
x
streamUnpickleElem :: PU [Node] a
-> Element
-> StreamSink a
streamUnpickleElem :: forall a. PU [Node] a -> Element -> StreamSink a
streamUnpickleElem PU [Node] a
p Element
x = do
case forall a. PU [Node] a -> Element -> Either UnpickleError a
unpickleElem PU [Node] a
p Element
x of
Left UnpickleError
l -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
warningM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"streamUnpickleElem: Unpickle error: " forall a. [a] -> [a] -> [a]
++ UnpickleError -> [Char]
ppUnpickleError UnpickleError
l
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ XmppFailure
XmppOtherFailure
Right a
r -> forall (m :: * -> *) a. Monad m => a -> m a
return a
r
type StreamSink a = ConduitM Event Void (ExceptT XmppFailure IO) a
throwOutJunk :: Monad m => ConduitM Event a m ()
throwOutJunk :: forall (m :: * -> *) a. Monad m => ConduitM Event a m ()
throwOutJunk = do
Maybe Event
next <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.peek
case Maybe Event
next of
Maybe Event
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (EventBeginElement Name
_ [(Name, [Content])]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe Event
_ -> forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
CL.drop Int
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => ConduitM Event a m ()
throwOutJunk
openElementFromEvents :: StreamSink Element
openElementFromEvents :: StreamSink Element
openElementFromEvents = do
forall (m :: * -> *) a. Monad m => ConduitM Event a m ()
throwOutJunk
Maybe Event
hd <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
await
case Maybe Event
hd of
Just (EventBeginElement Name
name [(Name, [Content])]
attrs) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> [(Name, [Content])] -> [Node] -> Element
Element Name
name [(Name, [Content])]
attrs []
Maybe Event
_ -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
warningM [Char]
"Pontarius.Xmpp" [Char]
"openElementFromEvents: Stream ended."
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppOtherFailure
startStream :: StateT StreamState IO (Either XmppFailure ())
startStream :: StateT StreamState IO (Either XmppFailure ())
startStream = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Starting stream..."
StreamState
st <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => m s
get
let expectedTo :: Maybe Jid
expectedTo = case ( StreamState -> ConnectionState
streamConnectionState StreamState
st
, StreamConfiguration -> Maybe (Jid, Bool)
toJid forall a b. (a -> b) -> a -> b
$ StreamState -> StreamConfiguration
streamConfiguration StreamState
st) of
(ConnectionState
Plain , (Just (Jid
j, Bool
True))) -> forall a. a -> Maybe a
Just Jid
j
(ConnectionState
Plain , Maybe (Jid, Bool)
_ ) -> forall a. Maybe a
Nothing
(ConnectionState
Secured , (Just (Jid
j, Bool
_ ))) -> forall a. a -> Maybe a
Just Jid
j
(ConnectionState
Secured , Maybe (Jid, Bool)
Nothing ) -> forall a. Maybe a
Nothing
(ConnectionState
Closed , Maybe (Jid, Bool)
_ ) -> forall a. Maybe a
Nothing
(ConnectionState
Finished , Maybe (Jid, Bool)
_ ) -> forall a. Maybe a
Nothing
case StreamState -> Maybe Text
streamAddress StreamState
st of
Maybe Text
Nothing -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" [Char]
"Server sent no hostname."
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppOtherFailure
Just Text
address -> do
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ StateT StreamState IO (Either XmppFailure ())
pushXmlDecl
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> StateT StreamState IO (Either XmppFailure ())
pushOpenElement forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Element
streamNSHack forall a b. (a -> b) -> a -> b
$
forall a. PU [Node] a -> a -> Element
pickleElem PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
xpStream ( Text
"1.0"
, Maybe Jid
expectedTo
, forall a. a -> Maybe a
Just (Maybe NonemptyText -> NonemptyText -> Maybe NonemptyText -> Jid
Jid forall a. Maybe a
Nothing (Text -> NonemptyText
Nonempty Text
address) forall a. Maybe a
Nothing)
, forall a. Maybe a
Nothing
, StreamConfiguration -> Maybe LangTag
preferredLang forall a b. (a -> b) -> a -> b
$ StreamState -> StreamConfiguration
streamConfiguration StreamState
st
)
Either
Element
(Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
StreamFeatures)
response <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall b.
ConduitT Event Void (ExceptT XmppFailure IO) b
-> StateT StreamState IO (Either XmppFailure b)
runEventsSink forall a b. (a -> b) -> a -> b
$ Maybe Jid
-> StreamSink
(Either
Element
(Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
StreamFeatures))
streamS Maybe Jid
expectedTo
case Either
Element
(Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
StreamFeatures)
response of
Right (Text
ver, Maybe Jid
from, Maybe Jid
to, Maybe Text
sid, Maybe LangTag
lt, StreamFeatures
features)
| Text -> Maybe Version
versionFromText Text
ver forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing -> StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError
StreamErrorCondition
StreamUnsupportedVersion forall a. Maybe a
Nothing
[Char]
"Unspecified version"
| let v :: Maybe Version
v = Text -> Maybe Version
versionFromText Text
ver
in forall a. Maybe a -> Bool
isJust Maybe Version
v Bool -> Bool -> Bool
&& Version -> Integer
majorVersion (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Version
v) forall a. Ord a => a -> a -> Bool
>= Integer
2 ->
StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
StreamUnsupportedVersion forall a. Maybe a
Nothing
[Char]
"Non-1.x version"
| forall a. Maybe a -> Bool
isJust Maybe Jid
from Bool -> Bool -> Bool
&& (Maybe Jid
from forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just (Maybe NonemptyText -> NonemptyText -> Maybe NonemptyText -> Jid
Jid forall a. Maybe a
Nothing (Text -> NonemptyText
Nonempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ StreamState -> Maybe Text
streamAddress StreamState
st) forall a. Maybe a
Nothing)) ->
StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
StreamInvalidFrom forall a. Maybe a
Nothing
[Char]
"Stream from is invalid"
| Maybe Jid
to forall a. Eq a => a -> a -> Bool
/= Maybe Jid
expectedTo ->
StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
StreamUndefinedCondition (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> [(Name, [Content])] -> [Node] -> Element
Element Name
"invalid-to" [] [])
[Char]
"Stream to invalid"
| Bool
otherwise -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Maybe a -> Bool
isJust Maybe LangTag
lt) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
warningM [Char]
"Pontariusm.Xmpp"
[Char]
"Stream has no language tag"
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\StreamState
s -> StreamState
s{ streamFeatures :: StreamFeatures
streamFeatures = StreamFeatures
features
, streamLang :: Maybe LangTag
streamLang = Maybe LangTag
lt
, streamId :: Maybe Text
streamId = Maybe Text
sid
, streamFrom :: Maybe Jid
streamFrom = Maybe Jid
from
} )
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Left (Element Name
name [(Name, [Content])]
attrs [Node]
_children)
| (Name -> Text
nameLocalName Name
name forall a. Eq a => a -> a -> Bool
/= Text
"stream") ->
StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
StreamInvalidXml forall a. Maybe a
Nothing
[Char]
"Root element is not stream"
| (Name -> Maybe Text
nameNamespace Name
name forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Text
"http://etherx.jabber.org/streams") ->
StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
StreamInvalidNamespace forall a. Maybe a
Nothing
[Char]
"Wrong root element name space"
| (forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ Name -> Maybe Text
namePrefix Name
name) Bool -> Bool -> Bool
&& (forall a. HasCallStack => Maybe a -> a
fromJust (Name -> Maybe Text
namePrefix Name
name) forall a. Eq a => a -> a -> Bool
/= Text
"stream") ->
StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
StreamBadNamespacePrefix forall a. Maybe a
Nothing
[Char]
"Root name prefix set and not stream"
| Bool
otherwise -> forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ [(Name, Text)] -> StateT StreamState IO (Either XmppFailure ())
checkchildren ([(Name, [Content])] -> [(Name, Text)]
flattenAttrs [(Name, [Content])]
attrs)
where
streamNSHack :: Element -> Element
streamNSHack Element
e = Element
e{elementAttributes :: [(Name, [Content])]
elementAttributes = Element -> [(Name, [Content])]
elementAttributes Element
e
forall a. [a] -> [a] -> [a]
++ [( Name
"xmlns"
, [Text -> Content
ContentText Text
"jabber:client"])]}
closeStreamWithError :: StreamErrorCondition -> Maybe Element -> String
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError :: StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError StreamErrorCondition
sec Maybe Element
el [Char]
msg = do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> StateT StreamState IO (Either XmppFailure ())
pushElement forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PU [Node] a -> a -> Element
pickleElem PU [Node] StreamErrorInfo
xpStreamError
forall a b. (a -> b) -> a -> b
$ StreamErrorCondition
-> Maybe (Maybe LangTag, NonemptyText)
-> Maybe Element
-> StreamErrorInfo
StreamErrorInfo StreamErrorCondition
sec forall a. Maybe a
Nothing Maybe Element
el
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ StateT StreamState IO ()
closeStreams'
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"closeStreamWithError: " forall a. [a] -> [a] -> [a]
++ [Char]
msg
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppOtherFailure
checkchildren :: [(Name, Text)] -> StateT StreamState IO (Either XmppFailure ())
checkchildren [(Name, Text)]
children =
let to' :: Maybe Text
to' = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
"to" [(Name, Text)]
children
ver' :: Maybe Text
ver' = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
"version" [(Name, Text)]
children
xl :: Maybe Text
xl = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
xmlLang [(Name, Text)]
children
in case () of () | forall a. a -> Maybe a
Just forall a. Maybe a
Nothing forall a. Eq a => a -> a -> Bool
== forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Maybe Jid
jidFromText Maybe Text
to' ->
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError
StreamErrorCondition
StreamBadNamespacePrefix forall a. Maybe a
Nothing
[Char]
"stream to not a valid JID"
| forall a. Maybe a
Nothing forall a. Eq a => a -> a -> Bool
== Maybe Text
ver' ->
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError
StreamErrorCondition
StreamUnsupportedVersion forall a. Maybe a
Nothing
[Char]
"stream no version"
| forall a. a -> Maybe a
Just (forall a. Maybe a
Nothing :: Maybe LangTag) forall a. Eq a => a -> a -> Bool
== (forall {a}. Read a => Text -> Maybe a
safeRead forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
xl) ->
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError
StreamErrorCondition
StreamInvalidXml forall a. Maybe a
Nothing
[Char]
"stream no language tag"
| Bool
otherwise ->
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ StreamErrorCondition
-> Maybe Element
-> [Char]
-> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError
StreamErrorCondition
StreamBadFormat forall a. Maybe a
Nothing
[Char]
""
safeRead :: Text -> Maybe a
safeRead Text
x = case forall a. Read a => ReadS a
reads forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Text.unpack Text
x of
[] -> forall a. Maybe a
Nothing
((a
y,[Char]
_):[(a, [Char])]
_) -> forall a. a -> Maybe a
Just a
y
flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)]
flattenAttrs :: [(Name, [Content])] -> [(Name, Text)]
flattenAttrs [(Name, [Content])]
attrs = forall a b. (a -> b) -> [a] -> [b]
Prelude.map (\(Name
name, [Content]
cont) ->
( Name
name
, [Text] -> Text
Text.concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
Prelude.map Content -> Text
uncontentify [Content]
cont)
)
[(Name, [Content])]
attrs
where
uncontentify :: Content -> Text
uncontentify (ContentText Text
t) = Text
t
uncontentify Content
_ = Text
""
restartStream :: StateT StreamState IO (Either XmppFailure ())
restartStream :: StateT StreamState IO (Either XmppFailure ())
restartStream = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Restarting stream..."
StreamHandle
raw <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StreamState -> StreamHandle
streamHandle
let newSource :: ConduitT a Event m ()
newSource = forall (m :: * -> *) i.
(MonadIO m, MonadError XmppFailure m) =>
StreamHandle -> ConduitM i Domain m ()
sourceStreamHandle StreamHandle
raw forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
$= forall (m :: * -> *).
MonadThrow m =>
ParseSettings -> ConduitT Domain Event m ()
XP.parseBytes forall a. Default a => a
def
ConduitM () Event (ExceptT XmppFailure IO) ()
buffered <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o i.
ConduitT () o (ExceptT XmppFailure IO) ()
-> IO (ConduitM i o (ExceptT XmppFailure IO) ())
bufferSrc forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a}.
(MonadIO m, MonadError XmppFailure m, MonadThrow m) =>
ConduitT a Event m ()
newSource
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\StreamState
s -> StreamState
s{streamEventSource :: ConduitM () Event (ExceptT XmppFailure IO) ()
streamEventSource = ConduitM () Event (ExceptT XmppFailure IO) ()
buffered })
StateT StreamState IO (Either XmppFailure ())
startStream
sourceStreamHandleRaw :: (MonadIO m, MonadError XmppFailure m)
=> StreamHandle -> ConduitM i ByteString m ()
sourceStreamHandleRaw :: forall (m :: * -> *) i.
(MonadIO m, MonadError XmppFailure m) =>
StreamHandle -> ConduitM i Domain m ()
sourceStreamHandleRaw StreamHandle
s = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {m :: * -> *} {t} {e} {o} {i}.
(MonadIO m, Num t, MonadError e m) =>
(t -> IO (Either e o)) -> ConduitT i o m ()
read forall a b. (a -> b) -> a -> b
$ StreamHandle -> Int -> IO (Either XmppFailure Domain)
streamReceive StreamHandle
s
where
read :: (t -> IO (Either e o)) -> ConduitT i o m ()
read t -> IO (Either e o)
rd = do
Either e o
bs' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (t -> IO (Either e o)
rd t
4096)
o
bs <- case Either e o
bs' of
Left e
e -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
Right o
r -> forall (m :: * -> *) a. Monad m => a -> m a
return o
r
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield o
bs
sourceStreamHandle :: (MonadIO m, MonadError XmppFailure m)
=> StreamHandle -> ConduitM i ByteString m ()
sourceStreamHandle :: forall (m :: * -> *) i.
(MonadIO m, MonadError XmppFailure m) =>
StreamHandle -> ConduitM i Domain m ()
sourceStreamHandle StreamHandle
sh = forall (m :: * -> *) i.
(MonadIO m, MonadError XmppFailure m) =>
StreamHandle -> ConduitM i Domain m ()
sourceStreamHandleRaw StreamHandle
sh forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
$= forall (m :: * -> *). MonadIO m => ConduitM Domain Domain m ()
logInput
logInput :: MonadIO m => ConduitM ByteString ByteString m ()
logInput :: forall (m :: * -> *). MonadIO m => ConduitM Domain Domain m ()
logInput = forall {m :: * -> *}.
MonadIO m =>
Maybe (Domain -> Decoding) -> ConduitT Domain Domain m ()
go forall a. Maybe a
Nothing
where
go :: Maybe (Domain -> Decoding) -> ConduitT Domain Domain m ()
go Maybe (Domain -> Decoding)
mbDec = do
Maybe Domain
mbBs <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
await
case Maybe Domain
mbBs of
Maybe Domain
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Domain
bs -> do
let decode :: Domain -> Decoding
decode = case Maybe (Domain -> Decoding)
mbDec of
Maybe (Domain -> Decoding)
Nothing -> OnDecodeError -> Domain -> Decoding
Text.streamDecodeUtf8With OnDecodeError
Text.lenientDecode
Just Domain -> Decoding
d -> Domain -> Decoding
d
(Text.Some Text
out Domain
leftover Domain -> Decoding
cont) = Domain -> Decoding
decode Domain
bs
cont' :: Maybe (Domain -> Decoding)
cont' = if Domain -> Bool
BS.null Domain
leftover
then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just Domain -> Decoding
cont
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Text.null Text
out) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp"
forall a b. (a -> b) -> a -> b
$ [Char]
"in: " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Text.unpack Text
out
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Domain
bs
Maybe (Domain -> Decoding) -> ConduitT Domain Domain m ()
go Maybe (Domain -> Decoding)
cont'
bufferSrc :: ConduitT () o (ExceptT XmppFailure IO) ()
-> IO (ConduitM i o (ExceptT XmppFailure IO) ())
bufferSrc :: forall o i.
ConduitT () o (ExceptT XmppFailure IO) ()
-> IO (ConduitM i o (ExceptT XmppFailure IO) ())
bufferSrc ConduitT () o (ExceptT XmppFailure IO) ()
src = do
TMVar (SealedConduitT () o (ExceptT XmppFailure IO) ())
ref <- forall a. a -> IO (TMVar a)
newTMVarIO forall a b. (a -> b) -> a -> b
$ forall i o (m :: * -> *) r.
ConduitT i o m r -> SealedConduitT i o m r
DCI.sealConduitT ConduitT () o (ExceptT XmppFailure IO) ()
src
let go :: ConduitT i o m ()
go = do
Either XmppFailure (Maybe o)
dt <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Ex.bracketOnError
(forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> STM a
takeTMVar TMVar (SealedConduitT () o (ExceptT XmppFailure IO) ())
ref)
(\SealedConduitT () o (ExceptT XmppFailure IO) ()
_ -> forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TMVar a -> a -> STM ()
putTMVar TMVar (SealedConduitT () o (ExceptT XmppFailure IO) ())
ref forall a b. (a -> b) -> a -> b
$ forall {o}. SealedConduitT () o (ExceptT XmppFailure IO) ()
zeroResumableSource)
(\SealedConduitT () o (ExceptT XmppFailure IO) ()
s -> do
Either
XmppFailure
(SealedConduitT () o (ExceptT XmppFailure IO) (), Maybe o)
res <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (SealedConduitT () o (ExceptT XmppFailure IO) ()
s forall (m :: * -> *) a b.
Monad m =>
SealedConduitT () a m ()
-> ConduitT a Void m b -> m (SealedConduitT () a m (), b)
$$++ forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
await)
case Either
XmppFailure
(SealedConduitT () o (ExceptT XmppFailure IO) (), Maybe o)
res of
Left XmppFailure
e -> do
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar (SealedConduitT () o (ExceptT XmppFailure IO) ())
ref forall {o}. SealedConduitT () o (ExceptT XmppFailure IO) ()
zeroResumableSource
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left XmppFailure
e
Right (SealedConduitT () o (ExceptT XmppFailure IO) ()
s',Maybe o
b) -> do
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar (SealedConduitT () o (ExceptT XmppFailure IO) ())
ref SealedConduitT () o (ExceptT XmppFailure IO) ()
s'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Maybe o
b
)
case Either XmppFailure (Maybe o)
dt of
Left XmppFailure
e -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
e
Right Maybe o
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Right (Just o
d) -> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield o
d forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConduitT i o m ()
go
forall (m :: * -> *) a. Monad m => a -> m a
return forall {m :: * -> *} {i}.
(MonadIO m, MonadError XmppFailure m) =>
ConduitT i o m ()
go
where
zeroResumableSource :: SealedConduitT () o (ExceptT XmppFailure IO) ()
zeroResumableSource = forall i o (m :: * -> *) r.
ConduitT i o m r -> SealedConduitT i o m r
DCI.sealConduitT forall a. ConduitT () a (ExceptT XmppFailure IO) ()
zeroSource
streamS :: Maybe Jid -> StreamSink (Either Element ( Text
, Maybe Jid
, Maybe Jid
, Maybe Text
, Maybe LangTag
, StreamFeatures ))
streamS :: Maybe Jid
-> StreamSink
(Either
Element
(Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag,
StreamFeatures))
streamS Maybe Jid
_expectedTo = do
Either
Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
streamHeader <- StreamSink
(Either
Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag))
xmppStreamHeader
case Either
Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
streamHeader of
Right (Text
version, Maybe Jid
from, Maybe Jid
to, Maybe Text
sid, Maybe LangTag
lTag) -> do
StreamFeatures
features <- StreamSink StreamFeatures
xmppStreamFeatures
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (Text
version, Maybe Jid
from, Maybe Jid
to, Maybe Text
sid, Maybe LangTag
lTag, StreamFeatures
features)
Left Element
el -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Element
el
where
xmppStreamHeader :: StreamSink (Either Element (Text, Maybe Jid, Maybe Jid, Maybe Text.Text, Maybe LangTag))
xmppStreamHeader :: StreamSink
(Either
Element (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag))
xmppStreamHeader = do
forall (m :: * -> *) a. Monad m => ConduitM Event a m ()
throwOutJunk
Element
el <- StreamSink Element
openElementFromEvents
case forall a. PU [Node] a -> Element -> Either UnpickleError a
unpickleElem PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
xpStream Element
el of
Left UnpickleError
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Element
el
Right (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
r -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
r
xmppStreamFeatures :: StreamSink StreamFeatures
xmppStreamFeatures :: StreamSink StreamFeatures
xmppStreamFeatures = do
Maybe Element
e <- forall (m :: * -> *).
MonadError XmppFailure m =>
ConduitT Event Element m ()
elements forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
=$ forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
await
case Maybe Element
e of
Maybe Element
Nothing -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" [Char]
"streamS: Stream ended."
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppOtherFailure
Just Element
r -> forall a. PU [Node] a -> Element -> StreamSink a
streamUnpickleElem PU [Node] StreamFeatures
xpStreamFeatures Element
r
openStream :: HostName -> StreamConfiguration -> IO (Either XmppFailure (Stream))
openStream :: [Char] -> StreamConfiguration -> IO (Either XmppFailure Stream)
openStream [Char]
realm StreamConfiguration
config = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Opening stream..."
Stream
stream' <- [Char] -> StreamConfiguration -> ExceptT XmppFailure IO Stream
createStream [Char]
realm StreamConfiguration
config
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. StateT StreamState IO a -> Stream -> IO a
withStream StateT StreamState IO (Either XmppFailure ())
startStream Stream
stream'
forall (m :: * -> *) a. Monad m => a -> m a
return Stream
stream'
closeStreams :: Stream -> IO ()
closeStreams :: Stream -> IO ()
closeStreams = forall a. StateT StreamState IO a -> Stream -> IO a
withStream StateT StreamState IO ()
closeStreams'
closeStreams' :: StateT StreamState IO ()
closeStreams' :: StateT StreamState IO ()
closeStreams' = do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Closing stream"
Domain -> IO (Either XmppFailure ())
send <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StreamHandle -> Domain -> IO (Either XmppFailure ())
streamSend forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamHandle
streamHandle)
IO ()
cc <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StreamHandle -> IO ()
streamClose forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamHandle
streamHandle)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Sending closing tag"
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Domain -> IO (Either XmppFailure ())
send Domain
"</stream:stream>"
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Waiting for stream to close"
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
Int -> IO ()
threadDelay Int
3000000
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((forall e a. Exception e => IO a -> IO (Either e a)
Ex.try IO ()
cc) :: IO (Either Ex.SomeException ()))
forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put StreamState
xmppNoStream{ streamConnectionState :: ConnectionState
streamConnectionState = ConnectionState
Finished }
debugOut :: MonadIO m => ByteString -> m ()
debugOut :: forall (m :: * -> *). MonadIO m => Domain -> m ()
debugOut Domain
outData = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp"
([Char]
"Out: " forall a. [a] -> [a] -> [a]
++ (Text -> [Char]
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domain -> Text
Text.decodeUtf8 forall a b. (a -> b) -> a -> b
$ Domain
outData))
wrapIOException :: MonadIO m =>
String
-> IO a
-> m (Either XmppFailure a)
wrapIOException :: forall (m :: * -> *) a.
MonadIO m =>
[Char] -> IO a -> m (Either XmppFailure a)
wrapIOException [Char]
tag IO a
action = do
Either IOException a
r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Either IOException a)
tryIOError IO a
action
case Either IOException a
r of
Right a
b -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right a
b
Left IOException
e -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
warningM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"wrapIOException ("
, [Char]
tag
, [Char]
") : Exception wrapped: "
, forall a. Show a => a -> [Char]
show IOException
e
]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ IOException -> XmppFailure
XmppIOException IOException
e
pushElement :: Element -> StateT StreamState IO (Either XmppFailure ())
pushElement :: Element -> StateT StreamState IO (Either XmppFailure ())
pushElement Element
x = do
Domain -> IO (Either XmppFailure ())
send <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StreamHandle -> Domain -> IO (Either XmppFailure ())
streamSend forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamHandle
streamHandle)
let outData :: Domain
outData = Element -> Domain
renderElement forall a b. (a -> b) -> a -> b
$ Element -> Element
nsHack Element
x
forall (m :: * -> *). MonadIO m => Domain -> m ()
debugOut Domain
outData
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Domain -> IO (Either XmppFailure ())
send Domain
outData
nsHack :: Element -> Element
nsHack :: Element -> Element
nsHack e :: Element
e@(Element{elementName :: Element -> Name
elementName = Name
n})
| Name -> Maybe Text
nameNamespace Name
n forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
"jabber:client" =
Element
e{ elementName :: Name
elementName = Text -> Maybe Text -> Maybe Text -> Name
Name (Name -> Text
nameLocalName Name
n) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
, elementNodes :: [Node]
elementNodes = forall a b. (a -> b) -> [a] -> [b]
map Node -> Node
mapNSHack forall a b. (a -> b) -> a -> b
$ Element -> [Node]
elementNodes Element
e
}
| Bool
otherwise = Element
e
where
mapNSHack :: Node -> Node
mapNSHack :: Node -> Node
mapNSHack (NodeElement Element
el) = Element -> Node
NodeElement forall a b. (a -> b) -> a -> b
$ Element -> Element
nsHack Element
el
mapNSHack Node
nd = Node
nd
pushStanza :: Stanza -> Stream -> IO (Either XmppFailure ())
pushStanza :: Stanza -> Stream -> IO (Either XmppFailure ())
pushStanza Stanza
s = forall a. StateT StreamState IO a -> Stream -> IO a
withStream' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> StateT StreamState IO (Either XmppFailure ())
pushElement forall a b. (a -> b) -> a -> b
$ forall a. PU [Node] a -> a -> Element
pickleElem PU [Node] Stanza
xpStanza Stanza
s
pushXmlDecl :: StateT StreamState IO (Either XmppFailure ())
pushXmlDecl :: StateT StreamState IO (Either XmppFailure ())
pushXmlDecl = do
StreamHandle
con <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StreamState -> StreamHandle
streamHandle
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ StreamHandle -> Domain -> IO (Either XmppFailure ())
streamSend StreamHandle
con Domain
"<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
pushOpenElement :: Element -> StateT StreamState IO (Either XmppFailure ())
pushOpenElement :: Element -> StateT StreamState IO (Either XmppFailure ())
pushOpenElement Element
e = do
Domain -> IO (Either XmppFailure ())
send <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StreamHandle -> Domain -> IO (Either XmppFailure ())
streamSend forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamHandle
streamHandle)
let outData :: Domain
outData = Element -> Domain
renderOpenElement Element
e
forall (m :: * -> *). MonadIO m => Domain -> m ()
debugOut Domain
outData
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Domain -> IO (Either XmppFailure ())
send Domain
outData
runEventsSink :: ConduitT Event Void (ExceptT XmppFailure IO) b
-> StateT StreamState IO (Either XmppFailure b)
runEventsSink :: forall b.
ConduitT Event Void (ExceptT XmppFailure IO) b
-> StateT StreamState IO (Either XmppFailure b)
runEventsSink ConduitT Event Void (ExceptT XmppFailure IO) b
snk = do
ConduitM () Event (ExceptT XmppFailure IO) ()
src <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StreamState -> ConduitM () Event (ExceptT XmppFailure IO) ()
streamEventSource
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ ConduitM () Event (ExceptT XmppFailure IO) ()
src forall (m :: * -> *) a b.
Monad m =>
Source m a -> Sink a m b -> m b
$$ ConduitT Event Void (ExceptT XmppFailure IO) b
snk
pullElement :: StateT StreamState IO (Either XmppFailure Element)
pullElement :: StateT StreamState IO (Either XmppFailure Element)
pullElement = do
Either XmppFailure (Maybe Element)
e <- forall b.
ConduitT Event Void (ExceptT XmppFailure IO) b
-> StateT StreamState IO (Either XmppFailure b)
runEventsSink (forall (m :: * -> *).
MonadError XmppFailure m =>
ConduitT Event Element m ()
elements forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
=$ forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
await)
case Either XmppFailure (Maybe Element)
e of
Left XmppFailure
l -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$
[Char]
"Error while retrieving XML element: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show XmppFailure
l
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left XmppFailure
l
Right Maybe Element
Nothing -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" [Char]
"pullElement: Stream ended."
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ XmppFailure
XmppOtherFailure
Right (Just Element
r) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Element
r
pullUnpickle :: PU [Node] a -> StateT StreamState IO (Either XmppFailure a)
pullUnpickle :: forall a.
PU [Node] a -> StateT StreamState IO (Either XmppFailure a)
pullUnpickle PU [Node] a
p = do
Either XmppFailure Element
el <- StateT StreamState IO (Either XmppFailure Element)
pullElement
case Either XmppFailure Element
el of
Left XmppFailure
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left XmppFailure
e
Right Element
elem' -> do
let res :: Either UnpickleError a
res = forall a. PU [Node] a -> Element -> Either UnpickleError a
unpickleElem PU [Node] a
p Element
elem'
case Either UnpickleError a
res of
Left UnpickleError
e -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"pullUnpickle: Unpickle failed: " forall a. [a] -> [a] -> [a]
++ (UnpickleError -> [Char]
ppUnpickleError UnpickleError
e)
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ XmppFailure
XmppOtherFailure
Right a
r -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right a
r
pullStanza :: Stream -> IO (Either XmppFailure Stanza)
pullStanza :: Stream -> IO (Either XmppFailure Stanza)
pullStanza = forall a. StateT StreamState IO a -> Stream -> IO a
withStream' forall a b. (a -> b) -> a -> b
$ do
Either XmppFailure (Either StreamErrorInfo Stanza)
res <- forall a.
PU [Node] a -> StateT StreamState IO (Either XmppFailure a)
pullUnpickle PU [Node] (Either StreamErrorInfo Stanza)
xpStreamStanza
case Either XmppFailure (Either StreamErrorInfo Stanza)
res of
Left XmppFailure
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left XmppFailure
e
Right (Left StreamErrorInfo
e) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ StreamErrorInfo -> XmppFailure
StreamErrorFailure StreamErrorInfo
e
Right (Right Stanza
r) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Stanza
r
pullXmppElement :: Stream -> IO (Either XmppFailure XmppElement)
pullXmppElement :: Stream -> IO (Either XmppFailure XmppElement)
pullXmppElement = forall a. StateT StreamState IO a -> Stream -> IO a
withStream' forall a b. (a -> b) -> a -> b
$ do
Either XmppFailure (Either StreamErrorInfo XmppElement)
res <- forall a.
PU [Node] a -> StateT StreamState IO (Either XmppFailure a)
pullUnpickle PU [Node] (Either StreamErrorInfo XmppElement)
xpStreamElement
case Either XmppFailure (Either StreamErrorInfo XmppElement)
res of
Left XmppFailure
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left XmppFailure
e
Right (Left StreamErrorInfo
e) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ StreamErrorInfo -> XmppFailure
StreamErrorFailure StreamErrorInfo
e
Right (Right XmppElement
r) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right XmppElement
r
catchPush :: IO () -> IO (Either XmppFailure ())
catchPush :: IO () -> IO (Either XmppFailure ())
catchPush IO ()
p = forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
ExL.catch
(IO ()
p forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right ()))
(\IOException
e -> case IOException -> IOErrorType
GIE.ioe_type IOException
e of
IOErrorType
GIE.ResourceVanished -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ IOException -> XmppFailure
XmppIOException IOException
e
IOErrorType
GIE.IllegalOperation -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ IOException -> XmppFailure
XmppIOException IOException
e
IOErrorType
_ -> forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
ExL.throwIO IOException
e
)
zeroHandle :: StreamHandle
zeroHandle :: StreamHandle
zeroHandle = StreamHandle { streamSend :: Domain -> IO (Either XmppFailure ())
streamSend = \Domain
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left XmppFailure
XmppNoStream)
, streamReceive :: Int -> IO (Either XmppFailure Domain)
streamReceive = \Int
_ -> do
[Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp"
[Char]
"xmppNoStream: Stream is closed."
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left XmppFailure
XmppNoStream
, streamFlush :: IO ()
streamFlush = forall (m :: * -> *) a. Monad m => a -> m a
return ()
, streamClose :: IO ()
streamClose = forall (m :: * -> *) a. Monad m => a -> m a
return ()
}
xmppNoStream :: StreamState
xmppNoStream :: StreamState
xmppNoStream = StreamState {
streamConnectionState :: ConnectionState
streamConnectionState = ConnectionState
Closed
, streamHandle :: StreamHandle
streamHandle = StreamHandle
zeroHandle
, streamEventSource :: ConduitM () Event (ExceptT XmppFailure IO) ()
streamEventSource = forall a. ConduitT () a (ExceptT XmppFailure IO) ()
zeroSource
, streamFeatures :: StreamFeatures
streamFeatures = forall a. Monoid a => a
mempty
, streamAddress :: Maybe Text
streamAddress = forall a. Maybe a
Nothing
, streamFrom :: Maybe Jid
streamFrom = forall a. Maybe a
Nothing
, streamId :: Maybe Text
streamId = forall a. Maybe a
Nothing
, streamLang :: Maybe LangTag
streamLang = forall a. Maybe a
Nothing
, streamJid :: Maybe Jid
streamJid = forall a. Maybe a
Nothing
, streamConfiguration :: StreamConfiguration
streamConfiguration = forall a. Default a => a
def
}
zeroSource :: ConduitT () a (ExceptT XmppFailure IO) ()
zeroSource :: forall a. ConduitT () a (ExceptT XmppFailure IO) ()
zeroSource = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"zeroSource"
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppNoStream
handleToStreamHandle :: Handle -> StreamHandle
handleToStreamHandle :: Handle -> StreamHandle
handleToStreamHandle Handle
h = StreamHandle { streamSend :: Domain -> IO (Either XmppFailure ())
streamSend = \Domain
d ->
forall (m :: * -> *) a.
MonadIO m =>
[Char] -> IO a -> m (Either XmppFailure a)
wrapIOException [Char]
"streamSend"
forall a b. (a -> b) -> a -> b
$ Handle -> Domain -> IO ()
BS.hPut Handle
h Domain
d
, streamReceive :: Int -> IO (Either XmppFailure Domain)
streamReceive = \Int
n ->
forall (m :: * -> *) a.
MonadIO m =>
[Char] -> IO a -> m (Either XmppFailure a)
wrapIOException [Char]
"streamReceive"
forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO Domain
BS.hGetSome Handle
h Int
n
, streamFlush :: IO ()
streamFlush = Handle -> IO ()
hFlush Handle
h
, streamClose :: IO ()
streamClose = Handle -> IO ()
hClose Handle
h
}
createStream :: HostName -> StreamConfiguration -> ExceptT XmppFailure IO (Stream)
createStream :: [Char] -> StreamConfiguration -> ExceptT XmppFailure IO Stream
createStream [Char]
realm StreamConfiguration
config = do
Maybe StreamHandle
result <- [Char]
-> StreamConfiguration
-> ExceptT XmppFailure IO (Maybe StreamHandle)
connect [Char]
realm StreamConfiguration
config
case Maybe StreamHandle
result of
Just StreamHandle
hand -> forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ do
[Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Acquired handle."
[Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Setting NoBuffering mode on handle."
ConduitM () Event (ExceptT XmppFailure IO) ()
eSource <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o i.
ConduitT () o (ExceptT XmppFailure IO) ()
-> IO (ConduitM i o (ExceptT XmppFailure IO) ())
bufferSrc forall a b. (a -> b) -> a -> b
$
(forall (m :: * -> *) i.
(MonadIO m, MonadError XmppFailure m) =>
StreamHandle -> ConduitM i Domain m ()
sourceStreamHandle StreamHandle
hand forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
$= forall (m :: * -> *). MonadIO m => ConduitM Domain Domain m ()
logConduit)
forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
$= forall (m :: * -> *).
MonadThrow m =>
ParseSettings -> ConduitT Domain Event m ()
XP.parseBytes forall a. Default a => a
def
let stream :: StreamState
stream = StreamState
{ streamConnectionState :: ConnectionState
streamConnectionState = ConnectionState
Plain
, streamHandle :: StreamHandle
streamHandle = StreamHandle
hand
, streamEventSource :: ConduitM () Event (ExceptT XmppFailure IO) ()
streamEventSource = ConduitM () Event (ExceptT XmppFailure IO) ()
eSource
, streamFeatures :: StreamFeatures
streamFeatures = forall a. Monoid a => a
mempty
, streamAddress :: Maybe Text
streamAddress = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Text
Text.pack [Char]
realm
, streamFrom :: Maybe Jid
streamFrom = forall a. Maybe a
Nothing
, streamId :: Maybe Text
streamId = forall a. Maybe a
Nothing
, streamLang :: Maybe LangTag
streamLang = forall a. Maybe a
Nothing
, streamJid :: Maybe Jid
streamJid = forall a. Maybe a
Nothing
, streamConfiguration :: StreamConfiguration
streamConfiguration = [Char] -> StreamConfiguration -> StreamConfiguration
maybeSetTlsHost [Char]
realm StreamConfiguration
config
}
Stream
stream' <- StreamState -> IO Stream
mkStream StreamState
stream
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Stream
stream'
Maybe StreamHandle
Nothing -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Did not acquire handle."
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
TcpConnectionFailure
where
logConduit :: MonadIO m => ConduitT ByteString ByteString m ()
logConduit :: forall (m :: * -> *). MonadIO m => ConduitM Domain Domain m ()
logConduit = forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
CL.mapM forall a b. (a -> b) -> a -> b
$ \Domain
d -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"In: " forall a. [a] -> [a] -> [a]
++ (Domain -> [Char]
BSC8.unpack Domain
d) forall a. [a] -> [a] -> [a]
++
[Char]
"."
forall (m :: * -> *) a. Monad m => a -> m a
return Domain
d
tlsIdentL :: (([Char], Domain) -> f ([Char], Domain))
-> StreamConfiguration -> f StreamConfiguration
tlsIdentL = Lens StreamConfiguration ClientParams
L.tlsParamsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens ClientParams ([Char], Domain)
L.clientServerIdentificationL
updateHost :: a -> (a, b) -> (a, b)
updateHost a
host (a
"", b
_) = (a
host, b
"")
updateHost a
_ (a, b)
hst = (a, b)
hst
maybeSetTlsHost :: [Char] -> StreamConfiguration -> StreamConfiguration
maybeSetTlsHost [Char]
host = forall s t a b. Setter s t a b -> (a -> b) -> s -> t
over forall {f :: * -> *}.
Functor f =>
(([Char], Domain) -> f ([Char], Domain))
-> StreamConfiguration -> f StreamConfiguration
tlsIdentL (forall {a} {b}.
(Eq a, IsString a, IsString b) =>
a -> (a, b) -> (a, b)
updateHost [Char]
host)
connect :: HostName -> StreamConfiguration -> ExceptT XmppFailure IO
(Maybe StreamHandle)
connect :: [Char]
-> StreamConfiguration
-> ExceptT XmppFailure IO (Maybe StreamHandle)
connect [Char]
realm StreamConfiguration
config = do
case StreamConfiguration -> ConnectionDetails
connectionDetails StreamConfiguration
config of
UseHost [Char]
host PortNumber
port -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
[Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Connecting to configured address."
Maybe Handle
h <- [Char] -> PortNumber -> IO (Maybe Handle)
resolveAndConnectTcp [Char]
host PortNumber
port
case Maybe Handle
h of
Maybe Handle
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just Handle
h' -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
h' BufferMode
NoBuffering
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Handle -> StreamHandle
handleToStreamHandle Handle
h'
UseSrv [Char]
host -> do
Maybe Handle
h <- ResolvConf -> [Char] -> ExceptT XmppFailure IO (Maybe Handle)
connectSrv (StreamConfiguration -> ResolvConf
resolvConf StreamConfiguration
config) [Char]
host
case Maybe Handle
h of
Maybe Handle
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just Handle
h' -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
h' BufferMode
NoBuffering
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Handle -> StreamHandle
handleToStreamHandle Handle
h'
ConnectionDetails
UseRealm -> do
Maybe Handle
h <- ResolvConf -> [Char] -> ExceptT XmppFailure IO (Maybe Handle)
connectSrv (StreamConfiguration -> ResolvConf
resolvConf StreamConfiguration
config) [Char]
realm
case Maybe Handle
h of
Maybe Handle
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just Handle
h' -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
h' BufferMode
NoBuffering
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Handle -> StreamHandle
handleToStreamHandle Handle
h'
UseConnection ExceptT XmppFailure IO StreamHandle
mkC -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT XmppFailure IO StreamHandle
mkC
connectSrv :: ResolvConf -> String -> ExceptT XmppFailure IO (Maybe Handle)
connectSrv :: ResolvConf -> [Char] -> ExceptT XmppFailure IO (Maybe Handle)
connectSrv ResolvConf
config [Char]
host = do
case Text -> Maybe Text
checkHostName ([Char] -> Text
Text.pack [Char]
host) of
Just Text
host' -> do
ResolvSeed
resolvSeed <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ ResolvConf -> IO ResolvSeed
makeResolvSeed ResolvConf
config
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Performing SRV lookup..."
Maybe [(Domain, Word16)]
srvRecords <- Text
-> ResolvSeed -> ExceptT XmppFailure IO (Maybe [(Domain, Word16)])
srvLookup Text
host' ResolvSeed
resolvSeed
case Maybe [(Domain, Word16)]
srvRecords of
Maybe [(Domain, Word16)]
Nothing -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp"
[Char]
"No SRV records, using fallback process."
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> PortNumber -> IO (Maybe Handle)
resolveAndConnectTcp [Char]
host PortNumber
5222
Just [(Domain
".", Word16
_)] -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
infoM [Char]
"Pontarius.Xmpp"
[Char]
"SRV lookup returned \".\"; service not available"
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
TcpConnectionFailure
Just [(Domain, Word16)]
srvRecords' -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp"
[Char]
"SRV records found, looking up host."
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [([Char], PortNumber)] -> IO (Maybe Handle)
resolvSrvsAndConnectTcp
( forall {f :: * -> *} {a} {b}. Functor f => f a -> (a -> b) -> f b
for [(Domain, Word16)]
srvRecords' forall a b. (a -> b) -> a -> b
$
\(Domain
domain, Word16
port) -> ( Domain -> [Char]
BSC8.unpack Domain
domain
, forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
port))
Maybe Text
Nothing -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp"
[Char]
"The hostname could not be validated."
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppIllegalTcpDetails
where for :: f a -> (a -> b) -> f b
for = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
connectHandle :: AddrInfo -> IO Handle
connectHandle :: AddrInfo -> IO Handle
connectHandle AddrInfo
addrInfo = do
Socket
s <- Family -> SocketType -> ProtocolNumber -> IO Socket
S.socket (AddrInfo -> Family
S.addrFamily AddrInfo
addrInfo) SocketType
S.Stream ProtocolNumber
S.defaultProtocol
Socket -> SockAddr -> IO ()
S.connect Socket
s (AddrInfo -> SockAddr
S.addrAddress AddrInfo
addrInfo)
Socket -> IOMode -> IO Handle
S.socketToHandle Socket
s IOMode
ReadWriteMode
connectTcp :: [AddrInfo] -> IO (Maybe Handle)
connectTcp :: [AddrInfo] -> IO (Maybe Handle)
connectTcp [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
connectTcp (AddrInfo
addrInfo:[AddrInfo]
remainder) = do
let addr :: [Char]
addr = (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ AddrInfo -> SockAddr
S.addrAddress AddrInfo
addrInfo)
Either IOException Handle
result <- forall e a. Exception e => IO a -> IO (Either e a)
Ex.try forall a b. (a -> b) -> a -> b
$ (do
[Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"Connecting to " forall a. [a] -> [a] -> [a]
++ [Char]
addr
AddrInfo -> IO Handle
connectHandle AddrInfo
addrInfo) :: IO (Either Ex.IOException Handle)
case Either IOException Handle
result of
Right Handle
handle -> do
[Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"Successfully connected to " forall a. [a] -> [a] -> [a]
++ [Char]
addr
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Handle
handle
Left IOException
_ -> do
[Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$
[Char]
"Connection to " forall a. [a] -> [a] -> [a]
++ [Char]
addr forall a. [a] -> [a] -> [a]
++ [Char]
" could not be established."
[AddrInfo] -> IO (Maybe Handle)
connectTcp [AddrInfo]
remainder
#if MIN_VERSION_dns(1, 0, 0)
fixDnsResult :: Either e a -> Maybe a
fixDnsResult :: forall e a. Either e a -> Maybe a
fixDnsResult = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just
#else
fixDnsResult :: Maybe a -> Maybe a
fixDnsResult = id
#endif
resolveAndConnectTcp :: HostName -> PortNumber -> IO (Maybe Handle)
resolveAndConnectTcp :: [Char] -> PortNumber -> IO (Maybe Handle)
resolveAndConnectTcp [Char]
hostName PortNumber
port = do
[AddrInfo]
ais <- Maybe AddrInfo -> Maybe [Char] -> Maybe [Char] -> IO [AddrInfo]
S.getAddrInfo forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just [Char]
hostName) forall a. Maybe a
Nothing
[AddrInfo] -> IO (Maybe Handle)
connectTcp forall a b. (a -> b) -> a -> b
$ AddrInfo -> AddrInfo
setPort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AddrInfo]
ais
where
setPort :: AddrInfo -> AddrInfo
setPort AddrInfo
ai = AddrInfo
ai {addrAddress :: SockAddr
S.addrAddress = PortNumber -> SockAddr -> SockAddr
setAddressPort PortNumber
port (AddrInfo -> SockAddr
S.addrAddress AddrInfo
ai)}
setAddressPort :: PortNumber -> SockAddr -> SockAddr
setAddressPort PortNumber
port (S.SockAddrInet PortNumber
_ HostAddress
addr) = PortNumber -> HostAddress -> SockAddr
S.SockAddrInet PortNumber
port HostAddress
addr
setAddressPort PortNumber
port (S.SockAddrInet6 PortNumber
_ HostAddress
flow HostAddress6
addr HostAddress
scope) =
PortNumber
-> HostAddress -> HostAddress6 -> HostAddress -> SockAddr
S.SockAddrInet6 PortNumber
port HostAddress
flow HostAddress6
addr HostAddress
scope
setAddressPort PortNumber
_ SockAddr
addr = SockAddr
addr
resolvSrvsAndConnectTcp :: [(HostName, PortNumber)] -> IO (Maybe Handle)
resolvSrvsAndConnectTcp :: [([Char], PortNumber)] -> IO (Maybe Handle)
resolvSrvsAndConnectTcp [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
resolvSrvsAndConnectTcp (([Char]
domain, PortNumber
port):[([Char], PortNumber)]
remaining) = do
Maybe Handle
result <- [Char] -> PortNumber -> IO (Maybe Handle)
resolveAndConnectTcp [Char]
domain PortNumber
port
case Maybe Handle
result of
Just Handle
handle -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Handle
handle
Maybe Handle
Nothing -> [([Char], PortNumber)] -> IO (Maybe Handle)
resolvSrvsAndConnectTcp [([Char], PortNumber)]
remaining
rethrowErrorCall :: IO a -> IO a
rethrowErrorCall :: forall a. IO a -> IO a
rethrowErrorCall IO a
action = do
Either ErrorCall a
result <- forall e a. Exception e => IO a -> IO (Either e a)
Ex.try IO a
action
case Either ErrorCall a
result of
Right a
result' -> forall (m :: * -> *) a. Monad m => a -> m a
return a
result'
Left (Ex.ErrorCall [Char]
e) -> forall a. IOException -> IO a
Ex.ioError forall a b. (a -> b) -> a -> b
$ [Char] -> IOException
userError
forall a b. (a -> b) -> a -> b
$ [Char]
"rethrowErrorCall: " forall a. [a] -> [a] -> [a]
++ [Char]
e
srvLookup :: Text -> ResolvSeed -> ExceptT XmppFailure IO (Maybe [(Domain, Word16)])
srvLookup :: Text
-> ResolvSeed -> ExceptT XmppFailure IO (Maybe [(Domain, Word16)])
srvLookup Text
realm ResolvSeed
resolvSeed = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ do
Either IOException (Maybe [(Domain, Word16)])
result <- forall e a. Exception e => IO a -> IO (Either e a)
Ex.try forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
rethrowErrorCall forall a b. (a -> b) -> a -> b
$ forall a. ResolvSeed -> (Resolver -> IO a) -> IO a
withResolver ResolvSeed
resolvSeed
forall a b. (a -> b) -> a -> b
$ \Resolver
resolver -> do
Either DNSError [(Word16, Word16, Word16, Domain)]
srvResult <- Resolver
-> Domain
-> IO (Either DNSError [(Word16, Word16, Word16, Domain)])
lookupSRV Resolver
resolver forall a b. (a -> b) -> a -> b
$ [Char] -> Domain
BSC8.pack forall a b. (a -> b) -> a -> b
$ [Char]
"_xmpp-client._tcp." forall a. [a] -> [a] -> [a]
++ (Text -> [Char]
Text.unpack Text
realm) forall a. [a] -> [a] -> [a]
++ [Char]
"."
case forall e a. Either e a -> Maybe a
fixDnsResult Either DNSError [(Word16, Word16, Word16, Domain)]
srvResult of
Just [] -> do
[Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"No SRV result returned."
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just [(Word16
_, Word16
_, Word16
_, Domain
".")] -> do
[Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"\".\" SRV result returned."
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just []
Just [(Word16, Word16, Word16, Domain)]
srvResult' -> do
[Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"SRV result: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show [(Word16, Word16, Word16, Domain)]
srvResult')
[(Word16, Word16, Word16, Domain)]
orderedSrvResult <- [(Word16, Word16, Word16, Domain)]
-> IO [(Word16, Word16, Word16, Domain)]
orderSrvResult [(Word16, Word16, Word16, Domain)]
srvResult'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
Prelude.map (\(Word16
_, Word16
_, Word16
port, Domain
domain) -> (Domain
domain, Word16
port)) [(Word16, Word16, Word16, Domain)]
orderedSrvResult
Maybe [(Word16, Word16, Word16, Domain)]
Nothing -> do
[Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"No SRV result returned."
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
case Either IOException (Maybe [(Domain, Word16)])
result of
Right Maybe [(Domain, Word16)]
result' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Maybe [(Domain, Word16)]
result'
Left IOException
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ IOException -> XmppFailure
XmppIOException IOException
e
where
orderSrvResult :: [(Word16, Word16, Word16, Domain)] -> IO [(Word16, Word16, Word16, Domain)]
orderSrvResult :: [(Word16, Word16, Word16, Domain)]
-> IO [(Word16, Word16, Word16, Domain)]
orderSrvResult [(Word16, Word16, Word16, Domain)]
srvResult = do
let srvResult' :: [(Word16, Word16, Word16, Domain)]
srvResult' = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (\(Word16
priority, Word16
_, Word16
_, Domain
_) -> Word16
priority)) [(Word16, Word16, Word16, Domain)]
srvResult
let srvResult'' :: [[(Word16, Word16, Word16, Domain)]]
srvResult'' = forall a. (a -> a -> Bool) -> [a] -> [[a]]
Data.List.groupBy (\(Word16
priority, Word16
_, Word16
_, Domain
_) (Word16
priority', Word16
_, Word16
_, Domain
_) -> Word16
priority forall a. Eq a => a -> a -> Bool
== Word16
priority') [(Word16, Word16, Word16, Domain)]
srvResult' :: [[(Word16, Word16, Word16, Domain)]]
let srvResult''' :: [[(Word16, Word16, Word16, Domain)]]
srvResult''' = forall a b. (a -> b) -> [a] -> [b]
Data.List.map (\[(Word16, Word16, Word16, Domain)]
sublist -> let ([(Word16, Word16, Word16, Domain)]
a, [(Word16, Word16, Word16, Domain)]
b) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(Word16
_, Word16
weight, Word16
_, Domain
_) -> Word16
weight forall a. Eq a => a -> a -> Bool
== Word16
0) [(Word16, Word16, Word16, Domain)]
sublist in forall (t :: * -> *) a. Foldable t => t [a] -> [a]
Data.List.concat [[(Word16, Word16, Word16, Domain)]
a, [(Word16, Word16, Word16, Domain)]
b]) [[(Word16, Word16, Word16, Domain)]]
srvResult''
[[(Word16, Word16, Word16, Domain)]]
srvResult'''' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [(Word16, Word16, Word16, Domain)]
-> IO [(Word16, Word16, Word16, Domain)]
orderSublist [[(Word16, Word16, Word16, Domain)]]
srvResult'''
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
Data.List.concat [[(Word16, Word16, Word16, Domain)]]
srvResult''''
where
orderSublist :: [(Word16, Word16, Word16, Domain)] -> IO [(Word16, Word16, Word16, Domain)]
orderSublist :: [(Word16, Word16, Word16, Domain)]
-> IO [(Word16, Word16, Word16, Domain)]
orderSublist [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
orderSublist [(Word16, Word16, Word16, Domain)]
sublist = do
let (Word16
total, [(Word16, Word16, Word16, Domain, Word16)]
sublist') = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
Data.List.mapAccumL (\Word16
total' (Word16
priority, Word16
weight, Word16
port, Domain
domain) -> (Word16
total' forall a. Num a => a -> a -> a
+ Word16
weight, (Word16
priority, Word16
weight, Word16
port, Domain
domain, Word16
total' forall a. Num a => a -> a -> a
+ Word16
weight))) Word16
0 [(Word16, Word16, Word16, Domain)]
sublist
Word16
randomNumber <- forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Word16
0, Word16
total)
let ([(Word16, Word16, Word16, Domain, Word16)]
beginning, ((Word16
priority, Word16
weight, Word16
port, Domain
domain, Word16
_):[(Word16, Word16, Word16, Domain, Word16)]
end)) = forall a. (a -> Bool) -> [a] -> ([a], [a])
Data.List.break (\(Word16
_, Word16
_, Word16
_, Domain
_, Word16
running) -> Word16
randomNumber forall a. Ord a => a -> a -> Bool
<= Word16
running) [(Word16, Word16, Word16, Domain, Word16)]
sublist'
let sublist'' :: [(Word16, Word16, Word16, Domain)]
sublist'' = forall a b. (a -> b) -> [a] -> [b]
Data.List.map (\(Word16
priority', Word16
weight', Word16
port', Domain
domain', Word16
_) -> (Word16
priority', Word16
weight', Word16
port', Domain
domain')) (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
Data.List.concat [[(Word16, Word16, Word16, Domain, Word16)]
beginning, [(Word16, Word16, Word16, Domain, Word16)]
end])
[(Word16, Word16, Word16, Domain)]
rest <- [(Word16, Word16, Word16, Domain)]
-> IO [(Word16, Word16, Word16, Domain)]
orderSublist [(Word16, Word16, Word16, Domain)]
sublist''
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ((Word16
priority, Word16
weight, Word16
port, Domain
domain)forall a. a -> [a] -> [a]
:[(Word16, Word16, Word16, Domain)]
rest)
killStream :: Stream -> IO (Either XmppFailure ())
killStream :: Stream -> IO (Either XmppFailure ())
killStream = forall a. StateT StreamState IO a -> Stream -> IO a
withStream forall a b. (a -> b) -> a -> b
$ do
IO ()
cc <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StreamHandle -> IO ()
streamClose forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamHandle
streamHandle)
Either XmppFailure ()
err <- forall (m :: * -> *) a.
MonadIO m =>
[Char] -> IO a -> m (Either XmppFailure a)
wrapIOException [Char]
"killStream" IO ()
cc
forall s (m :: * -> *). MonadState s m => s -> m ()
put StreamState
xmppNoStream{ streamConnectionState :: ConnectionState
streamConnectionState = ConnectionState
Finished }
forall (m :: * -> *) a. Monad m => a -> m a
return Either XmppFailure ()
err
pushIQ :: Text
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> Stream
-> IO (Either XmppFailure (Either IQError IQResult))
pushIQ :: Text
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> Stream
-> IO (Either XmppFailure (Either IQError IQResult))
pushIQ Text
iqID Maybe Jid
to IQRequestType
tp Maybe LangTag
lang Element
body Stream
stream = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ Stanza -> Stream -> IO (Either XmppFailure ())
pushStanza
(IQRequest -> Stanza
IQRequestS forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Jid
-> Maybe Jid
-> Maybe LangTag
-> IQRequestType
-> Element
-> [(Name, Text)]
-> IQRequest
IQRequest Text
iqID forall a. Maybe a
Nothing Maybe Jid
to Maybe LangTag
lang IQRequestType
tp Element
body []) Stream
stream
Either XmppFailure Stanza
res <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Stream -> IO (Either XmppFailure Stanza)
pullStanza Stream
stream
case Either XmppFailure Stanza
res of
Left XmppFailure
e -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
e
Right (IQErrorS IQError
e) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left IQError
e
Right (IQResultS IQResult
r) -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
(Text
iqID forall a. Eq a => a -> a -> Bool
== IQResult -> Text
iqResultID IQResult
r) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"pushIQ: ID mismatch (" forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show Text
iqID) forall a. [a] -> [a] -> [a]
++ [Char]
" /= " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ IQResult -> Text
iqResultID IQResult
r) forall a. [a] -> [a] -> [a]
++ [Char]
")."
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
ExL.throwIO XmppFailure
XmppOtherFailure
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right IQResult
r
Either XmppFailure Stanza
_ -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"pushIQ: Unexpected stanza type."
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppOtherFailure
debugConduit :: (Show o, MonadIO m) => ConduitM o o m b
debugConduit :: forall o (m :: * -> *) b. (Show o, MonadIO m) => ConduitM o o m b
debugConduit = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
Maybe o
s' <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
await
case Maybe o
s' of
Just o
s -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"debugConduit: In: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show o
s)
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield o
s
Maybe o
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
elements :: MonadError XmppFailure m => ConduitT Event Element m ()
elements :: forall (m :: * -> *).
MonadError XmppFailure m =>
ConduitT Event Element m ()
elements = do
Maybe Event
x <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
await
case Maybe Event
x of
Just (EventBeginElement Name
n [(Name, [Content])]
as) -> do
forall {m :: * -> *} {o}.
MonadError XmppFailure m =>
Name -> [(Name, [Content])] -> ConduitT Event o m Element
goE Name
n [(Name, [Content])]
as forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield
forall (m :: * -> *).
MonadError XmppFailure m =>
ConduitT Event Element m ()
elements
Just EventEndElement{} -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
StreamEndFailure
Just Event
EventEndDocument -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
StreamEndFailure
Just (EventContent (ContentText Text
ct)) | (Char -> Bool) -> Text -> Bool
Text.all Char -> Bool
isSpace Text
ct ->
forall (m :: * -> *).
MonadError XmppFailure m =>
ConduitT Event Element m ()
elements
Maybe Event
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe Event
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ [Char] -> XmppFailure
XmppInvalidXml forall a b. (a -> b) -> a -> b
$ [Char]
"not an element: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Maybe Event
x
where
many' :: m (Either a a) -> m (a, [a])
many' m (Either a a)
f =
forall {c}. ([a] -> c) -> m (a, c)
go forall a. a -> a
id
where
go :: ([a] -> c) -> m (a, c)
go [a] -> c
front = do
Either a a
x <- m (Either a a)
f
case Either a a
x of
Left a
l -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (a
l, [a] -> c
front [])
Right a
r -> ([a] -> c) -> m (a, c)
go ([a] -> c
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) a
r)
goE :: Name -> [(Name, [Content])] -> ConduitT Event o m Element
goE Name
n [(Name, [Content])]
as = do
(Maybe Event
y, [Node]
ns) <- forall {m :: * -> *} {a} {a}.
Monad m =>
m (Either a a) -> m (a, [a])
many' ConduitT Event o m (Either (Maybe Event) Node)
goN
if Maybe Event
y forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (Name -> Event
EventEndElement Name
n)
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> [(Name, [Content])] -> [Node] -> Element
Element Name
n (forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> a
id forall {t} {a} {t} {b}. (t -> a) -> (t -> b) -> (t, t) -> (a, b)
>< [Content] -> [Content]
compressContents) [(Name, [Content])]
as)
([Node] -> [Node]
compressNodes [Node]
ns)
else forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> XmppFailure
XmppInvalidXml forall a b. (a -> b) -> a -> b
$ [Char]
"Missing close tag: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Name
n
goN :: ConduitT Event o m (Either (Maybe Event) Node)
goN = do
Maybe Event
x <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
await
case Maybe Event
x of
Just (EventBeginElement Name
n [(Name, [Content])]
as) -> (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Node
NodeElement) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> [(Name, [Content])] -> ConduitT Event o m Element
goE Name
n [(Name, [Content])]
as
Just (EventInstruction Instruction
i) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Instruction -> Node
NodeInstruction Instruction
i
Just (EventContent Content
c) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Content -> Node
NodeContent Content
c
Just (EventComment Text
t) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Node
NodeComment Text
t
Just (EventCDATA Text
t) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Content -> Node
NodeContent forall a b. (a -> b) -> a -> b
$ Text -> Content
ContentText Text
t
Maybe Event
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Maybe Event
x
compressNodes :: [Node] -> [Node]
compressNodes :: [Node] -> [Node]
compressNodes [] = []
compressNodes [Node
x] = [Node
x]
compressNodes (NodeContent (ContentText Text
x) : NodeContent (ContentText Text
y) : [Node]
z) =
[Node] -> [Node]
compressNodes forall a b. (a -> b) -> a -> b
$ Content -> Node
NodeContent (Text -> Content
ContentText forall a b. (a -> b) -> a -> b
$ Text
x Text -> Text -> Text
`Text.append` Text
y) forall a. a -> [a] -> [a]
: [Node]
z
compressNodes (Node
x:[Node]
xs) = Node
x forall a. a -> [a] -> [a]
: [Node] -> [Node]
compressNodes [Node]
xs
compressContents :: [Content] -> [Content]
compressContents :: [Content] -> [Content]
compressContents [Content]
cs = [Text -> Content
ContentText forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.concat (forall a b. (a -> b) -> [a] -> [b]
map Content -> Text
unwrap [Content]
cs)]
where unwrap :: Content -> Text
unwrap (ContentText Text
t) = Text
t
unwrap (ContentEntity Text
t) = Text
t
>< :: (t -> a) -> (t -> b) -> (t, t) -> (a, b)
(><) t -> a
f t -> b
g (t
x, t
y) = (t -> a
f t
x, t -> b
g t
y)
withStream :: StateT StreamState IO a -> Stream -> IO a
withStream :: forall a. StateT StreamState IO a -> Stream -> IO a
withStream StateT StreamState IO a
action (Stream TMVar StreamState
stream) = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Ex.bracketOnError
(forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> STM a
takeTMVar TMVar StreamState
stream )
(forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TMVar a -> a -> STM ()
putTMVar TMVar StreamState
stream)
(\StreamState
s -> do
(a
r, StreamState
s') <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT StreamState IO a
action StreamState
s
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar StreamState
stream StreamState
s'
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
)
withStream' :: StateT StreamState IO a -> Stream -> IO a
withStream' :: forall a. StateT StreamState IO a -> Stream -> IO a
withStream' StateT StreamState IO a
action (Stream TMVar StreamState
stream) = do
StreamState
stream_ <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> STM a
readTMVar TMVar StreamState
stream
(a
r, StreamState
_) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT StreamState IO a
action StreamState
stream_
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
mkStream :: StreamState -> IO Stream
mkStream :: StreamState -> IO Stream
mkStream StreamState
con = TMVar StreamState -> Stream
Stream forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. STM a -> IO a
atomically (forall a. a -> STM (TMVar a)
newTMVar StreamState
con)
tryIOError :: IO a -> IO (Either IOError a)
tryIOError :: forall a. IO a -> IO (Either IOException a)
tryIOError IO a
f = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Ex.catch (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
f) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)