Hydrate events in transactions

Author: ChrisPenner

src/Share/BackgroundJobs/Webhooks/Worker.hs

@@ -34,6 +34,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)
@@ -308,7 +309,7 @@ buildWebhookRequest webhookId uri event defaultPayload = do
           actorAvatarUrl = event.eventActor ^. DisplayInfo.avatarUrl_
       actorLink <- Links.userProfilePage (event.eventActor ^. DisplayInfo.handle_)
       let mainLink = event.eventData.hydratedEventLink
-      messageContent :: MessageContent provider <- case event.eventData.payload of
+      messageContent :: 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."
@@ -369,7 +370,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

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

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 ()

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}

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

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

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.