FS-266: Add sft_servers_all to calls/config/v2

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

@@ -0,0 +1 @@
+Extend GET /calls/config/v2 to include all SFT servers in federation

charts/brig/templates/configmap.yaml

@@ -175,6 +175,8 @@ data:
       {{- if .sftDiscoveryIntervalSeconds }}
       sftDiscoveryIntervalSeconds: {{ .sftDiscoveryIntervalSeconds }}
       {{- end }}
+      sftLookupDomain: {{ required "Missing value: .sft.sftLookupDomain" .sftLookupDomain }}
+      sftLookupPort: {{ required "Missing value: .sft.sftLookupPort" .sftLookupPort }}
     {{- end }}
     {{- end }}
 

libs/dns-util/dns-util.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: eb1c3d83585fec582c135dbe676c68498f2546468581882f07fdba8f0d16aec3
+-- hash: d71d0f07f44620f73670692eb75544d71d97efd5ddfd25d72388d073f8cf2494
 
 name:           dns-util
 version:        0.1.0
@@ -20,6 +20,7 @@ build-type:     Simple
 
 library
   exposed-modules:
+      Wire.Network.DNS.A
       Wire.Network.DNS.Effect
       Wire.Network.DNS.Helper
       Wire.Network.DNS.SRV
@@ -33,6 +34,7 @@ library
       base >=4.6 && <5.0
     , dns
     , imports
+    , iproute
     , polysemy
     , random
   default-language: Haskell2010
@@ -55,6 +57,7 @@ test-suite spec
     , dns-util
     , hspec
     , imports
+    , iproute
     , polysemy
     , random
   default-language: Haskell2010

libs/dns-util/package.yaml

@@ -14,6 +14,7 @@ dependencies:
 - dns
 - random
 - imports
+- iproute
 - polysemy
 library:
   source-dirs: src

libs/dns-util/src/Wire/Network/DNS/A.hs

@@ -0,0 +1,32 @@
+-- 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 Wire.Network.DNS.A where
+
+import Data.IP
+import Imports
+import Network.DNS
+
+-- | A response to lookupA, i.e., a reponse to a lookup of IPv4 addresses of a
+-- domain.
+data AResponse
+  = AIPv4s [IPv4]
+  | AResponseError DNSError
+  deriving (Eq)
+
+interpretResponse :: Either DNSError [IPv4] -> AResponse
+interpretResponse = either AResponseError AIPv4s

libs/dns-util/src/Wire/Network/DNS/Effect.hs

@@ -21,20 +21,29 @@ import Imports
 import Network.DNS (Domain, Resolver)
 import qualified Network.DNS as DNS
 import Polysemy
-import Wire.Network.DNS.SRV
+import qualified Wire.Network.DNS.A as A
+import qualified Wire.Network.DNS.SRV as SRV
 
 data DNSLookup m a where
-  LookupSRV :: Domain -> DNSLookup m SrvResponse
+  LookupSRV :: Domain -> DNSLookup m SRV.SrvResponse
+  LookupA :: Domain -> DNSLookup m A.AResponse
 
 makeSem ''DNSLookup
 
 runDNSLookupDefault :: Member (Embed IO) r => Sem (DNSLookup ': r) a -> Sem r a
 runDNSLookupDefault =
-  interpret $ \(LookupSRV domain) -> embed $ do
-    rs <- DNS.makeResolvSeed DNS.defaultResolvConf
-    DNS.withResolver rs $ \resolver ->
-      interpretResponse <$> DNS.lookupSRV resolver domain
+  interpret $ \case
+    LookupSRV domain -> embed $ do
+      rs <- DNS.makeResolvSeed DNS.defaultResolvConf
+      DNS.withResolver rs $ \resolver ->
+        SRV.interpretResponse <$> DNS.lookupSRV resolver domain
+    LookupA domain -> embed $ do
+      rs <- DNS.makeResolvSeed DNS.defaultResolvConf
+      DNS.withResolver rs $ \resolver ->
+        A.interpretResponse <$> DNS.lookupA resolver domain
 
 runDNSLookupWithResolver :: Member (Embed IO) r => Resolver -> Sem (DNSLookup ': r) a -> Sem r a
 runDNSLookupWithResolver resolver =
-  interpret $ \(LookupSRV domain) -> embed (interpretResponse <$> DNS.lookupSRV resolver domain)
+  interpret $ \case
+    LookupSRV domain -> embed (SRV.interpretResponse <$> DNS.lookupSRV resolver domain)
+    LookupA domain -> embed (A.interpretResponse <$> DNS.lookupA resolver domain)

libs/wire-api/src/Wire/API/Call/Config.hs

@@ -25,6 +25,7 @@ module Wire.API.Call.Config
     rtcConfiguration,
     rtcConfIceServers,
     rtcConfSftServers,
+    rtcConfSftServersAll,
     rtcConfTTL,
 
     -- * RTCIceServer
@@ -104,12 +105,18 @@ import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..))
 data RTCConfiguration = RTCConfiguration
   { _rtcConfIceServers :: NonEmpty RTCIceServer,
     _rtcConfSftServers :: Maybe (NonEmpty SFTServer),
-    _rtcConfTTL :: Word32
+    _rtcConfTTL :: Word32,
+    _rtcConfSftServersAll :: Maybe [SFTServer]
   }
   deriving stock (Eq, Show, Generic)
   deriving (Arbitrary) via (GenericUniform RTCConfiguration)
 
-rtcConfiguration :: NonEmpty RTCIceServer -> Maybe (NonEmpty SFTServer) -> Word32 -> RTCConfiguration
+rtcConfiguration ::
+  NonEmpty RTCIceServer ->
+  Maybe (NonEmpty SFTServer) ->
+  Word32 ->
+  Maybe [SFTServer] ->
+  RTCConfiguration
 rtcConfiguration = RTCConfiguration
 
 modelRtcConfiguration :: Doc.Model
@@ -121,19 +128,26 @@ modelRtcConfiguration = Doc.defineModel "RTCConfiguration" $ do
     Doc.description "Array of 'SFTServer' objects (optional)"
   Doc.property "ttl" Doc.int32' $
     Doc.description "Number of seconds after which the configuration should be refreshed (advisory)"
+  Doc.property "sft_servers_all" (Doc.array (Doc.ref modelRtcSftServerUrl)) $
+    Doc.description "Array of 'SFTServer' URLs (optional)"
 
 instance ToJSON RTCConfiguration where
-  toJSON (RTCConfiguration srvs sfts ttl) =
+  toJSON (RTCConfiguration srvs sfts ttl all_servers) =
     object
       ( [ "ice_servers" .= srvs,
           "ttl" .= ttl
         ]
           <> ["sft_servers" .= sfts | isJust sfts]
+          <> ["sft_servers_all" .= all_servers | isJust all_servers]
       )
 
 instance FromJSON RTCConfiguration where
   parseJSON = withObject "RTCConfiguration" $ \o ->
-    RTCConfiguration <$> o .: "ice_servers" <*> o .:? "sft_servers" <*> o .: "ttl"
+    RTCConfiguration
+      <$> o .: "ice_servers"
+      <*> o .:? "sft_servers"
+      <*> o .: "ttl"
+      <*> o .:? "sft_servers_all"
 
 --------------------------------------------------------------------------------
 -- SFTServer
@@ -165,6 +179,12 @@ modelRtcSftServer = Doc.defineModel "RTC SFT Server" $ do
   Doc.property "urls" (Doc.array Doc.string') $
     Doc.description "Array containing exactly one SFT server address of the form 'https://<addr>:<port>'"
 
+modelRtcSftServerUrl :: Doc.Model
+modelRtcSftServerUrl = Doc.defineModel "RTC SFT Server URL" $ do
+  Doc.description "Inspired by WebRTC 'RTCIceServer' object, contains details of SFT servers"
+  Doc.property "urls" (Doc.array Doc.string') $
+    Doc.description "Array containing exactly one SFT server URL"
+
 --------------------------------------------------------------------------------
 -- RTCIceServer
 

libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCConfiguration_user.hs

@@ -152,6 +152,7 @@ testObject_RTCConfiguration_user_1 =
       )
       (Nothing)
       (2)
+      Nothing
   )
 
 testObject_RTCConfiguration_user_2 :: RTCConfiguration
@@ -334,6 +335,7 @@ testObject_RTCConfiguration_user_2 =
           )
       )
       (4)
+      Nothing
   )
 
 testObject_RTCConfiguration_user_3 :: RTCConfiguration
@@ -480,6 +482,7 @@ testObject_RTCConfiguration_user_3 =
           )
       )
       (9)
+      Nothing
   )
 
 testObject_RTCConfiguration_user_4 :: RTCConfiguration
@@ -685,6 +688,7 @@ testObject_RTCConfiguration_user_4 =
           )
       )
       (2)
+      Nothing
   )
 
 testObject_RTCConfiguration_user_5 :: RTCConfiguration
@@ -728,6 +732,7 @@ testObject_RTCConfiguration_user_5 =
           )
       )
       (2)
+      Nothing
   )
 
 testObject_RTCConfiguration_user_6 :: RTCConfiguration
@@ -750,4 +755,5 @@ testObject_RTCConfiguration_user_6 =
       )
       Nothing
       (2)
+      Nothing
   )

services/brig/brig.cabal

@@ -4,7 +4,7 @@ cabal-version: 2.0
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 513c0f5104342fb14b0246f7c44733a84ec36fae97633fc55cb209e0e0bcd087
+-- hash: 244ca5e0c12867ef47ffcfbc056775381028fbc85e5c57eb280afe842e3499d9
 
 name:           brig
 version:        2.0
@@ -167,6 +167,7 @@ library
     , errors >=1.4
     , exceptions >=0.5
     , extended
+    , extra
     , filepath >=1.3
     , fsnotify >=0.2
     , galley-types >=0.75.3
@@ -496,6 +497,7 @@ test-suite brig-tests
     , dns-util
     , http-types
     , imports
+    , iproute
     , polysemy
     , polysemy-wire-zoo
     , retry

services/brig/package.yaml

@@ -57,6 +57,7 @@ library:
   - errors >=1.4
   - exceptions >=0.5
   - extended
+  - extra
   - filepath >=1.3
   - fsnotify >=0.2
   - galley-types >=0.75.3
@@ -160,6 +161,7 @@ tests:
     - dns-util
     - http-types
     - imports
+    - iproute
     - polysemy
     - polysemy-wire-zoo
     - retry

services/brig/src/Brig/Calling.hs

@@ -29,6 +29,7 @@ module Brig.Calling
     newEnv,
     sftDiscoveryLoop,
     discoverSFTServers,
+    discoverSFTServersAll,
     discoveryToMaybe,
     randomize,
     startSFTServiceDiscovery,
@@ -46,9 +47,11 @@ import qualified Brig.Options as Opts
 import Brig.Types (TurnURI)
 import Control.Lens
 import Control.Monad.Random.Class (MonadRandom)
+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
@@ -59,6 +62,7 @@ import Polysemy.TinyLog
 import qualified System.Logger as Log
 import System.Random.MWC (GenIO, createSystemRandom)
 import System.Random.Shuffle
+import Wire.Network.DNS.A
 import Wire.Network.DNS.Effect
 import Wire.Network.DNS.SRV
 
@@ -109,7 +113,9 @@ data SFTEnv = SFTEnv
     sftDiscoveryInterval :: Int,
     -- | maximum amount of servers to give out,
     -- even if more are in the SRV record
-    sftListLength :: Range 1 100 Int
+    sftListLength :: Range 1 100 Int,
+    sftLookupDomain :: DNS.Domain,
+    sftLookupPort :: Port
   }
 
 data Discovery a
@@ -133,6 +139,14 @@ discoverSFTServers domain =
       err (Log.msg ("DNS Lookup failed for SFT Discovery" :: ByteString) . Log.field "Error" (show e))
       pure Nothing
 
+discoverSFTServersAll :: Members [DNSLookup, TinyLog] r => DNS.Domain -> Sem r (Maybe [IPv4])
+discoverSFTServersAll domain =
+  lookupA domain >>= \case
+    AIPv4s ips -> pure . Just $ ips
+    AResponseError e -> do
+      err (Log.msg ("DNS Lookup failed for SFT Discovery" :: ByteString) . Log.field "Error" (show e))
+      pure Nothing
+
 mkSFTDomain :: SFTOptions -> DNS.Domain
 mkSFTDomain SFTOptions {..} = DNS.normalize $ maybe defSftServiceName ("_" <>) sftSRVServiceName <> "._tcp." <> sftBaseDomain
 
@@ -153,6 +167,8 @@ mkSFTEnv opts =
     <*> pure (mkSFTDomain opts)
     <*> pure (diffTimeToMicroseconds (fromMaybe defSftDiscoveryIntervalSeconds (Opts.sftDiscoveryIntervalSeconds opts)))
     <*> pure (fromMaybe defSftListLength (Opts.sftListLength opts))
+    <*> pure (Opts.sftLookupDomain opts)
+    <*> pure (Opts.sftLookupPort opts)
 
 startSFTServiceDiscovery :: Log.Logger -> SFTEnv -> IO ()
 startSFTServiceDiscovery logger =