asakul
/
pontarius-xmpp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

Simplify `openStream' and `session'; allow for SockAddr; validate IP 

`openStream' and `session' now takes a `HostName'. If the hostname is
an IP adress, we connect to it using the default XMPP port. If it's a
hostname, we perform the SRV lookup (or fallback on A/AAAA lookups and
the default XMPP port).

This patch allows for the use of a socket and socket address pair in
the settings, giving advanced users additionally flexibility. This
field can also be used by users that want to use a non-standard port
in combination with a) a misconfigured XMPP domain name (one without
SRV records), or b) connection by IP.

The "manual" A(AAA) lookups have been kept in order to allow the
Pontarius XMPP client to attempt to connect to multiple IP addresses.
master
Jon Kristensen 13 years ago
parent
dcd64ce2c9
commit
95dbb2c724
6 changed files with 90 additions and 75 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 5
      examples/echoclient/EchoClient.hs
  2. 2
      examples/echoclient/echoclient.cabal
  3. 2
      source/Network/Xmpp.hs
  4. 6
      source/Network/Xmpp/Concurrent.hs
  5. 133
      source/Network/Xmpp/Stream.hs
  6. 17
      source/Network/Xmpp/Types.hs

5
examples/echoclient/EchoClient.hs
Unescape View File

@ -37,9 +37,6 @@ username = "echo"
password = "pwd" password = "pwd"
resource = Just "bot" resource = Just "bot"
config = def{srvOverrideDetails = Just ( fromJust $ hostname "127.0.0.1"
, 5222) }
-- | Automatically accept all subscription requests from other entities -- | Automatically accept all subscription requests from other entities
autoAccept :: Session -> IO () autoAccept :: Session -> IO ()
autoAccept session = forever $ do autoAccept session = forever $ do
@ -60,7 +57,7 @@ main = do
sess' <- session sess' <- session
realm realm
config def
Nothing -- (Just exampleParams) Nothing -- (Just exampleParams)
(Just ([scramSha1 username Nothing password], resource)) (Just ([scramSha1 username Nothing password], resource))
sess <- case sess' of sess <- case sess' of

2
examples/echoclient/echoclient.cabal
Unescape View File

@ -8,5 +8,5 @@ Maintainer: info@jonkri.com
Synopsis: Echo client test program for Pontarius XMPP Synopsis: Echo client test program for Pontarius XMPP
Executable echoclient Executable echoclient
Build-Depends: base, hslogger, mtl, pontarius-xmpp, text, tls Build-Depends: base, data-default, hslogger, mtl, pontarius-xmpp, text, tls
Main-Is: EchoClient.hs Main-Is: EchoClient.hs

2
source/Network/Xmpp.hs
Unescape View File

@ -155,8 +155,6 @@ module Network.Xmpp
, AuthSaslFailure , AuthSaslFailure
, AuthIllegalCredentials , AuthIllegalCredentials
, AuthOtherFailure ) , AuthOtherFailure )
, Hostname
, hostname
) where ) where
import Network import Network

6
source/Network/Xmpp/Concurrent.hs
Unescape View File

@ -132,7 +132,7 @@ writeWorker stCh writeR = forever $ do
-- value, @session@ will attempt to secure the connection with TLS. If the fifth -- value, @session@ will attempt to secure the connection with TLS. If the fifth
-- parameters is a 'Just' value, @session@ will attempt to authenticate and -- parameters is a 'Just' value, @session@ will attempt to authenticate and
-- acquire an XMPP resource. -- acquire an XMPP resource.
session :: Hostname -- ^ The hostname / realm session :: HostName -- ^ The hostname / realm
-> StreamConfiguration -- ^ configuration details -> StreamConfiguration -- ^ configuration details
-> Maybe TLS.TLSParams -- ^ TLS settings, if securing the -> Maybe TLS.TLSParams -- ^ TLS settings, if securing the
-- connection to the server is -- connection to the server is
@ -141,8 +141,8 @@ session :: Hostname -- ^ The hostname / realm
-- JID resource (or Nothing to let -- JID resource (or Nothing to let
-- the server decide) -- the server decide)
-> IO (Either XmppFailure (Session, Maybe AuthFailure)) -> IO (Either XmppFailure (Session, Maybe AuthFailure))
session host config mbTls mbSasl = runErrorT $ do session realm config mbTls mbSasl = runErrorT $ do
con <- ErrorT $ openStream (Right host) config con <- ErrorT $ openStream realm config
case mbTls of case mbTls of
Nothing -> return () Nothing -> return ()
Just tls -> ErrorT $ startTls tls con Just tls -> ErrorT $ startTls tls con

133
source/Network/Xmpp/Stream.hs
Unescape View File

@ -53,6 +53,15 @@ import Data.List
import Data.IP import Data.IP
import System.Random import System.Random
import qualified Network.Socket as NS
-- "readMaybe" definition, as readMaybe is not introduced in the `base' package
-- until version 4.6.
readMaybe_ :: (Read a) => String -> Maybe a
readMaybe_ string = case reads string of
[(a, "")] -> Just a
_ -> Nothing
-- import Text.XML.Stream.Elements -- import Text.XML.Stream.Elements
mbl :: Maybe [a] -> [a] mbl :: Maybe [a] -> [a]
@ -259,9 +268,9 @@ streamS expectedTo = do
-- | Connects to the XMPP server and opens the XMPP stream against the given -- | Connects to the XMPP server and opens the XMPP stream against the given
-- realm. -- realm.
openStream :: Either (Either IPv4 IPv6, PortNumber) Hostname -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream)) openStream :: HostName -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream))
openStream destination config = runErrorT $ do openStream realm config = runErrorT $ do
stream' <- createStream destination config stream' <- createStream realm config
result <- liftIO $ withStream startStream stream' result <- liftIO $ withStream startStream stream'
return stream' return stream'
@ -410,15 +419,11 @@ xmppNoStream = Stream {
zeroSource :: Source IO output zeroSource :: Source IO output
zeroSource = liftIO . ExL.throwIO $ XmppOtherFailure "zeroSource" zeroSource = liftIO . ExL.throwIO $ XmppOtherFailure "zeroSource"
createStream :: Either (Either IPv4 IPv6, PortNumber) Hostname -> StreamConfiguration -> ErrorT XmppFailure IO (TMVar Stream) createStream :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (TMVar Stream)
createStream destination config = do createStream realm config = do
result <- connect destination config result <- connect realm config
case result of case result of
Just h -> ErrorT $ do Just h -> ErrorT $ do
let address = case destination of
Left (Left ipv4, _) -> Text.pack $ show ipv4
Left (Right ipv6, _) -> Text.pack $ show ipv6
Right (Hostname hostname) -> hostname
debugM "Pontarius.Xmpp" "Acquired handle." debugM "Pontarius.Xmpp" "Acquired handle."
debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle." debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle."
hSetBuffering h NoBuffering hSetBuffering h NoBuffering
@ -435,7 +440,7 @@ createStream destination config = do
, streamHandle = hand , streamHandle = hand
, streamEventSource = eSource , streamEventSource = eSource
, streamFeatures = StreamFeatures Nothing [] [] , streamFeatures = StreamFeatures Nothing [] []
, streamAddress = (Just address) , streamAddress = Just $ Text.pack realm
, streamFrom = Nothing , streamFrom = Nothing
, streamId = Nothing , streamId = Nothing
, streamLang = Nothing , streamLang = Nothing
@ -454,66 +459,78 @@ createStream destination config = do
"." "."
return d return d
-- Connects to the provided hostname or IP address. If a hostname is provided, a
-- DNS-SRV lookup is performed (unless `sockAddr' has been specified, in which
-- Connects to the provided hostname or IP address. If a hostname is provided, -- case that address is used instead). If an A(AAA) record results are
-- one or many DNS lookups are performed, starting with a SRV lookup (unless -- encountered, all IP addresses will be tried until a successful connection
-- `srvOverrideDetails' has been specified, in which case those details are used -- attempt has been made. Will return the Handle acquired, if any.
-- instead). Will return the Handle acquired, if any. connect :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (Maybe Handle)
connect :: Either (Either IPv4 IPv6, PortNumber) Hostname -> StreamConfiguration -> ErrorT XmppFailure IO (Maybe Handle) connect realm config = do
connect (Left (ip, portNumber)) config = do case socketDetails config of
let ip' = case ip of -- Just (_, NS.SockAddrUnix _) -> do
Left ipv4 -> Text.pack $ show ipv4 -- lift $ errorM "Pontarius.Xmpp" "SockAddrUnix address provided."
Right ipv6 -> Text.pack $ show ipv6 -- throwError XmppIllegalTcpDetails
lift $ connectTcp' [(ip', portNumber)] Just socketDetails' -> lift $ do
connect (Right (Hostname realm)) config = do debugM "Pontarius.Xmpp" "Connecting to configured SockAddr address..."
case srvOverrideDetails config of connectTcp $ Left socketDetails'
Just (Hostname hostname, portNumber) -> lift $ do
debugM "Pontarius.Xmpp" "Connecting to hardcoded TCP host and port..."
connectTcp' [(hostname, portNumber)]
Nothing -> do Nothing -> do
resolvSeed <- lift $ makeResolvSeed (resolvConf config) case (readMaybe_ realm :: Maybe IPv6, readMaybe_ realm :: Maybe IPv4, hostname (Text.pack realm) :: Maybe Hostname) of
lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..." (Just ipv6, Nothing, _) -> lift $ connectTcp $ Right [(show ipv6, 5222)]
srvRecords <- srvLookup realm resolvSeed (Nothing, Just ipv4, _) -> lift $ connectTcp $ Right [(show ipv4, 5222)]
case srvRecords of (Nothing, Nothing, Just (Hostname realm')) -> do
-- No SRV records. Try fallback lookup. resolvSeed <- lift $ makeResolvSeed (resolvConf config)
Nothing -> do lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..."
lift $ debugM "Pontarius.Xmpp" "No SRV records, using fallback process..." srvRecords <- srvLookup realm' resolvSeed
lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ Text.unpack realm) (fromIntegral 5222) case srvRecords of
Just srvRecords' -> do -- No SRV records. Try fallback lookup.
lift $ debugM "Pontarius.Xmpp" "SRV records found, performing A/AAAA lookups..." Nothing -> do
lift $ resolvSrvsAndConnectTcp resolvSeed srvRecords' lift $ debugM "Pontarius.Xmpp" "No SRV records, using fallback process..."
lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ realm) 5222
Just srvRecords' -> do
lift $ debugM "Pontarius.Xmpp" "SRV records found, performing A/AAAA lookups..."
lift $ resolvSrvsAndConnectTcp resolvSeed srvRecords'
(Nothing, Nothing, Nothing) -> do
lift $ errorM "Pontarius.Xmpp" "The hostname could not be validated."
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' :: [(Text, PortNumber)] -> IO (Maybe Handle) connectTcp :: Either (NS.Socket, NS.SockAddr) [(HostName, Int)] -> IO (Maybe Handle)
connectTcp' [] = return Nothing connectTcp (Right []) = return Nothing
connectTcp' ((address, port):remainder) = do connectTcp (Right ((address, port):remainder)) = do
result <- try $ connectTcp address port :: IO (Either IOException Handle) result <- try $ (do
debugM "Pontarius.Xmpp" $ "Connecting to " ++ (address) ++ " on port " ++
(show port) ++ "."
connectTo address (PortNumber $ fromIntegral port)) :: IO (Either IOException Handle)
case result of case result of
Right handle -> do Right handle -> do
debugM "Pontarius.Xmpp" "Successfully connected." debugM "Pontarius.Xmpp" "Successfully connected to HostName."
return $ Just handle return $ Just handle
Left _ -> do Left _ -> do
debugM "Pontarius.Xmpp" "Connection could not be established." debugM "Pontarius.Xmpp" "Connection to HostName could not be established."
connectTcp' remainder connectTcp $ Right remainder
connectTcp (Left (sock, sockAddr)) = do
connectTcp :: Text -> PortNumber -> IO Handle result <- try $ (do
connectTcp address port = do NS.connect sock sockAddr
debugM "Pontarius.Xmpp" $ "Connecting to " ++ (Text.unpack address) ++ NS.socketToHandle sock ReadWriteMode) :: IO (Either IOException Handle)
" on port " ++ (show port) ++ "." case result of
connectTo (Text.unpack address) (PortNumber port) 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 -> PortNumber -> 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 <- (try $ rethrowErrorCall $ withResolver resolvSeed $
\resolver -> lookupAAAA resolver domain) :: IO (Either IOException (Maybe [IPv6])) \resolver -> lookupAAAA resolver domain) :: IO (Either IOException (Maybe [IPv6]))
handle <- case aaaaResults of handle <- case aaaaResults of
Right Nothing -> return Nothing Right Nothing -> return Nothing
Right (Just ipv6s) -> connectTcp' $ Data.List.map (\ipv6 -> (Text.pack $ show ipv6, port)) ipv6s Right (Just ipv6s) -> connectTcp $ Right $ Data.List.map (\ipv6 -> (show ipv6, port)) ipv6s
Left e -> return Nothing Left e -> return Nothing
case handle of case handle of
Nothing -> do Nothing -> do
@ -521,7 +538,7 @@ resolvAndConnectTcp resolvSeed domain port = do
\resolver -> lookupA resolver domain) :: IO (Either IOException (Maybe [IPv4])) \resolver -> lookupA resolver domain) :: IO (Either IOException (Maybe [IPv4]))
handle' <- case aResults of handle' <- case aResults of
Right Nothing -> return Nothing Right Nothing -> return Nothing
Right (Just ipv4s) -> connectTcp' $ Data.List.map (\ipv4 -> (Text.pack $ show ipv4, port)) ipv4s Right (Just ipv4s) -> connectTcp $ Right $ Data.List.map (\ipv4 -> (show ipv4, port)) ipv4s
case handle' of case handle' of
Nothing -> return Nothing Nothing -> return Nothing
Just handle'' -> return $ Just handle'' Just handle'' -> return $ Just handle''
@ -529,7 +546,7 @@ resolvAndConnectTcp resolvSeed domain port = do
-- Tries `resolvAndConnectTcp' for every SRV record, stopping if a handle is -- Tries `resolvAndConnectTcp' for every SRV record, stopping if a handle is
-- acquired. -- acquired.
resolvSrvsAndConnectTcp :: ResolvSeed -> [(Domain, PortNumber)] -> IO (Maybe Handle) resolvSrvsAndConnectTcp :: ResolvSeed -> [(Domain, Int)] -> IO (Maybe Handle)
resolvSrvsAndConnectTcp _ [] = return Nothing resolvSrvsAndConnectTcp _ [] = return Nothing
resolvSrvsAndConnectTcp resolvSeed ((domain, port):remaining) = do resolvSrvsAndConnectTcp resolvSeed ((domain, port):remaining) = do
result <- resolvAndConnectTcp resolvSeed domain port result <- resolvAndConnectTcp resolvSeed domain port
@ -550,7 +567,7 @@ rethrowErrorCall action = do
-- 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, PortNumber)]) 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 <- 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) ++ "."
@ -559,7 +576,7 @@ srvLookup realm resolvSeed = ErrorT $ do
debugM "Pontarius.Xmpp" $ "SRV result: " ++ (show srvResult) debugM "Pontarius.Xmpp" $ "SRV result: " ++ (show srvResult)
-- Get [(Domain, PortNumber)] of SRV request, if any. -- Get [(Domain, PortNumber)] of SRV request, if any.
srvResult' <- orderSrvResult srvResult srvResult' <- orderSrvResult srvResult
return $ Just $ Prelude.map (\(_, _, port, domain) -> (domain, fromIntegral port)) srvResult' return $ Just $ Prelude.map (\(_, _, port, domain) -> (domain, port)) srvResult'
-- The service is not available at this domain. -- The service is not available at this domain.
-- Sorts the records based on the priority value. -- Sorts the records based on the priority value.
Just [(_, _, _, ".")] -> do Just [(_, _, _, ".")] -> do

17
source/Network/Xmpp/Types.hs
Unescape View File

@ -82,6 +82,7 @@ import qualified Text.StringPrep as SP
import Network import Network
import Network.DNS import Network.DNS
import Network.Socket
import Data.Default import Data.Default
import Data.IP import Data.IP
@ -662,8 +663,8 @@ data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream
| TcpConnectionFailure -- ^ All attempts to TCP | TcpConnectionFailure -- ^ All attempts to TCP
-- connect to the server -- connect to the server
-- failed. -- failed.
| DnsLookupFailed -- ^ An IP address to connect to could not be | XmppIllegalTcpDetails -- ^ The TCP details provided did not
-- resolved. -- validate.
| TlsError TLS.TLSError -- ^ An error occurred in the | TlsError TLS.TLSError -- ^ An error occurred in the
-- TLS layer -- TLS layer
| TlsNoServerSupport -- ^ The server does not support | TlsNoServerSupport -- ^ The server does not support
@ -1027,10 +1028,12 @@ data StreamConfiguration =
-- boolean is set to 'True', then the JID is also -- boolean is set to 'True', then the JID is also
-- included when the 'ConnectionState' is 'Plain' -- included when the 'ConnectionState' is 'Plain'
, toJid :: !(Maybe (Jid, Bool)) , toJid :: !(Maybe (Jid, Bool))
-- | By specifying these details, Pontarius XMPP will -- | By settings this field, clients can specify the
-- connect to the provided address and port, and will -- network interface to use, override the SRV lookup
-- not perform a DNS look-up -- of the realm, as well as specify the use of a
, srvOverrideDetails :: Maybe (Hostname, PortNumber) -- non-standard port when connecting by IP or
-- connecting to a domain without SRV records.
, socketDetails :: Maybe (Socket, SockAddr)
-- | DNS resolver configuration -- | DNS resolver configuration
, resolvConf :: ResolvConf , resolvConf :: ResolvConf
} }
@ -1039,7 +1042,7 @@ data StreamConfiguration =
instance Default StreamConfiguration where instance Default StreamConfiguration where
def = StreamConfiguration { preferredLang = Nothing def = StreamConfiguration { preferredLang = Nothing
, toJid = Nothing , toJid = Nothing
, srvOverrideDetails = Nothing , socketDetails = Nothing
, resolvConf = defaultResolvConf , resolvConf = defaultResolvConf
} }

Write Preview
Loading…
Cancel
Save