From 0bf994ca55202755a9ddb0e38ff8d581ffa19876 Mon Sep 17 00:00:00 2001 From: "Antoine \"Annwan\" Combet" Date: Thu, 17 Mar 2022 09:55:14 +0100 Subject: [PATCH] Fixed reminders --- .gitignore | 4 +- README.org | 12 +- app/Commands.hs | 405 ++++++++++++++++++---------------------- app/Commands/EDT.hs | 250 ++++++++++++------------- app/Commands/Reminds.hs | 78 ++++++++ app/Conf.hs | 169 +++++++++-------- app/Main.hs | 306 +++++++++++++++--------------- botiut.cabal | 4 + stack.yaml | 1 + 9 files changed, 642 insertions(+), 587 deletions(-) create mode 100644 app/Commands/Reminds.hs diff --git a/.gitignore b/.gitignore index 1ed6ea1..583789f 100644 --- a/.gitignore +++ b/.gitignore @@ -4,4 +4,6 @@ dist-newstyle *.secret *# .#* -conf.yaml \ No newline at end of file +conf.yaml +db.sqlite3 +*.data diff --git a/README.org b/README.org index e872ae6..0c6a244 100644 --- a/README.org +++ b/README.org @@ -1,9 +1,11 @@ #+title: botiut #+author: Annwan +#+date: <2022-03-16 Wed> #+options: h:0 num:nil toc:nil ** TODO List -- [ ] Reminders +- [ ] Room availability +- [ ] Write example configuration ** Setup @@ -22,17 +24,17 @@ stack build *** Configuring -- Put your discord token in =auth.secret= in the working directory, +- Put your discord token in ~auth.secret~ in the working directory, without trailing new lines -- Put the yaml format configuration in =conf.yaml=. An commented - configuration example is given in [[./conf.example.yaml][conf.example.yaml]]. +- Put the yaml format configuration in ~conf.yaml~. +A commented + configuration example is given in [[./conf.example.yaml][conf.example.yaml]].+ *** Running There is two options -1) Run =stack run= from the repository +1) Run ~stack run~ from the repository 2) Copy the executable somewhere else, then call it from the expected working directory. diff --git a/app/Commands.hs b/app/Commands.hs index 8eddee7..b99ec39 100644 --- a/app/Commands.hs +++ b/app/Commands.hs @@ -3,261 +3,224 @@ module Commands where -import Discord ( restCall, DiscordHandler ) -import Discord.Types ( ChannelId - , User(..) - , GuildMember(..) - , GuildId, UTCTime, Snowflake - ) -import Discord.Interactions ( interactionResponseBasic - , createApplicationCommandChatInput - , MemberOrUser(..) - , InteractionDataApplicationCommandOptions(..) - , InteractionDataApplicationCommandOptionValue(..) - , Choice(..) - , ApplicationCommandOptionValue(..) - , ApplicationCommandOptions(..) - , InteractionResponse - , CreateApplicationCommand(..) - ) -import Discord.Requests ( ChannelRequest(..) - , GuildRequest(..) - ) - - -import Control.Event ( EventSystem, addEvent ) - -import Control.Monad ( when ) -import Control.Monad.IO.Class ( liftIO ) - -import qualified Data.Map.Strict as Map -import Data.Maybe ( fromMaybe ) -import Data.Time ( getCurrentTime, addUTCTime ) -import qualified Data.Text as T - -import UnliftIO ( withRunInIO ) - - -import Commands.EDT ( getEdt ) -import Conf ( Config(..), Group(..) ) +import Commands.EDT ( getEdt ) +import Commands.Reminds ( Remind(..) + , registerRemind + , scheduleRemind + ) +import Conf ( Config(..) + , Group(..) + ) +import Control.Event ( EventSystem + , addEvent + ) +import Control.Monad ( when ) +import Control.Monad.IO.Class ( liftIO ) +import qualified Data.Map.Strict as Map +import Data.Maybe ( fromMaybe ) +import qualified Data.Text as T +import Data.Time ( addUTCTime + , getCurrentTime + ) +import Discord ( DiscordHandler + , restCall + ) +import Discord.Interactions ( ApplicationCommandOptionValue(..) + , ApplicationCommandOptions(..) + , Choice(..) + , CreateApplicationCommand(..) + , InteractionDataApplicationCommandOptionValue(..) + , InteractionDataApplicationCommandOptions(..) + , InteractionResponse + , MemberOrUser(..) + , createApplicationCommandChatInput + , interactionResponseBasic + ) +import Discord.Requests ( ChannelRequest(..) + , GuildRequest(..) + ) +import Discord.Types ( ChannelId + , GuildId + , GuildMember(..) + , Snowflake + , UTCTime + , User(..) + ) +import UnliftIO ( withRunInIO ) groupNames :: Config -> [T.Text] -groupNames Config{..} = map fst $ Map.toList configGroups +groupNames Config {..} = map fst $ Map.toList configGroups pingCommand :: Maybe CreateApplicationCommand -pingCommand = - createApplicationCommandChatInput - "ping" - "pong" +pingCommand = createApplicationCommandChatInput "ping" "pong" pingResponse :: Config -> IO InteractionResponse pingResponse _ = return $ interactionResponseBasic "Pong" -edtCommand :: Config -> Maybe CreateApplicationCommand +edtCommand :: Config -> Maybe CreateApplicationCommand edtCommand c = createApplicationCommandChatInput "edt" "Gets the planning for a group" - >>= - \cac -> - return - $ cac - { createApplicationCommandOptions = - Just - $ ApplicationCommandOptionsValues - [ ApplicationCommandOptionValueString - "group" - "The group for which the planning is requested" - True (Right $ map (\x -> Choice x x) $ groupNames c) - , ApplicationCommandOptionValueString - "day" - ("The day(s) for which the planning is requested " - `T.append` "(today, tomorrow, week or DD/MM/YYYY)") - False - (Left False) - ] - } - + >>= \cac -> return $ cac + { createApplicationCommandOptions = + Just $ ApplicationCommandOptionsValues + [ ApplicationCommandOptionValueString + "group" + "The group for which the planning is requested" + True + (Right $ map (\x -> Choice x x) $ groupNames c) + , ApplicationCommandOptionValueString + "day" + ( "The day(s) for which the planning is requested " + `T.append` "(today, tomorrow, week or DD/MM/YYYY)" + ) + False + (Left False) + ] + } parseOpt :: InteractionDataApplicationCommandOptionValue -> (T.Text, T.Text) -parseOpt InteractionDataApplicationCommandOptionValueString - { interactionDataApplicationCommandOptionValueName = name - , interactionDataApplicationCommandOptionValueStringValue = - Right val - , .. - } = - (name, val) +parseOpt InteractionDataApplicationCommandOptionValueString { interactionDataApplicationCommandOptionValueName = name, interactionDataApplicationCommandOptionValueStringValue = Right val, ..} + = (name, val) parseOpt _ = ("INVALID Option", "INVALID type") -edtResponse :: Config - -> Maybe InteractionDataApplicationCommandOptions - -> IO InteractionResponse -edtResponse conf@Config{..} (Just (InteractionDataApplicationCommandOptionsValues opts)) = do - planning <- getEdt conf parsedOpts - return $ interactionResponseBasic planning - where - parsedOpts :: Map.Map T.Text T.Text - parsedOpts = Map.fromList $ map parseOpt opts - -edtResponse _ _ = - return $ interactionResponseBasic - "The edt command has mandatory params yet you managed not to give any, WOW" +edtResponse + :: Config + -> Maybe InteractionDataApplicationCommandOptions + -> IO InteractionResponse +edtResponse conf@Config {..} (Just (InteractionDataApplicationCommandOptionsValues opts)) + = do + planning <- getEdt conf parsedOpts + return $ interactionResponseBasic planning + where + parsedOpts :: Map.Map T.Text T.Text + parsedOpts = Map.fromList $ map parseOpt opts +edtResponse _ _ = return $ interactionResponseBasic + "The edt command has mandatory params yet you managed not to give any, WOW" remindCommand :: Maybe CreateApplicationCommand remindCommand = createApplicationCommandChatInput "remind" "reminds you of something later on" - >>= - \cac -> - return - $ cac - { createApplicationCommandOptions = - Just - $ ApplicationCommandOptionsValues - [ ApplicationCommandOptionValueString "delay" "delay" True (Left False) - , ApplicationCommandOptionValueString "message" "message" True (Left False) - ] - } - -data Remind = Remind { rmdWhen :: UTCTime - , rmdWhat :: T.Text - , rmdWhere :: Snowflake - , rmdWho :: Snowflake - } - deriving (Read, Show, Eq) - -remindResponse :: Maybe InteractionDataApplicationCommandOptions - -> EventSystem - -> ChannelId - -> MemberOrUser - -> DiscordHandler InteractionResponse -remindResponse (Just (InteractionDataApplicationCommandOptionsValues opts)) evts ch mou = do - let userid = case mou of - MemberOrUser (Left GuildMember{memberUser = Just User{userId = uid}}) -> uid - MemberOrUser (Right User{userId = uid}) -> uid + >>= \cac -> return $ cac + { createApplicationCommandOptions = + Just $ ApplicationCommandOptionsValues + [ ApplicationCommandOptionValueString "delay" + "delay" + True + (Left False) + , ApplicationCommandOptionValueString "message" + "message" + True + (Left False) + ] + } + +remindResponse + :: Maybe InteractionDataApplicationCommandOptions + -> EventSystem + -> ChannelId + -> MemberOrUser + -> DiscordHandler InteractionResponse +remindResponse (Just (InteractionDataApplicationCommandOptionsValues opts)) evts ch mou + = do + let + userid = case mou of + MemberOrUser (Left GuildMember { memberUser = Just User { userId = uid } }) + -> uid + MemberOrUser (Right User { userId = uid }) -> uid _ -> error "Couldnt get user id" - let d = delay' - now <- liftIO getCurrentTime - let remindDateTime = - case T.last d of - 's' -> addUTCTime ( fromInteger - $ read - $ init - $ T.unpack d - ) now - 'm' -> addUTCTime ( (*60) - $ fromInteger - $ read - $ init - $ T.unpack d - ) now - 'h' -> addUTCTime ( (*3600) - $ fromInteger - $ read - $ init - $ T.unpack d - ) now - 'd' -> addUTCTime ( (*86400) - $ fromInteger - $ read - $ init - $ T.unpack d - ) now - _ -> now - if remindDateTime /= now - then - ( do - withRunInIO $ \runInIO -> - addEvent evts remindDateTime - ( do - runInIO ( restCall - $ CreateMessage ch - $ "<@" - `T.append` T.pack (show userid) - `T.append` "> **Reminder**\n" - `T.append` message - ) - return () - ) - liftIO $ appendFile "reminds.data" $ show (Remind remindDateTime message ch userid) ++ "\n" + let d = delay' + now <- liftIO getCurrentTime + let + remindDateTime = case T.last d of + 's' -> addUTCTime (fromInteger $ read $ init $ T.unpack d) now + 'm' -> addUTCTime ((* 60) $ fromInteger $ read $ init $ T.unpack d) now + 'h' -> + addUTCTime ((* 3600) $ fromInteger $ read $ init $ T.unpack d) now + 'd' -> + addUTCTime ((* 86400) $ fromInteger $ read $ init $ T.unpack d) now + _ -> now + if remindDateTime /= now + then do + let rmd = Remind { rmdUser = userid + , rmdChannel = ch + , rmdMessage = message + , rmdDatetime = remindDateTime + } + scheduleRemind evts rmd + liftIO $ registerRemind rmd return - $ interactionResponseBasic - $ "Reminder registered sucessfully for " + $ interactionResponseBasic + $ "Reminder registered sucessfully for " `T.append` T.pack (show remindDateTime) - ) - else - return $ interactionResponseBasic "couldn't parse your delay :/" - where - parsedOpts = Map.fromList $ map parseOpt opts - delay' = - fromMaybe (error "delay must exist wtf") - $ Map.lookup "delay" parsedOpts - message = - fromMaybe (error "message must exist, wtf") - $ Map.lookup "message" parsedOpts - - -remindResponse _ _ _ _= return $ interactionResponseBasic - "The remind command has mandatory params, yet you managed not to give any, WOW" + else return $ interactionResponseBasic "couldn't parse your delay :/" + where + parsedOpts = Map.fromList $ map parseOpt opts + delay' = + fromMaybe (error "delay must exist wtf") $ Map.lookup "delay" parsedOpts + message = fromMaybe (error "message must exist, wtf") + $ Map.lookup "message" parsedOpts +remindResponse _ _ _ _ = + return + $ interactionResponseBasic + "The remind command has mandatory params, yet you managed not to give any, WOW" groupCommand :: Config -> Maybe CreateApplicationCommand groupCommand c = - createApplicationCommandChatInput "group" "grab your group" - >>= - \cac -> - return - $ cac - { createApplicationCommandOptions = - Just - $ ApplicationCommandOptionsValues + createApplicationCommandChatInput "group" "grab your group" >>= \cac -> + return $ cac + { createApplicationCommandOptions = Just $ ApplicationCommandOptionsValues [ ApplicationCommandOptionValueString - "group" - "Your group" - True - (Right $ map (\x -> Choice x x) $ groupNames c) + "group" + "Your group" + True + (Right $ map (\x -> Choice x x) $ groupNames c) ] - } - -groupResponse :: Config - -> MemberOrUser - -> GuildId - -> Maybe InteractionDataApplicationCommandOptions - -> DiscordHandler InteractionResponse -groupResponse c - mou - gid - (Just (InteractionDataApplicationCommandOptionsValues opts)) = - do - let uid = case mou of - MemberOrUser (Left GuildMember{memberUser = Just User{userId = uid}}) -> uid - MemberOrUser (Right User{userId = uid}) -> uid - _ -> -1 + } + +groupResponse + :: Config + -> MemberOrUser + -> GuildId + -> Maybe InteractionDataApplicationCommandOptions + -> DiscordHandler InteractionResponse +groupResponse c mou gid (Just (InteractionDataApplicationCommandOptionsValues opts)) + = do + let + uid = case mou of + MemberOrUser (Left GuildMember { memberUser = Just User { userId = uid } }) + -> uid + MemberOrUser (Right User { userId = uid }) -> uid + _ -> -1 let rid = groupRole - $ fromMaybe (error "group must exist") - $ Map.lookup group - $ configGroups c + $ fromMaybe (error "group must exist") + $ Map.lookup group + $ configGroups c restCall $ AddGuildMemberRole gid uid rid - return $ interactionResponseBasic $ - "You are now part of group " `T.append` group - where - group = - fromMaybe (error "required option") + return + $ interactionResponseBasic + $ "You are now part of group " + `T.append` group + where + group = + fromMaybe (error "required option") $ Map.lookup "group" $ Map.fromList $ map parseOpt opts - groupResponse _ _ _ _ = - return $ interactionResponseBasic - "the group command has mandatory params, yet you managed not to give any, WOW" + return + $ interactionResponseBasic + "the group command has mandatory params, yet you managed not to give any, WOW" helpCommand :: Maybe CreateApplicationCommand -helpCommand = - createApplicationCommandChatInput - "help" - "help" +helpCommand = createApplicationCommandChatInput "help" "help" helpResponse :: IO InteractionResponse -helpResponse = return . interactionResponseBasic - $ "**__Help for Bot IUT__**\n\n" - `T.append` "`/help` shows this help message\n" - `T.append` "`/group ` join a group\n" - `T.append` "`/remind