[#64] Add possibility to run tzbot as server

Problem: only server-like Slack apps can be published in the Slack App
Directory.

Solution: Allow to choose how to run the server, using common handler
functions.

package.yaml

@@ -37,6 +37,7 @@ library:
   - formatting
   - guid
   - glider-nlp
+  - http-api-data
   - http-client
   - http-client-tls
   - http-types
@@ -49,6 +50,7 @@ library:
   - o-clock
   - random
   - optparse-applicative
+  - servant
   - servant-auth
   - servant-auth-client
   - servant-client
@@ -69,6 +71,7 @@ library:
   - validation
   - yaml
   - utf8-string
+  - warp
 
 executables:
   tzbot-exe:

src/TzBot/BotMain.hs

@@ -6,29 +6,16 @@ module TzBot.BotMain where
 
 import Universum
 
-import Control.Monad.Managed (managed, runManaged)
 import Data.ByteString qualified as BS
-import Network.HTTP.Client (newManager)
-import Network.HTTP.Client.TLS (tlsManagerSettings)
 import Options.Applicative (execParser)
-import Slacker
-  (defaultSlackConfig, handleThreadExceptionSensibly, runSocketMode, setApiToken, setAppToken,
-  setGracefulShutdownHandler, setOnException)
 import System.Directory (doesFileExist)
 import Text.Interpolation.Nyan (int, rmode')
-import Time (hour)
 
-import TzBot.Cache
-  (TzCacheSettings(tcsExpiryRandomAmplitudeFraction), defaultTzCacheSettings, withTzCache,
-  withTzCacheDefault)
-import TzBot.Config
+import TzBot.BotMain.Server (runServer)
+import TzBot.BotMain.Server.Verification (runVerificationServer)
+import TzBot.BotMain.SocketMode (runSocketMode)
 import TzBot.Config.Default (defaultConfigText)
-import TzBot.Config.Types (BotConfig)
-import TzBot.Logger
 import TzBot.Options
-import TzBot.ProcessEvents (handler)
-import TzBot.RunMonad
-import TzBot.Util (withMaybe)
 
 {- |
 Usage:
@@ -43,7 +30,11 @@ main = do
   cliOptions <- execParser totalParser
   case cliOptions of
     DumpConfig dumpOpts -> dumpConfig dumpOpts
-    DefaultCommand op -> run op
+    RunSocketMode opts -> runSocketMode opts
+    RunServer opts ->
+      if rsoVerification opts
+      then runVerificationServer
+      else runServer opts
 
 dumpConfig :: DumpOptions -> IO ()
 dumpConfig = \case
@@ -57,51 +48,3 @@ dumpConfig = \case
       (hPutStrLn @Text stderr [int||File #{path} already exists, \
                                 use --force to overwrite|] >> exitFailure)
       writeAction
-
-run :: Options -> IO ()
-run opts = do
-  let mbConfigFilePath = oConfigFile opts
-  bsConfig@Config {..} <- readConfig mbConfigFilePath
-  runManaged $ do
-
-    let fifteenPercentAmplitudeSettings = defaultTzCacheSettings
-          { tcsExpiryRandomAmplitudeFraction = Just 0.15
-          }
-
-    gracefulShutdownContainer <- liftIO $ newIORef $ (pure () :: IO ())
-    let extractShutdownFunction :: IO () -> IO ()
-        extractShutdownFunction = writeIORef gracefulShutdownContainer
-    let sCfg = defaultSlackConfig
-              & setApiToken (unBotToken cBotToken)
-              & setAppToken (unAppLevelToken cAppToken)
-              & setOnException handleThreadExceptionSensibly -- auto-handle disconnects
-              & setGracefulShutdownHandler extractShutdownFunction
-
-    bsManager <- liftIO $ newManager tlsManagerSettings
-    bsFeedbackConfig <-
-      managed $ withFeedbackConfig bsConfig
-    bsUserInfoCache <-
-      managed $ withTzCache fifteenPercentAmplitudeSettings cCacheUsersInfo
-    bsConversationMembersCache <-
-      managed $ withTzCache fifteenPercentAmplitudeSettings cCacheConversationMembers
-    let defaultMessageInfoCachingTime = hour 1
-    bsMessageCache <-
-      managed $ withTzCacheDefault defaultMessageInfoCachingTime
-    bsMessageLinkCache <-
-      managed $ withTzCacheDefault defaultMessageInfoCachingTime
-    bsReportEntries <-
-      managed $ withTzCacheDefault cCacheReportDialog
-    -- auto-acknowledge received messages
-    (bsLogNamespace, bsLogContext, bsLogEnv) <- managed $ withLogger cLogLevel
-    liftIO $ runSocketMode sCfg $ handler gracefulShutdownContainer BotState {..}
-
-withFeedbackConfig :: BotConfig -> (FeedbackConfig -> IO a) -> IO a
-withFeedbackConfig Config {..} action = do
-  let fcFeedbackChannel = cFeedbackChannel
-  withFeedbackFile cFeedbackFile $ \fcFeedbackFile ->
-    action FeedbackConfig {..}
-  where
-    withFeedbackFile :: Maybe FilePath -> (Maybe Handle -> IO a) -> IO a
-    withFeedbackFile mbPath action =
-      withMaybe mbPath (action Nothing) $ \path ->
-        withFile path AppendMode (action . Just)

src/TzBot/BotMain/Common.hs

@@ -0,0 +1,58 @@
+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>
+--
+-- SPDX-License-Identifier: MPL-2.0
+
+module TzBot.BotMain.Common where
+
+
+import Universum
+
+import Control.Monad.Managed (Managed, managed)
+import Network.HTTP.Client (newManager)
+import Network.HTTP.Client.TLS (tlsManagerSettings)
+import Time (hour)
+
+import TzBot.Cache
+  (TzCacheSettings(tcsExpiryRandomAmplitudeFraction), defaultTzCacheSettings, withTzCache,
+  withTzCacheDefault)
+import TzBot.Config
+import TzBot.Config.Types (BotConfig)
+import TzBot.Logger
+import TzBot.RunMonad
+import TzBot.Util
+
+withBotState :: BotConfig -> Managed BotState
+withBotState bsConfig@Config {..} = do
+  let fifteenPercentAmplitudeSettings = defaultTzCacheSettings
+        { tcsExpiryRandomAmplitudeFraction = Just 0.15
+        }
+
+  bsManager <- liftIO $ newManager tlsManagerSettings
+  bsFeedbackConfig <-
+    managed $ withFeedbackConfig bsConfig
+  bsUserInfoCache <-
+    managed $ withTzCache fifteenPercentAmplitudeSettings cCacheUsersInfo
+
+  bsConversationMembersCache <-
+    managed $ withTzCache fifteenPercentAmplitudeSettings cCacheConversationMembers
+  let defaultMessageInfoCachingTime = hour 1
+  bsMessageCache <-
+    managed $ withTzCacheDefault defaultMessageInfoCachingTime
+  bsMessageLinkCache <-
+    managed $ withTzCacheDefault defaultMessageInfoCachingTime
+  bsReportEntries <-
+    managed $ withTzCacheDefault cCacheReportDialog
+  -- auto-acknowledge received messages
+  (bsLogNamespace, bsLogContext, bsLogEnv) <- managed $ withLogger cLogLevel
+  pure BotState {..}
+
+withFeedbackConfig :: BotConfig -> (FeedbackConfig -> IO a) -> IO a
+withFeedbackConfig Config {..} action = do
+  let fcFeedbackChannel = cFeedbackChannel
+  withFeedbackFile cFeedbackFile $ \fcFeedbackFile ->
+    action FeedbackConfig {..}
+  where
+    withFeedbackFile :: Maybe FilePath -> (Maybe Handle -> IO a) -> IO a
+    withFeedbackFile mbPath action =
+      withMaybe mbPath (action Nothing) $ \path ->
+        withFile path AppendMode (action . Just)

src/TzBot/BotMain/Server.hs

@@ -0,0 +1,133 @@
+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>
+--
+-- SPDX-License-Identifier: MPL-2.0
+
+module TzBot.BotMain.Server where
+
+import Universum
+
+import Control.Monad.Managed (runManaged)
+import Data.Aeson (FromJSON(..), Value)
+import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
+import Data.Aeson.Types (parseEither)
+import Network.Wai.Handler.Warp (defaultSettings)
+import Network.Wai.Handler.Warp qualified as Warp
+import Servant
+  (Application, FormUrlEncoded, Handler(Handler), Header, JSON, NoContent(..), PlainText, Post,
+  ReqBody, type (:>))
+import Servant.API.Generic ((:-))
+import Servant.Server.Generic (genericServeT)
+import Slacker (SlashCommand)
+import Slacker.SocketMode (EventWrapper)
+import Text.Interpolation.Nyan (int, rmode', rmode's)
+import UnliftIO (async, try)
+import Web.FormUrlEncoded (FromForm(..), genericFromForm)
+
+import TzBot.BotMain.Common (withBotState)
+import TzBot.BotMain.Server.Extractors
+  (pattern BlockActionServer, pattern EventValueServer, pattern InteractiveServer)
+import TzBot.Config (readConfig)
+import TzBot.Logger (logError)
+import TzBot.Options (RunServerOptions(..))
+import TzBot.ProcessEvents
+  (handleRawBlockAction, handleRawEvent, handleRawInteractive, handleSlashCommand)
+import TzBot.RunMonad (BotM, BotState, runBotM)
+import TzBot.Util (defaultFromFormOptions)
+
+type ReqIdHeader = Header "X-Slack-Request-Timestamp" Text
+
+data Routes mode = Routes
+  { rCommon :: mode
+    :- ReqIdHeader
+      :> ReqBody '[JSON] Value
+      :> Post '[PlainText] NoContent
+  , rHelp   :: mode
+    :- "help"
+      :> ReqBody '[FormUrlEncoded] SlashCommand
+      :> Post '[PlainText] NoContent
+  , rInteractive :: mode
+    :- "interactive"
+      :> ReqIdHeader
+      :> ReqBody '[FormUrlEncoded] InteractiveRequest
+      :> Post '[PlainText] NoContent
+  } deriving stock (Generic)
+
+runServer :: RunServerOptions -> IO ()
+runServer opts = do
+  let mbConfigFilePath = rsoConfigFile opts
+  bsConfig <- readConfig mbConfigFilePath
+  let settings = Warp.setPort 8080 defaultSettings
+  runManaged do
+    botState <- withBotState bsConfig
+    liftIO $ Warp.runSettings settings $ app botState
+  where
+    app :: BotState -> Application
+    app bState = genericServeT (naturalTransformation bState) Routes
+      { rCommon = handleEvent
+      , rHelp = handleCommand
+      , rInteractive = handleInteractive
+      }
+
+-- | Here we never report any errors to Slack so never return `ServerError`
+naturalTransformation :: BotState -> BotM a -> Handler a
+naturalTransformation botState action = Handler $ lift $ runBotM botState action
+
+----------------------------------------------------------------------------
+---- Subscribed events
+----------------------------------------------------------------------------
+handleEvent :: Maybe Text -> Value -> BotM NoContent
+handleEvent mbReqTimestamp val = forkAndReturnAck $ do
+  let logTag = fromMaybe "unknown" mbReqTimestamp
+  let eventWrapper = parseEither parseJSON val :: Either String EventWrapper
+  case eventWrapper of
+    Left err -> do
+      logError [int||Unrecognized EventWrapper: #{err}|]
+      logError [int||Full EventWrapper value: #{encodePrettyToTextBuilder val}|]
+    Right ew -> case ew of
+      EventValueServer typ val -> handleRawEvent logTag typ val
+      _ -> logError [int||Invalid Event: #s{ew}|]
+
+----------------------------------------------------------------------------
+---- Interactive (including block actions)
+----------------------------------------------------------------------------
+newtype InteractiveRequest = InteractiveRequest
+  { irPayload :: Value
+  } deriving stock (Generic)
+
+instance FromForm InteractiveRequest where
+  fromForm = genericFromForm defaultFromFormOptions
+
+handleInteractive :: Maybe Text -> InteractiveRequest -> BotM NoContent
+handleInteractive mbReqTimestamp req = forkAndReturnAck do
+  let logTag = fromMaybe "unknown" mbReqTimestamp
+      intValue = irPayload req
+  case intValue of
+    BlockActionServer actionId blockActionRaw ->
+      handleRawBlockAction logTag actionId blockActionRaw
+    InteractiveServer typ interactiveRaw ->
+      handleRawInteractive logTag typ interactiveRaw
+    _ -> logError [int||Unrecognized interactive event: #{encodePrettyToTextBuilder intValue}|]
+
+----------------------------------------------------------------------------
+---- Commands
+----------------------------------------------------------------------------
+handleCommand :: SlashCommand -> BotM NoContent
+handleCommand slashCmd = forkAndReturnAck $ handleSlashCommand slashCmd
+
+----------------------------------------------------------------------------
+---- Common
+----------------------------------------------------------------------------
+
+-- | Slack advices to send ack response as soon as possible, so we run the actual
+-- handler in a separate async (without caring about its further destiny)
+forkAndReturnAck :: BotM () -> BotM NoContent
+forkAndReturnAck action = do
+  -- Here we only log sync exceptions,
+  -- let the servant decide how to handle others
+  let logExceptionWrapper :: BotM () -> BotM ()
+      logExceptionWrapper a = do
+        eithRes <- UnliftIO.try @_ @SomeException a
+        whenLeft eithRes \e ->
+          logError [int||Error occured: #{displayException e}|]
+  UnliftIO.async $ logExceptionWrapper action
+  pure NoContent

src/TzBot/BotMain/Server/Extractors.hs

@@ -0,0 +1,38 @@
+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>
+--
+-- SPDX-License-Identifier: MPL-2.0
+
+{- | This module contains extractors that are similar to ones defined in the `slacker`
+ - package, but adapted to server incoming requests.
+ -}
+module TzBot.BotMain.Server.Extractors where
+
+import Universum
+
+import Data.Aeson (Value)
+import Data.Aeson.Lens (AsPrimitive(_String), AsValue(_Array), key)
+import Slacker.SocketMode (EventWrapper(..))
+
+getEvent :: Value -> Maybe (Text, Value)
+getEvent evt =
+  (,) <$> evt ^? key "type" . _String
+      <*> pure evt
+
+pattern EventValueServer :: Text -> Value -> EventWrapper
+pattern EventValueServer typ event <-
+        EventWrapper
+          { ewEvent = getEvent -> Just (typ, event)
+          , ewType = "event_callback"
+          }
+
+pattern BlockActionServer :: Text -> Value -> Value
+pattern BlockActionServer actionId val <-
+  (getEvent -> Just ("block_actions", getAction -> Just (actionId, val)))
+
+getAction :: Value -> Maybe (Text, Value)
+getAction evt = do
+  [action] <- toList <$> evt ^? key "actions" . _Array
+  (,) <$> (action ^? key "action_id" . _String) <*> pure evt
+
+pattern InteractiveServer :: Text -> Value -> Value
+pattern InteractiveServer typ val <- (getEvent -> Just (typ, val))