Merge pull request #72 from unisoncomputing/cp/slack-webhooks

Slack/Discord webhook support

Author: ChrisPenner

share-api.cabal

@@ -183,6 +183,7 @@ library
       Share.Web.UCM.SyncV2.Impl
       Share.Web.UCM.SyncV2.Queries
       Share.Web.UCM.SyncV2.Types
+      Share.Web.UI.Links
       Unison.Server.NameSearch.Postgres
       Unison.Server.Share.Definitions
       Unison.Server.Share.DefinitionSummary

sql/2025-05-16_webhook-name.sql

@@ -0,0 +1,12 @@
+-- Add a name to the webhooks table
+ALTER TABLE notification_webhooks
+  ADD COLUMN name TEXT NULL CONSTRAINT notification_webhooks_name_not_empty CHECK (name <> ''::text)
+;
+
+UPDATE notification_webhooks
+  SET name = 'Webhook'
+  WHERE name IS NULL;
+
+ALTER TABLE notification_webhooks
+  ALTER COLUMN name SET NOT NULL
+;

src/Share/BackgroundJobs/Webhooks/Worker.hs

@@ -1,41 +1,53 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE StandaloneDeriving #-}
 
 -- | This module provides the background worker for sending notification webhooks.
 module Share.BackgroundJobs.Webhooks.Worker (worker) where
 
-import Control.Lens
-import Control.Monad.Except (runExceptT)
+import Control.Lens hiding ((.=))
+import Control.Monad.Except (ExceptT (..), runExceptT)
 import Crypto.JWT (JWTError)
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import Data.Aeson qualified as Aeson
+import Data.Aeson.Types ((.=))
 import Data.ByteString.Lazy.Char8 qualified as BL
+import Data.List.Extra qualified as List
 import Data.Text qualified as Text
 import Data.Text.Encoding qualified as Text
 import Data.Time (UTCTime)
+import Data.Time qualified as Time
+import Data.Time.Clock.POSIX qualified as POSIX
 import Ki.Unlifted qualified as Ki
 import Network.HTTP.Client qualified as HTTPClient
 import Network.HTTP.Types qualified as HTTP
+import Network.URI (URI)
+import Network.URI qualified as URI
 import Share.BackgroundJobs.Errors (reportError)
 import Share.BackgroundJobs.Monad (Background)
 import Share.BackgroundJobs.Webhooks.Queries qualified as WQ
 import Share.BackgroundJobs.Workers (newWorker)
 import Share.Env qualified as Env
-import Share.IDs (NotificationEventId, NotificationWebhookId)
+import Share.IDs
+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.Queries qualified as NQ
-import Share.Notifications.Types (HydratedEventPayload, NotificationEvent (..), NotificationTopic, eventData_, eventUserInfo_, hydratedEventTopic)
+import Share.Notifications.Types
 import Share.Notifications.Webhooks.Secrets (WebhookConfig (..), WebhookSecretError)
 import Share.Notifications.Webhooks.Secrets qualified as Webhooks
 import Share.Postgres qualified as PG
 import Share.Postgres.Notifications qualified as Notif
 import Share.Prelude
 import Share.Utils.Logging qualified as Logging
-import Share.Utils.URI (URIParam (..))
+import Share.Utils.URI (URIParam (..), uriToText)
 import Share.Web.Authorization qualified as AuthZ
 import Share.Web.Share.DisplayInfo.Queries qualified as DisplayInfoQ
 import Share.Web.Share.DisplayInfo.Types (UnifiedDisplayInfo)
+import Share.Web.Share.DisplayInfo.Types qualified as DisplayInfo
+import Share.Web.UI.Links qualified as Links
 import UnliftIO qualified
 
 data WebhookSendFailure
@@ -188,23 +200,168 @@ tryWebhook event webhookId = UnliftIO.handleAny (\someException -> pure $ Just $
         Left jwtErr -> throwError $ JWTError event.eventId webhookId jwtErr
         Right jwt -> pure jwt
     let payloadWithJWT = payload {jwt = JWTParam payloadJWT}
-    let reqResult =
-          HTTPClient.requestFromURI uri <&> \req ->
-            req
-              { HTTPClient.method = "POST",
-                HTTPClient.responseTimeout = webhookTimeout,
-                HTTPClient.requestHeaders = [(HTTP.hContentType, "application/json")],
-                HTTPClient.requestBody = HTTPClient.RequestBodyLBS $ Aeson.encode $ payloadWithJWT
-              }
-    req <- case reqResult of
-      Left parseErr -> throwError $ InvalidRequest event.eventId webhookId parseErr
-      Right req -> pure req
+    req <- ExceptT $ buildWebhookRequest webhookId uri event payloadWithJWT
     resp <- liftIO $ HTTPClient.httpLbs req proxiedHTTPManager
     case HTTPClient.responseStatus resp of
       httpStatus@(HTTP.Status status _)
         | status >= 400 -> throwError $ ReceiverError event.eventId webhookId httpStatus $ HTTPClient.responseBody resp
         | otherwise -> pure ()
 
+data ChatProvider
+  = Slack
+  | Discord
+  deriving stock (Show, Eq)
+
+-- A type to unify slack and discord message types
+data MessageContent (provider :: ChatProvider) = MessageContent
+  { -- Text of the bot message
+    preText :: Text,
+    -- Title of the attachment
+    title :: Text,
+    -- Text of the attachment
+    content :: Text,
+    -- Title link
+    mainLink :: URI,
+    authorName :: Text,
+    authorLink :: URI,
+    authorAvatarUrl :: Maybe URI,
+    thumbnailUrl :: Maybe URI,
+    timestamp :: UTCTime
+  }
+  deriving stock (Show, Eq)
+
+instance ToJSON (MessageContent 'Slack) where
+  toJSON MessageContent {preText, content, title, mainLink, authorName, authorLink, authorAvatarUrl, thumbnailUrl, timestamp} =
+    Aeson.object
+      [ "text" .= preText,
+        "attachments"
+          .= [ Aeson.object
+                 [ "title" .= cutOffText 250 title,
+                   "title_link" .= uriToText mainLink,
+                   "text" .= content,
+                   "author_name" .= authorName,
+                   "author_link" .= uriToText authorLink,
+                   "author_icon" .= fmap uriToText authorAvatarUrl,
+                   "thumb_url" .= fmap uriToText thumbnailUrl,
+                   "ts" .= (round (POSIX.utcTimeToPOSIXSeconds timestamp) :: Int64),
+                   "color" .= ("#36a64f" :: Text)
+                 ]
+             ]
+      ]
+
+instance ToJSON (MessageContent 'Discord) where
+  toJSON MessageContent {preText, content, title, mainLink, authorName, authorLink, authorAvatarUrl, thumbnailUrl, timestamp} =
+    Aeson.object
+      [ "username" .= ("Share Notifications" :: Text),
+        "avatar_url" .= Links.unisonLogoImage,
+        "content" .= cutOffText 1950 preText,
+        "embeds"
+          .= [ Aeson.object
+                 [ "title" .= cutOffText 250 title,
+                   "url" .= uriToText mainLink,
+                   "description" .= cutOffText 4000 content,
+                   "author" .= Aeson.object ["name" .= cutOffText 250 authorName, "url" .= uriToText authorLink, "icon_url" .= fmap uriToText authorAvatarUrl],
+                   "timestamp" .= (Just $ Text.pack $ Time.formatTime Time.defaultTimeLocale "%FT%T%QZ" timestamp),
+                   "thumbnail" .= fmap (\url -> Aeson.object ["url" .= uriToText url]) thumbnailUrl
+                 ]
+             ]
+      ]
+
+buildWebhookRequest :: NotificationWebhookId -> URI -> NotificationEvent NotificationEventId UnifiedDisplayInfo UTCTime HydratedEventPayload -> WebhookEventPayload JWTParam -> Background (Either WebhookSendFailure HTTPClient.Request)
+buildWebhookRequest webhookId uri event defaultPayload = do
+  if
+    | isSlackWebhook uri -> buildChatAppPayload (Proxy @Slack) uri
+    | isDiscordWebhook uri -> buildChatAppPayload (Proxy @Discord) uri
+    | otherwise -> pure $ buildDefaultPayload
+  where
+    isSlackWebhook :: URI -> Bool
+    isSlackWebhook uri =
+      case URI.uriRegName <$> URI.uriAuthority uri of
+        Nothing -> False
+        Just regName -> List.isPrefixOf "hooks.slack.com" regName
+
+    isDiscordWebhook :: URI -> Bool
+    isDiscordWebhook uri =
+      case (URI.uriRegName <$> URI.uriAuthority uri) of
+        Just regName ->
+          Text.isPrefixOf "discord.com" (Text.pack regName)
+            && Text.isPrefixOf "/api/webhooks" (Text.pack $ URI.uriPath uri)
+        _ -> False
+
+    buildDefaultPayload :: Either WebhookSendFailure HTTPClient.Request
+    buildDefaultPayload =
+      HTTPClient.requestFromURI uri
+        & mapLeft (\e -> InvalidRequest event.eventId webhookId e)
+        <&> \req ->
+          req
+            { HTTPClient.method = "POST",
+              HTTPClient.responseTimeout = webhookTimeout,
+              HTTPClient.requestHeaders = [(HTTP.hContentType, "application/json")],
+              HTTPClient.requestBody = HTTPClient.RequestBodyLBS $ Aeson.encode defaultPayload
+            }
+
+    buildChatAppPayload :: forall provider. (ToJSON (MessageContent provider)) => Proxy provider -> URI -> Background (Either WebhookSendFailure HTTPClient.Request)
+    buildChatAppPayload _ uri = do
+      let actorName = event.eventActor ^. DisplayInfo.name_
+          actorHandle = "(" <> IDs.toText (PrefixedID @"@" $ event.eventActor ^. DisplayInfo.handle_) <> ")"
+          actorAuthor = maybe "" (<> " ") actorName <> actorHandle
+          actorAvatarUrl = event.eventActor ^. DisplayInfo.avatarUrl_
+      actorLink <- Links.userProfilePage (event.eventActor ^. DisplayInfo.handle_)
+      messageContent :: MessageContent provider <- case event.eventData 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 $
+            MessageContent
+              { preText = preText,
+                content = "Branch updated",
+                title = title,
+                mainLink = link,
+                authorName = actorAuthor,
+                authorLink = actorLink,
+                authorAvatarUrl = actorAvatarUrl,
+                thumbnailUrl = Nothing,
+                timestamp = event.eventOccurredAt
+              }
+        HydratedProjectContributionCreatedPayload payload -> do
+          let pbShorthand = (projectBranchShortHandFromParts payload.projectInfo.projectShortHand payload.contributionInfo.contributionSourceBranch.branchShortHand)
+              title = payload.contributionInfo.contributionTitle
+              description = fromMaybe "" $ payload.contributionInfo.contributionDescription
+              preText = "New Contribution in " <> IDs.toText pbShorthand
+          link <- Links.notificationLink event.eventData
+          pure $
+            MessageContent
+              { preText = preText,
+                content = description,
+                title = title,
+                mainLink = link,
+                authorName = actorAuthor,
+                authorLink = actorLink,
+                authorAvatarUrl = actorAvatarUrl,
+                thumbnailUrl = Nothing,
+                timestamp = event.eventOccurredAt
+              }
+      pure $
+        HTTPClient.requestFromURI uri
+          & mapLeft (\e -> InvalidRequest event.eventId webhookId e)
+          <&> ( \req ->
+                  req
+                    { HTTPClient.method = "POST",
+                      HTTPClient.responseTimeout = webhookTimeout,
+                      HTTPClient.requestHeaders = [(HTTP.hContentType, "application/json")],
+                      HTTPClient.requestBody = HTTPClient.RequestBodyLBS $ Aeson.encode messageContent
+                    }
+              )
+
+-- | Nicely cut off text so that it doesn't exceed the max length
+cutOffText :: Int -> Text -> Text
+cutOffText maxLength text =
+  if Text.length text > maxLength
+    then Text.take (maxLength - 3) text <> "..."
+    else text
+
 attemptWebhookSend ::
   AuthZ.AuthZReceipt ->
   (NotificationEvent NotificationEventId UnifiedDisplayInfo UTCTime HydratedEventPayload -> NotificationWebhookId -> IO (Maybe WebhookSendFailure)) ->

src/Share/Github.hs

@@ -22,6 +22,7 @@ import Share.Utils.Show
 import Share.Utils.URI (URIParam (URIParam))
 import Share.Web.App
 import Share.Web.Errors
+import Share.Web.UI.Links qualified as Links
 
 data GithubError
   = GithubClientError ClientError
@@ -210,7 +211,7 @@ githubOauthApi = Proxy
 githubAuthenticationURI :: OAuth2State -> WebApp URI
 githubAuthenticationURI oauth2State = do
   oauthClientId <- asks Env.githubClientID
-  redirectUri <- sharePath ["oauth", "redirect"]
+  redirectUri <- Links.oauthRedirect
   let ghAuth = Just (URIAuth "" "github.com" "")
       ghLink = linkURI (uri oauthClientId redirectUri)
    in return $

src/Share/IDs.hs

@@ -46,6 +46,7 @@ module Share.IDs
     NotificationSubscriptionId (..),
     Email (..),
     projectBranchShortHandToBranchShortHand,
+    projectBranchShortHandFromParts,
     JTI (..),
     CategoryName (..),
     CategoryID (..),
@@ -473,6 +474,10 @@ projectBranchShortHandToBranchShortHand :: ProjectBranchShortHand -> BranchShort
 projectBranchShortHandToBranchShortHand ProjectBranchShortHand {contributorHandle, branchName} =
   BranchShortHand {contributorHandle, branchName}
 
+projectBranchShortHandFromParts :: ProjectShortHand -> BranchShortHand -> ProjectBranchShortHand
+projectBranchShortHandFromParts ProjectShortHand {userHandle, projectSlug} BranchShortHand {contributorHandle, branchName} =
+  ProjectBranchShortHand {userHandle, projectSlug, contributorHandle, branchName}
+
 -- | A fully specified branch identifier of the form '@user/project/@contributor/branch' or
 --
 -- With contributor

src/Share/Notifications/API.hs

@@ -289,13 +289,15 @@ type CreateWebhookEndpoint =
 
 data CreateWebhookRequest
   = CreateWebhookRequest
-  { url :: URIParam
+  { url :: URIParam,
+    name :: Text
   }
 
 instance FromJSON CreateWebhookRequest where
   parseJSON = withObject "CreateWebhookRequest" $ \o -> do
     url <- o .: "url"
-    pure CreateWebhookRequest {url}
+    name <- o .: "name"
+    pure CreateWebhookRequest {url, name}
 
 data CreateWebhookResponse
   = CreateWebhookResponse

src/Share/Notifications/Impl.hs

@@ -140,10 +140,10 @@ removeSubscriptionDeliveryMethodsEndpoint userHandle subscriptionId callerUserId
   pure ()
 
 createWebhookEndpoint :: UserHandle -> UserId -> API.CreateWebhookRequest -> WebApp API.CreateWebhookResponse
-createWebhookEndpoint userHandle callerUserId API.CreateWebhookRequest {url} = do
+createWebhookEndpoint userHandle callerUserId API.CreateWebhookRequest {url, name = webhookName} = do
   User {user_id = notificationUserId} <- UserQ.expectUserByHandle userHandle
   _authZReceipt <- AuthZ.permissionGuard $ AuthZ.checkDeliveryMethodsManage callerUserId notificationUserId
-  webhookId <- NotifOps.createWebhookDeliveryMethod notificationUserId url
+  webhookId <- NotifOps.createWebhookDeliveryMethod notificationUserId url webhookName
   pure $ API.CreateWebhookResponse {webhookId}
 
 deleteWebhookEndpoint :: UserHandle -> UserId -> NotificationWebhookId -> WebApp ()

src/Share/Notifications/Ops.hs

@@ -31,11 +31,11 @@ listNotificationDeliveryMethods userId maySubscriptionId = do
 
   pure $ (EmailDeliveryMethod <$> emailDeliveryMethods) <> (WebhookDeliveryMethod <$> webhookDeliveryMethods)
 
-createWebhookDeliveryMethod :: UserId -> URIParam -> WebApp NotificationWebhookId
-createWebhookDeliveryMethod userId uriParam = do
+createWebhookDeliveryMethod :: UserId -> URIParam -> Text -> WebApp NotificationWebhookId
+createWebhookDeliveryMethod userId uriParam webhookName = do
   -- Note that we can't be completely transactional between postgres and vault here.
   webhookId <- PG.runTransaction do
-    NotifQ.createWebhookDeliveryMethod userId
+    NotifQ.createWebhookDeliveryMethod userId webhookName
   let webhookConfig = WebhookConfig {uri = uriParam}
   WebhookSecrets.putWebhookConfig webhookId webhookConfig
   pure webhookId