[DUX-3058]: implement support for App Home tab

CHANGELOG.md

@@ -1,3 +1,7 @@
+# 2.1.0.0 (2025-03-06)
+* [#138](https://github.com/MercuryTechnologies/slack-web/pull/138)
+  Implement `views.publish` method and App Home tab events.
+
 # 2.0.1.0 (2025-01-09)
 * [#136](https://github.com/MercuryTechnologies/slack-web/pull/136)
   Bumps the version ranges for dependencies to be compatible with LTS 22.43.

slack-web.cabal

@@ -1,6 +1,6 @@
 cabal-version: 3.0
 name: slack-web
-version: 2.0.1.0
+version: 2.1.0.0
 
 build-type: Simple
 
@@ -29,6 +29,10 @@ extra-source-files:
   tests/golden/BlockKitBuilderMessage/*.golden.json
   tests/golden/FileObject/*.json
   tests/golden/FileObject/*.golden
+  tests/golden/SlackView/*.json
+  tests/golden/SlackView/*.golden
+  tests/golden/PublishResp/*.json
+  tests/golden/PublishResp/*.golden
 
 category: Web
 
@@ -69,7 +73,6 @@ common build-opts
 
   default-extensions:
     AllowAmbiguousTypes
-    ApplicativeDo
     BlockArguments
     DataKinds
     DeriveAnyClass
@@ -97,6 +100,7 @@ common build-opts
     RankNTypes
     RecordWildCards
     RecursiveDo
+    RoleAnnotations
     ScopedTypeVariables
     StandaloneDeriving
     StandaloneKindSignatures
@@ -127,6 +131,7 @@ library
       Web.Slack.Experimental.Blocks
       Web.Slack.Experimental.Blocks.Types
       Web.Slack.Experimental.Events.Types
+      Web.Slack.Experimental.Views
       Web.Slack.Experimental.RequestVerification
   other-modules:
       Web.Slack.Util
@@ -188,6 +193,7 @@ test-suite tests
       Web.Slack.Experimental.Events.TypesSpec
       Web.Slack.Experimental.BlocksSpec
       Web.Slack.Experimental.Blocks.TypesSpec
+      Web.Slack.Experimental.ViewsSpec
       TestImport
       TestImport.Aeson
   build-tool-depends:

src/Web/Slack/AesonUtils.hs

@@ -2,10 +2,12 @@ module Web.Slack.AesonUtils where
 
 import Data.Aeson
 import Data.Aeson qualified as J
-import Data.Aeson.Types (Pair)
+import Data.Aeson.Types (Pair, parseFail)
 import Data.Char qualified as Char
+import Data.List (dropWhileEnd)
 import Data.Text qualified as T
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
 import Web.FormUrlEncoded qualified as F
 import Web.Slack.Prelude
 
@@ -108,6 +110,15 @@ snakeCaseOptions =
     , constructorTagModifier = camelTo2 '_'
     }
 
+-- | 'snakeCaseOptions' that eats trailing underscores. This is so that you can
+-- have a field called "type_".
+snakeCaseOptionsEatTrailingUnderscore :: Options
+snakeCaseOptionsEatTrailingUnderscore =
+  defaultOptions
+    { fieldLabelModifier = camelTo2 '_' . dropWhileEnd (== '_')
+    , constructorTagModifier = camelTo2 '_'
+    }
+
 snakeCaseFormOptions :: F.FormOptions
 snakeCaseFormOptions =
   F.defaultFormOptions
@@ -122,3 +133,23 @@ instance FromJSON UnixTimestamp where
 
 instance ToJSON UnixTimestamp where
   toJSON (UnixTimestamp a) = toJSON (utcTimeToPOSIXSeconds a)
+
+-- | Expected a given value as a string. Useful for @type@ fields in json.
+data Expected (lit :: Symbol) = Expected
+
+type role Expected phantom
+
+instance (KnownSymbol lit) => Eq (Expected lit) where
+  -- If the types match the values are always equal
+  _ == _ = True
+
+instance (KnownSymbol lit) => FromJSON (Expected lit) where
+  parseJSON = withText "Expected" \s -> do
+    unless (s == T.pack (symbolVal (Proxy @lit))) $ parseFail ("should be " <> symbolVal (Proxy @lit))
+    pure Expected
+
+instance (KnownSymbol lit) => ToJSON (Expected lit) where
+  toJSON _ = String . T.pack $ symbolVal (Proxy @lit)
+
+instance (KnownSymbol lit) => Show (Expected lit) where
+  show _ = show $ symbolVal (Proxy @lit)

src/Web/Slack/Experimental/Blocks/Types.hs

@@ -111,6 +111,8 @@ instance Slack Int where
 newtype OptionalSetting a = OptionalSetting {unOptionalSetting :: Maybe a}
   deriving newtype (Eq)
 
+type role OptionalSetting representational
+
 -- | Allows using bare Strings without having to use 'setting'
 instance IsString (OptionalSetting String) where
   fromString = OptionalSetting . Just
@@ -402,6 +404,7 @@ data SlackBlock
   | SlackBlockRichText RichText
   | SlackBlockActions (Maybe SlackBlockId) SlackActionList -- 1 to 5 elements
   | SlackBlockHeader SlackPlainTextOnly -- max length 150
+  | SlackBlockOther Object
   deriving stock (Eq)
 
 instance Show SlackBlock where
@@ -420,6 +423,7 @@ instance Show SlackBlock where
         ]
   show (SlackBlockRichText rt) = show rt
   show (SlackBlockHeader p) = show p
+  show (SlackBlockOther o) = "SlackBlockOther " <> show o
 
 instance ToJSON SlackBlock where
   toJSON (SlackBlockSection SlackSection {..}) =
@@ -454,6 +458,7 @@ instance ToJSON SlackBlock where
       [ "type" .= ("header" :: Text)
       , "text" .= slackPlainText
       ]
+  toJSON (SlackBlockOther o) = Object o
 
 instance FromJSON SlackBlock where
   parseJSON = withObject "SlackBlock" $ \obj -> do
@@ -500,7 +505,7 @@ instance FromJSON SlackBlock where
         (headerContentObj :: Value) <- obj .: "text"
         headerContentText <- parseJSON headerContentObj
         pure $ SlackBlockHeader headerContentText
-      _ -> fail "Unknown SlackBlock type, must be one of ['section', 'context', 'image', 'divider', 'actions', 'rich_text', 'header']"
+      _unk -> pure $ SlackBlockOther obj
 
 newtype SlackMessage = SlackMessage [SlackBlock]
   deriving newtype (Semigroup, Monoid, Eq)

src/Web/Slack/Experimental/Events/Types.hs

@@ -273,6 +273,42 @@ newtype MessageId = MessageId {unMessageId :: Text}
   deriving newtype (FromJSON)
   deriving stock (Show, Eq)
 
+-- | Which tab of App Home is open.
+--
+-- @since 2.1.0.0
+newtype AppHomeTab = AppHomeTab {unAppHomeTab :: Text}
+  deriving stock (Show, Eq)
+  deriving newtype (FromJSON, ToJSON)
+
+-- | Home tab of App Home.
+--
+-- @since 2.1.0.0
+appHomeTabHome :: AppHomeTab
+appHomeTabHome = AppHomeTab "home"
+
+-- | Messages tab of App Home.
+--
+-- @since 2.1.0.0
+appHomeTabMessages :: AppHomeTab
+appHomeTabMessages = AppHomeTab "messages"
+
+-- | App Home Opened event: when a Slack bot's home page is opened.
+--
+-- <https://api.slack.com/events/app_home_opened>
+--
+-- See also: <https://api.slack.com/reference/app-home>
+--
+-- @since 2.1.0.0
+data AppHomeOpenedEvent = AppHomeOpenedEvent
+  { user :: UserId
+  , channel :: ConversationId
+  , tab :: AppHomeTab
+  , eventTs :: Text
+  }
+  deriving stock (Show)
+
+$(deriveFromJSON snakeCaseOptions ''AppHomeOpenedEvent)
+
 data Event
   = EventMessage MessageEvent
   | EventBotMessage BotMessageEvent
@@ -285,6 +321,8 @@ data Event
     EventChannelJoinMessage
   | EventChannelCreated ChannelCreatedEvent
   | EventChannelLeft ChannelLeftEvent
+  | -- | @since 2.1.0.0
+    EventAppHomeOpened AppHomeOpenedEvent
   | EventUnknown Value
   deriving stock (Show, Generic)
 
@@ -302,6 +340,7 @@ instance FromJSON Event where
       ("message", Just "file_share") -> EventMessage <$> parseJSON @MessageEvent (Object obj)
       ("channel_created", Nothing) -> EventChannelCreated <$> parseJSON (Object obj)
       ("channel_left", Nothing) -> EventChannelLeft <$> parseJSON (Object obj)
+      ("app_home_opened", Nothing) -> EventAppHomeOpened <$> parseJSON (Object obj)
       _ -> pure $ EventUnknown (Object obj)
 
 data EventCallback = EventCallback

src/Web/Slack/Experimental/Views.hs

@@ -0,0 +1,160 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | Publishing views using the Blocks API.
+--
+-- This is used for App Home and modals.
+--
+-- <https://api.slack.com/methods/views.publish>
+--
+-- @since 2.1.0.0
+module Web.Slack.Experimental.Views (
+  -- * Types
+  SlackView (..),
+  HomeTabView (..),
+  ModalView (..),
+  Expected (..),
+
+  -- * Requests and responses
+  PublishReq (..),
+  PublishResp (..),
+  Api,
+  viewsPublish,
+) where
+
+import Data.Aeson qualified as A
+import Data.Aeson.KeyMap qualified as KM
+import Servant.API (AuthProtect, FormUrlEncoded, JSON, Post, ReqBody, (:>))
+import Servant.Client (ClientM, client)
+import Servant.Client.Core (AuthenticatedRequest)
+import Web.FormUrlEncoded (ToForm (..))
+import Web.HttpApiData (ToHttpApiData (..))
+import Web.Slack.AesonUtils (Expected (..), snakeCaseOptions, snakeCaseOptionsEatTrailingUnderscore, (.=!), (.=?))
+import Web.Slack.Experimental.Blocks qualified as B
+import Web.Slack.Experimental.Blocks.Types (SlackPlainTextOnly)
+import Web.Slack.Internal (ResponseJSON (..), SlackConfig (..), mkSlackAuthenticateReq, run)
+import Web.Slack.Pager (Response)
+import Web.Slack.Prelude
+import Web.Slack.Types (UserId)
+
+-- | View definition for some Slack surface. Has an inner type of either
+-- 'ModalView' or 'HomeTabView'.
+--
+-- <https://api.slack.com/reference/surfaces/views>
+--
+-- @since 2.1.0.0
+data SlackView inner = SlackView
+  { blocks :: Vector B.SlackBlock
+  , privateMetadata :: Maybe Text
+  , callbackId :: Maybe Text
+  , externalId :: Maybe Text
+  , inner :: inner
+  }
+  deriving stock (Show, Eq, Generic)
+
+type role SlackView representational
+
+instance (FromJSON inner) => FromJSON (SlackView inner) where
+  parseJSON = withObject "SlackView" \o -> do
+    blocks <- o .: "blocks"
+    privateMetadata <- o .:? "private_metadata"
+    callbackId <- o .:? "callback_id"
+    externalId <- o .:? "external_id"
+    inner <- parseJSON @inner (A.Object o)
+    pure SlackView {..}
+
+instance (ToJSON inner) => ToJSON (SlackView inner) where
+  toJSON SlackView {..} = case toJSON inner of
+    A.Object innerObj ->
+      A.Object
+        ( KM.fromList
+            ( catMaybes
+                [ "blocks" .=! blocks
+                , "private_metadata" .=? privateMetadata
+                , "callback_id" .=? callbackId
+                , "external_id" .=? externalId
+                ]
+            )
+            <> innerObj
+        )
+    _ -> error "inner of SlackView is not an object"
+
+-- | @since 2.1.0.0
+data HomeTabView = HomeTabView
+  { type_ :: Expected "home"
+  }
+  deriving stock (Show, Eq, Generic)
+
+$(deriveJSON snakeCaseOptionsEatTrailingUnderscore ''HomeTabView)
+
+-- | Modal view
+--
+-- <https://api.slack.com/reference/surfaces/views#modal>
+--
+-- @since 2.1.0.0
+data ModalView = ModalView
+  { type_ :: Expected "modal"
+  , title :: SlackPlainTextOnly
+  -- ^ Title of the modal on the top left. Maximum length of 24 characters.
+  , close :: Maybe SlackPlainTextOnly
+  -- ^ Text appearing on the close button on the bottom-right of the modal.
+  -- Maximum length of 24 characters.
+  , submit :: Maybe SlackPlainTextOnly
+  -- ^ Text appearing on the submit buttonn. Maximum length of 24 characters.
+  -- Must be 'SlackPlainTextOnly'.
+  , submitDisabled :: Maybe Bool
+  -- ^ Whether one or more inputs must be filled before enabling the submit button.
+  -- For configuration modals: <https://api.slack.com/reference/workflows/configuration-view>
+  }
+  deriving stock (Show, Eq, Generic)
+
+$(deriveJSON snakeCaseOptionsEatTrailingUnderscore ''ModalView)
+
+-- | Publishes the App Home view for a user.
+--
+-- <https://api.slack.com/methods/views.publish>
+--
+-- @since 2.1.0.0
+data PublishReq = PublishReq
+  { userId :: UserId
+  -- ^ User to whom the view is being published.
+  , view :: SlackView HomeTabView
+  -- ^ View payload.
+  }
+  deriving stock (Show)
+
+instance ToForm PublishReq where
+  toForm PublishReq {..} =
+    [ ("user_id" :: Text, toQueryParam userId)
+    , ("view", toQueryParam . decodeUtf8 $ A.encode view)
+    ]
+
+-- | @since 2.1.0.0
+data PublishResp = PublishResp
+  { view :: SlackView HomeTabView
+  }
+  deriving stock (Show)
+
+$(deriveJSON snakeCaseOptions ''PublishResp)
+
+-- | @since 2.1.0.0
+type Api =
+  "views.publish"
+    :> AuthProtect "token"
+    :> ReqBody '[FormUrlEncoded] PublishReq
+    :> Post '[JSON] (ResponseJSON PublishResp)
+
+-- | Publishes the App Home view for a user.
+--
+-- <https://api.slack.com/methods/views.publish>
+--
+-- @since 2.1.0.0
+viewsPublish :: SlackConfig -> PublishReq -> IO (Response PublishResp)
+viewsPublish slackConfig req = do
+  let authR = mkSlackAuthenticateReq slackConfig
+  run (viewsPublish_ authR req) . slackConfigManager $ slackConfig
+
+viewsPublish_ :: AuthenticatedRequest (AuthProtect "token") -> PublishReq -> ClientM (ResponseJSON PublishResp)
+viewsPublish_ = client (Proxy @Api)

tests/Web/Slack/Experimental/Events/TypesSpec.hs

@@ -33,4 +33,6 @@ spec = describe "Types for Slack events" do
         , "github_notification_ts_string"
         , "github_with_link"
         , "non_spec_attachment"
+        , "app_home_opened_home"
+        , "app_home_opened_messages"
         ]