Merge pull request #81 from unisoncomputing/cp/hydrate-notification-links

Include links in notification hub entries

Author: ChrisPenner

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)
@@ -138,7 +139,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 +176,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 +207,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 +247,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.hydratedEventPayload 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 +273,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 +302,14 @@ 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
+  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/Env.hs

@@ -59,3 +59,4 @@ data Env ctx = Env
     maxParallelismPerDownloadRequest :: Int,
     maxParallelismPerUploadRequest :: Int
   }
+  deriving (Functor)

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"],

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

@@ -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 -> PG.Transaction e HydratedEvent
+hydrateEvent hydratedEventPayload = do
+  hydratedEventLink <- Links.notificationLink hydratedEventPayload
+  pure $ HydratedEvent {hydratedEventPayload, hydratedEventLink}

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,8 +70,8 @@ listNotificationHubEntries notificationUserId mayLimit afterTime statusFilter =
       ORDER BY hub.created_at DESC
       LIMIT #{limit}
     |]
-  hydrated <- 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
@@ -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

src/Share/Notifications/Types.hs

@@ -18,6 +18,7 @@ module Share.Notifications.Types
     NotificationEmailDeliveryConfig (..),
     NotificationWebhookConfig (..),
     HydratedEventPayload (..),
+    HydratedEvent (..),
     BranchPayload (..),
     ProjectPayload (..),
     ContributionPayload (..),
@@ -527,27 +528,42 @@ 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
+          ]
+
+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
   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