Use user ID hashes as SFT usernames

changelog.d/2-features/sft-username

@@ -0,0 +1 @@
+The SFT and turn usernames returned by `/calls/config/v2` are now deterministically computed from the user ID

services/brig/brig.cabal

@@ -244,6 +244,7 @@ library
     , cookie                     >=0.4
     , cql
     , cryptobox-haskell          >=0.1.1
+    , crypton
     , currency-codes             >=2.0
     , data-default
     , dns
@@ -274,14 +275,14 @@ library
     , jwt-tools
     , lens                       >=3.8
     , lens-aeson                 >=1.0
+    , memory
     , metrics-core               >=0.3
     , metrics-wai                >=0.3
     , mime
     , mime-mail                  >=0.4
     , mmorph
     , MonadRandom                >=0.5
     , mtl                        >=2.1
-    , mwc-random
     , network                    >=2.4
     , network-conduit-tls
     , openapi3
@@ -554,6 +555,7 @@ test-suite brig-tests
     , tasty
     , tasty-hunit
     , tasty-quickcheck
+    , text
     , time
     , tinylog
     , types-common

services/brig/default.nix

@@ -31,6 +31,7 @@
 , cookie
 , cql
 , cryptobox-haskell
+, crypton
 , currency-codes
 , data-default
 , data-timeout
@@ -70,14 +71,14 @@
 , lens
 , lens-aeson
 , lib
+, memory
 , metrics-core
 , metrics-wai
 , mime
 , mime-mail
 , mmorph
 , MonadRandom
 , mtl
-, mwc-random
 , network
 , network-conduit-tls
 , network-uri
@@ -189,6 +190,7 @@ mkDerivation {
     cookie
     cql
     cryptobox-haskell
+    crypton
     currency-codes
     data-default
     dns
@@ -219,14 +221,14 @@ mkDerivation {
     jwt-tools
     lens
     lens-aeson
+    memory
     metrics-core
     metrics-wai
     mime
     mime-mail
     mmorph
     MonadRandom
     mtl
-    mwc-random
     network
     network-conduit-tls
     openapi3
@@ -397,6 +399,7 @@ mkDerivation {
     tasty
     tasty-hunit
     tasty-quickcheck
+    text
     time
     tinylog
     types-common

services/brig/src/Brig/Calling.hs

@@ -45,7 +45,6 @@ module Brig.Calling
     turnConfigTTL,
     turnSecret,
     turnSHA512,
-    turnPrng,
   )
 where
 
@@ -74,7 +73,6 @@ import Polysemy.TinyLog
 import System.FSNotify qualified as FS
 import System.FilePath qualified as Path
 import System.Logger qualified as Log
-import System.Random.MWC (GenIO, createSystemRandom)
 import System.Random.Shuffle
 import UnliftIO (Async)
 import UnliftIO.Async qualified as Async
@@ -189,7 +187,6 @@ srvDiscoveryLoop domain discoveryInterval saveAction = forever $ do
 data SFTTokenEnv = SFTTokenEnv
   { sftTokenTTL :: Word32,
     sftTokenSecret :: ByteString,
-    sftTokenPRNG :: GenIO,
     sftTokenSHA :: Digest
   }
 
@@ -214,7 +211,6 @@ mkSFTTokenEnv :: Digest -> Opts.SFTTokenOptions -> IO SFTTokenEnv
 mkSFTTokenEnv digest opts =
   SFTTokenEnv (Opts.sttTTL opts)
     <$> BS.readFile (Opts.sttSecret opts)
-    <*> createSystemRandom
     <*> pure digest
 
 -- | Start SFT service discovery synchronously
@@ -240,8 +236,7 @@ data TurnEnv = TurnEnv
     _turnTokenTTL :: Word32,
     _turnConfigTTL :: Word32,
     _turnSecret :: ByteString,
-    _turnSHA512 :: Digest,
-    _turnPrng :: GenIO
+    _turnSHA512 :: Digest
   }
 
 makeLenses ''TurnEnv
@@ -260,7 +255,6 @@ mkTurnEnv serversSource _turnTokenTTL _turnConfigTTL _turnSecret _turnSHA512 = d
       TurnServersFromFiles files
         <$> newIORef NotDiscoveredYet
         <*> newIORef NotDiscoveredYet
-  _turnPrng <- createSystemRandom
   pure $ TurnEnv {..}
 
 turnServersV1 :: (MonadIO m) => TurnServers -> m (Discovery (NonEmpty TurnURI))

services/brig/src/Brig/Calling/API.hs

@@ -21,6 +21,7 @@
 module Brig.Calling.API
   ( getCallsConfig,
     getCallsConfigV2,
+    base26,
 
     -- * Exposed for testing purposes
     newConfig,
@@ -40,22 +41,24 @@ import Brig.Options (ListAllSFTServers (..))
 import Brig.Options qualified as Opt
 import Control.Error (hush, throwE)
 import Control.Lens
+import Crypto.Hash qualified as Crypto
+import Data.ByteArray (convert)
+import Data.ByteString qualified as B
 import Data.ByteString.Conversion
-import Data.ByteString.Lens
+import Data.ByteString.Lazy qualified as BL
 import Data.Id
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.List.NonEmpty qualified as NonEmpty
 import Data.Misc (HttpsUrl)
 import Data.Range
 import Data.Text.Ascii (AsciiBase64, encodeBase64)
-import Data.Text.Strict.Lens
 import Data.Time.Clock.POSIX
+import Data.UUID qualified as UUID
 import Imports hiding (head)
 import OpenSSL.EVP.Digest (Digest, hmacBS)
 import Polysemy
 import Polysemy.Error qualified as Polysemy
 import System.Logger.Class qualified as Log
-import System.Random.MWC qualified as MWC
 import Wire.API.Call.Config qualified as Public
 import Wire.API.Team.Feature (AllFeatureConfigs (afcConferenceCalling), FeatureStatus (FeatureStatusDisabled, FeatureStatusEnabled), wsStatus)
 import Wire.Error
@@ -88,7 +91,7 @@ getCallsConfigV2 uid _ limit = do
     lift
       . liftSem
       . Polysemy.runError
-      $ newConfig env discoveredServers staticUrl sftEnv' limit sftListAllServers (CallsConfigV2 sftFederation) shared
+      $ newConfig uid env discoveredServers staticUrl sftEnv' limit sftListAllServers (CallsConfigV2 sftFederation) shared
   handleNoTurnServers eitherConfig
 
 -- | Throws '500 Internal Server Error' when no turn servers are found. This is
@@ -124,7 +127,7 @@ getCallsConfig uid _ = do
       . lift
       . liftSem
       . Polysemy.runError
-      $ newConfig env discoveredServers Nothing Nothing Nothing HideAllSFTServers CallsConfigDeprecated shared
+      $ newConfig uid env discoveredServers Nothing Nothing Nothing HideAllSFTServers CallsConfigDeprecated shared
   handleNoTurnServers eitherConfig
   where
     -- In order to avoid being backwards incompatible, remove the `transport` query param from the URIs
@@ -153,6 +156,7 @@ newConfig ::
     Member SFT r,
     Member (Polysemy.Error NoTurnServers) r
   ) =>
+  UserId ->
   Calling.TurnEnv ->
   Discovery (NonEmpty Public.TurnURI) ->
   Maybe HttpsUrl ->
@@ -162,7 +166,7 @@ newConfig ::
   CallsConfigVersion ->
   Bool ->
   Sem r Public.RTCConfiguration
-newConfig env discoveredServers sftStaticUrl mSftEnv limit listAllServers version shared = do
+newConfig uid env discoveredServers sftStaticUrl mSftEnv limit listAllServers version shared = do
   -- randomize list of servers (before limiting the list, to ensure not always the same servers are chosen if limit is set)
   randomizedUris <-
     liftIO . randomize
@@ -173,7 +177,7 @@ newConfig env discoveredServers sftStaticUrl mSftEnv limit listAllServers versio
   -- randomize again (as limitedList partially re-orders uris)
   finalUris <- liftIO $ randomize limitedUris
   srvs <- for finalUris $ \uri -> do
-    u <- liftIO $ genTurnUsername (env ^. turnTokenTTL) (env ^. turnPrng)
+    u <- liftIO $ genTurnUsername (env ^. turnTokenTTL)
     pure . Public.rtcIceServer (pure uri) u $ computeCred (env ^. turnSHA512) (env ^. turnSecret) u
 
   let staticSft = pure . Public.sftServer <$> sftStaticUrl
@@ -211,20 +215,38 @@ newConfig env discoveredServers sftStaticUrl mSftEnv limit listAllServers versio
       NonEmpty.nonEmpty (Public.limitServers (NonEmpty.toList uris) (fromRange lim))
         & fromMaybe (error "newConfig:limitedList: empty list of servers")
 
-    genUsername :: Word32 -> MWC.GenIO -> IO (POSIXTime, Text)
-    genUsername ttl prng = do
-      rnd <- view (packedBytes . utf8) <$> replicateM 16 (MWC.uniformR (97, 122) prng)
-      t <- fromIntegral . (+ ttl) . round <$> getPOSIXTime
-      pure $ (t, rnd)
+    hash :: ByteString -> ByteString
+    hash = convert . Crypto.hash @ByteString @Crypto.SHA256
+
+    genUsername :: UserId -> Text
+    genUsername =
+      base26
+        . foldr (\x r -> fromIntegral x + r * 256) 0
+        . take 16
+        . B.unpack
+        . hash
+        . BL.toStrict
+        . UUID.toByteString
+        . toUUID
 
-    genTurnUsername :: Word32 -> MWC.GenIO -> IO Public.TurnUsername
-    genTurnUsername = (fmap (uncurry Public.turnUsername) .) . genUsername
+    getTime :: Word32 -> IO POSIXTime
+    getTime ttl = fromIntegral . (+ ttl) . round <$> getPOSIXTime
 
-    genSFTUsername :: Word32 -> MWC.GenIO -> IO Public.SFTUsername
-    genSFTUsername = (fmap (uncurry (Public.mkSFTUsername shared)) .) . genUsername
+    genTurnUsername :: Word32 -> IO Public.TurnUsername
+    genTurnUsername ttl =
+      Public.turnUsername
+        <$> getTime ttl
+        <*> pure (genUsername uid)
+
+    genSFTUsername :: Word32 -> IO Public.SFTUsername
+    genSFTUsername ttl =
+      Public.mkSFTUsername shared
+        <$> getTime ttl
+        <*> pure (genUsername uid)
 
     computeCred :: (ToByteString a) => Digest -> ByteString -> a -> AsciiBase64
     computeCred dig secret = encodeBase64 . hmacBS dig secret . toByteString'
+
     authenticate ::
       (Member (Embed IO) r) =>
       Public.SFTServer ->
@@ -233,7 +255,7 @@ newConfig env discoveredServers sftStaticUrl mSftEnv limit listAllServers versio
       maybe
         (pure . Public.nauthSFTServer)
         ( \SFTTokenEnv {..} sftsvr -> do
-            username <- liftIO $ genSFTUsername sftTokenTTL sftTokenPRNG
+            username <- liftIO $ genSFTUsername sftTokenTTL
             let credential = computeCred sftTokenSHA sftTokenSecret username
             pure $ Public.authSFTServer sftsvr username credential
         )

services/brig/src/Brig/Calling/Internal.hs

@@ -20,6 +20,7 @@ module Brig.Calling.Internal where
 import Control.Lens ((?~))
 import Data.ByteString.Char8 qualified as BS
 import Data.Misc (ensureHttpsUrl)
+import Data.Text qualified as T
 import Imports
 import URI.ByteString qualified as URI
 import URI.ByteString.QQ qualified as URI
@@ -40,3 +41,13 @@ sftServerFromSrvTarget (SrvTarget host port) =
       if BS.last bs == '.'
         then BS.init bs
         else bs
+
+base26 :: Integer -> Text
+base26 0 = "a"
+base26 num = T.pack $ go [] num
+  where
+    go :: String -> Integer -> String
+    go acc 0 = acc
+    go acc n =
+      let (q, r) = divMod n 26
+       in go (chr (fromIntegral r + ord 'a') : acc) q

services/brig/test/unit/Test/Brig/Calling.hs

@@ -291,12 +291,13 @@ testSFTStaticDeprecatedEndpoint :: IO ()
 testSFTStaticDeprecatedEndpoint = do
   env <- fst <$> sftStaticEnv
   turnUri <- generate arbitrary
+  uid <- generate arbitrary
   cfg <-
     runM @IO
       . ignoreLogs
       . interpretSFTInMemory mempty
       . throwErrorInIO @_ @NoTurnServers
-      $ newConfig env (Discovered turnUri) Nothing Nothing Nothing HideAllSFTServers CallsConfigDeprecated True
+      $ newConfig uid env (Discovered turnUri) Nothing Nothing Nothing HideAllSFTServers CallsConfigDeprecated True
   assertEqual
     "when SFT static URL is disabled, sft_servers should be empty."
     Set.empty
@@ -305,6 +306,7 @@ testSFTStaticDeprecatedEndpoint = do
 -- The v2 endpoint `GET /calls/config/v2` without an SFT static URL
 testSFTStaticV2NoStaticUrl :: IO ()
 testSFTStaticV2NoStaticUrl = do
+  uid <- generate arbitrary
   env <- fst <$> sftStaticEnv
   let entry1 = SrvEntry 0 0 (SrvTarget "sft1.foo.example.com." 443)
       entry2 = SrvEntry 0 0 (SrvTarget "sft2.foo.example.com." 443)
@@ -323,7 +325,7 @@ testSFTStaticV2NoStaticUrl = do
       . ignoreLogs
       . interpretSFTInMemory mempty
       . throwErrorInIO @_ @NoTurnServers
-      $ newConfig env (Discovered turnUri) Nothing (Just sftEnv) (Just . unsafeRange $ 2) ListAllSFTServers (CallsConfigV2 Nothing) True
+      $ newConfig uid env (Discovered turnUri) Nothing (Just sftEnv) (Just . unsafeRange $ 2) ListAllSFTServers (CallsConfigV2 Nothing) True
   assertEqual
     "when SFT static URL is disabled, sft_servers_all should be from SFT environment"
     (Just . fmap ((^. sftURL) . sftServerFromSrvTarget . srvTarget) . toList $ servers)
@@ -334,12 +336,13 @@ testSFTStaticV2StaticUrlError :: IO ()
 testSFTStaticV2StaticUrlError = do
   (env, staticUrl) <- sftStaticEnv
   turnUri <- generate arbitrary
+  uid <- generate arbitrary
   cfg <-
     runM @IO
       . ignoreLogs
       . interpretSFTInMemory mempty -- an empty lookup map, meaning there was an error
       . throwErrorInIO @_ @NoTurnServers
-      $ newConfig env (Discovered turnUri) (Just staticUrl) Nothing (Just . unsafeRange $ 2) ListAllSFTServers (CallsConfigV2 Nothing) True
+      $ newConfig uid env (Discovered turnUri) (Just staticUrl) Nothing (Just . unsafeRange $ 2) ListAllSFTServers (CallsConfigV2 Nothing) True
   assertEqual
     "when SFT static URL is enabled (and setSftListAllServers is enabled), but returns error, sft_servers_all should be omitted"
     Nothing
@@ -353,12 +356,13 @@ testSFTStaticV2StaticUrlList = do
   -- for sft_servers_all
   servers <- generate $ replicateM 10 arbitrary
   turnUri <- generate arbitrary
+  uid <- generate arbitrary
   cfg <-
     runM @IO
       . ignoreLogs
       . interpretSFTInMemory (Map.singleton staticUrl (SFTGetResponse $ Right servers))
       . throwErrorInIO @_ @NoTurnServers
-      $ newConfig env (Discovered turnUri) (Just staticUrl) Nothing (Just . unsafeRange $ 3) ListAllSFTServers (CallsConfigV2 Nothing) True
+      $ newConfig uid env (Discovered turnUri) (Just staticUrl) Nothing (Just . unsafeRange $ 3) ListAllSFTServers (CallsConfigV2 Nothing) True
   assertEqual
     "when SFT static URL and setSftListAllServers are enabled, sft_servers_all should be from /sft_servers_all.json"
     ((^. sftURL) <$$> Just servers)
@@ -371,12 +375,13 @@ testSFTStaticV2ListAllServersDisabled = do
   -- for sft_servers_all
   servers <- generate $ replicateM 10 arbitrary
   turnUri <- generate arbitrary
+  uid <- generate arbitrary
   cfg <-
     runM @IO
       . ignoreLogs
       . interpretSFTInMemory (Map.singleton staticUrl (SFTGetResponse . Right $ servers))
       . throwErrorInIO @_ @NoTurnServers
-      $ newConfig env (Discovered turnUri) (Just staticUrl) Nothing (Just . unsafeRange $ 3) HideAllSFTServers (CallsConfigV2 Nothing) True
+      $ newConfig uid env (Discovered turnUri) (Just staticUrl) Nothing (Just . unsafeRange $ 3) HideAllSFTServers (CallsConfigV2 Nothing) True
   assertEqual
     "when SFT static URL is enabled and setSftListAllServers is \"disabled\" then sft_servers_all is missing"
     Nothing