Update slack messages

Author: ChrisPenner

src/Share/BackgroundJobs/Webhooks/Worker.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE StandaloneDeriving #-}
 
@@ -241,55 +242,59 @@ buildWebhookRequest webhookId uri event defaultPayload = do
               HTTPClient.requestBody = HTTPClient.RequestBodyLBS $ Aeson.encode defaultPayload
             }
 
-    mkSlackAttachment :: Maybe URI -> Text -> Text -> Text -> UTCTime -> Aeson.Value
-    mkSlackAttachment mainURI author title msg timestamp =
+    mkSlackAttachment :: Text -> URI -> Text -> URI -> Maybe URI -> Text -> Text -> UTCTime -> Aeson.Value
+    mkSlackAttachment preText mainURI authorName authorLink authorAvatarUrl title msg timestamp =
       let epochSeconds :: Int64
           epochSeconds = round (POSIX.utcTimeToPOSIXSeconds timestamp)
           t :: Text -> Text
           t x = x
        in Aeson.object $
             [ "mrkdwn_in" Aeson..= [t "text"],
               "color" .= t "#36a64f",
-              -- "pretext" .= "Optional pre-text that appears above the attachment block",
-              "author_name" .= author,
-              -- "author_link" .= "http://flickr.com/bobby/",
-              -- "author_icon" .= "https://placeimg.com/16/16/people",
+              "pretext" .= preText,
+              "author_name" .= authorName,
+              "author_link" .= uriToText authorLink,
               "title" .= title,
+              "title_link" .= uriToText mainURI,
               "text" .= msg,
-              -- "thumb_url" .= "http://placekitten.com/g/200/200",
+              "thumb_url" .= uriToText Links.unisonLogoImage,
               -- "footer" .= "footer",
               -- "footer_icon" .= "https://platform.slack-edge.com/img/default_application_icon.png",
               "ts" .= epochSeconds
             ]
-              <> (mainURI & foldMap \uri -> ["title_link" .= uriToText uri])
+              <> (authorAvatarUrl & foldMap \uri -> ["author_icon" .= uriToText uri])
     buildSlackWebhookRequest :: URI -> AppM reqCtx (Either WebhookSendFailure HTTPClient.Request)
     buildSlackWebhookRequest uri = do
       let actorName = event.eventActor ^. DisplayInfo.name_
-          actorHandle = "(" <> IDs.toText (event.eventActor ^. DisplayInfo.handle_) <> ")"
+          actorHandle = "(" <> IDs.toText (PrefixedID @"@" $ event.eventActor ^. DisplayInfo.handle_) <> ")"
           actorAuthor = maybe "" (<> " ") actorName <> actorHandle
+          actorAvatarUrl = event.eventActor ^. DisplayInfo.avatarUrl_
+      actorLink <- Links.userProfilePage (event.eventActor ^. DisplayInfo.handle_)
       slackPayload <- case event.eventData of
         HydratedProjectBranchUpdatedPayload payload -> do
           let pbShorthand = (projectBranchShortHandFromParts payload.projectInfo.projectShortHand payload.branchInfo.branchShortHand)
               title = "Branch " <> IDs.toText pbShorthand <> " was just updated."
-              msg = "Branch " <> IDs.toText pbShorthand <> " was just updated."
+              msg = ""
+              preText = title
           link <- Links.notificationLink event.eventData
           pure $
             Aeson.object
-              [ "text" Aeson..= msg,
+              [ "text" Aeson..= title,
                 "attachments"
-                  Aeson..= [ mkSlackAttachment (Just link) actorAuthor title msg event.eventOccurredAt
+                  Aeson..= [ mkSlackAttachment preText link actorAuthor actorLink actorAvatarUrl title msg event.eventOccurredAt
                            ]
               ]
         HydratedProjectContributionCreatedPayload payload -> do
           let pbShorthand = (projectBranchShortHandFromParts payload.projectInfo.projectShortHand payload.contributionInfo.contributionSourceBranch.branchShortHand)
-              title = "New Contribution in " <> IDs.toText pbShorthand
-              msg = payload.contributionInfo.contributionTitle <> maybe "" (<> " — ") payload.contributionInfo.contributionDescription
+              title = payload.contributionInfo.contributionTitle
+              msg = fromMaybe "" payload.contributionInfo.contributionDescription
+              preText = "New Contribution in " <> IDs.toText pbShorthand
           link <- Links.notificationLink event.eventData
           pure $
             Aeson.object
-              [ "text" Aeson..= msg,
+              [ "text" Aeson..= preText,
                 "attachments"
-                  Aeson..= [ mkSlackAttachment (Just link) actorAuthor title msg event.eventOccurredAt
+                  Aeson..= [ mkSlackAttachment preText link actorAuthor actorLink actorAvatarUrl title msg event.eventOccurredAt
                            ]
               ]
       pure $

src/Share/Web/Share/DisplayInfo/Types.hs

@@ -16,6 +16,7 @@ module Share.Web.Share.DisplayInfo.Types
     unifiedOrg_,
     handle_,
     name_,
+    avatarUrl_,
   )
 where
 
@@ -64,6 +65,13 @@ name_ f = \case
   UnifiedOrg orgDisplayInfo -> do
     UnifiedOrg <$> (orgDisplayInfo & field @"user" . field @"name" %%~ f)
 
+avatarUrl_ :: Lens UnifiedDisplayInfo UnifiedDisplayInfo (Maybe URI) (Maybe URI)
+avatarUrl_ f = \case
+  UnifiedUser userDisplayInfo -> do
+    UnifiedUser <$> (userDisplayInfo & field @"avatarUrl" %%~ f)
+  UnifiedOrg orgDisplayInfo -> do
+    UnifiedOrg <$> (orgDisplayInfo & field @"user" . field @"avatarUrl" %%~ f)
+
 type UnifiedDisplayInfo = UserLike UserDisplayInfo OrgDisplayInfo
 
 type UserLikeIds = UserLike UserId OrgId

src/Share/Web/UI/Links.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE DataKinds #-}
+
 module Share.Web.UI.Links
   ( oauthRedirect,
     oauthRedirectWithCodeAndState,
@@ -12,6 +14,9 @@ module Share.Web.UI.Links
     notificationLink,
     projectBranchBrowseLink,
     contributionLink,
+    unisonLogoImage,
+
+    -- * Utilities
     isTrustedURI,
     errorRedirectLink,
     errorRedirect,
@@ -24,6 +29,7 @@ where
 import Control.Monad.Reader
 import Data.Map qualified as Map
 import Network.URI
+import Network.URI qualified as URI
 import Servant (ToHttpApiData (..))
 import Share.App
 import Share.Env qualified as Env
@@ -92,13 +98,13 @@ projectBranchBrowseLink (ProjectBranchShortHand {userHandle, projectSlug, contri
   let branchPath = case contributorHandle of
         Just contributor -> [IDs.toText contributor, IDs.toText branchName]
         Nothing -> [IDs.toText branchName]
-      path = [IDs.toText userHandle, IDs.toText projectSlug, "code"] <> branchPath <> ["latest"]
+      path = [IDs.toText (PrefixedID @"@" userHandle), IDs.toText projectSlug, "code"] <> branchPath <> ["latest"]
   shareUIPath path
 
 -- E.g. https://share.unison-lang.org/@unison/base/contributions/100
 contributionLink :: ProjectShortHand -> ContributionNumber -> AppM reqCtx URI
 contributionLink (ProjectShortHand {userHandle, projectSlug}) contributionNumber = do
-  let path = [IDs.toText userHandle, IDs.toText projectSlug, "contributions", IDs.toText contributionNumber]
+  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
@@ -109,6 +115,11 @@ notificationLink = \case
   HydratedProjectContributionCreatedPayload payload ->
     contributionLink payload.projectInfo.projectShortHand payload.contributionInfo.contributionNumber
 
+unisonLogoImage :: URI
+unisonLogoImage =
+  URI.parseURI "https://share.unison-lang.org/static/unison-logo-circle.png"
+    & fromMaybe (error "unisonLogoImage: invalid URI")
+
 ----------- Utilities -----------
 
 -- | Construct a full URI to a path within share, with provided query params.