From 903b87e62032085848a13e1455771c6ddb7fcf74 Mon Sep 17 00:00:00 2001 From: Mango The Fourth <40720523+MangoIV@users.noreply.github.com> Date: Mon, 9 Oct 2023 18:32:44 +0200 Subject: [PATCH] [feat] improve type safety for Named, servantify brig internal route (#3634) * [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 --- changelog.d/5-internal/WBP-1224 | 1 + .../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 | 37 +++++--- .../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 +- 22 files changed, 161 insertions(+), 133 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 00000000000..12dd7e6cbab --- /dev/null +++ b/changelog.d/5-internal/WBP-1224 @@ -0,0 +1 @@ +Servantify internal end-points: brig/teams 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 476df183032..5e6b294e122 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 8946a785721..fbc743cfe65 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 acf06f3b8a6..f6b97c0769e 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -36,6 +36,7 @@ module Wire.API.Routes.Internal.Brig NewKeyPackageRef (..), NewKeyPackage (..), NewKeyPackageResult (..), + FoundInvitationCode (..), ) where @@ -68,10 +69,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 +668,82 @@ 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 {getFoundInvitationCode :: User.InvitationCode} + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema FoundInvitationCode) + +instance ToSchema FoundInvitationCode where + schema = + FoundInvitationCode + <$> getFoundInvitationCode .= object "FoundInvitationCode" (field "code" (schema @User.InvitationCode)) + +type SuspendTeam = + Named + "suspend-team" + ( "teams" + :> Capture "tid" TeamId + :> "suspend" + :> Post + '[Servant.JSON] + NoContent + ) + +type UnsuspendTeam = + Named + "unsuspend-team" + ( "teams" + :> Capture "tid" TeamId + :> "unsuspend" + :> Post + '[Servant.JSON] + NoContent + ) + +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 8974da4c27c..70d478643a0 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 0cca4948901..0b90fd43524 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 f76ada19664..e7bf7224a74 100644 --- a/libs/wire-api/src/Wire/API/Routes/Named.hs +++ b/libs/wire-api/src/Wire/API/Routes/Named.hs @@ -33,7 +33,15 @@ 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} +-- +-- 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} deriving (Functor) -- | For 'HasSwagger' instance of 'Named'. 'KnownSymbol' isn't enough because we're using @@ -47,7 +55,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 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 +71,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 +129,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 +155,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 b7eba29b037..70b75bf40dc 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 a096c78d975..a3173c0700b 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 b1b6310dfe4..4145161611c 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 a2a337b61df..98a184592ed 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 16be7999255..ada22cbd43c 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 3580f888511..ba318c3f2b5 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 75f90bd606c..167ea19fc44 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 b2196be7be7..b204fadd065 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 5e22dfcb500..ae77817ef62 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 8c4af7f34ff..6291aa84f61 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 18a60a9e797..14987469fff 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 8a3a0d5b9c0..8b8970faf55 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 9d15edc5ee9..bb12cebb6ba 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 e2034b3d62e..b74b8e00f44 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 c559d0e6f20..03832056ac0 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