From dcef0b65069fb38fd0f6c4382353167f603ebff1 Mon Sep 17 00:00:00 2001 From: LLLL Colonq Date: Thu, 16 Nov 2023 19:06:43 -0500 Subject: Initial commit --- fig-monitor-discord/fig-monitor-discord.cabal | 50 ++++++++ fig-monitor-discord/main/Main.hs | 29 +++++ fig-monitor-discord/src/Fig/Monitor/Discord.hs | 142 +++++++++++++++++++++ .../src/Fig/Monitor/Discord/Utils.hs | 31 +++++ 4 files changed, 252 insertions(+) create mode 100644 fig-monitor-discord/fig-monitor-discord.cabal create mode 100644 fig-monitor-discord/main/Main.hs create mode 100644 fig-monitor-discord/src/Fig/Monitor/Discord.hs create mode 100644 fig-monitor-discord/src/Fig/Monitor/Discord/Utils.hs (limited to 'fig-monitor-discord') diff --git a/fig-monitor-discord/fig-monitor-discord.cabal b/fig-monitor-discord/fig-monitor-discord.cabal new file mode 100644 index 0000000..ef74799 --- /dev/null +++ b/fig-monitor-discord/fig-monitor-discord.cabal @@ -0,0 +1,50 @@ +cabal-version: 3.4 +name: fig-monitor-discord +version: 0.1.0.0 + +common defaults + ghc-options: -Wall + default-language: GHC2021 + default-extensions: NoImplicitPrelude PackageImports LambdaCase MultiWayIf OverloadedStrings OverloadedLists OverloadedRecordDot DuplicateRecordFields RecordWildCards NoFieldSelectors BlockArguments ViewPatterns TypeFamilies DataKinds GADTs + +common deps + build-depends: + base + , aeson + , base64 + , binary + , bytestring + , containers + , data-default-class + , discord-haskell + , directory + , filepath + , megaparsec + , mtl + , network + , pcre-heavy + , safe-exceptions + , text + , time + , tomland + , transformers + , unordered-containers + , vector + , fig-utils + , fig-bus + +library + import: defaults + import: deps + hs-source-dirs: src + exposed-modules: + Fig.Monitor.Discord + Fig.Monitor.Discord.Utils + +executable fig-monitor-discord + import: defaults + import: deps + build-depends: fig-monitor-discord, optparse-applicative + hs-source-dirs: + main + main-is: Main.hs \ No newline at end of file diff --git a/fig-monitor-discord/main/Main.hs b/fig-monitor-discord/main/Main.hs new file mode 100644 index 0000000..595a270 --- /dev/null +++ b/fig-monitor-discord/main/Main.hs @@ -0,0 +1,29 @@ +module Main where + +import Fig.Prelude + +import Options.Applicative + +import Fig.Monitor.Discord +import Fig.Monitor.Discord.Utils + +data Opts = Opts + { busHost :: Text + , busPort :: Text + , config :: FilePath + } + +parseOpts :: Parser Opts +parseOpts = Opts + <$> strOption (long "bus-host" <> metavar "HOST" <> help "Address of message bus" <> value "localhost") + <*> strOption (long "bus-port" <> metavar "PORT" <> help "Message bus port" <> showDefault <> value "32050") + <*> strOption (long "config" <> metavar "PATH" <> help "Path to config file" <> showDefault <> value "fig-monitor-discord.toml") + +main :: IO () +main = do + opts <- execParser $ info (parseOpts <**> helper) + ( fullDesc + <> header "fig-monitor-discord - monitor Discord chat events" + ) + cfg <- loadConfig opts.config + discordBot cfg (opts.busHost, opts.busPort) diff --git a/fig-monitor-discord/src/Fig/Monitor/Discord.hs b/fig-monitor-discord/src/Fig/Monitor/Discord.hs new file mode 100644 index 0000000..ffba215 --- /dev/null +++ b/fig-monitor-discord/src/Fig/Monitor/Discord.hs @@ -0,0 +1,142 @@ +{-# Language QuasiQuotes #-} + +module Fig.Monitor.Discord where + +import Fig.Prelude + +import GHC.Real (fromIntegral) + +import Control.Arrow ((>>>)) +import Control.Monad (unless) +import Control.Monad.Reader (runReaderT) +import Control.Concurrent (forkIO) +import qualified Control.Concurrent.Chan as Chan + +import qualified Data.Text as Text +import qualified Data.ByteString.Base64 as BS.Base64 +import qualified Data.Map.Strict as Map + +import qualified Text.Regex.PCRE.Heavy as PCRE + +import qualified Discord as Dis +import qualified Discord.Types as Dis +import qualified Discord.Requests as Dis +import qualified Discord.Interactions as Dis + +import Fig.Utils.SExpr +import Fig.Bus.Client +import Fig.Monitor.Discord.Utils + +data OutgoingMessage = OutgoingMessage + { user :: Text + , msg :: Text + } + +discordBot :: Config -> (Text, Text) -> IO () +discordBot cfg busAddr = do + outgoing <- Chan.newChan @OutgoingMessage + let cid = Dis.DiscordId $ fromIntegral cfg.channel + busClient busAddr + (\cmds -> do + cmds.subscribe [sexp|(monitor discord chat outgoing)|] + err <- Dis.runDiscord Dis.def + { Dis.discordToken = cfg.authToken + , Dis.discordOnStart = do + let activity = Dis.def + { Dis.activityName = "LCOLONQ" + , Dis.activityType = Dis.ActivityTypeCompeting + } + let opts = Dis.UpdateStatusOpts + { updateStatusOptsSince = Nothing + , updateStatusOptsGame = Just activity + , updateStatusOptsNewStatus = Dis.UpdateStatusOnline + , updateStatusOptsAFK = False + } + Dis.sendCommand (Dis.UpdateStatus opts) + dst <- ask + liftIO . void . forkIO . forever $ flip runReaderT dst do + o <- liftIO $ Chan.readChan outgoing + void . Dis.restCall . Dis.CreateMessage cid $ mconcat + [ "`<", o.user, ">` " + , o.msg + ] + , Dis.discordOnLog = log + , Dis.discordOnEvent = \case + Dis.Ready _ _ _ _ _ _ (Dis.PartialApplication i _) -> do + cmd <- case Dis.createUser "ping" of + Nothing -> throwM $ FigMonitorDiscordException "Failed to create ping command" + Just cmd -> pure cmd + log "Creating application command" + resp <- Dis.restCall $ Dis.CreateGlobalApplicationCommand i cmd + log $ tshow resp + Dis.InteractionCreate cmd@Dis.InteractionApplicationCommand{} -> do + void . Dis.restCall . Dis.CreateInteractionResponse (Dis.interactionId cmd) (Dis.interactionToken cmd) $ Dis.interactionResponseBasic "pong" + Dis.MessageCreate m -> + let + auth = Dis.messageAuthor m + mmemb = Dis.messageMember m + name = fromMaybe (Dis.userName auth) (Dis.memberNick =<< mmemb) + attach = Dis.attachmentProxy <$> Dis.messageAttachments m + reply = Dis.messageReferencedMessage m + mentions = Map.fromList + . filter (isJust . snd) + $ (\u -> (Dis.userId u, Dis.memberNick <$> Dis.userMember u)) + <$> Dis.messageMentions m + replyNick = join . join $ flip Map.lookup mentions . Dis.userId . Dis.messageAuthor =<< reply + replyUser = if isJust replyNick then replyNick else Dis.userName . Dis.messageAuthor <$> reply + msg = Dis.messageContent m + replyMsg = Dis.messageContent <$> reply + replyStr = replyUser >>= \ru -> + if ru == "The Computer" + then replyMsg >>= ( + PCRE.scan [PCRE.re|^`\<(.*)\>`|] >>> \case + ((_, [compName]):_) -> Just compName + _ -> Just ru + ) + else Just ru + msgReplacedEmotes = PCRE.gsub + [PCRE.re|<:([\w_-]+):(\d+)>|] + (\(_ :: Text) -> \case + ([emotename, _num] :: [Text]) -> case emotename of + "mrgreen" -> "🟢" + "mrred" -> "🔴" + "mrblue" -> "🔵" + _ -> ":" <> emotename <> ":" + -- "https://cdn.discordapp.com/emojis/" <> num <> ".webp" + _ -> "" + ) + msg + in unless (Dis.userIsBot auth) do + log $ "Received: " <> msg <> " (from " <> name <> ")" + liftIO $ cmds.publish [sexp|(monitor discord chat incoming)|] + [ SExprString . BS.Base64.encodeBase64 $ encodeUtf8 name + , SExprList [] + , SExprString . BS.Base64.encodeBase64 . encodeUtf8 . Text.intercalate " " + $ maybe [] ((:[]) . (<>":")) replyStr <> + [ msgReplacedEmotes + , Text.intercalate " " + $ Text.takeWhile (/='?') + <$> attach + ] + ] + _ -> pure () + } + log err + ) + (\_cmds d -> do + case d of + SExprList [ev, SExprString euser, SExprString emsg] + | ev == [sexp|(monitor discord chat outgoing)|] + , Right user <- decodeUtf8 <$> BS.Base64.decodeBase64 (encodeUtf8 euser) + , Right msg <- decodeUtf8 <$> BS.Base64.decodeBase64 (encodeUtf8 emsg) -> do + log $ "Sending: " <> msg <> " (from " <> user <> ")" + let replacements :: [(Text, Text)] = + [ (":mrgreen:", "<:mrgreen:1093634800792911972>") + , (":mrblue:", "<:mrblue:1154526193358491719>") + , (":mrred:", "<:mrred:1154524307649724449>") + ] + let newMsg = foldr' (\(n, r) h -> Text.replace n r h) msg replacements + Chan.writeChan outgoing OutgoingMessage { user = user, msg = newMsg } + _ -> log $ "Invalid outgoing message: " <> tshow d + ) + (pure ()) diff --git a/fig-monitor-discord/src/Fig/Monitor/Discord/Utils.hs b/fig-monitor-discord/src/Fig/Monitor/Discord/Utils.hs new file mode 100644 index 0000000..b2a316d --- /dev/null +++ b/fig-monitor-discord/src/Fig/Monitor/Discord/Utils.hs @@ -0,0 +1,31 @@ +{-# Language ApplicativeDo #-} + +module Fig.Monitor.Discord.Utils + ( FigMonitorDiscordException(..) + , Config(..) + , loadConfig + ) where + +import Fig.Prelude + +import qualified Toml + +newtype FigMonitorDiscordException = FigMonitorDiscordException Text + deriving (Show, Eq, Ord) +instance Exception FigMonitorDiscordException + +data Config = Config + { authToken :: Text + , channel :: Int + } deriving (Show, Eq, Ord) + +configCodec :: Toml.TomlCodec Config +configCodec = do + authToken <- Toml.text "auth_token" Toml..= (\a -> a.authToken) + channel <- Toml.int "channel" Toml..= (\a -> a.channel) + pure $ Config{..} + +loadConfig :: FilePath -> IO Config +loadConfig path = Toml.decodeFileEither configCodec path >>= \case + Left err -> throwM . FigMonitorDiscordException $ tshow err + Right config -> pure config -- cgit v1.2.3