mirror of
https://gitlab.com/upRootNutrition/dotfiles.git
synced 2025-12-16 19:38:01 -06:00
328 lines
17 KiB
Haskell
Executable file
328 lines
17 KiB
Haskell
Executable file
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Main where
|
|
|
|
import Control.Monad (void, when)
|
|
import Data.Text (Text, isPrefixOf, pack, strip, toLower, unpack)
|
|
import Data.Text.IO as TIO
|
|
import Data.Word
|
|
import Discord
|
|
import Discord.Internal.Types.ApplicationCommands
|
|
import Discord.Internal.Types.Interactions
|
|
import Discord.Requests as R
|
|
import Discord.Types
|
|
import UnliftIO.Concurrent
|
|
|
|
main :: IO ()
|
|
main = do
|
|
tokenRaw <- TIO.readFile "/run/secrets/env"
|
|
let token = strip tokenRaw
|
|
userFacingError <-
|
|
runDiscord $
|
|
def
|
|
{ discordToken = token,
|
|
discordOnStart = do
|
|
let appId = botId
|
|
let guildId = serverId
|
|
void $ restCall (CreateGuildApplicationCommand appId guildId baboonCommand)
|
|
void $ restCall (CreateGuildApplicationCommand appId guildId unbaboonCommand),
|
|
discordOnEvent = eventHandler,
|
|
discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn ""
|
|
}
|
|
TIO.putStrLn userFacingError
|
|
|
|
baboonCommand :: CreateApplicationCommand
|
|
baboonCommand =
|
|
CreateApplicationCommandChatInput
|
|
{ createName = "baboon",
|
|
createLocalizedName = Nothing,
|
|
createDescription = "Make someone a baboon",
|
|
createLocalizedDescription = Nothing,
|
|
createOptions =
|
|
Just $
|
|
OptionsValues
|
|
[ OptionValueUser
|
|
{ optionValueName = "target",
|
|
optionValueLocalizedName = Nothing,
|
|
optionValueDescription = "Send a baboon to the safari",
|
|
optionValueLocalizedDescription = Nothing,
|
|
optionValueRequired = True
|
|
}
|
|
],
|
|
createDefaultMemberPermissions = Nothing,
|
|
createDMPermission = Nothing
|
|
}
|
|
|
|
unbaboonCommand :: CreateApplicationCommand
|
|
unbaboonCommand =
|
|
CreateApplicationCommandChatInput
|
|
{ createName = "unbaboon",
|
|
createLocalizedName = Nothing,
|
|
createDescription = "Return a baboon to the wild",
|
|
createLocalizedDescription = Nothing,
|
|
createOptions =
|
|
Just $
|
|
OptionsValues
|
|
[ OptionValueUser
|
|
{ optionValueName = "target",
|
|
optionValueLocalizedName = Nothing,
|
|
optionValueDescription = "The baboon to rewild",
|
|
optionValueLocalizedDescription = Nothing,
|
|
optionValueRequired = True
|
|
}
|
|
],
|
|
createDefaultMemberPermissions = Nothing,
|
|
createDMPermission = Nothing
|
|
}
|
|
|
|
eventHandler :: Event -> DiscordHandler ()
|
|
eventHandler event = case event of
|
|
InteractionCreate interaction -> do
|
|
case interaction of
|
|
InteractionApplicationCommand
|
|
{ interactionId = iId,
|
|
interactionApplicationId = _appId,
|
|
applicationCommandData = cmd,
|
|
interactionGuildId = guildId,
|
|
interactionChannelId = _chanId,
|
|
interactionUser = user,
|
|
interactionToken = iToken
|
|
} -> do
|
|
let invokerUid = case user of
|
|
MemberOrUser (Left guildMember) ->
|
|
maybe (error "No user") userId (memberUser guildMember)
|
|
MemberOrUser (Right plainUser) -> userId plainUser
|
|
|
|
let invokerRoles = case user of
|
|
MemberOrUser (Left guildMember) -> memberRoles guildMember
|
|
MemberOrUser (Right _) -> []
|
|
|
|
let hasPermission = any (\r -> unSnowflake (unId r) == ownerRoleId || unSnowflake (unId r) == moderatorRoleId) invokerRoles
|
|
|
|
when (applicationCommandDataName cmd == "baboon") $ do
|
|
if not hasPermission
|
|
then do
|
|
let response =
|
|
InteractionResponseChannelMessage $
|
|
InteractionResponseMessage
|
|
{ interactionResponseMessageTTS = Nothing,
|
|
interactionResponseMessageContent = Just "You don't have permission to baboonify!",
|
|
interactionResponseMessageEmbeds = Nothing,
|
|
interactionResponseMessageAllowedMentions = Nothing,
|
|
interactionResponseMessageFlags = Just $ InteractionResponseMessageFlags [InteractionResponseMessageFlagEphermeral],
|
|
interactionResponseMessageComponents = Nothing,
|
|
interactionResponseMessageAttachments = Nothing
|
|
}
|
|
void $ restCall (CreateInteractionResponse iId iToken response)
|
|
else do
|
|
let options = optionsData cmd
|
|
let targetUid = case options of
|
|
Just (OptionsDataValues opts) -> extractUserOption opts "target"
|
|
_ -> error "No target specified"
|
|
|
|
if invokerUid == targetUid
|
|
then do
|
|
let response =
|
|
InteractionResponseChannelMessage $
|
|
InteractionResponseMessage
|
|
{ interactionResponseMessageTTS = Nothing,
|
|
interactionResponseMessageContent = Just "You can't baboonify yourself!",
|
|
interactionResponseMessageEmbeds = Nothing,
|
|
interactionResponseMessageAllowedMentions = Nothing,
|
|
interactionResponseMessageFlags = Just $ InteractionResponseMessageFlags [InteractionResponseMessageFlagEphermeral],
|
|
interactionResponseMessageComponents = Nothing,
|
|
interactionResponseMessageAttachments = Nothing
|
|
}
|
|
void $ restCall (CreateInteractionResponse iId iToken response)
|
|
else do
|
|
case guildId of
|
|
Just gid -> do
|
|
targetMemberRes <- restCall (GetGuildMember gid targetUid)
|
|
case targetMemberRes of
|
|
Right targetMember -> do
|
|
let targetRoles = memberRoles targetMember
|
|
let isImmune = any (\r -> unSnowflake (unId r) `elem` immuneRoles) targetRoles
|
|
|
|
if isImmune
|
|
then do
|
|
let response =
|
|
InteractionResponseChannelMessage $
|
|
InteractionResponseMessage
|
|
{ interactionResponseMessageTTS = Nothing,
|
|
interactionResponseMessageContent = Just "That user is immune to baboonification!",
|
|
interactionResponseMessageEmbeds = Nothing,
|
|
interactionResponseMessageAllowedMentions = Nothing,
|
|
interactionResponseMessageFlags = Just $ InteractionResponseMessageFlags [InteractionResponseMessageFlagEphermeral],
|
|
interactionResponseMessageComponents = Nothing,
|
|
interactionResponseMessageAttachments = Nothing
|
|
}
|
|
void $ restCall (CreateInteractionResponse iId iToken response)
|
|
else do
|
|
let targetRoles = memberRoles targetMember
|
|
mapM_ (\roleId -> restCall (RemoveGuildMemberRole gid targetUid roleId)) targetRoles
|
|
void $ restCall (AddGuildMemberRole gid targetUid (DiscordId (Snowflake baboonRoleId)))
|
|
let response =
|
|
InteractionResponseChannelMessage $
|
|
InteractionResponseMessage
|
|
{ interactionResponseMessageTTS = Nothing,
|
|
interactionResponseMessageContent = Just $ "<@" <> pack (show (unId targetUid)) <> "> has become a baboon!",
|
|
interactionResponseMessageEmbeds = Nothing,
|
|
interactionResponseMessageAllowedMentions = Nothing,
|
|
interactionResponseMessageFlags = Nothing,
|
|
interactionResponseMessageComponents = Nothing,
|
|
interactionResponseMessageAttachments = Nothing
|
|
}
|
|
void $ restCall (CreateInteractionResponse iId iToken response)
|
|
Left _ -> do
|
|
let response =
|
|
InteractionResponseChannelMessage $
|
|
InteractionResponseMessage
|
|
{ interactionResponseMessageTTS = Nothing,
|
|
interactionResponseMessageContent = Just "Failed to get target member info!",
|
|
interactionResponseMessageEmbeds = Nothing,
|
|
interactionResponseMessageAllowedMentions = Nothing,
|
|
interactionResponseMessageFlags = Just $ InteractionResponseMessageFlags [InteractionResponseMessageFlagEphermeral],
|
|
interactionResponseMessageComponents = Nothing,
|
|
interactionResponseMessageAttachments = Nothing
|
|
}
|
|
void $ restCall (CreateInteractionResponse iId iToken response)
|
|
Nothing -> return ()
|
|
|
|
when (applicationCommandDataName cmd == "unbaboon") $ do
|
|
if not hasPermission
|
|
then do
|
|
let response =
|
|
InteractionResponseChannelMessage $
|
|
InteractionResponseMessage
|
|
{ interactionResponseMessageTTS = Nothing,
|
|
interactionResponseMessageContent = Just "You don't have permission to use this command!",
|
|
interactionResponseMessageEmbeds = Nothing,
|
|
interactionResponseMessageAllowedMentions = Nothing,
|
|
interactionResponseMessageFlags = Just $ InteractionResponseMessageFlags [InteractionResponseMessageFlagEphermeral],
|
|
interactionResponseMessageComponents = Nothing,
|
|
interactionResponseMessageAttachments = Nothing
|
|
}
|
|
void $ restCall (CreateInteractionResponse iId iToken response)
|
|
else do
|
|
let options = optionsData cmd
|
|
let targetUid = case options of
|
|
Just (OptionsDataValues opts) -> extractUserOption opts "target"
|
|
_ -> error "No target specified"
|
|
|
|
if invokerUid == targetUid
|
|
then do
|
|
let response =
|
|
InteractionResponseChannelMessage $
|
|
InteractionResponseMessage
|
|
{ interactionResponseMessageTTS = Nothing,
|
|
interactionResponseMessageContent = Just "You can't unbaboonify yourself!",
|
|
interactionResponseMessageEmbeds = Nothing,
|
|
interactionResponseMessageAllowedMentions = Nothing,
|
|
interactionResponseMessageFlags = Just $ InteractionResponseMessageFlags [InteractionResponseMessageFlagEphermeral],
|
|
interactionResponseMessageComponents = Nothing,
|
|
interactionResponseMessageAttachments = Nothing
|
|
}
|
|
void $ restCall (CreateInteractionResponse iId iToken response)
|
|
else do
|
|
case guildId of
|
|
Just gid -> do
|
|
targetMemberRes <- restCall (GetGuildMember gid targetUid)
|
|
case targetMemberRes of
|
|
Right targetMember -> do
|
|
let targetRoles = memberRoles targetMember
|
|
let hasBaboonRole = any (\r -> unSnowflake (unId r) == baboonRoleId) targetRoles
|
|
|
|
if not hasBaboonRole
|
|
then do
|
|
let response =
|
|
InteractionResponseChannelMessage $
|
|
InteractionResponseMessage
|
|
{ interactionResponseMessageTTS = Nothing,
|
|
interactionResponseMessageContent = Just "That user is not a baboon!",
|
|
interactionResponseMessageEmbeds = Nothing,
|
|
interactionResponseMessageAllowedMentions = Nothing,
|
|
interactionResponseMessageFlags = Just $ InteractionResponseMessageFlags [InteractionResponseMessageFlagEphermeral],
|
|
interactionResponseMessageComponents = Nothing,
|
|
interactionResponseMessageAttachments = Nothing
|
|
}
|
|
void $ restCall (CreateInteractionResponse iId iToken response)
|
|
else do
|
|
void $ restCall (AddGuildMemberRole gid targetUid (DiscordId (Snowflake defaultRoleId)))
|
|
void $ restCall (RemoveGuildMemberRole gid targetUid (DiscordId (Snowflake baboonRoleId)))
|
|
let response =
|
|
InteractionResponseChannelMessage $
|
|
InteractionResponseMessage
|
|
{ interactionResponseMessageTTS = Nothing,
|
|
interactionResponseMessageContent = Just $ "<@" <> pack (show (unId targetUid)) <> "> is no longer a baboon!",
|
|
interactionResponseMessageEmbeds = Nothing,
|
|
interactionResponseMessageAllowedMentions = Nothing,
|
|
interactionResponseMessageFlags = Nothing,
|
|
interactionResponseMessageComponents = Nothing,
|
|
interactionResponseMessageAttachments = Nothing
|
|
}
|
|
void $ restCall (CreateInteractionResponse iId iToken response)
|
|
Left _ -> do
|
|
let response =
|
|
InteractionResponseChannelMessage $
|
|
InteractionResponseMessage
|
|
{ interactionResponseMessageTTS = Nothing,
|
|
interactionResponseMessageContent = Just "Failed to get target member info!",
|
|
interactionResponseMessageEmbeds = Nothing,
|
|
interactionResponseMessageAllowedMentions = Nothing,
|
|
interactionResponseMessageFlags = Just $ InteractionResponseMessageFlags [InteractionResponseMessageFlagEphermeral],
|
|
interactionResponseMessageComponents = Nothing,
|
|
interactionResponseMessageAttachments = Nothing
|
|
}
|
|
void $ restCall (CreateInteractionResponse iId iToken response)
|
|
Nothing -> return ()
|
|
_ -> return ()
|
|
MessageCreate m -> do
|
|
when (isPing m && not (fromBot m)) $ do
|
|
void $ restCall (R.CreateReaction (messageChannelId m, messageId m) "eyes")
|
|
threadDelay standardPause
|
|
void $ restCall (R.CreateMessage (messageChannelId m) "Pong!")
|
|
_ -> return ()
|
|
|
|
extractUserOption :: [OptionDataValue] -> Text -> UserId
|
|
extractUserOption opts name =
|
|
case [v | OptionDataValueUser n v <- opts, n == name] of
|
|
(uid : _) -> uid
|
|
[] -> error $ "Option not found: " <> unpack name
|
|
|
|
-- Role IDs
|
|
|
|
botId :: ApplicationId
|
|
botId = DiscordId (Snowflake 1428951383494623262)
|
|
|
|
serverId :: GuildId
|
|
serverId = DiscordId (Snowflake 692563032546476062)
|
|
|
|
baboonRoleId :: Word64
|
|
baboonRoleId = 1160622954082738347
|
|
|
|
ownerRoleId :: Word64
|
|
ownerRoleId = 827332588803850270
|
|
|
|
moderatorRoleId :: Word64
|
|
moderatorRoleId = 827303828884946944
|
|
|
|
patronRoleId :: Word64
|
|
patronRoleId = 827404707843538975
|
|
|
|
youTubeRoleId :: Word64
|
|
youTubeRoleId = 993361806141706310
|
|
|
|
defaultRoleId :: Word64
|
|
defaultRoleId = 964354344948494416
|
|
|
|
immuneRoles :: [Word64]
|
|
immuneRoles = [ownerRoleId, moderatorRoleId, patronRoleId, youTubeRoleId]
|
|
|
|
fromBot :: Message -> Bool
|
|
fromBot = userIsBot . messageAuthor
|
|
|
|
isPing :: Message -> Bool
|
|
isPing = ("ping" `isPrefixOf`) . toLower . messageContent
|
|
|
|
standardPause :: Int
|
|
standardPause = (2 * 5 ^ 3)
|