Skip to content

Instantly share code, notes, and snippets.

@velveteer

velveteer/slacking.md

Created June 15, 2022 21:03
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save velveteer/4e28900021a31c8e75f1a7bb813f0e5f to your computer and use it in GitHub Desktop.
Save velveteer/4e28900021a31c8e75f1a7bb813f0e5f to your computer and use it in GitHub Desktop.
Download ZIP
slacking.md
Raw
slacking.md
theme class
gaia
lead
invert

bg opacity:.3

Slacking with Haskell

  • Slack maintains official "Bolt" libraries for Java, Python, and JavaScript/TypeScript.

  • I'd like a similar experience in Haskell, particularly for the Events API in Socket Mode.

  • https://github.com/velveteer/slacker

Socket Mode

https://api.slack.com/apis/connections/socket

  • You can use Slack's Events API with Socket Mode or over HTTP
  • Socket Mode is necessary when building apps behind a firewall
  • It should replace usage of the RTM (Real Time Messaging) API that also uses websockets
  • Slack offers some documentation for how to implement a client

High Level Design

  • A user can specify how many connections to keep open
  • Each connection will be its own Haskell thread
  • Use async library to create and manage threads
  • Use stm-chans library for the TBMQueue data structure
  • Use stm library for TVar and synchronizing variable TMVar
  • Use websockets and wuss (for secure websockets)
data SocketModeEnv
  = SocketModeEnv
  { slackConfig   :: !SlackConfig
  , inboundQueue  :: !(TBMQueue SocketModeEvent)
  , bgThreads     :: !(TVar [(Async (), Int)])
  , shutdownVar   :: !(TMVar ())
  }

initSocketMode :: SlackConfig -> IO SocketModeEnv
initSocketMode cfg = mask_ $ do
  iqueue        <- newTBMQueueIO (inboundQueueMax cfg)
  threadsTVar   <- newTVarIO []
  shutdownTMVar <- newEmptyTMVarIO
  let env = SocketModeEnv cfg iqueue threadsTVar shutdownTMVar
  threads <- for [1..numThreads cfg] $ \tId -> do
    thread <- async $ pollSocket env tId
    pure (thread, tId)
  void . atomically $ swapTVar threadsTVar threads
  void $ spawnThreadMonitor env
  void $ spawnShutdownHandler env
  pure env
spawnThreadMonitor :: SocketModeEnv -> IO (Async ())
spawnThreadMonitor env = async loop
  where
    loop = do
      threads <- readTVarIO $ bgThreads env
      (stoppedAsync, x) <- waitAnyCatch (fst <$> threads)
      case x of
        Left err | Just tId <- lookup stoppedAsync threads -> do
          if shouldRestart err
            then restartFailed env threads tId >> loop
            else shutdownSocketMode env
        _ -> do
          -- Polling thread exited normally, which shouldn't ever happen.
          shutdownSocketMode env
spawnShutdownHandler :: SocketModeEnv -> IO (Async ())
spawnShutdownHandler env = async $ do
  atomically . takeTMVar $ shutdownVar env
  threads <- fmap fst <$> readTVarIO (bgThreads env)
  uninterruptibleMask_ $ traverse_ uninterruptibleCancel threads
  traverse_ waitCatch threads
  atomically $ closeTBMQueue (inboundQueue env)
shutdownSocketMode :: SocketModeEnv -> IO ()
shutdownSocketMode env = atomically $ putTMVar (shutdownVar env) ()

Distilled version of a connection thread.

pollSocket :: SocketModeEnv -> Int -> IO ()
pollSocket env tId = do
  url <- connectionsOpen env
  (host, path) <- parseWebSocketUrl url
  WS.runSecureClient host 443 path go
  pollSocket env tId
  where
    go conn = WS.withPingThread conn 15 (pure ()) (loop conn)
    writeInboundEvent conn val = case val of
      EventsApi (EventsApiEnvelope { eaeEnvelopeId = eId }) -> do
        ackEnvelopeId conn eId
        atomically $ writeTBMQueue (inboundQueue env) val
        loop conn
      Disconnect _ -> pure ()
    loop conn = do
      raw <- WS.receiveData conn `catch` (throwIO . ConnectionError)
      either (throwIO . JSONDecodeError) (writeInboundEvent conn)
        $ Aeson.eitherDecode raw
-- | Users can pass a callback to be called whenever
-- an event is pulled from the queue. The function loops
-- until the queue is closed and empty.
handleEvents
  :: MonadIO m
  => SocketModeEnv
  -> (SlackConfig -> SocketModeEvent -> m ())
  -> m ()
handleEvents env fn = getNextEvent env >>= \case
  Just evt -> fn (slackConfig env) evt >> handleEvents env fn
  Nothing  -> pure ()

-- | Returns Nothing when the inbound queue is closed and empty.
getNextEvent :: MonadIO m => SocketModeEnv -> m (Maybe SocketModeEvent)
getNextEvent = liftIO . atomically . readTBMQueue . inboundQueue

runSocketMode :: MonadIO m => SlackConfig -> (SlackConfig -> SocketModeEvent -> m ()) -> m ()
runSocketMode cfg fn = liftIO (initSocketMode cfg) >>= flip handleEvents fn
main :: IO ()
main = do
  let cfg = defaultSlackConfig
          & setApiToken "YOUR_API_TOKEN"
          & setAppToken "YOUR_APP_TOKEN"
  runSocketMode cfg handler

handler :: SlackConfig -> SocketModeEvent -> IO ()
handler cfg = \case
  Event "app_mention" evt -> -- do stuff
  Command "/magic-button" cmd -> -- do stuff
  BlockAction "magic-action" val -> -- do stuff

Block Kit

https://api.slack.com/block-kit

Nice things:

  • Everything is JSON
  • Blocks do not nest, only stack
  • WYSIWYG Block Editor
  • Required and optional fields are well-documented

Not nice things

  • Implicit rules of composition
    • Message surfaces support different layout blocks
    • Context layout block cannot contain interactive elements
    • Actions layout block cannot contain image elements
    • Actions block can only have 25 elements, context only 10, etc.
    • Buttons must use text objects with only plaintext type
    • etc.
  • Everything is JSON

Is this Haskell Block Kit?

-- Non-empty difference list for O(1) append
type Blocks = DNonEmpty Block

data Block
 = Section !SectionBlock
 | Divider !DividerBlock
 | Header  !HeaderBlock

section :: SectionBlock -> Blocks
section block = pure $ Section block

exampleBlocks :: Blocks
exampleBlocks
 = header "I see you" <>
   divider <>
   section $ defaultSection ":eyes:"

Example layout block:

data SectionBlock
  = SectionBlock
  { text      :: !TextObject
  , block_id  :: !(Maybe Text)
  , fields    :: !(Maybe (DNonEmpty TextObject))
  , accessory :: !(Maybe Element)
  } deriving stock (Generic)

defaultSection :: TextObject -> SectionBlock
defaultSection txt
  = SectionBlock
  { text      = txt
  , block_id  = Nothing
  , fields    = Nothing
  , accessory = Nothing
  }

Record Types

Less confusion, more ergonomics

  • Have the same field names as in the Slack API
  • Use constructor functions to force users to provide required fields

GHC 9.2.3:

(defaultSection "hello"){ block_id = Just "123" }
The record update (defaultSection "hello"){block_id = Just "123"} with type SectionBlock is ambiguous.
This will not be supported by -XDuplicateRecordFields in future releases of GHC.

Future GHC:

(defaultSection "hello"){ Slacker.Blocks.Section.block_id = Just "123" }

:'(

generic-lens

https://hackage.haskell.org/package/generic-lens

import Control.Lens
import Data.Generics.Labels ()

-- Set fields with lenses
exampleBlocks :: Blocks
exampleBlocks
  = section
  $ defaultSection ":eyes:"
      & #block_id ?~ "123"
      & #accessory ?~ button_ "Click me!" "button-click"
      & #fields ?~ field (markdown "I'm a field")

Need OverloadedLabels - GHC Docs

So we can create and update blocks.

But it's not much better than copying Block Kit Builder JSON and pasting it into the aesonQQ quasiquoter.

-- Compile-time JSON conversion
exampleBlocks :: Value
exampleBlocks = [aesonQQ|
  [{
    "type": "section",
    "text": {
      "type": "mrkdwn",
      "text": "hello world"
    }
  }]]

Remember those implicit rules?

Can we tell the compiler about those?

Example rule: Context elements can only be text objects or image elements

data ContextBlock
  = ContextBlock
  { elements :: !ContextElements
  , block_id :: !(Maybe Text)
  } deriving stock (Generic)

newtype ContextElements = DNonEmpty ContextElement
  deriving newtype (Aeson.ToJSON, Semigroup)

data ContextElement
  = ContextText !TextObject
  | ContextImage !ImageElement

We are correct by construction, but it doesn't make for a nice DSL.

exampleBlocks :: Blocks
exampleBlocks
  = context_
  $ contextText (markdown "hello") <>
    contextImage (image_ "url" "alt_text")

We will have an explosion of constructor functions:

e.g. sectionButton, actionsButton, contextImage, sectionImage, etc.

  • We can model each block's elements with a union type.

    • TypeScript users know these well.
    • Sometimes called a variant or untagged sum.

  • extensible and world-peace libraries, among others

  • I like world-peace because:

    • It has nice type errors
    • It provides ToJSON and FromJSON instances
    • Hackage
newtype ContextElement = OpenUnion ContextElementTypes
  deriving newtype (Aeson.ToJSON)

type ContextElementTypes = '[ImageElement, TextObject]

asContext
  :: forall a. IsMember a ContextElementTypes
  => a
  -> ContextElements
asContext = ContextElements . pure . ContextElement . openUnionLift

exampleBlocks :: Blocks
exampleBlocks
  = context_
  $ asContext (markdown "hello") <>
    asContext (image_ "url" "alt_text")

We're still type safe.

> context_ $ asContext (button_ "click me" "action id")
• You require open sum type to contain the following element:
      ButtonElement
  However, given list can store elements only of the following types:
      '[ImageElement, TextObject]
• In the first argument of ‘($)’, namely ‘context_’

But asContext is still noisy.

It wouldn't be Haskell if we didn't

OVERLOAD EVERYTHING.

{-# LANGUAGE OverloadedStrings #-}

class HasImage a where
  image :: ImageElement -> a
  image_ :: Text -> Text -> a
  image_ url alt = image $ defaultImage url alt

instance HasImage ContextElements where
  image = asContext

instance IsString ContextElements where
  fromString s = asContext (fromString s :: TextObject)

exampleBlocks :: Blocks
exampleBlocks = context_ $ "hello" <> image_ "url" "alt_text"

But we no longer see the same type error.

> context_ $ button_ "click me" "action id"
• No instance for (Slacker.Blocks.Elements.Button.HasButton
                    Slacker.Blocks.Context.ContextElements)
  arising from a use of ‘button_’

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}

data Elements i where
  EButton :: ButtonElement -> Elements '[ButtonElement]
  EText   :: TextObject -> Elements '[TextObject]
  EImage  :: ImageElement -> Elements '[ImageElement]
  EAppend :: Elements xs -> Elements ys -> Elements (xs ++ ys)

type family (++) (xs :: [Type]) (ys :: [Type]) where
  '[] ++ ys = ys
  (x ': xs) ++ ys = x ': (xs ++ ys)

instance (i ~ '[TextObject]) => IsString (Elements i) where
  fromString el = EText (fromString el)

instance (i ~ '[ImageElement]) => HasImage (Elements i) where
  image i = EImage i

https://hackage.haskell.org/package/world-peace-1.0.0.0/docs/Data-WorldPeace.html#t:Contains

A type family to assert that all of the types in a list are contained within another list.

context_ :: (Contains i ContextElementTypes) => Elements i -> Blocks
context_ = Context . defaultContext . go
  where
    go :: Elements i -> ContextElements
    go (EText t)     = asContext t
    go (EImage i)    = asContext i
    go (EAppend x y) = go x <> go y
    go _             = error "impossible context element"
> context_ $ "some text" `EAppend` button_ "click me" "action id"
• You require open sum type to contain the following element:
      ButtonElement
  However, given list can store elements only of the following types:
      '[ImageElement, TextObject]

Our nice type error is back.

exampleBlocks :: Blocks
exampleBlocks =
  header_ "Cool header"
  <> divider_
  <> context_ $
       "context1" `EAppend` image_ "url" "context1alt" `EAppend`
       "context2" `EAppend` image_ "url" "context2alt"
  <> section_ $ "click the button, I dare you"
      `EAppend` button_ "Click me!" "button-click"
  • Mixing Semigroup and our custom append. Not great.
  • Can't give Elements i a Semigroup instance.

Overload appending, of course.

class IxAppend (m :: [Type] -> Type) where
  (>>) :: m i -> m j -> m (i ++ j)

instance IxAppend Elements where
  (>>) = EAppend

-- Using the GADT approach for blocks is useful when enforcing
-- block usage for certain message surfaces.
instance IxAppend Blocks where
  (>>) = BAppend

Why use >> instead of a custom operator?

QualifiedDo

GHC Docs

import qualified Slacker as S

exampleBlocks :: Blocks
exampleBlocks = S.do
  header_ "Cool header"
  divider_
  context_ $ S.do
    "context1"
    image_ "url" "context1alt"
    "context2"
    image_ "url" "context2alt"
  section_ $ S.do
    "click the button, I dare you"
    button_ "Click me!" "button-click"

It's all sugar.

The shortened version is entirely optional, and both expressions report the same type error for disallowed elements.

section $ defaultSection (markdown "hello") & #accessory ?~ asAccessory (defaultButton "click me" "button-click")
section_ $ "hello" S.>> button_ "click me" "button-click"

That's it!

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment