diff --git a/changelog.d/5-internal/pr-2815 b/changelog.d/5-internal/pr-2815 new file mode 100644 index 00000000000..4462cf30cae --- /dev/null +++ b/changelog.d/5-internal/pr-2815 @@ -0,0 +1 @@ +Brig calling API is now migrated to servant diff --git a/libs/types-common/src/Data/Misc.hs b/libs/types-common/src/Data/Misc.hs index c049381e78d..30d31965968 100644 --- a/libs/types-common/src/Data/Misc.hs +++ b/libs/types-common/src/Data/Misc.hs @@ -74,6 +74,7 @@ import Data.ByteString.Lazy (toStrict) import Data.IP (IP (IPv4, IPv6), toIPv4, toIPv6b) import Data.Range import Data.Schema +import Data.String.Conversions (cs) import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc import qualified Data.Text as Text @@ -83,7 +84,7 @@ import Servant (FromHttpApiData (..)) import Test.QuickCheck (Arbitrary (arbitrary), chooseInteger) import qualified Test.QuickCheck as QC import Text.Read (Read (..)) -import URI.ByteString hiding (Port) +import URI.ByteString hiding (Port, portNumber) import qualified URI.ByteString.QQ as URI.QQ -------------------------------------------------------------------------------- @@ -91,6 +92,7 @@ import qualified URI.ByteString.QQ as URI.QQ newtype IpAddr = IpAddr {ipAddr :: IP} deriving stock (Eq, Ord, Show, Generic) + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema IpAddr) instance S.ToParamSchema IpAddr where toParamSchema _ = mempty & S.type_ ?~ S.SwaggerString @@ -125,24 +127,22 @@ newtype Port = Port {portNumber :: Word16} deriving stock (Eq, Ord, Show, Generic) deriving newtype (Real, Enum, Num, Integral, NFData, Arbitrary) + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema Port) instance Read Port where readsPrec n = map (first Port) . readsPrec n -instance ToJSON IpAddr where - toJSON (IpAddr ip) = A.String (Text.pack $ show ip) - -instance FromJSON IpAddr where - parseJSON = A.withText "IpAddr" $ \txt -> - case readMaybe (Text.unpack txt) of - Nothing -> fail "Failed parsing IP address." - Just ip -> pure (IpAddr ip) +instance ToSchema IpAddr where + schema = toText .= parsedText "IpAddr" fromText + where + toText :: IpAddr -> Text + toText = cs . toByteString -instance ToJSON Port where - toJSON (Port p) = toJSON p + fromText :: Text -> Either String IpAddr + fromText = maybe (Left "Failed parsing IP address.") Right . fromByteString . cs -instance FromJSON Port where - parseJSON = fmap Port . parseJSON +instance ToSchema Port where + schema = Port <$> portNumber .= schema -------------------------------------------------------------------------------- -- Location @@ -158,8 +158,10 @@ instance ToSchema Location where schema = object "Location" $ Location - <$> _latitude .= field "lat" genericToSchema - <*> _longitude .= field "lon" genericToSchema + <$> _latitude + .= field "lat" genericToSchema + <*> _longitude + .= field "lon" genericToSchema instance Show Location where show p = @@ -273,7 +275,10 @@ instance ToSchema HttpsUrl where schema = (decodeUtf8 . toByteString') .= parsedText "HttpsUrl" (runParser parser . encodeUtf8) - & doc' . S.schema . S.example ?~ toJSON ("https://example.com" :: Text) + & doc' + . S.schema + . S.example + ?~ toJSON ("https://example.com" :: Text) instance Cql HttpsUrl where ctype = Tagged BlobColumn @@ -319,7 +324,10 @@ instance ToSchema (Fingerprint Rsa) where schema = (decodeUtf8 . B64.encode . fingerprintBytes) .= parsedText "Fingerprint" (runParser p . encodeUtf8) - & doc' . S.schema . S.example ?~ toJSON ("ioy3GeIjgQRsobf2EKGO3O8mq/FofFxHRqy0T4ERIZ8=" :: Text) + & doc' + . S.schema + . S.example + ?~ toJSON ("ioy3GeIjgQRsobf2EKGO3O8mq/FofFxHRqy0T4ERIZ8=" :: Text) where p :: Chars.Parser (Fingerprint Rsa) p = do @@ -353,7 +361,8 @@ instance Show PlainTextPassword where instance ToSchema PlainTextPassword where schema = PlainTextPassword - <$> fromPlainTextPassword .= untypedRangedSchema 6 1024 schema + <$> fromPlainTextPassword + .= untypedRangedSchema 6 1024 schema instance Arbitrary PlainTextPassword where -- TODO: why 6..1024? For tests we might want invalid passwords as well, e.g. 3 chars diff --git a/libs/wire-api/src/Wire/API/Call/Config.hs b/libs/wire-api/src/Wire/API/Call/Config.hs index 4c45d67875a..f01c1274ffa 100644 --- a/libs/wire-api/src/Wire/API/Call/Config.hs +++ b/libs/wire-api/src/Wire/API/Call/Config.hs @@ -66,23 +66,24 @@ module Wire.API.Call.Config isTcp, isTls, limitServers, - - -- * Swagger - modelRtcConfiguration, - modelRtcIceServer, ) where import Control.Applicative (optional) -import Control.Lens hiding ((.=)) -import Data.Aeson hiding (()) -import Data.Attoparsec.Text hiding (parse) +import Control.Lens hiding (element, enum, (.=)) +import qualified Data.Aeson as A hiding (()) +import qualified Data.Aeson.Types as A +import Data.Attoparsec.Text hiding (Parser, parse) +import qualified Data.Attoparsec.Text as Text import Data.ByteString.Builder +import Data.ByteString.Conversion (toByteString) import qualified Data.ByteString.Conversion as BC import qualified Data.IP as IP import Data.List.NonEmpty (NonEmpty) import Data.Misc (HttpsUrl (..), IpAddr (IpAddr), Port (..)) -import qualified Data.Swagger.Build.Api as Doc +import Data.Schema +import Data.String.Conversions (cs) +import qualified Data.Swagger as S import qualified Data.Text as Text import Data.Text.Ascii import qualified Data.Text.Encoding as TE @@ -110,6 +111,7 @@ data RTCConfiguration = RTCConfiguration } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform RTCConfiguration) + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema RTCConfiguration) rtcConfiguration :: NonEmpty RTCIceServer -> @@ -119,35 +121,18 @@ rtcConfiguration :: RTCConfiguration rtcConfiguration = RTCConfiguration -modelRtcConfiguration :: Doc.Model -modelRtcConfiguration = Doc.defineModel "RTCConfiguration" $ do - Doc.description "A subset of the WebRTC 'RTCConfiguration' dictionary" - Doc.property "ice_servers" (Doc.array (Doc.ref modelRtcIceServer)) $ - Doc.description "Array of 'RTCIceServer' objects" - Doc.property "sft_servers" (Doc.array (Doc.ref modelRtcSftServer)) $ - 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 all SFT servers" - -instance ToJSON RTCConfiguration where - 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" - <*> o .:? "sft_servers_all" +instance ToSchema RTCConfiguration where + schema = + objectWithDocModifier "RTCConfiguration" (description ?~ "A subset of the WebRTC 'RTCConfiguration' dictionary") $ + RTCConfiguration + <$> _rtcConfIceServers + .= fieldWithDocModifier "ice_servers" (description ?~ "Array of 'RTCIceServer' objects") (nonEmptyArray schema) + <*> _rtcConfSftServers + .= maybe_ (optFieldWithDocModifier "sft_servers" (description ?~ "Array of 'SFTServer' objects (optional)") (nonEmptyArray schema)) + <*> _rtcConfTTL + .= fieldWithDocModifier "ttl" (description ?~ "Number of seconds after which the configuration should be refreshed (advisory)") schema + <*> _rtcConfSftServersAll + .= maybe_ (optFieldWithDocModifier "sft_servers_all" (description ?~ "Array of all SFT servers") (array schema)) -------------------------------------------------------------------------------- -- SFTServer @@ -157,34 +142,22 @@ newtype SFTServer = SFTServer } deriving stock (Eq, Show, Ord, Generic) deriving (Arbitrary) via (GenericUniform SFTServer) - -instance ToJSON SFTServer where - toJSON (SFTServer url) = - object - [ "urls" .= [url] - ] - -instance FromJSON SFTServer where - parseJSON = withObject "SFTServer" $ \o -> - o .: "urls" >>= \case - [url] -> pure $ SFTServer url - xs -> fail $ "SFTServer can only have exactly one URL, found " <> show (length xs) + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema SFTServer) + +instance ToSchema SFTServer where + schema = + objectWithDocModifier "SftServer" (description ?~ "Inspired by WebRTC 'RTCIceServer' object, contains details of SFT servers") $ + SFTServer + <$> (pure . _sftURL) + .= fieldWithDocModifier "urls" (description ?~ "Array containing exactly one SFT server address of the form 'https://:'") (withParser (array schema) p) + where + p :: [HttpsUrl] -> A.Parser HttpsUrl + p [url] = pure url + p xs = fail $ "SFTServer can only have exactly one URL, found " <> show (length xs) sftServer :: HttpsUrl -> SFTServer sftServer = SFTServer -modelRtcSftServer :: Doc.Model -modelRtcSftServer = Doc.defineModel "RTC SFT Server" $ 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 address of the form 'https://:'" - -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 @@ -198,31 +171,21 @@ data RTCIceServer = RTCIceServer } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform RTCIceServer) + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema RTCIceServer) rtcIceServer :: NonEmpty TurnURI -> TurnUsername -> AsciiBase64 -> RTCIceServer rtcIceServer = RTCIceServer -modelRtcIceServer :: Doc.Model -modelRtcIceServer = Doc.defineModel "RTCIceServer" $ do - Doc.description "A subset of the WebRTC 'RTCIceServer' object" - Doc.property "urls" (Doc.array Doc.string') $ - Doc.description "Array of TURN server addresses of the form 'turn::'" - Doc.property "username" Doc.string' $ - Doc.description "Username to use for authenticating against the given TURN servers" - Doc.property "credential" Doc.string' $ - Doc.description "Password to use for authenticating against the given TURN servers" - -instance ToJSON RTCIceServer where - toJSON (RTCIceServer urls name cred) = - object - [ "urls" .= urls, - "username" .= name, - "credential" .= cred - ] - -instance FromJSON RTCIceServer where - parseJSON = withObject "RTCIceServer" $ \o -> - RTCIceServer <$> o .: "urls" <*> o .: "username" <*> o .: "credential" +instance ToSchema RTCIceServer where + schema = + objectWithDocModifier "RTCIceServer" (description ?~ "A subset of the WebRTC 'RTCIceServer' object") $ + RTCIceServer + <$> _iceURLs + .= fieldWithDocModifier "urls" (description ?~ "Array of TURN server addresses of the form 'turn::'") (nonEmptyArray schema) + <*> _iceUsername + .= fieldWithDocModifier "username" (description ?~ "Username to use for authenticating against the given TURN servers") schema + <*> _iceCredential + .= fieldWithDocModifier "credential" (description ?~ "Password to use for authenticating against the given TURN servers") schema -------------------------------------------------------------------------------- -- TurnURI @@ -244,6 +207,10 @@ data TurnURI = TurnURI _turiTransport :: Maybe Transport } deriving stock (Eq, Show, Ord, Generic) + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema TurnURI) + +instance ToSchema TurnURI where + schema = (cs . toByteString) .= parsedText "TurnURI" parseTurnURI turnURI :: Scheme -> TurnHost -> Port -> Maybe Transport -> TurnURI turnURI = TurnURI @@ -277,12 +244,6 @@ parseTurnURI = parseOnly (parser <* endOfInput) Just ok -> pure ok Nothing -> fail (err ++ " failed when parsing: " ++ show x) -instance ToJSON TurnURI where - toJSON = String . TE.decodeUtf8 . BC.toByteString' - -instance FromJSON TurnURI where - parseJSON = withText "TurnURI" $ either fail pure . parseTurnURI - instance Arbitrary TurnURI where arbitrary = (getGenericUniform <$> arbitrary) `QC.suchThat` (not . isIPv6) where @@ -295,6 +256,7 @@ data Scheme | SchemeTurns deriving stock (Eq, Show, Ord, Generic) deriving (Arbitrary) via (GenericUniform Scheme) + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema Scheme) instance BC.ToByteString Scheme where builder SchemeTurn = "turn" @@ -307,19 +269,63 @@ instance BC.FromByteString Scheme where "turns" -> pure SchemeTurns _ -> fail $ "Invalid turn scheme: " ++ show t -instance ToJSON Scheme where - toJSON = String . TE.decodeUtf8 . BC.toByteString' - -instance FromJSON Scheme where - parseJSON = - withText "Scheme" $ - either fail pure . BC.runParser BC.parser . TE.encodeUtf8 +instance ToSchema Scheme where + schema = + enum @Text "Scheme" $ + mconcat + [ element "turn" SchemeTurn, + element "turns" SchemeTurns + ] data TurnHost = TurnHostIp IpAddr | TurnHostName Text deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (ToJSON, FromJSON) + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema TurnHost) + +instance ToSchema TurnHost where + schema = turnHostSchema + +data TurnHostTag = TurnHostIpTag | TurnHostNameTag + deriving (Eq, Enum, Bounded) + +tagSchema :: ValueSchema NamedSwaggerDoc TurnHostTag +tagSchema = + enum @Text "TurnHostTag" $ + mconcat + [ element "TurnHostIp" TurnHostIpTag, + element "TurnHostName" TurnHostNameTag + ] + +turnHostSchema :: ValueSchema NamedSwaggerDoc TurnHost +turnHostSchema = + object "TurnHost" $ + fromTagged + <$> toTagged + .= bind + (fst .= field "tag" tagSchema) + (snd .= fieldOver _1 "contents" untaggedSchema) + where + toTagged :: TurnHost -> (TurnHostTag, TurnHost) + toTagged d@(TurnHostIp _) = (TurnHostIpTag, d) + toTagged d@(TurnHostName _) = (TurnHostNameTag, d) + + fromTagged :: (TurnHostTag, TurnHost) -> TurnHost + fromTagged = snd + + untaggedSchema = dispatch $ \case + TurnHostIpTag -> tag _TurnHostIp (unnamed schema) + TurnHostNameTag -> tag _TurnHostName (unnamed schema) + + _TurnHostIp :: Prism' TurnHost IpAddr + _TurnHostIp = prism' TurnHostIp $ \case + TurnHostIp a -> Just a + _ -> Nothing + + _TurnHostName :: Prism' TurnHost Text + _TurnHostName = prism' TurnHostName $ \case + TurnHostName b -> Just b + _ -> Nothing instance BC.FromByteString TurnHost where parser = BC.parser >>= maybe (fail "Invalid turn host") pure . parseTurnHost @@ -362,6 +368,7 @@ data Transport | TransportTCP deriving stock (Eq, Show, Ord, Generic) deriving (Arbitrary) via (GenericUniform Transport) + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema Transport) instance BC.ToByteString Transport where builder TransportUDP = "udp" @@ -374,13 +381,13 @@ instance BC.FromByteString Transport where "tcp" -> pure TransportTCP _ -> fail $ "Invalid turn transport: " ++ show t -instance ToJSON Transport where - toJSON = String . TE.decodeUtf8 . BC.toByteString' - -instance FromJSON Transport where - parseJSON = - withText "Transport" $ - either fail pure . BC.runParser BC.parser . TE.encodeUtf8 +instance ToSchema Transport where + schema = + enum @Text "Transport" $ + mconcat + [ element "udp" TransportUDP, + element "tcp" TransportTCP + ] -------------------------------------------------------------------------------- -- TurnUsername @@ -397,6 +404,7 @@ data TurnUsername = TurnUsername _tuRandom :: Text } deriving stock (Eq, Show, Generic) + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema TurnUsername) -- note that the random value is not checked for well-formedness turnUsername :: POSIXTime -> Text -> TurnUsername @@ -409,13 +417,14 @@ turnUsername expires rnd = _tuRandom = rnd } -instance ToJSON TurnUsername where - toJSON = String . view utf8 . BC.toByteString' +instance ToSchema TurnUsername where + schema = toText .= parsedText "" fromText + where + fromText :: Text -> Either String TurnUsername + fromText = parseOnly (parseTurnUsername <* endOfInput) -instance FromJSON TurnUsername where - parseJSON = - withText "TurnUsername" $ - either fail pure . parseOnly (parseTurnUsername <* endOfInput) + toText :: TurnUsername -> Text + toText = cs . toByteString instance BC.ToByteString TurnUsername where builder tu = @@ -430,7 +439,7 @@ instance BC.ToByteString TurnUsername where <> shortByteString ".r=" <> byteString (view (re utf8) (_tuRandom tu)) -parseTurnUsername :: Parser TurnUsername +parseTurnUsername :: Text.Parser TurnUsername parseTurnUsername = TurnUsername <$> (string "d=" *> fmap (fromIntegral :: Word64 -> POSIXTime) decimal) diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index b48d3e1cb79..ff31ab1ac85 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -41,6 +41,7 @@ import Servant (JSON) import Servant hiding (Handler, JSON, addHeader, respond) import Servant.Swagger (HasSwagger (toSwagger)) import Servant.Swagger.Internal.Orphans () +import Wire.API.Call.Config (RTCConfiguration) import Wire.API.Connection hiding (MissingLegalholdConsent) import Wire.API.Error import Wire.API.Error.Brig @@ -68,6 +69,27 @@ import Wire.API.User.RichInfo (RichInfoAssocList) import Wire.API.User.Search (Contact, RoleFilter, SearchResult, TeamContact, TeamUserSearchSortBy, TeamUserSearchSortOrder) import Wire.API.UserMap +type BrigAPI = + UserAPI + :<|> SelfAPI + :<|> AccountAPI + :<|> ClientAPI + :<|> PrekeyAPI + :<|> UserClientAPI + :<|> ConnectionAPI + :<|> PropertiesAPI + :<|> MLSAPI + :<|> UserHandleAPI + :<|> SearchAPI + :<|> AuthAPI + :<|> CallingAPI + +brigSwagger :: Swagger +brigSwagger = toSwagger (Proxy @BrigAPI) + +------------------------------------------------------------------------------- +-- User API + type MaxUsersForListClientsBulk = 500 type GetUserVerb = @@ -524,8 +546,10 @@ instance ToSchema DeprecatedMatchingResult where object "DeprecatedMatchingResult" $ DeprecatedMatchingResult - <$ const [] .= field "results" (array (null_ @SwaggerDoc)) - <* const [] .= field "auto-connects" (array (null_ @SwaggerDoc)) + <$ const [] + .= field "results" (array (null_ @SwaggerDoc)) + <* const [] + .= field "auto-connects" (array (null_ @SwaggerDoc)) data ActivationRespWithStatus = ActivationResp ActivationResponse @@ -1254,19 +1278,34 @@ type AuthAPI = :> MultiVerb1 'POST '[JSON] (RespondEmpty 200 "Cookies revoked") ) -type BrigAPI = - UserAPI - :<|> SelfAPI - :<|> AccountAPI - :<|> ClientAPI - :<|> PrekeyAPI - :<|> UserClientAPI - :<|> ConnectionAPI - :<|> PropertiesAPI - :<|> MLSAPI - :<|> UserHandleAPI - :<|> SearchAPI - :<|> AuthAPI +------------------------------------------------------------------------------- +-- Calling API -brigSwagger :: Swagger -brigSwagger = toSwagger (Proxy @BrigAPI) +type CallingAPI = + -- Deprecated endpoint, but still used by old clients. + -- See https://github.com/zinfra/backend-issues/issues/1616 for context + Named + "get-calls-config" + ( Summary + "[deprecated] Retrieve TURN server addresses and credentials for \ + \ IP addresses, scheme `turn` and transport `udp` only" + :> ZUser + :> ZConn + :> "calls" + :> "config" + :> Get '[JSON] RTCConfiguration + ) + :<|> Named + "get-calls-config-v2" + ( Summary + "Retrieve all TURN server addresses and credentials. \ + \Clients are expected to do a DNS lookup to resolve \ + \the IP addresses of the given hostnames " + :> ZUser + :> ZConn + :> "calls" + :> "config" + :> "v2" + :> QueryParam' '[Optional, Strict, Description "Limit resulting list. Allowed values [1..10]"] "limit" (Range 1 10 Int) + :> Get '[JSON] RTCConfiguration + ) diff --git a/libs/wire-api/src/Wire/API/Swagger.hs b/libs/wire-api/src/Wire/API/Swagger.hs index 9a133e98ead..575ded7007e 100644 --- a/libs/wire-api/src/Wire/API/Swagger.hs +++ b/libs/wire-api/src/Wire/API/Swagger.hs @@ -18,7 +18,6 @@ module Wire.API.Swagger where import Data.Swagger.Build.Api (Model) -import qualified Wire.API.Call.Config as Call.Config import qualified Wire.API.Connection as Connection import qualified Wire.API.Conversation as Conversation import qualified Wire.API.Conversation.Code as Conversation.Code @@ -44,9 +43,7 @@ import qualified Wire.API.User.Search as User.Search models :: [Model] models = - [ Call.Config.modelRtcConfiguration, - Call.Config.modelRtcIceServer, - Connection.modelConnectionList, + [ Connection.modelConnectionList, Connection.modelConnection, Connection.modelConnectionUpdate, Conversation.modelConversation, diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 09c233e98ad..d9cd8b71d81 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -113,7 +113,7 @@ import Wire.API.Error import qualified Wire.API.Error.Brig as E import qualified Wire.API.Properties as Public import qualified Wire.API.Routes.MultiTablePaging as Public -import Wire.API.Routes.Named +import Wire.API.Routes.Named (Named (Named)) import Wire.API.Routes.Public.Brig import qualified Wire.API.Routes.Public.Cannon as CannonAPI import qualified Wire.API.Routes.Public.Cargohold as CargoholdAPI @@ -195,6 +195,7 @@ servantSitemap = :<|> userHandleAPI :<|> searchAPI :<|> authAPI + :<|> callingAPI where userAPI :: ServerT UserAPI (Handler r) userAPI = @@ -312,6 +313,11 @@ servantSitemap = :<|> Named @"list-cookies" listCookies :<|> Named @"remove-cookies" removeCookies + callingAPI :: ServerT CallingAPI (Handler r) + callingAPI = + Named @"get-calls-config" Calling.getCallsConfig + :<|> Named @"get-calls-config-v2" Calling.getCallsConfigV2 + -- Note [ephemeral user sideeffect] -- If the user is ephemeral and expired, it will be removed upon calling -- CheckUserExists[Un]Qualified, see 'Brig.API.User.userGC'. @@ -333,7 +339,6 @@ sitemap :: sitemap = do Provider.routesPublic Team.routesPublic - Calling.routesPublic apiDocs :: forall r. diff --git a/services/brig/src/Brig/Calling/API.hs b/services/brig/src/Brig/Calling/API.hs index c6e48162fbc..41dcb19298f 100644 --- a/services/brig/src/Brig/Calling/API.hs +++ b/services/brig/src/Brig/Calling/API.hs @@ -18,7 +18,8 @@ -- with this program. If not, see . module Brig.Calling.API - ( routesPublic, + ( getCallsConfig, + getCallsConfigV2, -- * Exposed for testing purposes newConfig, @@ -45,16 +46,10 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty import Data.Misc (HttpsUrl) import Data.Range -import qualified Data.Swagger.Build.Api as Doc import Data.Text.Ascii (AsciiBase64, encodeBase64) import Data.Text.Strict.Lens import Data.Time.Clock.POSIX (getPOSIXTime) import Imports hiding (head) -import Network.Wai (Response) -import Network.Wai.Predicate hiding (and, result, setStatus, (#)) -import Network.Wai.Routing hiding (toList) -import Network.Wai.Utilities hiding (code, message) -import Network.Wai.Utilities.Swagger (document) import OpenSSL.EVP.Digest (Digest, hmacBS) import Polysemy import qualified Polysemy.Error as Polysemy @@ -65,42 +60,6 @@ import qualified Wire.API.Call.Config as Public import Wire.Network.DNS.SRV (srvTarget) import Wire.Sem.Logger.TinyLog (loggerToTinyLog) -routesPublic :: Routes Doc.ApiBuilder (Handler r) () -routesPublic = do - -- Deprecated endpoint, but still used by old clients. - -- See https://github.com/zinfra/backend-issues/issues/1616 for context - get "/calls/config" (continue getCallsConfigH) $ - accept "application" "json" - .&. header "Z-User" - .&. header "Z-Connection" - document "GET" "getCallsConfig" $ do - Doc.deprecated - Doc.summary - "Retrieve TURN server addresses and credentials for \ - \ IP addresses, scheme `turn` and transport `udp` only " - Doc.returns (Doc.ref Public.modelRtcConfiguration) - Doc.response 200 "RTCConfiguration" Doc.end - - get "/calls/config/v2" (continue getCallsConfigV2H) $ - accept "application" "json" - .&. header "Z-User" - .&. header "Z-Connection" - .&. opt (query "limit") - document "GET" "getCallsConfigV2" $ do - Doc.summary - "Retrieve all TURN server addresses and credentials. \ - \Clients are expected to do a DNS lookup to resolve \ - \the IP addresses of the given hostnames " - Doc.parameter Doc.Query "limit" Doc.int32' $ do - Doc.description "Limit resulting list. Allowes values [1..10]" - Doc.optional - Doc.returns (Doc.ref Public.modelRtcConfiguration) - Doc.response 200 "RTCConfiguration" Doc.end - -getCallsConfigV2H :: JSON ::: UserId ::: ConnId ::: Maybe (Range 1 10 Int) -> (Handler r) Response -getCallsConfigV2H (_ ::: uid ::: connid ::: limit) = - json <$> getCallsConfigV2 uid connid limit - -- | ('UserId', 'ConnId' are required as args here to make sure this is an authenticated end-point.) getCallsConfigV2 :: UserId -> ConnId -> Maybe (Range 1 10 Int) -> (Handler r) Public.RTCConfiguration getCallsConfigV2 _ _ limit = do @@ -121,7 +80,7 @@ getCallsConfigV2 _ _ limit = do handleNoTurnServers eitherConfig -- | Throws '500 Internal Server Error' when no turn servers are found. This is --- done to keep backwards compatiblity, the previous code initialized an 'IORef' +-- done to keep backwards compatibility, the previous code initialized an 'IORef' -- with an 'error' so reading the 'IORef' threw a 500. -- -- FUTUREWORK: Making this a '404 Not Found' would be more idiomatic, but this @@ -132,10 +91,6 @@ handleNoTurnServers (Left NoTurnServers) = do Log.err $ Log.msg (Log.val "Call config requested before TURN URIs could be discovered.") throwE $ StdError internalServerError -getCallsConfigH :: JSON ::: UserId ::: ConnId -> (Handler r) Response -getCallsConfigH (_ ::: uid ::: connid) = - json <$> getCallsConfig uid connid - getCallsConfig :: UserId -> ConnId -> (Handler r) Public.RTCConfiguration getCallsConfig _ _ = do env <- view turnEnv