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

elaborate connectionDetails 

add ConnectionDetails type
remove Hostname type
rename hostname to checkHostname
master
Philipp Balzarek 13 years ago
parent
c4c0d02985
commit
477dbc14c7
3 changed files with 56 additions and 65 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. 1
      source/Network/Xmpp.hs
  2. 88
      source/Network/Xmpp/Stream.hs
  3. 32
      source/Network/Xmpp/Types.hs

1
source/Network/Xmpp.hs
Unescape View File

@ -29,6 +29,7 @@ module Network.Xmpp
, session , session
, StreamConfiguration(..) , StreamConfiguration(..)
, SessionConfiguration(..) , SessionConfiguration(..)
, ConnectionDetails(..)
-- TODO: Close session, etc. -- TODO: Close session, etc.
-- ** Authentication handlers -- ** Authentication handlers
-- | The use of 'scramSha1' is /recommended/, but 'digestMd5' might be -- | The use of 'scramSha1' is /recommended/, but 'digestMd5' might be

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

@ -19,9 +19,10 @@ import Control.Monad.IO.Class
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.ByteString.Base64 import Data.ByteString.Base64
import Data.ByteString.Char8 as BSC8 import qualified 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
@ -483,60 +484,50 @@ 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 realm = do
case (readMaybe_ realm :: Maybe IPv6, readMaybe_ realm :: Maybe IPv4, hostname (Text.pack realm) :: Maybe Hostname) of case checkHostName (Text.pack realm) of
(Just ipv6, Nothing, _) -> lift $ connectTcp $ Right [(show ipv6, 5222)] Just realm' -> do
(Nothing, Just ipv4, _) -> lift $ connectTcp $ Right [(show ipv4, 5222)] resolvSeed <- lift $ makeResolvSeed (resolvConf config)
(Nothing, Nothing, Just (Hostname realm')) -> do lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..."
resolvSeed <- lift $ makeResolvSeed (resolvConf config) srvRecords <- srvLookup realm' resolvSeed
lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..." case srvRecords of
srvRecords <- srvLookup realm' resolvSeed Nothing -> do
case srvRecords of lift $ debugM "Pontarius.Xmpp"
-- No SRV records. Try fallback lookup. "No SRV records, using fallback process."
Nothing -> do lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ realm)
lift $ debugM "Pontarius.Xmpp" "No SRV records, using fallback process..." 5222
lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ realm) 5222 Just srvRecords' -> do
Just srvRecords' -> do lift $ debugM "Pontarius.Xmpp"
lift $ debugM "Pontarius.Xmpp" "SRV records found, performing A/AAAA lookups..." "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 <- 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 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.
@ -547,7 +538,10 @@ resolvAndConnectTcp resolvSeed domain port = do
\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 $ Right $ Data.List.map (\ipv6 -> (show ipv6, port)) ipv6s Right (Just ipv6s) -> connectTcp $
map (\ipv6 -> ( show ipv6
, PortNumber $ fromIntegral port))
ipv6s
Left e -> return Nothing Left e -> return Nothing
case handle of case handle of
Nothing -> do Nothing -> do
@ -555,7 +549,11 @@ 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 $ Right $ Data.List.map (\ipv4 -> (show ipv4, port)) ipv4s Right (Just ipv4s) -> connectTcp $
map (\ipv4 -> (show ipv4
, 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''

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

@ -37,6 +37,7 @@ module Network.Xmpp.Types
, ConnectionState(..) , ConnectionState(..)
, StreamErrorInfo(..) , StreamErrorInfo(..)
, StanzaHandler , StanzaHandler
, ConnectionDetails(..)
, StreamConfiguration(..) , StreamConfiguration(..)
, langTag , langTag
, Jid(..) , Jid(..)
@ -46,8 +47,7 @@ module Network.Xmpp.Types
, jidFromTexts , jidFromTexts
, StreamEnd(..) , StreamEnd(..)
, InvalidXmppXml(..) , InvalidXmppXml(..)
, Hostname(..) , checkHostName
, hostname
, SessionConfiguration(..) , SessionConfiguration(..)
, TlsBehaviour(..) , TlsBehaviour(..)
) )
@ -70,7 +70,6 @@ import Data.Typeable(Typeable)
import Data.XML.Types import Data.XML.Types
import Network import Network
import Network.DNS import Network.DNS
import Network.Socket
import Network.TLS hiding (Version) import Network.TLS hiding (Version)
import Network.TLS.Extra import Network.TLS.Extra
import qualified Text.NamePrep as SP import qualified Text.NamePrep as SP
@ -1012,6 +1011,10 @@ data InvalidXmppXml = InvalidXmppXml String deriving (Show, Typeable)
instance Exception InvalidXmppXml instance Exception InvalidXmppXml
data ConnectionDetails = UseRealm -- ^ Use realm to resolv host
| UseSrv HostName -- ^ Use this hostname for a SRC lookup
| UseHost HostName PortID -- ^ Use specified host
-- | Configuration settings related to the stream. -- | Configuration settings related to the stream.
data StreamConfiguration = data StreamConfiguration =
StreamConfiguration { -- | Default language when no language tag is set StreamConfiguration { -- | Default language when no language tag is set
@ -1026,7 +1029,7 @@ data StreamConfiguration =
-- of the realm, as well as specify the use of a -- of the realm, as well as specify the use of a
-- non-standard port when connecting by IP or -- non-standard port when connecting by IP or
-- connecting to a domain without SRV records. -- connecting to a domain without SRV records.
, socketDetails :: Maybe (Socket, SockAddr) , connectionDetails :: ConnectionDetails
-- | DNS resolver configuration -- | DNS resolver configuration
, resolvConf :: ResolvConf , resolvConf :: ResolvConf
-- | Whether or not to perform the legacy -- | Whether or not to perform the legacy
@ -1039,11 +1042,10 @@ data StreamConfiguration =
, tlsParams :: TLSParams , tlsParams :: TLSParams
} }
instance Default StreamConfiguration where instance Default StreamConfiguration where
def = StreamConfiguration { preferredLang = Nothing def = StreamConfiguration { preferredLang = Nothing
, toJid = Nothing , toJid = Nothing
, socketDetails = Nothing , connectionDetails = UseRealm
, resolvConf = defaultResolvConf , resolvConf = defaultResolvConf
, establishSession = True , establishSession = True
, tlsBehaviour = PreferTls , tlsBehaviour = PreferTls
@ -1053,22 +1055,12 @@ instance Default StreamConfiguration where
} }
} }
data Hostname = Hostname Text deriving (Eq, Show)
instance Read Hostname where
readsPrec _ x = case hostname (Text.pack x) of
Nothing -> []
Just h -> [(h,"")]
instance IsString Hostname where
fromString = fromJust . hostname . Text.pack
-- | Validates the hostname string in accordance with RFC 1123. -- | Validates the hostname string in accordance with RFC 1123.
hostname :: Text -> Maybe Hostname checkHostName :: Text -> Maybe Text
hostname t = do checkHostName t = do
eitherToMaybeHostname $ AP.parseOnly hostnameP t eitherToMaybeHostName $ AP.parseOnly hostnameP t
where where
eitherToMaybeHostname = either (const Nothing) (Just . Hostname) eitherToMaybeHostName = either (const Nothing) Just
-- Validation of RFC 1123 hostnames. -- Validation of RFC 1123 hostnames.
hostnameP :: AP.Parser Text hostnameP :: AP.Parser Text

Write Preview
Loading…
Cancel
Save