diff --git a/changelog.d/6-federation/sft-servers-all-fixup b/changelog.d/6-federation/sft-servers-all-fixup new file mode 100644 index 00000000000..25c1a8fb06d --- /dev/null +++ b/changelog.d/6-federation/sft-servers-all-fixup @@ -0,0 +1 @@ +Improve Brig's configuration for SFTs and fix a call to SFT servers diff --git a/charts/brig/templates/configmap.yaml b/charts/brig/templates/configmap.yaml index 967217453d1..88be747050b 100644 --- a/charts/brig/templates/configmap.yaml +++ b/charts/brig/templates/configmap.yaml @@ -175,8 +175,6 @@ data: {{- if .sftDiscoveryIntervalSeconds }} sftDiscoveryIntervalSeconds: {{ .sftDiscoveryIntervalSeconds }} {{- end }} - sftLookupDomain: {{ required "Missing value: .sft.sftLookupDomain" .sftLookupDomain }} - sftLookupPort: {{ required "Missing value: .sft.sftLookupPort" .sftLookupPort }} {{- end }} {{- end }} @@ -230,5 +228,13 @@ data: {{- if .setSftStaticUrl }} setSftStaticUrl: {{ .setSftStaticUrl }} {{- end }} + {{- if .setSftLookup }} + {{- with .setSftLookup }} + setSftLookup: + domain: {{ required "Missing value: .setSftLookup.domain" .setSftLookup.domain }} + port: {{ required "Missing value: .setSftLookup.port" .setSftLookup.port }} + isTestingEnvironment: {{ .setSftLookup.isTestingEnvironment }} + {{- end }} + {{- end }} {{- end }} {{- end }} diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 17a6c70c7b8..fe097e533ae 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -4,7 +4,7 @@ cabal-version: 2.0 -- -- see: https://github.com/sol/hpack -- --- hash: 244ca5e0c12867ef47ffcfbc056775381028fbc85e5c57eb280afe842e3499d9 +-- hash: addf4b080e564149f44c6cdb33c824734aa68cc9ff021f41268938902e2958b0 name: brig version: 2.0 @@ -64,6 +64,7 @@ library Brig.Data.User Brig.Data.UserKey Brig.Data.UserPendingActivation + Brig.Effects.SFT Brig.Email Brig.Federation.Client Brig.Index.Eval @@ -154,6 +155,7 @@ library , cassandra-util >=0.16.2 , comonad , conduit >=1.2.8 + , connection , containers >=0.5 , cookie >=0.4 , cryptobox-haskell >=0.1.1 @@ -177,6 +179,7 @@ library , html-entities >=1.1 , http-client >=0.5 , http-client-openssl >=0.2 + , http-client-tls , http-media , http-types >=0.8 , imports diff --git a/services/brig/brig.integration.yaml b/services/brig/brig.integration.yaml index b5ca314dfb9..07175fdd7be 100644 --- a/services/brig/brig.integration.yaml +++ b/services/brig/brig.integration.yaml @@ -178,6 +178,12 @@ optSettings: # Remember to keep it the same in Galley. setFederationDomain: example.com setFeatureFlags: # see #RefConfigOptions in `/docs/reference` + # FUTUREWORK: Replace the following SFT DNS lookup parameters with something + # to be added to the CI environment + setSftLookup: + domain: sftd.integration-tests.zinfra.io + port: 443 + isTestingEnvironment: true logLevel: Warn # ^ NOTE: We log too much in brig, if we set this to Info like other services, running tests diff --git a/services/brig/package.yaml b/services/brig/package.yaml index 02cd7dbf32b..0f10e5f4b24 100644 --- a/services/brig/package.yaml +++ b/services/brig/package.yaml @@ -44,6 +44,7 @@ library: - cassandra-util >=0.16.2 - comonad - conduit >=1.2.8 + - connection - containers >=0.5 - cookie >=0.4 - cryptobox-haskell >=0.1.1 @@ -71,6 +72,7 @@ library: - html-entities >=1.1 - http-client >=0.5 - http-client-openssl >=0.2 + - http-client-tls - http-media - http-types >=0.8 - imports diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 326ca0b0a24..6f68e03adf2 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -214,7 +214,7 @@ newEnv o = do eventsQueue <- case Opt.internalEventsQueue (Opt.internalEvents o) of StompQueue q -> pure (StompQueue q) SqsQueue q -> SqsQueue <$> AWS.getQueueUrl (aws ^. AWS.amazonkaEnv) q - mSFTEnv <- mapM Calling.mkSFTEnv $ Opt.sft o + mSFTEnv <- mapM Calling.mkSFTEnv $ (,Opt.setSftLookup . Opt.optSettings $ o) <$> Opt.sft o prekeyLocalLock <- case Opt.randomPrekeys o of Just True -> Just <$> newMVar () _ -> pure Nothing diff --git a/services/brig/src/Brig/Calling.hs b/services/brig/src/Brig/Calling.hs index 9c102058288..97537d82cbe 100644 --- a/services/brig/src/Brig/Calling.hs +++ b/services/brig/src/Brig/Calling.hs @@ -51,7 +51,6 @@ import Data.IP import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty import Data.List1 -import Data.Misc (Port (..)) import Data.Range import Data.Time.Clock (DiffTime, diffTimeToPicoseconds) import Imports @@ -114,8 +113,7 @@ data SFTEnv = SFTEnv -- | maximum amount of servers to give out, -- even if more are in the SRV record sftListLength :: Range 1 100 Int, - sftLookupDomain :: DNS.Domain, - sftLookupPort :: Port + sftLookup :: Maybe Opts.SFTLookup } data Discovery a @@ -160,15 +158,14 @@ sftDiscoveryLoop SFTEnv {..} = forever $ do Just es -> atomicWriteIORef sftServers (Discovered (SFTServers es)) threadDelay sftDiscoveryInterval -mkSFTEnv :: SFTOptions -> IO SFTEnv -mkSFTEnv opts = +mkSFTEnv :: (SFTOptions, Maybe Opts.SFTLookup) -> IO SFTEnv +mkSFTEnv (opts, msftLookup) = SFTEnv <$> newIORef NotDiscoveredYet <*> pure (mkSFTDomain opts) <*> pure (diffTimeToMicroseconds (fromMaybe defSftDiscoveryIntervalSeconds (Opts.sftDiscoveryIntervalSeconds opts))) <*> pure (fromMaybe defSftListLength (Opts.sftListLength opts)) - <*> pure (Opts.sftLookupDomain opts) - <*> pure (Opts.sftLookupPort opts) + <*> pure msftLookup startSFTServiceDiscovery :: Log.Logger -> SFTEnv -> IO () startSFTServiceDiscovery logger = diff --git a/services/brig/src/Brig/Calling/API.hs b/services/brig/src/Brig/Calling/API.hs index 4e500c9f417..44c1d2b7d2a 100644 --- a/services/brig/src/Brig/Calling/API.hs +++ b/services/brig/src/Brig/Calling/API.hs @@ -27,6 +27,7 @@ import Brig.App import Brig.Calling import qualified Brig.Calling as Calling import Brig.Calling.Internal +import Brig.Effects.SFT import qualified Brig.Options as Opt import Control.Lens import Data.ByteString.Conversion @@ -43,7 +44,8 @@ import Data.Text.Ascii (AsciiBase64, encodeBase64) import Data.Text.Strict.Lens import Data.Time.Clock.POSIX (getPOSIXTime) import Imports hiding (head) -import Network.HTTP.Client hiding (Response) +import Network.Connection +import Network.HTTP.Client.TLS (mkManagerSettings, newTlsManager, newTlsManagerWith) import Network.Wai (Response) import Network.Wai.Predicate hiding (and, result, setStatus, (#)) import Network.Wai.Routing hiding (toList) @@ -101,9 +103,8 @@ getCallsConfigV2 _ _ limit = do env <- liftIO . readIORef =<< view turnEnvV2 staticUrl <- view $ settings . Opt.sftStaticUrl sftEnv' <- view sftEnv - httpMan <- view httpManager logger <- view applog - newConfig env staticUrl sftEnv' limit httpMan logger + newConfig env staticUrl sftEnv' limit logger getCallsConfigH :: JSON ::: UserId ::: ConnId -> Handler Response getCallsConfigH (_ ::: uid ::: connid) = @@ -112,9 +113,8 @@ getCallsConfigH (_ ::: uid ::: connid) = getCallsConfig :: UserId -> ConnId -> Handler Public.RTCConfiguration getCallsConfig _ _ = do env <- liftIO . readIORef =<< view turnEnv - httpMan <- view httpManager logger <- view applog - dropTransport <$> newConfig env Nothing Nothing Nothing httpMan logger + dropTransport <$> newConfig env Nothing Nothing Nothing logger where -- In order to avoid being backwards incompatible, remove the `transport` query param from the URIs dropTransport :: Public.RTCConfiguration -> Public.RTCConfiguration @@ -129,10 +129,9 @@ newConfig :: Maybe HttpsUrl -> Maybe SFTEnv -> Maybe (Range 1 10 Int) -> - Manager -> Logger -> m Public.RTCConfiguration -newConfig env sftStaticUrl mSftEnv limit httpMan logger = do +newConfig env sftStaticUrl mSftEnv limit logger = do let (sha, secret, tTTL, cTTL, prng) = (env ^. turnSHA512, env ^. turnSecret, env ^. turnTokenTTL, env ^. turnConfigTTL, env ^. turnPrng) -- randomize list of servers (before limiting the list, to ensure not always the same servers are chosen if limit is set) randomizedUris <- liftIO $ randomize (List1.toNonEmpty $ env ^. turnServers) @@ -153,27 +152,27 @@ newConfig env sftStaticUrl mSftEnv limit httpMan logger = do let subsetLength = Calling.sftListLength actualSftEnv liftIO $ mapM (getRandomSFTServers subsetLength) sftSrvEntries - let mSftServers = staticSft <|> sftServerFromSrvTarget . srvTarget <$$> sftEntries - mSftServersAll :: Maybe (Maybe [SFTServer]) <- for mSftEnv $ \e -> liftIO $ do - response <- runM . runTinyLog logger . runDNSLookupDefault . discoverSFTServersAll . sftLookupDomain $ e + mSftServersAll :: Maybe (Maybe [SFTServer]) <- for (mSftEnv >>= sftLookup) $ \sftl -> liftIO $ do + httpMan <- + if Opt.sftlIsTestEnv sftl + then + let s = TLSSettingsSimple True False True + in newTlsManagerWith $ mkManagerSettings s Nothing + else newTlsManager + response <- + runM + . runTinyLog logger + . runDNSLookupDefault + . discoverSFTServersAll + . Opt.unLookupDomain + . Opt.sftlDomain + $ sftl case response of Nothing -> pure $ Nothing @[SFTServer] - Just ips -> fmap (eitherToMaybe @String @[SFTServer] . sequence) $ - for ips $ \ip -> do - let req = - parseRequest_ $ - mconcat - [ "GET ", - show ip, - ":", - show . sftLookupPort $ e, - "/sft/url" - ] - -- TODO: introduce an effect for talking to SFT. Perhaps this could be a - -- part of an existing effect External. - sftUrlResponse <- liftIO (responseBody <$> httpLbs req httpMan) - pure @IO . fmap Public.sftServer . runParser' (parser @HttpsUrl) $ sftUrlResponse + Just ips -> fmap (eitherToMaybe @SFTError @[SFTServer] . sequence) $ + for ips $ \ip -> runM . interpretSFT httpMan $ sftGetClientUrl ip (Opt.sftlPort sftl) + let mSftServers = staticSft <|> sftServerFromSrvTarget . srvTarget <$$> sftEntries pure $ Public.rtcConfiguration srvs mSftServers cTTL (join mSftServersAll) where limitedList :: NonEmpty Public.TurnURI -> Range 1 10 Int -> NonEmpty Public.TurnURI diff --git a/services/brig/src/Brig/Effects/SFT.hs b/services/brig/src/Brig/Effects/SFT.hs new file mode 100644 index 00000000000..2297a7a1df1 --- /dev/null +++ b/services/brig/src/Brig/Effects/SFT.hs @@ -0,0 +1,68 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Brig.Effects.SFT where + +import Data.ByteString (unsnoc) +import qualified Data.ByteString.Char8 as BS8 +import Data.ByteString.Conversion.From +import Data.ByteString.Internal (ByteString (PS), w2c) +import Data.ByteString.Unsafe (unsafeTake) +import Data.IP +import Data.Misc +import Data.String.Conversions (cs) +import Imports +import Network.HTTP.Client +import Polysemy +import Polysemy.Internal +import Wire.API.Call.Config + +newtype SFTError = SFTError {unSFTError :: String} + +data SFT m a where + SFTGetClientUrl :: IPv4 -> Port -> SFT m (Either SFTError SFTServer) + +sftGetClientUrl :: Member SFT r => IPv4 -> Port -> Sem r (Either SFTError SFTServer) +sftGetClientUrl ipAddr port = send $ SFTGetClientUrl ipAddr port + +interpretSFT :: Member (Embed IO) r => Manager -> Sem (SFT ': r) a -> Sem r a +interpretSFT httpManager = interpret $ \(SFTGetClientUrl ipAddr port) -> do + let req = + parseRequest_ $ + mconcat + [ "GET https://", + show ipAddr, + ":", + show . portNumber $ port, + "/sft/url" + ] + sftUrlResponse <- liftIO (responseBody <$> httpLbs req httpManager) + pure . bimap SFTError sftServer . runParser' (parser @HttpsUrl) . cs . strip . cs $ sftUrlResponse + where + -- FUTUREWORK: remove this adopted code once upgraded to bytestring >= 0.10.12.0 + strip :: BS8.ByteString -> BS8.ByteString + strip = BS8.dropWhile isSpace . dropWhileEnd' isSpace + where + dropWhileEnd' :: (Char -> Bool) -> BS8.ByteString -> BS8.ByteString + dropWhileEnd' f ps = unsafeTake (findFromEndUntil (not . f . w2c) ps) ps + findFromEndUntil :: (Word8 -> Bool) -> BS8.ByteString -> Int + findFromEndUntil f ps@(PS _ _ l) = case unsnoc ps of + Nothing -> 0 + Just (b, c) -> + if f c + then l + else findFromEndUntil f b diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 5d73b27e89e..ce19a26eded 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -495,10 +495,46 @@ data Settings = Settings -- config will always return this entry. This is useful in Kubernetes -- where SFTs are deployed behind a load-balancer. In the long-run the SRV -- fetching logic can go away completely - setSftStaticUrl :: !(Maybe HttpsUrl) + setSftStaticUrl :: !(Maybe HttpsUrl), + setSftLookup :: !(Maybe SFTLookup) } deriving (Show, Generic) +data SFTLookup = SFTLookup + { sftlDomain :: !LookupDomain, + sftlPort :: !Port, + -- FUTUREWORK: Get rid of the test environment flag below. This is to be + -- done by not looking up A records and consequently making GET requests via + -- HTTPS based on IP addresses, instead of domain names. + + -- | Set to True if running in a test environment. This will avoid + -- performing SSL checks in a request to an SFT server. The default value is + -- False. + sftlIsTestEnv :: Bool + } + deriving (Show, Generic) + +instance FromJSON SFTLookup where + parseJSON = Aeson.withObject "SFTLookup" $ \o -> do + d <- o Aeson..: "domain" + p <- o Aeson..: "port" + t <- o Aeson..:? "isTestingEnvironment" Aeson..!= False + pure $ SFTLookup d p t + +newtype LookupDomain = LookupDomain {unLookupDomain :: DNS.Domain} + deriving stock (Show, Generic) + +instance FromJSON LookupDomain where + parseJSON (Y.String s) = + LookupDomain <$> Y.withText "LookupDomain" asciiOnly (Y.String s) + where + asciiOnly :: Text -> Y.Parser ByteString + asciiOnly t = + if Text.all Char.isAscii t + then pure $ Text.encodeUtf8 t + else fail $ "Expected ascii string only, found: " <> Text.unpack t + parseJSON _ = fail "Expected a String" + -- | The analog to `GT.FeatureFlags`. This type tracks only the things that we need to -- express our current cloud business logic. -- @@ -612,9 +648,7 @@ data SFTOptions = SFTOptions { sftBaseDomain :: !DNS.Domain, sftSRVServiceName :: !(Maybe ByteString), -- defaults to defSftServiceName if unset sftDiscoveryIntervalSeconds :: !(Maybe DiffTime), -- defaults to defSftDiscoveryIntervalSeconds - sftListLength :: !(Maybe (Range 1 100 Int)), -- defaults to defSftListLength - sftLookupDomain :: !DNS.Domain, - sftLookupPort :: !Port + sftListLength :: !(Maybe (Range 1 100 Int)) -- defaults to defSftListLength } deriving (Show, Generic) @@ -625,8 +659,6 @@ instance FromJSON SFTOptions where <*> (mapM asciiOnly =<< o .:? "sftSRVServiceName") <*> (secondsToDiffTime <$$> o .:? "sftDiscoveryIntervalSeconds") <*> (o .:? "sftListLength") - <*> (asciiOnly =<< o .: "sftLookupDomain") - <*> o .: "sftLookupPort" where asciiOnly :: Text -> Y.Parser ByteString asciiOnly t = @@ -688,7 +720,8 @@ Lens.makeLensesFor ("setUserMaxPermClients", "userMaxPermClients"), ("setFederationDomain", "federationDomain"), ("setSqsThrottleMillis", "sqsThrottleMillis"), - ("setSftStaticUrl", "sftStaticUrl") + ("setSftStaticUrl", "sftStaticUrl"), + ("setSftLookup", "sftLookup") ] ''Settings diff --git a/services/brig/test/integration/API/Calling.hs b/services/brig/test/integration/API/Calling.hs index 6515f2272ff..7b06963fdab 100644 --- a/services/brig/test/integration/API/Calling.hs +++ b/services/brig/test/integration/API/Calling.hs @@ -112,16 +112,22 @@ testSFT b opts = do "when SFT discovery is not enabled, sft_servers_all shouldn't be returned" Nothing (cfg ^. rtcConfSftServersAll) - withSettingsOverrides (opts & Opts.sftL ?~ Opts.SFTOptions "integration-tests.zinfra.io" Nothing (Just 0.001) Nothing "integration-tests.zinfra.io" (Port 8585)) $ do + withSettingsOverrides (opts & Opts.sftL ?~ Opts.SFTOptions "integration-tests.zinfra.io" Nothing (Just 0.001) Nothing) $ do cfg1 <- retryWhileN 10 (isNothing . view rtcConfSftServers) (getTurnConfigurationV2 uid b) -- These values are controlled by https://github.com/zinfra/cailleach/tree/77ca2d23cf2959aa183dd945d0a0b13537a8950d/environments/dns-integration-tests let Right server1 = mkHttpsUrl =<< first show (parseURI laxURIParserOptions "https://sft01.integration-tests.zinfra.io:443") let Right server2 = mkHttpsUrl =<< first show (parseURI laxURIParserOptions "https://sft02.integration-tests.zinfra.io:8443") - liftIO $ + liftIO $ do assertEqual "when SFT discovery is enabled, sft_servers should be returned" (Set.fromList [sftServer server1, sftServer server2]) (Set.fromList $ maybe [] NonEmpty.toList $ cfg1 ^. rtcConfSftServers) + void . for (cfg1 ^. rtcConfSftServersAll) $ \allServers -> do + let Right clientUrl = mkHttpsUrl =<< first show (parseURI laxURIParserOptions "https://sft01.avs.zinfra.io") + assertEqual + "when SFT discovery is enabled and SFT lookup configured, sft_servers_all should be returned" + (Set.singleton . sftServer $ clientUrl) + (Set.fromList allServers) modifyAndAssert :: Brig -> diff --git a/services/brig/test/unit/Test/Brig/Calling.hs b/services/brig/test/unit/Test/Brig/Calling.hs index 64af8c99b84..192262f7cd4 100644 --- a/services/brig/test/unit/Test/Brig/Calling.hs +++ b/services/brig/test/unit/Test/Brig/Calling.hs @@ -25,7 +25,6 @@ import Control.Retry import Data.IP import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty -import Data.Misc (Port (..)) import Data.Range import qualified Data.Set as Set import Imports @@ -43,20 +42,21 @@ import Wire.Network.DNS.SRV data FakeDNSEnv = FakeDNSEnv { fakeLookupSrv :: Domain -> SrvResponse, fakeLookupA :: Domain -> A.AResponse, - fakeLookupCalls :: IORef [Domain] + fakeLookupSrvCalls :: IORef [Domain], + fakeLookupACalls :: IORef [Domain] } newFakeDNSEnv :: (Domain -> SrvResponse) -> (Domain -> A.AResponse) -> IO FakeDNSEnv newFakeDNSEnv lookupSrvFn lookupAFn = - FakeDNSEnv lookupSrvFn lookupAFn <$> newIORef [] + FakeDNSEnv lookupSrvFn lookupAFn <$> newIORef [] <*> newIORef [] runFakeDNSLookup :: Member (Embed IO) r => FakeDNSEnv -> Sem (DNSLookup ': r) a -> Sem r a runFakeDNSLookup FakeDNSEnv {..} = interpret $ \case LookupSRV domain -> do - modifyIORef' fakeLookupCalls (++ [domain]) + modifyIORef' fakeLookupSrvCalls (++ [domain]) pure $ fakeLookupSrv domain LookupA domain -> do - modifyIORef' fakeLookupCalls (++ [domain]) + modifyIORef' fakeLookupACalls (++ [domain]) pure $ fakeLookupA domain newtype LogRecorder = LogRecorder {recordedLogs :: IORef [(Log.Level, LByteString)]} @@ -81,12 +81,12 @@ tests = assertEqual "should use the service name to form domain" "_foo._tcp.example.com." - (mkSFTDomain (SFTOptions "example.com" (Just "foo") Nothing Nothing "example.com" (Port 8585))), + (mkSFTDomain (SFTOptions "example.com" (Just "foo") Nothing Nothing)), testCase "when service name is not provided" $ assertEqual "should assume service name to be 'sft'" "_sft._tcp.example.com." - (mkSFTDomain (SFTOptions "example.com" Nothing Nothing Nothing "example.com" (Port 8585))) + (mkSFTDomain (SFTOptions "example.com" Nothing Nothing Nothing)) ], testGroup "sftDiscoveryLoop" $ [ testCase "when service can be discovered" $ void testDiscoveryLoopWhenSuccessful, @@ -117,10 +117,10 @@ testDiscoveryLoopWhenSuccessful = do entry3 = SrvEntry 0 0 (SrvTarget "sft3.foo.example.com." 443) returnedEntries = entry1 :| [entry2, entry3] fakeDNSEnv <- newFakeDNSEnv (\_ -> SrvAvailable returnedEntries) undefined - sftEnv <- mkSFTEnv (SFTOptions "foo.example.com" Nothing (Just 0.001) Nothing "foo.example.com" (Port 8585)) + sftEnv <- mkSFTEnv (SFTOptions "foo.example.com" Nothing (Just 0.001) Nothing, Nothing) discoveryLoop <- Async.async $ runM . ignoreLogs . runFakeDNSLookup fakeDNSEnv $ sftDiscoveryLoop sftEnv - void $ retryEvery10MicrosWhileN 2000 (== 0) (length <$> readIORef (fakeLookupCalls fakeDNSEnv)) + void $ retryEvery10MicrosWhileN 2000 (== 0) (length <$> readIORef (fakeLookupSrvCalls fakeDNSEnv)) -- We don't want to stop the loop before it has written to the sftServers IORef void $ retryEvery10MicrosWhileN 2000 (== NotDiscoveredYet) (readIORef (sftServers sftEnv)) Async.cancel discoveryLoop @@ -132,12 +132,12 @@ testDiscoveryLoopWhenSuccessful = do testDiscoveryLoopWhenUnsuccessful :: IO () testDiscoveryLoopWhenUnsuccessful = do fakeDNSEnv <- newFakeDNSEnv (const SrvNotAvailable) undefined - sftEnv <- mkSFTEnv (SFTOptions "foo.example.com" Nothing (Just 0.001) Nothing "foo.example.com" (Port 8585)) + sftEnv <- mkSFTEnv (SFTOptions "foo.example.com" Nothing (Just 0.001) Nothing, Nothing) discoveryLoop <- Async.async $ runM . ignoreLogs . runFakeDNSLookup fakeDNSEnv $ sftDiscoveryLoop sftEnv -- We wait for at least two lookups to be sure that the lookup loop looped at -- least once - void $ retryEvery10MicrosWhileN 2000 (<= 1) (length <$> readIORef (fakeLookupCalls fakeDNSEnv)) + void $ retryEvery10MicrosWhileN 2000 (<= 1) (length <$> readIORef (fakeLookupSrvCalls fakeDNSEnv)) Async.cancel discoveryLoop actualServers <- readIORef (sftServers sftEnv) @@ -154,7 +154,7 @@ testDiscoveryLoopWhenUnsuccessfulAfterSuccess = do discoveryLoop <- Async.async $ runM . ignoreLogs . runFakeDNSLookup failingFakeDNSEnv $ sftDiscoveryLoop sftEnv -- We wait for at least two lookups to be sure that the lookup loop looped at -- least once - void $ retryEvery10MicrosWhileN 2000 (<= 1) (length <$> readIORef (fakeLookupCalls failingFakeDNSEnv)) + void $ retryEvery10MicrosWhileN 2000 (<= 1) (length <$> readIORef (fakeLookupSrvCalls failingFakeDNSEnv)) Async.cancel discoveryLoop actualServers <- readIORef (sftServers sftEnv) @@ -172,7 +172,7 @@ testDiscoveryLoopWhenURLsChange = do fakeDNSEnv <- newFakeDNSEnv (const $ SrvAvailable newEntries) undefined discoveryLoop <- Async.async $ runM . ignoreLogs . runFakeDNSLookup fakeDNSEnv $ sftDiscoveryLoop sftEnv - void $ retryEvery10MicrosWhileN 2000 (== 0) (length <$> readIORef (fakeLookupCalls fakeDNSEnv)) + void $ retryEvery10MicrosWhileN 2000 (== 0) (length <$> readIORef (fakeLookupSrvCalls fakeDNSEnv)) -- We don't want to stop the loop before it has written to the sftServers IORef void $ retryEvery10MicrosWhileN 2000 (== Discovered (mkSFTServers newEntries)) (readIORef (sftServers sftEnv)) Async.cancel discoveryLoop