diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Dns.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Dns.hs index 92a68c2cc72..d411f9686c1 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Dns.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Dns.hs @@ -39,6 +39,7 @@ import qualified Data.IP as IP import Data.Void (Void) import qualified Network.DNS as DNS import qualified Network.Socket as Socket +import System.IO.Error import Text.Printf import Ouroboros.Network.ErrorPolicy @@ -89,6 +90,7 @@ withResolver port rs k = do dnsResolve :: forall a m s. ( MonadAsync m + , MonadCatch m , MonadSay m , MonadSTM m , MonadTime m @@ -103,29 +105,42 @@ dnsResolve :: forall a m s. -> DnsSubscriptionTarget -> m (SubscriptionTarget m Socket.SockAddr) dnsResolve tracer getSeed withResolver peerStatesVar beforeConnect (DnsSubscriptionTarget domain _ _) = do - rs <- getSeed - withResolver rs $ \resolver -> do - ipv6Rsps <- newEmptyTMVarM - ipv4Rsps <- newEmptyTMVarM - gotIpv6Rsp <- newTVarM False - - -- Though the DNS lib does have its own timeouts, these do not work - -- on Windows reliably so as a workaround we add an extra layer - -- of timeout on the outside. - -- TODO: Fix upstream dns lib. - -- On windows the aid_ipv6 and aid_ipv4 threads are leaked incase - -- of an exception in the main thread. - res <- timeout 20 $ do - aid_ipv6 <- async $ resolveAAAA resolver gotIpv6Rsp ipv6Rsps - aid_ipv4 <- async $ resolveA resolver gotIpv6Rsp ipv4Rsps - rd_e <- waitEitherCatch aid_ipv6 aid_ipv4 - handleResult ipv6Rsps ipv4Rsps rd_e - case res of - Nothing -> do - -- TODO: the thread timedout, we should trace it - return (SubscriptionTarget $ pure Nothing) - Just st -> - return st + rs_e <- (Right <$> getSeed) `catches` + [ mkHandler (\ (e :: DNS.DNSError) -> + return (Left $ toException e) :: m (Either SomeException a)) + -- On windows getSeed fails with BadConfiguration if the network is down. + , mkHandler (\ (e :: IOError) -> + return (Left $ toException e) :: m (Either SomeException a)) + -- On OSX getSeed can fail with IOError if all network devices are down. + ] + case rs_e of + Left e -> do + traceWith tracer $ DnsTraceLookupException e + return $ listSubscriptionTarget [] + + Right rs -> do + withResolver rs $ \resolver -> do + ipv6Rsps <- newEmptyTMVarM + ipv4Rsps <- newEmptyTMVarM + gotIpv6Rsp <- newTVarM False + + -- Though the DNS lib does have its own timeouts, these do not work + -- on Windows reliably so as a workaround we add an extra layer + -- of timeout on the outside. + -- TODO: Fix upstream dns lib. + -- On windows the aid_ipv6 and aid_ipv4 threads are leaked incase + -- of an exception in the main thread. + res <- timeout 20 $ do + aid_ipv6 <- async $ resolveAAAA resolver gotIpv6Rsp ipv6Rsps + aid_ipv4 <- async $ resolveA resolver gotIpv6Rsp ipv4Rsps + rd_e <- waitEitherCatch aid_ipv6 aid_ipv4 + handleResult ipv6Rsps ipv4Rsps rd_e + case res of + Nothing -> do + -- TODO: the thread timedout, we should trace it + return (SubscriptionTarget $ pure Nothing) + Just st -> + return st where handleResult :: StrictTMVar m [Socket.SockAddr] -> StrictTMVar m [Socket.SockAddr] diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/Subscription.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/Subscription.hs index 986dfb353bc..0aaaa3e5b23 100644 --- a/ouroboros-network-framework/test/Test/Ouroboros/Network/Subscription.hs +++ b/ouroboros-network-framework/test/Test/Ouroboros/Network/Subscription.hs @@ -295,6 +295,7 @@ permCheck a b = L.sort a == L.sort b prop_resolv :: forall m. ( MonadAsync m + , MonadCatch m , MonadSay m , MonadSTM m , MonadTime m