From 1d5155f95c18d15861a6afe58ddc9ded39380536 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 27 May 2025 16:20:19 -0700 Subject: [PATCH 1/4] Add MonadReader Env to Transactions --- src/Share/Env.hs | 1 + src/Share/Metrics.hs | 2 +- src/Share/Postgres.hs | 63 +++++++++++++++-------------- src/Share/Postgres/Notifications.hs | 2 +- 4 files changed, 35 insertions(+), 33 deletions(-) diff --git a/src/Share/Env.hs b/src/Share/Env.hs index 4fe9bc84..cf101c9a 100644 --- a/src/Share/Env.hs +++ b/src/Share/Env.hs @@ -59,3 +59,4 @@ data Env ctx = Env maxParallelismPerDownloadRequest :: Int, maxParallelismPerUploadRequest :: Int } + deriving (Functor) diff --git a/src/Share/Metrics.hs b/src/Share/Metrics.hs index b68ff2d2..c418dd36 100644 --- a/src/Share/Metrics.hs +++ b/src/Share/Metrics.hs @@ -78,7 +78,7 @@ serveMetricsMiddleware env = do refreshGauges getMetrics Prom.prometheus prometheusSettings app req handleResponse where - runPG = PG.runSessionWithPool (Env.pgConnectionPool env) . PG.transaction PG.ReadCommitted PG.Read + runPG = PG.runSessionWithEnv env . PG.transaction PG.ReadCommitted PG.Read prometheusSettings = Prom.def { Prom.prometheusEndPoint = ["metrics"], diff --git a/src/Share/Postgres.hs b/src/Share/Postgres.hs index 6896b1c6..04214b6c 100644 --- a/src/Share/Postgres.hs +++ b/src/Share/Postgres.hs @@ -12,7 +12,7 @@ module Share.Postgres Transaction, Pipeline, T, - Session, + Session (..), Mode (..), IsolationLevel (..), Interp.EncodeValue (..), @@ -40,8 +40,8 @@ module Share.Postgres runSession, tryRunSession, runSessionOrRespondError, - runSessionWithPool, - tryRunSessionWithPool, + runSessionWithEnv, + tryRunSessionWithEnv, unliftSession, defaultIsolationLevel, pipelined, @@ -112,8 +112,8 @@ data TransactionError e | Err e -- | A transaction that may fail with an error 'e' (or throw an unrecoverable error) -newtype Transaction e a = Transaction {unTransaction :: Hasql.Session (Either (TransactionError e) a)} - deriving (Functor, Applicative, Monad) via (ExceptT (TransactionError e) Hasql.Session) +newtype Transaction e a = Transaction {unTransaction :: ReaderT (Env.Env ()) Hasql.Session (Either (TransactionError e) a)} + deriving (Functor, Applicative, Monad, MonadReader (Env.Env ())) via (ReaderT (Env.Env ()) (ExceptT (TransactionError e) Hasql.Session)) instance MonadError e (Transaction e) where throwError = Transaction . pure . Left . Err @@ -129,7 +129,7 @@ newtype Pipeline e a = Pipeline {unPipeline :: Hasql.Pipeline.Pipeline (Either ( -- | Run a pipeline in a transaction pipelined :: Pipeline e a -> Transaction e a -pipelined p = Transaction (Hasql.pipeline (unPipeline p)) +pipelined p = Transaction (lift $ Hasql.pipeline (unPipeline p)) -- | Like fmap, but the provided function can throw a recoverable error by returning 'Left'. pEitherMap :: (a -> Either e b) -> Pipeline e a -> Pipeline e b @@ -151,7 +151,8 @@ pFor_ f p = pipelined $ for_ f p type T = Transaction Void -- | A session that may fail with an error 'e' -type Session e = ExceptT (TransactionError e) Hasql.Session +newtype Session e a = Session {_unSession :: ReaderT (Env.Env ()) (ExceptT (TransactionError e) Hasql.Session) a} + deriving newtype (Functor, Applicative, Monad, MonadReader (Env.Env ()), MonadIO, MonadError (TransactionError e)) data PostgresError = PostgresError (Pool.UsageError) @@ -185,10 +186,10 @@ data IsolationLevel -- | Run a transaction in a session transaction :: forall e a. IsolationLevel -> Mode -> Transaction e a -> Session e a -transaction isoLevel mode (Transaction t) = do - let loop :: Session.Session (Either (TransactionError e) a) +transaction isoLevel mode (Transaction t) = Session do + let loop :: ReaderT (Env.Env ()) Session.Session (Either (TransactionError e) a) loop = do - beginTransaction isoLevel mode + lift $ beginTransaction isoLevel mode res <- catchError (Just <$> mayCommit t) \case Session.QueryError _ @@ -202,25 +203,25 @@ transaction isoLevel mode (Transaction t) = do err -> do -- Try rolling back, but this will most likely fail since the connection has -- already failed. If this fails we just rethrow the original exception. - catchError rollbackSession (const $ throwError err) + lift $ catchError rollbackSession (const $ throwError err) -- It's very important to rethrow all QueryErrors so Hasql can remove the -- connection from the pool. throwError err case res of Nothing -> do - rollbackSession + lift $ rollbackSession loop Just res -> pure res - ExceptT loop + mapReaderT ExceptT loop where - mayCommit :: Hasql.Session (Either (TransactionError e) a) -> Hasql.Session (Either (TransactionError e) a) + mayCommit :: ReaderT (Env.Env ()) Hasql.Session (Either (TransactionError e) a) -> ReaderT (Env.Env ()) Hasql.Session (Either (TransactionError e) a) mayCommit m = m >>= \case Left err -> do - rollbackSession + lift rollbackSession pure (Left err) Right a -> do - commit + lift commit pure (Right a) beginTransaction :: IsolationLevel -> Mode -> Hasql.Session () @@ -250,7 +251,7 @@ rollback e = Transaction do transactionStatement :: a -> Hasql.Statement a b -> Transaction e b transactionStatement v stmt = Transaction do - Right <$> Session.statement v stmt + Right <$> lift (Session.statement v stmt) -- | Run a read-only transaction within a session readTransaction :: Transaction e a -> Session e a @@ -305,23 +306,23 @@ runSession t = either absurd id <$> tryRunSession t -- | Run a session in the App monad, returning an Either error. tryRunSession :: (MonadReader (Env.Env x) m, MonadIO m, HasCallStack) => Session e a -> m (Either e a) tryRunSession s = do - pool <- asks Env.pgConnectionPool - liftIO $ tryRunSessionWithPool pool s + env <- ask + liftIO $ tryRunSessionWithEnv env s -- | Unlift a session to run in IO. unliftSession :: Session e a -> AppM x (IO (Either e a)) unliftSession s = do - pool <- asks Env.pgConnectionPool - pure $ tryRunSessionWithPool pool s + env <- ask + pure $ tryRunSessionWithEnv env s --- | Manually run an unfailing session using a connection pool. -runSessionWithPool :: (HasCallStack) => Pool.Pool -> Session Void a -> IO a -runSessionWithPool pool s = either absurd id <$> tryRunSessionWithPool pool s +-- | Manually run an unfailing session using the connection pool from the provided env. +runSessionWithEnv :: (HasCallStack) => Env.Env any -> Session Void a -> IO a +runSessionWithEnv env s = either absurd id <$> tryRunSessionWithEnv env s --- | Manually run a session using a connection pool, returning an Either error. -tryRunSessionWithPool :: (HasCallStack) => Pool.Pool -> Session e a -> IO (Either e a) -tryRunSessionWithPool pool s = do - liftIO (Pool.use pool (runExceptT s)) >>= \case +-- | Manually run a session, using the connection pool from the provided env, returning an Either error. +tryRunSessionWithEnv :: (HasCallStack) => Env.Env any -> Session e a -> IO (Either e a) +tryRunSessionWithEnv env@(Env.Env {pgConnectionPool = pool}) (Session s) = do + liftIO (Pool.use pool (runExceptT $ runReaderT s (void env))) >>= \case Left err -> throwIO . someServerError $ PostgresError err Right (Left (Unrecoverable e)) -> throwIO e Right (Left (Err e)) -> pure (Left e) @@ -365,14 +366,14 @@ instance QueryM (Transaction e) where transactionUnsafeIO io = Transaction (Right <$> liftIO io) instance QueryA (Session e) where - statement q s = do - lift $ Session.statement q s + statement q s = + Session . lift . lift $ Session.statement q s unrecoverableError e = do throwError (Unrecoverable (someServerError e)) instance QueryM (Session e) where - transactionUnsafeIO io = lift $ liftIO io + transactionUnsafeIO io = Session . lift . lift $ liftIO io instance QueryA (Pipeline e) where statement q s = Pipeline (Right <$> Hasql.Pipeline.statement q s) diff --git a/src/Share/Postgres/Notifications.hs b/src/Share/Postgres/Notifications.hs index cd60cc8c..df9b3fb3 100644 --- a/src/Share/Postgres/Notifications.hs +++ b/src/Share/Postgres/Notifications.hs @@ -48,7 +48,7 @@ initialize scope = Ki.fork_ scope $ forever do PG.statement () $ Hasql.listen (Hasql.Identifier . Text.encodeUtf8 $ toChannelText kind) -- Wait for notifications let loop = do - Hasql.Notification {channel} <- lift $ Hasql.await + Hasql.Notification {channel} <- PG.Session . lift . lift $ Hasql.await fromChannelText channel & \case Just kind -> do liftIO . STM.atomically $ STM.modifyTVar' notifs $ Set.insert kind From 28b4376c43063b55e9653ce5ead44915ff4b2229 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 27 May 2025 16:20:19 -0700 Subject: [PATCH 2/4] Add links to Hydrated events --- src/Share/BackgroundJobs/Webhooks/Worker.hs | 19 +++++----- src/Share/Notifications/Ops.hs | 7 ++++ src/Share/Notifications/Queries.hs | 14 ++++---- src/Share/Notifications/Types.hs | 40 ++++++++++++--------- 4 files changed, 46 insertions(+), 34 deletions(-) diff --git a/src/Share/BackgroundJobs/Webhooks/Worker.hs b/src/Share/BackgroundJobs/Webhooks/Worker.hs index ce85d4d5..17e72dd3 100644 --- a/src/Share/BackgroundJobs/Webhooks/Worker.hs +++ b/src/Share/BackgroundJobs/Webhooks/Worker.hs @@ -138,7 +138,7 @@ data WebhookEventPayload jwt = WebhookEventPayload -- | The topic of the notification event. topic :: NotificationTopic, -- | The data associated with the notification event. - data_ :: HydratedEventPayload, + data_ :: HydratedEvent, -- | A signed token containing all of the same data. jwt :: jwt } @@ -175,7 +175,7 @@ instance FromJSON (WebhookEventPayload ()) where <*> pure () tryWebhook :: - NotificationEvent NotificationEventId UnifiedDisplayInfo UTCTime HydratedEventPayload -> + NotificationEvent NotificationEventId UnifiedDisplayInfo UTCTime HydratedEvent -> NotificationWebhookId -> Background (Maybe WebhookSendFailure) tryWebhook event webhookId = UnliftIO.handleAny (\someException -> pure $ Just $ InvalidRequest event.eventId webhookId someException) do @@ -206,7 +206,7 @@ tryWebhook event webhookId = UnliftIO.handleAny (\someException -> pure $ Just $ | status >= 400 -> throwError $ ReceiverError event.eventId webhookId httpStatus $ HTTPClient.responseBody resp | otherwise -> pure () -buildWebhookRequest :: NotificationWebhookId -> URI -> NotificationEvent NotificationEventId UnifiedDisplayInfo UTCTime HydratedEventPayload -> WebhookEventPayload JWTParam -> Background (Either WebhookSendFailure HTTPClient.Request) +buildWebhookRequest :: NotificationWebhookId -> URI -> NotificationEvent NotificationEventId UnifiedDisplayInfo UTCTime HydratedEvent -> WebhookEventPayload JWTParam -> Background (Either WebhookSendFailure HTTPClient.Request) buildWebhookRequest webhookId uri event defaultPayload = do if | isSlackWebhook uri -> buildChatAppPayload (Proxy @ChatApps.Slack) uri @@ -246,18 +246,18 @@ buildWebhookRequest webhookId uri event defaultPayload = do actorAuthor = maybe "" (<> " ") actorName <> actorHandle actorAvatarUrl = event.eventActor ^. DisplayInfo.avatarUrl_ actorLink <- Links.userProfilePage (event.eventActor ^. DisplayInfo.handle_) - messageContent :: ChatApps.MessageContent provider <- case event.eventData of + let mainLink = Just event.eventData.hydratedEventLink + messageContent :: ChatApps.MessageContent provider <- case event.eventData.payload of HydratedProjectBranchUpdatedPayload payload -> do let pbShorthand = (projectBranchShortHandFromParts payload.projectInfo.projectShortHand payload.branchInfo.branchShortHand) title = "Branch " <> IDs.toText pbShorthand <> " was just updated." preText = title - link <- Links.notificationLink event.eventData pure $ ChatApps.MessageContent { preText = preText, content = "Branch updated", title = title, - mainLink = Just link, + mainLink, author = Author { authorName = Just actorAuthor, @@ -272,13 +272,12 @@ buildWebhookRequest webhookId uri event defaultPayload = do title = payload.contributionInfo.contributionTitle description = fromMaybe "" $ payload.contributionInfo.contributionDescription preText = "New Contribution in " <> IDs.toText pbShorthand - link <- Links.notificationLink event.eventData pure $ ChatApps.MessageContent { preText = preText, content = description, title = title, - mainLink = Just link, + mainLink, author = Author { authorName = Just actorAuthor, @@ -302,13 +301,13 @@ buildWebhookRequest webhookId uri event defaultPayload = do attemptWebhookSend :: AuthZ.AuthZReceipt -> - (NotificationEvent NotificationEventId UnifiedDisplayInfo UTCTime HydratedEventPayload -> NotificationWebhookId -> IO (Maybe WebhookSendFailure)) -> + (NotificationEvent NotificationEventId UnifiedDisplayInfo UTCTime HydratedEvent -> NotificationWebhookId -> IO (Maybe WebhookSendFailure)) -> NotificationEventId -> NotificationWebhookId -> PG.Transaction e (Maybe WebhookSendFailure) attemptWebhookSend _authZReceipt tryWebhookIO eventId webhookId = do event <- NQ.expectEvent eventId - hydratedEvent <- forOf eventData_ event NQ.hydrateEventData + hydratedEvent <- forOf eventData_ event NQ.hydrateEventPayload populatedEvent <- hydratedEvent & DisplayInfoQ.unifiedDisplayInfoForUserOf eventUserInfo_ PG.transactionUnsafeIO (tryWebhookIO populatedEvent webhookId) >>= \case Just err -> do diff --git a/src/Share/Notifications/Ops.hs b/src/Share/Notifications/Ops.hs index ed0ff2b9..4327542d 100644 --- a/src/Share/Notifications/Ops.hs +++ b/src/Share/Notifications/Ops.hs @@ -3,6 +3,7 @@ module Share.Notifications.Ops createWebhookDeliveryMethod, updateWebhookDeliveryMethod, deleteWebhookDeliveryMethod, + hydrateEvent, ) where @@ -16,6 +17,7 @@ import Share.Prelude import Share.Utils.URI (URIParam (..)) import Share.Web.App (WebApp) import Share.Web.Errors (respondError) +import Share.Web.UI.Links qualified as Links listNotificationDeliveryMethods :: UserId -> Maybe NotificationSubscriptionId -> WebApp [NotificationDeliveryMethod] listNotificationDeliveryMethods userId maySubscriptionId = do @@ -75,3 +77,8 @@ deleteWebhookDeliveryMethod notificationUser webhookDeliveryMethodId = do Right _ -> do PG.runTransaction $ do NotifQ.deleteWebhookDeliveryMethod notificationUser webhookDeliveryMethodId + +hydrateEvent :: HydratedEventPayload -> WebApp HydratedEvent +hydrateEvent hydratedEventPayload = do + hydratedEventLink <- Links.notificationLink hydratedEventPayload + pure $ HydratedEvent {hydratedEventPayload, hydratedEventLink} diff --git a/src/Share/Notifications/Queries.hs b/src/Share/Notifications/Queries.hs index 129c29ad..727378bf 100644 --- a/src/Share/Notifications/Queries.hs +++ b/src/Share/Notifications/Queries.hs @@ -1,7 +1,7 @@ module Share.Notifications.Queries ( recordEvent, expectEvent, - listNotificationHubEntries, + listNotificationHubEntryPayloads, updateNotificationHubEntries, addSubscriptionDeliveryMethods, removeSubscriptionDeliveryMethods, @@ -17,7 +17,7 @@ module Share.Notifications.Queries deleteNotificationSubscription, updateNotificationSubscription, getNotificationSubscription, - hydrateEventData, + hydrateEventPayload, ) where @@ -54,8 +54,8 @@ expectEvent eventId = do WHERE id = #{eventId} |] -listNotificationHubEntries :: UserId -> Maybe Int -> Maybe UTCTime -> Maybe (NESet NotificationStatus) -> Transaction e [NotificationHubEntry UnifiedDisplayInfo HydratedEventPayload] -listNotificationHubEntries notificationUserId mayLimit afterTime statusFilter = do +listNotificationHubEntryPayloads :: UserId -> Maybe Int -> Maybe UTCTime -> Maybe (NESet NotificationStatus) -> Transaction e [NotificationHubEntry UnifiedDisplayInfo HydratedEventPayload] +listNotificationHubEntryPayloads notificationUserId mayLimit afterTime statusFilter = do let limit = clamp (0, 1000) . fromIntegral @Int @Int32 . fromMaybe 50 $ mayLimit let statusFilterList = Foldable.toList <$> statusFilter dbNotifications <- @@ -70,7 +70,7 @@ listNotificationHubEntries notificationUserId mayLimit afterTime statusFilter = ORDER BY hub.created_at DESC LIMIT #{limit} |] - hydrated <- PG.pipelined $ forOf (traversed . traversed) dbNotifications hydrateEventData + hydratedPayloads <- PG.pipelined $ forOf (traversed . traversed) dbNotifications hydrateEventData hydrated & DisplayInfoQ.unifiedDisplayInfoForUserOf (traversed . hubEntryUserInfo_) updateNotificationHubEntries :: (QueryA m) => NESet NotificationHubEntryId -> NotificationStatus -> m () @@ -293,8 +293,8 @@ getNotificationSubscription subscriberUserId subscriptionId = do -- (preferably pipelined). -- -- If need be we can write a batch job in plpgsql to hydrate them all at once. -hydrateEventData :: forall m. (QueryA m) => NotificationEventData -> m HydratedEventPayload -hydrateEventData = \case +hydrateEventPayload :: forall m. (QueryA m) => NotificationEventData -> m HydratedEventPayload +hydrateEventPayload = \case ProjectBranchUpdatedData (ProjectBranchData {projectId, branchId}) -> do HydratedProjectBranchUpdatedPayload <$> hydrateProjectBranchPayload projectId branchId diff --git a/src/Share/Notifications/Types.hs b/src/Share/Notifications/Types.hs index 39f32d1d..54c084a5 100644 --- a/src/Share/Notifications/Types.hs +++ b/src/Share/Notifications/Types.hs @@ -18,6 +18,7 @@ module Share.Notifications.Types NotificationEmailDeliveryConfig (..), NotificationWebhookConfig (..), HydratedEventPayload (..), + HydratedEvent (..), BranchPayload (..), ProjectPayload (..), ContributionPayload (..), @@ -527,27 +528,32 @@ instance FromJSON ProjectContributionCreatedPayload where contributionInfo <- o .: "contribution" pure ProjectContributionCreatedPayload {projectInfo, contributionInfo} +data HydratedEvent = HydratedEvent + { hydratedEventPayload :: HydratedEventPayload, + hydratedEventLink :: URI + } + deriving stock (Show, Eq) + +instance ToJSON HydratedEvent where + toJSON he@(HydratedEvent {hydratedEventPayload, hydratedEventLink}) = + let kind :: Text = case hydratedEventTopic he of + ProjectBranchUpdated -> "projectBranchUpdated" + ProjectContributionCreated -> "projectContributionCreated" + payload = case hydratedEventPayload of + HydratedProjectBranchUpdatedPayload p -> Aeson.toJSON p + HydratedProjectContributionCreatedPayload p -> Aeson.toJSON p + in Aeson.object + [ "payload" .= payload, + "link" .= URIParam hydratedEventLink, + "kind" .= kind + ] + data HydratedEventPayload = HydratedProjectBranchUpdatedPayload ProjectBranchUpdatedPayload | HydratedProjectContributionCreatedPayload ProjectContributionCreatedPayload deriving stock (Show, Eq) -hydratedEventTopic :: HydratedEventPayload -> NotificationTopic -hydratedEventTopic = \case +hydratedEventTopic :: HydratedEvent -> NotificationTopic +hydratedEventTopic (HydratedEvent {hydratedEventPayload}) = case hydratedEventPayload of HydratedProjectBranchUpdatedPayload _ -> ProjectBranchUpdated HydratedProjectContributionCreatedPayload _ -> ProjectContributionCreated - -instance ToJSON HydratedEventPayload where - toJSON = \case - (HydratedProjectBranchUpdatedPayload payload) -> - Aeson.object ["kind" .= ("projectBranchUpdated" :: Text), "payload" .= payload] - (HydratedProjectContributionCreatedPayload payload) -> - Aeson.object ["kind" .= ("projectContributionCreated" :: Text), "payload" .= payload] - -instance FromJSON HydratedEventPayload where - parseJSON = Aeson.withObject "HydratedEventPayload" \o -> do - kind <- o .: "kind" - case kind of - "projectBranchUpdated" -> HydratedProjectBranchUpdatedPayload <$> o .: "payload" - "projectContributionCreated" -> HydratedProjectContributionCreatedPayload <$> o .: "payload" - _ -> fail $ "Unknown event kind: " <> Text.unpack kind From abc6f190911daf2f93bd60bd9fa7df3d28803324 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 27 May 2025 16:39:00 -0700 Subject: [PATCH 3/4] Hydrate events in transactions --- src/Share/BackgroundJobs/Webhooks/Worker.hs | 6 ++++-- src/Share/Notifications/API.hs | 4 ++-- src/Share/Notifications/Impl.hs | 5 ++++- src/Share/Notifications/Ops.hs | 2 +- src/Share/Notifications/Queries.hs | 4 ++-- src/Share/Notifications/Types.hs | 10 ++++++++++ src/Share/Web/UI/Links.hs | 18 +++++++++--------- 7 files changed, 32 insertions(+), 17 deletions(-) diff --git a/src/Share/BackgroundJobs/Webhooks/Worker.hs b/src/Share/BackgroundJobs/Webhooks/Worker.hs index 17e72dd3..5d3f6ff7 100644 --- a/src/Share/BackgroundJobs/Webhooks/Worker.hs +++ b/src/Share/BackgroundJobs/Webhooks/Worker.hs @@ -33,6 +33,7 @@ import Share.IDs qualified as IDs import Share.JWT (JWTParam (..)) import Share.JWT qualified as JWT import Share.Metrics qualified as Metrics +import Share.Notifications.Ops qualified as NotOps import Share.Notifications.Queries qualified as NQ import Share.Notifications.Types import Share.Notifications.Webhooks.Secrets (WebhookConfig (..), WebhookSecretError) @@ -247,7 +248,7 @@ buildWebhookRequest webhookId uri event defaultPayload = do actorAvatarUrl = event.eventActor ^. DisplayInfo.avatarUrl_ actorLink <- Links.userProfilePage (event.eventActor ^. DisplayInfo.handle_) let mainLink = Just event.eventData.hydratedEventLink - messageContent :: ChatApps.MessageContent provider <- case event.eventData.payload of + messageContent :: ChatApps.MessageContent provider <- case event.eventData.hydratedEventPayload of HydratedProjectBranchUpdatedPayload payload -> do let pbShorthand = (projectBranchShortHandFromParts payload.projectInfo.projectShortHand payload.branchInfo.branchShortHand) title = "Branch " <> IDs.toText pbShorthand <> " was just updated." @@ -307,7 +308,8 @@ attemptWebhookSend :: PG.Transaction e (Maybe WebhookSendFailure) attemptWebhookSend _authZReceipt tryWebhookIO eventId webhookId = do event <- NQ.expectEvent eventId - hydratedEvent <- forOf eventData_ event NQ.hydrateEventPayload + hydratedEventPayload <- forOf eventData_ event NQ.hydrateEventPayload + hydratedEvent <- for hydratedEventPayload NotOps.hydrateEvent populatedEvent <- hydratedEvent & DisplayInfoQ.unifiedDisplayInfoForUserOf eventUserInfo_ PG.transactionUnsafeIO (tryWebhookIO populatedEvent webhookId) >>= \case Just err -> do diff --git a/src/Share/Notifications/API.hs b/src/Share/Notifications/API.hs index 653a17ed..2e84c9f2 100644 --- a/src/Share/Notifications/API.hs +++ b/src/Share/Notifications/API.hs @@ -39,7 +39,7 @@ import Data.Text qualified as Text import Data.Time (UTCTime) import Servant import Share.IDs -import Share.Notifications.Types (DeliveryMethodId, HydratedEventPayload, NotificationDeliveryMethod, NotificationHubEntry, NotificationStatus, NotificationSubscription, NotificationTopic, SubscriptionFilter) +import Share.Notifications.Types (DeliveryMethodId, HydratedEvent, NotificationDeliveryMethod, NotificationHubEntry, NotificationStatus, NotificationSubscription, NotificationTopic, SubscriptionFilter) import Share.OAuth.Session (AuthenticatedUserId) import Share.Prelude import Share.Utils.URI (URIParam) @@ -213,7 +213,7 @@ type GetHubEntriesEndpoint = :> Get '[JSON] GetHubEntriesResponse data GetHubEntriesResponse = GetHubEntriesResponse - { notifications :: [NotificationHubEntry UnifiedDisplayInfo HydratedEventPayload] + { notifications :: [NotificationHubEntry UnifiedDisplayInfo HydratedEvent] } instance ToJSON GetHubEntriesResponse where diff --git a/src/Share/Notifications/Impl.hs b/src/Share/Notifications/Impl.hs index 2f6caf0e..8f9dc09e 100644 --- a/src/Share/Notifications/Impl.hs +++ b/src/Share/Notifications/Impl.hs @@ -1,5 +1,6 @@ module Share.Notifications.Impl (server) where +import Control.Lens (forOf, traversed) import Data.Time import Servant import Servant.Server.Generic (AsServerT) @@ -80,7 +81,9 @@ getHubEntriesEndpoint :: UserHandle -> UserId -> Maybe Int -> Maybe UTCTime -> M getHubEntriesEndpoint userHandle callerUserId limit afterTime mayStatusFilter = do User {user_id = notificationUserId} <- UserQ.expectUserByHandle userHandle _authZReceipt <- AuthZ.permissionGuard $ AuthZ.checkNotificationsGet callerUserId notificationUserId - notifications <- PG.runTransaction $ NotificationQ.listNotificationHubEntries notificationUserId limit afterTime (API.getStatusFilter <$> mayStatusFilter) + notifications <- PG.runTransaction do + notifs <- NotificationQ.listNotificationHubEntryPayloads notificationUserId limit afterTime (API.getStatusFilter <$> mayStatusFilter) + forOf (traversed . traversed) notifs NotifOps.hydrateEvent pure $ API.GetHubEntriesResponse {notifications} updateHubEntriesEndpoint :: UserHandle -> UserId -> API.UpdateHubEntriesRequest -> WebApp () diff --git a/src/Share/Notifications/Ops.hs b/src/Share/Notifications/Ops.hs index 4327542d..ad378e1a 100644 --- a/src/Share/Notifications/Ops.hs +++ b/src/Share/Notifications/Ops.hs @@ -78,7 +78,7 @@ deleteWebhookDeliveryMethod notificationUser webhookDeliveryMethodId = do PG.runTransaction $ do NotifQ.deleteWebhookDeliveryMethod notificationUser webhookDeliveryMethodId -hydrateEvent :: HydratedEventPayload -> WebApp HydratedEvent +hydrateEvent :: HydratedEventPayload -> PG.Transaction e HydratedEvent hydrateEvent hydratedEventPayload = do hydratedEventLink <- Links.notificationLink hydratedEventPayload pure $ HydratedEvent {hydratedEventPayload, hydratedEventLink} diff --git a/src/Share/Notifications/Queries.hs b/src/Share/Notifications/Queries.hs index 727378bf..ead10478 100644 --- a/src/Share/Notifications/Queries.hs +++ b/src/Share/Notifications/Queries.hs @@ -70,8 +70,8 @@ listNotificationHubEntryPayloads notificationUserId mayLimit afterTime statusFil ORDER BY hub.created_at DESC LIMIT #{limit} |] - hydratedPayloads <- PG.pipelined $ forOf (traversed . traversed) dbNotifications hydrateEventData - hydrated & DisplayInfoQ.unifiedDisplayInfoForUserOf (traversed . hubEntryUserInfo_) + hydratedPayloads <- PG.pipelined $ forOf (traversed . traversed) dbNotifications hydrateEventPayload + hydratedPayloads & DisplayInfoQ.unifiedDisplayInfoForUserOf (traversed . hubEntryUserInfo_) updateNotificationHubEntries :: (QueryA m) => NESet NotificationHubEntryId -> NotificationStatus -> m () updateNotificationHubEntries hubEntryIds status = do diff --git a/src/Share/Notifications/Types.hs b/src/Share/Notifications/Types.hs index 54c084a5..7dd0d693 100644 --- a/src/Share/Notifications/Types.hs +++ b/src/Share/Notifications/Types.hs @@ -548,6 +548,16 @@ instance ToJSON HydratedEvent where "kind" .= kind ] +instance FromJSON HydratedEvent where + parseJSON = Aeson.withObject "HydratedEvent" \o -> do + kind <- o .: "kind" + hydratedEventLink <- o .: "link" + hydratedEventPayload <- case kind of + "projectBranchUpdated" -> HydratedProjectBranchUpdatedPayload <$> o .: "payload" + "projectContributionCreated" -> HydratedProjectContributionCreatedPayload <$> o .: "payload" + _ -> fail $ "Unknown event kind: " <> Text.unpack kind + pure HydratedEvent {hydratedEventPayload, hydratedEventLink} + data HydratedEventPayload = HydratedProjectBranchUpdatedPayload ProjectBranchUpdatedPayload | HydratedProjectContributionCreatedPayload ProjectContributionCreatedPayload diff --git a/src/Share/Web/UI/Links.hs b/src/Share/Web/UI/Links.hs index 7d2cb863..222f8228 100644 --- a/src/Share/Web/UI/Links.hs +++ b/src/Share/Web/UI/Links.hs @@ -93,7 +93,7 @@ homePage mayEvent = do LogOut -> Map.singleton "event" "log-out" -- E.g. https://share.unison-lang.org/@unison/base/code/@ceedubs/each-first/latest -projectBranchBrowseLink :: ProjectBranchShortHand -> AppM reqCtx URI +projectBranchBrowseLink :: (MonadReader (Env.Env ctx) m) => ProjectBranchShortHand -> m URI projectBranchBrowseLink (ProjectBranchShortHand {userHandle, projectSlug, contributorHandle, branchName}) = do let branchPath = case contributorHandle of Just contributor -> [IDs.toText contributor, IDs.toText branchName] @@ -102,13 +102,13 @@ projectBranchBrowseLink (ProjectBranchShortHand {userHandle, projectSlug, contri shareUIPath path -- E.g. https://share.unison-lang.org/@unison/base/contributions/100 -contributionLink :: ProjectShortHand -> ContributionNumber -> AppM reqCtx URI +contributionLink :: (MonadReader (Env.Env ctx) m) => ProjectShortHand -> ContributionNumber -> m URI contributionLink (ProjectShortHand {userHandle, projectSlug}) contributionNumber = do let path = [IDs.toText (PrefixedID @"@" userHandle), IDs.toText projectSlug, "contributions", IDs.toText contributionNumber] shareUIPath path -- | Where the user should go when clicking on a notification -notificationLink :: HydratedEventPayload -> AppM reqCtx URI +notificationLink :: (MonadReader (Env.Env ctx) m) => HydratedEventPayload -> m URI notificationLink = \case HydratedProjectBranchUpdatedPayload payload -> projectBranchBrowseLink payload.branchInfo.projectBranchShortHand @@ -123,19 +123,19 @@ unisonLogoImage = ----------- Utilities ----------- -- | Construct a full URI to a path within share, with provided query params. -sharePathQ :: [Text] -> Map Text Text -> AppM reqCtx URI +sharePathQ :: (MonadReader (Env.Env ctx) m) => [Text] -> Map Text Text -> m URI sharePathQ pathSegments queryParams = do uri <- asks Env.apiOrigin pure . setPathAndQueryParams pathSegments queryParams $ uri -- | Construct a full URI to a path within share. -sharePath :: [Text] -> AppM reqCtx URI +sharePath :: (MonadReader (Env.Env ctx) m) => [Text] -> m URI sharePath path = sharePathQ path mempty -- | Check if a URI is a the Share UI, the Cloud UI, the main website, or the -- Cloud website. This is useful for preventing attackers from generating -- arbitrary redirections in things like login redirects. -isTrustedURI :: URI -> AppM reqCtx Bool +isTrustedURI :: (MonadReader (Env.Env ctx) m) => URI -> m Bool isTrustedURI uri = do shareUiURI <- asks Env.shareUiOrigin websiteURI <- asks Env.websiteOrigin @@ -146,12 +146,12 @@ isTrustedURI uri = do pure $ any (\uri -> uriAuthority uri == requestedAuthority) trustedURIs -- | Construct a full URI to a path within the share UI, with the provided query params. -shareUIPathQ :: [Text] -> Map Text Text -> AppM reqCtx URI +shareUIPathQ :: (MonadReader (Env.Env ctx) m) => [Text] -> Map Text Text -> m URI shareUIPathQ pathSegments queryParams = do shareUiURI <- asks Env.shareUiOrigin pure . setPathAndQueryParams pathSegments queryParams $ shareUiURI -shareUIPath :: [Text] -> AppM reqCtx URI +shareUIPath :: (MonadReader (Env.Env ctx) m) => [Text] -> m URI shareUIPath pathSegments = shareUIPathQ pathSegments mempty -- | Various Error types that the Share UI knows how to interpret @@ -172,7 +172,7 @@ shareUIErrorToUIText e = AccountCreationInvalidHandle {} -> "AccountCreationInvalidHandle" -errorRedirectLink :: ShareUIError -> AppM reqCtx URI +errorRedirectLink :: (MonadReader (Env.Env ctx) m) => ShareUIError -> m URI errorRedirectLink shareUIError = shareUIPathQ ["error"] (Map.fromList [("appError", shareUIErrorToUIText shareUIError)]) -- | Redirect the user to the Share UI and show an error message. From ac91fcb4dc703540386e2a4028cffcaec602a4cf Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 27 May 2025 16:39:42 -0700 Subject: [PATCH 4/4] Hydrated links in hub entry notifications --- .../notifications/list-notifications-read-transcripts.json | 1 + .../notifications/list-notifications-transcripts.json | 2 ++ 2 files changed, 3 insertions(+) diff --git a/transcripts/share-apis/notifications/list-notifications-read-transcripts.json b/transcripts/share-apis/notifications/list-notifications-read-transcripts.json index 8db7049c..8ae88fd0 100644 --- a/transcripts/share-apis/notifications/list-notifications-read-transcripts.json +++ b/transcripts/share-apis/notifications/list-notifications-read-transcripts.json @@ -14,6 +14,7 @@ }, "data": { "kind": "projectBranchUpdated", + "link": "http://:1234/@test/publictestproject/code/newbranch/latest", "payload": { "branch": { "branchContributorHandle": null, diff --git a/transcripts/share-apis/notifications/list-notifications-transcripts.json b/transcripts/share-apis/notifications/list-notifications-transcripts.json index 67bf0d5f..4e41daac 100644 --- a/transcripts/share-apis/notifications/list-notifications-transcripts.json +++ b/transcripts/share-apis/notifications/list-notifications-transcripts.json @@ -14,6 +14,7 @@ }, "data": { "kind": "projectBranchUpdated", + "link": "http://:1234/@test/publictestproject/code/newbranch/latest", "payload": { "branch": { "branchContributorHandle": null, @@ -60,6 +61,7 @@ }, "data": { "kind": "projectContributionCreated", + "link": "http://:1234/@test/publictestproject/contributions/3", "payload": { "contribution": { "author": {