diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,62 @@ +# 1.5.0.0 + +## Breaking changes + +- `PostMsgRsp` uses a `Text` instead of a `String` for the ts. +- `PostMsgReq` uses `Maybe` for the `text` since it is optional if blocks or + attachments are provided. + +The following fields are now Maybe since they have been found to be absent in +some responses: + +- `ChannelConversation.channelSharedTeamIds` +- `ChannelConversation.channelIsMember` +- `ChannelConversation.channelNumMembers` + +### Breaking changes since development versions + +- The `SlackBlockSection` constructor has a new `Maybe` field for accessories. + +## New features + +- `chat.update` bindings [#112](https://github.com/MercuryTechnologies/slack-web/pull/112) +- `users.conversations` bindings [#109](https://github.com/MercuryTechnologies/slack-web/pull/109) +- Generic pagination, making new requests easy to paginate + [#105](https://github.com/MercuryTechnologies/slack-web/pull/105) +- Expose an Internal module, allowing for new endpoints to be defined without + changing slack-web + [#99](https://github.com/MercuryTechnologies/slack-web/pull/99) +- Three experimental features: + - Schemas for the Events API + [#107](https://github.com/MercuryTechnologies/slack-web/pull/107) + - Request verification for webhooks + [#106](https://github.com/MercuryTechnologies/slack-web/pull/106) + - Support for [Blocks](https://api.slack.com/block-kit) including a builder, + headers, and accessories + [#100](https://github.com/MercuryTechnologies/slack-web/pull/100), + [#115](https://github.com/MercuryTechnologies/slack-web/pull/115), + [#116](https://github.com/MercuryTechnologies/slack-web/pull/116) + +## Bug fixes + +- Conversation parse errors will pick the variant first, *then* let it fail. + Messages now identify the correct variant and missing fields. + [#108](https://github.com/MercuryTechnologies/slack-web/pull/108) + +## Project updates + +[Mercury](https://mercury.com) now maintains this library. + +CI has been rewritten, and a Nix flake is now provided. + +We have gathered a fair corpus of sample data from Slack through the course of +writing [Slacklinker](https://github.com/MercuryTechnologies/Slacklinker), +which has been used to write a new snapshot test suite. + +Thanks to Daniel Brice, Dennis Hennen, Claire Violet, Evan Relf, Jake Keuhlen, +Rebecca Turner, Matthew Mongeau, and Kevin Tang for their contributions to this +release! + # 0.3.0.1 - Use Authorization header (44c3cf1) diff --git a/LICENSE.md b/LICENSE.md --- a/LICENSE.md +++ b/LICENSE.md @@ -1,6 +1,6 @@ MIT License -Copyright (c) 2017 Juan Pedro Villa Isaza +Copyright (c) 2017 Juan Pedro Villa Isaza, (c) 2022 Mercury Technologies, Inc Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,17 +1,5 @@ # Haskell bindings for the Slack web API -[![][1]][0] - -[![][3]][2] -[![][5]][4] - -[0]: https://circleci.com/gh/jpvillaisaza/slack-web -[1]: https://circleci.com/gh/jpvillaisaza/slack-web.svg?style=svg -[2]: https://www.stackage.org/lts/package/slack-web -[3]: https://www.stackage.org/package/slack-web/badge/lts -[4]: https://www.stackage.org/nightly/package/slack-web -[5]: https://www.stackage.org/package/slack-web/badge/nightly - - Hackage: - Slack web API: @@ -27,10 +15,6 @@ ``` ``` -> import Control.Monad.Reader -``` - -``` > :set -XOverloadedStrings ``` @@ -39,14 +23,25 @@ ``` ``` -> flip runReaderT slackConfig (Slack.apiTest Api.mkTestReq) +> Slack.apiTest (Slack.slackConfigManager slackConfig) Api.mkTestReq Right ... ``` ``` -> flip runReaderT slackConfig (Slack.apiTest Api.mkTestReq { Api.testReqFoo = Just "bar" }) +> Slack.apiTest (Slack.slackConfigManager slackConfig) Api.mkTestReq { Api.testReqFoo = Just "bar" } Right ... ``` + +## Contributing + +This repository provides a `flake.nix` file which offers pre-commit hooks and +haskell-language-server. We use `fourmolu` for formatting, which is verified in +CI. + +To use the flake, run `nix develop`, which will get you `cabal` and everything +else you need to work on `slack-web`. + +Pull requests are welcome! ## License diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/main/cli.hs b/main/cli.hs --- a/main/cli.hs +++ b/main/cli.hs @@ -1,47 +1,40 @@ -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE LambdaCase #-} - +{-# LANGUAGE TypeApplications #-} -- base import Control.Exception (throwIO) import Control.Monad.IO.Class (liftIO) -import Data.Functor (void) -import System.Environment (getEnv) -import System.Exit (die) -import System.IO (hPutStrLn, stderr) -import Text.Read (readMaybe) - -- butcher -import UI.Butcher.Monadic -- bytestring -import qualified Data.ByteString.Lazy.Char8 as BL -- monad-loops import Control.Monad.Loops (iterateUntil) - -- mtl import Control.Monad.Reader (runReaderT) - +import Data.ByteString.Lazy.Char8 qualified as BL +import Data.Functor (void) -- pretty-simple -import Text.Pretty.Simple (pPrint, pShow) -- slack-web -import qualified Web.Slack.Classy as Slack -import qualified Web.Slack.Common as Slack -import qualified Web.Slack.Conversation as SlackConversation -- text -import qualified Data.Text as Text -import qualified Data.Text.Lazy as TextLazy - +import Data.Text qualified as Text +import Data.Text.Lazy qualified as TextLazy -- time -import Data.Time.Clock (getCurrentTime, nominalDay, addUTCTime) +import Data.Time.Clock (addUTCTime, getCurrentTime, nominalDay) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) - -- servant-client-core -import Servant.Client.Core (ClientError(..), Response, ResponseF(..)) - +import Servant.Client.Core (ClientError (..), Response, ResponseF (..)) +import System.Environment (getEnv) +import System.Exit (die) +import System.IO (hPutStrLn, stderr) +import Text.Pretty.Simple (pPrint, pShow) +import Text.Read (readMaybe) +import UI.Butcher.Monadic +import Web.Slack.Classy qualified as Slack +import Web.Slack.Common qualified as Slack +import Web.Slack.Conversation qualified as SlackConversation main :: IO () main = do @@ -49,17 +42,19 @@ mainFromCmdParserWithHelpDesc $ \helpDesc -> do addHelpCommand helpDesc addCmd "conversations.list" . addCmdImpl $ do - let listReq = SlackConversation.ListReq - { SlackConversation.listReqExcludeArchived = Just True - , SlackConversation.listReqTypes = - [ SlackConversation.PublicChannelType - , SlackConversation.PrivateChannelType - , SlackConversation.MpimType - , SlackConversation.ImType - ] - } + let listReq = + SlackConversation.ListReq + { SlackConversation.listReqExcludeArchived = Just True + , SlackConversation.listReqTypes = + [ SlackConversation.PublicChannelType + , SlackConversation.PrivateChannelType + , SlackConversation.MpimType + , SlackConversation.ImType + ] + } Slack.conversationsList listReq - `runReaderT` apiConfig >>= \case + `runReaderT` apiConfig + >>= \case Right (SlackConversation.ListRsp cs) -> do pPrint cs Left err -> do @@ -76,7 +71,7 @@ if getsAll then do (`runReaderT` apiConfig) $ do - fetchPage <- Slack.conversationsHistoryAll $ (SlackConversation.mkHistoryReq conversationId) { SlackConversation.historyReqCount = 2 } + fetchPage <- Slack.conversationsHistoryAll $ (SlackConversation.mkHistoryReq conversationId) {SlackConversation.historyReqCount = 2} void . iterateUntil null $ do result <- either (liftIO . throwIO) return =<< fetchPage liftIO $ pPrint result @@ -85,16 +80,18 @@ nowUtc <- getCurrentTime let now = Slack.mkSlackTimestamp nowUtc thirtyDaysAgo = Slack.mkSlackTimestamp $ addUTCTime (nominalDay * negate 30) nowUtc - histReq = SlackConversation.HistoryReq - { SlackConversation.historyReqChannel = conversationId - , SlackConversation.historyReqCount = 5 - , SlackConversation.historyReqLatest = Just now - , SlackConversation.historyReqOldest = Just thirtyDaysAgo - , SlackConversation.historyReqInclusive = True - , SlackConversation.historyReqCursor = Nothing - } + histReq = + SlackConversation.HistoryReq + { SlackConversation.historyReqChannel = conversationId + , SlackConversation.historyReqCount = 5 + , SlackConversation.historyReqLatest = Just now + , SlackConversation.historyReqOldest = Just thirtyDaysAgo + , SlackConversation.historyReqInclusive = True + , SlackConversation.historyReqCursor = Nothing + } Slack.conversationsHistory histReq - `runReaderT` apiConfig >>= \case + `runReaderT` apiConfig + >>= \case Right rsp -> pPrint rsp Left err -> do @@ -111,25 +108,26 @@ pageSize <- addParamRead "PAGE_SIZE" (paramHelpStr "How many messages to get by a request.") addCmdImpl $ do -- NOTE: butcher's CmdParser isn't a MonadFail - threadTimeStamp <- either - (\emsg -> fail $ "Invalid timestamp " ++ show threadTimeStampStr ++ ": " ++ emsg) - return - ethreadTimeStamp + threadTimeStamp <- + either + (\emsg -> fail $ "Invalid timestamp " ++ show threadTimeStampStr ++ ": " ++ emsg) + return + ethreadTimeStamp nowUtc <- getCurrentTime let now = Slack.mkSlackTimestamp nowUtc tenDaysAgo = Slack.mkSlackTimestamp $ addUTCTime (nominalDay * negate 10) nowUtc - req = (SlackConversation.mkRepliesReq conversationId threadTimeStamp) - { SlackConversation.repliesReqLimit = pageSize - , SlackConversation.repliesReqLatest = Just now - , SlackConversation.repliesReqOldest = Just tenDaysAgo - } + req = + (SlackConversation.mkRepliesReq conversationId threadTimeStamp) + { SlackConversation.repliesReqLimit = pageSize + , SlackConversation.repliesReqLatest = Just now + , SlackConversation.repliesReqOldest = Just tenDaysAgo + } (`runReaderT` apiConfig) $ do fetchPage <- Slack.repliesFetchAll req void . iterateUntil null $ do result <- either (liftIO . throwIO) return =<< fetchPage liftIO $ pPrint result return result - peepInResponseBody err = do {- Uncomment these lines when you want to see the JSON in the reponse body. diff --git a/slack-web.cabal b/slack-web.cabal --- a/slack-web.cabal +++ b/slack-web.cabal @@ -1,32 +1,108 @@ +cabal-version: 2.2 name: slack-web -version: 0.4.0.0 +version: 1.5.0.0 build-type: Simple -cabal-version: 1.20 license: MIT license-file: LICENSE.md -copyright: 2017 Juan Pedro Villa Isaza -author: Juan Pedro Villa Isaza -maintainer: Juan Pedro Villa Isaza +copyright: 2017 Juan Pedro Villa Isaza, 2022 Mercury Technologies, Inc +author: Juan Pedro Villa Isaza , Jade Lovelace , Dennis Hennen +maintainer: Jade Lovelace -homepage: https://github.com/jpvillaisaza/slack-web -bug-reports: https://github.com/jpvillaisaza/slack-web/issues +homepage: https://github.com/MercuryTechnologies/slack-web +bug-reports: https://github.com/MercuryTechnologies/slack-web/issues synopsis: Bindings for the Slack web API description: Haskell bindings for the Slack web API. +extra-source-files: + tests/golden/SlackWebhookEvent/*.json + tests/golden/SlackWebhookEvent/*.golden + tests/golden/Conversation/*.json + tests/golden/Conversation/*.golden + tests/golden/UsersConversationsResponse/*.json + tests/golden/UsersConversationsResponse/*.golden + tests/golden/UpdateRsp/*.json + tests/golden/UpdateRsp/*.golden + tests/golden/BlockKitBuilderMessage/*.golden.json + category: Web -tested-with: GHC == 8.10.7 +tested-with: GHC == 8.10.7 || ==9.2.4 || == 9.4.2 extra-source-files: CHANGELOG.md README.md +common build-opts + ghc-options: + -Weverything + -- missing-exported-signatures turns off the more strict -Wmissing-signatures. See https://ghc.haskell.org/trac/ghc/ticket/14794#ticket + -Wno-missing-exported-signatures + -- Requires explicit export lists for every module, a pain for large modules + -Wno-missing-export-lists + -- Requires explicit imports of _every_ function (e.g. '$'); too strict + -Wno-missing-import-lists + -- When GHC can't specialize a polymorphic function. No big deal and requires fixing underlying libraries to solve. + -Wno-missed-specialisations + -- See missed-specialisations + -Wno-all-missed-specialisations + -- Don't use Safe Haskell warnings + -Wno-unsafe + -- Warning for polymorphic local bindings. Don't think this is an issue + -Wno-missing-local-signatures + -- Don't warn if the monomorphism restriction is used + -Wno-monomorphism-restriction + -- Cabal isn’t setting this currently (introduced in GHC 8.10) + -Wno-missing-safe-haskell-mode + -- Cabal’s generate Path_*.hs doesn’t do this (fixed in https://github.com/haskell/cabal/pull/7352) + -Wno-prepositive-qualified-module + -- Some tooling gives this error + -Wno-unused-packages + -- Warns on every single data declaration + -Wno-missing-kind-signatures + default-extensions: + AllowAmbiguousTypes + ApplicativeDo + BlockArguments + DataKinds + DeriveAnyClass + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingVia + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + InstanceSigs + LambdaCase + MonoLocalBinds + MultiWayIf + NamedFieldPuns + NumericUnderscores + NoImplicitPrelude + OverloadedStrings + PatternSynonyms + PolyKinds + RankNTypes + RecordWildCards + RecursiveDo + ScopedTypeVariables + StandaloneDeriving + StandaloneKindSignatures + TypeApplications + TypeFamilies + ViewPatterns + library + import: build-opts hs-source-dirs: src exposed-modules: @@ -37,41 +113,59 @@ Web.Slack.Classy Web.Slack.Common Web.Slack.Conversation + Web.Slack.Internal Web.Slack.MessageParser Web.Slack.Pager + Web.Slack.Pager.Types Web.Slack.Types Web.Slack.User + Web.Slack.UsersConversations + Web.Slack.Experimental.Blocks + Web.Slack.Experimental.Blocks.Types + Web.Slack.Experimental.Events.Types + Web.Slack.Experimental.RequestVerification other-modules: Web.Slack.Util + Web.Slack.Prelude + Web.Slack.AesonUtils build-depends: - aeson >= 1.0 && < 1.6 - , base >= 4.11 && < 4.16 - , scientific + aeson >= 2.0 && < 2.2 + , base >= 4.11 && < 4.18 + , base16-bytestring + , bytestring + , classy-prelude , containers + , cryptonite + , data-default-class , deepseq - , unordered-containers + , either + , errors , hashable - , http-api-data >= 0.3 && < 0.5 - , http-client >= 0.5 && < 0.7 + , http-api-data >= 0.3 && < 0.6 + , http-client >= 0.5 && < 0.8 , http-client-tls >= 0.3 && < 0.4 - , servant >= 0.12 && < 0.19 - , servant-client >= 0.12 && < 0.19 - , servant-client-core >= 0.12 && < 0.19 - , text >= 1.2 && < 1.3 - , transformers + , megaparsec >= 5.0 && < 10 + , mono-traversable , mtl + , refined + , scientific + , servant >= 0.16 && < 0.20 + , servant-client >= 0.16 && < 0.20 + , servant-client-core >= 0.16 && < 0.20 + , string-conversions + , string-variants >= 0.1.0.1 + , text (>= 1.2 && < 1.3) || (>= 2.0 && < 2.1) , time - , errors - , megaparsec >= 5.0 && < 10 + , transformers + , unordered-containers + , vector default-language: Haskell2010 ghc-options: -Wall --- the test suite doesn't depend on slack-web --- but rather has the src as an extra source directory. --- that allows us to refer to non exported modules from tests. test-suite tests + import: build-opts main-is: Spec.hs hs-source-dirs: @@ -79,19 +173,39 @@ type: exitcode-stdio-1.0 other-modules: + JSONGolden Web.Slack.PagerSpec Web.Slack.MessageParserSpec Web.Slack.ConversationSpec + Web.Slack.ChatSpec + Web.Slack.UsersConversationsSpec + Web.Slack.Experimental.RequestVerificationSpec + Web.Slack.Experimental.Events.TypesSpec + Web.Slack.Experimental.BlocksSpec + TestImport + build-tool-depends: + hspec-discover:hspec-discover >=2.6.0 && <2.11 build-depends: base - , slack-web + , QuickCheck , aeson + , aeson-pretty + , bytestring + , classy-prelude , fakepull , hspec + , hspec-core + , hspec-golden + , mtl + , pretty-simple + , quickcheck-instances + , slack-web + , string-conversions + , string-variants + , template-haskell , text + , th-compat , time - , QuickCheck - , quickcheck-instances default-language: Haskell2010 ghc-options: @@ -103,6 +217,7 @@ manual: True executable slack-web-cli + import: build-opts if flag(cli) buildable: True else @@ -125,4 +240,4 @@ source-repository head type: git - location: https://github.com/jpvillaisaza/slack-web + location: https://github.com/MercuryTechnologies/slack-web diff --git a/src/Web/Slack.hs b/src/Web/Slack.hs --- a/src/Web/Slack.hs +++ b/src/Web/Slack.hs @@ -1,212 +1,165 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} ---------------------------------------------------------------------- + +---------------------------------------------------------------------- + -- | -- Module: Web.Slack -- Description: Provides Slack's Web API functions. -- *Since 0.4.0.0*: The API functions is now more intuitive for newbies -- than before. If you need compatiblity with the previous version, use -- 'Web.Slack.Classy' instead. --- ----------------------------------------------------------------------- - module Web.Slack - ( SlackConfig(..) - , mkSlackConfig - , apiTest - , authTest - , chatPostMessage - , conversationsList - , conversationsHistory - , conversationsHistoryAll - , conversationsReplies - , repliesFetchAll - , getUserDesc - , usersList - , userLookupByEmail - , authenticateReq - , Response - , LoadPage + ( SlackConfig (..), + mkSlackConfig, + + -- * Endpoints + apiTest, + authTest, + chatPostMessage, + chatUpdate, + conversationsList, + conversationsListAll, + conversationsHistory, + conversationsHistoryAll, + conversationsReplies, + repliesFetchAll, + getUserDesc, + usersList, + userLookupByEmail, + UsersConversations.usersConversations, + UsersConversations.usersConversationsAll, + + -- * Requests and responses + authenticateReq, + Response, + LoadPage, ) - where +where --- aeson -import Data.Aeson +-- FIXME: Web.Slack.Prelude --- base import Control.Arrow ((&&&)) +import Data.Map qualified as Map import Data.Maybe -import Data.Proxy (Proxy(..)) - --- containers -import qualified Data.Map as Map - --- http-client +import Data.Proxy (Proxy (..)) +import Data.Text (Text) import Network.HTTP.Client (Manager, newManager) - --- http-client-tls import Network.HTTP.Client.TLS (tlsManagerSettings) - --- mtl -import Control.Monad.Reader - --- servant import Servant.API hiding (addHeader) - --- servant-client import Servant.Client hiding (Response, baseUrl) - -#if MIN_VERSION_servant(0,16,0) -import Servant.Client.Core (AuthClientData, AuthenticatedRequest, Request, mkAuthenticatedRequest, addHeader) -#else -import Servant.Client.Core.Internal.Auth -import Servant.Client.Core (Request, addHeader) -#endif - --- slack-web -import qualified Web.Slack.Api as Api -import qualified Web.Slack.Auth as Auth -import qualified Web.Slack.Conversation as Conversation -import qualified Web.Slack.Chat as Chat -import qualified Web.Slack.Common as Common -import qualified Web.Slack.User as User -import Web.Slack.Pager - --- text -import Data.Text (Text) - -#if !MIN_VERSION_servant(0,13,0) -mkClientEnv :: Manager -> BaseUrl -> ClientEnv -mkClientEnv = ClientEnv -#endif - - -data SlackConfig - = SlackConfig - { slackConfigManager :: Manager - , slackConfigToken :: Text - } - - --- contains errors that can be returned by the slack API. --- constrast with 'SlackClientError' which additionally --- contains errors which occured during the network communication. -data ResponseSlackError = ResponseSlackError Text - deriving (Eq, Show) - - --- | --- Internal type! --- -newtype ResponseJSON a = ResponseJSON (Either ResponseSlackError a) - -instance FromJSON a => FromJSON (ResponseJSON a) where - parseJSON = withObject "Response" $ \o -> do - ok <- o .: "ok" - ResponseJSON <$> if ok - then Right <$> parseJSON (Object o) - else Left . ResponseSlackError <$> o .: "error" - +import Servant.Client.Core (AuthenticatedRequest) +import Web.Slack.Api qualified as Api +import Web.Slack.Auth qualified as Auth +import Web.Slack.Chat qualified as Chat +import Web.Slack.Common qualified as Common +import Web.Slack.Conversation qualified as Conversation +import Web.Slack.Internal +import Web.Slack.Pager +import Web.Slack.User qualified as User +import Web.Slack.UsersConversations qualified as UsersConversations +import Prelude --- | --- --- type Api = - "api.test" - :> ReqBody '[FormUrlEncoded] Api.TestReq - :> Post '[JSON] (ResponseJSON Api.TestRsp) - :<|> - "auth.test" + "api.test" + :> ReqBody '[FormUrlEncoded] Api.TestReq + :> Post '[JSON] (ResponseJSON Api.TestRsp) + :<|> "auth.test" :> AuthProtect "token" :> Post '[JSON] (ResponseJSON Auth.TestRsp) - :<|> - "conversations.list" + :<|> "conversations.list" :> AuthProtect "token" :> ReqBody '[FormUrlEncoded] Conversation.ListReq :> Post '[JSON] (ResponseJSON Conversation.ListRsp) - :<|> - "conversations.history" + :<|> "conversations.history" :> AuthProtect "token" :> ReqBody '[FormUrlEncoded] Conversation.HistoryReq :> Post '[JSON] (ResponseJSON Conversation.HistoryRsp) - :<|> - "conversations.replies" + :<|> "conversations.replies" :> AuthProtect "token" :> ReqBody '[FormUrlEncoded] Conversation.RepliesReq :> Post '[JSON] (ResponseJSON Conversation.HistoryRsp) - :<|> - "chat.postMessage" + :<|> "chat.postMessage" :> AuthProtect "token" :> ReqBody '[FormUrlEncoded] Chat.PostMsgReq :> Post '[JSON] (ResponseJSON Chat.PostMsgRsp) - :<|> - "users.list" + :<|> "chat.update" :> AuthProtect "token" + :> ReqBody '[FormUrlEncoded] Chat.UpdateReq + :> Post '[JSON] (ResponseJSON Chat.UpdateRsp) + :<|> "users.list" + :> AuthProtect "token" :> Post '[JSON] (ResponseJSON User.ListRsp) - :<|> - "users.lookupByEmail" + :<|> "users.lookupByEmail" :> AuthProtect "token" :> ReqBody '[FormUrlEncoded] User.Email :> Post '[JSON] (ResponseJSON User.UserRsp) - -- | -- -- Check API calling code. -- -- - -apiTest - :: Manager - -> Api.TestReq - -> IO (Response Api.TestRsp) +apiTest :: + Manager -> + Api.TestReq -> + IO (Response Api.TestRsp) apiTest mgr req = run (apiTest_ req) mgr -apiTest_ - :: Api.TestReq - -> ClientM (ResponseJSON Api.TestRsp) - +apiTest_ :: + Api.TestReq -> + ClientM (ResponseJSON Api.TestRsp) -- | -- -- Check authentication and identity. -- -- - -authTest - :: SlackConfig - -> IO (Response Auth.TestRsp) +authTest :: + SlackConfig -> + IO (Response Auth.TestRsp) authTest = do authR <- mkSlackAuthenticateReq run (authTest_ authR) . slackConfigManager -authTest_ - :: AuthenticatedRequest (AuthProtect "token") - -> ClientM (ResponseJSON Auth.TestRsp) +authTest_ :: + AuthenticatedRequest (AuthProtect "token") -> + ClientM (ResponseJSON Auth.TestRsp) -- | -- -- Retrieve conversations list. -- -- - -conversationsList - :: SlackConfig - -> Conversation.ListReq - -> IO (Response Conversation.ListRsp) +conversationsList :: + SlackConfig -> + Conversation.ListReq -> + IO (Response Conversation.ListRsp) conversationsList = flip $ \listReq -> do authR <- mkSlackAuthenticateReq run (conversationsList_ authR listReq) . slackConfigManager -conversationsList_ - :: AuthenticatedRequest (AuthProtect "token") - -> Conversation.ListReq - -> ClientM (ResponseJSON Conversation.ListRsp) +conversationsList_ :: + AuthenticatedRequest (AuthProtect "token") -> + Conversation.ListReq -> + ClientM (ResponseJSON Conversation.ListRsp) +-- | Returns an action to send a request to get the list of conversations in the +-- workspace. +-- +-- To fetch all replies in the conversation, run the returned 'LoadPage' action +-- repeatedly until it returns an empty list. +conversationsListAll :: + SlackConfig -> + -- | The first request to send. _NOTE_: 'Conversation.listReqCursor' is silently ignored. + Conversation.ListReq -> + -- | An action which returns a new page of messages every time called. + -- If there are no pages anymore, it returns an empty list. + IO (LoadPage IO Conversation.Conversation) +conversationsListAll = fetchAllBy . conversationsList -- | -- @@ -214,20 +167,18 @@ -- Consider using 'historyFetchAll' in combination with this function. -- -- - -conversationsHistory - :: SlackConfig - -> Conversation.HistoryReq - -> IO (Response Conversation.HistoryRsp) +conversationsHistory :: + SlackConfig -> + Conversation.HistoryReq -> + IO (Response Conversation.HistoryRsp) conversationsHistory = flip $ \histReq -> do authR <- mkSlackAuthenticateReq run (conversationsHistory_ authR histReq) . slackConfigManager -conversationsHistory_ - :: AuthenticatedRequest (AuthProtect "token") - -> Conversation.HistoryReq - -> ClientM (ResponseJSON Conversation.HistoryRsp) - +conversationsHistory_ :: + AuthenticatedRequest (AuthProtect "token") -> + Conversation.HistoryReq -> + ClientM (ResponseJSON Conversation.HistoryRsp) -- | -- @@ -236,58 +187,69 @@ -- of a conversation. -- -- - -conversationsReplies - :: SlackConfig - -> Conversation.RepliesReq - -> IO (Response Conversation.HistoryRsp) +conversationsReplies :: + SlackConfig -> + Conversation.RepliesReq -> + IO (Response Conversation.HistoryRsp) conversationsReplies = flip $ \repliesReq -> do authR <- mkSlackAuthenticateReq run (conversationsReplies_ authR repliesReq) . slackConfigManager -conversationsReplies_ - :: AuthenticatedRequest (AuthProtect "token") - -> Conversation.RepliesReq - -> ClientM (ResponseJSON Conversation.HistoryRsp) - +conversationsReplies_ :: + AuthenticatedRequest (AuthProtect "token") -> + Conversation.RepliesReq -> + ClientM (ResponseJSON Conversation.HistoryRsp) -- | -- -- Send a message to a channel. -- -- - -chatPostMessage - :: SlackConfig - -> Chat.PostMsgReq - -> IO (Response Chat.PostMsgRsp) +chatPostMessage :: + SlackConfig -> + Chat.PostMsgReq -> + IO (Response Chat.PostMsgRsp) chatPostMessage = flip $ \postReq -> do authR <- mkSlackAuthenticateReq run (chatPostMessage_ authR postReq) . slackConfigManager -chatPostMessage_ - :: AuthenticatedRequest (AuthProtect "token") - -> Chat.PostMsgReq - -> ClientM (ResponseJSON Chat.PostMsgRsp) +chatPostMessage_ :: + AuthenticatedRequest (AuthProtect "token") -> + Chat.PostMsgReq -> + ClientM (ResponseJSON Chat.PostMsgRsp) +-- | Updates a message. +-- +-- +chatUpdate :: + SlackConfig -> + Chat.UpdateReq -> + IO (Response Chat.UpdateRsp) +chatUpdate = flip $ \updateReq -> do + authR <- mkSlackAuthenticateReq + run (chatUpdate_ authR updateReq) . slackConfigManager +chatUpdate_ :: + AuthenticatedRequest (AuthProtect "token") -> + Chat.UpdateReq -> + ClientM (ResponseJSON Chat.UpdateRsp) + -- | -- -- This method returns a list of all users in the team. -- This includes deleted/deactivated users. -- -- - -usersList - :: SlackConfig - -> IO (Response User.ListRsp) +usersList :: + SlackConfig -> + IO (Response User.ListRsp) usersList = do authR <- mkSlackAuthenticateReq run (usersList_ authR) . slackConfigManager -usersList_ - :: AuthenticatedRequest (AuthProtect "token") - -> ClientM (ResponseJSON User.ListRsp) +usersList_ :: + AuthenticatedRequest (AuthProtect "token") -> + ClientM (ResponseJSON User.ListRsp) -- | -- @@ -295,49 +257,44 @@ -- This includes deleted/deactivated users. -- -- - -userLookupByEmail - :: SlackConfig - -> User.Email - -> IO (Response User.UserRsp) +userLookupByEmail :: + SlackConfig -> + User.Email -> + IO (Response User.UserRsp) userLookupByEmail = flip $ \email -> do authR <- mkSlackAuthenticateReq run (userLookupByEmail_ authR email) . slackConfigManager -userLookupByEmail_ - :: AuthenticatedRequest (AuthProtect "token") - -> User.Email - -> ClientM (ResponseJSON User.UserRsp) - +userLookupByEmail_ :: + AuthenticatedRequest (AuthProtect "token") -> + User.Email -> + ClientM (ResponseJSON User.UserRsp) -- | Returns a function to get a username from a 'Common.UserId'. -- Comes in handy to use 'Web.Slack.MessageParser.messageToHtml' -getUserDesc - :: (Common.UserId -> Text) - -- ^ A function to give a default username in case the username is unknown - -> User.ListRsp - -- ^ List of users as known by the slack server. See 'usersList'. - -> (Common.UserId -> Text) - -- ^ A function from 'Common.UserId' to username. +getUserDesc :: + -- | A function to give a default username in case the username is unknown + (Common.UserId -> Text) -> + -- | List of users as known by the slack server. See 'usersList'. + User.ListRsp -> + -- | A function from 'Common.UserId' to username. + (Common.UserId -> Text) getUserDesc unknownUserFn users = let userMap = Map.fromList $ (User.userId &&& User.userName) <$> User.listRspMembers users - in - \userId -> fromMaybe (unknownUserFn userId) $ Map.lookup userId userMap - + in \userId -> fromMaybe (unknownUserFn userId) $ Map.lookup userId userMap -- | Returns an action to send a request to get the history of a conversation. -- -- To fetch all messages in the conversation, run the returned 'LoadPage' action -- repeatedly until it returns an empty list. -conversationsHistoryAll - :: SlackConfig - -> Conversation.HistoryReq - -- ^ The first request to send. _NOTE_: 'Conversation.historyReqCursor' is silently ignored. - -> IO (LoadPage IO Common.Message) - -- ^ An action which returns a new page of messages every time called. +conversationsHistoryAll :: + SlackConfig -> + -- | The first request to send. _NOTE_: 'Conversation.historyReqCursor' is silently ignored. + Conversation.HistoryReq -> + -- | An action which returns a new page of messages every time called. -- If there are no pages anymore, it returns an empty list. -conversationsHistoryAll = conversationsHistoryAllBy . conversationsHistory - + IO (LoadPage IO Common.Message) +conversationsHistoryAll = fetchAllBy . conversationsHistory -- | Returns an action to send a request to get the replies of a conversation. -- @@ -348,15 +305,14 @@ -- of the thread. So every page returned by the 'LoadPage' action includes -- the first message of the thread. You should drop it if you want to -- collect messages in a thread without duplicates. -repliesFetchAll - :: SlackConfig - -> Conversation.RepliesReq - -- ^ The first request to send. _NOTE_: 'Conversation.repliesReqCursor' is silently ignored. - -> IO (LoadPage IO Common.Message) - -- ^ An action which returns a new page of messages every time called. +repliesFetchAll :: + SlackConfig -> + -- | The first request to send. _NOTE_: 'Conversation.repliesReqCursor' is silently ignored. + Conversation.RepliesReq -> + -- | An action which returns a new page of messages every time called. -- If there are no pages anymore, it returns an empty list. -repliesFetchAll = repliesFetchAllBy . conversationsReplies - + IO (LoadPage IO Common.Message) +repliesFetchAll = fetchAllBy . conversationsReplies apiTest_ :<|> authTest_ @@ -364,57 +320,12 @@ :<|> conversationsHistory_ :<|> conversationsReplies_ :<|> chatPostMessage_ + :<|> chatUpdate_ :<|> usersList_ - :<|> userLookupByEmail_ - = - client (Proxy :: Proxy Api) - - --- | --- --- - -type instance AuthClientData (AuthProtect "token") = - Text - - --- | --- --- -authenticateReq - :: Text - -> Request - -> Request -authenticateReq token = - addHeader "Authorization" $ "Bearer " <> token - - --- | --- --- - -run - :: ClientM (ResponseJSON a) - -> Manager - -> IO (Response a) -run clientAction mgr = do - let baseUrl = BaseUrl Https "slack.com" 443 "/api" - unnestErrors <$> liftIO (runClientM clientAction $ mkClientEnv mgr baseUrl) - - -mkSlackAuthenticateReq :: SlackConfig -> AuthenticatedRequest (AuthProtect "token") -mkSlackAuthenticateReq = (`mkAuthenticatedRequest` authenticateReq) . slackConfigToken - - -unnestErrors :: Either ClientError (ResponseJSON a) -> Response a -unnestErrors (Right (ResponseJSON (Right a))) = Right a -unnestErrors (Right (ResponseJSON (Left (ResponseSlackError serv)))) - = Left (Common.SlackError serv) -unnestErrors (Left slackErr) = Left (Common.ServantError slackErr) - + :<|> userLookupByEmail_ = + client (Proxy :: Proxy Api) -- | Prepare a SlackConfig from a slack token. -- You can then call the other functions providing this in a reader context. --- mkSlackConfig :: Text -> IO SlackConfig mkSlackConfig token = SlackConfig <$> newManager tlsManagerSettings <*> pure token diff --git a/src/Web/Slack/AesonUtils.hs b/src/Web/Slack/AesonUtils.hs new file mode 100644 --- /dev/null +++ b/src/Web/Slack/AesonUtils.hs @@ -0,0 +1,114 @@ +module Web.Slack.AesonUtils where + +import Data.Aeson +import Data.Aeson qualified as J +import Data.Aeson.Types (Pair) +import Data.Char qualified as Char +import Data.Text qualified as T +import Web.FormUrlEncoded qualified as F +import Web.Slack.Prelude + +-- | Checks that a record's field labels each start with the given 'prefix', +-- then uses a given 'drop (length prefix)' derivingStrategy to drop that prefix from generated JSON. +-- +-- If used in a Template Haskell splice, gives a compile-time error if the prefixes don't match up. +-- Warning: This function should not be used outside of a Template Haskell splice, as it calls `error` in the case that the prefixes don't match up! +-- +-- Example usage: +-- +-- data PrefixedRecord = PrefixedRecord { prefixedRecordOne :: Int, prefixedRecordTwo :: Char } + +-- $(deriveFromJSON (jsonDeriveWithAffix "prefixedRecord" jsonDeriveOptionsSnakeCase) ''PrefixedRecord) + +jsonDeriveWithAffix :: Text -> (Int -> Options) -> Options +jsonDeriveWithAffix prefix derivingStrategy = + originalOptions + { fieldLabelModifier = \fieldLabel -> + if prefix `isPrefixOf` T.pack fieldLabel + then originalModifier fieldLabel + else error $ "Prefixes don't match: `" <> T.unpack prefix <> "` isn't a prefix of `" <> fieldLabel <> "`. Search for jsonDeriveWithAffix to learn more." + } + where + originalOptions = derivingStrategy $ T.length prefix + originalModifier = fieldLabelModifier originalOptions + +camelToSnake :: String -> String +camelToSnake = camelTo2 '_' + +lowerFirst :: String -> String +lowerFirst [] = [] +lowerFirst (c : chars) = Char.toLower c : chars + +jsonDeriveOptionsSnakeCase :: Int -> Options +jsonDeriveOptionsSnakeCase n = + defaultOptions + { fieldLabelModifier = camelToSnake . lowerFirst . drop n + , omitNothingFields = True + , constructorTagModifier = camelToSnake . lowerFirst . drop n + } + +-- | Create a 'Value' from a list of name\/value @Maybe Pair@'s. +-- For 'Nothing', instead of outputting @null@, that field will not be output at all. +-- If duplicate keys arise, later keys and their associated values win. +-- +-- Example: +-- +-- @ +-- objectOptional +-- [ "always" .=! 1 +-- , "just" .=? Just 2 +-- , "nothing" .=? Nothing +-- ] +-- @ +-- +-- will result in the JSON +-- +-- @ +-- { +-- "always": 1, +-- "just": 2 +-- } +-- @ +-- +-- The field @nothing@ is ommited because it was 'Nothing'. +objectOptional :: [Maybe Pair] -> Value +objectOptional = J.object . catMaybes + +-- | Encode a value for 'objectOptional' +(.=!) :: ToJSON v => Key -> v -> Maybe Pair +key .=! val = Just (key .= val) + +infixr 8 .=! + +-- | Encode a Maybe value for 'objectOptional' +(.=?) :: ToJSON v => Key -> Maybe v -> Maybe Pair +key .=? mVal = fmap (key .=) mVal + +infixr 8 .=? + +-- | Conditionally encode a value for 'objectOptional' +(?.>) :: Bool -> Pair -> Maybe Pair +True ?.> pair = Just pair +False ?.> _ = Nothing + +infixr 7 ?.> + +-- | Conditionally express a pair in a JSON series +thenPair :: Bool -> J.Series -> J.Series +thenPair True s = s +thenPair False _ = mempty + +infixr 7 `thenPair` + +snakeCaseOptions :: Options +snakeCaseOptions = + defaultOptions + { fieldLabelModifier = camelTo2 '_' + , constructorTagModifier = camelTo2 '_' + } + +snakeCaseFormOptions :: F.FormOptions +snakeCaseFormOptions = + F.defaultFormOptions + { F.fieldLabelModifier = camelTo2 '_' + } diff --git a/src/Web/Slack/Api.hs b/src/Web/Slack/Api.hs --- a/src/Web/Slack/Api.hs +++ b/src/Web/Slack/Api.hs @@ -3,75 +3,53 @@ {-# LANGUAGE TemplateHaskell #-} ---------------------------------------------------------------------- + +---------------------------------------------------------------------- + -- | -- Module: Web.Slack.Api -- Description: --- --- --- ----------------------------------------------------------------------- - - module Web.Slack.Api - ( TestReq(..) - , mkTestReq - , TestRsp(..) + ( TestReq (..), + mkTestReq, + TestRsp (..), ) - where +where +-- FIXME: Web.Slack.Prelude + -- aeson -import Data.Aeson.TH -- base -import GHC.Generics (Generic) -- deepseq import Control.DeepSeq (NFData) - +import Data.Aeson.TH -- http-api-data -import Web.FormUrlEncoded -- slack-web -import Web.Slack.Util -- text import Data.Text (Text) - - --- | --- --- +import GHC.Generics (Generic) +import Web.FormUrlEncoded +import Web.Slack.Util +import Prelude -data TestReq = - TestReq - { testReqError :: Maybe Text - , testReqFoo :: Maybe Text - } - deriving (Eq, Generic, Show) +data TestReq = TestReq + { testReqError :: Maybe Text + , testReqFoo :: Maybe Text + } + deriving stock (Eq, Generic, Show) instance NFData TestReq - --- | --- --- - $(deriveJSON (jsonOpts "testReq") ''TestReq) - --- | --- --- - instance ToForm TestReq where toForm = genericToForm (formOpts "testReq") - --- | --- --- - mkTestReq :: TestReq mkTestReq = TestReq @@ -79,20 +57,11 @@ , testReqFoo = Nothing } - --- | --- --- - -data TestRsp = - TestRsp - { testRspArgs :: Maybe TestReq - } - deriving (Eq, Generic, Show) +data TestRsp = TestRsp + { testRspArgs :: Maybe TestReq + } + deriving stock (Eq, Generic, Show) instance NFData TestRsp --- | --- --- $(deriveFromJSON (jsonOpts "testRsp") ''TestRsp) diff --git a/src/Web/Slack/Auth.hs b/src/Web/Slack/Auth.hs --- a/src/Web/Slack/Auth.hs +++ b/src/Web/Slack/Auth.hs @@ -3,50 +3,41 @@ {-# LANGUAGE TemplateHaskell #-} ---------------------------------------------------------------------- + +---------------------------------------------------------------------- + -- | -- Module: Web.Slack.Auth -- Description: --- --- --- ----------------------------------------------------------------------- - +module Web.Slack.Auth where -module Web.Slack.Auth - where +-- FIXME: Web.Slack.Prelude -- aeson -import Data.Aeson.TH -- base -import GHC.Generics (Generic) -- deepseq import Control.DeepSeq (NFData) - +import Data.Aeson.TH -- slack-web -import Web.Slack.Util -- text import Data.Text (Text) - - --- | --- --- +import GHC.Generics (Generic) +import Web.Slack.Util +import Prelude -data TestRsp = - TestRsp - { testRspUrl :: Text - , testRspTeam :: Text - , testRspUser :: Text - , testRspTeamId :: Text - , testRspUserId :: Text - , testRspEnterpriseId :: Maybe Text - } - deriving (Eq, Generic, Show) +data TestRsp = TestRsp + { testRspUrl :: Text + , testRspTeam :: Text + , testRspUser :: Text + , testRspTeamId :: Text + , testRspUserId :: Text + , testRspEnterpriseId :: Maybe Text + } + deriving stock (Eq, Generic, Show) instance NFData TestRsp - $(deriveJSON (jsonOpts "testRsp") ''TestRsp) diff --git a/src/Web/Slack/Chat.hs b/src/Web/Slack/Chat.hs --- a/src/Web/Slack/Chat.hs +++ b/src/Web/Slack/Chat.hs @@ -2,123 +2,78 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------- --- | --- Module: Web.Slack.Chat --- Description: --- --- --- ----------------------------------------------------------------------- - module Web.Slack.Chat - ( PostMsg(..) - , PostMsgReq(..) - , mkPostMsgReq - , PostMsgRsp(..) + ( PostMsg (..), + PostMsgReq (..), + mkPostMsgReq, + PostMsgRsp (..), + UpdateReq (..), + mkUpdateReq, + UpdateRsp (..), ) - where - --- aeson -import Data.Aeson.TH - --- base -import GHC.Generics (Generic) - --- deepseq -import Control.DeepSeq (NFData) +where --- http-api-data import Web.FormUrlEncoded - --- slack-web +import Web.Slack.Conversation (ConversationId) +import Web.Slack.Prelude import Web.Slack.Util --- text -import Data.Text (Text) - - -data PostMsg = - PostMsg - { postMsgText :: Text - , postMsgParse :: Maybe Text - , postMsgLinkNames :: Maybe Bool - , postMsgAttachments :: Maybe Text - , postMsgUnfurlLinks :: Maybe Bool - , postMsgUnfurlMedia :: Maybe Bool - , postMsgUsername :: Maybe Text - , postMsgAsUser :: Maybe Bool - , postMsgIconUrl :: Maybe Text - , postMsgIconEmoji :: Maybe Text - , postMsgThreadTs :: Maybe Text - , postMsgReplyBroadcast :: Maybe Bool - } - deriving (Eq, Generic, Show) +data PostMsg = PostMsg + { postMsgText :: Text + , postMsgParse :: Maybe Text + , postMsgLinkNames :: Maybe Bool + , postMsgAttachments :: Maybe Text + , postMsgUnfurlLinks :: Maybe Bool + , postMsgUnfurlMedia :: Maybe Bool + , postMsgUsername :: Maybe Text + , postMsgAsUser :: Maybe Bool + , postMsgIconUrl :: Maybe Text + , postMsgIconEmoji :: Maybe Text + , postMsgThreadTs :: Maybe Text + , postMsgReplyBroadcast :: Maybe Bool + } + deriving stock (Eq, Generic, Show) instance NFData PostMsg - --- | --- --- - $(deriveJSON (jsonOpts "postMsg") ''PostMsg) - --- | --- --- - -data PostMsgReq = - PostMsgReq - { postMsgReqChannel :: Text - , postMsgReqText :: Text - , postMsgReqParse :: Maybe Text - , postMsgReqLinkNames :: Maybe Bool - , postMsgReqAttachments :: Maybe Text - , postMsgReqBlocks :: Maybe Text - , postMsgReqUnfurlLinks :: Maybe Bool - , postMsgReqUnfurlMedia :: Maybe Bool - , postMsgReqUsername :: Maybe Text - , postMsgReqAsUser :: Maybe Bool - , postMsgReqIconUrl :: Maybe Text - , postMsgReqIconEmoji :: Maybe Text - , postMsgReqThreadTs :: Maybe Text - , postMsgReqReplyBroadcast :: Maybe Bool - } - deriving (Eq, Generic, Show) +data PostMsgReq = PostMsgReq + { postMsgReqChannel :: Text + , postMsgReqText :: Maybe Text + -- ^ One of 'postMsgReqText', 'postMsgReqAttachments', or 'postMsgReqBlocks' + -- is required. + , postMsgReqParse :: Maybe Text + , postMsgReqLinkNames :: Maybe Bool + , postMsgReqAttachments :: Maybe Text + , postMsgReqBlocks :: Maybe Text + , postMsgReqUnfurlLinks :: Maybe Bool + , postMsgReqUnfurlMedia :: Maybe Bool + , postMsgReqUsername :: Maybe Text + , postMsgReqAsUser :: Maybe Bool + , postMsgReqIconUrl :: Maybe Text + , postMsgReqIconEmoji :: Maybe Text + , postMsgReqThreadTs :: Maybe Text + , postMsgReqReplyBroadcast :: Maybe Bool + } + deriving stock (Eq, Generic, Show) instance NFData PostMsgReq - --- | --- --- - $(deriveJSON (jsonOpts "postMsgReq") ''PostMsgReq) - --- | --- --- - instance ToForm PostMsgReq where toForm = genericToForm (formOpts "postMsgReq") - --- | --- --- - -mkPostMsgReq - :: Text - -> Text - -> PostMsgReq +mkPostMsgReq :: + Text -> + Text -> + PostMsgReq mkPostMsgReq channel text = PostMsgReq { postMsgReqChannel = channel - , postMsgReqText = text + , postMsgReqText = Just text , postMsgReqParse = Nothing , postMsgReqLinkNames = Nothing , postMsgReqAttachments = Nothing @@ -133,18 +88,61 @@ , postMsgReqReplyBroadcast = Nothing } +data PostMsgRsp = PostMsgRsp + { postMsgRspTs :: Text + , postMsgRspMessage :: PostMsg + } + deriving stock (Eq, Generic, Show) --- | --- --- +instance NFData PostMsgRsp -data PostMsgRsp = - PostMsgRsp - { postMsgRspTs :: String - , postMsgRspMessage :: PostMsg +$(deriveFromJSON (jsonOpts "postMsgRsp") ''PostMsgRsp) + +-- | +data UpdateReq = UpdateReq + { updateReqChannel :: ConversationId + , updateReqTs :: Text + -- ^ \"Timestamp of the message to be updated.\" + , updateReqAsUser :: Maybe Bool + -- ^ \"Pass true to update the message as the authed user. Bot users in this context are considered authed users.\" + , updateReqAttachments :: Maybe Text + -- ^ \"A JSON-based array of structured attachments, presented as a URL-encoded string. This field is required when not presenting text. If you don't include this field, the message's previous attachments will be retained. To remove previous attachments, include an empty array for this field.\" + , updateReqLinkNames :: Maybe Bool + , updateReqMetadata :: Maybe Text + , updateReqParse :: Maybe Text + , updateReqReplyBroadcast :: Maybe Bool + -- ^ \"Broadcast an existing thread reply to make it visible to everyone in the channel or conversation.\" + , updateReqText :: Maybe Text + -- ^ \"New text for the message, using the default formatting rules. It's not required when presenting blocks or attachments.\" + } + deriving stock (Eq, Generic, Show) + +instance ToForm UpdateReq where + toForm = genericToForm (formOpts "updateReq") + +mkUpdateReq :: ConversationId -> Text -> UpdateReq +mkUpdateReq channel ts = + UpdateReq + { updateReqChannel = channel + , updateReqTs = ts + , updateReqAsUser = Nothing + , updateReqAttachments = Nothing + , updateReqLinkNames = Nothing + , updateReqMetadata = Nothing + , updateReqParse = Nothing + , updateReqReplyBroadcast = Nothing + , updateReqText = Nothing } - deriving (Eq, Generic, Show) -instance NFData PostMsgRsp +data UpdateRsp = UpdateRsp + { updateRspChannel :: ConversationId + , updateRspTs :: Text + , updateRspText :: Text + -- FIXME(jadel): this does look suspiciously like the same schema as + -- MessageEvent based on the example I received, but Slack hasn't documented + -- what it actually is, so let's not try to parse it for now. + -- , message :: MessageEvent + } + deriving stock (Eq, Generic, Show) -$(deriveFromJSON (jsonOpts "postMsgRsp") ''PostMsgRsp) +$(deriveFromJSON (jsonOpts "updateRsp") ''UpdateRsp) diff --git a/src/Web/Slack/Classy.hs b/src/Web/Slack/Classy.hs --- a/src/Web/Slack/Classy.hs +++ b/src/Web/Slack/Classy.hs @@ -1,65 +1,61 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} ---------------------------------------------------------------------- + +---------------------------------------------------------------------- + -- | -- Module: Web.Slack.Classy -- Description: For compatibility with Web.Slack prior to v0.4.0.0. --- --- --- ----------------------------------------------------------------------- - module Web.Slack.Classy - ( SlackConfig(..) - , mkSlackConfig - , apiTest - , authTest - , chatPostMessage - , conversationsList - , conversationsHistory - , conversationsHistoryAll - , conversationsReplies - , repliesFetchAll - , getUserDesc - , usersList - , userLookupByEmail - , authenticateReq - , Response - , LoadPage - , HasManager(..) - , HasToken(..) + ( SlackConfig (..), + mkSlackConfig, + apiTest, + authTest, + chatPostMessage, + conversationsList, + conversationsHistory, + conversationsHistoryAll, + conversationsReplies, + repliesFetchAll, + getUserDesc, + usersList, + userLookupByEmail, + authenticateReq, + Response, + LoadPage, + HasManager (..), + HasToken (..), ) - where +where +-- FIXME: Web.Slack.Prelude + -- base import Control.Arrow ((&&&)) -import Data.Maybe - -- containers -import qualified Data.Map as Map -- http-client -import Network.HTTP.Client (Manager) -- mtl import Control.Monad.Reader - +import Data.Map qualified as Map +import Data.Maybe -- slack-web -import qualified Web.Slack.Api as Api -import qualified Web.Slack.Auth as Auth -import qualified Web.Slack.Conversation as Conversation -import qualified Web.Slack.Chat as Chat -import qualified Web.Slack.Common as Common -import qualified Web.Slack.User as User -import Web.Slack.Pager -import qualified Web.Slack as NonClassy -import Web.Slack (SlackConfig (..), authenticateReq, mkSlackConfig) -- text import Data.Text (Text) +import Network.HTTP.Client (Manager) +import Web.Slack (SlackConfig (..), authenticateReq, mkSlackConfig) +import Web.Slack qualified as NonClassy +import Web.Slack.Api qualified as Api +import Web.Slack.Auth qualified as Auth +import Web.Slack.Chat qualified as Chat +import Web.Slack.Common qualified as Common +import Web.Slack.Conversation qualified as Conversation +import Web.Slack.Pager +import Web.Slack.User qualified as User +import Prelude #if !MIN_VERSION_servant(0,13,0) mkClientEnv :: Manager -> BaseUrl -> ClientEnv @@ -68,70 +64,62 @@ -- | Implemented by 'SlackConfig' class HasManager a where - getManager :: a -> Manager + getManager :: a -> Manager -- | Implemented by 'SlackConfig' class HasToken a where - getToken :: a -> Text + getToken :: a -> Text instance HasManager SlackConfig where - getManager = slackConfigManager -instance HasToken SlackConfig where - getToken = slackConfigToken + getManager = slackConfigManager +instance HasToken SlackConfig where + getToken = slackConfigToken -- | -- -- Check API calling code. -- -- - -apiTest - :: (MonadReader env m, HasManager env, MonadIO m) - => Api.TestReq - -> m (Response Api.TestRsp) +apiTest :: + (MonadReader env m, HasManager env, MonadIO m) => + Api.TestReq -> + m (Response Api.TestRsp) apiTest = liftToReader . flip (NonClassy.apiTest . getManager) - -- | -- -- Check authentication and identity. -- -- - -authTest - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => m (Response Auth.TestRsp) +authTest :: + (MonadReader env m, HasManager env, HasToken env, MonadIO m) => + m (Response Auth.TestRsp) authTest = liftNonClassy NonClassy.authTest - -- | -- -- Retrieve conversations list. -- -- - -conversationsList - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => Conversation.ListReq - -> m (Response Conversation.ListRsp) +conversationsList :: + (MonadReader env m, HasManager env, HasToken env, MonadIO m) => + Conversation.ListReq -> + m (Response Conversation.ListRsp) conversationsList = liftNonClassy . flip NonClassy.conversationsList - -- | -- -- Retrieve ceonversation history. -- Consider using 'historyFetchAll' in combination with this function. -- -- - -conversationsHistory - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => Conversation.HistoryReq - -> m (Response Conversation.HistoryRsp) +conversationsHistory :: + (MonadReader env m, HasManager env, HasToken env, MonadIO m) => + Conversation.HistoryReq -> + m (Response Conversation.HistoryRsp) conversationsHistory = liftNonClassy . flip NonClassy.conversationsHistory - -- | -- -- Retrieve replies of a conversation. @@ -139,82 +127,71 @@ -- of a conversation. -- -- - -conversationsReplies - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => Conversation.RepliesReq - -> m (Response Conversation.HistoryRsp) +conversationsReplies :: + (MonadReader env m, HasManager env, HasToken env, MonadIO m) => + Conversation.RepliesReq -> + m (Response Conversation.HistoryRsp) conversationsReplies = liftNonClassy . flip NonClassy.conversationsReplies - -- | -- -- Send a message to a channel. -- -- - -chatPostMessage - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => Chat.PostMsgReq - -> m (Response Chat.PostMsgRsp) +chatPostMessage :: + (MonadReader env m, HasManager env, HasToken env, MonadIO m) => + Chat.PostMsgReq -> + m (Response Chat.PostMsgRsp) chatPostMessage = liftNonClassy . flip NonClassy.chatPostMessage - -- | -- -- This method returns a list of all users in the team. -- This includes deleted/deactivated users. -- -- - -usersList - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => m (Response User.ListRsp) +usersList :: + (MonadReader env m, HasManager env, HasToken env, MonadIO m) => + m (Response User.ListRsp) usersList = liftNonClassy NonClassy.usersList - -- | -- -- This method returns a list of all users in the team. -- This includes deleted/deactivated users. -- -- - -userLookupByEmail - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => User.Email - -> m (Response User.UserRsp) +userLookupByEmail :: + (MonadReader env m, HasManager env, HasToken env, MonadIO m) => + User.Email -> + m (Response User.UserRsp) userLookupByEmail = liftNonClassy . flip NonClassy.userLookupByEmail - -- | Returns a function to get a username from a 'Common.UserId'. -- Comes in handy to use 'Web.Slack.MessageParser.messageToHtml' -getUserDesc - :: (Common.UserId -> Text) - -- ^ A function to give a default username in case the username is unknown - -> User.ListRsp - -- ^ List of users as known by the slack server. See 'usersList'. - -> (Common.UserId -> Text) - -- ^ A function from 'Common.UserId' to username. +getUserDesc :: + -- | A function to give a default username in case the username is unknown + (Common.UserId -> Text) -> + -- | List of users as known by the slack server. See 'usersList'. + User.ListRsp -> + -- | A function from 'Common.UserId' to username. + (Common.UserId -> Text) getUserDesc unknownUserFn users = let userMap = Map.fromList $ (User.userId &&& User.userName) <$> User.listRspMembers users - in - \userId -> fromMaybe (unknownUserFn userId) $ Map.lookup userId userMap - + in \userId -> fromMaybe (unknownUserFn userId) $ Map.lookup userId userMap -- | Returns an action to send a request to get the history of a conversation. -- -- To fetch all messages in the conversation, run the returned 'LoadPage' action -- repeatedly until it returns an empty list. -conversationsHistoryAll - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => Conversation.HistoryReq - -- ^ The first request to send. _NOTE_: 'Conversation.historyReqCursor' is silently ignored. - -> m (LoadPage m Common.Message) - -- ^ An action which returns a new page of messages every time called. +conversationsHistoryAll :: + (MonadReader env m, HasManager env, HasToken env, MonadIO m) => + -- | The first request to send. _NOTE_: 'Conversation.historyReqCursor' is silently ignored. + Conversation.HistoryReq -> + -- | An action which returns a new page of messages every time called. -- If there are no pages anymore, it returns an empty list. -conversationsHistoryAll = conversationsHistoryAllBy conversationsHistory - + m (LoadPage m Common.Message) +conversationsHistoryAll = fetchAllBy conversationsHistory -- | Returns an action to send a request to get the replies of a conversation. -- @@ -225,26 +202,26 @@ -- of the thread. So every page returned by the 'LoadPage' action includes -- the first message of the thread. You should drop it if you want to -- collect messages in a thread without duplicates. -repliesFetchAll - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => Conversation.RepliesReq - -- ^ The first request to send. _NOTE_: 'Conversation.repliesReqCursor' is silently ignored. - -> m (LoadPage m Common.Message) - -- ^ An action which returns a new page of messages every time called. +repliesFetchAll :: + (MonadReader env m, HasManager env, HasToken env, MonadIO m) => + -- | The first request to send. _NOTE_: 'Conversation.repliesReqCursor' is silently ignored. + Conversation.RepliesReq -> + -- | An action which returns a new page of messages every time called. -- If there are no pages anymore, it returns an empty list. -repliesFetchAll = repliesFetchAllBy conversationsReplies - + m (LoadPage m Common.Message) +repliesFetchAll = fetchAllBy conversationsReplies -liftNonClassy - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => (SlackConfig -> IO a) -> m a +liftNonClassy :: + (MonadReader env m, HasManager env, HasToken env, MonadIO m) => + (SlackConfig -> IO a) -> + m a liftNonClassy f = liftToReader $ \env -> f $ SlackConfig (getManager env) (getToken env) - -liftToReader - :: (MonadReader env m, MonadIO m) - => (env -> IO a) -> m a +liftToReader :: + (MonadReader env m, MonadIO m) => + (env -> IO a) -> + m a liftToReader f = do env <- ask liftIO $ f env diff --git a/src/Web/Slack/Common.hs b/src/Web/Slack/Common.hs --- a/src/Web/Slack/Common.hs +++ b/src/Web/Slack/Common.hs @@ -1,66 +1,65 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} ---------------------------------------------------------------------- + +---------------------------------------------------------------------- + -- | -- Module: Web.Slack.Common -- Description: --- --- --- ----------------------------------------------------------------------- - module Web.Slack.Common - ( Color(..) - , UserId(..) - , ConversationId (..) - , TeamId (..) - , Cursor (..) - , SlackTimestamp(..) - , mkSlackTimestamp - , timestampFromText - , Message(..) - , MessageType(..) - , SlackClientError(..) - , SlackMessageText(..) + ( Color (..), + UserId (..), + ConversationId (..), + TeamId (..), + Cursor (..), + SlackTimestamp (..), + mkSlackTimestamp, + timestampFromText, + Message (..), + MessageType (..), + SlackClientError (..), + SlackMessageText (..), ) - where +where +-- FIXME: Web.Slack.Prelude + -- aeson -import Data.Aeson -import Data.Aeson.TH -- base -import Control.Exception -import GHC.Generics (Generic) -- deepseq import Control.DeepSeq (NFData) - - +import Control.Exception +import Data.Aeson +import Data.Aeson.TH -- servant-client -import Servant.Client -- slack-web -import Web.Slack.Types -import Web.Slack.Util -- text import Data.Text (Text) +import GHC.Generics (Generic) +import Servant.Client +import Web.Slack.Types +import Web.Slack.Util +import Prelude #if !MIN_VERSION_servant(0,16,0) type ClientError = ServantError #endif data MessageType = MessageTypeMessage - deriving (Eq, Show, Generic) + deriving stock (Eq, Show, Generic) instance NFData MessageType @@ -71,16 +70,16 @@ instance ToJSON MessageType where toJSON _ = String "message" -data Message = - Message - { messageType :: MessageType - , messageUser :: Maybe UserId -- ^ not present for bot messages at least - , messageText :: SlackMessageText - -- ^ the message text is in a markdown-like slack-specific format. - -- Use 'Web.Slack.MessageParser.messageToHtml' to convert it to HTML. - , messageTs :: SlackTimestamp - } - deriving (Eq, Generic, Show) +data Message = Message + { messageType :: MessageType + , messageUser :: Maybe UserId + -- ^ not present for bot messages at least + , messageText :: SlackMessageText + -- ^ the message text is in a markdown-like slack-specific format. + -- Use 'Web.Slack.MessageParser.messageToHtml' to convert it to HTML. + , messageTs :: SlackTimestamp + } + deriving stock (Eq, Generic, Show) instance NFData Message @@ -89,11 +88,11 @@ -- | -- Errors that can be triggered by a slack request. data SlackClientError - = ServantError ClientError - -- ^ errors from the network connection - | SlackError Text - -- ^ errors returned by the slack API - deriving (Eq, Generic, Show) + = -- | errors from the network connection + ServantError ClientError + | -- | errors returned by the slack API + SlackError Text + deriving stock (Eq, Generic, Show) instance NFData SlackClientError diff --git a/src/Web/Slack/Conversation.hs b/src/Web/Slack/Conversation.hs --- a/src/Web/Slack/Conversation.hs +++ b/src/Web/Slack/Conversation.hs @@ -2,127 +2,99 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RecordWildCards #-} +-- FIXME: squashes warnings +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} ---------------------------------------------------------------------- + +---------------------------------------------------------------------- + -- | -- Module: Web.Slack.Channel -- Description: Types and functions related to --- --- --- ----------------------------------------------------------------------- - module Web.Slack.Conversation - ( Conversation(..) - , ConversationId(..) - , ConversationType(..) - , ChannelConversation(..) - , GroupConversation(..) - , ImConversation(..) - , TeamId(..) - , Purpose(..) - , Topic(..) - , ListReq(..) - , mkListReq - , ListRsp(..) - , HistoryReq (..) - , mkHistoryReq - , HistoryRsp (..) - , RepliesReq (..) - , mkRepliesReq - , ResponseMetadata (..) - ) where + ( Conversation (..), + ConversationId (..), + ConversationType (..), + ChannelConversation (..), + GroupConversation (..), + ImConversation (..), + TeamId (..), + Purpose (..), + Topic (..), + ListReq (..), + mkListReq, + ListRsp (..), + HistoryReq (..), + mkHistoryReq, + HistoryRsp (..), + RepliesReq (..), + mkRepliesReq, + ResponseMetadata (..), + ) +where --- aeson import Data.Aeson import Data.Aeson.Encoding +import Data.Aeson.KeyMap qualified as KM import Data.Aeson.TH import Data.Aeson.Types - --- unordered-containers -import qualified Data.HashMap.Strict as HM - --- base -import Control.Applicative (empty, (<|>)) -import GHC.Generics (Generic) - --- deepseq -import Control.DeepSeq (NFData) - --- http-api-data +import Data.Scientific +import Data.Text qualified as T import Web.FormUrlEncoded import Web.HttpApiData - --- slack-web import Web.Slack.Common +import Web.Slack.Pager.Types (PagedRequest (..), PagedResponse (..), ResponseMetadata (..)) +import Web.Slack.Prelude import Web.Slack.Util --- scientific -import Data.Scientific - --- text -import Data.Text (Text) -import qualified Data.Text as T - - --- | --- --- -data Topic = - Topic - { topicValue :: Text - , topicCreator :: Text - , topicLastSet :: Integer - } - deriving (Eq, Show, Generic) +data Topic = Topic + { topicValue :: Text + , topicCreator :: Text + , topicLastSet :: Integer + } + deriving stock (Eq, Show, Generic) instance NFData Topic $(deriveJSON (jsonOpts "topic") ''Topic) - --- | --- --- -data Purpose = - Purpose - { purposeValue :: Text - , purposeCreator :: Text - , purposeLastSet :: Integer - } - deriving (Eq, Show, Generic) +data Purpose = Purpose + { purposeValue :: Text + , purposeCreator :: Text + , purposeLastSet :: Integer + } + deriving stock (Eq, Show, Generic) instance NFData Purpose $(deriveJSON (jsonOpts "purpose") ''Purpose) - -- | Conversation object representing a public channel, -- which any people in the team can join in and see. -data ChannelConversation = - ChannelConversation - { channelId :: ConversationId - , channelName :: Text - , channelCreated :: Integer - , channelIsArchived :: Bool - , channelIsGeneral :: Bool - , channelUnlinked :: Integer - , channelNameNormalized :: Text - , channelIsShared :: Bool - - -- FIXME: +data ChannelConversation = ChannelConversation + { channelId :: ConversationId + , channelName :: Text + , channelCreated :: Integer + , channelIsArchived :: Bool + , channelIsGeneral :: Bool + , channelUnlinked :: Integer + , channelNameNormalized :: Text + , channelIsShared :: Bool + , -- FIXME: -- I'm not sure the correct type of this field, because I only found -- example responses whose @parent_conversation@ is @null@ -- , channelParentConversation: null - , channelCreator :: UserId - , channelIsExtShared :: Bool - , channelIsOrgShared :: Bool - , channelSharedTeamIds :: [TeamId] - - -- FIXME: + channelCreator :: UserId + , channelIsExtShared :: Bool + , channelIsOrgShared :: Bool + , channelSharedTeamIds :: Maybe [TeamId] + -- ^ Ironically this has been observed to be absent on real shared-channel + -- responses. + , -- FIXME: -- I'm not sure the correct type of these fields, because I only found -- example responses whose @pending_connected_team_ids@ and -- @pending_shared@ are empty arrays. (Perhaps this is because @@ -131,45 +103,43 @@ -- , channelPendingShared :: [TeamId] -- , channelPendingConnectedTeamIds :: [TeamId] - , channelIsPendingExtShared :: Bool - , channelIsMember :: Bool - , channelTopic :: Topic - , channelPurpose :: Purpose - , channelPreviousNames :: [Text] - , channelNumMembers :: Integer - } - deriving (Eq, Show, Generic) + channelIsPendingExtShared :: Bool + , channelIsMember :: Maybe Bool + -- ^ Absent from @users.conversations@ response + , channelTopic :: Topic + , channelPurpose :: Purpose + , channelPreviousNames :: [Text] + , channelNumMembers :: Maybe Integer + -- ^ Absent from @conversations.join@ response + } + deriving stock (Eq, Show, Generic) instance NFData ChannelConversation $(deriveJSON (jsonOpts "channel") ''ChannelConversation) - -- | Conversation object representing a private channel or -- _a multi-party instant message (mpim)*, which only invited people in the -- team can join in and see. -data GroupConversation = - GroupConversation - { groupId :: ConversationId - , groupName :: Text - , groupCreated :: Integer - , groupIsArchived :: Bool - , groupIsGeneral :: Bool - , groupUnlinked :: Integer - , groupNameNormalized :: Text - , groupIsShared :: Bool - - -- FIXME: +data GroupConversation = GroupConversation + { groupId :: ConversationId + , groupName :: Text + , groupCreated :: Integer + , groupIsArchived :: Bool + , groupIsGeneral :: Bool + , groupUnlinked :: Integer + , groupNameNormalized :: Text + , groupIsShared :: Bool + , -- FIXME: -- I'm not sure the correct type of this field, because I only found -- example responses whose @parent_conversation@ is @null@ -- , groupParentConversation :: null - , groupCreator :: UserId - , groupIsExtShared :: Bool - , groupIsOrgShared :: Bool - , groupSharedTeamIds :: [TeamId] - - -- FIXME: + groupCreator :: UserId + , groupIsExtShared :: Bool + , groupIsOrgShared :: Bool + , groupSharedTeamIds :: [TeamId] + , -- FIXME: -- I'm not sure the correct type of these fields, because I only found -- example responses whose @pending_connected_team_ids@ and -- @pending_shared@ are empty arrays. (Perhaps this is because @@ -178,97 +148,101 @@ -- , group_pending_shared :: [] -- , group_pending_connected_team_ids :: [] - , groupIsPendingExtShared :: Bool - , groupIsMember :: Bool - , groupIsPrivate :: Bool - , groupIsMpim :: Bool - , groupLastRead :: SlackTimestamp - , groupIsOpen :: Bool - , groupTopic :: Topic - , groupPurpose :: Purpose - , groupPriority :: Scientific - } - deriving (Eq, Show, Generic) + groupIsPendingExtShared :: Bool + , groupIsMember :: Bool + , groupIsPrivate :: Bool + , groupIsMpim :: Bool + , groupLastRead :: SlackTimestamp + , groupIsOpen :: Bool + , groupTopic :: Topic + , groupPurpose :: Purpose + , groupPriority :: Scientific + } + deriving stock (Eq, Show, Generic) instance NFData GroupConversation $(deriveJSON (jsonOpts "group") ''GroupConversation) - -- | Conversation object representing a (single-party) instance message, -- where only two people talk. -data ImConversation = - ImConversation - { imId :: ConversationId - , imCreated :: Integer - , imIsArchived :: Bool - , imIsOrgShared :: Bool - , imUser :: UserId - , imIsUserDeleted :: Bool - , imPriority :: Scientific - } - deriving (Eq, Show, Generic) +data ImConversation = ImConversation + { imId :: ConversationId + , imCreated :: Integer + , imIsArchived :: Bool + , imIsOrgShared :: Bool + , imUser :: UserId + , imIsUserDeleted :: Bool + , imPriority :: Scientific + } + deriving stock (Eq, Show, Generic) instance NFData ImConversation $(deriveJSON (jsonOpts "im") ''ImConversation) - -- | Ref. https://api.slack.com/types/conversation --- --- -data Conversation = - Channel ChannelConversation - | Group GroupConversation - | Im ImConversation - deriving (Eq, Show, Generic) +data Conversation + = Channel ChannelConversation + | Group GroupConversation + | Im ImConversation + deriving stock (Eq, Show, Generic) instance NFData Conversation - instance FromJSON Conversation where parseJSON = withObject "Conversation" $ \o -> - parseWhen "is_channel" Channel o - <|> parseWhen "is_group" Group o - <|> parseWhen "is_im" Im o - <|> prependFailure - "parsing a Conversation failed: neither channel, group, nor im, " - (typeMismatch "Conversation" (Object o)) - where - parseWhen key con o = do - is <- (o .: key) <|> empty - if is - then con <$> parseJSON (Object o) - else empty + fromMaybe (noneMatched o) + =<< parseWhen "is_channel" Channel o + `parseOr` parseWhen "is_group" Group o + `parseOr` parseWhen "is_im" Im o + where + noneMatched o = + prependFailure + "parsing a Conversation failed: neither channel, group, nor im: " + (typeMismatch "Conversation" (Object o)) + -- '(<|>)' that pierces one layer of 'Monad' first + parseOr :: (Monad m, Alternative a) => m (a b) -> m (a b) -> m (a b) + parseOr = liftM2 (<|>) + -- This uses the outer Parser monad since deciding which parser to use + -- is monadic, then the Maybe to decide which parser is picked, then + -- finally the inner parser to actually run it + parseWhen :: FromJSON a => Key -> (a -> b) -> Object -> Parser (Maybe (Parser b)) + parseWhen key con o = do + -- Slack only inconsistently includes the is_* attributes if false. + is <- o .:? key .!= False + if is + then pure . Just $ con <$> parseJSON (Object o) + else pure $ Nothing + instance ToJSON Conversation where toJSON (Channel channel) = let (Object obj) = toJSON channel in Object - . HM.insert "is_channel" (Bool True) - . HM.insert "is_group" (Bool False) - $ HM.insert "is_im" (Bool False) obj - toJSON (Group group) = - let (Object obj) = toJSON group + . KM.insert "is_channel" (Bool True) + . KM.insert "is_group" (Bool False) + $ KM.insert "is_im" (Bool False) obj + toJSON (Group theGroup) = + let (Object obj) = toJSON theGroup in Object - . HM.insert "is_channel" (Bool False) - . HM.insert "is_group" (Bool True) - $ HM.insert "is_im" (Bool False) obj + . KM.insert "is_channel" (Bool False) + . KM.insert "is_group" (Bool True) + $ KM.insert "is_im" (Bool False) obj toJSON (Im im) = let (Object obj) = toJSON im in Object - . HM.insert "is_channel" (Bool False) - . HM.insert "is_group" (Bool False) - $ HM.insert "is_im" (Bool True) obj - + . KM.insert "is_channel" (Bool False) + . KM.insert "is_group" (Bool False) + $ KM.insert "is_im" (Bool True) obj -data ConversationType = - PublicChannelType +data ConversationType + = PublicChannelType | PrivateChannelType | MpimType | ImType - deriving (Eq, Show, Generic) + deriving stock (Eq, Show, Generic) instance NFData ConversationType @@ -290,99 +264,91 @@ "im" -> pure ImType actual -> prependFailure "must be either \"public_channel\", \"private_channel\", \"mpim\" or \"im\"!" - . typeMismatch "ConversationType" $ String actual - - + . typeMismatch "ConversationType" + $ String actual -data ListReq = - ListReq - { listReqExcludeArchived :: Maybe Bool - , listReqTypes :: [ConversationType] - } - deriving (Eq, Show, Generic) +data ListReq = ListReq + { listReqExcludeArchived :: Maybe Bool + , listReqTypes :: [ConversationType] + , listReqCursor :: Maybe Cursor + , listReqLimit :: Maybe Int + , listReqTeamId :: Maybe TeamId + } + deriving stock (Eq, Show, Generic) instance NFData ListReq - --- | --- --- - $(deriveJSON (jsonOpts "listReq") ''ListReq) --- | --- --- - -mkListReq - :: ListReq +mkListReq :: + ListReq mkListReq = ListReq { listReqExcludeArchived = Nothing , listReqTypes = [] + , listReqLimit = Nothing + , listReqTeamId = Nothing + , listReqCursor = Nothing } - --- | --- --- - instance ToForm ListReq where - toForm (ListReq archived types) = - archivedForm <> typesForm - where - archivedForm = - maybe mempty (\val -> [("archived", toUrlPiece val)]) archived - typesForm = - if null types - then mempty - else [("types", T.intercalate "," $ map toUrlPiece types)] - - --- | --- + toForm + ( ListReq + { listReqExcludeArchived + , listReqTypes = types + , listReqTeamId + , listReqCursor + , listReqLimit + } + ) = + archivedForm + <> typesForm + <> toQueryParamIfJust "team_id" listReqTeamId + <> toQueryParamIfJust "cursor" listReqCursor + <> toQueryParamIfJust "limit" listReqLimit + where + archivedForm = + maybe mempty (\val -> [("exclude_archived", toUrlPiece val)]) listReqExcludeArchived + typesForm = + if null types + then mempty + else [("types", T.intercalate "," $ map toUrlPiece types)] -newtype ListRsp = - ListRsp - { listRspChannels :: [Conversation] - } - deriving (Eq, Show, Generic) +data ListRsp = ListRsp + { listRspChannels :: [Conversation] + , listRspResponseMetadata :: Maybe ResponseMetadata + } + deriving stock (Eq, Show, Generic) instance NFData ListRsp $(deriveFromJSON (jsonOpts "listRsp") ''ListRsp) --- | --- --- +instance PagedRequest ListReq where + setCursor c r = r {listReqCursor = c} -data HistoryReq = - HistoryReq - { historyReqChannel :: ConversationId - , historyReqCursor :: Maybe Cursor - , historyReqCount :: Int - , historyReqLatest :: Maybe SlackTimestamp - , historyReqOldest :: Maybe SlackTimestamp - , historyReqInclusive :: Bool - } - deriving (Eq, Show, Generic) +instance PagedResponse ListRsp where + type ResponseObject ListRsp = Conversation + getResponseData ListRsp {listRspChannels} = listRspChannels + getResponseMetadata ListRsp {listRspResponseMetadata} = listRspResponseMetadata -instance NFData HistoryReq +data HistoryReq = HistoryReq + { historyReqChannel :: ConversationId + , historyReqCursor :: Maybe Cursor + , historyReqCount :: Int + , historyReqLatest :: Maybe SlackTimestamp + , historyReqOldest :: Maybe SlackTimestamp + , historyReqInclusive :: Bool + } + deriving stock (Eq, Show, Generic) --- | --- --- +instance NFData HistoryReq $(deriveJSON (jsonOpts "historyReq") ''HistoryReq) - --- | --- --- - -mkHistoryReq - :: ConversationId - -> HistoryReq +mkHistoryReq :: + ConversationId -> + HistoryReq mkHistoryReq channel = HistoryReq { historyReqChannel = channel @@ -393,13 +359,9 @@ , historyReqInclusive = True } --- | --- --- - instance ToForm HistoryReq where -- can't use genericToForm because slack expects booleans as 0/1 - toForm HistoryReq{..} = + toForm HistoryReq {..} = [("channel", toQueryParam historyReqChannel)] <> toQueryParamIfJust "cursor" historyReqCursor <> [("count", toQueryParam historyReqCount)] @@ -407,46 +369,35 @@ <> toQueryParamIfJust "oldest" historyReqOldest <> [("inclusive", toQueryParam (if historyReqInclusive then 1 :: Int else 0))] - --- | --- --- -newtype ResponseMetadata = ResponseMetadata { responseMetadataNextCursor :: Maybe Cursor } - deriving (Eq, Show, Generic) - -instance NFData ResponseMetadata - -$(deriveJSON (jsonOpts "responseMetadata") ''ResponseMetadata) - - --- | --- --- - -data HistoryRsp = - HistoryRsp - { historyRspMessages :: [Message] - , historyRspResponseMetadata :: Maybe ResponseMetadata - } - deriving (Eq, Show, Generic) +data HistoryRsp = HistoryRsp + { historyRspMessages :: [Message] + , historyRspResponseMetadata :: Maybe ResponseMetadata + } + deriving stock (Eq, Show, Generic) instance NFData HistoryRsp $(deriveJSON (jsonOpts "historyRsp") ''HistoryRsp) +instance PagedRequest HistoryReq where + setCursor c r = r {historyReqCursor = c} -data RepliesReq = - RepliesReq - { repliesReqTs :: SlackTimestamp - , repliesReqCursor :: Maybe Cursor - , repliesReqChannel :: ConversationId - , repliesReqLimit :: Int - , repliesReqLatest :: Maybe SlackTimestamp - , repliesReqOldest :: Maybe SlackTimestamp - , repliesReqInclusive :: Bool - } - deriving (Eq, Show, Generic) +instance PagedResponse HistoryRsp where + type ResponseObject HistoryRsp = Message + getResponseMetadata HistoryRsp {historyRspResponseMetadata} = historyRspResponseMetadata + getResponseData HistoryRsp {historyRspMessages} = historyRspMessages +data RepliesReq = RepliesReq + { repliesReqTs :: SlackTimestamp + , repliesReqCursor :: Maybe Cursor + , repliesReqChannel :: ConversationId + , repliesReqLimit :: Int + , repliesReqLatest :: Maybe SlackTimestamp + , repliesReqOldest :: Maybe SlackTimestamp + , repliesReqInclusive :: Bool + } + deriving stock (Eq, Show, Generic) + instance NFData RepliesReq $(deriveJSON (jsonOpts "repliesReq") ''RepliesReq) @@ -462,15 +413,13 @@ <> toQueryParamIfJust "oldest" repliesReqOldest <> [("inclusive", toQueryParam (if repliesReqInclusive then 1 :: Int else 0))] - --- | --- --- +instance PagedRequest RepliesReq where + setCursor c r = r {repliesReqCursor = c} -mkRepliesReq - :: ConversationId - -> SlackTimestamp - -> RepliesReq +mkRepliesReq :: + ConversationId -> + SlackTimestamp -> + RepliesReq mkRepliesReq channel ts = RepliesReq { repliesReqChannel = channel diff --git a/src/Web/Slack/Experimental/Blocks.hs b/src/Web/Slack/Experimental/Blocks.hs new file mode 100644 --- /dev/null +++ b/src/Web/Slack/Experimental/Blocks.hs @@ -0,0 +1,204 @@ +module Web.Slack.Experimental.Blocks + ( -- * General Slack Messages + SlackText, + (<+>), + parens, + brackets, + angleBrackets, + ticks, + codeBlock, + bold, + italic, + newline, + unorderedList, + link, + monospaced, + mentionUser, + isSubStringOf, + SlackImage (..), + SlackMessage, + Markdown (..), + Image (..), + context, + textToMessage, + prefixFirstSlackMessage, + mentionUserGroupById, + textToContext, + slackMessage, + SlackBlock (..), + + -- ** Blocks' rich text formatting (receive only!) + RichItem (..), + RichStyle (..), + RichLinkAttrs (..), + RichTextSectionItem (..), + RichText (..), + + -- * Rendered messages + RenderedSlackMessage (..), + render, + + -- * Introduction to Slack Interactive Messages + -- $interactive + + -- * Creating Slack Interactive Messages + actions, + actionsWithBlockId, + SlackActionId (..), + SlackBlockId, + setting, + emptySetting, + SlackStyle (..), + plaintext, + plaintextonly, + mrkdwn, + button, + buttonSettings, + ButtonSettings + ( buttonUrl, + buttonValue, + buttonStyle, + buttonConfirm + ), + confirm, + confirmAreYouSure, + ConfirmSettings + ( confirmTitle, + confirmText, + confirmConfirm, + confirmDeny, + confirmStyle + ), + + -- * Responding to Slack Interactive Messages + SlackInteractiveResponse (..), + ) +where + +import Data.Aeson.Text (encodeToLazyText) +import Data.Text qualified as T +import Web.Slack.Experimental.Blocks.Types +import Web.Slack.Prelude +import Web.Slack.Types + +(<+>) :: SlackText -> SlackText -> SlackText +x <+> y = x <> " " <> y + +parens :: SlackText -> SlackText +parens x = "(" <> x <> ")" + +brackets :: SlackText -> SlackText +brackets x = "[" <> x <> "]" + +angleBrackets :: SlackText -> SlackText +angleBrackets x = "<" <> x <> ">" + +ticks :: SlackText -> SlackText +ticks x = "`" <> x <> "`" + +-- | Render a 'Slack' renderable value with ticks around it. Alias for @ticks . message@ +monospaced :: Slack a => a -> SlackText +monospaced = ticks . message + +codeBlock :: SlackText -> SlackText +codeBlock x = "```\n" <> x <> "\n```" + +bold :: SlackText -> SlackText +bold x = "*" <> x <> "*" + +italic :: SlackText -> SlackText +italic x = "_" <> x <> "_" + +newline :: SlackText -> SlackText +newline x = "\n" <> x + +-- | Render an unordered (bulleted) list +unorderedList :: [SlackText] -> SlackText +unorderedList = mconcat . fmap (\t -> newline (message @Text "- " <> t)) + +-- | https://api.slack.com/reference/surfaces/formatting#mentioning-users +mentionUser :: UserId -> SlackText +mentionUser slackUserId = message $ "<@" <> unUserId slackUserId <> ">" + +-- | https://api.slack.com/reference/surfaces/formatting#mentioning-groups +mentionUserGroupById :: SlackText -> SlackText +mentionUserGroupById userGroupId = angleBrackets $ "!subteam^" <> userGroupId + +isSubStringOf :: Text -> SlackText -> Bool +needle `isSubStringOf` (SlackText haystack) = needle `isInfixOf` concat haystack + +-- | RenderedSlackMessage contains the original SlackMessage, the rendered version, and a +-- boolean indicating whether truncation was done. +-- +-- Usage: +-- +-- @ +-- let +-- msg = +-- (mkPostMsgReq channel "") +-- { postMsgReqBlocks = Just blocks +-- , postMsgReqThreadTs = mThreadTs +-- } +-- chatPostMessage msg +-- @ +data RenderedSlackMessage = RenderedSlackMessage + { _originalMessage :: SlackMessage + , _renderedMessage :: Text + , _truncated :: Bool + } + +render :: SlackMessage -> RenderedSlackMessage +render sm = + let (truncatedSm, isTruncated) = truncateSlackMessage sm + in RenderedSlackMessage sm (cs . encodeToLazyText . toJSON $ truncatedSm) isTruncated + +-- | Slack will fail if any text block is over 3000 chars. +-- truncateSlackMessage will truncate all text blocks and also return an bool +-- indicating whether any truncation was done. +truncateSlackMessage :: SlackMessage -> (SlackMessage, Bool) +truncateSlackMessage (SlackMessage blocks) = + let (truncatedBlocks, isTruncateds) = unzip $ map truncateSlackBlock blocks + in (SlackMessage truncatedBlocks, or isTruncateds) + +truncateSlackBlock :: SlackBlock -> (SlackBlock, Bool) +truncateSlackBlock sb@(SlackBlockSection (SlackText texts) mAccessory) = + let messageLength = sum $ map T.length texts + lengthLimit = 3000 + truncationMessage = "\n...Rest of message truncated for slack\n" + truncationMessageLength = T.length truncationMessage + truncateTexts ts = take (lengthLimit - truncationMessageLength) (concat ts) + in if messageLength > lengthLimit + then (SlackBlockSection (SlackText [truncateTexts texts <> "\n...Rest of message truncated for slack\n"]) mAccessory, True) + else (sb, False) +-- possible to also truncate SlackContexts, but we never put long strings in there. +truncateSlackBlock x = (x, False) + +prefixFirstSlackBlockSection :: Text -> [SlackBlock] -> ([SlackBlock], Bool) +prefixFirstSlackBlockSection prefix (SlackBlockSection text mAccessory : sbs) = (SlackBlockSection (message prefix <> text) mAccessory : sbs, True) +prefixFirstSlackBlockSection prefix (sb : sbs) = let (prefixedSbs, match) = prefixFirstSlackBlockSection prefix sbs in (sb : prefixedSbs, match) +prefixFirstSlackBlockSection _ [] = ([], False) + +prefixFirstSlackMessage :: Text -> [SlackMessage] -> [SlackMessage] +prefixFirstSlackMessage prefix (sm : sms) = + let SlackMessage slackBlocks = sm + (prefixedSlackBlocks, match) = prefixFirstSlackBlockSection prefix slackBlocks + in if match + then SlackMessage prefixedSlackBlocks : sms + else sm : prefixFirstSlackMessage prefix sms +prefixFirstSlackMessage _ [] = [] + +-- | Concatenate a list of 'SlackText' into a single block, and wrap it up as a full message +slackMessage :: [SlackText] -> SlackMessage +slackMessage = SlackMessage . pure . (`SlackBlockSection` Nothing) . mconcat + +-- $interactive +-- +-- = Slack Interactive Messages +-- +-- First, familiarize yourself with [Slack's Interactivity documentation](https://api.slack.com/interactivity). +-- Currently we only support [Block Kit interactive components](https://api.slack.com/interactivity/components), +-- i.e. components like buttons attached to messages. +-- +-- To make an Slack message interactive, you need to include an \"Actions\" block that has one or more interactive components. +-- These should generally only be created using the builder functions such as 'actions' and 'button'. Consumers of this module +-- should avoid directly importing "Web.Slack.Experimental.Blocks.Types". diff --git a/src/Web/Slack/Experimental/Blocks/Types.hs b/src/Web/Slack/Experimental/Blocks/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/Slack/Experimental/Blocks/Types.hs @@ -0,0 +1,756 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} + +module Web.Slack.Experimental.Blocks.Types where + +import Control.Monad (MonadFail (..)) +import Data.Aeson (Object, Value (..), withArray) +import Data.Aeson.Types ((.!=)) +import Data.StringVariants +import Data.Vector qualified as V +import Refined +import Refined.Unsafe (reallyUnsafeRefine) +import Web.Slack.AesonUtils +import Web.Slack.Common (ConversationId, UserId) +import Web.Slack.Prelude + +-- | Class of types that can be turned into part of a Slack Message. 'message' +-- is the primary way of converting primitive and domain-level types into things +-- that can be shown in a slack message. +class Slack a where + message :: a -> SlackText + +newtype SlackText = SlackText {unSlackTexts :: [Text]} + deriving newtype (Semigroup, Monoid, Eq) + +-- | Render a link with optional link text +link :: Text -> Maybe Text -> SlackText +link uri = \case + Nothing -> message $ "<" <> uri <> ">" + Just linkText -> message $ "<" <> uri <> "|" <> linkText <> ">" + +data SlackPlainTextOnly = SlackPlainTextOnly SlackText + deriving stock (Eq, Show) + +instance IsString SlackPlainTextOnly where + fromString = SlackPlainTextOnly . message + +instance ToJSON SlackPlainTextOnly where + toJSON (SlackPlainTextOnly (SlackText arr)) = + object + [ "type" .= ("plain_text" :: Text) + , "text" .= intercalate "\n" arr + ] + +instance FromJSON SlackPlainTextOnly where + parseJSON = withObject "SlackPlainTextOnly" $ \obj -> do + text <- obj .: "text" + pure . SlackPlainTextOnly . SlackText $ lines text + +-- | Create a 'SlackPlainTextOnly'. Some API points can can take either markdown or plain text, +-- but some can take only plain text. This enforces the latter. +plaintextonly :: Slack a => a -> SlackPlainTextOnly +plaintextonly a = SlackPlainTextOnly $ message a + +data SlackTextObject + = SlackPlainText SlackText + | SlackMarkdownText SlackText + deriving stock (Eq, Show) + +instance ToJSON SlackTextObject where + toJSON (SlackPlainText (SlackText arr)) = + object + [ "type" .= ("plain_text" :: Text) + , "text" .= intercalate "\n" arr + ] + toJSON (SlackMarkdownText (SlackText arr)) = + object + [ "type" .= ("mrkdwn" :: Text) + , "text" .= intercalate "\n" arr + ] + +-- | Create a plain text 'SlackTextObject' where the API allows either markdown or plain text. +plaintext :: Slack a => a -> SlackTextObject +plaintext = SlackPlainText . message + +-- | Create a markdown 'SlackTextObject' where the API allows either markdown or plain text. +mrkdwn :: Slack a => a -> SlackTextObject +mrkdwn = SlackMarkdownText . message + +instance FromJSON SlackTextObject where + parseJSON = withObject "SlackTextObject" $ \obj -> do + (slackTextType :: Text) <- obj .: "type" + case slackTextType of + "text" -> do + text <- obj .: "text" + pure . SlackPlainText . SlackText $ lines text + "mrkdwn" -> do + text <- obj .: "text" + pure . SlackMarkdownText . SlackText $ lines text + _ -> fail "Unknown SlackTextObject type, must be one of ['text', 'mrkdwn']" + +instance Show SlackText where + show (SlackText arr) = show $ concat arr + +instance ToJSON SlackText where + toJSON (SlackText arr) = toJSON $ concat arr + +instance IsString SlackText where + fromString = message + +instance Slack Text where + message text = SlackText [text] + +instance Slack String where + message = message @Text . pack + +instance Slack Int where + message = message . show + +-- | Represents an optional setting for some Slack Setting. +newtype OptionalSetting a = OptionalSetting {unOptionalSetting :: Maybe a} + deriving newtype (Eq) + +-- | Allows using bare Strings without having to use 'setting' +instance IsString (OptionalSetting String) where + fromString = OptionalSetting . Just + +-- | Allows using bare Texts without having to use 'setting' +instance IsString (OptionalSetting Text) where + fromString = OptionalSetting . Just . pack + +-- | Sets a setting. +setting :: a -> OptionalSetting a +setting = OptionalSetting . Just + +-- | Sets the empty setting. +emptySetting :: OptionalSetting a +emptySetting = OptionalSetting Nothing + +-- | Styles for Slack [buttons](https://api.slack.com/reference/block-kit/block-elements#button). +-- If no style is given, the default style (black) is used. +data SlackStyle + = -- | Green button + SlackStylePrimary + | -- | Red button + SlackStyleDanger + deriving stock (Eq, Show) + +$(deriveJSON (jsonDeriveWithAffix "SlackStyle" jsonDeriveOptionsSnakeCase) ''SlackStyle) + +-- | Used to identify an action. The ID used should be unique among all actions in the block. +-- +-- This is limited to 255 characters, per the Slack documentation at +-- +newtype SlackActionId = SlackActionId {unSlackActionId :: NonEmptyText 255} + deriving stock (Show, Eq) + deriving newtype (FromJSON, ToJSON) + +-- FIXME(jadel): SlackActionId might be worth turning into something more type +-- safe: possibly parameterize SlackAction over a sum type parameter + +data SlackImage = SlackImage + { slackImageTitle :: !(Maybe Text) + , slackImageAltText :: !Text + -- ^ Optional Title + , slackImageUrl :: !Text + } + deriving stock (Eq) + +instance Show SlackImage where + show (SlackImage _ altText _) = unpack altText + +data SlackContent + = SlackContentText SlackText + | SlackContentImage SlackImage + deriving stock (Eq) + +instance Show SlackContent where + show (SlackContentText t) = show t + show (SlackContentImage i) = show i + +instance ToJSON SlackContent where + toJSON (SlackContentText t) = + object + [ "type" .= ("mrkdwn" :: Text) + , "text" .= t + ] + toJSON (SlackContentImage (SlackImage mtitle altText url)) = + object $ + [ "type" .= ("image" :: Text) + , "image_url" .= url + , "alt_text" .= altText + ] + <> maybe [] mkTitle mtitle + where + mkTitle title = + [ "title" + .= object + [ "type" .= ("plain_text" :: Text) + , "text" .= title + ] + ] + +instance FromJSON SlackContent where + parseJSON = withObject "SlackContent" $ \obj -> do + (slackContentType :: Text) <- obj .: "type" + case slackContentType of + "mrkdwn" -> do + (slackContentText :: String) <- obj .: "text" + pure $ SlackContentText $ fromString slackContentText + "image" -> do + (slackImageUrl :: Text) <- obj .: "image_url" + (slackImageAltText :: Text) <- obj .: "alt_text" + (slackImageTitleObj :: Maybe Object) <- obj .:? "title" + (slackImageTitleText :: Maybe Text) <- case slackImageTitleObj of + Just innerObj -> innerObj .: "text" + Nothing -> pure Nothing + pure $ SlackContentImage $ SlackImage slackImageTitleText slackImageAltText slackImageUrl + _ -> fail "Unknown SlackContent type, must be one of ['mrkdwn', 'image']" + +newtype SlackContext = SlackContext [SlackContent] + deriving newtype (Semigroup, Monoid, Eq) + +instance Show SlackContext where + show (SlackContext arr) = show arr + +instance ToJSON SlackContext where + toJSON (SlackContext arr) = toJSON arr + +instance FromJSON SlackContext where + parseJSON = withArray "SlackContext" $ \arr -> do + (parsedAsArrayOfSlackContents :: V.Vector SlackContent) <- traverse parseJSON arr + let slackContentList = V.toList parsedAsArrayOfSlackContents + pure $ SlackContext slackContentList + +type SlackActionListConstraints = SizeGreaterThan 0 && SizeLessThan 6 + +-- | List that enforces that Slack actions must have between 1 and 5 actions. +newtype SlackActionList = SlackActionList {unSlackActionList :: Refined SlackActionListConstraints [SlackAction]} + deriving stock (Show) + deriving newtype (Eq, FromJSON, ToJSON) + +-- | Helper to allow using up to a 5-tuple for a 'SlackActionList' +class ToSlackActionList a where + toSlackActionList :: a -> SlackActionList + +instance ToSlackActionList SlackActionList where + toSlackActionList = id + +instance ToSlackActionList SlackAction where + toSlackActionList a = SlackActionList $ reallyUnsafeRefine [a] + +instance ToSlackActionList (SlackAction, SlackAction) where + toSlackActionList (a, b) = SlackActionList $ reallyUnsafeRefine [a, b] + +instance ToSlackActionList (SlackAction, SlackAction, SlackAction) where + toSlackActionList (a, b, c) = SlackActionList $ reallyUnsafeRefine [a, b, c] + +instance ToSlackActionList (SlackAction, SlackAction, SlackAction, SlackAction) where + toSlackActionList (a, b, c, d) = SlackActionList $ reallyUnsafeRefine [a, b, c, d] + +instance ToSlackActionList (SlackAction, SlackAction, SlackAction, SlackAction, SlackAction) where + toSlackActionList (a, b, c, d, e) = SlackActionList $ reallyUnsafeRefine [a, b, c, d, e] + +-- | A rich text style. You can't actually send these, for some reason. +data RichStyle = RichStyle + { rsBold :: Bool + , rsItalic :: Bool + } + deriving stock (Eq, Show) + +instance Semigroup RichStyle where + a <> b = RichStyle {rsBold = rsBold a || rsBold b, rsItalic = rsItalic a || rsItalic b} + +instance Monoid RichStyle where + mempty = RichStyle {rsBold = False, rsItalic = False} + +instance FromJSON RichStyle where + parseJSON = withObject "RichStyle" \obj -> do + rsBold <- obj .:? "bold" .!= False + rsItalic <- obj .:? "italic" .!= False + pure RichStyle {..} + +data RichLinkAttrs = RichLinkAttrs + { style :: RichStyle + , url :: Text + , text :: Maybe Text + -- ^ Probably is empty in the case of links that are just the URL + } + deriving stock (Eq, Show) + +-- | Seemingly only documented at +-- +-- +-- They warn of undocumented element types. Joy. +data RichItem + = RichItemText Text RichStyle + | RichItemChannel ConversationId + | RichItemUser UserId RichStyle + | RichItemLink RichLinkAttrs + | RichItemEmoji Text + | RichItemOther Text Value + -- FIXME(jadel): date, usergroup, team, broadcast + deriving stock (Eq, Show) + +instance FromJSON RichItem where + parseJSON = withObject "RichItem" \obj -> do + kind :: Text <- obj .: "type" + case kind of + "text" -> do + style <- obj .:? "style" .!= mempty + text <- obj .: "text" + pure $ RichItemText text style + "channel" -> do + channelId <- obj .: "chanel_id" + pure $ RichItemChannel channelId + "emoji" -> do + name <- obj .: "name" + pure $ RichItemEmoji name + "link" -> do + url <- obj .: "url" + text <- obj .:? "text" + style <- obj .:? "style" .!= mempty + pure $ RichItemLink RichLinkAttrs {..} + "user" -> do + userId <- obj .: "user_id" + style <- obj .:? "style" .!= mempty + pure $ RichItemUser userId style + _ -> pure $ RichItemOther kind (Object obj) + +data RichTextSectionItem + = RichTextSectionItemRichText [RichItem] + | RichTextSectionItemUnknown Text Value + deriving stock (Eq, Show) + +instance FromJSON RichTextSectionItem where + parseJSON = withObject "RichTextSectionItem" \obj -> do + kind <- obj .: "type" + case kind of + "rich_text_section" -> do + elts <- obj .: "elements" + pure $ RichTextSectionItemRichText elts + _ -> pure $ RichTextSectionItemUnknown kind (Object obj) + +data RichText = RichText + { blockId :: Maybe SlackBlockId + , elements :: [RichTextSectionItem] + } + deriving stock (Eq, Show) + +instance FromJSON RichText where + parseJSON = withObject "RichText" \obj -> do + blockId <- obj .:? "block_id" + elements <- obj .: "elements" + pure RichText {..} + +-- | Accessory is a type of optional block element that floats to the right of text in a BlockSection. +-- +data SlackAccessory + = SlackButtonAccessory SlackAction -- button + deriving stock (Eq) + +instance ToJSON SlackAccessory where + toJSON (SlackButtonAccessory btn) = toJSON btn + +instance FromJSON SlackAccessory where + parseJSON v = SlackButtonAccessory <$> parseJSON v + +instance Show SlackAccessory where + show (SlackButtonAccessory btn) = show btn + +-- | Small helper function for constructing a section with a button accessory out of a button and text components +sectionWithButtonAccessory :: SlackAction -> SlackText -> SlackBlock +sectionWithButtonAccessory btn txt = SlackBlockSection txt (Just $ SlackButtonAccessory btn) + +data SlackBlock + = SlackBlockSection SlackText (Maybe SlackAccessory) + | SlackBlockImage SlackImage + | SlackBlockContext SlackContext + | SlackBlockDivider + | SlackBlockRichText RichText + | SlackBlockActions (Maybe SlackBlockId) SlackActionList -- 1 to 5 elements + | SlackBlockHeader SlackPlainTextOnly -- max length 150 + deriving stock (Eq) + +instance Show SlackBlock where + show (SlackBlockSection t Nothing) = show t + show (SlackBlockSection t (Just mAccessory)) = + show $ mconcat [show t, " [", show mAccessory, "]"] + show (SlackBlockImage i) = show i + show (SlackBlockContext contents) = show contents + show SlackBlockDivider = "|" + show (SlackBlockActions mBlockId as) = + show $ + mconcat + [ "actions(" + , show mBlockId + , ") = [" + , show $ intercalate ", " (map show (unrefine $ unSlackActionList as)) + , "]" + ] + show (SlackBlockRichText rt) = show rt + show (SlackBlockHeader p) = show p + +instance ToJSON SlackBlock where + toJSON (SlackBlockSection slackText mSectionAccessory) = + objectOptional + [ "type" .=! ("section" :: Text) + , "text" .=! SlackContentText slackText + , "accessory" .=? mSectionAccessory + ] + toJSON (SlackBlockImage i) = toJSON (SlackContentImage i) + toJSON (SlackBlockContext contents) = + object + [ "type" .= ("context" :: Text) + , "elements" .= contents + ] + toJSON SlackBlockDivider = + object + [ "type" .= ("divider" :: Text) + ] + toJSON (SlackBlockActions mBlockId as) = + objectOptional + [ "type" .=! ("actions" :: Text) + , "block_id" .=? mBlockId + , "elements" .=! as + ] + -- FIXME(jadel): should this be an error? Slack doesn't accept these + toJSON (SlackBlockRichText _) = + object [] + toJSON (SlackBlockHeader slackPlainText) = + object + [ "type" .= ("header" :: Text) + , "text" .= slackPlainText + ] + +instance FromJSON SlackBlock where + parseJSON = withObject "SlackBlock" $ \obj -> do + (slackBlockType :: Text) <- obj .: "type" + case slackBlockType of + "section" -> do + (sectionContentObj :: Value) <- obj .: "text" + SlackContentText sectionContentText <- parseJSON sectionContentObj + mSectionAccessory <- obj .:? "accessory" + pure $ SlackBlockSection sectionContentText mSectionAccessory + "context" -> do + (contextElementsObj :: Value) <- obj .: "elements" + slackContent <- parseJSON contextElementsObj + pure $ SlackBlockContext slackContent + "image" -> do + SlackContentImage i <- parseJSON $ Object obj + pure $ SlackBlockImage i + "divider" -> pure SlackBlockDivider + "actions" -> do + slackActions <- obj .: "elements" + mBlockId <- obj .:? "block_id" + pure $ SlackBlockActions mBlockId slackActions + "rich_text" -> do + elements <- obj .: "elements" + mBlockId <- obj .:? "block_id" + pure . SlackBlockRichText $ + RichText + { blockId = mBlockId + , elements + } + "header" -> do + (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']" + +newtype SlackMessage = SlackMessage [SlackBlock] + deriving newtype (Semigroup, Monoid, Eq) + +instance Show SlackMessage where + show (SlackMessage arr) = intercalate " " (map show arr) + +instance ToJSON SlackMessage where + toJSON (SlackMessage arr) = toJSON arr + +instance FromJSON SlackMessage where + parseJSON = withArray "SlackMessage" $ \arr -> do + (parsedAsArrayOfSlackBlocks :: V.Vector SlackBlock) <- traverse parseJSON arr + let slackBlockList = V.toList parsedAsArrayOfSlackBlocks + pure $ SlackMessage slackBlockList + +textToMessage :: Text -> SlackMessage +textToMessage = markdown . message + +class Markdown a where + markdown :: SlackText -> a + +instance Markdown SlackMessage where + markdown t = SlackMessage [SlackBlockSection t Nothing] + +instance Markdown SlackContext where + markdown t = SlackContext [SlackContentText t] + +class Image a where + image :: SlackImage -> a + +instance Image SlackMessage where + image i = SlackMessage [SlackBlockImage i] + +instance Image SlackContext where + image i = SlackContext [SlackContentImage i] + +context :: SlackContext -> SlackMessage +context c = SlackMessage [SlackBlockContext c] + +textToContext :: Text -> SlackMessage +textToContext = context . markdown . message + +-- | Generates interactive components such as buttons. +actions :: ToSlackActionList as => as -> SlackMessage +actions as = SlackMessage [SlackBlockActions Nothing $ toSlackActionList as] + +-- | Generates interactive components such as buttons with a 'SlackBlockId'. +actionsWithBlockId :: ToSlackActionList as => SlackBlockId -> as -> SlackMessage +actionsWithBlockId slackBlockId as = SlackMessage [SlackBlockActions (Just slackBlockId) $ toSlackActionList as] + +-- | Settings for [button elements](https://api.slack.com/reference/block-kit/block-elements#button). +data ButtonSettings = ButtonSettings + { buttonUrl :: OptionalSetting (NonEmptyText 3000) + -- ^ Optional URL to load into the user's browser. + -- However, Slack will still call the webhook and you must send an acknowledgement response. + , buttonValue :: OptionalSetting (NonEmptyText 2000) + -- ^ Optional value to send with the interaction payload. + -- One commoon use is to send state via JSON encoding. + , buttonStyle :: OptionalSetting SlackStyle + -- ^ Optional 'SlackStyle'. If not provided, uses the default style which is a black button. + , buttonConfirm :: OptionalSetting SlackConfirmObject + -- ^ An optional confirmation dialog to display. + } + +-- | Default button settings. +buttonSettings :: ButtonSettings +buttonSettings = + ButtonSettings + { buttonUrl = emptySetting + , buttonValue = emptySetting + , buttonStyle = emptySetting + , buttonConfirm = emptySetting + } + +-- | Button builder. +button :: SlackActionId -> SlackButtonText -> ButtonSettings -> SlackAction +button actionId buttonText ButtonSettings {..} = + SlackAction actionId $ + SlackButton + { slackButtonText = buttonText + , slackButtonUrl = unOptionalSetting buttonUrl + , slackButtonValue = unOptionalSetting buttonValue + , slackButtonStyle = unOptionalSetting buttonStyle + , slackButtonConfirm = unOptionalSetting buttonConfirm + } + +-- | Settings for [confirmation dialog objects](https://api.slack.com/reference/block-kit/composition-objects#confirm). +data ConfirmSettings = ConfirmSettings + { confirmTitle :: Text + -- ^ Plain text title for the dialog window. Max length 100 characters. + , confirmText :: Text + -- ^ Markdown explanatory text that appears in the confirm dialog. + -- Max length is 300 characters. + , confirmConfirm :: Text + -- ^ Plain text to display in the \"confirm\" button. + -- Max length is 30 characters. + , confirmDeny :: Text + -- ^ Plain text to display in the \"deny\" button. + -- Max length is 30 characters. + , confirmStyle :: OptionalSetting SlackStyle + -- ^ Optional 'SlackStyle' to use for the \"confirm\" button. + } + +-- | Default settings for a \"Are you sure?\" confirmation dialog. +confirmAreYouSure :: ConfirmSettings +confirmAreYouSure = + ConfirmSettings + { confirmTitle = "Are You Sure?" + , confirmText = "Are you sure you wish to perform this operation?" + , confirmConfirm = "Yes" + , confirmDeny = "No" + , confirmStyle = emptySetting + } + +-- | Confirm dialog builder. +confirm :: ConfirmSettings -> SlackConfirmObject +confirm ConfirmSettings {..} = + SlackConfirmObject + { slackConfirmTitle = plaintextonly confirmTitle + , slackConfirmText = mrkdwn confirmText + , slackConfirmConfirm = plaintextonly confirmConfirm + , slackConfirmDeny = plaintextonly confirmDeny + , slackConfirmStyle = unOptionalSetting confirmStyle + } + +-- | 'SlackBlockId' should be unique for each message and each iteration +-- of a message. If a message is updated, use a new block_id. +type SlackBlockId = NonEmptyText 255 + +-- | All Slack Actions must have a 'SlackActionId' and one 'SlackActionComponent' (such as a button). +data SlackAction = SlackAction SlackActionId SlackActionComponent + deriving stock (Eq) + +instance Show SlackAction where + show (SlackAction actionId component) = show actionId <> " " <> show component + +-- | [Confirm dialog object](https://api.slack.com/reference/block-kit/composition-objects#confirm). +data SlackConfirmObject = SlackConfirmObject + { slackConfirmTitle :: SlackPlainTextOnly -- max length 100 + , slackConfirmText :: SlackTextObject -- max length 300 + , slackConfirmConfirm :: SlackPlainTextOnly -- max length 30 + , slackConfirmDeny :: SlackPlainTextOnly -- max length 30 + , slackConfirmStyle :: Maybe SlackStyle + } + deriving stock (Eq) + +instance ToJSON SlackConfirmObject where + toJSON SlackConfirmObject {..} = + objectOptional + [ "title" .=! slackConfirmTitle + , "text" .=! slackConfirmText + , "confirm" .=! slackConfirmConfirm + , "deny" .=! slackConfirmDeny + , "style" .=? slackConfirmStyle + ] + +instance FromJSON SlackConfirmObject where + parseJSON = withObject "SlackConfirmObject" $ \obj -> do + slackConfirmTitle <- obj .: "title" + slackConfirmText <- obj .: "text" + slackConfirmConfirm <- obj .: "confirm" + slackConfirmDeny <- obj .: "deny" + slackConfirmStyle <- obj .:? "style" + pure SlackConfirmObject {..} + +newtype SlackResponseUrl = SlackResponseUrl {unSlackResponseUrl :: Text} + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) + +-- | Represents the data we get from a callback from Slack for interactive +-- operations. See https://api.slack.com/interactivity/handling#payloads +data SlackInteractivePayload = SlackInteractivePayload + { sipUserId :: Text + , sipUsername :: Text + , sipName :: Text + , sipResponseUrl :: Maybe SlackResponseUrl + , sipTriggerId :: Maybe Text + , sipActions :: [SlackActionResponse] + } + deriving stock (Show) + +instance FromJSON SlackInteractivePayload where + parseJSON = withObject "SlackInteractivePayload" $ \obj -> do + user <- obj .: "user" + sipUserId <- user .: "id" + sipUsername <- user .: "username" + sipName <- user .: "name" + sipResponseUrl <- obj .:? "response_url" + sipTriggerId <- obj .:? "trigger_id" + actionsObj <- obj .: "actions" + sipActions <- parseJSON actionsObj + pure $ SlackInteractivePayload {..} + +-- | Which component and it's IDs that triggered an interactive webhook call. +data SlackActionResponse = SlackActionResponse + { sarBlockId :: SlackBlockId + , sarActionId :: SlackActionId + , sarActionComponent :: SlackActionComponent + } + deriving stock (Show) + +instance FromJSON SlackActionResponse where + parseJSON = withObject "SlackActionResponse" $ \obj -> do + sarBlockId <- obj .: "block_id" + sarActionId <- obj .: "action_id" + sarActionComponent <- parseJSON $ Object obj + pure $ SlackActionResponse {..} + +data SlackInteractiveResponseResponse = SlackInteractiveResponseResponse {unSlackInteractiveResponseResponse :: Bool} + +instance FromJSON SlackInteractiveResponseResponse where + parseJSON = withObject "SlackInteractiveResponseResponse" $ \obj -> do + res <- obj .: "ok" + pure $ SlackInteractiveResponseResponse res + +-- | Type of message to send in response to an interactive webhook. +-- See Slack's [Handling user interaction in your Slack apps](https://api.slack.com/interactivity/handling#responses) +-- for a description of these fieldds. +data SlackInteractiveResponse + = -- | Respond with a new message. + SlackInteractiveResponse SlackMessage + | -- | Respond with a message that only the interacting user can usee. + Ephemeral SlackMessage + | -- | Replace the original message. + ReplaceOriginal SlackMessage + | -- | Delete the original message. + DeleteOriginal + deriving stock (Show) + +instance ToJSON SlackInteractiveResponse where + toJSON (SlackInteractiveResponse msg) = object ["blocks" .= msg] + toJSON (Ephemeral msg) = object ["blocks" .= msg, "replace_original" .= False, "response_type" .= ("ephemeral" :: Text)] + toJSON (ReplaceOriginal msg) = object ["blocks" .= msg, "replace_original" .= True] + toJSON DeleteOriginal = object ["delete_original" .= True] + +-- | Text to be displayed in a 'SlackButton'. +-- Up to 75 characters, but may be truncated to 30 characters. +newtype SlackButtonText = SlackButtonText (NonEmptyText 75) + deriving stock (Show) + deriving newtype (Eq, FromJSON) + +instance Slack SlackButtonText where + message (SlackButtonText m) = SlackText [nonEmptyTextToText m] + +-- It isn't the end of the world if this gets truncated (slack may truncate it +-- to about 30 characters anyway) so we have this convenience instance to +-- use plain strings for button text. +instance IsString SlackButtonText where + fromString s = SlackButtonText . unsafeMkNonEmptyText . cs $ take 75 s + +-- | The component in a 'SlackAction'. Do not use directly. +-- Use the builder functions such as 'button' instead. +data SlackActionComponent = SlackButton + { slackButtonText :: SlackButtonText -- max length 75, may truncate to ~30 + , slackButtonUrl :: Maybe (NonEmptyText 3000) -- max length 3000 + , slackButtonValue :: Maybe (NonEmptyText 2000) -- max length 2000 + , slackButtonStyle :: Maybe SlackStyle + , slackButtonConfirm :: Maybe SlackConfirmObject + } + deriving stock (Eq) + +instance FromJSON SlackActionComponent where + parseJSON = withObject "SlactActionComponent" $ \obj -> do + (slackActionType :: Text) <- obj .: "type" + case slackActionType of + "button" -> do + text <- obj .: "text" + slackButtonText <- text .: "text" + slackButtonUrl <- obj .:? "url" + slackButtonValue <- obj .:? "value" + slackButtonStyle <- obj .:? "style" + slackButtonConfirm <- obj .:? "confirm" + pure $ SlackButton {..} + _ -> fail "Unknown SlackActionComponent type, must be one of ['button']" + +instance Show SlackActionComponent where + show SlackButton {..} = "[button " <> show slackButtonText <> "]" + +instance ToJSON SlackAction where + toJSON (SlackAction actionId SlackButton {..}) = + objectOptional + [ "type" .=! ("button" :: Text) + , "action_id" .=! actionId + , "text" .=! plaintext slackButtonText + , "url" .=? slackButtonUrl + , "value" .=? slackButtonValue + , "style" .=? slackButtonStyle + , "confirm" .=? slackButtonConfirm + ] + +instance FromJSON SlackAction where + parseJSON = withObject "SlackAction" $ \obj -> do + actionId <- obj .: "action_id" + slackActionComponent <- parseJSON $ Object obj + pure $ SlackAction actionId slackActionComponent diff --git a/src/Web/Slack/Experimental/Events/Types.hs b/src/Web/Slack/Experimental/Events/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/Slack/Experimental/Events/Types.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TemplateHaskell #-} + +-- FIXME(jadel): Use NoFieldSelectors when we drop everything before 9.2. + +-- | Types for the [Slack Events API](https://api.slack.com/events). +module Web.Slack.Experimental.Events.Types where + +import Data.Aeson +import Data.Aeson.TH +import Data.Time.Clock.System (SystemTime) +import Web.Slack.AesonUtils +import Web.Slack.Experimental.Blocks (SlackBlock) +import Web.Slack.Prelude +import Web.Slack.Types (ConversationId, TeamId, UserId) + +-- | Not a ConversationType for some mysterious reason; this one has Channel as +-- an option, which does not exist as a ConversationType. Slack, why? +data ChannelType = Channel | Group | Im + deriving stock (Show, Eq) + +$(deriveJSON snakeCaseOptions ''ChannelType) + +-- | +data MessageEvent = MessageEvent + { blocks :: Maybe [SlackBlock] + , channel :: ConversationId + , text :: Text + , channelType :: ChannelType + , -- FIXME(jadel): clientMsgId?? + user :: UserId + , ts :: Text + , threadTs :: Maybe Text + -- ^ Present if the message is in a thread + , appId :: Maybe Text + -- ^ Present if it's sent by an app + -- + -- For mysterious reasons, this is NOT + -- , this is a regular + -- message but with bot metadata. I Think it's because there *is* an + -- associated user. + -- + -- See @botMessage.json@ golden parser test. + , botId :: Maybe Text + -- ^ Present if it's sent by a bot user + } + deriving stock (Show) + +-- | +-- +-- FIXME(jadel): implement. This is mega cursed! in the normal message event +-- the channel is called "channel" but here it is called "channelId" and also +-- has a "channel_name" and "channel_team". Why?! +-- +-- We don't decode these on this basis. +data MessageUpdateEvent = MessageUpdateEvent + { message :: MessageEvent + } + deriving stock (Show) + +$(deriveFromJSON snakeCaseOptions ''MessageEvent) +$(deriveFromJSON snakeCaseOptions ''MessageUpdateEvent) + +-- | FIXME: this might be a Channel, but may also be missing some fields/have bonus +-- because Slack is cursed. +data CreatedChannel = CreatedChannel + { id :: ConversationId + , isChannel :: Bool + , name :: Text + , nameNormalized :: Text + , creator :: UserId + , created :: SystemTime + , isShared :: Bool + , isOrgShared :: Bool + , -- what is this? + contextTeamId :: TeamId + } + deriving stock (Show) + +-- | A channel was created. +-- +-- +data ChannelCreatedEvent = ChannelCreatedEvent + { channel :: CreatedChannel + } + deriving stock (Show) + +$(deriveFromJSON snakeCaseOptions ''CreatedChannel) +$(deriveFromJSON snakeCaseOptions ''ChannelCreatedEvent) + +-- | You left a channel. +-- +-- +data ChannelLeftEvent = ChannelLeftEvent + { actorId :: UserId + , channel :: ConversationId + , eventTs :: Text + } + deriving stock (Show) + +$(deriveFromJSON snakeCaseOptions ''ChannelLeftEvent) + +-- | +data UrlVerificationPayload = UrlVerificationPayload + { challenge :: Text + } + deriving stock (Show) + +$(deriveFromJSON snakeCaseOptions ''UrlVerificationPayload) + +newtype EventId = EventId {unEventId :: Text} + deriving newtype (FromJSON) + deriving stock (Show) + +newtype MessageId = MessageId {unMessageId :: Text} + deriving newtype (FromJSON) + deriving stock (Show, Eq) + +data Event + = EventMessage MessageEvent + | EventMessageChanged + | -- | Weird message event of subtype channel_join. Sent "sometimes", according + -- to a random Slack blog post from 2017: + -- + -- + -- Documentation: + EventChannelJoinMessage + | EventChannelCreated ChannelCreatedEvent + | EventChannelLeft ChannelLeftEvent + | EventUnknown Value + deriving stock (Show, Generic) + +instance FromJSON Event where + parseJSON = withObject "MessageEvent" \obj -> do + tag :: Text <- obj .: "type" + subtype :: Maybe Text <- obj .:? "subtype" + case (tag, subtype) of + ("message", Nothing) -> EventMessage <$> parseJSON @MessageEvent (Object obj) + ("message", Just "message_changed") -> pure EventMessageChanged + ("message", Just "channel_join") -> pure EventChannelJoinMessage + ("channel_created", Nothing) -> EventChannelCreated <$> parseJSON (Object obj) + ("channel_left", Nothing) -> EventChannelLeft <$> parseJSON (Object obj) + _ -> pure $ EventUnknown (Object obj) + +data EventCallback = EventCallback + { eventId :: EventId + , teamId :: TeamId + , eventTime :: SystemTime + , event :: Event + } + deriving stock (Show) + +$(deriveFromJSON snakeCaseOptions ''EventCallback) + +data SlackWebhookEvent + = EventUrlVerification UrlVerificationPayload + | EventEventCallback EventCallback + | EventUnknownWebhook Value + deriving stock (Show, Generic) + +instance FromJSON SlackWebhookEvent where + parseJSON = withObject "SlackWebhookEvent" \obj -> do + tag :: Text <- obj .: "type" + case tag of + "url_verification" -> EventUrlVerification <$> parseJSON (Object obj) + "event_callback" -> EventEventCallback <$> parseJSON (Object obj) + _ -> pure $ EventUnknownWebhook (Object obj) + +-- * Event responses + +-- $eventResponses +-- +-- By and large, Slack does not care about the response returned from event +-- handlers, at least for the 'EventEventCallback' as long as your service +-- 200s. The exception is 'EventUrlVerification', which is expected to return a +-- 'UrlVerificationResponse' + +-- | Response for @url_verification@. +data UrlVerificationResponse = UrlVerificationResponse + { challenge :: Text + } + deriving stock (Show) + +$(deriveToJSON defaultOptions ''UrlVerificationResponse) diff --git a/src/Web/Slack/Experimental/RequestVerification.hs b/src/Web/Slack/Experimental/RequestVerification.hs new file mode 100644 --- /dev/null +++ b/src/Web/Slack/Experimental/RequestVerification.hs @@ -0,0 +1,101 @@ +module Web.Slack.Experimental.RequestVerification + ( SlackSigningSecret (..), + SlackSignature (..), + SlackRequestTimestamp (..), + SlackVerificationFailed (..), + validateRequest, + validateRequest', + ) +where + +import Crypto.Hash (SHA256, digestFromByteString) +import Crypto.MAC.HMAC +import Data.Aeson (eitherDecodeStrict) +import Data.ByteString.Base16 qualified as B16 +import Data.ByteString.Char8 (readInt) +import Data.Either.Combinators (mapLeft, maybeToRight) +import Data.Time (NominalDiffTime) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Web.HttpApiData (FromHttpApiData (..)) +import Web.Slack.Prelude + +-- | Slack generated Signing Secret placed into configuration. +-- See https://api.slack.com/authentication/verifying-requests-from-slack#signing_secrets_admin_page +newtype SlackSigningSecret + = SlackSigningSecret ByteString + deriving stock (Eq) + +instance Show SlackSigningSecret where + show _ = "" + +newtype SlackSignature = SlackSignature ByteString + deriving newtype (Eq, Show) + +newtype SlackRequestTimestamp = SlackRequestTimestamp ByteString + deriving newtype (Eq, Show) + +instance FromHttpApiData SlackRequestTimestamp where + parseQueryParam _ = error "SlackRequestTimestamp should not be in a query param" + parseUrlPiece _ = error "SlackRequestTimestamp should not be in a url piece" + parseHeader = Right . SlackRequestTimestamp + +instance FromHttpApiData SlackSignature where + parseQueryParam _ = error "SlackSignature should not be in a query param" + parseUrlPiece _ = error "SlackSignature should not be in a url piece" + parseHeader = Right . SlackSignature + +data SlackVerificationFailed + = VerificationMissingTimestamp + | VerificationMalformedTimestamp ByteString + | VerificationTimestampOutOfRange Int + | VerificationMissingSignature + | VerificationUnknownSignatureVersion ByteString + | VerificationMalformedSignature String + | VerificationUndecodableSignature ByteString + | VerificationSignatureMismatch + | VerificationCannotParse Text + deriving stock (Show, Eq) + +instance Exception SlackVerificationFailed + +validateRequest :: + (MonadIO m, FromJSON a) => + SlackSigningSecret -> + SlackSignature -> + SlackRequestTimestamp -> + ByteString -> + m (Either SlackVerificationFailed a) +validateRequest secret sig reqTs body = + liftIO getPOSIXTime >>= \time -> pure $ validateRequest' time secret sig reqTs body + +-- | Pure version of 'validateRequest'. Probably only useful for tests. +validateRequest' :: + FromJSON a => + NominalDiffTime -> + SlackSigningSecret -> + SlackSignature -> + SlackRequestTimestamp -> + ByteString -> + Either SlackVerificationFailed a +validateRequest' now (SlackSigningSecret secret) (SlackSignature sigHeader) (SlackRequestTimestamp timestampString) body = do + let fiveMinutes = 5 * 60 + -- timestamp must be an Int for proper basestring construction below + timestamp <- + maybeToRight (VerificationMalformedTimestamp timestampString) $ + fst <$> readInt timestampString + if abs (now - fromIntegral timestamp) > fiveMinutes + then Left $ VerificationTimestampOutOfRange timestamp + else Right () + sigHeaderStripped <- + maybeToRight (VerificationUnknownSignatureVersion sigHeader) $ + stripPrefix "v0=" sigHeader + sigDecoded <- + mapLeft VerificationMalformedSignature $ + B16.decode sigHeaderStripped + sig :: HMAC SHA256 <- + maybeToRight (VerificationUndecodableSignature sigDecoded) $ + HMAC <$> digestFromByteString sigDecoded + let basestring = encodeUtf8 ("v0:" <> tshow timestamp <> ":") <> body + when (hmac secret basestring /= sig) $ + Left VerificationSignatureMismatch + mapLeft (VerificationCannotParse . pack) $ eitherDecodeStrict body diff --git a/src/Web/Slack/Internal.hs b/src/Web/Slack/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Web/Slack/Internal.hs @@ -0,0 +1,64 @@ +-- | Internal things in slack-web. May be changed arbitrarily! +module Web.Slack.Internal where + +import Data.Aeson (Value (..)) +import Network.HTTP.Client (Manager) +import Servant.API hiding (addHeader) +-- import Servant.Client.Core + +import Servant.Client (BaseUrl (..), ClientError, ClientM, Scheme (..), mkClientEnv, runClientM) +import Servant.Client.Core (AuthClientData, AuthenticatedRequest, Request, addHeader, mkAuthenticatedRequest) +import Web.Slack.Common qualified as Common +import Web.Slack.Pager (Response) +import Web.Slack.Prelude + +data SlackConfig = SlackConfig + { slackConfigManager :: Manager + , slackConfigToken :: Text + } + +-- contains errors that can be returned by the slack API. +-- constrast with 'SlackClientError' which additionally +-- contains errors which occured during the network communication. +data ResponseSlackError = ResponseSlackError Text + deriving stock (Eq, Show) + +-- | +-- Internal type! +newtype ResponseJSON a = ResponseJSON (Either ResponseSlackError a) + +instance FromJSON a => FromJSON (ResponseJSON a) where + parseJSON = withObject "Response" $ \o -> do + ok <- o .: "ok" + ResponseJSON + <$> if ok + then Right <$> parseJSON (Object o) + else Left . ResponseSlackError <$> o .: "error" + +mkSlackAuthenticateReq :: SlackConfig -> AuthenticatedRequest (AuthProtect "token") +mkSlackAuthenticateReq = (`mkAuthenticatedRequest` authenticateReq) . slackConfigToken + +type instance + AuthClientData (AuthProtect "token") = + Text + +authenticateReq :: + Text -> + Request -> + Request +authenticateReq token = + addHeader "Authorization" $ "Bearer " <> token + +run :: + ClientM (ResponseJSON a) -> + Manager -> + IO (Response a) +run clientAction mgr = do + let baseUrl = BaseUrl Https "slack.com" 443 "/api" + unnestErrors <$> liftIO (runClientM clientAction $ mkClientEnv mgr baseUrl) + +unnestErrors :: Either ClientError (ResponseJSON a) -> Response a +unnestErrors (Right (ResponseJSON (Right a))) = Right a +unnestErrors (Right (ResponseJSON (Left (ResponseSlackError serv)))) = + Left (Common.SlackError serv) +unnestErrors (Left slackErr) = Left (Common.ServantError slackErr) diff --git a/src/Web/Slack/MessageParser.hs b/src/Web/Slack/MessageParser.hs --- a/src/Web/Slack/MessageParser.hs +++ b/src/Web/Slack/MessageParser.hs @@ -1,39 +1,39 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} -- | See https://api.slack.com/docs/message-formatting --- module Web.Slack.MessageParser - ( messageToHtml - , HtmlRenderers(..) - , defaultHtmlRenderers + ( messageToHtml, + HtmlRenderers (..), + defaultHtmlRenderers, ) - where +where +-- FIXME: Web.Slack.Prelude + -- base import Control.Monad -import Data.List -import Data.Maybe -import Data.Void - -- megaparsec -import Text.Megaparsec -import Text.Megaparsec.Char -- mtl import Data.Functor.Identity - +import Data.List (intercalate) +import Data.Maybe -- slack-web -import Web.Slack.Types -- text import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T +import Data.Void +import Text.Megaparsec +import Text.Megaparsec.Char +import Web.Slack.Types +import Prelude -newtype SlackUrl = SlackUrl { unSlackUrl :: Text } - deriving (Show, Eq) +newtype SlackUrl = SlackUrl {unSlackUrl :: Text} + deriving stock (Show, Eq) data SlackMsgItem = SlackMsgItemPlainText Text @@ -46,7 +46,7 @@ | SlackMsgItemCodeSection Text | SlackMsgItemQuoted [SlackMsgItem] | SlackMsgItemEmoticon Text - deriving (Show, Eq) + deriving stock (Show, Eq) #if MIN_VERSION_megaparsec(6,0,0) type MegaparsecError = Void @@ -63,29 +63,35 @@ type SlackParser a = ParsecT MegaparsecError T.Text Identity a parseMessage :: Text -> [SlackMsgItem] -parseMessage input = fromMaybe [SlackMsgItemPlainText input] $ - parseMaybe (some $ parseMessageItem True) input +parseMessage input = + fromMaybe [SlackMsgItemPlainText input] $ + parseMaybe (some $ parseMessageItem True) input parseMessageItem :: Bool -> SlackParser SlackMsgItem -parseMessageItem acceptNewlines - = parseBoldSection - <|> parseItalicsSection - <|> parseStrikethroughSection - <|> try parseEmoticon - <|> parseCode - <|> parseInlineCode - <|> parseUserLink - <|> parseLink - <|> parseBlockQuote - <|> parsePlainText - <|> parseWhitespace acceptNewlines +parseMessageItem acceptNewlines = + parseBoldSection + <|> parseItalicsSection + <|> parseStrikethroughSection + <|> try parseEmoticon + <|> parseCode + <|> parseInlineCode + <|> parseUserLink + <|> parseLink + <|> parseBlockQuote + <|> parsePlainText + <|> parseWhitespace acceptNewlines parsePlainText :: SlackParser SlackMsgItem -parsePlainText = SlackMsgItemPlainText . T.pack <$> - someTill (noneOf stopChars) (void (lookAhead $ try $ oneOf stopChars) - <|> lookAhead (try $ choice $ sectionEndSymbol <$> ['*', '_', ':', '~']) - <|> lookAhead eof) - where stopChars = [' ', '\n'] +parsePlainText = + SlackMsgItemPlainText . T.pack + <$> someTill + (noneOf stopChars) + ( void (lookAhead $ try $ oneOf stopChars) + <|> lookAhead (try $ choice $ sectionEndSymbol <$> ['*', '_', ':', '~']) + <|> lookAhead eof + ) + where + stopChars = [' ', '\n'] -- slack accepts bold/italics modifiers -- only at word boundary. for instance 'my_word' @@ -99,7 +105,7 @@ sectionEndSymbol chr = void $ char chr >> lookAhead wordBoundary parseCharDelimitedSection :: Char -> SlackParser [SlackMsgItem] -parseCharDelimitedSection chr = +parseCharDelimitedSection chr = char chr *> someTill (parseMessageItem False) (sectionEndSymbol chr) wordBoundary :: SlackParser () @@ -118,75 +124,84 @@ fmap SlackMsgItemStrikethroughSection (parseCharDelimitedSection '~') parseEmoticon :: SlackParser SlackMsgItem -parseEmoticon = fmap (SlackMsgItemEmoticon . T.pack) $ - char ':' *> someTill (alphaNumChar <|> char '_' <|> char '+') (sectionEndSymbol ':') +parseEmoticon = + fmap (SlackMsgItemEmoticon . T.pack) $ + char ':' *> someTill (alphaNumChar <|> char '_' <|> char '+') (sectionEndSymbol ':') parseUserLink :: SlackParser SlackMsgItem parseUserLink = do void (string "<@") userId <- UserId . T.pack <$> some (noneOf ['|', '>']) - let linkWithoutDesc = char '>' >> - pure (SlackMsgItemUserLink userId Nothing) - let linkWithDesc = char '|' >> - SlackMsgItemUserLink <$> pure userId <*> (Just <$> ((T.pack <$> some (noneOf ['>'])) <* char '>')) + let linkWithoutDesc = + char '>' + >> pure (SlackMsgItemUserLink userId Nothing) + let linkWithDesc = + char '|' + >> SlackMsgItemUserLink <$> pure userId <*> (Just <$> ((T.pack <$> some (noneOf ['>'])) <* char '>')) linkWithDesc <|> linkWithoutDesc parseLink :: SlackParser SlackMsgItem parseLink = do void (char '<') url <- SlackUrl . T.pack <$> some (noneOf ['|', '>']) - let linkWithoutDesc = char '>' >> - pure (SlackMsgItemLink (unSlackUrl url) url) - let linkWithDesc = char '|' >> - SlackMsgItemLink <$> ((T.pack <$> some (noneOf ['>'])) <* char '>') <*> pure url + let linkWithoutDesc = + char '>' + >> pure (SlackMsgItemLink (unSlackUrl url) url) + let linkWithDesc = + char '|' + >> SlackMsgItemLink <$> ((T.pack <$> some (noneOf ['>'])) <* char '>') <*> pure url linkWithDesc <|> linkWithoutDesc parseCode :: SlackParser SlackMsgItem -parseCode = SlackMsgItemCodeSection . T.pack <$> - (string "```" >> manyTill anySingle (string "```")) +parseCode = + SlackMsgItemCodeSection . T.pack + <$> (string "```" >> manyTill anySingle (string "```")) parseInlineCode :: SlackParser SlackMsgItem -parseInlineCode = SlackMsgItemInlineCodeSection . T.pack <$> - (char '`' *> some (noneOf ['`']) <* char '`') +parseInlineCode = + SlackMsgItemInlineCodeSection . T.pack + <$> (char '`' *> some (noneOf ['`']) <* char '`') parseBlockQuote :: SlackParser SlackMsgItem parseBlockQuote = SlackMsgItemQuoted . intercalate [SlackMsgItemPlainText "
"] <$> some blockQuoteLine blockQuoteLine :: SlackParser [SlackMsgItem] -blockQuoteLine = string ">" *> optional (char ' ') *> - manyTill (parseMessageItem False) (eof <|> void newline) +blockQuoteLine = + string ">" + *> optional (char ' ') + *> manyTill (parseMessageItem False) (eof <|> void newline) -- | -- Convert the slack format for messages (markdown like, see -- https://api.slack.com/docs/message-formatting ) to HTML. -messageToHtml - :: HtmlRenderers - -- ^ Renderers allow you to customize the message rendering. +messageToHtml :: + -- | Renderers allow you to customize the message rendering. -- Give 'defaultHtmlRenderers' for a default implementation. - -> (UserId -> Text) - -- ^ A function giving a user name for a user id. You can use 'Web.Slack.getUserDesc' - -> SlackMessageText - -- ^ A slack message to convert to HTML - -> Text - -- ^ The HTML-formatted slack message + HtmlRenderers -> + -- | A function giving a user name for a user id. You can use 'Web.Slack.getUserDesc' + (UserId -> Text) -> + -- | A slack message to convert to HTML + SlackMessageText -> + -- | The HTML-formatted slack message + Text messageToHtml htmlRenderers getUserDesc = messageToHtml' htmlRenderers getUserDesc . parseMessage . unSlackMessageText messageToHtml' :: HtmlRenderers -> (UserId -> Text) -> [SlackMsgItem] -> Text messageToHtml' htmlRenderers getUserDesc = foldr ((<>) . msgItemToHtml htmlRenderers getUserDesc) "" -data HtmlRenderers - = HtmlRenderers +data HtmlRenderers = HtmlRenderers { emoticonRenderer :: Text -> Text } defaultHtmlRenderers :: HtmlRenderers -defaultHtmlRenderers = HtmlRenderers - { emoticonRenderer = \code -> ":" <> code <> ":" - } - +defaultHtmlRenderers = + HtmlRenderers + { emoticonRenderer = \code -> ":" <> code <> ":" + } + msgItemToHtml :: HtmlRenderers -> (UserId -> Text) -> SlackMsgItem -> Text -msgItemToHtml htmlRenderers@HtmlRenderers{..} getUserDesc = \case +msgItemToHtml htmlRenderers@HtmlRenderers {..} getUserDesc = \case SlackMsgItemPlainText txt -> T.replace "\n" "
" txt SlackMsgItemBoldSection cts -> "" <> messageToHtml' htmlRenderers getUserDesc cts <> "" diff --git a/src/Web/Slack/Pager.hs b/src/Web/Slack/Pager.hs --- a/src/Web/Slack/Pager.hs +++ b/src/Web/Slack/Pager.hs @@ -1,112 +1,65 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - module Web.Slack.Pager - ( Response - , conversationsHistoryAllBy - , repliesFetchAllBy - , LoadPage - , loadingPage - ) where - --- base -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.IORef (newIORef, readIORef, writeIORef) -import Data.Maybe (isNothing) - --- slack-web -import qualified Web.Slack.Common as Common -import qualified Web.Slack.Conversation as Conversation -import Web.Slack.Types (Cursor) - - --- | Public only for testing. -conversationsHistoryAllBy - :: MonadIO m - => (Conversation.HistoryReq -> m (Response Conversation.HistoryRsp)) - -- ^ Response generator - -> Conversation.HistoryReq - -- ^ The first request to send. _NOTE_: 'Conversation.historyReqCursor' is silently ignored. - -> m (LoadPage m Common.Message) - -- ^ An action which returns a new page of messages every time called. - -- If there are no pages anymore, it returns an empty list. -conversationsHistoryAllBy sendRequest initialRequest = - genericFetchAllBy - sendRequest - (\cursor -> initialRequest { Conversation.historyReqCursor = cursor }) - - --- | Public only for testing. -repliesFetchAllBy - :: MonadIO m - => (Conversation.RepliesReq -> m (Response Conversation.HistoryRsp)) - -- ^ Response generator - -> Conversation.RepliesReq - -- ^ The first request to send. _NOTE_: 'Conversation.historyReqCursor' is silently ignored. - -> m (LoadPage m Common.Message) - -- ^ An action which returns a new page of messages every time called. - -- If there are no pages anymore, it returns an empty list. -repliesFetchAllBy sendRequest initialRequest = - genericFetchAllBy - sendRequest - (\cursor -> initialRequest { Conversation.repliesReqCursor = cursor }) + ( Response, + LoadPage, + loadingPage, + fetchAllBy, + module Web.Slack.Pager.Types, + ) +where +import Web.Slack.Common qualified as Common +import Web.Slack.Conversation qualified as Conversation +import Web.Slack.Pager.Types +import Web.Slack.Prelude type Response a = Either Common.SlackClientError a - -- | Represents an action which returns a paginated response from Slack. -- Every time calling the action, it performs a request with a new cursor -- to get the next page. -- If there is no more response, the action returns an empty list. type LoadPage m a = m (Response [a]) - -- | Utility function for 'LoadPage'. Perform the 'LoadPage' action to call -- the function with the loaded page, until an empty page is loaded. loadingPage :: (Monad m, Monoid n) => LoadPage m a -> (Response [a] -> m n) -> m n loadingPage loadPage usePage = go mempty - where - go result = do - epage <- loadPage - case epage of + where + go result = do + epage <- loadPage + case epage of Right page -> if null page then return result else (go $!) . (result <>) =<< usePage epage Left e -> (result <>) <$> usePage (Left e) - -genericFetchAllBy - :: MonadIO m - => (a -> m (Response Conversation.HistoryRsp)) - -> (Maybe Cursor -> a) - -> m (LoadPage m Common.Message) -genericFetchAllBy sendRequest requestFromCursor = do +fetchAllBy :: + ( MonadIO m + , PagedRequest req + , PagedResponse resp + ) => + (req -> m (Response resp)) -> + req -> + m (LoadPage m (ResponseObject resp)) +fetchAllBy sendRequest initialRequest = do cursorRef <- liftIO $ newIORef Nothing - let collectAndUpdateCursor - Conversation.HistoryRsp - { Conversation.historyRspMessages - , Conversation.historyRspResponseMetadata - } = do - let newCursor = Conversation.responseMetadataNextCursor =<< historyRspResponseMetadata + let requestFromCursor cursor = setCursor cursor initialRequest + collectAndUpdateCursor resp = do + let newCursor = Conversation.responseMetadataNextCursor =<< getResponseMetadata resp -- emptyCursor is used for the marker to show that there are no more pages. cursorToSave = if isNothing newCursor then emptyCursor else newCursor writeIORef cursorRef cursorToSave - return historyRspMessages + return $ getResponseData resp return $ do cursor <- liftIO $ readIORef cursorRef if cursor == emptyCursor - then - return $ Right [] + then return $ Right [] else traverse (liftIO . collectAndUpdateCursor) =<< sendRequest (requestFromCursor cursor) - where - -- Used for the marker to show that there are no more pages. - emptyCursor = Just $ Common.Cursor "" + where + -- Used for the marker to show that there are no more pages. + emptyCursor = Just $ Common.Cursor "" diff --git a/src/Web/Slack/Pager/Types.hs b/src/Web/Slack/Pager/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/Slack/Pager/Types.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Web.Slack.Pager.Types where + +import Web.Slack.Prelude +import Web.Slack.Util + +newtype Cursor = Cursor {unCursor :: Text} + deriving stock (Eq, Generic, Show) + deriving newtype (NFData, Hashable, FromJSON, ToJSON, ToHttpApiData) + +newtype ResponseMetadata = ResponseMetadata {responseMetadataNextCursor :: Maybe Cursor} + deriving stock (Eq, Show, Generic) + +instance NFData ResponseMetadata + +$(deriveJSON (jsonOpts "responseMetadata") ''ResponseMetadata) + +class PagedRequest a where + setCursor :: Maybe Cursor -> a -> a + +class PagedResponse a where + type ResponseObject a + getResponseMetadata :: a -> Maybe ResponseMetadata + getResponseData :: a -> [ResponseObject a] diff --git a/src/Web/Slack/Prelude.hs b/src/Web/Slack/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Web/Slack/Prelude.hs @@ -0,0 +1,20 @@ +module Web.Slack.Prelude + ( module ClassyPrelude, + module Data.Aeson, + module Data.Aeson.TH, + cs, + ToHttpApiData, + NonEmpty (..), + Default (..), + Proxy (..), + ) +where + +import ClassyPrelude hiding (link) +import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.=)) +import Data.Aeson.TH (deriveFromJSON, deriveJSON, deriveToJSON) +import Data.Default.Class (Default (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Proxy (Proxy (..)) +import Data.String.Conversions (cs) +import Web.HttpApiData (ToHttpApiData) diff --git a/src/Web/Slack/Types.hs b/src/Web/Slack/Types.hs --- a/src/Web/Slack/Types.hs +++ b/src/Web/Slack/Types.hs @@ -1,94 +1,66 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeApplications #-} +---------------------------------------------------------------------- ---------------------------------------------------------------------- + -- | -- Module: Web.Slack.Types -- Description: --- --- --- ----------------------------------------------------------------------- - module Web.Slack.Types - ( Color(..) - , UserId(..) - , ConversationId(..) - , TeamId(..) - , Cursor(..) - , SlackTimestamp(..) - , mkSlackTimestamp - , timestampFromText - , SlackMessageText(..) + ( Color (..), + UserId (..), + ConversationId (..), + TeamId (..), + Cursor (..), + SlackTimestamp (..), + mkSlackTimestamp, + timestampFromText, + SlackMessageText (..), ) - where +where --- aeson +import Control.Monad (MonadFail (..)) import Data.Aeson - --- base -import Data.Bifunctor (second) -import GHC.Generics (Generic) - --- deepseq -import Control.DeepSeq (NFData) - --- hashable -import Data.Hashable (Hashable) - --- http-api-data -import Web.HttpApiData - --- text -import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Data.Text.Read (rational) - --- time import Data.Time.Clock import Data.Time.Clock.POSIX +import Web.HttpApiData +import Web.Slack.Pager.Types +import Web.Slack.Prelude -- Ord to allow it to be a key of a Map -newtype Color = Color { unColor :: Text } +newtype Color = Color {unColor :: Text} deriving stock (Eq, Ord, Generic, Show) deriving newtype (NFData, Hashable, FromJSON, ToJSON) -- Ord to allow it to be a key of a Map -newtype UserId = UserId { unUserId :: Text } +newtype UserId = UserId {unUserId :: Text} deriving stock (Eq, Ord, Generic, Show) deriving newtype (NFData, Hashable, FromJSON, ToJSON, ToHttpApiData) -- | Common identifier for every type of 'Conversation'. -- Unique to the team which the conversation belongs to. -- Ord to allow it to be a key of a Map -newtype ConversationId = ConversationId { unConversationId :: Text } +newtype ConversationId = ConversationId {unConversationId :: Text} deriving stock (Eq, Ord, Generic, Show) deriving newtype (NFData, Hashable, FromJSON, ToJSON, ToHttpApiData) -- Ord to allow it to be a key of a Map -newtype TeamId = TeamId { unTeamId :: Text } +newtype TeamId = TeamId {unTeamId :: Text} deriving stock (Eq, Ord, Generic, Show) deriving newtype (NFData, Hashable, FromJSON, ToJSON, ToHttpApiData) -newtype Cursor = Cursor { unCursor :: Text } - deriving stock (Eq, Generic, Show) - deriving newtype (NFData, Hashable, FromJSON, ToJSON, ToHttpApiData) - -- | Message text in the format returned by Slack, -- see https://api.slack.com/docs/message-formatting -- Consider using 'messageToHtml' for displaying. -newtype SlackMessageText = SlackMessageText { unSlackMessageText :: Text} +newtype SlackMessageText = SlackMessageText {unSlackMessageText :: Text} deriving stock (Eq, Ord, Generic, Show) deriving newtype (NFData, Hashable, FromJSON, ToJSON) -data SlackTimestamp = - SlackTimestamp - { slackTimestampTs :: Text - , slackTimestampTime :: UTCTime - } +data SlackTimestamp = SlackTimestamp + { slackTimestampTs :: Text + , slackTimestampTime :: UTCTime + } deriving stock (Eq, Show, Generic) instance NFData SlackTimestamp @@ -99,24 +71,25 @@ -- | Convert timestamp texts e.g. "1595719220.011100" into 'SlackTimestamp' timestampFromText :: Text -> Either String SlackTimestamp timestampFromText t = f =<< rational t - where - f (posixTime, "") = - Right . SlackTimestamp t $ posixSecondsToUTCTime posixTime - f (_, _left) = Left "Unexpected text left after timestamp" + where + f (posixTime, "") = + Right . SlackTimestamp t $ posixSecondsToUTCTime posixTime + f (_, _left) = Left "Unexpected text left after timestamp" mkSlackTimestamp :: UTCTime -> SlackTimestamp mkSlackTimestamp utctime = SlackTimestamp (take6DigitsAfterPoint $ T.pack (show unixts)) utctime - where - unixts = nominalDiffTimeToSeconds $ utcTimeToPOSIXSeconds utctime - take6DigitsAfterPoint = uncurry (<>) . second (T.take 7) . T.break (== '.') + where + unixts = nominalDiffTimeToSeconds $ utcTimeToPOSIXSeconds utctime + take6DigitsAfterPoint = uncurry (<>) . second (T.take 7) . T.break (== '.') instance ToHttpApiData SlackTimestamp where toQueryParam (SlackTimestamp contents _) = contents instance FromJSON SlackTimestamp where - parseJSON = withText "Slack ts" - $ either (fail . ("Invalid Slack ts: " ++)) pure - . timestampFromText + parseJSON = + withText "Slack ts" $ + either (fail . ("Invalid Slack ts: " ++)) pure + . timestampFromText instance ToJSON SlackTimestamp where toJSON = String . slackTimestampTs diff --git a/src/Web/Slack/User.hs b/src/Web/Slack/User.hs --- a/src/Web/Slack/User.hs +++ b/src/Web/Slack/User.hs @@ -1,106 +1,100 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedLists #-} ---------------------------------------------------------------------- + +---------------------------------------------------------------------- + -- | -- Module: Web.Slack.User -- Description: --- --- --- ----------------------------------------------------------------------- - module Web.Slack.User - ( Profile(..) - , User(..) - , ListRsp(..) - , Email(..) - , UserRsp(..) + ( Profile (..), + User (..), + ListRsp (..), + Email (..), + UserRsp (..), ) - where +where +-- FIXME: Web.Slack.Prelude + -- aeson import Data.Aeson.TH - -- base -import GHC.Generics (Generic) -- slack-web -import Web.Slack.Common -import Web.Slack.Util -- text import Data.Text (Text) - -- time import Data.Time.Clock.POSIX - +import GHC.Generics (Generic) -- http-api-data -import Web.HttpApiData + import Web.FormUrlEncoded +import Web.HttpApiData +import Web.Slack.Common +import Web.Slack.Util +import Prelude -- See https://api.slack.com/types/user -data Profile = - Profile - { profileAvatarHash :: Maybe Text - , profileStatusText :: Maybe Text - , profileStatusEmoji :: Maybe Text - , profileRealName :: Maybe Text - , profileDisplayName :: Maybe Text - , profileRealNameNormalized :: Maybe Text - , profileDisplayNameNormalized :: Maybe Text - , profileEmail :: Maybe Text - , profileImage_24 :: Text - , profileImage_32 :: Text - , profileImage_48 :: Text - , profileImage_72 :: Text - , profileImage_192 :: Text - , profileImage_512 :: Text - , profileTeam :: Maybe Text - } - deriving (Eq, Generic, Show) +data Profile = Profile + { profileAvatarHash :: Maybe Text + , profileStatusText :: Maybe Text + , profileStatusEmoji :: Maybe Text + , profileRealName :: Maybe Text + , profileDisplayName :: Maybe Text + , profileRealNameNormalized :: Maybe Text + , profileDisplayNameNormalized :: Maybe Text + , profileEmail :: Maybe Text + , profileImage_24 :: Text + , profileImage_32 :: Text + , profileImage_48 :: Text + , profileImage_72 :: Text + , profileImage_192 :: Text + , profileImage_512 :: Text + , profileTeam :: Maybe Text + } + deriving stock (Eq, Generic, Show) $(deriveFromJSON (jsonOpts "profile") ''Profile) -data User = - User - { userId :: UserId - , userName :: Text - , userDeleted :: Bool - , userColor :: Maybe Color - , userProfile :: Maybe Profile - , userIsAdmin :: Maybe Bool - , userIsOwner :: Maybe Bool - , userIsPrimaryOwner :: Maybe Bool - , userIsRestricted :: Maybe Bool - , userIsUltraRestricted :: Maybe Bool - , userUpdated :: POSIXTime - } - deriving (Eq, Generic, Show) +data User = User + { userId :: UserId + , userName :: Text + , userDeleted :: Bool + , userColor :: Maybe Color + , userProfile :: Maybe Profile + , userIsAdmin :: Maybe Bool + , userIsOwner :: Maybe Bool + , userIsPrimaryOwner :: Maybe Bool + , userIsRestricted :: Maybe Bool + , userIsUltraRestricted :: Maybe Bool + , userUpdated :: POSIXTime + } + deriving stock (Eq, Generic, Show) $(deriveFromJSON (jsonOpts "user") ''User) -data ListRsp = - ListRsp - { listRspMembers :: [User] - } - deriving (Eq, Generic, Show) +data ListRsp = ListRsp + { listRspMembers :: [User] + } + deriving stock (Eq, Generic, Show) $(deriveFromJSON (jsonOpts "listRsp") ''ListRsp) - -data UserRsp = - UserRsp - { userRspUser :: User - } - deriving (Eq, Generic, Show) +data UserRsp = UserRsp + { userRspUser :: User + } + deriving stock (Eq, Generic, Show) $(deriveFromJSON (jsonOpts "UserRsp") ''UserRsp) -newtype Email = Email Text deriving (Eq, Generic, Show) -instance ToForm Email where - toForm (Email txt) = [("email", toQueryParam txt)] +newtype Email = Email Text deriving stock (Eq, Generic, Show) +instance ToForm Email where + toForm (Email txt) = [("email", toQueryParam txt)] diff --git a/src/Web/Slack/UsersConversations.hs b/src/Web/Slack/UsersConversations.hs new file mode 100644 --- /dev/null +++ b/src/Web/Slack/UsersConversations.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} + +-- | Client for Slack's @users.conversations@ endpoint. +-- +module Web.Slack.UsersConversations + ( UsersConversationsRequest (..), + UsersConversationsResponse (..), + usersConversations, + usersConversationsAll, + ) +where + +import Servant.API +import Servant.Client hiding (Response) +import Servant.Client.Core hiding (Response) +import Web.FormUrlEncoded (ToForm (..), genericToForm) +import Web.Slack.AesonUtils +import Web.Slack.Common (Cursor, TeamId, UserId) +import Web.Slack.Conversation (Conversation, ConversationType) +import Web.Slack.Internal +import Web.Slack.Pager (LoadPage, PagedRequest (..), PagedResponse (..), Response, ResponseMetadata, fetchAllBy) +import Web.Slack.Prelude + +newtype ConversationTypesList = ConversationTypesList {unConversationTypesList :: NonEmpty ConversationType} + deriving stock (Show, Eq) + deriving newtype (NFData) + +instance ToHttpApiData ConversationTypesList where + toQueryParam (ConversationTypesList list) = intercalate "," $ toUrlPiece <$> list + +-- | +data UsersConversationsRequest = UsersConversationsRequest + { cursor :: Maybe Cursor + , excludeArchived :: Maybe Bool + , limit :: Maybe Int + , teamId :: Maybe TeamId + , types :: Maybe ConversationTypesList + -- ^ Specify some specific conversation types. Defaults on Slack's end to + -- @public_channel@, aka 'PublicChannelType'. + , user :: Maybe UserId + -- ^ Look at the conversations of a specified user rather than the calling + -- user + } + deriving stock (Show, Eq, Generic) + deriving anyclass (Default) + +instance ToForm UsersConversationsRequest where + toForm = genericToForm snakeCaseFormOptions + +instance PagedRequest UsersConversationsRequest where + setCursor c req = req {cursor = c} + +data UsersConversationsResponse = UsersConversationsResponse + { channels :: [Conversation] + , responseMetadata :: Maybe ResponseMetadata + } + deriving stock (Show, Eq) + +instance PagedResponse UsersConversationsResponse where + type ResponseObject UsersConversationsResponse = Conversation + getResponseData UsersConversationsResponse {channels} = channels + getResponseMetadata UsersConversationsResponse {responseMetadata} = responseMetadata + +$(deriveFromJSON snakeCaseOptions ''UsersConversationsResponse) + +type Api = + "users.conversations" + :> AuthProtect "token" + :> ReqBody '[FormUrlEncoded] UsersConversationsRequest + :> Post '[JSON] (ResponseJSON UsersConversationsResponse) + +-- | Client for Slack's @users.conversations@ endpoint. +-- +usersConversations :: SlackConfig -> UsersConversationsRequest -> IO (Response UsersConversationsResponse) +usersConversations slackConfig req = do + let authR = mkSlackAuthenticateReq slackConfig + run (usersConversations_ authR req) . slackConfigManager $ slackConfig + +usersConversations_ :: + AuthenticatedRequest (AuthProtect "token") -> + UsersConversationsRequest -> + ClientM (ResponseJSON UsersConversationsResponse) +usersConversations_ = client (Proxy @Api) + +-- | Fetch all user conversations. +usersConversationsAll :: SlackConfig -> UsersConversationsRequest -> IO (LoadPage IO Conversation) +usersConversationsAll = fetchAllBy . usersConversations diff --git a/src/Web/Slack/Util.hs b/src/Web/Slack/Util.hs --- a/src/Web/Slack/Util.hs +++ b/src/Web/Slack/Util.hs @@ -1,85 +1,63 @@ ---------------------------------------------------------------------- + +---------------------------------------------------------------------- + -- | -- Module: Web.Slack.Util -- Description: --- --- --- ----------------------------------------------------------------------- - module Web.Slack.Util - ( formOpts - , jsonOpts - , toQueryParamIfJust + ( formOpts, + jsonOpts, + toQueryParamIfJust, ) - where +where +-- FIXME: Web.Slack.Prelude + -- aeson import Data.Aeson.TH import Data.Aeson.Types - -- base import Data.Char import Data.Maybe (maybeToList) -import GHC.Exts (fromList) - -- http-api-data -import Web.HttpApiData (toQueryParam, ToHttpApiData) -import Web.FormUrlEncoded (Form, FormOptions(FormOptions)) -- text import Data.Text (Text) -import qualified Data.Text as Text - - --- | --- --- +import Data.Text qualified as Text +import GHC.Exts (fromList) +import Web.FormUrlEncoded (Form, FormOptions (FormOptions)) +import Web.HttpApiData (ToHttpApiData, toQueryParam) +import Prelude -formOpts - :: Text - -> FormOptions +formOpts :: + Text -> + FormOptions formOpts prefix = FormOptions (modifyLabel prefix) - --- | --- --- - -jsonOpts - :: Text - -> Options +jsonOpts :: + Text -> + Options jsonOpts prefix = defaultOptions { fieldLabelModifier = modifyLabel prefix } - --- | --- --- - -modifyLabel - :: Text - -> String - -> String +modifyLabel :: + Text -> + String -> + String modifyLabel prefix = fmap toLower . addUnderscores . drop (Text.length prefix) - --- | --- --- - -addUnderscores - :: String - -> String +addUnderscores :: + String -> + String addUnderscores = camelTo2 '_' - toQueryParamIfJust :: ToHttpApiData a => Text -> Maybe a -> Form toQueryParamIfJust key = diff --git a/tests/JSONGolden.hs b/tests/JSONGolden.hs new file mode 100644 --- /dev/null +++ b/tests/JSONGolden.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TemplateHaskell #-} + +module JSONGolden (oneGoldenTestDecode, oneGoldenTestEncode) where + +import Data.Aeson (eitherDecode) +import Data.Aeson.Encode.Pretty qualified as AP +import Data.ByteString.Lazy qualified as LBS +import Data.Text (stripEnd) +import Data.Text.IO qualified as T +import Language.Haskell.TH (Exp (..), Lit (..)) +import Language.Haskell.TH.Syntax.Compat (makeRelativeToProject) +import Test.Hspec.Core.Spec (SpecM) +import Test.Hspec.Golden +import TestImport +import Text.Pretty.Simple (pShowNoColor) +import Type.Reflection + +-- this requires the filepath hacking like this so it can be run from arbitrary +-- working directories +filename :: Text -> Text -> FilePath +filename tycon name = $(LitE . StringL <$> makeRelativeToProject "tests/golden") unpack tycon unpack name + +typeName :: forall a. Typeable a => Text +typeName = pack . tyConName . typeRepTyCon $ typeRep @a + +goldenTestDecode :: forall a. (FromJSON a, Show a, Typeable a) => Text -> LByteString -> Golden Text +goldenTestDecode name rawInput = do + let output = either error id $ eitherDecode @a rawInput + theTypeName = typeName @a + in Golden + { output = toStrict . pShowNoColor $ output + , encodePretty = unpack + , writeToFile = T.writeFile + , -- deal with vim related EOF + readFromFile = \fname -> stripEnd <$> T.readFile fname + , goldenFile = filename theTypeName name ++ ".golden" + , actualFile = Just $ filename theTypeName name ++ ".actual" + , failFirstTime = True + } + +goldenTestEncode :: forall a. (ToJSON a, Typeable a) => Text -> a -> Golden Text +goldenTestEncode name value = do + let output = AP.encodePretty @a value + theTypeName = typeName @a + in Golden + { output = cs output + , encodePretty = unpack + , writeToFile = T.writeFile + , -- deal with vim related EOF + readFromFile = \fname -> stripEnd <$> T.readFile fname + , goldenFile = filename theTypeName name ++ ".golden.json" + , actualFile = Just $ filename theTypeName name ++ ".actual.json" + , failFirstTime = True + } + +oneGoldenTestEncode :: forall a. (ToJSON a, Typeable a) => Text -> a -> SpecM () () +oneGoldenTestEncode name value = do + it (unpack name) $ goldenTestEncode @a name value + +oneGoldenTestDecode :: forall a. (FromJSON a, Show a, Typeable a) => Text -> SpecM () () +oneGoldenTestDecode name = do + input <- runIO . LBS.readFile $ filename (typeName @a) name <> ".json" + it (unpack name) $ goldenTestDecode @a name input diff --git a/tests/TestImport.hs b/tests/TestImport.hs new file mode 100644 --- /dev/null +++ b/tests/TestImport.hs @@ -0,0 +1,18 @@ +module TestImport + ( fromJust, + module Control.Monad.Fail, + module Test.Hspec, + module ClassyPrelude, + module Data.Aeson, + module Data.Aeson.TH, + cs, + ) +where + +import ClassyPrelude hiding (link) +import Control.Monad.Fail +import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.=)) +import Data.Aeson.TH (deriveJSON) +import Data.Maybe (fromJust) +import Data.String.Conversions (cs) +import Test.Hspec diff --git a/tests/Web/Slack/ChatSpec.hs b/tests/Web/Slack/ChatSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Web/Slack/ChatSpec.hs @@ -0,0 +1,11 @@ +module Web.Slack.ChatSpec (spec) where + +import JSONGolden +import TestImport +import Web.Slack.Chat (UpdateRsp) + +spec :: Spec +spec = describe "Chat methods" do + describe "chat.update" do + describe "Response FromJSON" do + mapM_ (oneGoldenTestDecode @UpdateRsp) ["sample", "actual"] diff --git a/tests/Web/Slack/ConversationSpec.hs b/tests/Web/Slack/ConversationSpec.hs --- a/tests/Web/Slack/ConversationSpec.hs +++ b/tests/Web/Slack/ConversationSpec.hs @@ -4,36 +4,22 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Web.Slack.ConversationSpec - ( spec - ) where + ( spec, + ) +where -- aeson import Data.Aeson - --- base -import Data.Maybe - --- hspec -import Test.Hspec +-- time +import Data.Time.Clock.POSIX +import JSONGolden import Test.Hspec.QuickCheck - --- QuickCheck import Test.QuickCheck - --- quickcheck-instances import Test.QuickCheck.Instances () - --- slack-web +import TestImport import Web.Slack.Common import Web.Slack.Conversation --- text -import Data.Text (Text) - --- time -import Data.Time.Clock.POSIX - - instance Arbitrary MessageType where arbitrary = return MessageTypeMessage @@ -55,71 +41,97 @@ arbitrary = Purpose <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary ChannelConversation where - arbitrary = ChannelConversation - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary + arbitrary = + ChannelConversation + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary instance Arbitrary GroupConversation where - arbitrary = GroupConversation - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary + arbitrary = + GroupConversation + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary instance Arbitrary ImConversation where - arbitrary = ImConversation - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary + arbitrary = + ImConversation + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary instance Arbitrary Conversation where arbitrary = oneof [Channel <$> arbitrary, Group <$> arbitrary, Im <$> arbitrary] +deriving newtype instance Arbitrary ConversationId -deriving instance Arbitrary ConversationId -deriving instance Arbitrary SlackMessageText -deriving instance Arbitrary TeamId +deriving newtype instance Arbitrary SlackMessageText +deriving newtype instance Arbitrary TeamId spec :: Spec spec = describe "ToJSON and FromJSON for Conversation" $ do - prop "the encoded json is decoded as " $ \conversation -> do - actual <- either fail return . eitherDecode $ encode conversation - actual `shouldBe` (conversation :: Conversation) + prop "the encoded json is decoded as " $ \conversation -> do + actual <- either fail return . eitherDecode $ encode conversation + actual `shouldBe` (conversation :: Conversation) + + describe "Golden tests" $ do + mapM_ (oneGoldenTestDecode @Conversation) ["shared_channel"] + + it "errors accurately if no variant matches" $ do + let badData = + object + [ ("is_group", Bool False) + , ("is_im", Bool False) + , ("is_channel", Bool False) + ] + fromJSON @Conversation badData + `shouldBe` Error "parsing a Conversation failed: neither channel, group, nor im: expected Conversation, but encountered Object" + + it "has good errors if a variant matches but is missing fields" $ do + let badData = + object + [ ("is_group", Bool False) + , ("is_im", Bool False) + , ("is_channel", Bool True) + ] + fromJSON @Conversation badData + `shouldBe` Error "When parsing the record ChannelConversation of type Web.Slack.Conversation.ChannelConversation the key id was not present." diff --git a/tests/Web/Slack/Experimental/BlocksSpec.hs b/tests/Web/Slack/Experimental/BlocksSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Web/Slack/Experimental/BlocksSpec.hs @@ -0,0 +1,89 @@ +module Web.Slack.Experimental.BlocksSpec where + +import Control.Monad.Writer.Strict +import Data.StringVariants (mkNonEmptyText) +import JSONGolden (oneGoldenTestEncode) +import TestImport +import Web.Slack.Experimental.Blocks +import Web.Slack.Experimental.Blocks.Types + +-- FIXME(jadel, violet): These builder things should probably be put into a +-- module to make them available, but that's later work + +headerBlock :: SlackText -> WriterT [SlackBlock] Identity () +headerBlock = tell . pure . SlackBlockHeader . SlackPlainTextOnly + +sectionBlock :: SlackText -> WriterT [SlackBlock] Identity () +sectionBlock text = tell . pure $ SlackBlockSection text Nothing + +sectionBlockWithAccessory :: + SlackText -> + SlackAction -> + WriterT [SlackBlock] Identity () +sectionBlockWithAccessory a b = tell . pure $ SlackBlockSection a (Just . SlackButtonAccessory $ b) + +dividerBlock :: WriterT [SlackBlock] Identity () +dividerBlock = tell . pure $ SlackBlockDivider + +contextBlock :: [SlackContent] -> WriterT [SlackBlock] Identity () +contextBlock = tell . pure . SlackBlockContext . SlackContext + +actionsBlock :: + Maybe SlackBlockId -> + SlackActionList -> + WriterT [SlackBlock] Identity () +actionsBlock a b = tell . pure $ SlackBlockActions a b + +slackActionDoNothing :: SlackActionId +slackActionDoNothing = SlackActionId . fromJust . mkNonEmptyText $ "doNothing" + +slackActionDoNothing2 :: SlackActionId +slackActionDoNothing2 = SlackActionId . fromJust . mkNonEmptyText $ "doNothing2" + +slackActionDoNothing3 :: SlackActionId +slackActionDoNothing3 = SlackActionId . fromJust . mkNonEmptyText $ "doNothing3" + +slackShowBlockFormat :: BlockKitBuilderMessage +slackShowBlockFormat = + BlockKitBuilderMessage $ + execWriter $ do + headerBlock ("Blah: " <> list ["a", "b", "c"]) + dividerBlock + sectionBlock (bold $ list ["blah", "blah2", "blah3"]) + sectionBlockWithAccessory + (monospaced @Text "blah") + (button slackActionDoNothing ":mag: Look at it" buttonSettings {buttonUrl = google}) + sectionBlockWithAccessory + (bold $ list ["blah", "blah2", "blah3"]) + (button slackActionDoNothing ":office: Look at it but different" buttonSettings {buttonUrl = google}) + sectionBlock (bold (textMessage "Letters:") <> newline (list ["a", "b", "c"])) + sectionBlock (list ["blah1", "blah2", "blah3"]) + dividerBlock + sectionBlock (bold . textMessage $ "blah") + sectionBlockWithAccessory + (bold . textMessage $ "blah") + (button slackActionDoNothing ":bank: Look at it!" buttonSettings {buttonUrl = google}) + contextBlock [SlackContentText ":key: Context!"] + dividerBlock + actionsBlock Nothing $ + toSlackActionList + ( button slackActionDoNothing ":mag: View" buttonSettings {buttonUrl = google} + , button slackActionDoNothing2 ":office: View" buttonSettings {buttonUrl = google} + , button slackActionDoNothing3 ":bank: View" buttonSettings {buttonUrl = google} + ) + where + textMessage = message @Text + list x = textMessage (intercalate ", " x) + google = OptionalSetting . mkNonEmptyText @3000 $ "https://google.com" + +-- | This is used so that we can paste the output of these tests directly into +-- the block kit builder: +-- +newtype BlockKitBuilderMessage = BlockKitBuilderMessage {blocks :: [SlackBlock]} + +instance ToJSON BlockKitBuilderMessage where + toJSON BlockKitBuilderMessage {blocks} = object [("blocks", toJSON blocks)] + +spec :: Spec +spec = describe "Slack block builder" do + oneGoldenTestEncode "simple_blocks" slackShowBlockFormat diff --git a/tests/Web/Slack/Experimental/Events/TypesSpec.hs b/tests/Web/Slack/Experimental/Events/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Web/Slack/Experimental/Events/TypesSpec.hs @@ -0,0 +1,23 @@ +module Web.Slack.Experimental.Events.TypesSpec (spec) where + +import JSONGolden +import TestImport +import Web.Slack.Experimental.Events.Types + +spec :: Spec +spec = describe "Types for Slack events" do + describe "SlackWebhookEvent" do + describe "FromJSON" do + mapM_ + (oneGoldenTestDecode @SlackWebhookEvent) + [ "messageExample" + , "messageChange" + , "link" + , "botMessage" + , "joinChannel" + , "createChannel" + , "messageIm" + , "slackbotIm" + , "channel_left" + , "share_without_message" + ] diff --git a/tests/Web/Slack/Experimental/RequestVerificationSpec.hs b/tests/Web/Slack/Experimental/RequestVerificationSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Web/Slack/Experimental/RequestVerificationSpec.hs @@ -0,0 +1,50 @@ +module Web.Slack.Experimental.RequestVerificationSpec where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Time.Clock.POSIX +import TestImport +import Web.Slack.Experimental.RequestVerification + +spec :: Spec +spec = do + let timestamp = SlackRequestTimestamp "1665615887" -- Oct 12 2022 23:04:47 GMT+0000 + let sig = SlackSignature "v0=f7f0a2f48ae5fe2c923813af0a7c7636396fea6e03edb3d73580a99cd1913575" + let slackSigningSecret = SlackSigningSecret "SIGNING_SECRET" + -- matches the test timestamp within one minute + goodUtcTime = utcTimeToPOSIXSeconds $ UTCTime (fromGregorian 2022 10 12) (23 * 60 * 60 + 5 * 60) + -- back to the future + someoneGotATimeMachineUtcTime = utcTimeToPOSIXSeconds $ UTCTime (fromGregorian 2020 1 1) 0 + oldUtcTime = utcTimeToPOSIXSeconds $ UTCTime (fromGregorian 2025 10 12) (23 * 60 * 60 + 5 * 60) + + -- the simplest possible JSON; this thing just parses it straight through + -- anyway + requestBody = "{}" + + describe "Slack Webhook" $ do + it "Correctly validates webhooks" $ do + validateRequest' goodUtcTime slackSigningSecret sig timestamp requestBody + `shouldBe` (Right $ Object KeyMap.empty) + + it "Handles incorrect timestamp" $ do + validateRequest' @Value goodUtcTime slackSigningSecret sig (SlackRequestTimestamp "bad") requestBody + `shouldBe` Left (VerificationMalformedTimestamp "bad") + + it "Handles invalid signature" $ do + validateRequest' @Value goodUtcTime slackSigningSecret (SlackSignature "the_v0_prefix_missing") timestamp requestBody + `shouldBe` Left (VerificationUnknownSignatureVersion "the_v0_prefix_missing") + + it "Handles signature mismatch" $ do + let badSignature = SlackSignature "v0=bad0bad0bad0bad0bad0bad0bad0bad0bad0bad0bad0bad0bad0bad0bad0bad0" + validateRequest' @Value goodUtcTime slackSigningSecret badSignature timestamp requestBody + `shouldBe` Left VerificationSignatureMismatch + + it "Handles timestamp in the future" $ do + -- it's "in 2020" and someone gave us a 2022 timestamp + validateRequest' @Value someoneGotATimeMachineUtcTime slackSigningSecret sig timestamp requestBody + `shouldBe` Left (VerificationTimestampOutOfRange 1665615887) + + it "Handles timestamp in the past" $ do + -- it's "in 2025" and someone gave us a 2022 timestamp + validateRequest' @Value oldUtcTime slackSigningSecret sig timestamp requestBody + `shouldBe` (Left (VerificationTimestampOutOfRange 1665615887)) diff --git a/tests/Web/Slack/MessageParserSpec.hs b/tests/Web/Slack/MessageParserSpec.hs --- a/tests/Web/Slack/MessageParserSpec.hs +++ b/tests/Web/Slack/MessageParserSpec.hs @@ -1,25 +1,18 @@ -{-# LANGUAGE OverloadedStrings #-} - module Web.Slack.MessageParserSpec (spec) where --- hspec -import Test.Hspec - --- slack-web +import TestImport import Web.Slack.MessageParser import Web.Slack.Types --- text -import Data.Text (Text) - testGetUserDesc :: UserId -> Text testGetUserDesc (UserId "USER1") = "user_one" testGetUserDesc x = unUserId x testHtmlRenderers :: HtmlRenderers -testHtmlRenderers = HtmlRenderers - { emoticonRenderer = \x -> ":>" <> x <> "<:" - } +testHtmlRenderers = + HtmlRenderers + { emoticonRenderer = \x -> ":>" <> x <> "<:" + } msgToHtml :: Text -> Text msgToHtml = messageToHtml testHtmlRenderers testGetUserDesc . SlackMessageText @@ -31,12 +24,10 @@ msgToHtml "hello" `shouldBe` "hello" it "converts a simple message to HTML correctly" $ msgToHtml "_hello_ *world* `code` ```longer\ncode```" - `shouldBe` - "hello world google code 
longer\ncode
" + `shouldBe` "hello world google code 
longer\ncode
" it "degrades properly to return the input message if it's incorrect" $ msgToHtml "link not closed
b.
:>slightly_smiling_face<:" it "properly parses multiline blockquotes" $ msgToHtml "> first row\n> second row\nthird row\n> fourth row" - `shouldBe` - "
first row
second row
third row
fourth row
" + `shouldBe` "
first row
second row
third row
fourth row
" it "converts usernames" $ msgToHtml "<@USER1> should be converted, <@USER1|default> stay default" - `shouldBe` - "@user_one should be converted, @default stay default" + `shouldBe` "@user_one should be converted, @default stay default" it "converts carriage returns" $ msgToHtml "a\nb" `shouldBe` "a
b" it "handles full stops as punctuation" $ diff --git a/tests/Web/Slack/PagerSpec.hs b/tests/Web/Slack/PagerSpec.hs --- a/tests/Web/Slack/PagerSpec.hs +++ b/tests/Web/Slack/PagerSpec.hs @@ -1,48 +1,30 @@ -{-# LANGUAGE OverloadedStrings #-} - module Web.Slack.PagerSpec (spec) where --- base -import Control.Exception (throwIO) -import Data.Maybe (fromJust) - --- fakepull -import Test.Pull.Fake.IO (FakeStream, pull, newFakeStream) - --- hspec -import Test.Hspec - --- slack-web -import Web.Slack.Pager +import Data.Text qualified as Text +-- time +import Data.Time.Clock (addUTCTime, nominalDay) +import Test.Pull.Fake.IO (FakeStream, newFakeStream, pull) +import TestImport import Web.Slack.Common - ( mkSlackTimestamp - , Cursor (..) - , Message (..) - , MessageType (..) - , SlackMessageText (..) + ( Message (..), + MessageType (..), + SlackMessageText (..), + mkSlackTimestamp, ) import Web.Slack.Conversation - ( ConversationId (ConversationId) - , mkHistoryReq - , mkRepliesReq - , HistoryReq (..) - , HistoryRsp (..) - , RepliesReq (..) - , ResponseMetadata (..) + ( ConversationId (ConversationId), + HistoryReq (..), + HistoryRsp (..), + RepliesReq (..), + mkHistoryReq, + mkRepliesReq, ) +import Web.Slack.Pager import Web.Slack.Types (UserId (..)) --- text -import qualified Data.Text as Text - --- time -import Data.Time.Clock (getCurrentTime, nominalDay, addUTCTime) - - stubbedSendRequest :: FakeStream (Response HistoryRsp) -> a -> IO (Response HistoryRsp) stubbedSendRequest stream _request = fromJust <$> pull stream - spec :: Spec spec = do let prepare = do @@ -54,35 +36,38 @@ allResponses = do -- According to https://api.slack.com/docs/pagination, -- The last page's cursor can be either an empty string, null, or non-exisitent in the object. - (pageN, cursor) <- zip [1..3] ["cursor1=", "cursor2=", ""] + (pageN, cursor) <- zip [1 .. 3] ["cursor1=", "cursor2=", ""] let pageNT = Text.pack (show pageN) - pure . Right $ HistoryRsp - { historyRspMessages = do - messageN <- [1..messagesPerPage] - let messagesPerPageNDT = fromIntegral messagesPerPage - messageNDT = fromIntegral messageN - messageNT = Text.pack (show messageN) - createdBefore = negate $ nominalDay * ((pageN - 1) * messagesPerPageNDT + messageNDT) - pure $ Message - MessageTypeMessage - (Just . UserId $ "U" <> pageNT <> messageNT) - (SlackMessageText $ "message " <> pageNT <> "-" <> messageNT) - (mkSlackTimestamp $ addUTCTime createdBefore nowUtc) - , historyRspResponseMetadata = Just . ResponseMetadata . Just $ Cursor cursor - } + pure . Right $ + HistoryRsp + { historyRspMessages = do + messageN <- [1 .. messagesPerPage] + let messagesPerPageNDT = fromIntegral messagesPerPage + messageNDT = fromIntegral messageN + messageNT = Text.pack (show messageN) + createdBefore = negate $ nominalDay * ((pageN - 1) * messagesPerPageNDT + messageNDT) + pure $ + Message + MessageTypeMessage + (Just . UserId $ "U" <> pageNT <> messageNT) + (SlackMessageText $ "message " <> pageNT <> "-" <> messageNT) + (mkSlackTimestamp $ addUTCTime createdBefore nowUtc) + , historyRspResponseMetadata = Just . ResponseMetadata . Just $ Cursor cursor + } responsesToReturn <- newFakeStream allResponses return (now, oldest, messagesPerPage, allResponses, responsesToReturn) describe "conversationsHistoryAllBy" $ it "collect all results by sending requests" $ do (now, oldest, messagesPerPage, allResponses, responsesToReturn) <- prepare - let initialRequest = (mkHistoryReq (ConversationId "C01234567")) - { historyReqCount = messagesPerPage - , historyReqLatest = Just now - , historyReqOldest = Just oldest - , historyReqInclusive = False - } - loadPage <- conversationsHistoryAllBy (stubbedSendRequest responsesToReturn) initialRequest + let initialRequest = + (mkHistoryReq (ConversationId "C01234567")) + { historyReqCount = messagesPerPage + , historyReqLatest = Just now + , historyReqOldest = Just oldest + , historyReqInclusive = False + } + loadPage <- fetchAllBy (stubbedSendRequest responsesToReturn) initialRequest let actual = unfoldPageM $ either throwIO return =<< loadPage expected <- fmap (map historyRspMessages) . either throwIO return $ sequenceA allResponses actual `shouldReturn` expected @@ -90,24 +75,24 @@ describe "repliesFetchAllBy" $ it "collect all results by sending requests" $ do (now, oldest, messagesPerPage, allResponses, responsesToReturn) <- prepare - let initialRequest = (mkRepliesReq (ConversationId "C98765432") oldest) - { repliesReqLimit = messagesPerPage - , repliesReqLatest = Just now - , repliesReqOldest = Just oldest - , repliesReqInclusive = False - } - loadPage <- repliesFetchAllBy (stubbedSendRequest responsesToReturn) initialRequest + let initialRequest = + (mkRepliesReq (ConversationId "C98765432") oldest) + { repliesReqLimit = messagesPerPage + , repliesReqLatest = Just now + , repliesReqOldest = Just oldest + , repliesReqInclusive = False + } + loadPage <- fetchAllBy (stubbedSendRequest responsesToReturn) initialRequest let actual = unfoldPageM $ either throwIO return =<< loadPage expected <- fmap (map historyRspMessages) . either throwIO return $ sequenceA allResponses actual `shouldReturn` expected - -- | Runs the given action repeatedly until it returns an empty list. unfoldPageM :: Monad m => m [a] -> m [[a]] unfoldPageM act = reverse <$> go [] - where - go accum = do - x <- act - case x of + where + go accum = do + x <- act + case x of [] -> return accum xs -> go $! xs : accum diff --git a/tests/Web/Slack/UsersConversationsSpec.hs b/tests/Web/Slack/UsersConversationsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Web/Slack/UsersConversationsSpec.hs @@ -0,0 +1,10 @@ +module Web.Slack.UsersConversationsSpec (spec) where + +import JSONGolden +import TestImport +import Web.Slack.UsersConversations (UsersConversationsResponse) + +spec :: Spec +spec = describe "User conversations method" do + describe "Response FromJSON" do + mapM_ (oneGoldenTestDecode @UsersConversationsResponse) ["im_and_channels"] diff --git a/tests/golden/BlockKitBuilderMessage/simple_blocks.golden.json b/tests/golden/BlockKitBuilderMessage/simple_blocks.golden.json new file mode 100644 --- /dev/null +++ b/tests/golden/BlockKitBuilderMessage/simple_blocks.golden.json @@ -0,0 +1,137 @@ +{ + "blocks": [ + { + "text": { + "text": "Blah: \na, b, c", + "type": "plain_text" + }, + "type": "header" + }, + { + "type": "divider" + }, + { + "text": { + "text": "*blah, blah2, blah3*", + "type": "mrkdwn" + }, + "type": "section" + }, + { + "accessory": { + "action_id": "doNothing", + "text": { + "text": ":mag: Look at it", + "type": "plain_text" + }, + "type": "button", + "url": "https://google.com" + }, + "text": { + "text": "`blah`", + "type": "mrkdwn" + }, + "type": "section" + }, + { + "accessory": { + "action_id": "doNothing", + "text": { + "text": ":office: Look at it but different", + "type": "plain_text" + }, + "type": "button", + "url": "https://google.com" + }, + "text": { + "text": "*blah, blah2, blah3*", + "type": "mrkdwn" + }, + "type": "section" + }, + { + "text": { + "text": "*Letters:*\na, b, c", + "type": "mrkdwn" + }, + "type": "section" + }, + { + "text": { + "text": "blah1, blah2, blah3", + "type": "mrkdwn" + }, + "type": "section" + }, + { + "type": "divider" + }, + { + "text": { + "text": "*blah*", + "type": "mrkdwn" + }, + "type": "section" + }, + { + "accessory": { + "action_id": "doNothing", + "text": { + "text": ":bank: Look at it!", + "type": "plain_text" + }, + "type": "button", + "url": "https://google.com" + }, + "text": { + "text": "*blah*", + "type": "mrkdwn" + }, + "type": "section" + }, + { + "elements": [ + { + "text": ":key: Context!", + "type": "mrkdwn" + } + ], + "type": "context" + }, + { + "type": "divider" + }, + { + "elements": [ + { + "action_id": "doNothing", + "text": { + "text": ":mag: View", + "type": "plain_text" + }, + "type": "button", + "url": "https://google.com" + }, + { + "action_id": "doNothing2", + "text": { + "text": ":office: View", + "type": "plain_text" + }, + "type": "button", + "url": "https://google.com" + }, + { + "action_id": "doNothing3", + "text": { + "text": ":bank: View", + "type": "plain_text" + }, + "type": "button", + "url": "https://google.com" + } + ], + "type": "actions" + } + ] +} diff --git a/tests/golden/Conversation/shared_channel.golden b/tests/golden/Conversation/shared_channel.golden new file mode 100644 --- /dev/null +++ b/tests/golden/Conversation/shared_channel.golden @@ -0,0 +1,32 @@ +Channel + ( ChannelConversation + { channelId = ConversationId + { unConversationId = "C0000000000" } + , channelName = "shared-channel" + , channelCreated = 1667519517 + , channelIsArchived = False + , channelIsGeneral = False + , channelUnlinked = 0 + , channelNameNormalized = "shared-channel" + , channelIsShared = True + , channelCreator = UserId + { unUserId = "UAAAAAAAA" } + , channelIsExtShared = True + , channelIsOrgShared = False + , channelSharedTeamIds = Nothing + , channelIsPendingExtShared = False + , channelIsMember = Just False + , channelTopic = Topic + { topicValue = "" + , topicCreator = "" + , topicLastSet = 0 + } + , channelPurpose = Purpose + { purposeValue = "" + , purposeCreator = "" + , purposeLastSet = 0 + } + , channelPreviousNames = [] + , channelNumMembers = Just 12 + } + ) diff --git a/tests/golden/Conversation/shared_channel.json b/tests/golden/Conversation/shared_channel.json new file mode 100644 --- /dev/null +++ b/tests/golden/Conversation/shared_channel.json @@ -0,0 +1,37 @@ +{ + "id": "C0000000000", + "name": "shared-channel", + "is_channel": true, + "is_group": false, + "is_im": false, + "is_mpim": false, + "is_private": false, + "created": 1667519517, + "is_archived": false, + "is_general": false, + "unlinked": 0, + "name_normalized": "shared-channel", + "is_shared": true, + "is_org_shared": false, + "is_pending_ext_shared": false, + "pending_shared": [], + "context_team_id": "TAAAAAAAA", + "parent_conversation": null, + "creator": "UAAAAAAAA", + "is_ext_shared": true, + "pending_connected_team_ids": [], + "conversation_host_id": "TAAAAAAAA", + "is_member": false, + "topic": { + "value": "", + "creator": "", + "last_set": 0 + }, + "purpose": { + "value": "", + "creator": "", + "last_set": 0 + }, + "previous_names": [], + "num_members": 12 +} diff --git a/tests/golden/SlackWebhookEvent/botMessage.golden b/tests/golden/SlackWebhookEvent/botMessage.golden new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/botMessage.golden @@ -0,0 +1,42 @@ +EventEventCallback + ( EventCallback + { eventId = EventId + { unEventId = "Ev043VFLT545" } + , teamId = TeamId + { unTeamId = "T043DB835ML" } + , eventTime = MkSystemTime + { systemSeconds = 1664216870 + , systemNanoseconds = 0 + } + , event = EventMessage + ( MessageEvent + { blocks = Just + [ RichText + { blockId = Just + ( NonEmptyText "FVI" ) + , elements = + [ RichTextSectionItemRichText + [ RichItemText "TEST" + ( RichStyle + { rsBold = False + , rsItalic = False + } + ) + ] + ] + } + ] + , channel = ConversationId + { unConversationId = "C043YJGBY49" } + , text = "TEST" + , channelType = Channel + , user = UserId + { unUserId = "U0442US8QGH" } + , ts = "1664216870.477049" + , threadTs = Just "1664216109.798919" + , appId = Just "A0442TUPHGR" + , botId = Just "B0439P161B9" + } + ) + } + ) diff --git a/tests/golden/SlackWebhookEvent/botMessage.json b/tests/golden/SlackWebhookEvent/botMessage.json new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/botMessage.json @@ -0,0 +1,63 @@ +{ + "token": "aaaa", + "team_id": "T043DB835ML", + "api_app_id": "A0442TUPHGR", + "event": { + "bot_id": "B0439P161B9", + "type": "message", + "text": "TEST", + "user": "U0442US8QGH", + "ts": "1664216870.477049", + "app_id": "A0442TUPHGR", + "team": "T043DB835ML", + "bot_profile": { + "id": "B0439P161B9", + "deleted": false, + "name": "Slacklinker dev", + "updated": 1663960005, + "app_id": "A0442TUPHGR", + "icons": { + "image_36": "https://a.slack-edge.com/80588/img/plugins/app/bot_36.png", + "image_48": "https://a.slack-edge.com/80588/img/plugins/app/bot_48.png", + "image_72": "https://a.slack-edge.com/80588/img/plugins/app/service_72.png" + }, + "team_id": "T043DB835ML" + }, + "blocks": [ + { + "type": "rich_text", + "block_id": "FVI", + "elements": [ + { + "type": "rich_text_section", + "elements": [ + { + "type": "text", + "text": "TEST" + } + ] + } + ] + } + ], + "thread_ts": "1664216109.798919", + "parent_user_id": "U043H11ES4V", + "channel": "C043YJGBY49", + "event_ts": "1664216870.477049", + "channel_type": "channel" + }, + "type": "event_callback", + "event_id": "Ev043VFLT545", + "event_time": 1664216870, + "authorizations": [ + { + "enterprise_id": null, + "team_id": "T043DB835ML", + "user_id": "U0442US8QGH", + "is_bot": true, + "is_enterprise_install": false + } + ], + "is_ext_shared_channel": false, + "event_context": "aaaa" +} diff --git a/tests/golden/SlackWebhookEvent/channel_left.golden b/tests/golden/SlackWebhookEvent/channel_left.golden new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/channel_left.golden @@ -0,0 +1,21 @@ +EventEventCallback + ( EventCallback + { eventId = EventId + { unEventId = "Ev044RKJHB8W" } + , teamId = TeamId + { unTeamId = "T043DB835ML" } + , eventTime = MkSystemTime + { systemSeconds = 1664827321 + , systemNanoseconds = 0 + } + , event = EventChannelLeft + ( ChannelLeftEvent + { actorId = UserId + { unUserId = "U043H11ES4V" } + , channel = ConversationId + { unConversationId = "C043KSKGJUB" } + , eventTs = "1664827321.000300" + } + ) + } + ) diff --git a/tests/golden/SlackWebhookEvent/channel_left.json b/tests/golden/SlackWebhookEvent/channel_left.json new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/channel_left.json @@ -0,0 +1,24 @@ +{ + "token": "aaaa", + "team_id": "T043DB835ML", + "api_app_id": "A0442TUPHGR", + "event": { + "type": "channel_left", + "channel": "C043KSKGJUB", + "actor_id": "U043H11ES4V", + "event_ts": "1664827321.000300" + }, + "type": "event_callback", + "event_id": "Ev044RKJHB8W", + "event_time": 1664827321, + "authorizations": [ + { + "enterprise_id": null, + "team_id": "T043DB835ML", + "user_id": "U0442US8QGH", + "is_bot": true, + "is_enterprise_install": false + } + ], + "is_ext_shared_channel": false +} diff --git a/tests/golden/SlackWebhookEvent/createChannel.golden b/tests/golden/SlackWebhookEvent/createChannel.golden new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/createChannel.golden @@ -0,0 +1,33 @@ +EventEventCallback + ( EventCallback + { eventId = EventId + { unEventId = "Ev0445DETPAA" } + , teamId = TeamId + { unTeamId = "T043DB835ML" } + , eventTime = MkSystemTime + { systemSeconds = 1664404606 + , systemNanoseconds = 0 + } + , event = EventChannelCreated + ( ChannelCreatedEvent + { channel = CreatedChannel + { id = ConversationId + { unConversationId = "C04493BRXEZ" } + , isChannel = True + , name = "new-channel" + , nameNormalized = "new-channel" + , creator = UserId + { unUserId = "U043H11ES4V" } + , created = MkSystemTime + { systemSeconds = 1664404606 + , systemNanoseconds = 0 + } + , isShared = False + , isOrgShared = False + , contextTeamId = TeamId + { unTeamId = "T043DB835ML" } + } + } + ) + } + ) diff --git a/tests/golden/SlackWebhookEvent/createChannel.json b/tests/golden/SlackWebhookEvent/createChannel.json new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/createChannel.json @@ -0,0 +1,33 @@ +{ + "token": "aaaa", + "team_id": "T043DB835ML", + "api_app_id": "A0442TUPHGR", + "event": { + "type": "channel_created", + "channel": { + "id": "C04493BRXEZ", + "is_channel": true, + "name": "new-channel", + "name_normalized": "new-channel", + "created": 1664404606, + "creator": "U043H11ES4V", + "is_shared": false, + "is_org_shared": false, + "context_team_id": "T043DB835ML" + }, + "event_ts": "1664404606.000700" + }, + "type": "event_callback", + "event_id": "Ev0445DETPAA", + "event_time": 1664404606, + "authorizations": [ + { + "enterprise_id": null, + "team_id": "T043DB835ML", + "user_id": "U0442US8QGH", + "is_bot": true, + "is_enterprise_install": false + } + ], + "is_ext_shared_channel": false +} diff --git a/tests/golden/SlackWebhookEvent/joinChannel.golden b/tests/golden/SlackWebhookEvent/joinChannel.golden new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/joinChannel.golden @@ -0,0 +1,13 @@ +EventEventCallback + ( EventCallback + { eventId = EventId + { unEventId = "Ev043W120WSH" } + , teamId = TeamId + { unTeamId = "T043DB835ML" } + , eventTime = MkSystemTime + { systemSeconds = 1664222685 + , systemNanoseconds = 0 + } + , event = EventChannelJoinMessage + } + ) diff --git a/tests/golden/SlackWebhookEvent/joinChannel.json b/tests/golden/SlackWebhookEvent/joinChannel.json new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/joinChannel.json @@ -0,0 +1,30 @@ +{ + "token": "aaaa", + "team_id": "T043DB835ML", + "api_app_id": "A0442TUPHGR", + "event": { + "type": "message", + "subtype": "channel_join", + "ts": "1664222685.728809", + "user": "U0442US8QGH", + "text": "<@U0442US8QGH> has joined the channel", + "inviter": "U043H11ES4V", + "channel": "C043KSKGJUB", + "event_ts": "1664222685.728809", + "channel_type": "channel" + }, + "type": "event_callback", + "event_id": "Ev043W120WSH", + "event_time": 1664222685, + "authorizations": [ + { + "enterprise_id": null, + "team_id": "T043DB835ML", + "user_id": "U0442US8QGH", + "is_bot": true, + "is_enterprise_install": false + } + ], + "is_ext_shared_channel": false, + "event_context": "aaaa" +} diff --git a/tests/golden/SlackWebhookEvent/link.golden b/tests/golden/SlackWebhookEvent/link.golden new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/link.golden @@ -0,0 +1,46 @@ +EventEventCallback + ( EventCallback + { eventId = EventId + { unEventId = "Ev043R67DQ1H" } + , teamId = TeamId + { unTeamId = "T043DB835ML" } + , eventTime = MkSystemTime + { systemSeconds = 1663978925 + , systemNanoseconds = 0 + } + , event = EventMessage + ( MessageEvent + { blocks = Just + [ RichText + { blockId = Just + ( NonEmptyText "MEdM" ) + , elements = + [ RichTextSectionItemRichText + [ RichItemLink + ( RichLinkAttrs + { style = RichStyle + { rsBold = False + , rsItalic = False + } + , url = "https://jadeapptesting.slack.com/archives/C043YJGBY49/p1663961604007869" + , text = Nothing + } + ) + ] + ] + } + ] + , channel = ConversationId + { unConversationId = "C043YJGBY49" } + , text = "" + , channelType = Channel + , user = UserId + { unUserId = "U043H11ES4V" } + , ts = "1663978925.099999" + , threadTs = Nothing + , appId = Nothing + , botId = Nothing + } + ) + } + ) diff --git a/tests/golden/SlackWebhookEvent/link.json b/tests/golden/SlackWebhookEvent/link.json new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/link.json @@ -0,0 +1,47 @@ +{ + "token": "aaaa", + "team_id": "T043DB835ML", + "api_app_id": "A0442TUPHGR", + "event": { + "client_msg_id": "ade2a33a-3aa8-4fcf-9b93-2e44e4a92899", + "type": "message", + "text": "", + "user": "U043H11ES4V", + "ts": "1663978925.099999", + "team": "T043DB835ML", + "blocks": [ + { + "type": "rich_text", + "block_id": "MEdM", + "elements": [ + { + "type": "rich_text_section", + "elements": [ + { + "type": "link", + "url": "https://jadeapptesting.slack.com/archives/C043YJGBY49/p1663961604007869" + } + ] + } + ] + } + ], + "channel": "C043YJGBY49", + "event_ts": "1663978925.099999", + "channel_type": "channel" + }, + "type": "event_callback", + "event_id": "Ev043R67DQ1H", + "event_time": 1663978925, + "authorizations": [ + { + "enterprise_id": null, + "team_id": "T043DB835ML", + "user_id": "U0442US8QGH", + "is_bot": true, + "is_enterprise_install": false + } + ], + "is_ext_shared_channel": false, + "event_context": "aaaa" +} diff --git a/tests/golden/SlackWebhookEvent/messageChange.golden b/tests/golden/SlackWebhookEvent/messageChange.golden new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/messageChange.golden @@ -0,0 +1,13 @@ +EventEventCallback + ( EventCallback + { eventId = EventId + { unEventId = "Ev043QRVT9FD" } + , teamId = TeamId + { unTeamId = "T043DB835ML" } + , eventTime = MkSystemTime + { systemSeconds = 1663969334 + , systemNanoseconds = 0 + } + , event = EventMessageChanged + } + ) diff --git a/tests/golden/SlackWebhookEvent/messageChange.json b/tests/golden/SlackWebhookEvent/messageChange.json new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/messageChange.json @@ -0,0 +1,127 @@ +{ + "token": "aaaa", + "team_id": "T043DB835ML", + "api_app_id": "A0442TUPHGR", + "event": { + "type": "message", + "subtype": "message_changed", + "message": { + "client_msg_id": "de349a9f-62a4-4293-b64d-701a1f566e8a", + "type": "message", + "text": "", + "user": "U043H11ES4V", + "team": "T043DB835ML", + "attachments": [ + { + "from_url": "https://jadeapptesting.slack.com/archives/C043YJGBY49/p1663966292304369", + "ts": "1663966292.304369", + "author_id": "U043H11ES4V", + "channel_team": "T043DB835ML", + "channel_id": "C043YJGBY49", + "channel_name": "general", + "is_msg_unfurl": true, + "message_blocks": [ + { + "team": "T043DB835ML", + "channel": "C043YJGBY49", + "ts": "1663966292.304369", + "message": { + "blocks": [ + { + "type": "rich_text", + "block_id": "hn8/C", + "elements": [ + { + "type": "rich_text_section", + "elements": [ + { + "type": "text", + "text": "asdfhlkfasdlhsdf" + } + ] + } + ] + } + ] + } + } + ], + "id": 1, + "original_url": "https://jadeapptesting.slack.com/archives/C043YJGBY49/p1663966292304369", + "fallback": "[September 23rd, 2022 1:51 PM] jadel: asdfhlkfasdlhsdf", + "text": "asdfhlkfasdlhsdf", + "author_name": "jadel", + "author_link": "https://jadeapptesting.slack.com/team/U043H11ES4V", + "author_icon": "https://secure.gravatar.com/avatar/dcd5bc53dcfaca62ddc3f5726d07ba13.jpg?s=48&d=https%3A%2F%2Fa.slack-edge.com%2Fdf10d%2Fimg%2Favatars%2Fava_0019-48.png", + "author_subname": "jadel", + "mrkdwn_in": [ + "text" + ], + "footer": "Posted in #general" + } + ], + "blocks": [ + { + "type": "rich_text", + "block_id": "FXy3n", + "elements": [ + { + "type": "rich_text_section", + "elements": [ + { + "type": "link", + "url": "https://jadeapptesting.slack.com/archives/C043YJGBY49/p1663966292304369" + } + ] + } + ] + } + ], + "ts": "1663969333.524439" + }, + "previous_message": { + "client_msg_id": "de349a9f-62a4-4293-b64d-701a1f566e8a", + "type": "message", + "text": "", + "user": "U043H11ES4V", + "ts": "1663969333.524439", + "team": "T043DB835ML", + "blocks": [ + { + "type": "rich_text", + "block_id": "FXy3n", + "elements": [ + { + "type": "rich_text_section", + "elements": [ + { + "type": "link", + "url": "https://jadeapptesting.slack.com/archives/C043YJGBY49/p1663966292304369" + } + ] + } + ] + } + ] + }, + "channel": "C043YJGBY49", + "hidden": true, + "ts": "1663969334.001500", + "event_ts": "1663969334.001500", + "channel_type": "channel" + }, + "type": "event_callback", + "event_id": "Ev043QRVT9FD", + "event_time": 1663969334, + "authorizations": [ + { + "enterprise_id": null, + "team_id": "T043DB835ML", + "user_id": "U0442US8QGH", + "is_bot": true, + "is_enterprise_install": false + } + ], + "is_ext_shared_channel": false, + "event_context": "aaaa" +} diff --git a/tests/golden/SlackWebhookEvent/messageExample.golden b/tests/golden/SlackWebhookEvent/messageExample.golden new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/messageExample.golden @@ -0,0 +1,42 @@ +EventEventCallback + ( EventCallback + { eventId = EventId + { unEventId = "Ev043T7CKN84" } + , teamId = TeamId + { unTeamId = "T043DB835ML" } + , eventTime = MkSystemTime + { systemSeconds = 1663966382 + , systemNanoseconds = 0 + } + , event = EventMessage + ( MessageEvent + { blocks = Just + [ RichText + { blockId = Just + ( NonEmptyText "u6n" ) + , elements = + [ RichTextSectionItemRichText + [ RichItemText "dgsfklsdgf" + ( RichStyle + { rsBold = False + , rsItalic = False + } + ) + ] + ] + } + ] + , channel = ConversationId + { unConversationId = "C043YJGBY49" } + , text = "dgsfklsdgf" + , channelType = Channel + , user = UserId + { unUserId = "U043H11ES4V" } + , ts = "1663966382.046509" + , threadTs = Nothing + , appId = Nothing + , botId = Nothing + } + ) + } + ) diff --git a/tests/golden/SlackWebhookEvent/messageExample.json b/tests/golden/SlackWebhookEvent/messageExample.json new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/messageExample.json @@ -0,0 +1,43 @@ +{ + "token": "aaaaaaaaaaaaaaaaaaaaabbb", + "team_id": "T043DB835ML", + "api_app_id": "A0442TUPHGR", + "event": { + "client_msg_id": "62ee8aaa-b28-4959-b2dc-c0ba4ecbfc7c", + "type": "message", + "text": "dgsfklsdgf", + "user": "U043H11ES4V", + "ts": "1663966382.046509", + "team": "T43DB835ML", + "blocks": [ + { + "type": "rich_text", + "block_id": "u6n", + "elements": [ + { + "type": "rich_text_section", + "elements": [{ "type": "text", "text": "dgsfklsdgf" }] + } + ] + } + ], + "channel": "C043YJGBY49", + "event_ts": "1663966382.046509", + "channel_type": "channel" + }, + "type": "event_callback", + "event_id": "Ev043T7CKN84", + "event_time": 1663966382, + "authorizations": [ + { + "enterprise_id": null, + "team_id": "T043DB835L", + "user_id": "U0442US8QGH", + "is_bot": true, + "is_enterprise_install": false + } + ], + "is_ext_shared_channel": false, + "event_context": "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" +} + diff --git a/tests/golden/SlackWebhookEvent/messageIm.golden b/tests/golden/SlackWebhookEvent/messageIm.golden new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/messageIm.golden @@ -0,0 +1,42 @@ +EventEventCallback + ( EventCallback + { eventId = EventId + { unEventId = "Ev044C51K43V" } + , teamId = TeamId + { unTeamId = "T043DB835ML" } + , eventTime = MkSystemTime + { systemSeconds = 1664408649 + , systemNanoseconds = 0 + } + , event = EventMessage + ( MessageEvent + { blocks = Just + [ RichText + { blockId = Just + ( NonEmptyText "LSo" ) + , elements = + [ RichTextSectionItemRichText + [ RichItemText "test" + ( RichStyle + { rsBold = False + , rsItalic = False + } + ) + ] + ] + } + ] + , channel = ConversationId + { unConversationId = "D0442US94JD" } + , text = "test" + , channelType = Im + , user = UserId + { unUserId = "U043H11ES4V" } + , ts = "1664408649.009629" + , threadTs = Nothing + , appId = Nothing + , botId = Nothing + } + ) + } + ) diff --git a/tests/golden/SlackWebhookEvent/messageIm.json b/tests/golden/SlackWebhookEvent/messageIm.json new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/messageIm.json @@ -0,0 +1,47 @@ +{ + "token": "aaaa", + "team_id": "T043DB835ML", + "api_app_id": "A0442TUPHGR", + "event": { + "client_msg_id": "1efd76a1-5075-4c2c-ad38-1284820b429f", + "type": "message", + "text": "test", + "user": "U043H11ES4V", + "ts": "1664408649.009629", + "team": "T043DB835ML", + "blocks": [ + { + "type": "rich_text", + "block_id": "LSo", + "elements": [ + { + "type": "rich_text_section", + "elements": [ + { + "type": "text", + "text": "test" + } + ] + } + ] + } + ], + "channel": "D0442US94JD", + "event_ts": "1664408649.009629", + "channel_type": "im" + }, + "type": "event_callback", + "event_id": "Ev044C51K43V", + "event_time": 1664408649, + "authorizations": [ + { + "enterprise_id": null, + "team_id": "T043DB835ML", + "user_id": "U0442US8QGH", + "is_bot": true, + "is_enterprise_install": false + } + ], + "is_ext_shared_channel": false, + "event_context": "aaaa" +} diff --git a/tests/golden/SlackWebhookEvent/share_without_message.golden b/tests/golden/SlackWebhookEvent/share_without_message.golden new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/share_without_message.golden @@ -0,0 +1,27 @@ +EventEventCallback + ( EventCallback + { eventId = EventId + { unEventId = "Ev04BEN3QMSM" } + , teamId = TeamId + { unTeamId = "T043DB835ML" } + , eventTime = MkSystemTime + { systemSeconds = 1668537593 + , systemNanoseconds = 0 + } + , event = EventMessage + ( MessageEvent + { blocks = Nothing + , channel = ConversationId + { unConversationId = "C043YJGBY49" } + , text = "" + , channelType = Channel + , user = UserId + { unUserId = "U043H11ES4V" } + , ts = "1668537593.598469" + , threadTs = Nothing + , appId = Nothing + , botId = Nothing + } + ) + } + ) diff --git a/tests/golden/SlackWebhookEvent/share_without_message.json b/tests/golden/SlackWebhookEvent/share_without_message.json new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/share_without_message.json @@ -0,0 +1,78 @@ +{ + "token": "aaaa", + "team_id": "T043DB835ML", + "api_app_id": "A0442TUPHGR", + "event": { + "type": "message", + "text": "", + "user": "U043H11ES4V", + "ts": "1668537593.598469", + "team": "T043DB835ML", + "attachments": [ + { + "from_url": "https://jadeapptesting.slack.com/archives/C043KSKGJUB/p1665615886364019", + "ts": "1665615886.364019", + "author_id": "U043H11ES4V", + "channel_id": "C043KSKGJUB", + "channel_team": "T043DB835ML", + "channel_name": "testing-slack-app", + "is_msg_unfurl": true, + "message_blocks": [ + { + "team": "T043DB835ML", + "channel": "C043KSKGJUB", + "ts": "1665615886.364019", + "message": { + "blocks": [ + { + "type": "rich_text", + "block_id": "TNHa4", + "elements": [ + { + "type": "rich_text_section", + "elements": [ + { + "type": "text", + "text": "blahblahblahblahblah" + } + ] + } + ] + } + ] + } + } + ], + "color": "D0D0D0", + "is_share": true, + "fallback": "[October 12th, 2022 4:04 PM] jadel: blahblahblahblahblah", + "text": "blahblahblahblahblah", + "author_name": "jadel", + "author_link": "https://jadeapptesting.slack.com/team/U043H11ES4V", + "author_icon": "https://secure.gravatar.com/avatar/dcd5bc53dcfaca62ddc3f5726d07ba13.jpg?s=48&d=https%3A%2F%2Fa.slack-edge.com%2Fdf10d%2Fimg%2Favatars%2Fava_0019-48.png", + "author_subname": "jadel", + "mrkdwn_in": [ + "text" + ], + "footer": "Posted in #testing-slack-app" + } + ], + "channel": "C043YJGBY49", + "event_ts": "1668537593.598469", + "channel_type": "channel" + }, + "type": "event_callback", + "event_id": "Ev04BEN3QMSM", + "event_time": 1668537593, + "authorizations": [ + { + "enterprise_id": null, + "team_id": "T043DB835ML", + "user_id": "U0442US8QGH", + "is_bot": true, + "is_enterprise_install": false + } + ], + "is_ext_shared_channel": false, + "event_context": "aaaa" +} diff --git a/tests/golden/SlackWebhookEvent/shared_message_no_content.json b/tests/golden/SlackWebhookEvent/shared_message_no_content.json new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/shared_message_no_content.json @@ -0,0 +1,78 @@ +{ + "token": "aaaa", + "team_id": "T043DB835ML", + "api_app_id": "A0442TUPHGR", + "event": { + "type": "message", + "text": "", + "user": "U043H11ES4V", + "ts": "1668537593.598469", + "team": "T043DB835ML", + "attachments": [ + { + "from_url": "https://jadeapptesting.slack.com/archives/C043KSKGJUB/p1665615886364019", + "ts": "1665615886.364019", + "author_id": "U043H11ES4V", + "channel_id": "C043KSKGJUB", + "channel_team": "T043DB835ML", + "channel_name": "testing-slack-app", + "is_msg_unfurl": true, + "message_blocks": [ + { + "team": "T043DB835ML", + "channel": "C043KSKGJUB", + "ts": "1665615886.364019", + "message": { + "blocks": [ + { + "type": "rich_text", + "block_id": "TNHa4", + "elements": [ + { + "type": "rich_text_section", + "elements": [ + { + "type": "text", + "text": "blahblahblahblahblah" + } + ] + } + ] + } + ] + } + } + ], + "color": "D0D0D0", + "is_share": true, + "fallback": "[October 12th, 2022 4:04 PM] jadel: blahblahblahblahblah", + "text": "blahblahblahblahblah", + "author_name": "jadel", + "author_link": "https://jadeapptesting.slack.com/team/U043H11ES4V", + "author_icon": "https://secure.gravatar.com/avatar/dcd5bc53dcfaca62ddc3f5726d07ba13.jpg?s=48&d=https%3A%2F%2Fa.slack-edge.com%2Fdf10d%2Fimg%2Favatars%2Fava_0019-48.png", + "author_subname": "jadel", + "mrkdwn_in": [ + "text" + ], + "footer": "Posted in #testing-slack-app" + } + ], + "channel": "C043YJGBY49", + "event_ts": "1668537593.598469", + "channel_type": "channel" + }, + "type": "event_callback", + "event_id": "Ev04BEN3QMSM", + "event_time": 1668537593, + "authorizations": [ + { + "enterprise_id": null, + "team_id": "T043DB835ML", + "user_id": "U0442US8QGH", + "is_bot": true, + "is_enterprise_install": false + } + ], + "is_ext_shared_channel": false, + "event_context": "aaaa" +} diff --git a/tests/golden/SlackWebhookEvent/slackbotIm.golden b/tests/golden/SlackWebhookEvent/slackbotIm.golden new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/slackbotIm.golden @@ -0,0 +1,51 @@ +EventEventCallback + ( EventCallback + { eventId = EventId + { unEventId = "Ev044Y3D66M9" } + , teamId = TeamId + { unTeamId = "T043DB835ML" } + , eventTime = MkSystemTime + { systemSeconds = 1664826477 + , systemNanoseconds = 0 + } + , event = EventMessage + ( MessageEvent + { blocks = Just + [ RichText + { blockId = Just + ( NonEmptyText "ZRe" ) + , elements = + [ RichTextSectionItemRichText + [ RichItemText "You have been removed from #testing-slack-app by " + ( RichStyle + { rsBold = False + , rsItalic = False + } + ) + , RichItemUser + ( UserId + { unUserId = "U043H11ES4V" } + ) + ( RichStyle + { rsBold = False + , rsItalic = False + } + ) + ] + ] + } + ] + , channel = ConversationId + { unConversationId = "D043HMJ0WDU" } + , text = "You have been removed from #testing-slack-app by <@U043H11ES4V>" + , channelType = Im + , user = UserId + { unUserId = "USLACKBOT" } + , ts = "1664826477.425039" + , threadTs = Nothing + , appId = Nothing + , botId = Nothing + } + ) + } + ) diff --git a/tests/golden/SlackWebhookEvent/slackbotIm.json b/tests/golden/SlackWebhookEvent/slackbotIm.json new file mode 100644 --- /dev/null +++ b/tests/golden/SlackWebhookEvent/slackbotIm.json @@ -0,0 +1,50 @@ +{ + "token": "aaaa", + "team_id": "T043DB835ML", + "api_app_id": "A0442TUPHGR", + "event": { + "type": "message", + "text": "You have been removed from #testing-slack-app by <@U043H11ES4V>", + "user": "USLACKBOT", + "ts": "1664826477.425039", + "team": "T043DB835ML", + "blocks": [ + { + "type": "rich_text", + "block_id": "ZRe", + "elements": [ + { + "type": "rich_text_section", + "elements": [ + { + "type": "text", + "text": "You have been removed from #testing-slack-app by " + }, + { + "type": "user", + "user_id": "U043H11ES4V" + } + ] + } + ] + } + ], + "channel": "D043HMJ0WDU", + "event_ts": "1664826477.425039", + "channel_type": "im" + }, + "type": "event_callback", + "event_id": "Ev044Y3D66M9", + "event_time": 1664826477, + "authorizations": [ + { + "enterprise_id": null, + "team_id": "T043DB835ML", + "user_id": "U0442US8QGH", + "is_bot": true, + "is_enterprise_install": false + } + ], + "is_ext_shared_channel": false, + "event_context": "aaaa" +} diff --git a/tests/golden/UpdateRsp/actual.golden b/tests/golden/UpdateRsp/actual.golden new file mode 100644 --- /dev/null +++ b/tests/golden/UpdateRsp/actual.golden @@ -0,0 +1,6 @@ +UpdateRsp + { updateRspChannel = ConversationId + { unConversationId = "D0442US94JD" } + , updateRspTs = "1668717810.728689" + , updateRspText = "blahblahblah" + } diff --git a/tests/golden/UpdateRsp/actual.json b/tests/golden/UpdateRsp/actual.json new file mode 100644 --- /dev/null +++ b/tests/golden/UpdateRsp/actual.json @@ -0,0 +1,48 @@ +{ + "ok": true, + "channel": "D0442US94JD", + "ts": "1668717810.728689", + "text": "blahblahblah", + "message": { + "bot_id": "B0439P161B9", + "type": "message", + "text": "blahblahblah", + "user": "U0442US8QGH", + "app_id": "A0442TUPHGR", + "blocks": [ + { + "type": "rich_text", + "block_id": "j1Bvn", + "elements": [ + { + "type": "rich_text_section", + "elements": [ + { + "type": "text", + "text": "blahblahblah" + } + ] + } + ] + } + ], + "team": "T043DB835ML", + "bot_profile": { + "id": "B0439P161B9", + "app_id": "A0442TUPHGR", + "name": "Slacklinker dev", + "icons": { + "image_36": "https://a.slack-edge.com/80588/img/plugins/app/bot_36.png", + "image_48": "https://a.slack-edge.com/80588/img/plugins/app/bot_48.png", + "image_72": "https://a.slack-edge.com/80588/img/plugins/app/service_72.png" + }, + "deleted": false, + "updated": 1663960005, + "team_id": "T043DB835ML" + }, + "edited": { + "user": "B0439P161B9", + "ts": "1668721589.000000" + } + } +} diff --git a/tests/golden/UpdateRsp/sample.golden b/tests/golden/UpdateRsp/sample.golden new file mode 100644 --- /dev/null +++ b/tests/golden/UpdateRsp/sample.golden @@ -0,0 +1,6 @@ +UpdateRsp + { updateRspChannel = ConversationId + { unConversationId = "C024BE91L" } + , updateRspTs = "1401383885.000061" + , updateRspText = "Updated text you carefully authored" + } diff --git a/tests/golden/UpdateRsp/sample.json b/tests/golden/UpdateRsp/sample.json new file mode 100644 --- /dev/null +++ b/tests/golden/UpdateRsp/sample.json @@ -0,0 +1,10 @@ +{ + "ok": true, + "channel": "C024BE91L", + "ts": "1401383885.000061", + "text": "Updated text you carefully authored", + "message": { + "text": "Updated text you carefully authored", + "user": "U34567890" + } +} diff --git a/tests/golden/UsersConversationsResponse/im_and_channels.golden b/tests/golden/UsersConversationsResponse/im_and_channels.golden new file mode 100644 --- /dev/null +++ b/tests/golden/UsersConversationsResponse/im_and_channels.golden @@ -0,0 +1,108 @@ +UsersConversationsResponse + { channels = + [ Channel + ( ChannelConversation + { channelId = ConversationId + { unConversationId = "C043YJGBY49" } + , channelName = "general" + , channelCreated = 1663890553 + , channelIsArchived = False + , channelIsGeneral = True + , channelUnlinked = 0 + , channelNameNormalized = "general" + , channelIsShared = False + , channelCreator = UserId + { unUserId = "U043H11ES4V" } + , channelIsExtShared = False + , channelIsOrgShared = False + , channelSharedTeamIds = Just + [ TeamId + { unTeamId = "T043DB835ML" } + ] + , channelIsPendingExtShared = False + , channelIsMember = Nothing + , channelTopic = Topic + { topicValue = "" + , topicCreator = "" + , topicLastSet = 0 + } + , channelPurpose = Purpose + { purposeValue = "This is the one channel that will always include everyone. It’s a great spot for announcements and team-wide conversations." + , purposeCreator = "U043H11ES4V" + , purposeLastSet = 1663890553 + } + , channelPreviousNames = [] + , channelNumMembers = Nothing + } + ) + , Channel + ( ChannelConversation + { channelId = ConversationId + { unConversationId = "C0451SKQN72" } + , channelName = "new-channel-2" + , channelCreated = 1664407230 + , channelIsArchived = False + , channelIsGeneral = False + , channelUnlinked = 0 + , channelNameNormalized = "new-channel-2" + , channelIsShared = False + , channelCreator = UserId + { unUserId = "U043H11ES4V" } + , channelIsExtShared = False + , channelIsOrgShared = False + , channelSharedTeamIds = Just + [ TeamId + { unTeamId = "T043DB835ML" } + ] + , channelIsPendingExtShared = False + , channelIsMember = Nothing + , channelTopic = Topic + { topicValue = "" + , topicCreator = "" + , topicLastSet = 0 + } + , channelPurpose = Purpose + { purposeValue = "" + , purposeCreator = "" + , purposeLastSet = 0 + } + , channelPreviousNames = [] + , channelNumMembers = Nothing + } + ) + , Im + ( ImConversation + { imId = ConversationId + { unConversationId = "D0442US94JD" } + , imCreated = 1663960005 + , imIsArchived = False + , imIsOrgShared = False + , imUser = UserId + { unUserId = "U043H11ES4V" } + , imIsUserDeleted = False + , imPriority = 0.0 + } + ) + , Im + ( ImConversation + { imId = ConversationId + { unConversationId = "D043HMJ0WDU" } + , imCreated = 1663960005 + , imIsArchived = False + , imIsOrgShared = False + , imUser = UserId + { unUserId = "USLACKBOT" } + , imIsUserDeleted = False + , imPriority = 0.0 + } + ) + ] + , responseMetadata = Just + ( ResponseMetadata + { responseMetadataNextCursor = Just + ( Cursor + { unCursor = "" } + ) + } + ) + } diff --git a/tests/golden/UsersConversationsResponse/im_and_channels.json b/tests/golden/UsersConversationsResponse/im_and_channels.json new file mode 100644 --- /dev/null +++ b/tests/golden/UsersConversationsResponse/im_and_channels.json @@ -0,0 +1,104 @@ +{ + "ok": true, + "channels": [ + { + "id": "C043YJGBY49", + "name": "general", + "is_channel": true, + "is_group": false, + "is_im": false, + "is_mpim": false, + "is_private": false, + "created": 1663890553, + "is_archived": false, + "is_general": true, + "unlinked": 0, + "name_normalized": "general", + "is_shared": false, + "is_org_shared": false, + "is_pending_ext_shared": false, + "pending_shared": [], + "context_team_id": "T043DB835ML", + "parent_conversation": null, + "creator": "U043H11ES4V", + "is_ext_shared": false, + "shared_team_ids": [ + "T043DB835ML" + ], + "pending_connected_team_ids": [], + "topic": { + "value": "", + "creator": "", + "last_set": 0 + }, + "purpose": { + "value": "This is the one channel that will always include everyone. It’s a great spot for announcements and team-wide conversations.", + "creator": "U043H11ES4V", + "last_set": 1663890553 + }, + "previous_names": [] + }, + { + "id": "C0451SKQN72", + "name": "new-channel-2", + "is_channel": true, + "is_group": false, + "is_im": false, + "is_mpim": false, + "is_private": false, + "created": 1664407230, + "is_archived": false, + "is_general": false, + "unlinked": 0, + "name_normalized": "new-channel-2", + "is_shared": false, + "is_org_shared": false, + "is_pending_ext_shared": false, + "pending_shared": [], + "context_team_id": "T043DB835ML", + "parent_conversation": null, + "creator": "U043H11ES4V", + "is_ext_shared": false, + "shared_team_ids": [ + "T043DB835ML" + ], + "pending_connected_team_ids": [], + "topic": { + "value": "", + "creator": "", + "last_set": 0 + }, + "purpose": { + "value": "", + "creator": "", + "last_set": 0 + }, + "previous_names": [] + }, + { + "id": "D0442US94JD", + "created": 1663960005, + "is_archived": false, + "is_im": true, + "is_org_shared": false, + "context_team_id": "T043DB835ML", + "user": "U043H11ES4V", + "is_user_deleted": false, + "priority": 0 + }, + { + "id": "D043HMJ0WDU", + "created": 1663960005, + "is_archived": false, + "is_im": true, + "is_org_shared": false, + "context_team_id": "T043DB835ML", + "user": "USLACKBOT", + "is_user_deleted": false, + "priority": 0 + } + ], + "response_metadata": { + "next_cursor": "" + } +}