Events api

scripts/sanitize.jq

@@ -0,0 +1,18 @@
+#!/usr/bin/env jq -Mf
+
+def to_set:
+    map({key: ., value: true}) | from_entries
+    ;
+
+def sanitize($set):
+    . as $inp |
+    if $set[$inp.key] == true then
+        {key: $inp.key, value: "aaaa"}
+    else
+        $inp
+    end
+    ;
+
+def excludes: ["token", "event_context"] | to_set;
+
+. | to_entries | map(sanitize(excludes)) | from_entries

scripts/update-golden.sh

@@ -0,0 +1,44 @@
+#!/usr/bin/env bash
+set -eu
+
+if [[ $# != 1 ]]; then
+    echo "usage: $0 DIR" >&2
+    echo "Updates the golden files in the specified directory" >&2
+    exit 1
+fi
+
+confirm() {
+    echo "$1"
+    echo -n "[Y/n] "
+    read confirmation
+    case "$confirmation" in
+        y | Y | yes | "")
+            return 0 ;;
+        *)
+            return 1 ;;
+    esac
+}
+
+promptUpdate() {
+    echo "diff: "
+    # for god knows why, this fails
+    diff -u $2 $1 || true
+
+    if confirm "update ${2}?"; then
+        cp $1 $2
+    else
+        echo "skipping ${2}"
+    fi
+}
+
+dir="$1"
+for f in ${dir}/*.golden; do
+    baseName="${f%%.golden}"
+    actualName="${baseName}.actual"
+    if cmp -s "$actualName" "$f"; then
+        echo "$f up to date"
+    else
+        promptUpdate "$actualName" "$f"
+    fi
+done
+

slack-web.cabal

@@ -17,6 +17,10 @@ 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
+
 category: Web
 
 tested-with: GHC == 8.10.7 || ==9.2.4 || == 9.4.2
@@ -110,6 +114,7 @@ library
       Web.Slack.User
       Web.Slack.Experimental.Blocks
       Web.Slack.Experimental.Blocks.Types
+      Web.Slack.Experimental.Events.Types
       Web.Slack.Experimental.RequestVerification
   other-modules:
       Web.Slack.Util
@@ -159,25 +164,33 @@ test-suite tests
   type:
       exitcode-stdio-1.0
   other-modules:
+      JSONGolden
       Web.Slack.PagerSpec
       Web.Slack.MessageParserSpec
       Web.Slack.ConversationSpec
       Web.Slack.Experimental.RequestVerificationSpec
+      Web.Slack.Experimental.Events.TypesSpec
       TestImport
   build-tool-depends:
     hspec-discover:hspec-discover >=2.6.0 && <2.11
   build-depends:
       base
-    , slack-web
-    , classy-prelude
-    , string-conversions
+    , QuickCheck
     , aeson
+    , bytestring
+    , classy-prelude
     , fakepull
     , hspec
+    , hspec-core
+    , hspec-golden
+    , pretty-simple
+    , quickcheck-instances
+    , slack-web
+    , string-conversions
     , text
+    , template-haskell
+    , th-compat
     , time
-    , QuickCheck
-    , quickcheck-instances
   default-language:
     Haskell2010
   ghc-options:

src/Web/Slack/AesonUtils.hs

@@ -98,3 +98,10 @@ thenPair True s = s
 thenPair False _ = mempty
 
 infixr 7 `thenPair`
+
+snakeCaseOptions :: Options
+snakeCaseOptions =
+  defaultOptions
+    { fieldLabelModifier = camelTo2 '_'
+    , constructorTagModifier = camelTo2 '_'
+    }

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)
+
+-- | <https://api.slack.com/events/message>
+data MessageEvent = MessageEvent
+  { blocks :: [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
+  --   <https://api.slack.com/events/message/bot_message>, 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)
+
+-- | <https://api.slack.com/events/message/message_changed>
+--
+-- 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.
+--
+-- <https://api.slack.com/events/channel_created>
+data ChannelCreatedEvent = ChannelCreatedEvent
+  { channel :: CreatedChannel
+  }
+  deriving stock (Show)
+
+$(deriveFromJSON snakeCaseOptions ''CreatedChannel)
+$(deriveFromJSON snakeCaseOptions ''ChannelCreatedEvent)
+
+-- | You left a channel.
+--
+-- <https://api.slack.com/events/channel_left>
+data ChannelLeftEvent = ChannelLeftEvent
+  { actorId :: UserId
+  , channel :: ConversationId
+  , eventTs :: Text
+  }
+  deriving stock (Show)
+
+$(deriveFromJSON snakeCaseOptions ''ChannelLeftEvent)
+
+-- | <https://api.slack.com/events/url_verification>
+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:
+    -- <https://api.slack.com/changelog/2017-05-rethinking-channel-entrance-and-exit-events-and-messages>
+    --
+    -- Documentation: <https://api.slack.com/events/message/channel_join>
+    EventChannelJoinMessage
+  | EventChannelCreated ChannelCreatedEvent
+  | EventChannelLeft ChannelLeftEvent
+  | EventUnknown Value
+  deriving stock (Show)
+
+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)
+
+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)

tests/JSONGolden.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module JSONGolden (oneGoldenTest) where
+
+import Data.Aeson (eitherDecode)
+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
+
+goldenTest :: forall a. (FromJSON a, Show a, Typeable a) => Text -> LByteString -> Golden Text
+goldenTest 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
+        }
+
+oneGoldenTest :: forall a. (FromJSON a, Show a, Typeable a) => Text -> SpecM () ()
+oneGoldenTest name = do
+  input <- runIO . LBS.readFile $ filename (typeName @a) name <> ".json"
+  it (unpack name) $ goldenTest @a name input

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

@@ -0,0 +1,22 @@
+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_
+        (oneGoldenTest @SlackWebhookEvent)
+        [ "messageExample"
+        , "messageChange"
+        , "link"
+        , "botMessage"
+        , "joinChannel"
+        , "createChannel"
+        , "messageIm"
+        , "slackbotIm"
+        , "channel_left"
+        ]