|
|
|
@ -1,74 +1,73 @@ |
|
|
|
{-# OPTIONS_HADDOCK hide #-} |
|
|
|
{-# OPTIONS_HADDOCK hide #-} |
|
|
|
|
|
|
|
|
|
|
|
{-# LANGUAGE CPP #-} |
|
|
|
{-# LANGUAGE CPP #-} |
|
|
|
|
|
|
|
{-# LANGUAGE FlexibleContexts #-} |
|
|
|
{-# LANGUAGE NoMonomorphismRestriction #-} |
|
|
|
{-# LANGUAGE NoMonomorphismRestriction #-} |
|
|
|
{-# LANGUAGE OverloadedStrings #-} |
|
|
|
{-# LANGUAGE OverloadedStrings #-} |
|
|
|
{-# LANGUAGE TupleSections #-} |
|
|
|
{-# LANGUAGE ScopedTypeVariables #-} |
|
|
|
{-# LANGUAGE ScopedTypeVariables #-} |
|
|
|
{-# LANGUAGE TupleSections #-} |
|
|
|
{-# LANGUAGE FlexibleContexts #-} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
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 qualified Control.Exception.Lifted as ExL |
|
|
|
import qualified Control.Exception.Lifted as ExL |
|
|
|
import Control.Monad |
|
|
|
import Control.Monad |
|
|
|
import Control.Monad.Except |
|
|
|
import Control.Monad.Except |
|
|
|
import Control.Monad.State.Strict |
|
|
|
import Control.Monad.State.Strict |
|
|
|
import Data.ByteString (ByteString) |
|
|
|
import Data.ByteString (ByteString) |
|
|
|
import qualified Data.ByteString as BS |
|
|
|
import qualified Data.ByteString as BS |
|
|
|
import qualified Data.ByteString.Char8 as BSC8 |
|
|
|
import qualified Data.ByteString.Char8 as BSC8 |
|
|
|
import Data.Char (isSpace) |
|
|
|
import Data.Char (isSpace) |
|
|
|
import Data.Conduit hiding (connect) |
|
|
|
import Data.Conduit hiding (connect) |
|
|
|
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.IP |
|
|
|
import Data.IP |
|
|
|
import Data.List |
|
|
|
import Data.List |
|
|
|
import Data.Maybe |
|
|
|
import Data.Maybe |
|
|
|
import Data.Ord |
|
|
|
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 qualified Data.Text.Encoding as Text |
|
|
|
import qualified Data.Text.Encoding.Error as Text |
|
|
|
import qualified Data.Text.Encoding.Error as Text |
|
|
|
import Data.Void (Void) |
|
|
|
import Data.Void (Void) |
|
|
|
import Data.Word (Word16) |
|
|
|
import Data.Word (Word16) |
|
|
|
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.DNS hiding (encode, lookup) |
|
|
|
import Network.DNS hiding (encode, lookup) |
|
|
|
import Network.Socket (AddrInfo, HostName, PortNumber) |
|
|
|
import qualified Network.Socket as S |
|
|
|
import qualified Network.Socket as S |
|
|
|
import Network.Socket (AddrInfo) |
|
|
|
|
|
|
|
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) <- Only available in base >=4.4 |
|
|
|
-- import System.IO.Error (tryIOError) <- Only available in base >=4.4 |
|
|
|
|
|
|
|
import Lens.Family2 (over) |
|
|
|
import System.Log.Logger |
|
|
|
import System.Log.Logger |
|
|
|
import System.Random (randomRIO) |
|
|
|
import System.Random (randomRIO) |
|
|
|
import Text.XML.Stream.Parse as XP |
|
|
|
import Text.XML.Stream.Parse as XP |
|
|
|
import Lens.Family2 (over) |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
import qualified Network.Xmpp.Lens as L |
|
|
|
import Network.Xmpp.Utilities |
|
|
|
import Network.Xmpp.Utilities |
|
|
|
import qualified Network.Xmpp.Lens as L |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- "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 |
|
|
|
readMaybe_ string = case reads string of |
|
|
|
readMaybe_ string = case reads string of |
|
|
|
[(a, "")] -> Just a |
|
|
|
[(a, "")] -> Just a |
|
|
|
_ -> Nothing |
|
|
|
_ -> Nothing |
|
|
|
|
|
|
|
|
|
|
|
-- import Text.XML.Stream.Elements |
|
|
|
-- import Text.XML.Stream.Elements |
|
|
|
|
|
|
|
|
|
|
|
mbl :: Maybe [a] -> [a] |
|
|
|
mbl :: Maybe [a] -> [a] |
|
|
|
mbl (Just l) = l |
|
|
|
mbl (Just l) = l |
|
|
|
mbl Nothing = [] |
|
|
|
mbl Nothing = [] |
|
|
|
|
|
|
|
|
|
|
|
lmb :: [t] -> Maybe [t] |
|
|
|
lmb :: [t] -> Maybe [t] |
|
|
|
lmb [] = Nothing |
|
|
|
lmb [] = Nothing |
|
|
|
lmb x = Just x |
|
|
|
lmb x = Just x |
|
|
|
|
|
|
|
|
|
|
|
-- Unpickles and returns a stream element. |
|
|
|
-- Unpickles and returns a stream element. |
|
|
|
streamUnpickleElem :: PU [Node] a |
|
|
|
streamUnpickleElem :: PU [Node] a |
|
|
|
@ -90,9 +89,9 @@ throwOutJunk :: Monad m => ConduitM Event a m () |
|
|
|
throwOutJunk = do |
|
|
|
throwOutJunk = do |
|
|
|
next <- CL.peek |
|
|
|
next <- CL.peek |
|
|
|
case next of |
|
|
|
case next of |
|
|
|
Nothing -> return () -- This will only happen if the stream is closed. |
|
|
|
Nothing -> return () -- This will only happen if the stream is closed. |
|
|
|
Just (EventBeginElement _ _) -> return () |
|
|
|
Just (EventBeginElement _ _) -> return () |
|
|
|
_ -> CL.drop 1 >> throwOutJunk |
|
|
|
_ -> CL.drop 1 >> throwOutJunk |
|
|
|
|
|
|
|
|
|
|
|
-- Returns an (empty) Element from a stream of XML events. |
|
|
|
-- Returns an (empty) Element from a stream of XML events. |
|
|
|
openElementFromEvents :: StreamSink Element |
|
|
|
openElementFromEvents :: StreamSink Element |
|
|
|
@ -117,12 +116,12 @@ startStream = runExceptT $ do |
|
|
|
-- state of the stream. |
|
|
|
-- state of the stream. |
|
|
|
let expectedTo = case ( streamConnectionState st |
|
|
|
let expectedTo = case ( streamConnectionState st |
|
|
|
, toJid $ streamConfiguration st) of |
|
|
|
, toJid $ streamConfiguration st) of |
|
|
|
(Plain , (Just (j, True))) -> Just j |
|
|
|
(Plain , (Just (j, True))) -> Just j |
|
|
|
(Plain , _ ) -> Nothing |
|
|
|
(Plain , _ ) -> Nothing |
|
|
|
(Secured , (Just (j, _ ))) -> Just j |
|
|
|
(Secured , (Just (j, _ ))) -> Just j |
|
|
|
(Secured , Nothing ) -> Nothing |
|
|
|
(Secured , Nothing ) -> Nothing |
|
|
|
(Closed , _ ) -> Nothing |
|
|
|
(Closed , _ ) -> Nothing |
|
|
|
(Finished , _ ) -> Nothing |
|
|
|
(Finished , _ ) -> Nothing |
|
|
|
case streamAddress st of |
|
|
|
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." |
|
|
|
@ -216,7 +215,7 @@ startStream = runExceptT $ do |
|
|
|
StreamBadFormat Nothing |
|
|
|
StreamBadFormat Nothing |
|
|
|
"" |
|
|
|
"" |
|
|
|
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)] |
|
|
|
@ -227,7 +226,7 @@ flattenAttrs attrs = Prelude.map (\(name, cont) -> |
|
|
|
attrs |
|
|
|
attrs |
|
|
|
where |
|
|
|
where |
|
|
|
uncontentify (ContentText t) = t |
|
|
|
uncontentify (ContentText t) = t |
|
|
|
uncontentify _ = "" |
|
|
|
uncontentify _ = "" |
|
|
|
|
|
|
|
|
|
|
|
-- Sets a new Event source using the raw source (of bytes) |
|
|
|
-- Sets a new Event source using the raw source (of bytes) |
|
|
|
-- and calls xmppStartStream. |
|
|
|
-- and calls xmppStartStream. |
|
|
|
@ -249,7 +248,7 @@ sourceStreamHandleRaw s = forever . read $ streamReceive s |
|
|
|
read rd = do |
|
|
|
read rd = do |
|
|
|
bs' <- liftIO (rd 4096) |
|
|
|
bs' <- liftIO (rd 4096) |
|
|
|
bs <- case bs' of |
|
|
|
bs <- case bs' of |
|
|
|
Left e -> throwError e |
|
|
|
Left e -> throwError e |
|
|
|
Right r -> return r |
|
|
|
Right r -> return r |
|
|
|
yield bs |
|
|
|
yield bs |
|
|
|
|
|
|
|
|
|
|
|
@ -300,8 +299,8 @@ bufferSrc src = do |
|
|
|
return $ Right b |
|
|
|
return $ Right b |
|
|
|
) |
|
|
|
) |
|
|
|
case dt of |
|
|
|
case dt of |
|
|
|
Left e -> throwError e |
|
|
|
Left e -> throwError e |
|
|
|
Right Nothing -> return () |
|
|
|
Right Nothing -> return () |
|
|
|
Right (Just d) -> yield d >> go |
|
|
|
Right (Just d) -> yield d >> go |
|
|
|
return go |
|
|
|
return go |
|
|
|
where |
|
|
|
where |
|
|
|
@ -335,7 +334,7 @@ streamS _expectedTo = do -- TODO: check expectedTo |
|
|
|
el <- openElementFromEvents -- May throw `XmppOtherFailure' if an |
|
|
|
el <- openElementFromEvents -- May throw `XmppOtherFailure' if an |
|
|
|
-- element is not received |
|
|
|
-- element is not received |
|
|
|
case unpickleElem xpStream el of |
|
|
|
case unpickleElem xpStream el of |
|
|
|
Left _ -> return $ Left el |
|
|
|
Left _ -> return $ Left el |
|
|
|
Right r -> return $ Right r |
|
|
|
Right r -> return $ Right r |
|
|
|
xmppStreamFeatures :: StreamSink StreamFeatures |
|
|
|
xmppStreamFeatures :: StreamSink StreamFeatures |
|
|
|
xmppStreamFeatures = do |
|
|
|
xmppStreamFeatures = do |
|
|
|
@ -431,7 +430,7 @@ nsHack e@(Element{elementName = n}) |
|
|
|
where |
|
|
|
where |
|
|
|
mapNSHack :: Node -> Node |
|
|
|
mapNSHack :: Node -> Node |
|
|
|
mapNSHack (NodeElement el) = NodeElement $ nsHack el |
|
|
|
mapNSHack (NodeElement el) = NodeElement $ nsHack el |
|
|
|
mapNSHack nd = nd |
|
|
|
mapNSHack nd = nd |
|
|
|
|
|
|
|
|
|
|
|
-- | Encode and send stanza |
|
|
|
-- | Encode and send stanza |
|
|
|
pushStanza :: Stanza -> Stream -> IO (Either XmppFailure ()) |
|
|
|
pushStanza :: Stanza -> Stream -> IO (Either XmppFailure ()) |
|
|
|
@ -494,8 +493,8 @@ pullStanza :: Stream -> IO (Either XmppFailure Stanza) |
|
|
|
pullStanza = withStream' $ do |
|
|
|
pullStanza = withStream' $ do |
|
|
|
res <- pullUnpickle xpStreamStanza |
|
|
|
res <- pullUnpickle xpStreamStanza |
|
|
|
case res of |
|
|
|
case res of |
|
|
|
Left e -> return $ Left e |
|
|
|
Left e -> return $ Left e |
|
|
|
Right (Left e) -> return $ Left $ StreamErrorFailure e |
|
|
|
Right (Left e) -> return $ Left $ StreamErrorFailure e |
|
|
|
Right (Right r) -> return $ Right r |
|
|
|
Right (Right r) -> return $ Right r |
|
|
|
|
|
|
|
|
|
|
|
-- | Pulls a stanza, nonza or stream error from the stream. |
|
|
|
-- | Pulls a stanza, nonza or stream error from the stream. |
|
|
|
@ -503,8 +502,8 @@ pullXmppElement :: Stream -> IO (Either XmppFailure XmppElement) |
|
|
|
pullXmppElement = withStream' $ do |
|
|
|
pullXmppElement = withStream' $ do |
|
|
|
res <- pullUnpickle xpStreamElement |
|
|
|
res <- pullUnpickle xpStreamElement |
|
|
|
case res of |
|
|
|
case res of |
|
|
|
Left e -> return $ Left e |
|
|
|
Left e -> return $ Left e |
|
|
|
Right (Left e) -> return $ Left $ StreamErrorFailure e |
|
|
|
Right (Left e) -> return $ Left $ StreamErrorFailure e |
|
|
|
Right (Right r) -> return $ Right r |
|
|
|
Right (Right r) -> return $ Right r |
|
|
|
|
|
|
|
|
|
|
|
-- Performs the given IO operation, catches any errors and re-throws everything |
|
|
|
-- Performs the given IO operation, catches any errors and re-throws everything |
|
|
|
@ -515,7 +514,7 @@ catchPush p = ExL.catch |
|
|
|
(\e -> case GIE.ioe_type e of |
|
|
|
(\e -> case GIE.ioe_type e of |
|
|
|
GIE.ResourceVanished -> return . Left $ XmppIOException e |
|
|
|
GIE.ResourceVanished -> return . Left $ XmppIOException e |
|
|
|
GIE.IllegalOperation -> return . Left $ XmppIOException e |
|
|
|
GIE.IllegalOperation -> return . Left $ XmppIOException e |
|
|
|
_ -> ExL.throwIO e |
|
|
|
_ -> ExL.throwIO e |
|
|
|
) |
|
|
|
) |
|
|
|
|
|
|
|
|
|
|
|
zeroHandle :: StreamHandle |
|
|
|
zeroHandle :: StreamHandle |
|
|
|
@ -594,7 +593,7 @@ createStream realm config = do |
|
|
|
return d |
|
|
|
return d |
|
|
|
tlsIdentL = L.tlsParamsL . L.clientServerIdentificationL |
|
|
|
tlsIdentL = L.tlsParamsL . L.clientServerIdentificationL |
|
|
|
updateHost host ("", _) = (host, "") |
|
|
|
updateHost host ("", _) = (host, "") |
|
|
|
updateHost _ hst = hst |
|
|
|
updateHost _ hst = hst |
|
|
|
maybeSetTlsHost host = over tlsIdentL (updateHost host) |
|
|
|
maybeSetTlsHost host = over tlsIdentL (updateHost host) |
|
|
|
|
|
|
|
|
|
|
|
-- Connects using the specified method. Returns the Handle acquired, if any. |
|
|
|
-- Connects using the specified method. Returns the Handle acquired, if any. |
|
|
|
@ -655,12 +654,11 @@ connectSrv config host = do |
|
|
|
throwError XmppIllegalTcpDetails |
|
|
|
throwError XmppIllegalTcpDetails |
|
|
|
where for = flip fmap |
|
|
|
where for = flip fmap |
|
|
|
|
|
|
|
|
|
|
|
showPort :: PortID -> String |
|
|
|
|
|
|
|
#if MIN_VERSION_network(2, 4, 1) |
|
|
|
#if MIN_VERSION_network(2, 4, 1) |
|
|
|
showPort = show |
|
|
|
showPort = show |
|
|
|
#else |
|
|
|
#else |
|
|
|
showPort (PortNumber x) = "PortNumber " ++ show x |
|
|
|
showPort (PortNumber x) = "PortNumber " ++ show x |
|
|
|
showPort (Service x) = "Service " ++ show x |
|
|
|
showPort (Service x) = "Service " ++ show x |
|
|
|
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) |
|
|
|
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) |
|
|
|
showPort (UnixSocket x) = "UnixSocket " ++ show x |
|
|
|
showPort (UnixSocket x) = "UnixSocket " ++ show x |
|
|
|
#endif |
|
|
|
#endif |
|
|
|
@ -720,7 +718,7 @@ resolvSrvsAndConnectTcp ((domain, port):remaining) = do |
|
|
|
result <- resolveAndConnectTcp domain port |
|
|
|
result <- resolveAndConnectTcp domain port |
|
|
|
case result of |
|
|
|
case result of |
|
|
|
Just handle -> return $ Just handle |
|
|
|
Just handle -> return $ Just handle |
|
|
|
Nothing -> resolvSrvsAndConnectTcp remaining |
|
|
|
Nothing -> resolvSrvsAndConnectTcp remaining |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- The DNS functions may make error calls. This function catches any such |
|
|
|
-- The DNS functions may make error calls. This function catches any such |
|
|
|
@ -759,7 +757,7 @@ srvLookup realm resolvSeed = ExceptT $ do |
|
|
|
return Nothing |
|
|
|
return Nothing |
|
|
|
case result of |
|
|
|
case result of |
|
|
|
Right result' -> return $ Right result' |
|
|
|
Right result' -> return $ Right result' |
|
|
|
Left e -> return $ Left $ XmppIOException e |
|
|
|
Left e -> return $ Left $ XmppIOException e |
|
|
|
where |
|
|
|
where |
|
|
|
-- This function orders the SRV result in accordance with RFC |
|
|
|
-- This function orders the SRV result in accordance with RFC |
|
|
|
-- 2782. It sorts the SRV results in order of priority, and then |
|
|
|
-- 2782. It sorts the SRV results in order of priority, and then |
|
|
|
@ -870,7 +868,7 @@ elements = do |
|
|
|
go front = do |
|
|
|
go front = do |
|
|
|
x <- f |
|
|
|
x <- f |
|
|
|
case x of |
|
|
|
case x of |
|
|
|
Left l -> return $ (l, front []) |
|
|
|
Left l -> return $ (l, front []) |
|
|
|
Right r -> go (front . (:) r) |
|
|
|
Right r -> go (front . (:) r) |
|
|
|
goE n as = do |
|
|
|
goE n as = do |
|
|
|
(y, ns) <- many' goN |
|
|
|
(y, ns) <- many' goN |
|
|
|
@ -897,7 +895,7 @@ elements = do |
|
|
|
|
|
|
|
|
|
|
|
compressContents :: [Content] -> [Content] |
|
|
|
compressContents :: [Content] -> [Content] |
|
|
|
compressContents cs = [ContentText $ Text.concat (map unwrap cs)] |
|
|
|
compressContents cs = [ContentText $ Text.concat (map unwrap cs)] |
|
|
|
where unwrap (ContentText t) = t |
|
|
|
where unwrap (ContentText t) = t |
|
|
|
unwrap (ContentEntity t) = t |
|
|
|
unwrap (ContentEntity t) = t |
|
|
|
|
|
|
|
|
|
|
|
(><) f g (x, y) = (f x, g y) |
|
|
|
(><) f g (x, y) = (f x, g y) |
|
|
|
|
