Calamity

Calamity is a Haskell library for writing discord bots, it uses Polysemy as the core library for handling effects, allowing you to pick and choose how to handle certain features of the library.

If you're looking for something with a less complicated interface, you might want to take a look at discord-haskell.

The current customisable effects are:

• Cache: The default cache handler keeps the cache in memory, however you could write a cache handler that stores cache in a database for example.

• Metrics: The library has counters, gauges, and histograms installed to measure useful things, by default these are not used (and cost nothing), but could be combined with Prometheus. An example of using prometheus as the metrics handler can be found here.

• Logging: The di-polysemy library is used to allow the logging effect to be customized, or disabled.

Docs

You can find documentation on hackage at: https://hackage.haskell.org/package/calamity

There's also a good blog post that covers the fundamentals of writing a bot with the library, you can read it here: https://morrowm.github.io/posts/2021-04-29-calamity.html

Examples

Here's a list of projects that use calamity:

• simmsb/calamity-bot: Uses a database, showing modularization of groups/commands.
• MorrowM/pandabot-discord: Uses a database, performs member role management, etc.
• MorrowM/calamity-tutorial: A bare minimum bot.

(Feel free to contact me via the discord server, or email me via ben@bensimms.moe if you've written a bot using calamity, or don't want your project listed here)

#!/usr/bin/env cabal
{- cabal:
  build-depends:
     base >= 4.13 && < 5
     , calamity >= 0.1.30.1
     , text >= 1.2 && < 2
     , lens >= 4.18 && < 5
     , di-polysemy ^>= 0.2
     , di >= 1.3 && < 2
     , df1 >= 0.3 && < 0.5
     , di-core ^>= 1.0.4
     , polysemy ^>= 1.5
     , polysemy-plugin ^>= 0.3
     , stm ^>= 2.5
     , text-show ^>= 3.9
-}

{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}

{-# LANGUAGE BlockArguments #-}

{-# LANGUAGE TypeOperators #-}

module Main where

import           Calamity
import           Calamity.Cache.InMemory
import Calamity.Commands
import Calamity.Commands.Context (FullContext, useFullContext)
import           Calamity.Metrics.Noop

import           Control.Concurrent
import           Control.Concurrent.STM.TVar
import           Control.Lens
import           Control.Monad

import qualified Data.Text.Lazy as L

import qualified Di
import qualified DiPolysemy                  as DiP

import qualified Polysemy                    as P
import qualified Polysemy.Async              as P
import qualified Polysemy.AtomicState        as P
import qualified Polysemy.Embed              as P
import qualified Polysemy.Fail               as P

import           Prelude                     hiding ( error )

import           System.Environment          (getEnv)

import           TextShow

data Counter m a where
  GetCounter :: Counter m Int

P.makeSem ''Counter

runCounterAtomic :: P.Member (P.Embed IO) r => P.Sem (Counter ': r) a -> P.Sem r a
runCounterAtomic m = do
  var <- P.embed $ newTVarIO (0 :: Int)
  P.runAtomicStateTVar var $ P.reinterpret (\case
                                              GetCounter -> P.atomicState (\v -> (v + 1, v))) m

handleFailByLogging m = do
  r <- P.runFail m
  case r of
    Left e -> DiP.error $ L.pack e
    _      -> pure ()

info, debug :: BotC r => L.Text -> P.Sem r ()
info = DiP.info
debug = DiP.info

tellt :: (BotC r, Tellable t) => t -> L.Text -> P.Sem r (Either RestError Message)
tellt t m = tell t $ L.toStrict m

data MyCustomEvt = MyCustomEvt L.Text Message

main :: IO ()
main = do
  token <- L.pack <$> getEnv "BOT_TOKEN"
  Di.new $ \di ->
    void . P.runFinal . P.embedToFinal . DiP.runDiToIO di . runCounterAtomic 
         . runCacheInMemory . runMetricsNoop . useConstantPrefix "!" . useFullContext
      $ runBotIO (BotToken token) defaultIntents $ do
      addCommands $ do
        helpCommand
        command @'[User] "utest" $ \ctx u -> do
          void $ tellt ctx $ "got user: " <> showtl u
        command @'[Named "u" User, Named "u1" User] "utest2" $ \ctx u u1 -> do
          void $ tellt ctx $ "got user: " <> showtl u <> "\nand: " <> showtl u1
        command @'[L.Text, Snowflake User] "test" $ \ctx something aUser -> do
          info $ "something = " <> showtl something <> ", aUser = " <> showtl aUser
        command @'[] "hello" $ \ctx -> do
          void $ tellt ctx "heya"
        group "testgroup" $ do
          command @'[[L.Text]] "test" $ \ctx l -> do
            void $ tellt ctx ("you sent: " <> showtl l)
          command @'[] "count" $ \ctx -> do
            val <- getCounter
            void $ tellt ctx ("The value is: " <> showtl val)
          group "say" $ do
            command @'[KleenePlusConcat L.Text] "this" $ \ctx msg -> do
              void $ tellt ctx msg
        command @'[Snowflake Emoji] "etest" $ \ctx e -> do
          void $ tellt ctx $ "got emoji: " <> showtl e
        command @'[] "explode" $ \ctx -> do
          Just x <- pure Nothing
          debug "unreachable!"
        command @'[] "bye" $ \ctx -> do
          void $ tellt ctx "bye!"
          stopBot
        command @'[] "fire-evt" $ \ctx -> do
          fire . customEvt $ MyCustomEvt "aha" (ctx ^. #message)
        command @'[L.Text] "wait-for" $ \ctx s -> do
          void $ tellt ctx ("waiting for !" <> s)
          waitUntil @'MessageCreateEvt (\msg -> msg ^. #content == ("!" <> s))
          void $ tellt ctx ("got !" <> s)
      react @'MessageCreateEvt $ \msg -> handleFailByLogging $ case msg ^. #content of
        "!say hi" -> replicateM_ 3 . P.async $ do
          info "saying heya"
          Right msg' <- tellt msg "heya"
          info "sleeping"
          P.embed $ threadDelay (5 * 1000 * 1000)
          info "slept"
          void . invoke $ EditMessage (msg ^. #channelID) msg' (editMessageContent $ Just "lol")
          info "edited"
        _ -> pure ()
      react @('CustomEvt (CtxCommandError FullContext)) \(CtxCommandError ctx e) -> do
        info $ "Command failed with reason: " <> showtl e
        case e of
          ParseError n r -> void . tellt ctx $ "Failed to parse parameter: `" <> L.fromStrict n <> "`, with reason: ```\n" <> r <> "```"
      react @('CustomEvt MyCustomEvt) $ \(MyCustomEvt s m) ->
        void $ tellt m ("Somebody told me to tell you about: " <> s)

Disabling library logging

The library logs on debug levels by default, if you wish to disable logging you can do something along the lines of:

import qualified Di
import qualified Df1
import qualified Di.Core
import qualified DiPolysemy

filterDi :: Di.Core.Di l Di.Path m -> Di.Core.Di l Di.Path m
filterDi = Di.Core.filter (\_ p _ -> Df1.Push "calamity" `notElem` p)

Di.new $ \di ->
-- ...
  . runDiToIO di
  -- disable logs emitted by calamity
  . DiPolysemy.local filterDi
  . runBotIO
  -- ...