Skip to content

Commit f7f71dc

Browse files
smattingsmatting
committed
wip
1 parent 331ea16 commit f7f71dc

File tree

6 files changed

+130
-20
lines changed

6 files changed

+130
-20
lines changed

‎libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs

Lines changed: 11 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -30,8 +30,8 @@ import Wire.API.Arbitrary (Arbitrary, GenericUniform (..))
3030
import Wire.API.Conversation
3131
import Wire.API.Conversation.Action
3232
import Wire.API.Conversation.Protocol
33-
import Wire.API.Conversation.Role (RoleName)
34-
import Wire.API.Error.Galley (GalleyError)
33+
import Wire.API.Conversation.Role (Action (ModifyConversationReceiptMode), RoleName)
34+
import Wire.API.Error.Galley
3535
import Wire.API.Federation.API.Common
3636
import Wire.API.Federation.Endpoint
3737
import Wire.API.Message
@@ -59,6 +59,15 @@ type GalleyApi =
5959
:<|> FedEndpoint "send-message" MessageSendRequest MessageSendResponse
6060
:<|> FedEndpoint "on-user-deleted-conversations" UserDeletedConversationsNotification EmptyResponse
6161
:<|> FedEndpoint "update-conversation" ConversationUpdateRequest ConversationUpdateResponse
62+
:<|> FedEndpointWithErrors
63+
"update-conversation-receipt-mode"
64+
'[ 'ActionDenied 'ModifyConversationReceiptMode,
65+
'ConvAccessDenied,
66+
'ConvNotFound,
67+
'InvalidOperation
68+
]
69+
ConversationUpdateRequest
70+
ConversationUpdateResponse
6271

6372
data GetConversationsRequest = GetConversationsRequest
6473
{ gcrUserId :: UserId,

‎libs/wire-api-federation/src/Wire/API/Federation/Endpoint.hs

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@
1818
module Wire.API.Federation.Endpoint where
1919

2020
import Servant.API
21+
import Wire.API.Error (CanThrowMany)
2122
import Wire.API.Federation.Domain
2223
import Wire.API.Routes.Named
2324

@@ -26,6 +27,11 @@ type FedEndpoint name input output =
2627
name
2728
(name :> OriginDomainHeader :> ReqBody '[JSON] input :> Post '[JSON] output)
2829

30+
type FedEndpointWithErrors name errors input output =
31+
Named
32+
name
33+
(name :> OriginDomainHeader :> CanThrowMany errors :> ReqBody '[JSON] input :> Post '[JSON] output)
34+
2935
type StreamingFedEndpoint name input output =
3036
Named
3137
name

‎libs/wire-api/src/Wire/API/Error/Galley.hs

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,7 @@ module Wire.API.Error.Galley
2626
where
2727

2828
import Data.Aeson (FromJSON (..), ToJSON (..))
29+
import Data.Singletons
2930
import Data.Singletons.CustomStar (genSingletons)
3031
import Data.Singletons.Prelude (Show_)
3132
import GHC.TypeLits
@@ -214,6 +215,9 @@ instance APIError GalleyError where
214215
TeamSearchVisibilityNotEnabled -> dynError @(MapError 'TeamSearchVisibilityNotEnabled)
215216
CannotEnableLegalHoldServiceLargeTeam -> dynError @(MapError 'CannotEnableLegalHoldServiceLargeTeam)
216217

218+
instance (SingI e, Member (Error GalleyError) r) => ServerEffect GalleyError (ErrorS (e :: GalleyError)) r where
219+
interpretServerEffect = mapToRuntimeError (demote @e)
220+
217221
--------------------------------------------------------------------------------
218222
-- Authentication errors
219223

@@ -241,7 +245,7 @@ authenticationErrorToDyn ReAuthFailed = dynError @(MapError 'ReAuthFailed)
241245
authenticationErrorToDyn VerificationCodeAuthFailed = dynError @(MapError 'VerificationCodeAuthFailed)
242246
authenticationErrorToDyn VerificationCodeRequired = dynError @(MapError 'VerificationCodeRequired)
243247

244-
instance Member (Error DynError) r => ServerEffect (Error AuthenticationError) r where
248+
instance Member (Error DynError) r => ServerEffect DynError (Error AuthenticationError) r where
245249
interpretServerEffect = mapError authenticationErrorToDyn
246250

247251
--------------------------------------------------------------------------------
@@ -284,7 +288,7 @@ type instance MapError 'FeatureLocked = 'StaticError 409 "feature-locked" "Featu
284288

285289
type instance ErrorEffect TeamFeatureError = Error TeamFeatureError
286290

287-
instance Member (Error DynError) r => ServerEffect (Error TeamFeatureError) r where
291+
instance Member (Error DynError) r => ServerEffect DynError (Error TeamFeatureError) r where
288292
interpretServerEffect = mapError $ \case
289293
AppLockInactivityTimeoutTooLow -> dynError @(MapError 'AppLockInactivityTimeoutTooLow)
290294
LegalHoldFeatureFlagNotEnabled -> dynError @(MapError 'LegalHoldFeatureFlagNotEnabled)

‎libs/wire-api/src/Wire/API/Routes/API.hs

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -44,15 +44,15 @@ newtype API api r = API {unAPI :: ServerT api (Sem r)}
4444
-- | Convert a polysemy handler to an 'API' value.
4545
mkAPI ::
4646
forall r0 api.
47-
(HasServer api '[Domain], ServerEffects (DeclaredErrorEffects api) r0) =>
47+
(HasServer api '[Domain], ServerEffects DynError (DeclaredErrorEffects api) r0) =>
4848
ServerT api (Sem (Append (DeclaredErrorEffects api) r0)) ->
4949
API api r0
50-
mkAPI h = API $ hoistServerWithDomain @api (interpretServerEffects @(DeclaredErrorEffects api) @r0) h
50+
mkAPI h = API $ hoistServerWithDomain @api (interpretServerEffects @DynError @(DeclaredErrorEffects api) @r0) h
5151

5252
-- | Convert a polysemy handler to a named 'API' value.
5353
mkNamedAPI ::
5454
forall name r0 api.
55-
(HasServer api '[Domain], ServerEffects (DeclaredErrorEffects api) r0) =>
55+
(HasServer api '[Domain], ServerEffects DynError (DeclaredErrorEffects api) r0) =>
5656
ServerT api (Sem (Append (DeclaredErrorEffects api) r0)) ->
5757
API (Named name api) r0
5858
mkNamedAPI = API . Named . unAPI . mkAPI @r0 @api
@@ -92,17 +92,17 @@ hoistAPI ::
9292
API api2 r2
9393
hoistAPI f = API . f . unAPI
9494

95-
class ServerEffect eff r where
95+
class ServerEffect targetError eff r where
9696
interpretServerEffect :: Sem (eff ': r) a -> Sem r a
9797

98-
class ServerEffects r r1 where
98+
class ServerEffects targetError r r1 where
9999
interpretServerEffects :: Sem (Append r r1) a -> Sem r1 a
100100

101-
instance ServerEffects '[] r where
101+
instance ServerEffects targetError '[] r where
102102
interpretServerEffects = id
103103

104-
instance (ServerEffects r r1, ServerEffect eff (Append r r1)) => ServerEffects (eff ': r) r1 where
105-
interpretServerEffects = interpretServerEffects @r @r1 . interpretServerEffect @eff @(Append r r1)
104+
instance (ServerEffects targetError r r1, ServerEffect targetError eff (Append r r1)) => ServerEffects targetError (eff ': r) r1 where
105+
interpretServerEffects = interpretServerEffects @targetError @r @r1 . interpretServerEffect @targetError @eff @(Append r r1)
106106

107-
instance (KnownError (MapError e), Member (Error DynError) r) => ServerEffect (ErrorS e) r where
107+
instance (KnownError (MapError e), Member (Error DynError) r) => ServerEffect DynError (ErrorS e) r where
108108
interpretServerEffect = mapToDynamicError

‎services/galley/src/Galley/API/Federation.hs

Lines changed: 75 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -69,14 +69,35 @@ import Wire.API.Federation.API
6969
import Wire.API.Federation.API.Common (EmptyResponse (..))
7070
import Wire.API.Federation.API.Galley (ConversationUpdateResponse)
7171
import qualified Wire.API.Federation.API.Galley as F
72+
import Wire.API.Federation.Endpoint
7273
import Wire.API.Federation.Error
74+
import Wire.API.Routes.API
7375
import Wire.API.Routes.Internal.Brig.Connection
7476
import Wire.API.Routes.Named
7577
import Wire.API.ServantProto
7678
import Wire.API.User.Client (userClientMap)
7779

7880
type FederationAPI = "federation" :> FedApi 'Galley
7981

82+
type ReceiptModeAPIWithoutErrors =
83+
FedEndpointWithErrors
84+
"update-conversation-receipt-mode"
85+
'[]
86+
F.ConversationUpdateRequest
87+
F.ConversationUpdateResponse
88+
89+
type ReceiptModeAPI =
90+
FedEndpointWithErrors
91+
"update-conversation-receipt-mode"
92+
'[ 'ActionDenied 'ModifyConversationReceiptMode,
93+
'ConvAccessDenied,
94+
'ConvNotFound,
95+
'InvalidOperation
96+
]
97+
F.ConversationUpdateRequest
98+
F.ConversationUpdateResponse
99+
100+
-- | Convert a polysemy handler to an 'API' value.
80101
federationSitemap :: ServerT FederationAPI (Sem GalleyEffects)
81102
federationSitemap =
82103
Named @"on-conversation-created" onConversationCreated
@@ -87,6 +108,10 @@ federationSitemap =
87108
:<|> Named @"send-message" sendMessage
88109
:<|> Named @"on-user-deleted-conversations" onUserDeleted
89110
:<|> Named @"update-conversation" updateConversation
111+
:<|> hoistServerWithDomain
112+
@ReceiptModeAPIWithoutErrors
113+
(interpretServerEffects @GalleyError @(DeclaredErrorEffects ReceiptModeAPI))
114+
(Named @"update-conversation-receipt-mode" updateConversationReceiptMode)
90115

91116
onConversationCreated ::
92117
Members
@@ -486,3 +511,53 @@ updateConversation origDomain updateRequest =
486511
mkResponse (Left err) = F.ConversationUpdateResponseError err
487512
mkResponse (Right (Left NoChanges)) = F.ConversationUpdateResponseNoChanges
488513
mkResponse (Right (Right convUpdate)) = F.ConversationUpdateResponseUpdate convUpdate
514+
515+
updateConversationReceiptMode ::
516+
forall r.
517+
( Members
518+
'[ BrigAccess,
519+
CodeStore,
520+
BotAccess,
521+
FireAndForget,
522+
Error FederationError,
523+
Error InvalidInput,
524+
Error LegalHoldError,
525+
ErrorS ('ActionDenied 'ModifyConversationReceiptMode),
526+
ErrorS 'ConvAccessDenied,
527+
ErrorS 'ConvNotFound,
528+
ErrorS 'InvalidOperation,
529+
ExternalAccess,
530+
FederatorAccess,
531+
Error InternalError,
532+
GundeckAccess,
533+
Input Opts,
534+
Input UTCTime,
535+
LegalHoldStore,
536+
MemberStore,
537+
TeamStore,
538+
ConversationStore,
539+
Input (Local ())
540+
]
541+
r
542+
) =>
543+
-- |
544+
Domain ->
545+
-- |
546+
F.ConversationUpdateRequest ->
547+
Sem r ConversationUpdateResponse
548+
updateConversationReceiptMode origDomain updateRequest =
549+
fmap mkResponse . runError . runError @NoChanges $
550+
do
551+
loc <- qualifyLocal ()
552+
let rusr = toRemoteUnsafe origDomain (F.curUser updateRequest)
553+
lcnv = qualifyAs loc (F.curConvId updateRequest)
554+
555+
-- case F.curAction updateRequest of
556+
-- SomeConversationAction tag action ->
557+
-- $(sCases ''ConversationActionTag [|tag|] [|updateLocalConversationWithRemoteUser tag lcnv rusr action|])
558+
pure (error "TODO")
559+
where
560+
mkResponse :: Either GalleyError (Either NoChanges ConversationUpdate) -> ConversationUpdateResponse
561+
mkResponse (Left err) = F.ConversationUpdateResponseError err
562+
mkResponse (Right (Left NoChanges)) = F.ConversationUpdateResponseNoChanges
563+
mkResponse (Right (Right convUpdate)) = F.ConversationUpdateResponseUpdate convUpdate

‎services/galley/src/Galley/API/Update.hs

Lines changed: 23 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -358,18 +358,34 @@ updateRemoteConversationReceiptMode rcnv lusr conn action = getUpdateResult $ do
358358
response <- E.runFederated rcnv (fedClient @'Galley @"update-conversation" updateRequest)
359359
convUpdate <- case response of
360360
ConversationUpdateResponseNoChanges -> throw NoChanges
361-
ConversationUpdateResponseError err' ->
362-
case err' of
363-
ActionDenied ModifyConversationReceiptMode -> throwS @('ActionDenied 'ModifyConversationReceiptMode)
364-
ConvAccessDenied -> throwS @'ConvAccessDenied
365-
ConvNotFound -> throwS @'ConvNotFound
366-
InvalidOperation -> throwS @'InvalidOperation
367-
_ -> throw (FederationUnexpectedError (toWai err'))
361+
ConversationUpdateResponseError err' -> rethrowErrors @'[ErrorS 'ConvAccessDenied] err'
368362
ConversationUpdateResponseUpdate convUpdate -> pure convUpdate
369363

370364
onConversationUpdated (tDomain rcnv) convUpdate
371365
notifyRemoteConversationAction (qualifyAs rcnv convUpdate) conn
372366

367+
class RethrowErrors (effs :: EffectRow) r where
368+
rethrowErrors :: GalleyError -> Sem r a
369+
370+
instance (Member (Error FederationError) r) => RethrowErrors '[] r where
371+
rethrowErrors :: GalleyError -> Sem r a
372+
rethrowErrors err' = throw (FederationUnexpectedError (toWai err'))
373+
374+
instance
375+
( SingI (e :: GalleyError),
376+
Member (ErrorS e) r,
377+
RethrowErrors effs r
378+
) =>
379+
RethrowErrors ((ErrorS e) ': effs) r
380+
where
381+
rethrowErrors :: GalleyError -> Sem r a
382+
rethrowErrors err' =
383+
if err' == demote @e
384+
then throwS @e
385+
else rethrowErrors @effs @r err'
386+
387+
-- rethrowErrors :: DeclaredErrorEffects api
388+
373389
updateConversationReceiptModeUnqualified ::
374390
Members
375391
'[ ConversationStore,

0 commit comments

Comments
 (0)