{-# 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_ :: 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
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
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
type StreamSink a = ConduitM Event Void (ExceptT XmppFailure IO) a
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 ()
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
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
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
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"
| 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"
| Bool
otherwise -> do
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 ()
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
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
""
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
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'
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
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
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
Element
el <- StreamSink Element
openElementFromEvents
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
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'
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
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 }
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
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
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
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
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
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
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
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
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
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 ()
}
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)
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
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
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
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
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
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')
[(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
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
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
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
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)]]
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''
[[(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'''
[(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
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
Word16
randomNumber <- (Word16, Word16) -> IO Word16
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Word16
0, Word16
total)
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'
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])
[(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)
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
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
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
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
Just EventEndElement{} -> XmppFailure -> ConduitT Event Element m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
StreamEndFailure
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
)
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)
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)