Initial commit

2 files changed, 173 insertions, 0 deletions

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"
+                      _ -> "<unknown emote>"
+                    )
+                    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