Skip to content
This repository has been archived by the owner on Aug 3, 2021. It is now read-only.

Commit

Permalink
Browse files Browse the repository at this point in the history
Merge pull request #42 from snoyberg/master
Add dns 1.0 and network 2.3.1.0 support
  • Loading branch information
Jon Kristensen committed Sep 17, 2013
2 parents ee54960 + 193e79c commit dd2ad39
Show file tree
Hide file tree
Showing 2 changed files with 25 additions and 5 deletions.
2 changes: 1 addition & 1 deletion pontarius-xmpp.cabal
Expand Up @@ -56,7 +56,7 @@ Library
, iproute >=1.2.4
, lifted-base >=0.1.0.1
, mtl >=2.0.0.0
, network >=2.4.1.0
, network >=2.3.1.0
, pureMD5 >=2.1.2.1
, resourcet >=0.3.0
, random >=1.0.0.0
Expand Down
28 changes: 24 additions & 4 deletions source/Network/Xmpp/Stream.hs
@@ -1,5 +1,6 @@
{-# OPTIONS_HADDOCK hide #-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
Expand Down Expand Up @@ -607,14 +608,25 @@ connectSrv config host = do
"The hostname could not be validated."
throwError XmppIllegalTcpDetails

showPort :: PortID -> String
#if MIN_VERSION_network(2, 4, 1)
showPort = show
#else
showPort (PortNumber x) = "PortNumber " ++ show x
showPort (Service x) = "Service " ++ show x
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
showPort (UnixSocket x) = "UnixSocket " ++ show x
#endif
#endif

-- Connects to a list of addresses and ports. Surpresses any exceptions from
-- connectTcp.
connectTcp :: [(HostName, PortID)] -> IO (Maybe Handle)
connectTcp [] = return Nothing
connectTcp ((address, port):remainder) = do
result <- Ex.try $ (do
debugM "Pontarius.Xmpp" $ "Connecting to " ++ address ++ " on port " ++
(show port) ++ "."
(showPort port) ++ "."
connectTo address port) :: IO (Either Ex.IOException Handle)
case result of
Right handle -> do
Expand All @@ -624,13 +636,21 @@ connectTcp ((address, port):remainder) = do
debugM "Pontarius.Xmpp" "Connection to HostName could not be established."
connectTcp remainder

#if MIN_VERSION_dns(1, 0, 0)
fixDnsResult :: Either e a -> Maybe a
fixDnsResult = either (const Nothing) Just
#else
fixDnsResult :: Maybe a -> Maybe a
fixDnsResult = id
#endif

-- 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.
-- Surpresses all IO exceptions.
resolvAndConnectTcp :: ResolvSeed -> Domain -> Int -> IO (Maybe Handle)
resolvAndConnectTcp resolvSeed domain port = do
aaaaResults <- (Ex.try $ rethrowErrorCall $ withResolver resolvSeed $
\resolver -> lookupAAAA resolver domain) :: IO (Either Ex.IOException (Maybe [IPv6]))
\resolver -> fmap fixDnsResult $ lookupAAAA resolver domain) :: IO (Either Ex.IOException (Maybe [IPv6]))
handle <- case aaaaResults of
Right Nothing -> return Nothing
Right (Just ipv6s) -> connectTcp $
Expand All @@ -641,7 +661,7 @@ resolvAndConnectTcp resolvSeed domain port = do
case handle of
Nothing -> do
aResults <- (Ex.try $ rethrowErrorCall $ withResolver resolvSeed $
\resolver -> lookupA resolver domain) :: IO (Either Ex.IOException (Maybe [IPv4]))
\resolver -> fmap fixDnsResult $ lookupA resolver domain) :: IO (Either Ex.IOException (Maybe [IPv4]))
handle' <- case aResults of
Left _ -> return Nothing
Right Nothing -> return Nothing
Expand Down Expand Up @@ -684,7 +704,7 @@ srvLookup realm resolvSeed = ErrorT $ do
result <- Ex.try $ rethrowErrorCall $ withResolver resolvSeed
$ \resolver -> do
srvResult <- lookupSRV resolver $ BSC8.pack $ "_xmpp-client._tcp." ++ (Text.unpack realm) ++ "."
case srvResult of
case fixDnsResult srvResult of
Just [(_, _, _, ".")] -> do
debugM "Pontarius.Xmpp" $ "\".\" SRV result returned."
return $ Just []
Expand Down

0 comments on commit dd2ad39

Please sign in to comment.