From 6b3433e321b6a641e04a88f18536acad0f47e746 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Fri, 6 Oct 2023 11:26:49 +0200 Subject: [PATCH 1/6] [feat] improve type safety for Named, servantify brig internal route - improve type safety of Named by making it possible to rule out weakly typed arguments to the type (e.g. Type) - servantify the internal route for querying the teams API for servant --- .../src/Wire/API/Federation/API.hs | 2 +- libs/wire-api/src/Wire/API/Error.hs | 4 +- .../src/Wire/API/Routes/Internal/Brig.hs | 84 +++++++++++++++- .../Wire/API/Routes/Internal/Brig/OAuth.hs | 2 +- .../API/Routes/Internal/Brig/SearchIndex.hs | 2 +- libs/wire-api/src/Wire/API/Routes/Named.hs | 31 +++--- .../src/Wire/API/Routes/Public/Brig/Bot.hs | 2 +- .../src/Wire/API/Routes/Public/Brig/OAuth.hs | 2 +- .../Wire/API/Routes/Public/Brig/Provider.hs | 2 +- libs/wire-api/src/Wire/API/Routes/Version.hs | 2 +- libs/wire-api/src/Wire/API/User.hs | 1 + services/brig/src/Brig/API.hs | 10 +- services/brig/src/Brig/API/Internal.hs | 21 ++-- services/brig/src/Brig/API/OAuth.hs | 2 +- services/brig/src/Brig/API/Public.hs | 2 +- services/brig/src/Brig/Provider/API.hs | 2 +- services/brig/src/Brig/Team/API.hs | 95 +++---------------- services/brig/test/integration/Main.hs | 3 +- .../test/integration/API/Federation/Util.hs | 14 +-- services/gundeck/src/Gundeck/API/Public.hs | 2 +- tools/stern/src/Stern/API.hs | 2 +- 21 files changed, 153 insertions(+), 134 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API.hs b/libs/wire-api-federation/src/Wire/API/Federation/API.hs index 476df18303..5e6b294e12 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API.hs @@ -78,7 +78,7 @@ instance HasEmptyResponse (Post '[JSON] EmptyResponse) instance HasEmptyResponse api => HasEmptyResponse (x :> api) -instance HasEmptyResponse api => HasEmptyResponse (Named name api) +instance HasEmptyResponse api => HasEmptyResponse (UntypedNamed name api) -- | Return a client for a named endpoint. -- diff --git a/libs/wire-api/src/Wire/API/Error.hs b/libs/wire-api/src/Wire/API/Error.hs index 8946a78572..fbc743cfe6 100644 --- a/libs/wire-api/src/Wire/API/Error.hs +++ b/libs/wire-api/src/Wire/API/Error.hs @@ -68,7 +68,7 @@ import Polysemy.Error import Servant import Servant.OpenApi import Wire.API.Routes.MultiVerb -import Wire.API.Routes.Named (Named) +import Wire.API.Routes.Named (UntypedNamed) import Wire.API.Routes.Version -- | Runtime representation of a statically-known error. @@ -209,7 +209,7 @@ type family DeclaredErrorEffects api :: EffectRow where DeclaredErrorEffects (CanThrowMany '(e, es) :> api) = DeclaredErrorEffects (CanThrow e :> CanThrowMany es :> api) DeclaredErrorEffects (x :> api) = DeclaredErrorEffects api - DeclaredErrorEffects (Named n api) = DeclaredErrorEffects api + DeclaredErrorEffects (UntypedNamed n api) = DeclaredErrorEffects api DeclaredErrorEffects api = '[] errorResponseSwagger :: forall e. (Typeable e, KnownError e) => S.Response diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index acf06f3b8a..d1a67a3de2 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -36,11 +36,15 @@ module Wire.API.Routes.Internal.Brig NewKeyPackageRef (..), NewKeyPackage (..), NewKeyPackageResult (..), + FoundInvitationCode (..), ) where import Control.Lens ((.~)) -import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson (FromJSON, ToJSON (toJSON)) +{- yes, this is a bit weird -} + +import Data.Aeson qualified as Aeson import Data.Code qualified as Code import Data.CommaSeparatedList import Data.Domain (Domain) @@ -68,10 +72,13 @@ import Wire.API.Routes.Internal.Brig.SearchIndex (ISearchIndexAPI) import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Multi import Wire.API.Routes.MultiVerb import Wire.API.Routes.Named -import Wire.API.Routes.Public (ZUser {- yes, this is a bit weird -}) +import Wire.API.Routes.Public (ZUser) import Wire.API.Team.Feature +import Wire.API.Team.Invitation (Invitation) import Wire.API.Team.LegalHold.Internal -import Wire.API.User +import Wire.API.Team.Size qualified as Teamsize +import Wire.API.User hiding (InvitationCode) +import Wire.API.User qualified as User import Wire.API.User.Auth import Wire.API.User.Auth.LegalHold import Wire.API.User.Auth.ReAuth @@ -664,6 +671,77 @@ type TeamsAPI = :> ReqBody '[Servant.JSON] (Multi.TeamStatus SearchVisibilityInboundConfig) :> Post '[Servant.JSON] () ) + :<|> InvitationByEmail + :<|> InvitationCode + :<|> SuspendTeam + :<|> UnSuspendTeam + :<|> TeamSize + :<|> TeamInvitations + +type InvitationByEmail = + Named + "get-invitation-by-email" + ( "teams" + :> "invitations" + :> "by-email" + :> QueryParam' [Required, Strict] "email" Email + :> Get '[Servant.JSON] Invitation + ) + +type InvitationCode = + Named + "get-invitation-code" + ( "teams" + :> "invitation-code" + :> QueryParam' [Required, Strict] "team" TeamId + :> QueryParam' [Required, Strict] "invitation_id" InvitationId + :> Get '[Servant.JSON] FoundInvitationCode + ) + +newtype FoundInvitationCode = FoundInvitationCode User.InvitationCode + deriving stock (Eq, Show, Generic) + -- TODO: is this correct? + deriving newtype (S.ToSchema) + +instance ToJSON FoundInvitationCode where + toJSON (FoundInvitationCode c) = Aeson.object ["code" Aeson..= c] + +type SuspendTeam = + Named + "suspend-team" + ( "teams" + :> Capture "tid" TeamId + :> "suspend" + :> PostNoContent + ) + +type UnSuspendTeam = + Named + "unsuspend-team" + ( "teams" + :> Capture "tid" TeamId + :> "unsuspend" + :> PostNoContent + ) + +type TeamSize = + Named + "team-size" + ( "teams" + :> Capture "tid" TeamId + :> "size" + :> Get '[JSON] Teamsize.TeamSize + ) + +type TeamInvitations = + Named + "create-invitations-via-scim" + ( "teams" + :> Capture "tid" TeamId + :> "invitations" + :> Servant.ReqBody '[JSON] NewUserScimInvitation + :> Post '[JSON] UserAccount + ) type UserAPI = UpdateUserLocale diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/OAuth.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/OAuth.hs index 8974da4c27..70d478643a 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/OAuth.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/OAuth.hs @@ -23,7 +23,7 @@ import Servant hiding (Handler, JSON, Tagged, addHeader, respond) import Servant.OpenApi.Internal.Orphans () import Wire.API.Error import Wire.API.OAuth -import Wire.API.Routes.Named (Named (..)) +import Wire.API.Routes.Named (Named) -------------------------------------------------------------------------------- -- API Internal diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/SearchIndex.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/SearchIndex.hs index 0cca494890..0b90fd4352 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/SearchIndex.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/SearchIndex.hs @@ -20,7 +20,7 @@ module Wire.API.Routes.Internal.Brig.SearchIndex where import Servant (JSON) import Servant hiding (Handler, JSON, Tagged, addHeader, respond) import Servant.OpenApi.Internal.Orphans () -import Wire.API.Routes.Named (Named (..)) +import Wire.API.Routes.Named (Named) type ISearchIndexAPI = Named diff --git a/libs/wire-api/src/Wire/API/Routes/Named.hs b/libs/wire-api/src/Wire/API/Routes/Named.hs index f76ada1966..05807d2c8a 100644 --- a/libs/wire-api/src/Wire/API/Routes/Named.hs +++ b/libs/wire-api/src/Wire/API/Routes/Named.hs @@ -33,7 +33,9 @@ import Servant.Client.Core (clientIn) import Servant.OpenApi -- | See http://docs.wire.com/developer/developer/servant.html#named-and-internal-route-ids-in-swagger -newtype Named name x = Named {unnamed :: x} +type Named name = UntypedNamed (IsStronglyTyped name) + +newtype UntypedNamed name x = Named {unnamed :: x} deriving (Functor) -- | For 'HasSwagger' instance of 'Named'. 'KnownSymbol' isn't enough because we're using @@ -47,7 +49,12 @@ instance {-# OVERLAPPABLE #-} KnownSymbol a => RenderableSymbol a where instance {-# OVERLAPPING #-} (RenderableSymbol a, RenderableSymbol b) => RenderableSymbol '(a, b) where renderSymbol = "(" <> (renderSymbol @a) <> ", " <> (renderSymbol @b) <> ")" -instance (HasOpenApi api, RenderableSymbol name) => HasOpenApi (Named name api) where +type IsStronglyTyped :: forall k. k -> k +type family IsStronglyTyped typ where + IsStronglyTyped (typ :: Type) = TypeError ('Text "Please don't use \"Type\" as Type as first parameter to Named") + IsStronglyTyped typ = typ + +instance (HasOpenApi api, RenderableSymbol name) => HasOpenApi (UntypedNamed name api) where toOpenApi _ = toOpenApi (Proxy @api) & allOperations . description %~ (Just (dscr <> "\n\n") <>) @@ -58,27 +65,27 @@ instance (HasOpenApi api, RenderableSymbol name) => HasOpenApi (Named name api) <> cs (renderSymbol @name) <> "]" -instance HasServer api ctx => HasServer (Named name api) ctx where - type ServerT (Named name api) m = Named name (ServerT api m) +instance HasServer api ctx => HasServer (UntypedNamed name api) ctx where + type ServerT (UntypedNamed name api) m = UntypedNamed name (ServerT api m) route _ ctx action = route (Proxy @api) ctx (fmap unnamed action) hoistServerWithContext _ ctx f = fmap (hoistServerWithContext (Proxy @api) ctx f) -instance HasLink endpoint => HasLink (Named name endpoint) where - type MkLink (Named name endpoint) a = MkLink endpoint a +instance HasLink endpoint => HasLink (UntypedNamed name endpoint) where + type MkLink (UntypedNamed name endpoint) a = MkLink endpoint a toLink toA _ = toLink toA (Proxy @endpoint) -instance RoutesToPaths api => RoutesToPaths (Named name api) where +instance RoutesToPaths api => RoutesToPaths (UntypedNamed name api) where getRoutes = getRoutes @api -instance HasClient m api => HasClient m (Named n api) where - type Client m (Named n api) = Client m api +instance HasClient m api => HasClient m (UntypedNamed n api) where + type Client m (UntypedNamed n api) = Client m api clientWithRoute pm _ req = clientWithRoute pm (Proxy @api) req hoistClientMonad pm _ f = hoistClientMonad pm (Proxy @api) f type family FindName n (api :: Type) :: (n, Type) where - FindName n (Named name api) = '(name, api) + FindName n (UntypedNamed name api) = '(name, api) FindName n (x :> api) = AddPrefix x (FindName n api) FindName n api = '(TypeError ('Text "Named combinator not found"), api) @@ -116,7 +123,7 @@ type family FMap (f :: a -> b) (m :: Maybe a) :: Maybe b where FMap f ('Just a) = 'Just (f a) type family LookupEndpoint api name :: Maybe Type where - LookupEndpoint (Named name endpoint) name = 'Just endpoint + LookupEndpoint (UntypedNamed name endpoint) name = 'Just endpoint LookupEndpoint (api1 :<|> api2) name = MappendMaybe (LookupEndpoint api1 name) @@ -142,5 +149,5 @@ namedClient = clientIn (Proxy @endpoint) (Proxy @m) type family x ::> api type instance - x ::> (Named name api) = + x ::> (UntypedNamed name api) = Named name (x :> api) diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig/Bot.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig/Bot.hs index b7eba29b03..70b75bf40d 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig/Bot.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig/Bot.hs @@ -28,7 +28,7 @@ import Wire.API.Error (CanThrow, ErrorResponse) import Wire.API.Error.Brig (BrigError (..)) import Wire.API.Provider.Bot (BotUserView) import Wire.API.Routes.MultiVerb -import Wire.API.Routes.Named (Named (..)) +import Wire.API.Routes.Named (Named) import Wire.API.Routes.Public import Wire.API.User import Wire.API.User.Client diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig/OAuth.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig/OAuth.hs index a096c78d97..a3173c0700 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig/OAuth.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig/OAuth.hs @@ -27,7 +27,7 @@ import Wire.API.Error import Wire.API.OAuth import Wire.API.Routes.API import Wire.API.Routes.MultiVerb -import Wire.API.Routes.Named (Named (..)) +import Wire.API.Routes.Named (Named) import Wire.API.Routes.Public type OAuthAPI = diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig/Provider.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig/Provider.hs index b1b6310dfe..4145161611 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig/Provider.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig/Provider.hs @@ -27,7 +27,7 @@ import Wire.API.Error import Wire.API.Error.Brig import Wire.API.Provider import Wire.API.Routes.MultiVerb -import Wire.API.Routes.Named (Named (..)) +import Wire.API.Routes.Named (Named) import Wire.API.Routes.Public import Wire.API.User.Auth diff --git a/libs/wire-api/src/Wire/API/Routes/Version.hs b/libs/wire-api/src/Wire/API/Routes/Version.hs index a2a337b61d..98a184592e 100644 --- a/libs/wire-api/src/Wire/API/Routes/Version.hs +++ b/libs/wire-api/src/Wire/API/Routes/Version.hs @@ -220,7 +220,7 @@ type instance s :> SpecialiseToVersion v api type instance - SpecialiseToVersion v (Named n api) = + SpecialiseToVersion v (UntypedNamed n api) = Named n (SpecialiseToVersion v api) type instance diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 16be799925..ada22cbd43 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -1896,6 +1896,7 @@ instance Schema.ToSchema UserAccount where -- NewUserScimInvitation data NewUserScimInvitation = NewUserScimInvitation + -- FIXME: the TID should be captured in the route as usual { newUserScimInvTeamId :: TeamId, newUserScimInvLocale :: Maybe Locale, newUserScimInvName :: Name, diff --git a/services/brig/src/Brig/API.hs b/services/brig/src/Brig/API.hs index 3580f88851..ba318c3f2b 100644 --- a/services/brig/src/Brig/API.hs +++ b/services/brig/src/Brig/API.hs @@ -22,18 +22,10 @@ where import Brig.API.Handler (Handler) import Brig.API.Internal qualified as Internal -import Brig.Effects.BlacklistStore (BlacklistStore) import Brig.Effects.GalleyProvider (GalleyProvider) -import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Network.Wai.Routing (Routes) import Polysemy -sitemap :: - forall r p. - ( Member BlacklistStore r, - Member GalleyProvider r, - Member (UserPendingActivationStore p) r - ) => - Routes () (Handler r) () +sitemap :: forall r. (Member GalleyProvider r) => Routes () (Handler r) () sitemap = do Internal.sitemap diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 75f90bd606..167ea19fc4 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -197,8 +197,20 @@ accountAPI = :<|> Named @"iLegalholdAddClient" legalHoldClientRequestedH :<|> Named @"iLegalholdDeleteClient" removeLegalHoldClientH -teamsAPI :: ServerT BrigIRoutes.TeamsAPI (Handler r) -teamsAPI = Named @"updateSearchVisibilityInbound" Index.updateSearchVisibilityInbound +teamsAPI :: + ( Member GalleyProvider r, + Member (UserPendingActivationStore p) r, + Member BlacklistStore r + ) => + ServerT BrigIRoutes.TeamsAPI (Handler r) +teamsAPI = + Named @"updateSearchVisibilityInbound" Index.updateSearchVisibilityInbound + :<|> Named @"get-invitation-by-email" Team.getInvitationByEmail + :<|> Named @"get-invitation-code" Team.getInvitationCode + :<|> Named @"suspend-team" Team.suspendTeam + :<|> Named @"unsuspend-team" Team.unsuspendTeam + :<|> Named @"team-size" Team.teamSize + :<|> Named @"create-invitations-via-scim" Team.createInvitationViaScim userAPI :: ServerT BrigIRoutes.UserAPI (Handler r) userAPI = @@ -436,14 +448,11 @@ internalSearchIndexAPI = -- Sitemap (wai-route) sitemap :: - ( Member BlacklistStore r, - Member GalleyProvider r, - Member (UserPendingActivationStore p) r + ( Member GalleyProvider r ) => Routes a (Handler r) () sitemap = unsafeCallsFed @'Brig @"on-user-deleted-connections" $ do Provider.routesInternal - Team.routesInternal --------------------------------------------------------------------------- -- Handlers diff --git a/services/brig/src/Brig/API/OAuth.hs b/services/brig/src/Brig/API/OAuth.hs index b2196be7be..b204fadd06 100644 --- a/services/brig/src/Brig/API/OAuth.hs +++ b/services/brig/src/Brig/API/OAuth.hs @@ -48,7 +48,7 @@ import Wire.API.Error import Wire.API.OAuth as OAuth import Wire.API.Password (Password, mkSafePassword) import Wire.API.Routes.Internal.Brig.OAuth qualified as I -import Wire.API.Routes.Named (Named (..)) +import Wire.API.Routes.Named (UntypedNamed (Named)) import Wire.API.Routes.Public.Brig.OAuth import Wire.Sem.Jwk import Wire.Sem.Jwk qualified as Jwk diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 5e22dfcb50..ae77817ef6 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -118,7 +118,7 @@ import Wire.API.Routes.Internal.Cargohold qualified as CargoholdInternalAPI import Wire.API.Routes.Internal.Galley qualified as GalleyInternalAPI import Wire.API.Routes.Internal.Spar qualified as SparInternalAPI import Wire.API.Routes.MultiTablePaging qualified as Public -import Wire.API.Routes.Named (Named (Named)) +import Wire.API.Routes.Named (UntypedNamed (Named)) import Wire.API.Routes.Public.Brig import Wire.API.Routes.Public.Brig.OAuth import Wire.API.Routes.Public.Cannon diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 8c4af7f34f..6291aa84f6 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -113,7 +113,7 @@ import Wire.API.Provider.External qualified as Ext import Wire.API.Provider.Service import Wire.API.Provider.Service qualified as Public import Wire.API.Provider.Service.Tag qualified as Public -import Wire.API.Routes.Named (Named (Named)) +import Wire.API.Routes.Named (UntypedNamed (Named)) import Wire.API.Routes.Public.Brig.Bot (BotAPI) import Wire.API.Routes.Public.Brig.Provider (ProviderAPI) import Wire.API.Routes.Public.Brig.Services (ServicesAPI) diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 18a60a9e79..14987469ff 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -17,7 +17,12 @@ module Brig.Team.API ( servantAPI, - routesInternal, + getInvitationByEmail, + getInvitationCode, + suspendTeam, + unsuspendTeam, + teamSize, + createInvitationViaScim, ) where @@ -45,17 +50,12 @@ import Brig.Types.Team (TeamSize) import Brig.User.Search.TeamSize qualified as TeamSize import Control.Lens (view, (^.)) import Control.Monad.Trans.Except (mapExceptT) -import Data.Aeson hiding (json) import Data.ByteString.Conversion (toByteString') import Data.Id import Data.List1 qualified as List1 import Data.Range import Galley.Types.Teams qualified as Team import Imports hiding (head) -import Network.HTTP.Types.Status -import Network.Wai (Response) -import Network.Wai.Predicate hiding (and, result, setStatus) -import Network.Wai.Routing import Network.Wai.Utilities hiding (code, message) import Polysemy (Member) import Servant hiding (Handler, JSON, addHeader) @@ -64,9 +64,10 @@ import System.Logger.Class qualified as Log import Util.Logging (logFunction, logTeam) import Wire.API.Error import Wire.API.Error.Brig qualified as E +import Wire.API.Routes.Internal.Brig (FoundInvitationCode (FoundInvitationCode)) import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team import Wire.API.Routes.Named -import Wire.API.Routes.Public.Brig +import Wire.API.Routes.Public.Brig (TeamsAPI) import Wire.API.Team import Wire.API.Team.Invitation import Wire.API.Team.Invitation qualified as Public @@ -92,64 +93,19 @@ servantAPI = :<|> Named @"head-team-invitations" headInvitationByEmail :<|> Named @"get-team-size" teamSizePublic -routesInternal :: - ( Member BlacklistStore r, - Member GalleyProvider r, - Member (UserPendingActivationStore p) r - ) => - Routes a (Handler r) () -routesInternal = do - get "/i/teams/invitations/by-email" (continue getInvitationByEmailH) $ - accept "application" "json" - .&. query "email" - - get "/i/teams/invitation-code" (continue getInvitationCodeH) $ - accept "application" "json" - .&. param "team" - .&. param "invitation_id" - - post "/i/teams/:tid/suspend" (continue suspendTeamH) $ - accept "application" "json" - .&. capture "tid" - - post "/i/teams/:tid/unsuspend" (continue unsuspendTeamH) $ - accept "application" "json" - .&. capture "tid" - - get "/i/teams/:tid/size" (continue teamSizeH) $ - accept "application" "json" - .&. capture "tid" - - post "/i/teams/:tid/invitations" (continue createInvitationViaScimH) $ - accept "application" "json" - .&. jsonRequest @NewUserScimInvitation - teamSizePublic :: Member GalleyProvider r => UserId -> TeamId -> (Handler r) TeamSize teamSizePublic uid tid = do ensurePermissions uid tid [AddTeamMember] -- limit this to team admins to reduce risk of involuntary DOS attacks teamSize tid -teamSizeH :: JSON ::: TeamId -> (Handler r) Response -teamSizeH (_ ::: t) = json <$> teamSize t - teamSize :: TeamId -> (Handler r) TeamSize teamSize t = lift $ TeamSize.teamSize t -getInvitationCodeH :: JSON ::: TeamId ::: InvitationId -> (Handler r) Response -getInvitationCodeH (_ ::: t ::: r) = do - json <$> getInvitationCode t r - getInvitationCode :: TeamId -> InvitationId -> (Handler r) FoundInvitationCode getInvitationCode t r = do code <- lift . wrapClient $ DB.lookupInvitationCode t r maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) (pure . FoundInvitationCode) code -newtype FoundInvitationCode = FoundInvitationCode InvitationCode - deriving (Eq, Show, Generic) - -instance ToJSON FoundInvitationCode where - toJSON (FoundInvitationCode c) = object ["code" .= c] - createInvitationPublicH :: ( Member BlacklistStore r, Member GalleyProvider r @@ -199,25 +155,15 @@ createInvitationPublic uid tid body = do context (createInvitation' tid inviteeRole (Just (inviterUid inviter)) (inviterEmail inviter) body) -createInvitationViaScimH :: - ( Member BlacklistStore r, - Member GalleyProvider r, - Member (UserPendingActivationStore p) r - ) => - JSON ::: JsonRequest NewUserScimInvitation -> - (Handler r) Response -createInvitationViaScimH (_ ::: req) = do - body <- parseJsonBody req - setStatus status201 . json <$> createInvitationViaScim body - createInvitationViaScim :: ( Member BlacklistStore r, Member GalleyProvider r, Member (UserPendingActivationStore p) r ) => + TeamId -> NewUserScimInvitation -> (Handler r) UserAccount -createInvitationViaScim newUser@(NewUserScimInvitation tid loc name email role) = do +createInvitationViaScim tid newUser@(NewUserScimInvitation _tid loc name email role) = do env <- ask let inviteeRole = role fromEmail = env ^. emailSender @@ -352,39 +298,26 @@ headInvitationByEmail e = do -- | FUTUREWORK: This should also respond with status 409 in case of -- @DB.InvitationByEmailMoreThanOne@. Refactor so that 'headInvitationByEmailH' and -- 'getInvitationByEmailH' are almost the same thing. -getInvitationByEmailH :: JSON ::: Email -> (Handler r) Response -getInvitationByEmailH (_ ::: email) = - json <$> getInvitationByEmail email - getInvitationByEmail :: Email -> (Handler r) Public.Invitation getInvitationByEmail email = do inv <- lift $ wrapClient $ DB.lookupInvitationByEmail HideInvitationUrl email maybe (throwStd (notFound "Invitation not found")) pure inv -suspendTeamH :: (Member GalleyProvider r) => JSON ::: TeamId -> (Handler r) Response -suspendTeamH (_ ::: tid) = do - empty <$ suspendTeam tid - -suspendTeam :: (Member GalleyProvider r) => TeamId -> (Handler r) () +suspendTeam :: (Member GalleyProvider r) => TeamId -> (Handler r) NoContent suspendTeam tid = do changeTeamAccountStatuses tid Suspended lift $ wrapClient $ DB.deleteInvitations tid lift $ liftSem $ GalleyProvider.changeTeamStatus tid Team.Suspended Nothing - -unsuspendTeamH :: - (Member GalleyProvider r) => - JSON ::: TeamId -> - (Handler r) Response -unsuspendTeamH (_ ::: tid) = do - empty <$ unsuspendTeam tid + pure NoContent unsuspendTeam :: (Member GalleyProvider r) => TeamId -> - (Handler r) () + (Handler r) NoContent unsuspendTeam tid = do changeTeamAccountStatuses tid Active lift $ liftSem $ GalleyProvider.changeTeamStatus tid Team.Active Nothing + pure NoContent ------------------------------------------------------------------------------- -- Internal diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index 8a3a0d5b9c..8b8970faf5 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -74,7 +74,6 @@ import Util.Test.SQS qualified as SQS import Web.HttpApiData import Wire.API.Federation.API import Wire.API.Routes.Version -import Wire.Sem.Paging.Cassandra (InternalPaging) data BackendConf = BackendConf { remoteBrig :: Endpoint, @@ -175,7 +174,7 @@ runTests iConf brigOpts otherArgs = do assertEqual "inconcistent sitemap" mempty - (pathsConsistencyCheck . treeToPaths . compile $ Brig.API.sitemap @BrigCanonicalEffects @InternalPaging), + (pathsConsistencyCheck . treeToPaths . compile $ Brig.API.sitemap @BrigCanonicalEffects), userApi, providerApi, searchApis, diff --git a/services/galley/test/integration/API/Federation/Util.hs b/services/galley/test/integration/API/Federation/Util.hs index 9d15edc5ee..bb12cebb6b 100644 --- a/services/galley/test/integration/API/Federation/Util.hs +++ b/services/galley/test/integration/API/Federation/Util.hs @@ -64,7 +64,7 @@ instance HasTrivialHandler api => HasTrivialHandler (From v :> api) where trivialNamedHandler :: forall (name :: Symbol) api. (KnownSymbol name, HasTrivialHandler api) => - Server (Named name api) + Server (UntypedNamed name api) trivialNamedHandler = Named (trivialHandler @api (symbolVal (Proxy @name))) -- | Generate a servant handler from an incomplete list of handlers of named @@ -74,40 +74,40 @@ class PartialAPI (api :: Type) (hs :: Type) where instance (KnownSymbol name, HasTrivialHandler endpoint) => - PartialAPI (Named (name :: Symbol) endpoint) EmptyAPI + PartialAPI (UntypedNamed (name :: Symbol) endpoint) EmptyAPI where mkHandler _ = trivialNamedHandler @name @endpoint instance {-# OVERLAPPING #-} (KnownSymbol name, HasTrivialHandler endpoint, PartialAPI api EmptyAPI) => - PartialAPI (Named (name :: Symbol) endpoint :<|> api) EmptyAPI + PartialAPI (UntypedNamed (name :: Symbol) endpoint :<|> api) EmptyAPI where mkHandler h = trivialNamedHandler @name @endpoint :<|> mkHandler @api h instance {-# OVERLAPPING #-} (h ~ Server endpoint, PartialAPI api hs) => - PartialAPI (Named (name :: Symbol) endpoint :<|> api) (Named name h :<|> hs) + PartialAPI (UntypedNamed (name :: Symbol) endpoint :<|> api) (UntypedNamed name h :<|> hs) where mkHandler (h :<|> hs) = h :<|> mkHandler @api hs instance (KnownSymbol name, HasTrivialHandler endpoint, PartialAPI api hs) => - PartialAPI (Named (name :: Symbol) endpoint :<|> api) hs + PartialAPI (UntypedNamed (name :: Symbol) endpoint :<|> api) hs where mkHandler hs = trivialNamedHandler @name @endpoint :<|> mkHandler @api hs instance (h ~ Server endpoint) => - PartialAPI (Named (name :: Symbol) endpoint) (Named name h) + PartialAPI (UntypedNamed (name :: Symbol) endpoint) (UntypedNamed name h) where mkHandler = id instance {-# OVERLAPPING #-} (h ~ Server endpoint, PartialAPI api EmptyAPI) => - PartialAPI (Named (name :: Symbol) endpoint :<|> api) (Named name h) + PartialAPI (UntypedNamed (name :: Symbol) endpoint :<|> api) (UntypedNamed name h) where mkHandler h = h :<|> mkHandler @api EmptyAPI diff --git a/services/gundeck/src/Gundeck/API/Public.hs b/services/gundeck/src/Gundeck/API/Public.hs index e2034b3d62..b74b8e00f4 100644 --- a/services/gundeck/src/Gundeck/API/Public.hs +++ b/services/gundeck/src/Gundeck/API/Public.hs @@ -31,7 +31,7 @@ import Gundeck.Push qualified as Push import Imports import Servant (HasServer (..), (:<|>) (..)) import Wire.API.Notification qualified as Public -import Wire.API.Routes.Named (Named (Named)) +import Wire.API.Routes.Named (UntypedNamed (Named)) import Wire.API.Routes.Public.Gundeck ------------------------------------------------------------------------------- diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index c559d0e6f2..03832056ac 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -63,7 +63,7 @@ import Wire.API.Internal.Notification (QueuedNotification) import Wire.API.Routes.Internal.Brig.Connection (ConnectionStatus) import Wire.API.Routes.Internal.Brig.EJPD qualified as EJPD import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team -import Wire.API.Routes.Named (Named (Named)) +import Wire.API.Routes.Named (UntypedNamed (Named)) import Wire.API.Team.Feature hiding (setStatus) import Wire.API.Team.SearchVisibility import Wire.API.User From eadd2ebdee5d863b694776c43485314874b8973f Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Sat, 7 Oct 2023 13:03:29 +0200 Subject: [PATCH 2/6] [fix] change status code of servantified route from 204 to 200 where needed --- .../src/Wire/API/Routes/Internal/Brig.hs | 29 +++++++++++++------ libs/wire-api/src/Wire/API/Routes/Named.hs | 2 +- 2 files changed, 21 insertions(+), 10 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index d1a67a3de2..403edd5e6a 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -500,9 +500,12 @@ instance ToSchema NewKeyPackageRef where schema = object "NewKeyPackageRef" $ NewKeyPackageRef - <$> nkprUserId .= field "user_id" schema - <*> nkprClientId .= field "client_id" schema - <*> nkprConversation .= field "conversation" schema + <$> nkprUserId + .= field "user_id" schema + <*> nkprClientId + .= field "client_id" schema + <*> nkprConversation + .= field "conversation" schema data NewKeyPackage = NewKeyPackage { nkpConversation :: Qualified ConvId, @@ -515,8 +518,10 @@ instance ToSchema NewKeyPackage where schema = object "NewKeyPackage" $ NewKeyPackage - <$> nkpConversation .= field "conversation" schema - <*> nkpKeyPackage .= field "key_package" schema + <$> nkpConversation + .= field "conversation" schema + <*> nkpKeyPackage + .= field "key_package" schema data NewKeyPackageResult = NewKeyPackageResult { nkpresClientIdentity :: ClientIdentity, @@ -529,8 +534,10 @@ instance ToSchema NewKeyPackageResult where schema = object "NewKeyPackageResult" $ NewKeyPackageResult - <$> nkpresClientIdentity .= field "client_identity" schema - <*> nkpresKeyPackageRef .= field "key_package_ref" schema + <$> nkpresClientIdentity + .= field "client_identity" schema + <*> nkpresKeyPackageRef + .= field "key_package_ref" schema type MLSAPI = "mls" @@ -712,7 +719,9 @@ type SuspendTeam = ( "teams" :> Capture "tid" TeamId :> "suspend" - :> PostNoContent + :> Post + '[Servant.JSON] + NoContent ) type UnSuspendTeam = @@ -721,7 +730,9 @@ type UnSuspendTeam = ( "teams" :> Capture "tid" TeamId :> "unsuspend" - :> PostNoContent + :> Post + '[Servant.JSON] + NoContent ) type TeamSize = diff --git a/libs/wire-api/src/Wire/API/Routes/Named.hs b/libs/wire-api/src/Wire/API/Routes/Named.hs index 05807d2c8a..3fd4512d70 100644 --- a/libs/wire-api/src/Wire/API/Routes/Named.hs +++ b/libs/wire-api/src/Wire/API/Routes/Named.hs @@ -51,7 +51,7 @@ instance {-# OVERLAPPING #-} (RenderableSymbol a, RenderableSymbol b) => Rendera type IsStronglyTyped :: forall k. k -> k type family IsStronglyTyped typ where - IsStronglyTyped (typ :: Type) = TypeError ('Text "Please don't use \"Type\" as Type as first parameter to Named") + IsStronglyTyped (typ :: Type) = TypeError ('Text "Please don't use \"Type\" as first parameter to \"Named\"") IsStronglyTyped typ = typ instance (HasOpenApi api, RenderableSymbol name) => HasOpenApi (UntypedNamed name api) where From 039ff0fcc8082a7c7490d2670ed5ca4e2df884c1 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Sat, 7 Oct 2023 13:22:12 +0200 Subject: [PATCH 3/6] [chore] add changelog.d entry --- changelog.d/5-internal/WBP-1224 | 1 + libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs | 4 +--- 2 files changed, 2 insertions(+), 3 deletions(-) create mode 100644 changelog.d/5-internal/WBP-1224 diff --git a/changelog.d/5-internal/WBP-1224 b/changelog.d/5-internal/WBP-1224 new file mode 100644 index 0000000000..12dd7e6cba --- /dev/null +++ b/changelog.d/5-internal/WBP-1224 @@ -0,0 +1 @@ +Servantify internal end-points: brig/teams diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index 403edd5e6a..a7a117dc61 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -41,9 +41,7 @@ module Wire.API.Routes.Internal.Brig where import Control.Lens ((.~)) -import Data.Aeson (FromJSON, ToJSON (toJSON)) -{- yes, this is a bit weird -} - +import Data.Aeson (FromJSON, ToJSON) import Data.Aeson qualified as Aeson import Data.Code qualified as Code import Data.CommaSeparatedList From a68e625b6b3f7b0a0062fb7c27f28b206f79bfba Mon Sep 17 00:00:00 2001 From: mangoiv Date: Sat, 7 Oct 2023 15:48:43 +0200 Subject: [PATCH 4/6] [fix] revert unwanted formatting changes --- .../src/Wire/API/Routes/Internal/Brig.hs | 21 +++++++------------ 1 file changed, 7 insertions(+), 14 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index a7a117dc61..1356782ad0 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -498,12 +498,9 @@ instance ToSchema NewKeyPackageRef where schema = object "NewKeyPackageRef" $ NewKeyPackageRef - <$> nkprUserId - .= field "user_id" schema - <*> nkprClientId - .= field "client_id" schema - <*> nkprConversation - .= field "conversation" schema + <$> nkprUserId .= field "user_id" schema + <*> nkprClientId .= field "client_id" schema + <*> nkprConversation .= field "conversation" schema data NewKeyPackage = NewKeyPackage { nkpConversation :: Qualified ConvId, @@ -516,10 +513,8 @@ instance ToSchema NewKeyPackage where schema = object "NewKeyPackage" $ NewKeyPackage - <$> nkpConversation - .= field "conversation" schema - <*> nkpKeyPackage - .= field "key_package" schema + <$> nkpConversation .= field "conversation" schema + <*> nkpKeyPackage .= field "key_package" schema data NewKeyPackageResult = NewKeyPackageResult { nkpresClientIdentity :: ClientIdentity, @@ -532,10 +527,8 @@ instance ToSchema NewKeyPackageResult where schema = object "NewKeyPackageResult" $ NewKeyPackageResult - <$> nkpresClientIdentity - .= field "client_identity" schema - <*> nkpresKeyPackageRef - .= field "key_package_ref" schema + <$> nkpresClientIdentity .= field "client_identity" schema + <*> nkpresKeyPackageRef .= field "key_package_ref" schema type MLSAPI = "mls" From c84b5e28e781e1eb4becd27dc2f3b43410606a77 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Mon, 9 Oct 2023 09:57:10 +0200 Subject: [PATCH 5/6] [fix] apply changes suggest by elland - add documentation of `Named` changes - s/UnSuspendTeam/UnsuspendTeam --- libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs | 4 ++-- libs/wire-api/src/Wire/API/Routes/Named.hs | 6 ++++++ 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index 1356782ad0..75a7a321f2 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -672,7 +672,7 @@ type TeamsAPI = :<|> InvitationByEmail :<|> InvitationCode :<|> SuspendTeam - :<|> UnSuspendTeam + :<|> UnsuspendTeam :<|> TeamSize :<|> TeamInvitations @@ -715,7 +715,7 @@ type SuspendTeam = NoContent ) -type UnSuspendTeam = +type UnsuspendTeam = Named "unsuspend-team" ( "teams" diff --git a/libs/wire-api/src/Wire/API/Routes/Named.hs b/libs/wire-api/src/Wire/API/Routes/Named.hs index 3fd4512d70..e7bf7224a7 100644 --- a/libs/wire-api/src/Wire/API/Routes/Named.hs +++ b/libs/wire-api/src/Wire/API/Routes/Named.hs @@ -33,6 +33,12 @@ import Servant.Client.Core (clientIn) import Servant.OpenApi -- | See http://docs.wire.com/developer/developer/servant.html#named-and-internal-route-ids-in-swagger +-- +-- as 'UntypedNamed' is of kind $k -> Type -> Type$, we can pass any +-- argument to it, however, most commonly we want to pass a 'Symbol' to +-- it. To avoid mistakes, we make it possible to rule out untyped arguments +-- like 'Type', this is done by the 'IsStronglyTyped' TyFam that will throw +-- a type error when passed a 'Type' type Named name = UntypedNamed (IsStronglyTyped name) newtype UntypedNamed name x = Named {unnamed :: x} From b9ced29e245cb1079b9b4ac42c6738d4f9ac6f5b Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Mon, 9 Oct 2023 13:18:45 +0200 Subject: [PATCH 6/6] [fix] fix the schema --- libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index 75a7a321f2..f6b97c0769 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -42,7 +42,6 @@ where import Control.Lens ((.~)) import Data.Aeson (FromJSON, ToJSON) -import Data.Aeson qualified as Aeson import Data.Code qualified as Code import Data.CommaSeparatedList import Data.Domain (Domain) @@ -696,13 +695,14 @@ type InvitationCode = :> Get '[Servant.JSON] FoundInvitationCode ) -newtype FoundInvitationCode = FoundInvitationCode User.InvitationCode +newtype FoundInvitationCode = FoundInvitationCode {getFoundInvitationCode :: User.InvitationCode} deriving stock (Eq, Show, Generic) - -- TODO: is this correct? - deriving newtype (S.ToSchema) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema FoundInvitationCode) -instance ToJSON FoundInvitationCode where - toJSON (FoundInvitationCode c) = Aeson.object ["code" Aeson..= c] +instance ToSchema FoundInvitationCode where + schema = + FoundInvitationCode + <$> getFoundInvitationCode .= object "FoundInvitationCode" (field "code" (schema @User.InvitationCode)) type SuspendTeam = Named