|
|
|
@ -7,54 +7,46 @@ |
|
|
|
|
|
|
|
|
|
|
|
module Network.Xmpp.Stream where |
|
|
|
module Network.Xmpp.Stream where |
|
|
|
|
|
|
|
|
|
|
|
import Control.Applicative ((<$>), (<*>)) |
|
|
|
import Control.Applicative ((<$>)) |
|
|
|
import Control.Concurrent (forkIO, threadDelay) |
|
|
|
import Control.Concurrent (forkIO, threadDelay) |
|
|
|
import Control.Concurrent.STM |
|
|
|
import Control.Concurrent.STM |
|
|
|
import qualified Control.Exception as Ex |
|
|
|
import qualified Control.Exception as Ex |
|
|
|
import Control.Exception.Base |
|
|
|
|
|
|
|
import qualified Control.Exception.Lifted as ExL |
|
|
|
import qualified Control.Exception.Lifted as ExL |
|
|
|
import Control.Monad |
|
|
|
import Control.Monad |
|
|
|
import Control.Monad.Error |
|
|
|
import Control.Monad.Error |
|
|
|
import Control.Monad.IO.Class |
|
|
|
|
|
|
|
import Control.Monad.Reader |
|
|
|
|
|
|
|
import Control.Monad.State.Strict |
|
|
|
import Control.Monad.State.Strict |
|
|
|
import Control.Monad.Trans.Class |
|
|
|
import Control.Monad.Trans.Resource as R |
|
|
|
|
|
|
|
import Data.ByteString (ByteString) |
|
|
|
import qualified Data.ByteString as BS |
|
|
|
import qualified Data.ByteString as BS |
|
|
|
import Data.ByteString.Base64 |
|
|
|
import qualified Data.ByteString.Char8 as BSC8 |
|
|
|
import Data.ByteString.Char8 as BSC8 |
|
|
|
|
|
|
|
import Data.Conduit |
|
|
|
import Data.Conduit |
|
|
|
import Data.Conduit.Binary as CB |
|
|
|
import Data.Conduit.Binary as CB |
|
|
|
import qualified Data.Conduit.Internal as DCI |
|
|
|
import qualified Data.Conduit.Internal as DCI |
|
|
|
import qualified Data.Conduit.List as CL |
|
|
|
import qualified Data.Conduit.List as CL |
|
|
|
import Data.Maybe (fromJust, isJust, isNothing) |
|
|
|
import Data.IP |
|
|
|
|
|
|
|
import Data.List |
|
|
|
|
|
|
|
import Data.Maybe |
|
|
|
|
|
|
|
import Data.Ord |
|
|
|
import Data.Text (Text) |
|
|
|
import Data.Text (Text) |
|
|
|
import qualified Data.Text as Text |
|
|
|
import qualified Data.Text as Text |
|
|
|
|
|
|
|
import qualified Data.Text.Encoding as Text |
|
|
|
import Data.Void (Void) |
|
|
|
import Data.Void (Void) |
|
|
|
import Data.XML.Pickle |
|
|
|
import Data.XML.Pickle |
|
|
|
import Data.XML.Types |
|
|
|
import Data.XML.Types |
|
|
|
import qualified GHC.IO.Exception as GIE |
|
|
|
import qualified GHC.IO.Exception as GIE |
|
|
|
import Network |
|
|
|
import Network |
|
|
|
|
|
|
|
import Network.DNS hiding (encode, lookup) |
|
|
|
import Network.Xmpp.Marshal |
|
|
|
import Network.Xmpp.Marshal |
|
|
|
import Network.Xmpp.Types |
|
|
|
import Network.Xmpp.Types |
|
|
|
import System.IO |
|
|
|
import System.IO |
|
|
|
import System.IO.Error (tryIOError) |
|
|
|
import System.IO.Error (tryIOError) |
|
|
|
import System.Log.Logger |
|
|
|
import System.Log.Logger |
|
|
|
|
|
|
|
import System.Random (randomRIO) |
|
|
|
import Text.XML.Stream.Parse as XP |
|
|
|
import Text.XML.Stream.Parse as XP |
|
|
|
import Text.XML.Unresolved(InvalidEventStream(..)) |
|
|
|
import Text.XML.Unresolved(InvalidEventStream(..)) |
|
|
|
|
|
|
|
|
|
|
|
import Control.Monad.Trans.Resource as R |
|
|
|
|
|
|
|
import Network.Xmpp.Utilities |
|
|
|
import Network.Xmpp.Utilities |
|
|
|
|
|
|
|
|
|
|
|
import Network.DNS hiding (encode, lookup) |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
import Data.Ord |
|
|
|
|
|
|
|
import Data.Maybe |
|
|
|
|
|
|
|
import Data.List |
|
|
|
|
|
|
|
import Data.IP |
|
|
|
|
|
|
|
import System.Random |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
import qualified Network.Socket as NS |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- "readMaybe" definition, as readMaybe is not introduced in the `base' package |
|
|
|
-- "readMaybe" definition, as readMaybe is not introduced in the `base' package |
|
|
|
-- until version 4.6. |
|
|
|
-- until version 4.6. |
|
|
|
readMaybe_ :: (Read a) => String -> Maybe a |
|
|
|
readMaybe_ :: (Read a) => String -> Maybe a |
|
|
|
@ -72,6 +64,17 @@ lmb :: [t] -> Maybe [t] |
|
|
|
lmb [] = Nothing |
|
|
|
lmb [] = Nothing |
|
|
|
lmb x = Just x |
|
|
|
lmb x = Just x |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
pushing :: MonadIO m => |
|
|
|
|
|
|
|
m (Either XmppFailure Bool) |
|
|
|
|
|
|
|
-> ErrorT XmppFailure m () |
|
|
|
|
|
|
|
pushing m = do |
|
|
|
|
|
|
|
res <- ErrorT m |
|
|
|
|
|
|
|
case res of |
|
|
|
|
|
|
|
True -> return () |
|
|
|
|
|
|
|
False -> do |
|
|
|
|
|
|
|
liftIO $ debugM "Pontarius.Xmpp" "Failed to send data." |
|
|
|
|
|
|
|
throwError XmppOtherFailure |
|
|
|
|
|
|
|
|
|
|
|
-- Unpickles and returns a stream element. |
|
|
|
-- Unpickles and returns a stream element. |
|
|
|
streamUnpickleElem :: PU [Node] a |
|
|
|
streamUnpickleElem :: PU [Node] a |
|
|
|
-> Element |
|
|
|
-> Element |
|
|
|
@ -85,7 +88,7 @@ streamUnpickleElem p x = do |
|
|
|
|
|
|
|
|
|
|
|
-- This is the conduit sink that handles the stream XML events. We extend it |
|
|
|
-- This is the conduit sink that handles the stream XML events. We extend it |
|
|
|
-- with ErrorT capabilities. |
|
|
|
-- with ErrorT capabilities. |
|
|
|
type StreamSink a = ErrorT XmppFailure (Pipe Event Event Void () IO) a |
|
|
|
type StreamSink a = ErrorT XmppFailure (ConduitM Event Void IO) a |
|
|
|
|
|
|
|
|
|
|
|
-- Discards all events before the first EventBeginElement. |
|
|
|
-- Discards all events before the first EventBeginElement. |
|
|
|
throwOutJunk :: Monad m => Sink Event m () |
|
|
|
throwOutJunk :: Monad m => Sink Event m () |
|
|
|
@ -114,55 +117,64 @@ openElementFromEvents = do |
|
|
|
startStream :: StateT StreamState IO (Either XmppFailure ()) |
|
|
|
startStream :: StateT StreamState IO (Either XmppFailure ()) |
|
|
|
startStream = runErrorT $ do |
|
|
|
startStream = runErrorT $ do |
|
|
|
lift $ lift $ debugM "Pontarius.Xmpp" "Starting stream..." |
|
|
|
lift $ lift $ debugM "Pontarius.Xmpp" "Starting stream..." |
|
|
|
state <- lift $ get |
|
|
|
st <- lift $ get |
|
|
|
-- Set the `from' (which is also the expected to) attribute depending on the |
|
|
|
-- Set the `from' (which is also the expected to) attribute depending on the |
|
|
|
-- state of the stream. |
|
|
|
-- state of the stream. |
|
|
|
let expectedTo = case ( streamConnectionState state |
|
|
|
let expectedTo = case ( streamConnectionState st |
|
|
|
, toJid $ streamConfiguration state) of |
|
|
|
, toJid $ streamConfiguration st) of |
|
|
|
(Plain, (Just (jid, True))) -> Just jid |
|
|
|
(Plain , (Just (jid, True))) -> Just jid |
|
|
|
(Secured, (Just (jid, _))) -> Just jid |
|
|
|
(Plain , _ ) -> Nothing |
|
|
|
(Plain, Nothing) -> Nothing |
|
|
|
(Secured, (Just (jid, _ ))) -> Just jid |
|
|
|
(Secured, Nothing) -> Nothing |
|
|
|
(Secured, Nothing ) -> Nothing |
|
|
|
case streamAddress state of |
|
|
|
(Closed , _ ) -> Nothing |
|
|
|
|
|
|
|
case streamAddress st of |
|
|
|
Nothing -> do |
|
|
|
Nothing -> do |
|
|
|
lift $ lift $ errorM "Pontarius.XMPP" "Server sent no hostname." |
|
|
|
lift $ lift $ errorM "Pontarius.XMPP" "Server sent no hostname." |
|
|
|
throwError XmppOtherFailure |
|
|
|
throwError XmppOtherFailure |
|
|
|
Just address -> lift $ do |
|
|
|
Just address -> do |
|
|
|
pushXmlDecl |
|
|
|
pushing pushXmlDecl |
|
|
|
pushOpenElement $ |
|
|
|
pushing . pushOpenElement . streamNSHack $ |
|
|
|
pickleElem xpStream ( "1.0" |
|
|
|
pickleElem xpStream ( "1.0" |
|
|
|
, expectedTo |
|
|
|
, expectedTo |
|
|
|
, Just (Jid Nothing address Nothing) |
|
|
|
, Just (Jid Nothing address Nothing) |
|
|
|
, Nothing |
|
|
|
, Nothing |
|
|
|
, preferredLang $ streamConfiguration state |
|
|
|
, preferredLang $ streamConfiguration st |
|
|
|
) |
|
|
|
) |
|
|
|
response <- ErrorT $ runEventsSink $ runErrorT $ streamS expectedTo |
|
|
|
response <- ErrorT $ runEventsSink $ runErrorT $ streamS expectedTo |
|
|
|
case response of |
|
|
|
case response of |
|
|
|
Left e -> throwError e |
|
|
|
Left e -> throwError e |
|
|
|
-- Successful unpickling of stream element. |
|
|
|
-- Successful unpickling of stream element. |
|
|
|
Right (Right (ver, from, to, id, lt, features)) |
|
|
|
Right (Right (ver, from, to, sid, lt, features)) |
|
|
|
| (Text.unpack ver) /= "1.0" -> |
|
|
|
| (Text.unpack ver) /= "1.0" -> |
|
|
|
closeStreamWithError StreamUnsupportedVersion Nothing |
|
|
|
closeStreamWithError StreamUnsupportedVersion Nothing |
|
|
|
"Unknown version" |
|
|
|
"Unknown version" |
|
|
|
| lt == Nothing -> |
|
|
|
|
|
|
|
closeStreamWithError StreamInvalidXml Nothing |
|
|
|
-- HACK: We ignore MUST-strength requirement (section 4.7.4. of RFC |
|
|
|
"Stream has no language tag" |
|
|
|
-- 6120) for the sake of compatibility with jabber.org |
|
|
|
-- If `from' is set, we verify that it's the correct one. TODO: Should we check against the realm instead? |
|
|
|
-- | lt == Nothing -> |
|
|
|
| isJust from && (from /= Just (Jid Nothing (fromJust $ streamAddress state) Nothing)) -> |
|
|
|
-- closeStreamWithError StreamInvalidXml Nothing |
|
|
|
|
|
|
|
-- "Stream has no language tag" |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- If `from' is set, we verify that it's the correct one. TODO: Should we |
|
|
|
|
|
|
|
-- check against the realm instead? |
|
|
|
|
|
|
|
| isJust from && (from /= Just (Jid Nothing (fromJust $ streamAddress st) Nothing)) -> |
|
|
|
closeStreamWithError StreamInvalidFrom Nothing |
|
|
|
closeStreamWithError StreamInvalidFrom Nothing |
|
|
|
"Stream from is invalid" |
|
|
|
"Stream from is invalid" |
|
|
|
| to /= expectedTo -> |
|
|
|
| to /= expectedTo -> |
|
|
|
closeStreamWithError StreamUndefinedCondition (Just $ Element "invalid-to" [] []) |
|
|
|
closeStreamWithError StreamUndefinedCondition (Just $ Element "invalid-to" [] []) |
|
|
|
"Stream to invalid"-- TODO: Suitable? |
|
|
|
"Stream to invalid"-- TODO: Suitable? |
|
|
|
| otherwise -> do |
|
|
|
| otherwise -> do |
|
|
|
|
|
|
|
-- HACK: (ignore section 4.7.4. of RFC 6120), see above |
|
|
|
|
|
|
|
unless (isJust lt) $ liftIO $ warningM "Pontariusm.Xmpp" |
|
|
|
|
|
|
|
"Stream has no language tag" |
|
|
|
modify (\s -> s{ streamFeatures = features |
|
|
|
modify (\s -> s{ streamFeatures = features |
|
|
|
, streamLang = lt |
|
|
|
, streamLang = lt |
|
|
|
, streamId = id |
|
|
|
, streamId = sid |
|
|
|
, streamFrom = from |
|
|
|
, streamFrom = from |
|
|
|
} ) |
|
|
|
} ) |
|
|
|
return () |
|
|
|
return () |
|
|
|
-- Unpickling failed - we investigate the element. |
|
|
|
-- Unpickling failed - we investigate the element. |
|
|
|
Right (Left (Element name attrs children)) |
|
|
|
Right (Left (Element name attrs _children)) |
|
|
|
| (nameLocalName name /= "stream") -> |
|
|
|
| (nameLocalName name /= "stream") -> |
|
|
|
closeStreamWithError StreamInvalidXml Nothing |
|
|
|
closeStreamWithError StreamInvalidXml Nothing |
|
|
|
"Root element is not stream" |
|
|
|
"Root element is not stream" |
|
|
|
@ -174,15 +186,17 @@ startStream = runErrorT $ do |
|
|
|
"Root name prefix set and not stream" |
|
|
|
"Root name prefix set and not stream" |
|
|
|
| otherwise -> ErrorT $ checkchildren (flattenAttrs attrs) |
|
|
|
| otherwise -> ErrorT $ checkchildren (flattenAttrs attrs) |
|
|
|
where |
|
|
|
where |
|
|
|
-- closeStreamWithError :: MonadIO m => Stream -> StreamErrorCondition -> |
|
|
|
-- HACK: We include the default namespace to make isode's M-LINK server happy. |
|
|
|
-- Maybe Element -> ErrorT XmppFailure m () |
|
|
|
streamNSHack e = e{elementAttributes = elementAttributes e |
|
|
|
|
|
|
|
++ [( "xmlns" |
|
|
|
|
|
|
|
, [ContentText "jabber:client"])]} |
|
|
|
closeStreamWithError :: StreamErrorCondition -> Maybe Element -> String |
|
|
|
closeStreamWithError :: StreamErrorCondition -> Maybe Element -> String |
|
|
|
-> ErrorT XmppFailure (StateT StreamState IO) () |
|
|
|
-> ErrorT XmppFailure (StateT StreamState IO) () |
|
|
|
closeStreamWithError sec el msg = do |
|
|
|
closeStreamWithError sec el msg = do |
|
|
|
lift . pushElement . pickleElem xpStreamError |
|
|
|
void . lift . pushElement . pickleElem xpStreamError |
|
|
|
$ StreamErrorInfo sec Nothing el |
|
|
|
$ StreamErrorInfo sec Nothing el |
|
|
|
lift $ closeStreams' |
|
|
|
void . lift $ closeStreams' |
|
|
|
lift $ lift $ errorM "Pontarius.XMPP" $ "closeStreamWithError: " ++ msg |
|
|
|
liftIO $ errorM "Pontarius.XMPP" $ "closeStreamWithError: " ++ msg |
|
|
|
throwError XmppOtherFailure |
|
|
|
throwError XmppOtherFailure |
|
|
|
checkchildren children = |
|
|
|
checkchildren children = |
|
|
|
let to' = lookup "to" children |
|
|
|
let to' = lookup "to" children |
|
|
|
@ -206,12 +220,12 @@ startStream = runErrorT $ do |
|
|
|
"" |
|
|
|
"" |
|
|
|
safeRead x = case reads $ Text.unpack x of |
|
|
|
safeRead x = case reads $ Text.unpack x of |
|
|
|
[] -> Nothing |
|
|
|
[] -> Nothing |
|
|
|
[(y,_),_] -> Just y |
|
|
|
((y,_):_) -> Just y |
|
|
|
|
|
|
|
|
|
|
|
flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)] |
|
|
|
flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)] |
|
|
|
flattenAttrs attrs = Prelude.map (\(name, content) -> |
|
|
|
flattenAttrs attrs = Prelude.map (\(name, cont) -> |
|
|
|
( name |
|
|
|
( name |
|
|
|
, Text.concat $ Prelude.map uncontentify content) |
|
|
|
, Text.concat $ Prelude.map uncontentify cont) |
|
|
|
) |
|
|
|
) |
|
|
|
attrs |
|
|
|
attrs |
|
|
|
where |
|
|
|
where |
|
|
|
@ -229,11 +243,15 @@ restartStream = do |
|
|
|
modify (\s -> s{streamEventSource = newSource }) |
|
|
|
modify (\s -> s{streamEventSource = newSource }) |
|
|
|
startStream |
|
|
|
startStream |
|
|
|
where |
|
|
|
where |
|
|
|
loopRead read = do |
|
|
|
loopRead rd = do |
|
|
|
bs <- liftIO (read 4096) |
|
|
|
bs <- liftIO (rd 4096) |
|
|
|
if BS.null bs |
|
|
|
if BS.null bs |
|
|
|
then return () |
|
|
|
then return () |
|
|
|
else yield bs >> loopRead read |
|
|
|
else do |
|
|
|
|
|
|
|
liftIO $ debugM "Pontarius.Xmpp" $ "in: " ++ |
|
|
|
|
|
|
|
(Text.unpack . Text.decodeUtf8 $ bs) |
|
|
|
|
|
|
|
yield bs |
|
|
|
|
|
|
|
loopRead rd |
|
|
|
|
|
|
|
|
|
|
|
-- Reads the (partial) stream:stream and the server features from the stream. |
|
|
|
-- Reads the (partial) stream:stream and the server features from the stream. |
|
|
|
-- Returns the (unvalidated) stream attributes, the unparsed element, or |
|
|
|
-- Returns the (unvalidated) stream attributes, the unparsed element, or |
|
|
|
@ -247,12 +265,12 @@ streamS :: Maybe Jid -> StreamSink (Either Element ( Text |
|
|
|
, Maybe Text |
|
|
|
, Maybe Text |
|
|
|
, Maybe LangTag |
|
|
|
, Maybe LangTag |
|
|
|
, StreamFeatures )) |
|
|
|
, StreamFeatures )) |
|
|
|
streamS expectedTo = do |
|
|
|
streamS _expectedTo = do -- TODO: check expectedTo |
|
|
|
header <- xmppStreamHeader |
|
|
|
streamHeader <- xmppStreamHeader |
|
|
|
case header of |
|
|
|
case streamHeader of |
|
|
|
Right (version, from, to, id, langTag) -> do |
|
|
|
Right (version, from, to, sid, lTag) -> do |
|
|
|
features <- xmppStreamFeatures |
|
|
|
features <- xmppStreamFeatures |
|
|
|
return $ Right (version, from, to, id, langTag, features) |
|
|
|
return $ Right (version, from, to, sid, lTag, features) |
|
|
|
Left el -> return $ Left el |
|
|
|
Left el -> return $ Left el |
|
|
|
where |
|
|
|
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.Text, Maybe LangTag)) |
|
|
|
@ -280,7 +298,7 @@ openStream :: HostName -> StreamConfiguration -> IO (Either XmppFailure (Stream) |
|
|
|
openStream realm config = runErrorT $ do |
|
|
|
openStream realm config = runErrorT $ do |
|
|
|
lift $ debugM "Pontarius.XMPP" "Opening stream..." |
|
|
|
lift $ debugM "Pontarius.XMPP" "Opening stream..." |
|
|
|
stream' <- createStream realm config |
|
|
|
stream' <- createStream realm config |
|
|
|
result <- liftIO $ withStream startStream stream' |
|
|
|
ErrorT . liftIO $ withStream startStream stream' |
|
|
|
return stream' |
|
|
|
return stream' |
|
|
|
|
|
|
|
|
|
|
|
-- | Send "</stream:stream>" and wait for the server to finish processing and to |
|
|
|
-- | Send "</stream:stream>" and wait for the server to finish processing and to |
|
|
|
@ -289,14 +307,15 @@ openStream realm config = runErrorT $ do |
|
|
|
closeStreams :: Stream -> IO (Either XmppFailure [Element]) |
|
|
|
closeStreams :: Stream -> IO (Either XmppFailure [Element]) |
|
|
|
closeStreams = withStream closeStreams' |
|
|
|
closeStreams = withStream closeStreams' |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
closeStreams' :: StateT StreamState IO (Either XmppFailure [Element]) |
|
|
|
closeStreams' = do |
|
|
|
closeStreams' = do |
|
|
|
lift $ debugM "Pontarius.XMPP" "Closing stream..." |
|
|
|
lift $ debugM "Pontarius.XMPP" "Closing stream..." |
|
|
|
send <- gets (streamSend . streamHandle) |
|
|
|
send <- gets (streamSend . streamHandle) |
|
|
|
cc <- gets (streamClose . streamHandle) |
|
|
|
cc <- gets (streamClose . streamHandle) |
|
|
|
liftIO $ send "</stream:stream>" |
|
|
|
void . liftIO $ send "</stream:stream>" |
|
|
|
void $ liftIO $ forkIO $ do |
|
|
|
void $ liftIO $ forkIO $ do |
|
|
|
threadDelay 3000000 -- TODO: Configurable value |
|
|
|
threadDelay 3000000 -- TODO: Configurable value |
|
|
|
(Ex.try cc) :: IO (Either Ex.SomeException ()) |
|
|
|
void ((Ex.try cc) :: IO (Either Ex.SomeException ())) |
|
|
|
return () |
|
|
|
return () |
|
|
|
collectElems [] |
|
|
|
collectElems [] |
|
|
|
where |
|
|
|
where |
|
|
|
@ -311,6 +330,9 @@ closeStreams' = do |
|
|
|
Right e -> collectElems (e:es) |
|
|
|
Right e -> collectElems (e:es) |
|
|
|
|
|
|
|
|
|
|
|
-- TODO: Can the TLS send/recv functions throw something other than an IO error? |
|
|
|
-- TODO: Can the TLS send/recv functions throw something other than an IO error? |
|
|
|
|
|
|
|
debugOut :: MonadIO m => ByteString -> m () |
|
|
|
|
|
|
|
debugOut outData = liftIO $ debugM "Pontarius.Xmpp" |
|
|
|
|
|
|
|
("Out: " ++ (Text.unpack . Text.decodeUtf8 $ outData)) |
|
|
|
|
|
|
|
|
|
|
|
wrapIOException :: IO a -> StateT StreamState IO (Either XmppFailure a) |
|
|
|
wrapIOException :: IO a -> StateT StreamState IO (Either XmppFailure a) |
|
|
|
wrapIOException action = do |
|
|
|
wrapIOException action = do |
|
|
|
@ -324,7 +346,21 @@ wrapIOException action = do |
|
|
|
pushElement :: Element -> StateT StreamState IO (Either XmppFailure Bool) |
|
|
|
pushElement :: Element -> StateT StreamState IO (Either XmppFailure Bool) |
|
|
|
pushElement x = do |
|
|
|
pushElement x = do |
|
|
|
send <- gets (streamSend . streamHandle) |
|
|
|
send <- gets (streamSend . streamHandle) |
|
|
|
wrapIOException $ send $ renderElement x |
|
|
|
let outData = renderElement $ nsHack x |
|
|
|
|
|
|
|
debugOut outData |
|
|
|
|
|
|
|
wrapIOException $ send outData |
|
|
|
|
|
|
|
where |
|
|
|
|
|
|
|
-- HACK: We remove the "jabber:client" namespace because it is set as |
|
|
|
|
|
|
|
-- default in the stream. This is to make isode's M-LINK server happy and |
|
|
|
|
|
|
|
-- should be removed once jabber.org accepts prefix-free canonicalization |
|
|
|
|
|
|
|
nsHack e@(Element{elementName = n}) |
|
|
|
|
|
|
|
| nameNamespace n == Just "jabber:client" = |
|
|
|
|
|
|
|
e{ elementName = Name (nameLocalName n) Nothing Nothing |
|
|
|
|
|
|
|
, elementNodes = map mapNSHack $ elementNodes e |
|
|
|
|
|
|
|
} |
|
|
|
|
|
|
|
| otherwise = e |
|
|
|
|
|
|
|
mapNSHack (NodeElement e) = NodeElement $ nsHack e |
|
|
|
|
|
|
|
mapNSHack n = n |
|
|
|
|
|
|
|
|
|
|
|
-- | Encode and send stanza |
|
|
|
-- | Encode and send stanza |
|
|
|
pushStanza :: Stanza -> Stream -> IO (Either XmppFailure Bool) |
|
|
|
pushStanza :: Stanza -> Stream -> IO (Either XmppFailure Bool) |
|
|
|
@ -341,8 +377,10 @@ pushXmlDecl = do |
|
|
|
|
|
|
|
|
|
|
|
pushOpenElement :: Element -> StateT StreamState IO (Either XmppFailure Bool) |
|
|
|
pushOpenElement :: Element -> StateT StreamState IO (Either XmppFailure Bool) |
|
|
|
pushOpenElement e = do |
|
|
|
pushOpenElement e = do |
|
|
|
sink <- gets (streamSend . streamHandle) |
|
|
|
send <- gets (streamSend . streamHandle) |
|
|
|
wrapIOException $ sink $ renderOpenElement e |
|
|
|
let outData = renderOpenElement e |
|
|
|
|
|
|
|
debugOut outData |
|
|
|
|
|
|
|
wrapIOException $ send outData |
|
|
|
|
|
|
|
|
|
|
|
-- `Connect-and-resumes' the given sink to the stream source, and pulls a |
|
|
|
-- `Connect-and-resumes' the given sink to the stream source, and pulls a |
|
|
|
-- `b' value. |
|
|
|
-- `b' value. |
|
|
|
@ -378,8 +416,8 @@ pullElement = do |
|
|
|
-- Pulls an element and unpickles it. |
|
|
|
-- Pulls an element and unpickles it. |
|
|
|
pullUnpickle :: PU [Node] a -> StateT StreamState IO (Either XmppFailure a) |
|
|
|
pullUnpickle :: PU [Node] a -> StateT StreamState IO (Either XmppFailure a) |
|
|
|
pullUnpickle p = do |
|
|
|
pullUnpickle p = do |
|
|
|
elem <- pullElement |
|
|
|
el <- pullElement |
|
|
|
case elem of |
|
|
|
case el of |
|
|
|
Left e -> return $ Left e |
|
|
|
Left e -> return $ Left e |
|
|
|
Right elem' -> do |
|
|
|
Right elem' -> do |
|
|
|
let res = unpickleElem p elem' |
|
|
|
let res = unpickleElem p elem' |
|
|
|
@ -433,7 +471,7 @@ xmppNoStream = StreamState { |
|
|
|
where |
|
|
|
where |
|
|
|
zeroSource :: Source IO output |
|
|
|
zeroSource :: Source IO output |
|
|
|
zeroSource = liftIO $ do |
|
|
|
zeroSource = liftIO $ do |
|
|
|
errorM "Pontarius.XMPP" "zeroSource utilized." |
|
|
|
errorM "Pontarius.Xmpp" "zeroSource utilized." |
|
|
|
ExL.throwIO XmppOtherFailure |
|
|
|
ExL.throwIO XmppOtherFailure |
|
|
|
|
|
|
|
|
|
|
|
createStream :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (Stream) |
|
|
|
createStream :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (Stream) |
|
|
|
@ -472,7 +510,7 @@ createStream realm config = do |
|
|
|
where |
|
|
|
where |
|
|
|
logConduit :: Conduit ByteString IO ByteString |
|
|
|
logConduit :: Conduit ByteString IO ByteString |
|
|
|
logConduit = CL.mapM $ \d -> do |
|
|
|
logConduit = CL.mapM $ \d -> do |
|
|
|
debugM "Pontarius.Xmpp" $ "Received TCP data: " ++ (BSC8.unpack d) ++ |
|
|
|
debugM "Pontarius.Xmpp" $ "In: " ++ (BSC8.unpack d) ++ |
|
|
|
"." |
|
|
|
"." |
|
|
|
return d |
|
|
|
return d |
|
|
|
|
|
|
|
|
|
|
|
@ -483,79 +521,78 @@ createStream realm config = do |
|
|
|
-- attempt has been made. Will return the Handle acquired, if any. |
|
|
|
-- attempt has been made. Will return the Handle acquired, if any. |
|
|
|
connect :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (Maybe Handle) |
|
|
|
connect :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (Maybe Handle) |
|
|
|
connect realm config = do |
|
|
|
connect realm config = do |
|
|
|
case socketDetails config of |
|
|
|
case connectionDetails config of |
|
|
|
-- Just (_, NS.SockAddrUnix _) -> do |
|
|
|
UseHost host port -> lift $ do |
|
|
|
-- lift $ errorM "Pontarius.Xmpp" "SockAddrUnix address provided." |
|
|
|
debugM "Pontarius.Xmpp" "Connecting to configured address." |
|
|
|
-- throwError XmppIllegalTcpDetails |
|
|
|
connectTcp $ [(host, port)] |
|
|
|
Just socketDetails' -> lift $ do |
|
|
|
UseSrv host -> connectSrv host |
|
|
|
debugM "Pontarius.Xmpp" "Connecting to configured SockAddr address..." |
|
|
|
UseRealm -> connectSrv realm |
|
|
|
connectTcp $ Left socketDetails' |
|
|
|
where |
|
|
|
Nothing -> do |
|
|
|
connectSrv host = do |
|
|
|
case (readMaybe_ realm :: Maybe IPv6, readMaybe_ realm :: Maybe IPv4, hostname (Text.pack realm) :: Maybe Hostname) of |
|
|
|
case checkHostName (Text.pack host) of |
|
|
|
(Just ipv6, Nothing, _) -> lift $ connectTcp $ Right [(show ipv6, 5222)] |
|
|
|
Just host' -> do |
|
|
|
(Nothing, Just ipv4, _) -> lift $ connectTcp $ Right [(show ipv4, 5222)] |
|
|
|
|
|
|
|
(Nothing, Nothing, Just (Hostname realm')) -> do |
|
|
|
|
|
|
|
resolvSeed <- lift $ makeResolvSeed (resolvConf config) |
|
|
|
resolvSeed <- lift $ makeResolvSeed (resolvConf config) |
|
|
|
lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..." |
|
|
|
lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..." |
|
|
|
srvRecords <- srvLookup realm' resolvSeed |
|
|
|
srvRecords <- srvLookup host' resolvSeed |
|
|
|
case srvRecords of |
|
|
|
case srvRecords of |
|
|
|
-- No SRV records. Try fallback lookup. |
|
|
|
|
|
|
|
Nothing -> do |
|
|
|
Nothing -> do |
|
|
|
lift $ debugM "Pontarius.Xmpp" "No SRV records, using fallback process..." |
|
|
|
lift $ debugM "Pontarius.Xmpp" |
|
|
|
lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ realm) 5222 |
|
|
|
"No SRV records, using fallback process." |
|
|
|
|
|
|
|
lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ host) |
|
|
|
|
|
|
|
5222 |
|
|
|
Just srvRecords' -> do |
|
|
|
Just srvRecords' -> do |
|
|
|
lift $ debugM "Pontarius.Xmpp" "SRV records found, performing A/AAAA lookups..." |
|
|
|
lift $ debugM "Pontarius.Xmpp" |
|
|
|
|
|
|
|
"SRV records found, performing A/AAAA lookups." |
|
|
|
lift $ resolvSrvsAndConnectTcp resolvSeed srvRecords' |
|
|
|
lift $ resolvSrvsAndConnectTcp resolvSeed srvRecords' |
|
|
|
(Nothing, Nothing, Nothing) -> do |
|
|
|
Nothing -> do |
|
|
|
lift $ errorM "Pontarius.Xmpp" "The hostname could not be validated." |
|
|
|
lift $ errorM "Pontarius.Xmpp" |
|
|
|
|
|
|
|
"The hostname could not be validated." |
|
|
|
throwError XmppIllegalTcpDetails |
|
|
|
throwError XmppIllegalTcpDetails |
|
|
|
|
|
|
|
|
|
|
|
-- Connects to a list of addresses and ports. Surpresses any exceptions from |
|
|
|
-- Connects to a list of addresses and ports. Surpresses any exceptions from |
|
|
|
-- connectTcp. |
|
|
|
-- connectTcp. |
|
|
|
connectTcp :: Either (NS.Socket, NS.SockAddr) [(HostName, Int)] -> IO (Maybe Handle) |
|
|
|
connectTcp :: [(HostName, PortID)] -> IO (Maybe Handle) |
|
|
|
connectTcp (Right []) = return Nothing |
|
|
|
connectTcp [] = return Nothing |
|
|
|
connectTcp (Right ((address, port):remainder)) = do |
|
|
|
connectTcp ((address, port):remainder) = do |
|
|
|
result <- try $ (do |
|
|
|
result <- Ex.try $ (do |
|
|
|
debugM "Pontarius.Xmpp" $ "Connecting to " ++ (address) ++ " on port " ++ |
|
|
|
debugM "Pontarius.Xmpp" $ "Connecting to " ++ address ++ " on port " ++ |
|
|
|
(show port) ++ "." |
|
|
|
(show port) ++ "." |
|
|
|
connectTo address (PortNumber $ fromIntegral port)) :: IO (Either IOException Handle) |
|
|
|
connectTo address port) :: IO (Either Ex.IOException Handle) |
|
|
|
case result of |
|
|
|
case result of |
|
|
|
Right handle -> do |
|
|
|
Right handle -> do |
|
|
|
debugM "Pontarius.Xmpp" "Successfully connected to HostName." |
|
|
|
debugM "Pontarius.Xmpp" "Successfully connected to HostName." |
|
|
|
return $ Just handle |
|
|
|
return $ Just handle |
|
|
|
Left _ -> do |
|
|
|
Left _ -> do |
|
|
|
debugM "Pontarius.Xmpp" "Connection to HostName could not be established." |
|
|
|
debugM "Pontarius.Xmpp" "Connection to HostName could not be established." |
|
|
|
connectTcp $ Right remainder |
|
|
|
connectTcp remainder |
|
|
|
connectTcp (Left (sock, sockAddr)) = do |
|
|
|
|
|
|
|
result <- try $ (do |
|
|
|
|
|
|
|
NS.connect sock sockAddr |
|
|
|
|
|
|
|
NS.socketToHandle sock ReadWriteMode) :: IO (Either IOException Handle) |
|
|
|
|
|
|
|
case result of |
|
|
|
|
|
|
|
Right handle -> do |
|
|
|
|
|
|
|
debugM "Pontarius.Xmpp" "Successfully connected to SockAddr." |
|
|
|
|
|
|
|
return $ Just handle |
|
|
|
|
|
|
|
Left _ -> do |
|
|
|
|
|
|
|
debugM "Pontarius.Xmpp" "Connection to SockAddr could not be established." |
|
|
|
|
|
|
|
return Nothing |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- Makes an AAAA query to acquire a IPs, and tries to connect to all of them. If |
|
|
|
-- Makes an AAAA query to acquire a IPs, and tries to connect to all of them. If |
|
|
|
-- a handle can not be acquired this way, an analogous A query is performed. |
|
|
|
-- a handle can not be acquired this way, an analogous A query is performed. |
|
|
|
-- Surpresses all IO exceptions. |
|
|
|
-- Surpresses all IO exceptions. |
|
|
|
resolvAndConnectTcp :: ResolvSeed -> Domain -> Int -> IO (Maybe Handle) |
|
|
|
resolvAndConnectTcp :: ResolvSeed -> Domain -> Int -> IO (Maybe Handle) |
|
|
|
resolvAndConnectTcp resolvSeed domain port = do |
|
|
|
resolvAndConnectTcp resolvSeed domain port = do |
|
|
|
aaaaResults <- (try $ rethrowErrorCall $ withResolver resolvSeed $ |
|
|
|
aaaaResults <- (Ex.try $ rethrowErrorCall $ withResolver resolvSeed $ |
|
|
|
\resolver -> lookupAAAA resolver domain) :: IO (Either IOException (Maybe [IPv6])) |
|
|
|
\resolver -> lookupAAAA resolver domain) :: IO (Either Ex.IOException (Maybe [IPv6])) |
|
|
|
handle <- case aaaaResults of |
|
|
|
handle <- case aaaaResults of |
|
|
|
Right Nothing -> return Nothing |
|
|
|
Right Nothing -> return Nothing |
|
|
|
Right (Just ipv6s) -> connectTcp $ Right $ Data.List.map (\ipv6 -> (show ipv6, port)) ipv6s |
|
|
|
Right (Just ipv6s) -> connectTcp $ |
|
|
|
Left e -> return Nothing |
|
|
|
map (\ip -> ( show ip |
|
|
|
|
|
|
|
, PortNumber $ fromIntegral port)) |
|
|
|
|
|
|
|
ipv6s |
|
|
|
|
|
|
|
Left _e -> return Nothing |
|
|
|
case handle of |
|
|
|
case handle of |
|
|
|
Nothing -> do |
|
|
|
Nothing -> do |
|
|
|
aResults <- (try $ rethrowErrorCall $ withResolver resolvSeed $ |
|
|
|
aResults <- (Ex.try $ rethrowErrorCall $ withResolver resolvSeed $ |
|
|
|
\resolver -> lookupA resolver domain) :: IO (Either IOException (Maybe [IPv4])) |
|
|
|
\resolver -> lookupA resolver domain) :: IO (Either Ex.IOException (Maybe [IPv4])) |
|
|
|
handle' <- case aResults of |
|
|
|
handle' <- case aResults of |
|
|
|
|
|
|
|
Left _ -> return Nothing |
|
|
|
Right Nothing -> return Nothing |
|
|
|
Right Nothing -> return Nothing |
|
|
|
Right (Just ipv4s) -> connectTcp $ Right $ Data.List.map (\ipv4 -> (show ipv4, port)) ipv4s |
|
|
|
|
|
|
|
|
|
|
|
Right (Just ipv4s) -> connectTcp $ |
|
|
|
|
|
|
|
map (\ip -> (show ip |
|
|
|
|
|
|
|
, PortNumber |
|
|
|
|
|
|
|
$ fromIntegral port)) |
|
|
|
|
|
|
|
ipv4s |
|
|
|
case handle' of |
|
|
|
case handle' of |
|
|
|
Nothing -> return Nothing |
|
|
|
Nothing -> return Nothing |
|
|
|
Just handle'' -> return $ Just handle'' |
|
|
|
Just handle'' -> return $ Just handle'' |
|
|
|
@ -576,29 +613,30 @@ resolvSrvsAndConnectTcp resolvSeed ((domain, port):remaining) = do |
|
|
|
-- exceptions and rethrows them as IOExceptions. |
|
|
|
-- exceptions and rethrows them as IOExceptions. |
|
|
|
rethrowErrorCall :: IO a -> IO a |
|
|
|
rethrowErrorCall :: IO a -> IO a |
|
|
|
rethrowErrorCall action = do |
|
|
|
rethrowErrorCall action = do |
|
|
|
result <- try action |
|
|
|
result <- Ex.try action |
|
|
|
case result of |
|
|
|
case result of |
|
|
|
Right result' -> return result' |
|
|
|
Right result' -> return result' |
|
|
|
Left (ErrorCall e) -> ioError $ userError $ "rethrowErrorCall: " ++ e |
|
|
|
Left (Ex.ErrorCall e) -> Ex.ioError $ userError |
|
|
|
Left e -> throwIO e |
|
|
|
$ "rethrowErrorCall: " ++ e |
|
|
|
|
|
|
|
|
|
|
|
-- Provides a list of A(AAA) names and port numbers upon a successful |
|
|
|
-- Provides a list of A(AAA) names and port numbers upon a successful |
|
|
|
-- DNS-SRV request, or `Nothing' if the DNS-SRV request failed. |
|
|
|
-- DNS-SRV request, or `Nothing' if the DNS-SRV request failed. |
|
|
|
srvLookup :: Text -> ResolvSeed -> ErrorT XmppFailure IO (Maybe [(Domain, Int)]) |
|
|
|
srvLookup :: Text -> ResolvSeed -> ErrorT XmppFailure IO (Maybe [(Domain, Int)]) |
|
|
|
srvLookup realm resolvSeed = ErrorT $ do |
|
|
|
srvLookup realm resolvSeed = ErrorT $ do |
|
|
|
result <- try $ rethrowErrorCall $ withResolver resolvSeed $ \resolver -> do |
|
|
|
result <- Ex.try $ rethrowErrorCall $ withResolver resolvSeed |
|
|
|
|
|
|
|
$ \resolver -> do |
|
|
|
srvResult <- lookupSRV resolver $ BSC8.pack $ "_xmpp-client._tcp." ++ (Text.unpack realm) ++ "." |
|
|
|
srvResult <- lookupSRV resolver $ BSC8.pack $ "_xmpp-client._tcp." ++ (Text.unpack realm) ++ "." |
|
|
|
case srvResult of |
|
|
|
case srvResult of |
|
|
|
Just srvResult -> do |
|
|
|
|
|
|
|
debugM "Pontarius.Xmpp" $ "SRV result: " ++ (show srvResult) |
|
|
|
|
|
|
|
-- Get [(Domain, PortNumber)] of SRV request, if any. |
|
|
|
|
|
|
|
srvResult' <- orderSrvResult srvResult |
|
|
|
|
|
|
|
return $ Just $ Prelude.map (\(_, _, port, domain) -> (domain, port)) srvResult' |
|
|
|
|
|
|
|
-- The service is not available at this domain. |
|
|
|
|
|
|
|
-- Sorts the records based on the priority value. |
|
|
|
|
|
|
|
Just [(_, _, _, ".")] -> do |
|
|
|
Just [(_, _, _, ".")] -> do |
|
|
|
debugM "Pontarius.Xmpp" $ "\".\" SRV result returned." |
|
|
|
debugM "Pontarius.Xmpp" $ "\".\" SRV result returned." |
|
|
|
return $ Just [] |
|
|
|
return $ Just [] |
|
|
|
|
|
|
|
Just srvResult' -> do |
|
|
|
|
|
|
|
debugM "Pontarius.Xmpp" $ "SRV result: " ++ (show srvResult') |
|
|
|
|
|
|
|
-- Get [(Domain, PortNumber)] of SRV request, if any. |
|
|
|
|
|
|
|
orderedSrvResult <- orderSrvResult srvResult' |
|
|
|
|
|
|
|
return $ Just $ Prelude.map (\(_, _, port, domain) -> (domain, port)) orderedSrvResult |
|
|
|
|
|
|
|
-- The service is not available at this domain. |
|
|
|
|
|
|
|
-- Sorts the records based on the priority value. |
|
|
|
Nothing -> do |
|
|
|
Nothing -> do |
|
|
|
debugM "Pontarius.Xmpp" "No SRV result returned." |
|
|
|
debugM "Pontarius.Xmpp" "No SRV result returned." |
|
|
|
return Nothing |
|
|
|
return Nothing |
|
|
|
@ -629,7 +667,7 @@ srvLookup realm resolvSeed = ErrorT $ do |
|
|
|
orderSublist sublist = do |
|
|
|
orderSublist sublist = do |
|
|
|
-- Compute the running sum, as well as the total sum of |
|
|
|
-- Compute the running sum, as well as the total sum of |
|
|
|
-- the sublist. Add the running sum to the SRV tuples. |
|
|
|
-- the sublist. Add the running sum to the SRV tuples. |
|
|
|
let (total, sublist') = Data.List.mapAccumL (\total (priority, weight, port, domain) -> (total + weight, (priority, weight, port, domain, total + weight))) 0 sublist |
|
|
|
let (total, sublist') = Data.List.mapAccumL (\total' (priority, weight, port, domain) -> (total' + weight, (priority, weight, port, domain, total' + weight))) 0 sublist |
|
|
|
-- Choose a random number between 0 and the total sum |
|
|
|
-- Choose a random number between 0 and the total sum |
|
|
|
-- (inclusive). |
|
|
|
-- (inclusive). |
|
|
|
randomNumber <- randomRIO (0, total) |
|
|
|
randomNumber <- randomRIO (0, total) |
|
|
|
@ -638,11 +676,11 @@ srvLookup realm resolvSeed = ErrorT $ do |
|
|
|
let (beginning, ((priority, weight, port, domain, _):end)) = Data.List.break (\(_, _, _, _, running) -> randomNumber <= running) sublist' |
|
|
|
let (beginning, ((priority, weight, port, domain, _):end)) = Data.List.break (\(_, _, _, _, running) -> randomNumber <= running) sublist' |
|
|
|
-- Remove the running total number from the remaining |
|
|
|
-- Remove the running total number from the remaining |
|
|
|
-- elements. |
|
|
|
-- elements. |
|
|
|
let sublist'' = Data.List.map (\(priority, weight, port, domain, _) -> (priority, weight, port, domain)) (Data.List.concat [beginning, end]) |
|
|
|
let sublist'' = Data.List.map (\(priority', weight', port', domain', _) -> (priority', weight', port', domain')) (Data.List.concat [beginning, end]) |
|
|
|
-- Repeat the ordering procedure on the remaining |
|
|
|
-- Repeat the ordering procedure on the remaining |
|
|
|
-- elements. |
|
|
|
-- elements. |
|
|
|
tail <- orderSublist sublist'' |
|
|
|
rest <- orderSublist sublist'' |
|
|
|
return $ ((priority, weight, port, domain):tail) |
|
|
|
return $ ((priority, weight, port, domain):rest) |
|
|
|
|
|
|
|
|
|
|
|
-- Closes the connection and updates the XmppConMonad Stream state. |
|
|
|
-- Closes the connection and updates the XmppConMonad Stream state. |
|
|
|
-- killStream :: Stream -> IO (Either ExL.SomeException ()) |
|
|
|
-- killStream :: Stream -> IO (Either ExL.SomeException ()) |
|
|
|
@ -663,25 +701,26 @@ pushIQ :: StanzaID |
|
|
|
-> Element |
|
|
|
-> Element |
|
|
|
-> Stream |
|
|
|
-> Stream |
|
|
|
-> IO (Either XmppFailure (Either IQError IQResult)) |
|
|
|
-> IO (Either XmppFailure (Either IQError IQResult)) |
|
|
|
pushIQ iqID to tp lang body stream = do |
|
|
|
pushIQ iqID to tp lang body stream = runErrorT $ do |
|
|
|
pushStanza (IQRequestS $ IQRequest iqID Nothing to lang tp body) stream |
|
|
|
pushing $ pushStanza |
|
|
|
res <- pullStanza stream |
|
|
|
(IQRequestS $ IQRequest iqID Nothing to lang tp body) stream |
|
|
|
|
|
|
|
res <- lift $ pullStanza stream |
|
|
|
case res of |
|
|
|
case res of |
|
|
|
Left e -> return $ Left e |
|
|
|
Left e -> throwError e |
|
|
|
Right (IQErrorS e) -> return $ Right $ Left e |
|
|
|
Right (IQErrorS e) -> return $ Left e |
|
|
|
Right (IQResultS r) -> do |
|
|
|
Right (IQResultS r) -> do |
|
|
|
unless |
|
|
|
unless |
|
|
|
(iqID == iqResultID r) $ liftIO $ do |
|
|
|
(iqID == iqResultID r) $ liftIO $ do |
|
|
|
errorM "Pontarius.XMPP" $ "pushIQ: ID mismatch (" ++ (show iqID) ++ " /= " ++ (show $ iqResultID r) ++ ")." |
|
|
|
liftIO $ errorM "Pontarius.XMPP" $ "pushIQ: ID mismatch (" ++ (show iqID) ++ " /= " ++ (show $ iqResultID r) ++ ")." |
|
|
|
ExL.throwIO XmppOtherFailure |
|
|
|
liftIO $ ExL.throwIO XmppOtherFailure |
|
|
|
-- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++ |
|
|
|
-- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++ |
|
|
|
-- " /= " ++ show (iqResultID r) ++ " .") |
|
|
|
-- " /= " ++ show (iqResultID r) ++ " .") |
|
|
|
return $ Right $ Right r |
|
|
|
return $ Right r |
|
|
|
_ -> do |
|
|
|
_ -> do |
|
|
|
errorM "Pontarius.XMPP" $ "pushIQ: Unexpected stanza type." |
|
|
|
liftIO $ errorM "Pontarius.XMPP" $ "pushIQ: Unexpected stanza type." |
|
|
|
return . Left $ XmppOtherFailure |
|
|
|
throwError XmppOtherFailure |
|
|
|
|
|
|
|
|
|
|
|
debugConduit :: Pipe l ByteString ByteString u IO b |
|
|
|
debugConduit :: (Show o, MonadIO m) => ConduitM o o m b |
|
|
|
debugConduit = forever $ do |
|
|
|
debugConduit = forever $ do |
|
|
|
s' <- await |
|
|
|
s' <- await |
|
|
|
case s' of |
|
|
|
case s' of |
|
|
|
@ -697,7 +736,9 @@ elements = do |
|
|
|
Just (EventBeginElement n as) -> do |
|
|
|
Just (EventBeginElement n as) -> do |
|
|
|
goE n as >>= yield |
|
|
|
goE n as >>= yield |
|
|
|
elements |
|
|
|
elements |
|
|
|
Just (EventEndElement streamName) -> lift $ R.monadThrow StreamEnd |
|
|
|
-- This might be an XML error if the end element tag is not |
|
|
|
|
|
|
|
-- "</stream>". TODO: We might want to check this at a later time |
|
|
|
|
|
|
|
Just (EventEndElement _) -> lift $ R.monadThrow StreamEnd |
|
|
|
Nothing -> return () |
|
|
|
Nothing -> return () |
|
|
|
_ -> lift $ R.monadThrow $ InvalidXmppXml $ "not an element: " ++ show x |
|
|
|
_ -> lift $ R.monadThrow $ InvalidXmppXml $ "not an element: " ++ show x |
|
|
|
where |
|
|
|
where |
|
|
|
@ -707,8 +748,8 @@ elements = do |
|
|
|
go front = do |
|
|
|
go front = do |
|
|
|
x <- f |
|
|
|
x <- f |
|
|
|
case x of |
|
|
|
case x of |
|
|
|
Left x -> return $ (x, front []) |
|
|
|
Left l -> return $ (l, front []) |
|
|
|
Right y -> go (front . (:) y) |
|
|
|
Right r -> go (front . (:) r) |
|
|
|
goE n as = do |
|
|
|
goE n as = do |
|
|
|
(y, ns) <- many' goN |
|
|
|
(y, ns) <- many' goN |
|
|
|
if y == Just (EventEndElement n) |
|
|
|
if y == Just (EventEndElement n) |
|
|
|
@ -732,11 +773,8 @@ elements = do |
|
|
|
compressNodes $ NodeContent (ContentText $ x `Text.append` y) : z |
|
|
|
compressNodes $ NodeContent (ContentText $ x `Text.append` y) : z |
|
|
|
compressNodes (x:xs) = x : compressNodes xs |
|
|
|
compressNodes (x:xs) = x : compressNodes xs |
|
|
|
|
|
|
|
|
|
|
|
streamName :: Name |
|
|
|
withStream :: StateT StreamState IO a -> Stream -> IO a |
|
|
|
streamName = (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) |
|
|
|
withStream action (Stream stream) = Ex.bracketOnError |
|
|
|
|
|
|
|
|
|
|
|
withStream :: StateT StreamState IO (Either XmppFailure c) -> Stream -> IO (Either XmppFailure c) |
|
|
|
|
|
|
|
withStream action (Stream stream) = bracketOnError |
|
|
|
|
|
|
|
(atomically $ takeTMVar stream ) |
|
|
|
(atomically $ takeTMVar stream ) |
|
|
|
(atomically . putTMVar stream) |
|
|
|
(atomically . putTMVar stream) |
|
|
|
(\s -> do |
|
|
|
(\s -> do |
|
|
|
@ -746,7 +784,7 @@ withStream action (Stream stream) = bracketOnError |
|
|
|
) |
|
|
|
) |
|
|
|
|
|
|
|
|
|
|
|
-- nonblocking version. Changes to the connection are ignored! |
|
|
|
-- nonblocking version. Changes to the connection are ignored! |
|
|
|
withStream' :: StateT StreamState IO (Either XmppFailure b) -> Stream -> IO (Either XmppFailure b) |
|
|
|
withStream' :: StateT StreamState IO a -> Stream -> IO a |
|
|
|
withStream' action (Stream stream) = do |
|
|
|
withStream' action (Stream stream) = do |
|
|
|
stream_ <- atomically $ readTMVar stream |
|
|
|
stream_ <- atomically $ readTMVar stream |
|
|
|
(r, _) <- runStateT action stream_ |
|
|
|
(r, _) <- runStateT action stream_ |
|
|
|
|
Jon Kristensen
13 years ago