Discover and expose SFT servers in /calls/config/v2 (#1177)

When configured with SFT information, brig will start a thread to discover SFT
servers using DNS SRV records. The discovered servers are then made available on
the `/calls/config/v2` endpoint along with the TURN servers.

Major Changes:

* Move code for SRV lookup from federation-util to dedicated package, delete
federation-util

* Refactor all `List1` to `NonEmpty` in RTCConfiguration

* Integration tests now depend on globally created DNS entries Log whenever sft

* service discovery fails or returns empty Add a safe way to create `HttpsUrl`

* Add deprecation notice to /calls/config swagger docs

Co-authored-by: Akshay Mankar <akshay@wire.com>
Co-authored-by: fisx <mf@zerobuzz.net>

libs/brig-types/brig-types.cabal

@@ -1,10 +1,10 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.31.2.
+-- This file has been generated from package.yaml by hpack version 0.33.0.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 7497d04521f12339e2a8f5537dacf242839dea9034f69e67f0a254b1548cadd9
+-- hash: fe16e52e870cb548573366fe9192319004e52c3e4d2ece172df69e408cbe391b
 
 name:           brig-types
 version:        1.35.0
@@ -21,6 +21,7 @@ library
   exposed-modules:
       Brig.Types
       Brig.Types.Activation
+      Brig.Types.Calling
       Brig.Types.Client
       Brig.Types.Client.Prekey
       Brig.Types.Code
@@ -37,7 +38,6 @@ library
       Brig.Types.Team.Invitation
       Brig.Types.Team.LegalHold
       Brig.Types.Test.Arbitrary
-      Brig.Types.TURN
       Brig.Types.User
       Brig.Types.User.Auth
   other-modules:

libs/brig-types/src/Brig/Types.hs

@@ -21,10 +21,10 @@ module Brig.Types
 where
 
 import Brig.Types.Activation as M
+import Brig.Types.Calling as M
 import Brig.Types.Client as M
 import Brig.Types.Connection as M
 import Brig.Types.Properties as M
 import Brig.Types.Search as M
-import Brig.Types.TURN as M
 import Brig.Types.Team as M
 import Brig.Types.User as M

libs/brig-types/src/Brig/Types/TURN.hs → libs/brig-types/src/Brig/Types/Calling.hs

@@ -15,7 +15,7 @@
 -- 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.Types.TURN
+module Brig.Types.Calling
   ( -- * re-exports
     RTCConfiguration,
     rtcConfiguration,
@@ -50,4 +50,4 @@ module Brig.Types.TURN
   )
 where
 
-import Wire.API.Call.TURN
+import Wire.API.Call.Config

libs/federation-util/federation-util.cabal → libs/dns-util/dns-util.cabal

@@ -1,16 +1,16 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.31.2.
+-- This file has been generated from package.yaml by hpack version 0.33.0.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: d327ef72460d5f79332d80fa4a70516b7351472f50c17a8c491d28c65ec0f024
+-- hash: 82f20a0525faea5f899c0a68fdc8a82623913d8b063f34a6cd4c6e32aa6acf54
 
-name:           federation-util
+name:           dns-util
 version:        0.1.0
-synopsis:       Various helpers for federation
-description:    Small helper functions useful when federating.
-category:       Web
+synopsis:       Library to deal with DNS SRV records
+description:    Library to deal with DNS SRV records
+category:       Network
 author:         Wire Swiss GmbH
 maintainer:     Wire Swiss GmbH <backend@wire.com>
 copyright:      (c) 2020 Wire Swiss GmbH
@@ -20,66 +20,44 @@ build-type:     Simple
 
 library
   exposed-modules:
-      Network.Federation.Util
-      Network.Federation.Util.DNS
-      Network.Federation.Util.Internal
+      Wire.Network.DNS.Effect
+      Wire.Network.DNS.SRV
   other-modules:
-      Paths_federation_util
+      Paths_dns_util
   hs-source-dirs:
       src
   default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns
   ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path
   build-depends:
-      async >=2.0
-    , base >=4.6 && <5.0
-    , bytestring >=0.10
-    , bytestring-conversion >=0.3
-    , containers >=0.5
+      base >=4.6 && <5.0
     , dns
-    , errors >=2.0
-    , exceptions >=0.6
-    , http-types >=0.8
     , imports
+    , polysemy
     , random
-    , stm
-    , streaming-commons >=0.1
-    , string-conversions
     , text >=0.11
-    , tinylog >=0.8
-    , transformers >=0.3
   default-language: Haskell2010
 
 test-suite spec
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
-      Test.DNSSpec
-      Paths_federation_util
+      Test.Wire.Network.DNS.SRVSpec
+      Paths_dns_util
   hs-source-dirs:
       test
   default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns
   ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N
+  build-tool-depends:
+      hspec-discover:hspec-discover
   build-depends:
       QuickCheck
-    , async >=2.0
     , base >=4.6 && <5.0
-    , bytestring >=0.10
-    , bytestring-conversion >=0.3
-    , containers >=0.5
     , dns
-    , errors >=2.0
-    , exceptions >=0.6
-    , federation-util
+    , dns-util
     , hspec
     , hspec-discover
-    , http-types >=0.8
     , imports
+    , polysemy
     , random
-    , stm
-    , streaming-commons >=0.1
-    , string-conversions
     , text >=0.11
-    , tinylog >=0.8
-    , transformers >=0.3
-    , uri-bytestring
   default-language: Haskell2010

libs/federation-util/package.yaml → libs/dns-util/package.yaml

@@ -1,32 +1,21 @@
 defaults:
   local: ../../package-defaults.yaml
-name: federation-util
+name: dns-util
 version: '0.1.0'
-synopsis: Various helpers for federation
-description: Small helper functions useful when federating.
-category: Web
+synopsis: Library to deal with DNS SRV records
+description: Library to deal with DNS SRV records
+category: Network
 author: Wire Swiss GmbH
 maintainer: Wire Swiss GmbH <backend@wire.com>
 copyright: (c) 2020 Wire Swiss GmbH
 license: AGPL-3
 dependencies:
-- async >=2.0
 - base >=4.6 && <5.0
-- bytestring >=0.10
-- bytestring-conversion >=0.3
-- containers >=0.5
-- errors >=2.0
-- exceptions >=0.6
-- http-types >=0.8
-- imports
 - dns
 - random
-- streaming-commons >=0.1
-- string-conversions
-- stm
 - text >=0.11
-- transformers >=0.3
-- tinylog >=0.8
+- imports
+- polysemy
 library:
   source-dirs: src
 
@@ -36,10 +25,10 @@ tests:
     source-dirs:
       - test
     ghc-options: -threaded -rtsopts -with-rtsopts=-N
+    build-tools:
+    - hspec-discover:hspec-discover
     dependencies:
       - hspec
       - hspec-discover
       - QuickCheck
-      - federation-util
-      - uri-bytestring
-
+      - dns-util

services/brig/src/Brig/TURN.hs → libs/dns-util/src/Wire/Network/DNS/Effect.hs

@@ -15,25 +15,22 @@
 -- 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.TURN where
+module Wire.Network.DNS.Effect where
 
-import Brig.Types (TurnURI)
-import Control.Lens
-import Data.List1
 import Imports
-import OpenSSL.EVP.Digest (Digest)
-import System.Random.MWC (GenIO, createSystemRandom)
+import Network.DNS (Domain)
+import qualified Network.DNS as DNS
+import Polysemy
+import Wire.Network.DNS.SRV
 
-data Env = Env
-  { _turnServers :: List1 TurnURI,
-    _turnTokenTTL :: Word32,
-    _turnConfigTTL :: Word32,
-    _turnSecret :: ByteString,
-    _turnSHA512 :: Digest,
-    _turnPrng :: GenIO
-  }
+data DNSLookup m a where
+  LookupSRV :: Domain -> DNSLookup m SrvResponse
 
-makeLenses ''Env
+makeSem ''DNSLookup
 
-newEnv :: Digest -> List1 TurnURI -> Word32 -> Word32 -> ByteString -> IO Env
-newEnv sha512 srvs tTTL cTTL secret = Env srvs tTTL cTTL secret sha512 <$> createSystemRandom
+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

libs/federation-util/src/Network/Federation/Util/Internal.hs → libs/dns-util/src/Wire/Network/DNS/SRV.hs

@@ -15,7 +15,7 @@
 -- 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/>.
 
--- Parts of this code, namely functions srvLookup'' and orderSrvResult,
+-- Parts of this code, namely functions interpretResponse and orderSrvResult,
 -- which were taken from http://hackage.haskell.org/package/pontarius-xmpp
 -- are also licensed under the three-clause BSD license:
 --
@@ -55,12 +55,12 @@
 -- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
 -- OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
-module Network.Federation.Util.Internal where
+module Wire.Network.DNS.SRV where
 
 import Control.Category ((>>>))
-import Data.Text.Encoding (encodeUtf8)
+import Data.List.NonEmpty (NonEmpty (..))
 import Imports
-import Network.DNS (DNSError, Domain, ResolvSeed, Resolver, lookupSRV, withResolver)
+import Network.DNS (DNSError, Domain)
 import System.Random (randomRIO)
 
 data SrvEntry = SrvEntry
@@ -78,37 +78,21 @@ data SrvTarget = SrvTarget
   }
   deriving (Eq, Show)
 
-toSrvEntry :: (Word16, Word16, Word16, Domain) -> SrvEntry
-toSrvEntry (prio, weight, port, domain) = SrvEntry prio weight (SrvTarget domain port)
+data SrvResponse
+  = SrvNotAvailable
+  | SrvAvailable (NonEmpty SrvEntry)
+  | SrvResponseError DNSError
+  deriving (Eq, Show)
 
--- Given a prefix (e.g. _wire-server) and a domain (e.g. wire.com),
--- provides a list of A(AAA) names and port numbers upon a successful
--- DNS-SRV request, or `Nothing' if the DNS-SRV request failed.
--- Modified version inspired from http://hackage.haskell.org/package/pontarius-xmpp
-srvLookup' :: Text -> Text -> ResolvSeed -> IO (Maybe [SrvTarget])
-srvLookup' = srvLookup'' lookupSRV
+interpretResponse :: Either DNSError [(Word16, Word16, Word16, Domain)] -> SrvResponse
+interpretResponse = \case
+  Left err -> SrvResponseError err
+  Right [] -> SrvNotAvailable
+  Right [(_, _, _, ".")] -> SrvNotAvailable -- According to RFC2782
+  Right (r : rs) -> SrvAvailable $ fmap toSrvEntry (r :| rs)
 
--- internal version for testing
---
--- FUTUREWORK: return more precise errors than 'Nothing'?
-srvLookup'' ::
-  (Resolver -> Domain -> IO (Either DNSError [(Word16, Word16, Word16, Domain)])) ->
-  Text ->
-  Text ->
-  ResolvSeed ->
-  IO (Maybe [SrvTarget])
-srvLookup'' lookupF prefix realm resolvSeed = withResolver resolvSeed $ \resolver -> do
-  srvResult <- lookupF resolver $ encodeUtf8 $ prefix <> "._tcp." <> realm <> "."
-  case srvResult of
-    -- The service is not available at this domain.
-    Left _ -> return Nothing
-    Right [] -> return Nothing
-    Right [(_, _, _, ".")] -> return Nothing -- "not available" as in RFC2782
-    Right srvResult' -> do
-      let srvEntries = toSrvEntry <$> srvResult'
-      -- Get [(Domain, PortNumber)] of SRV request, if any.
-      -- Sorts the records based on the priority value.
-      Just . fmap srvTarget <$> orderSrvResult srvEntries
+toSrvEntry :: (Word16, Word16, Word16, Domain) -> SrvEntry
+toSrvEntry (prio, weight, port, domain) = SrvEntry prio weight (SrvTarget domain port)
 
 -- FUTUREWORK: maybe improve sorting algorithm here? (with respect to performance and code style)
 --
@@ -121,7 +105,7 @@ srvLookup'' lookupF prefix realm resolvSeed = withResolver resolvSeed $ \resolve
 orderSrvResult :: [SrvEntry] -> IO [SrvEntry]
 orderSrvResult =
   -- Order the result set by priority.
-  sortBy (comparing srvPriority)
+  sortOn srvPriority
     -- Group elements in sublists based on their priority.
     -- The result type is `[[(Word16, Word16, Word16, Domain)]]' (nested list).
     >>> groupBy ((==) `on` srvPriority)
@@ -148,7 +132,7 @@ orderSrvResult =
               (b, (c : e)) -> (b, c, e)
               _ -> error "orderSrvResult: no record with running sum greater than random number"
       -- Remove the running total number from the remaining elements.
-      let remainingSrvs = map (\(srv, _) -> srv) (concat [beginning, end])
+      let remainingSrvs = map fst (concat [beginning, end])
       -- Repeat the ordering procedure on the remaining elements.
       rest <- orderSublist remainingSrvs
       return $ firstSrv : rest