diff --git a/changelog.d/2-features/sft-username b/changelog.d/2-features/sft-username new file mode 100644 index 00000000000..33c2b5cfa35 --- /dev/null +++ b/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 diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index fd3434fe99d..64b93e77f47 100644 --- a/services/brig/brig.cabal +++ b/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,6 +275,7 @@ library , jwt-tools , lens >=3.8 , lens-aeson >=1.0 + , memory , metrics-core >=0.3 , metrics-wai >=0.3 , mime @@ -281,7 +283,6 @@ library , 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 diff --git a/services/brig/default.nix b/services/brig/default.nix index 4a2369d7813..7982eab769f 100644 --- a/services/brig/default.nix +++ b/services/brig/default.nix @@ -31,6 +31,7 @@ , cookie , cql , cryptobox-haskell +, crypton , currency-codes , data-default , data-timeout @@ -70,6 +71,7 @@ , lens , lens-aeson , lib +, memory , metrics-core , metrics-wai , mime @@ -77,7 +79,6 @@ , 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,6 +221,7 @@ mkDerivation { jwt-tools lens lens-aeson + memory metrics-core metrics-wai mime @@ -226,7 +229,6 @@ mkDerivation { 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 diff --git a/services/brig/src/Brig/Calling.hs b/services/brig/src/Brig/Calling.hs index c9501b3fcad..8c1c2749d32 100644 --- a/services/brig/src/Brig/Calling.hs +++ b/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)) diff --git a/services/brig/src/Brig/Calling/API.hs b/services/brig/src/Brig/Calling/API.hs index e97c51e19c2..ec4f823a4a0 100644 --- a/services/brig/src/Brig/Calling/API.hs +++ b/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 ) diff --git a/services/brig/src/Brig/Calling/Internal.hs b/services/brig/src/Brig/Calling/Internal.hs index cc891c77590..d06a25431e4 100644 --- a/services/brig/src/Brig/Calling/Internal.hs +++ b/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 diff --git a/services/brig/test/unit/Test/Brig/Calling.hs b/services/brig/test/unit/Test/Brig/Calling.hs index 3b22294d16c..0dcf489a12a 100644 --- a/services/brig/test/unit/Test/Brig/Calling.hs +++ b/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 diff --git a/services/brig/test/unit/Test/Brig/Calling/Internal.hs b/services/brig/test/unit/Test/Brig/Calling/Internal.hs index 1967f708268..406108db991 100644 --- a/services/brig/test/unit/Test/Brig/Calling/Internal.hs +++ b/services/brig/test/unit/Test/Brig/Calling/Internal.hs @@ -21,9 +21,11 @@ module Test.Brig.Calling.Internal where import Brig.Calling.Internal import Data.Misc (mkHttpsUrl) +import Data.Text qualified as T import Imports import Test.Tasty import Test.Tasty.HUnit +import Test.Tasty.QuickCheck import URI.ByteString.QQ as URI import Wire.API.Call.Config (sftServer) import Wire.Network.DNS.SRV (SrvTarget (SrvTarget)) @@ -44,5 +46,26 @@ tests = "the dot should be stripped from sft server" expectedServer (sftServerFromSrvTarget $ SrvTarget "sft2.env.example.com" 443) - ] + ], + testCase "base26" $ do + "a" @=? base26 0 + "ba" @=? base26 26 + "cfox" @=? base26 38919, + testProperty "base26 . unbase26 === id" $ \(Base26 s) -> base26 (unbase26 s) === s, + testProperty "unbase26 . base26 === id" $ \(NonNegative n) -> unbase26 (base26 n) === n ] + +newtype Base26 = Base26 Text + deriving (Eq, Show) + +mkBase26 :: String -> Base26 +mkBase26 s = Base26 $ case dropWhile (== 'a') s of + "" -> "a" + str -> T.pack str + +instance Arbitrary Base26 where + arbitrary = + mkBase26 <$> listOf1 (fmap chr (chooseInt (ord 'a', ord 'z'))) + +unbase26 :: Text -> Integer +unbase26 = foldl' (\v c -> fromIntegral (ord c - ord 'a') + v * 26) 0 . T.unpack