{-# 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)