From 7c3ff2b09018b8cc1b72851be75cba8bc4a48240 Mon Sep 17 00:00:00 2001 From: Yuri Romanowski Date: Sun, 12 Feb 2023 21:22:59 +0500 Subject: [PATCH] [#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. --- config/config.yaml | 11 ++ package.yaml | 6 + src/TzBot/BotMain.hs | 73 +------ src/TzBot/BotMain/Common.hs | 57 ++++++ src/TzBot/BotMain/Server.hs | 231 +++++++++++++++++++++++ src/TzBot/BotMain/Server/Extractors.hs | 38 ++++ src/TzBot/BotMain/Server/Verification.hs | 56 ++++++ src/TzBot/BotMain/SocketMode.hs | 76 ++++++++ src/TzBot/Config.hs | 5 +- src/TzBot/Config/Default.hs | 11 ++ src/TzBot/Config/Types.hs | 8 +- src/TzBot/Instances.hs | 12 ++ src/TzBot/Options.hs | 77 ++++++-- src/TzBot/ProcessEvents.hs | 96 ++++------ src/TzBot/Util.hs | 17 +- test/Test/TzBot/ConfigSpec.hs | 5 + tzbot.cabal | 11 ++ 17 files changed, 647 insertions(+), 143 deletions(-) create mode 100644 src/TzBot/BotMain/Common.hs create mode 100644 src/TzBot/BotMain/Server.hs create mode 100644 src/TzBot/BotMain/Server/Extractors.hs create mode 100644 src/TzBot/BotMain/Server/Verification.hs create mode 100644 src/TzBot/BotMain/SocketMode.hs diff --git a/config/config.yaml b/config/config.yaml index 47f5917..3718a61 100644 --- a/config/config.yaml +++ b/config/config.yaml @@ -60,3 +60,14 @@ inverseHelpUsageChance: 15 # Envvar: SLACK_TZ_LOG_LEVEL # logLevel: Info + + +# Port on which to run (server mode only). +# Envvar: SLACK_TZ_PORT +# +port: 8912 + +# Signing key used to verify Slack signatures (server mode only). +# Envvar: SLACK_TZ_SIGNING_SECRET +# +# signingKey: 12345qwerty diff --git a/package.yaml b/package.yaml index 1ec285d..807a0ab 100644 --- a/package.yaml +++ b/package.yaml @@ -29,6 +29,7 @@ library: - case-insensitive - clock - containers + - cryptonite - directory - fmt - deriving-aeson @@ -37,6 +38,7 @@ library: - formatting - guid - glider-nlp + - http-api-data - http-client - http-client-tls - http-types @@ -45,10 +47,12 @@ library: - lens-aeson - managed - megaparsec + - memory - nyan-interpolation - o-clock - random - optparse-applicative + - servant - servant-auth - servant-auth-client - servant-client @@ -69,6 +73,8 @@ library: - validation - yaml - utf8-string + - wai + - warp executables: tzbot-exe: diff --git a/src/TzBot/BotMain.hs b/src/TzBot/BotMain.hs index 8ae6f4f..ebc8854 100644 --- a/src/TzBot/BotMain.hs +++ b/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 opts + 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) diff --git a/src/TzBot/BotMain/Common.hs b/src/TzBot/BotMain/Common.hs new file mode 100644 index 0000000..71fe3a5 --- /dev/null +++ b/src/TzBot/BotMain/Common.hs @@ -0,0 +1,57 @@ +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- 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) diff --git a/src/TzBot/BotMain/Server.hs b/src/TzBot/BotMain/Server.hs new file mode 100644 index 0000000..ec13b4a --- /dev/null +++ b/src/TzBot/BotMain/Server.hs @@ -0,0 +1,231 @@ +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- SPDX-License-Identifier: MPL-2.0 +{-# OPTIONS_GHC -Wno-deprecations #-} + +module TzBot.BotMain.Server where + +import Universum hiding (newMVar) + +import Control.Concurrent (modifyMVar, newMVar) +import Control.Monad.Managed (runManaged) +import Crypto.Hash (SHA256) +import Crypto.MAC.HMAC (HMAC(hmacGetDigest), hmac) +import Data.Aeson (FromJSON(..), Value) +import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder) +import Data.Aeson.Types (parseEither) +import Data.ByteArray.Encoding qualified as Arr +import Data.ByteString qualified as B +import Data.CaseInsensitive qualified as CI +import Data.List qualified as L +import Data.String.Conversions (cs) +import Network.Wai qualified as Wai +import Network.Wai.Handler.Warp qualified as Warp +import Servant + (AuthProtect, Context(..), FormUrlEncoded, Handler(Handler), Header, JSON, NamedRoutes, + NoContent(..), PlainText, Post, ReqBody, ServerError(..), err401, throwError, type (:>)) +import Servant.API.Generic ((:-)) +import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) +import Servant.Server.Generic (genericServeTWithContext) +import Slacker (SlashCommand) +import Slacker.SocketMode (EventWrapper) +import Text.Interpolation.Nyan (int, rmode', rmode's) +import UnliftIO qualified +import Web.FormUrlEncoded (FromForm(..), genericFromForm) + +import TzBot.BotMain.Common (withBotState) +import TzBot.BotMain.Server.Extractors + (pattern BlockActionServer, pattern EventValueServer, pattern InteractiveServer) +import TzBot.Config (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) + +---------------------------------------------------------------------------- +---- SlackAuth +---------------------------------------------------------------------------- +reqTimestampHeader, reqSignature, slackVersion :: ByteString +reqTimestampHeader = "X-Slack-Request-Timestamp" +reqSignature = "X-Slack-Signature" +slackVersion = "v0" + +type SlackAuth = AuthProtect "slack-sig" +type SlackAuthResult = () + +type instance AuthServerData SlackAuth = SlackAuthResult + +type ReqIdHeader = Header "X-Slack-Request-Timestamp" Text + +slackAuthHandler :: ByteString -> AuthHandler Wai.Request SlackAuthResult +slackAuthHandler signingKey = mkAuthHandler handler + where + handler :: Wai.Request -> Handler SlackAuthResult + handler req = do + body <- extractBody' req + let maybeToEither :: e -> Maybe a -> Either e a + maybeToEither e = maybe (Left e) Right + let lookupHeader headerName = + maybeToEither ("Header " <> cs headerName <> " not found.") $ + L.lookup (CI.mk headerName) $ Wai.requestHeaders req + let eithAuthRes = do + reqTimestamp <- lookupHeader reqTimestampHeader + reqSigFromHeader <- lookupHeader reqSignature + let reqSig = computeSignature reqTimestamp signingKey body + when (reqSig /= reqSigFromHeader) $ Left "Invalid signature" + either (\e -> throwError err401 { errBody = e }) (\_ -> pure ()) eithAuthRes + +computeSignature :: ByteString -> ByteString -> ByteString -> ByteString +computeSignature reqTimestamp signingKey reqBody = do + let total = B.concat [slackVersion, ":", reqTimestamp, ":", reqBody] + hash = hmacGetDigest @SHA256 $ hmac signingKey total + B.concat [slackVersion, "=", Arr.convertToBase Arr.Base16 hash] + +---------------------------------------------------------------------------- +---- Routes +---------------------------------------------------------------------------- +data AuthedRoutes mode = AuthedRoutes + { arRoutes :: mode :- SlackAuth :> NamedRoutes Routes + } deriving stock (Generic) + +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) + +---------------------------------------------------------------------------- +---- Middleware +---------------------------------------------------------------------------- +freezeReqBody :: Wai.Middleware +freezeReqBody app req handle' = do + body' <- extractBody' req + mockExtractor <- mockReqBodyExtractor body' + let req' = req { Wai.requestBody = mockExtractor } + app req' handle' + +mockReqBodyExtractor :: ByteString -> IO (IO ByteString) +mockReqBodyExtractor body = do + mvar <- newMVar (True, body) + pure $ modifyMVar mvar \(whetherToReturn, b) -> + pure if whetherToReturn + then ((not whetherToReturn, b), b) + else ((not whetherToReturn, b), "") + +---------------------------------------------------------------------------- +---- Body extractor +---------------------------------------------------------------------------- +extractBody' :: MonadIO m => Wai.Request -> m ByteString +extractBody' req = mconcat <$> loop [] + where + loop acc = do + chunk <- liftIO (Wai.getRequestBodyChunk req) + if null chunk + then pure $ chunk : acc + else loop $ chunk : acc + +---------------------------------------------------------------------------- +---- Runner +---------------------------------------------------------------------------- +runServer :: RunServerOptions -> IO () +runServer opts = do + let mbConfigFilePath = rsoConfigFile opts + bsConfig <- readConfig mbConfigFilePath + let port = cPort bsConfig + putStrLn @Text [int||Running on port #{port}|] + let settings = + Warp.setPort port Warp.defaultSettings + runManaged do + botState <- withBotState bsConfig + liftIO $ Warp.runSettings settings $ + freezeReqBody $ app (cs $ cSigningKey bsConfig) botState + where + ctx secr = slackAuthHandler secr :. EmptyContext + app :: ByteString -> BotState -> Wai.Application + app signingKey bState = + genericServeTWithContext (naturalTransformation bState) routes (ctx signingKey) + routes = AuthedRoutes $ \_ -> 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 diff --git a/src/TzBot/BotMain/Server/Extractors.hs b/src/TzBot/BotMain/Server/Extractors.hs new file mode 100644 index 0000000..612667c --- /dev/null +++ b/src/TzBot/BotMain/Server/Extractors.hs @@ -0,0 +1,38 @@ +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- 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)) diff --git a/src/TzBot/BotMain/Server/Verification.hs b/src/TzBot/BotMain/Server/Verification.hs new file mode 100644 index 0000000..d5944cd --- /dev/null +++ b/src/TzBot/BotMain/Server/Verification.hs @@ -0,0 +1,56 @@ +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- SPDX-License-Identifier: MPL-2.0 + +module TzBot.BotMain.Server.Verification where + +import Universum + +import Data.Aeson (FromJSON(..), ToJSON, Value) +import Network.Wai.Handler.Warp (defaultSettings) +import Network.Wai.Handler.Warp qualified as Warp +import Servant (Application, Handler, JSON, PlainText, Post, ReqBody, type (:>)) +import Servant.API.Generic ((:-)) +import Servant.Server.Generic (genericServe) +import Text.Interpolation.Nyan (int, rmode', rmode's) + +import TzBot.Config (Config(..), readConfig) +import TzBot.Options (RunServerOptions(..)) +import TzBot.Util (RecordWrapper(..)) + +type API = ReqBody '[JSON] Value :> Post '[PlainText] Text + +newtype VerificationRoutes mode = VerificationRoutes + { vrMain :: mode :- ReqBody '[JSON] VerifyingRequest :> Post '[PlainText] Text + } deriving stock (Generic) + +data VerifyingRequest = VerifyingRequest + { vrChallenge :: Text + , vrToken :: Text + , vrType :: Text + } deriving stock (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via RecordWrapper VerifyingRequest + +-- | When trying to submit a URL for the bot, Slack will send verification +-- request, the bot should just respond with \"challenge\" value. + +-- TODO: Slack also should check the server SSL certificates; currently this +-- was just tested with ngrok which has its own certificates, but for production +-- we need our own ones. +runVerificationServer :: RunServerOptions -> IO () +runVerificationServer opts = do + let mbConfigFilePath = rsoConfigFile opts + bsConfig <- readConfig mbConfigFilePath + let port = cPort bsConfig + let settings = Warp.setPort port defaultSettings + putStrLn @Text "Running in verification mode" + putStrLn @Text [int||Running on port #{port}|] + Warp.runSettings settings app + where + app :: Application + app = genericServe $ VerificationRoutes handler + +handler :: VerifyingRequest -> Handler Text +handler verReq = do + putStrLn @Text [int||got verification value: #s{verReq}|] + pure $ vrChallenge verReq diff --git a/src/TzBot/BotMain/SocketMode.hs b/src/TzBot/BotMain/SocketMode.hs new file mode 100644 index 0000000..19ac6af --- /dev/null +++ b/src/TzBot/BotMain/SocketMode.hs @@ -0,0 +1,76 @@ +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- SPDX-License-Identifier: MPL-2.0 + +module TzBot.BotMain.SocketMode where + +import Universum + +import Control.Exception (AsyncException(UserInterrupt)) +import Control.Monad.Managed (runManaged) +import Slacker + (DisconnectBody(..), EventsApiEnvelope(..), HelloBody(..), SlashCommandsEnvelope(..), + SocketModeEvent(..), defaultSlackConfig, handleThreadExceptionSensibly, pattern BlockAction, + pattern Command, pattern EventValue, pattern Interactive, runSocketMode, setApiToken, setAppToken, + setGracefulShutdownHandler, setOnException) +import Slacker.SocketMode (InteractiveEnvelope(..)) +import Text.Interpolation.Nyan (int, rmode', rmode's) +import UnliftIO.Exception qualified as UnliftIO + +import TzBot.BotMain.Common +import TzBot.Config +import TzBot.Logger +import TzBot.Options +import TzBot.ProcessEvents + (handleRawBlockAction, handleRawEvent, handleRawInteractive, handleSlashCommand) +import TzBot.RunMonad (BotM, BotState, runBotM) + +runSocketMode :: RunSocketModeOptions -> IO () +runSocketMode opts = do + let mbConfigFilePath = rsmoConfigFile opts + bsConfig@Config {..} <- readConfig mbConfigFilePath + runManaged $ do + + 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 + botState <- withBotState bsConfig + liftIO $ Slacker.runSocketMode sCfg \_ e -> + run gracefulShutdownContainer botState $ socketModeHandler e + where + run :: IORef (IO ()) -> BotState -> BotM a -> IO () + run shutdownRef bState action = void $ runBotM bState $ do + eithRes <- UnliftIO.trySyncOrAsync action + whenLeft eithRes $ \e -> do + case fromException e of + Just UserInterrupt -> liftIO $ join $ readIORef shutdownRef + _ -> logError [int||Error occured: #{displayException e}|] + +socketModeHandler :: SocketModeEvent -> BotM () +socketModeHandler e = do + logDebug [int||Received Slack event: #{show @Text e}|] + case e of + Command _cmdType slashCmd -> handleSlashCommand slashCmd + + EventValue eventType evtRaw -> handleRawEvent envelopeIdentifier eventType evtRaw + + -- BlockAction events form a subset of Interactive, so check them first + BlockAction actionId blockActionRaw -> + handleRawBlockAction envelopeIdentifier actionId blockActionRaw + + Interactive interactiveType interactiveRaw -> + handleRawInteractive envelopeIdentifier interactiveType interactiveRaw + _ -> logWarn [int||Unknown SocketModeEvent #s{e}|] + where + envelopeIdentifier :: Text + envelopeIdentifier = case e of + EventsApi EventsApiEnvelope {..} -> eaeEnvelopeId + SlashCommands SlashCommandsEnvelope {..} -> sceEnvelopeId + InteractiveEvent InteractiveEnvelope {..} -> ieEnvelopeId + Hello HelloBody {} -> "hello_body" + Disconnect DisconnectBody {} -> "disconnect_body" diff --git a/src/TzBot/Config.hs b/src/TzBot/Config.hs index 6555907..e72e7f3 100644 --- a/src/TzBot/Config.hs +++ b/src/TzBot/Config.hs @@ -30,7 +30,8 @@ import TzBot.Config.Default (defaultConfigTrick) import TzBot.Config.Types as Types (AppLevelToken(..), BotToken(..), Config(..), ConfigField, ConfigStage(..), Env, EnvVarName, FieldName, appTokenEnv, botTokenEnv, cacheConvMembersEnv, cacheReportDialogEnv, cacheUsersEnv, - feedbackChannelEnv, feedbackFileEnv, inverseHelpUsageChanceEnv, logLevelEnv, maxRetriesEnv) + feedbackChannelEnv, feedbackFileEnv, inverseHelpUsageChanceEnv, logLevelEnv, maxRetriesEnv, + serverPortEnv, signingKeyEnv) import TzBot.Instances () data LoadConfigError @@ -112,6 +113,8 @@ readConfigWithEnv env mbPath = cCacheReportDialog <- fetchOptional cacheReportDialogEnv cCacheReportDialog cInverseHelpUsageChance <- fetchOptional inverseHelpUsageChanceEnv cInverseHelpUsageChance cLogLevel <- fetchOptional logLevelEnv cLogLevel + cPort <- fetchOptional serverPortEnv cPort + cSigningKey <- fetchRequired "signingKey" signingKeyEnv cSigningKey pure Config {..} where handleFunc :: Y.ParseException -> IO (Either [LoadConfigError] $ Config 'CSFinal) diff --git a/src/TzBot/Config/Default.hs b/src/TzBot/Config/Default.hs index 056a9b7..be550a4 100644 --- a/src/TzBot/Config/Default.hs +++ b/src/TzBot/Config/Default.hs @@ -79,6 +79,17 @@ inverseHelpUsageChance: 15 # Envvar: #{CT.logLevelEnv} # logLevel: Info + + +# Port on which to run (server mode only). +# Envvar: #{CT.serverPortEnv} +# +port: 8912 + +# Signing key used to verify Slack signatures (server mode only). +# Envvar: #{CT.signingKeyEnv} +# +# signingKey: 12345qwerty |] -- This prevents Config.Default.defaultConfigText to be incorrect on compiling. diff --git a/src/TzBot/Config/Types.hs b/src/TzBot/Config/Types.hs index 1f1313a..648bcf1 100644 --- a/src/TzBot/Config/Types.hs +++ b/src/TzBot/Config/Types.hs @@ -45,7 +45,7 @@ appTokenEnv, botTokenEnv, maxRetriesEnv, cacheUsersEnv, cacheConvMembersEnv, feedbackChannelEnv, feedbackFileEnv, cacheReportDialogEnv, inverseHelpUsageChanceEnv, - logLevelEnv :: EnvVarName + logLevelEnv, serverPortEnv, signingKeyEnv :: EnvVarName appTokenEnv = "SLACK_TZ_APP_TOKEN" botTokenEnv = "SLACK_TZ_BOT_TOKEN" maxRetriesEnv = "SLACK_TZ_MAX_RETRIES" @@ -56,6 +56,8 @@ feedbackFileEnv = "SLACK_TZ_FEEDBACK_FILE" cacheReportDialogEnv = "SLACK_TZ_CACHE_REPORT_DIALOG" inverseHelpUsageChanceEnv = "SLACK_TZ_INVERSE_HELP_USAGE_CHANCE" logLevelEnv = "SLACK_TZ_LOG_LEVEL" +serverPortEnv = "SLACK_TZ_PORT" +signingKeyEnv = "SLACK_TZ_SIGNING_SECRET" -- | Overall config. data Config f = Config @@ -80,6 +82,10 @@ data Config f = Config -- to the ephemeral message. , cLogLevel :: Severity -- ^ Log level. + , cPort :: Int + -- ^ Port on which to run (server mode only). + , cSigningKey :: ConfigField f Text + -- ^ Signing key to check Slack authenticity (server mode only). } deriving stock (Generic) deriving stock instance Eq (Config 'CSInterm) diff --git a/src/TzBot/Instances.hs b/src/TzBot/Instances.hs index d15ad13..d790c94 100644 --- a/src/TzBot/Instances.hs +++ b/src/TzBot/Instances.hs @@ -16,7 +16,13 @@ import Data.Time.Zones.All (TZLabel, toTZName) import Data.Time.Zones.All qualified as TZ import Formatting.Buildable (Buildable(..)) import Glider.NLP.Tokenizer (Token(..)) +import Servant (FromHttpApiData) +import Servant.API (FromHttpApiData(..)) +import Slacker (SlashCommand) import Time (KnownRatName, Time, unitsF, unitsP) +import Web.FormUrlEncoded (FromForm(..), genericFromForm) + +import TzBot.Util (decodeText, defaultFromFormOptions) instance Buildable TZLabel where build = build . T.decodeUtf8 . toTZName @@ -40,3 +46,9 @@ instance KnownRatName unit => ToJSON (Time unit) where toJSON = String . fromString . unitsF deriving stock instance Ord Token + +instance FromForm SlashCommand where + fromForm = genericFromForm defaultFromFormOptions + +instance FromHttpApiData Value where + parseUrlPiece t = maybe (Left "invalid JSON value") Right $ decodeText t diff --git a/src/TzBot/Options.hs b/src/TzBot/Options.hs index 5b22791..8fca46c 100644 --- a/src/TzBot/Options.hs +++ b/src/TzBot/Options.hs @@ -7,17 +7,24 @@ module TzBot.Options where import Universum import Options.Applicative +import Text.Interpolation.Nyan (int) data Command - = DefaultCommand Options + = RunServer RunServerOptions + | RunSocketMode RunSocketModeOptions | DumpConfig DumpOptions data DumpOptions = DOStdOut | DOFile FilePath Bool -data Options = Options - { oConfigFile :: Maybe FilePath +data RunServerOptions = RunServerOptions + { rsoConfigFile :: Maybe FilePath + , rsoVerification :: Bool + } + +newtype RunSocketModeOptions = RunSocketModeOptions + { rsmoConfigFile :: Maybe FilePath } totalParser :: ParserInfo Command @@ -25,20 +32,26 @@ totalParser = info (commandParserWithDefault <**> helper) $ mconcat [ fullDesc , progDesc - "Perform time references translation on new messages post to \ - \Slack conversations or on direct user triggers." + [int|n| + Perform time references translation on new messages post to + Slack conversations or on direct user triggers. + |] , header "Slack timezone bot" , footer configAndEnvironmentNote ] +---------------------------------------------------------------------------- +---- Commands +---------------------------------------------------------------------------- commandParserWithDefault :: Parser Command commandParserWithDefault = asum - [ commandParser - , DefaultCommand <$> optionsParser + [ dumpCommandParser + , runServerCommandParser + , runSocketModeParser ] -commandParser :: Parser Command -commandParser = hsubparser $ +dumpCommandParser :: Parser Command +dumpCommandParser = hsubparser $ command "dump-config" $ info (DumpConfig <$> dumpOptionsParser) (progDesc "Dump default config") @@ -51,16 +64,42 @@ dumpOptionsParser = asum [stdoutParser, dumpFileParser] fileOption = (long "file" <> short 'f' <> metavar "FILEPATH" <> help "Dump to file FILEPATH") forceOption = switch (long "force" <> help "Whether to overwrite existing file") -optionsParser :: Parser Options -optionsParser = Options <$> do - optional $ - strOption - (long "config" <> short 'c' <> metavar "FILEPATH" <> help "Load configuration from FILEPATH") +runServerCommandParser :: Parser Command +runServerCommandParser = hsubparser $ + command "server" $ + info (RunServer <$> runServerOptionsParser) (progDesc "Run the bot as a server") + +runServerOptionsParser :: Parser RunServerOptions +runServerOptionsParser = do + rsoConfigFile <- optional configOptionParser + rsoVerification <- switch (long "verification" <> help "Run server in the verification mode") + pure RunServerOptions {..} + +runSocketModeParser :: Parser Command +runSocketModeParser = hsubparser $ + command "socket-mode" $ + info (RunSocketMode <$> runSocketModeOptionsParser) (progDesc "Run the bot in the socket mode") + +runSocketModeOptionsParser :: Parser RunSocketModeOptions +runSocketModeOptionsParser = RunSocketModeOptions <$> optional configOptionParser + +---------------------------------------------------------------------------- +---- Common +---------------------------------------------------------------------------- +configOptionParser :: Parser FilePath +configOptionParser = strOption + (long "config" <> short 'c' <> metavar "FILEPATH" + <> help "Load configuration from FILEPATH") +---------------------------------------------------------------------------- +---- Footer +---------------------------------------------------------------------------- configAndEnvironmentNote :: String configAndEnvironmentNote = - "Configuration parameters can be also specified using environment\ - \ variables, for details run `tzbot dump-config -f ` and\ - \ see the config fields descriptions. If all the parameters are contained\ - \ by either envvars or the default config, the additional config file is\ - \ not required." + [int|n| + Configuration parameters can be also specified using environment + variables, for details run `tzbot dump-config -f ` and + see the config fields descriptions. If all the parameters are contained + by either envvars or the default config, the additional config file is + not required. + |] diff --git a/src/TzBot/ProcessEvents.hs b/src/TzBot/ProcessEvents.hs index 083e22a..e4e9922 100644 --- a/src/TzBot/ProcessEvents.hs +++ b/src/TzBot/ProcessEvents.hs @@ -3,22 +3,17 @@ -- SPDX-License-Identifier: MPL-2.0 module TzBot.ProcessEvents - ( handler - ) where + ( handleSlashCommand + , handleRawEvent + , handleRawBlockAction + , handleRawInteractive) where import Universum -import Control.Exception (AsyncException(UserInterrupt)) import Data.Aeson (FromJSON(..), Value) import Data.Aeson.Types (parseEither) -import Slacker - (DisconnectBody(DisconnectBody), EventsApiEnvelope(EventsApiEnvelope, eaeEnvelopeId), - HelloBody(..), SlackConfig, SlashCommandsEnvelope(SlashCommandsEnvelope, sceEnvelopeId), - SocketModeEvent(..), pattern BlockAction, pattern Command, pattern EventValue, - pattern Interactive) -import Slacker.SocketMode (InteractiveEnvelope(..)) +import Slacker (SlashCommand, scCommand) import Text.Interpolation.Nyan (int, rmode', rmode's) -import UnliftIO.Exception qualified as UnliftIO import TzBot.Logger import TzBot.ProcessEvents.BlockAction qualified as B @@ -26,12 +21,12 @@ import TzBot.ProcessEvents.ChannelEvent (processMemberJoinedChannel, processMemb import TzBot.ProcessEvents.Command (processHelpCommand) import TzBot.ProcessEvents.Interactive qualified as I import TzBot.ProcessEvents.Message (processMessageEvent) -import TzBot.RunMonad (BotM, BotState(..), runBotM) +import TzBot.RunMonad (BotM) import TzBot.Slack.API.Block (ActionId(..)) import TzBot.Slack.Fixtures qualified as Fixtures import TzBot.Util (encodeText) -{- | +{- After the message event came, the bot sends some ephemerals containing translations of time references in that message. @@ -51,54 +46,43 @@ event comes, and the bot collects user feedback in the configured way. The bot also has a command `\tzhelp`, should return help message in response. -} -handler :: IORef (IO ()) -> BotState -> SlackConfig -> SocketModeEvent -> IO () -handler shutdownRef bState _cfg e = run $ do - logDebug [int||Received Slack event: #{show @Text e}|] - case e of - Command cmdType slashCmd -> case cmdType of - Fixtures.HelpCommand -> katipAddNamespaceText cmdType $ processHelpCommand slashCmd - unknownCmd -> logWarn [int||Unknown command #{unknownCmd}|] - EventValue eventType evtRaw - | eventType == "message" -> - decodeAndProcess eventType envelopeIdentifier processMessageEvent evtRaw - | eventType == "member_joined_channel" -> - decodeAndProcess eventType envelopeIdentifier processMemberJoinedChannel evtRaw - | eventType == "member_left_channel" -> - decodeAndProcess eventType envelopeIdentifier processMemberLeftChannel evtRaw - | otherwise -> logWarn [int||Unrecognized EventValue #{encodeText evtRaw}|] +handleSlashCommand :: SlashCommand -> BotM () +handleSlashCommand slashCmd = do + let cmdType = scCommand slashCmd + case cmdType of + Fixtures.HelpCommand -> katipAddNamespaceText cmdType $ processHelpCommand slashCmd + unknownCmd -> logWarn [int||Unknown command #{unknownCmd}|] - -- BlockAction events form a subset of Interactive, so check them first - BlockAction actionId blockActionRaw - | actionId == unActionId Fixtures.reportButtonActionId -> - decodeAndProcess actionId envelopeIdentifier B.processReportButtonToggled blockActionRaw - | otherwise -> - logWarn [int||Unrecognized BlockAction #s{e}|] - - Interactive interactiveType interactiveRaw - | interactiveType == "message_action" -> - decodeAndProcess interactiveType envelopeIdentifier I.processInteractive interactiveRaw - | interactiveType == "view_submission" -> - decodeAndProcess interactiveType envelopeIdentifier I.processViewSubmission interactiveRaw - | otherwise -> - logWarn [int||Unrecognized Interactive event #s{e}|] - _ -> logWarn [int||Unknown SocketModeEvent #s{e}|] +handleRawEvent :: Text -> Text -> Value -> BotM () +handleRawEvent envelopeIdentifier eventType evtRaw + | eventType == "message" = + go processMessageEvent + | eventType == "member_joined_channel" = + go processMemberJoinedChannel + | eventType == "member_left_channel" = + go processMemberLeftChannel + | otherwise = logWarn [int||Unrecognized EventValue #{encodeText evtRaw}|] where - run :: BotM a -> IO () - run action = void $ runBotM bState $ do - eithRes <- UnliftIO.trySyncOrAsync action - whenLeft eithRes $ \e -> do - case fromException e of - Just UserInterrupt -> liftIO $ join $ readIORef shutdownRef - _ -> logError [int||Error occured: #{displayException e}|] + go :: (FromJSON a) => (a -> BotM ()) -> BotM () + go action = decodeAndProcess eventType envelopeIdentifier action evtRaw + +-- BlockAction events form a subset of Interactive, so check them first +handleRawBlockAction :: Text -> Text -> Value -> BotM () +handleRawBlockAction envelopeIdentifier actionId blockActionRaw + | actionId == unActionId Fixtures.reportButtonActionId = + decodeAndProcess actionId envelopeIdentifier B.processReportButtonToggled blockActionRaw + | otherwise = + logWarn [int||Unrecognized BlockAction identifier #{actionId}|] - envelopeIdentifier :: Text - envelopeIdentifier = case e of - EventsApi EventsApiEnvelope {..} -> eaeEnvelopeId - SlashCommands SlashCommandsEnvelope {..} -> sceEnvelopeId - InteractiveEvent InteractiveEnvelope {..} -> ieEnvelopeId - Hello HelloBody {} -> "hello_body" - Disconnect DisconnectBody {} -> "disconnect_body" +handleRawInteractive :: Text -> Text -> Value -> BotM () +handleRawInteractive envelopeIdentifier interactiveType interactiveRaw + | interactiveType == "message_action" = + decodeAndProcess interactiveType envelopeIdentifier I.processInteractive interactiveRaw + | interactiveType == "view_submission" = + decodeAndProcess interactiveType envelopeIdentifier I.processViewSubmission interactiveRaw + | otherwise = + logWarn [int||Unrecognized Interactive event type #{interactiveType}|] decodeAndProcess :: FromJSON a => Text -> Text -> (a -> BotM b) -> Value -> BotM () decodeAndProcess interactiveType envelopeIdentifier processFunc raw = do diff --git a/src/TzBot/Util.hs b/src/TzBot/Util.hs index 8bf32e5..75e78da 100644 --- a/src/TzBot/Util.hs +++ b/src/TzBot/Util.hs @@ -23,11 +23,13 @@ import Data.Yaml qualified as Y import GHC.Generics import GHC.IO (unsafePerformIO) import Language.Haskell.TH +import Servant (QueryParam', Required) import System.Clock (TimeSpec, fromNanoSecs, toNanoSecs) import System.Environment (lookupEnv) import System.Random (randomRIO) import Text.Interpolation.Nyan (int, rmode') import Time (KnownDivRat, Nanosecond, Time, floorRat, ns, toUnit) +import Web.FormUrlEncoded qualified as Form attach :: (Functor f) => (a -> b) -> f a -> f (a, b) attach f = fmap (\x -> (x, f x)) @@ -80,9 +82,17 @@ x +- y = (x - y, x + y) decodeMaybe :: FromJSON a => Value -> Maybe a decodeMaybe = parseMaybe parseJSON +defaultRecordFieldModifier :: String -> String +defaultRecordFieldModifier = camelTo2 '_' . dropWhile isLower + +defaultFromFormOptions :: Form.FormOptions +defaultFromFormOptions = Form.defaultFormOptions + { Form.fieldLabelModifier = defaultRecordFieldModifier + } + defaultRecordOptions :: Options defaultRecordOptions = defaultOptions - { fieldLabelModifier = camelTo2 '_' . dropWhile isLower + { fieldLabelModifier = defaultRecordFieldModifier , omitNothingFields = True } @@ -175,3 +185,8 @@ postfixFields = lensRules & lensField .~ mappingNamer (\n -> [n ++ "L"]) whenT :: (Applicative m) => Bool -> m Bool -> m Bool whenT cond_ action_ = if cond_ then action_ else pure False + +---------------------------------------------------------------------------- +---- servant +---------------------------------------------------------------------------- +type MandatoryParam = QueryParam' '[Required, Strict] diff --git a/test/Test/TzBot/ConfigSpec.hs b/test/Test/TzBot/ConfigSpec.hs index 17134d6..5618765 100644 --- a/test/Test/TzBot/ConfigSpec.hs +++ b/test/Test/TzBot/ConfigSpec.hs @@ -48,6 +48,8 @@ configLoadingSpec = , (cacheReportDialogEnv, "3m") , (inverseHelpUsageChanceEnv, "15") , (logLevelEnv, "Info") + , (serverPortEnv, "8912") + , (signingKeyEnv, "signing-key") ] eithConfig <- readConfigWithEnv env (Just "config/nonexistent.yaml") eithConfig `shouldSatisfy` isRight @@ -87,6 +89,7 @@ configLoadingSpec = [ LCEBothEnvAndConfigFieldMissing "appToken" "SLACK_TZ_APP_TOKEN" , LCEEnvVarParseError "SLACK_TZ_MAX_RETRIES" _ , LCEEnvVarParseError "SLACK_TZ_CACHE_USERS_INFO" _ + , LCEBothEnvAndConfigFieldMissing "signingKey" "SLACK_TZ_SIGNING_SECRET" ] -> True _ -> False prop "maxRetries validation" $ \maxRetries -> do @@ -94,6 +97,7 @@ configLoadingSpec = [ (botTokenEnv, "bot-token") , (appTokenEnv, "app-token") , (maxRetriesEnv, show (maxRetries :: Int)) + , (signingKeyEnv, "signing-key") ] eithConfig <- readConfigWithEnv env (Just "config/config.yaml") eithConfig `shouldSatisfy` \case @@ -105,6 +109,7 @@ configLoadingSpec = let env = M.fromList $ [ (botTokenEnv, "bot-token") , (appTokenEnv, "app-token") + , (signingKeyEnv, "signing-key") ] eithConfig <- readConfigWithEnv env (Just "config/config.yaml") eithConfig `shouldSatisfy` isRight diff --git a/tzbot.cabal b/tzbot.cabal index 458b740..47c3b36 100644 --- a/tzbot.cabal +++ b/tzbot.cabal @@ -25,6 +25,11 @@ source-repository head library exposed-modules: TzBot.BotMain + TzBot.BotMain.Common + TzBot.BotMain.Server + TzBot.BotMain.Server.Extractors + TzBot.BotMain.Server.Verification + TzBot.BotMain.SocketMode TzBot.Cache TzBot.Config TzBot.Config.Default @@ -122,6 +127,7 @@ library , case-insensitive , clock , containers + , cryptonite , deriving-aeson , directory , dlist @@ -129,6 +135,7 @@ library , formatting , glider-nlp , guid + , http-api-data , http-client , http-client-tls , http-types @@ -137,10 +144,12 @@ library , lens-aeson , managed , megaparsec + , memory , nyan-interpolation , o-clock , optparse-applicative , random + , servant , servant-auth , servant-auth-client , servant-client @@ -160,6 +169,8 @@ library , unordered-containers , utf8-string , validation + , wai + , warp , yaml default-language: Haskell2010