Enable Insecure Requests for SFT Lookups in a Test Environment

changelog.d/6-federation/sft-servers-all-fixup

@@ -0,0 +1 @@
+Improve Brig's configuration for SFTs and fix a call to SFT servers

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 }}

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

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

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

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

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 =

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

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 <opensource@wire.com>
+--
+-- 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 <https://www.gnu.org/licenses/>.
+
+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

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