Merge pull request #82 from unisoncomputing/cp/chat-app-msg

Swap to use Slack instead of Zendesk for user support tickets

Author: ChrisPenner

app/Env.hs

@@ -25,7 +25,6 @@ import Share.Web.Authentication (cookieSessionTTL)
 import Hasql.Pool qualified as Pool
 import Hasql.Pool.Config qualified as Pool
 import Network.URI (parseURI)
-import Servant.API qualified as Servant
 import Servant.Client qualified as ServantClient
 import System.Environment (lookupEnv)
 import System.Exit
@@ -57,9 +56,6 @@ withEnv action = do
   githubClientSecret <- fromEnv "SHARE_GITHUB_CLIENT_SECRET" (pure . Right . Text.pack)
   hs256Key <- fromEnv "SHARE_HMAC_KEY" (pure . Right . BS.pack)
   edDSAKey <- fromEnv "SHARE_EDDSA_KEY" (pure . Right . BS.pack)
-  zendeskAPIUser <- fromEnv "SHARE_ZENDESK_API_USER" (pure . Right . BS.pack)
-  zendeskAPIToken <- fromEnv "SHARE_ZENDESK_API_TOKEN" (pure . Right . BS.pack)
-  let zendeskAuth = Servant.BasicAuthData zendeskAPIUser zendeskAPIToken
   commitHash <- fromEnv "SHARE_COMMIT" (pure . Right . Text.pack)
   minLogSeverity <-
     lookupEnv "SHARE_LOG_LEVEL" >>= \case
@@ -72,6 +68,7 @@ withEnv action = do
   shareUiOrigin <- fromEnv "SHARE_SHARE_UI_ORIGIN" (pure . maybeToEither "Invalid SHARE_SHARE_UI_ORIGIN" . parseURI)
   websiteOrigin <- fromEnv "SHARE_HOMEPAGE_ORIGIN" (pure . maybeToEither "Invalid SHARE_HOMEPAGE_ORIGIN" . parseURI)
   cloudUiOrigin <- fromEnv "SHARE_CLOUD_UI_ORIGIN" (pure . maybeToEither "Invalid SHARE_CLOUD_UI_ORIGIN" . parseURI)
+  supportTicketWebhookURI <- maybeEnv "SHARE_SUPPORT_TICKET_WEBHOOK_URI" (pure . maybeToEither "Invalid SHARE_SUPPORT_TICKET_WEBHOOK_URI" . parseURI)
   maxParallelismPerDownloadRequest <- fromEnv "SHARE_MAX_PARALLELISM_PER_DOWNLOAD_REQUEST" (pure . maybeToEither "Invalid SHARE_MAX_PARALLELISM_PER_DOWNLOAD_REQUEST" . readMaybe)
   maxParallelismPerUploadRequest <- fromEnv "SHARE_MAX_PARALLELISM_PER_UPLOAD_REQUEST" (pure . maybeToEither "Invalid SHARE_MAX_PARALLELISM_PER_UPLOAD_REQUEST" . readMaybe)
   cloudWebsiteOrigin <- fromEnv "SHARE_CLOUD_HOMEPAGE_ORIGIN" (pure . maybeToEither "Invalid SHARE_CLOUD_HOMEPAGE_ORIGIN" . parseURI)
@@ -162,6 +159,16 @@ withEnv action = do
       u <- ServantClient.parseBaseUrl str
       pure $ Right u
 
+-- | Parse an environment variable, but only if it exists.
+maybeEnv :: String -> (String -> IO (Either String a)) -> IO (Maybe a)
+maybeEnv var parser = do
+  val <- lookupEnv var
+  case val of
+    Nothing -> pure Nothing
+    Just val' -> parser val' >>= \case
+      Right a -> pure (Just a)
+      Left err -> putStrLn ("Error with " <> var <> ": " <> err) >> exitWith (ExitFailure 1)
+
 fromEnv :: String -> (String -> IO (Either String a)) -> IO a
 fromEnv var from = do
   val <- lookupEnv var

docker/docker-compose.yml

@@ -93,8 +93,6 @@ services:
       - VAULT_HOST=http://vault:8200/v1
       - VAULT_TOKEN=sekrit
       - USER_SECRETS_VAULT_MOUNT=secret # A default mount in dev vault
-      - SHARE_ZENDESK_API_USER=invaliduser@example.com
-      - SHARE_ZENDESK_API_TOKEN=bad-password
       - SHARE_GITHUB_CLIENTID=invalid
       - SHARE_GITHUB_CLIENT_SECRET=invalid
 

package.yaml

@@ -174,6 +174,7 @@ default-extensions:
   - QuasiQuotes
   - ImportQualifiedPost
   - OverloadedRecordDot
+  - NumericUnderscores
 
 library:
   source-dirs: src

share-api.cabal

@@ -41,6 +41,7 @@ library
       Share.BackgroundJobs.Webhooks.Worker
       Share.BackgroundJobs.Workers
       Share.Branch
+      Share.ChatApps
       Share.Codebase
       Share.Codebase.Types
       Share.Contribution
@@ -173,7 +174,6 @@ library
       Share.Web.Support.API
       Share.Web.Support.Impl
       Share.Web.Support.Types
-      Share.Web.Support.Zendesk
       Share.Web.Types
       Share.Web.UCM.Projects.Impl
       Share.Web.UCM.Sync.HashJWT
@@ -225,6 +225,7 @@ library
       QuasiQuotes
       ImportQualifiedPost
       OverloadedRecordDot
+      NumericUnderscores
   ghc-options: -Wall -Werror -Wname-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -Wincomplete-uni-patterns -Widentities -Wredundant-constraints -Wpartial-fields -fprint-expanded-synonyms -fwrite-ide-info -O2 -funbox-strict-fields
   build-depends:
       Diff
@@ -375,6 +376,7 @@ executable share-api
       QuasiQuotes
       ImportQualifiedPost
       OverloadedRecordDot
+      NumericUnderscores
   ghc-options: -Wall -Werror -Wname-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -Wincomplete-uni-patterns -Widentities -Wredundant-constraints -Wpartial-fields -fprint-expanded-synonyms -fwrite-ide-info -O2 -funbox-strict-fields -threaded -rtsopts "-with-rtsopts=-N -A32m -qn2 -T"
   build-depends:
       Diff

src/Share/BackgroundJobs/Webhooks/Worker.hs

@@ -11,14 +11,11 @@ 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
@@ -28,6 +25,8 @@ 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.ChatApps (Author (..))
+import Share.ChatApps qualified as ChatApps
 import Share.Env qualified as Env
 import Share.IDs
 import Share.IDs qualified as IDs
@@ -42,7 +41,7 @@ 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 (..), uriToText)
+import Share.Utils.URI (URIParam (..))
 import Share.Web.Authorization qualified as AuthZ
 import Share.Web.Share.DisplayInfo.Queries qualified as DisplayInfoQ
 import Share.Web.Share.DisplayInfo.Types (UnifiedDisplayInfo)
@@ -207,72 +206,12 @@ tryWebhook event webhookId = UnliftIO.handleAny (\someException -> pure $ Just $
         | 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
+    | isSlackWebhook uri -> buildChatAppPayload (Proxy @ChatApps.Slack) uri
+    | isDiscordWebhook uri -> buildChatAppPayload (Proxy @ChatApps.Discord) uri
+    | otherwise -> pure $ buildDefaultPayload
   where
     isSlackWebhook :: URI -> Bool
     isSlackWebhook uri =
@@ -300,28 +239,31 @@ buildWebhookRequest webhookId uri event defaultPayload = do
               HTTPClient.requestBody = HTTPClient.RequestBodyLBS $ Aeson.encode defaultPayload
             }
 
-    buildChatAppPayload :: forall provider. (ToJSON (MessageContent provider)) => Proxy provider -> URI -> Background (Either WebhookSendFailure HTTPClient.Request)
+    buildChatAppPayload :: forall provider. (ToJSON (ChatApps.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
+      messageContent :: ChatApps.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
+            ChatApps.MessageContent
               { preText = preText,
                 content = "Branch updated",
                 title = title,
-                mainLink = link,
-                authorName = actorAuthor,
-                authorLink = actorLink,
-                authorAvatarUrl = actorAvatarUrl,
+                mainLink = Just link,
+                author =
+                  Author
+                    { authorName = Just actorAuthor,
+                      authorLink = Just actorLink,
+                      authorAvatarUrl = actorAvatarUrl
+                    },
                 thumbnailUrl = Nothing,
                 timestamp = event.eventOccurredAt
               }
@@ -332,14 +274,17 @@ buildWebhookRequest webhookId uri event defaultPayload = do
               preText = "New Contribution in " <> IDs.toText pbShorthand
           link <- Links.notificationLink event.eventData
           pure $
-            MessageContent
+            ChatApps.MessageContent
               { preText = preText,
                 content = description,
                 title = title,
-                mainLink = link,
-                authorName = actorAuthor,
-                authorLink = actorLink,
-                authorAvatarUrl = actorAvatarUrl,
+                mainLink = Just link,
+                author =
+                  Author
+                    { authorName = Just actorAuthor,
+                      authorLink = Just actorLink,
+                      authorAvatarUrl = actorAvatarUrl
+                    },
                 thumbnailUrl = Nothing,
                 timestamp = event.eventOccurredAt
               }
@@ -355,13 +300,6 @@ buildWebhookRequest webhookId uri event defaultPayload = do
                     }
               )
 
--- | 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)) ->