From 18dfa4518250aa8a349af1998058ee2942fa3177 Mon Sep 17 00:00:00 2001 From: "Antoine \"Annwan\" Combet" Date: Thu, 1 Sep 2022 18:40:26 +0200 Subject: [PATCH] Update to d-h 1.15.1 --- README.org | 3 +- app/Commands.hs | 96 +++++++++++++++++++++-------------------- app/Commands/Reminds.hs | 14 +++--- app/Conf.hs | 39 +++++++++-------- app/Main.hs | 26 +++++------ stack.yaml | 11 ++--- 6 files changed, 97 insertions(+), 92 deletions(-) diff --git a/README.org b/README.org index 0c6a244..4402caa 100644 --- a/README.org +++ b/README.org @@ -4,8 +4,7 @@ #+options: h:0 num:nil toc:nil ** TODO List -- [ ] Room availability -- [ ] Write example configuration + - [ ] Write example configuration ** Setup diff --git a/app/Commands.hs b/app/Commands.hs index b99ec39..a158a87 100644 --- a/app/Commands.hs +++ b/app/Commands.hs @@ -25,15 +25,16 @@ import Data.Time ( addUTCTime import Discord ( DiscordHandler , restCall ) -import Discord.Interactions ( ApplicationCommandOptionValue(..) - , ApplicationCommandOptions(..) +import Discord.Interactions ( OptionValue(..) + , Options(..) , Choice(..) , CreateApplicationCommand(..) - , InteractionDataApplicationCommandOptionValue(..) - , InteractionDataApplicationCommandOptions(..) + , OptionDataValue(..) + , OptionsData(..) , InteractionResponse , MemberOrUser(..) - , createApplicationCommandChatInput + , LocalizedText(..) + , createChatInput , interactionResponseBasic ) import Discord.Requests ( ChannelRequest(..) @@ -45,6 +46,8 @@ import Discord.Types ( ChannelId , Snowflake , UTCTime , User(..) + , RoleId(..) + , DiscordId, ) import UnliftIO ( withRunInIO ) @@ -52,42 +55,46 @@ groupNames :: Config -> [T.Text] groupNames Config {..} = map fst $ Map.toList configGroups pingCommand :: Maybe CreateApplicationCommand -pingCommand = createApplicationCommandChatInput "ping" "pong" +pingCommand = createChatInput "ping" "pong" pingResponse :: Config -> IO InteractionResponse pingResponse _ = return $ interactionResponseBasic "Pong" edtCommand :: Config -> Maybe CreateApplicationCommand edtCommand c = - createApplicationCommandChatInput "edt" "Gets the planning for a group" + createChatInput "edt" "Gets the planning for a group" >>= \cac -> return $ cac - { createApplicationCommandOptions = - Just $ ApplicationCommandOptionsValues - [ ApplicationCommandOptionValueString + { createOptions = + Just $ OptionsValues + [ OptionValueString "group" + Nothing "The group for which the planning is requested" + Nothing True - (Right $ map (\x -> Choice x x) $ groupNames c) - , ApplicationCommandOptionValueString + (Right $ map (\x -> Choice x Nothing x) $ groupNames c) + Nothing Nothing + , OptionValueString "day" - ( "The day(s) for which the planning is requested " - `T.append` "(today, tomorrow, week or DD/MM/YYYY)" - ) + Nothing + "The day(s) for which the planning is requested (today, tomorrow, week or DD/MM/YYYY)" + Nothing False (Left False) + Nothing Nothing ] } -parseOpt :: InteractionDataApplicationCommandOptionValue -> (T.Text, T.Text) -parseOpt InteractionDataApplicationCommandOptionValueString { interactionDataApplicationCommandOptionValueName = name, interactionDataApplicationCommandOptionValueStringValue = Right val, ..} +parseOpt :: OptionDataValue -> (T.Text, T.Text) +parseOpt OptionDataValueString { optionDataValueName = name, optionDataValueString = Right val, ..} = (name, val) parseOpt _ = ("INVALID Option", "INVALID type") edtResponse :: Config - -> Maybe InteractionDataApplicationCommandOptions + -> Maybe OptionsData -> IO InteractionResponse -edtResponse conf@Config {..} (Just (InteractionDataApplicationCommandOptionsValues opts)) +edtResponse conf@Config {..} (Just (OptionsDataValues opts)) = do planning <- getEdt conf parsedOpts return $ interactionResponseBasic planning @@ -99,34 +106,28 @@ edtResponse _ _ = return $ interactionResponseBasic remindCommand :: Maybe CreateApplicationCommand remindCommand = - createApplicationCommandChatInput "remind" "reminds you of something later on" + createChatInput "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) + { createOptions = + Just $ OptionsValues + [ OptionValueString "delay" Nothing "delay" Nothing True (Left False) Nothing Nothing + , OptionValueString "message" Nothing "message" Nothing True (Left False) Nothing Nothing ] } remindResponse - :: Maybe InteractionDataApplicationCommandOptions + :: Maybe OptionsData -> EventSystem - -> ChannelId + -> Discord.Types.ChannelId -> MemberOrUser -> DiscordHandler InteractionResponse -remindResponse (Just (InteractionDataApplicationCommandOptionsValues opts)) evts ch mou +remindResponse (Just (OptionsDataValues opts)) evts ch mou = do let userid = case mou of - MemberOrUser (Left GuildMember { memberUser = Just User { userId = uid } }) + MemberOrUser (Left Discord.Types.GuildMember { memberUser = Just Discord.Types.User { userId = uid } }) -> uid - MemberOrUser (Right User { userId = uid }) -> uid + MemberOrUser (Right Discord.Types.User { userId = uid }) -> uid _ -> error "Couldnt get user id" let d = delay' now <- liftIO getCurrentTime @@ -166,30 +167,31 @@ remindResponse _ _ _ _ = groupCommand :: Config -> Maybe CreateApplicationCommand groupCommand c = - createApplicationCommandChatInput "group" "grab your group" >>= \cac -> + createChatInput "group" "grab your group" >>= \cac -> return $ cac - { createApplicationCommandOptions = Just $ ApplicationCommandOptionsValues - [ ApplicationCommandOptionValueString - "group" - "Your group" + { createOptions = Just $ OptionsValues + [ OptionValueString + "group" Nothing + "Your group" Nothing True - (Right $ map (\x -> Choice x x) $ groupNames c) + (Right $ map (\x -> Choice x Nothing x) $ groupNames c) + Nothing Nothing ] } groupResponse :: Config -> MemberOrUser - -> GuildId - -> Maybe InteractionDataApplicationCommandOptions + -> Discord.Types.GuildId + -> Maybe OptionsData -> DiscordHandler InteractionResponse -groupResponse c mou gid (Just (InteractionDataApplicationCommandOptionsValues opts)) +groupResponse c mou gid (Just (OptionsDataValues opts)) = do let uid = case mou of - MemberOrUser (Left GuildMember { memberUser = Just User { userId = uid } }) + MemberOrUser (Left Discord.Types.GuildMember { memberUser = Just Discord.Types.User { userId = uid } }) -> uid - MemberOrUser (Right User { userId = uid }) -> uid + MemberOrUser (Right Discord.Types.User { userId = uid }) -> uid _ -> -1 let rid = groupRole @@ -213,7 +215,7 @@ groupResponse _ _ _ _ = "the group command has mandatory params, yet you managed not to give any, WOW" helpCommand :: Maybe CreateApplicationCommand -helpCommand = createApplicationCommandChatInput "help" "help" +helpCommand = createChatInput "help" "help" helpResponse :: IO InteractionResponse helpResponse = diff --git a/app/Commands/Reminds.hs b/app/Commands/Reminds.hs index 799eb63..af4fdb4 100644 --- a/app/Commands/Reminds.hs +++ b/app/Commands/Reminds.hs @@ -22,11 +22,15 @@ import Discord ( DiscordHandler import Discord.Interactions ( ) import Discord.Requests ( ChannelRequest(CreateMessage) ) -import Discord.Types ( Snowflake(..) ) +import Discord.Types ( Snowflake(..) + , DiscordId(..) + , ChannelId(..) + , UserId(..) + ) data Remind = Remind - { rmdUser :: Snowflake - , rmdChannel :: Snowflake + { rmdUser :: UserId + , rmdChannel :: ChannelId , rmdMessage :: T.Text , rmdDatetime :: UTCTime } @@ -69,8 +73,8 @@ registerRemind Remind {..} = do conn "INSERT INTO reminds(user, channel, message, dt)\ \VALUES (?,?,?,?)" - [ DB.toSql rmdUser - , DB.toSql rmdChannel + [ DB.toSql $ unId rmdUser + , DB.toSql $ unId rmdChannel , DB.toSql rmdMessage , DB.toSql rmdDatetime ] diff --git a/app/Conf.hs b/app/Conf.hs index 15d22b5..6d42b68 100644 --- a/app/Conf.hs +++ b/app/Conf.hs @@ -31,28 +31,33 @@ import Data.Scientific ( Scientific import Data.Word ( Word64 ) data Group = Group - { groupChannel :: D.Snowflake - , groupRole :: D.Snowflake + { groupChannel :: D.ChannelId + , groupRole :: D.RoleId , groupAde :: T.Text } deriving (Show, Eq, Read) hmToGroup :: H.HashMap T.Text Value -> Group hmToGroup hm = Group - { groupChannel = scitosno + { groupChannel = fromInteger + . fromRight (error "Cant read that as an int") + . floatingOrInteger . valueNum "channel" . errorRequired "channel" $ H.lookup "channel" hm - , groupRole = scitosno . valueNum "role" . errorRequired "role" $ H.lookup - "role" - hm - , groupAde = valueText "edturl" . errorRequired "edturl" $ H.lookup - "edturl" - hm + , groupRole = fromInteger + . fromRight (error "Cant read that as an int") + . floatingOrInteger + . valueNum "role" + . errorRequired "role" + $ H.lookup "role" hm + , groupAde = valueText "edturl" + . errorRequired "edturl" + $ H.lookup "edturl" hm } data Config = Config - { configServer :: D.Snowflake + { configServer :: D.GuildId , configGroups :: Map.Map T.Text Group , configAutoEDTCronDay :: T.Text , configAutoEDTCronWeek :: T.Text @@ -72,8 +77,12 @@ ymlToConf v = Config { configServer = server , configAutoEDTCronWeek = autoEdtCronWeek } where - server' = errorRequired "server" $ H.lookup "server" v - server = scitosno $ valueNum "server" server' + server = fromInteger + . fromRight (error "Cant read that as an int") + . floatingOrInteger + . valueNum "server" + . errorRequired "server" + $ H.lookup "server" v groups = parseGroups groupsObject groupsObject = H.lookup "groups" v parseGroups (Just (Object o)) = @@ -107,9 +116,3 @@ valueNum :: [Char] -> Value -> Scientific valueNum _ (Number n) = n valueNum name _ = error $ name ++ " should be an integer" -scitosno :: Scientific -> D.Snowflake -scitosno = - D.Snowflake - . (fromInteger :: Integer -> Word64) - . fromRight (error "Cant read that as an int") - . floatingOrInteger diff --git a/app/Main.hs b/app/Main.hs index 8fc9f78..727ebf5 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -47,7 +47,7 @@ import Discord ( DiscordHandler , sendCommand ) import Discord.Interactions ( Interaction(..) - , InteractionDataApplicationCommand(..) + , ApplicationCommandData(..) , interactionResponseBasic ) import qualified Discord.Requests as R @@ -71,7 +71,7 @@ main = do conf <- readConfig "./conf.yaml" eventSystem <- E.initEventSystem - err <- runDiscord $ def + err <- Discord.runDiscord $ Discord.def { discordToken = tok , discordOnStart = onDiscordStart conf eventSystem , discordOnEnd = liftIO $ putStrLn "Ended" @@ -80,10 +80,10 @@ main = do } TIO.putStrLn err -onDiscordStart :: Config -> E.EventSystem -> DiscordHandler () +onDiscordStart :: Config -> E.EventSystem -> Discord.DiscordHandler () onDiscordStart conf@Config {..} eventSystem = do let activity :: Activity - activity = def { activityName = "Doing stuff" + activity = Discord.def { activityName = "Doing stuff" , activityType = ActivityTypeGame , activityUrl = Nothing } @@ -93,7 +93,7 @@ onDiscordStart conf@Config {..} eventSystem = do , updateStatusOptsNewStatus = UpdateStatusOnline , updateStatusOptsAFK = False } - sendCommand (UpdateStatus opts) + Discord.sendCommand (UpdateStatus opts) let glist = Map.toList configGroups @@ -122,8 +122,8 @@ onDiscordStart conf@Config {..} eventSystem = do liftIO $ print [u, c, m, d] scheduleRemind eventSystem - Remind { rmdUser = Snowflake $ DB.fromSql u - , rmdChannel = Snowflake $ DB.fromSql c + Remind { rmdUser = fromInteger $ DB.fromSql u + , rmdChannel = fromInteger $ DB.fromSql c , rmdMessage = DB.fromSql m , rmdDatetime = DB.fromSql d } @@ -131,13 +131,13 @@ onDiscordStart conf@Config {..} eventSystem = do reminds liftIO $ putStrLn "Started" -onDiscordEvent :: Config -> E.EventSystem -> Event -> DiscordHandler () +onDiscordEvent :: Config -> E.EventSystem -> Event -> Discord.DiscordHandler () onDiscordEvent conf@Config {..} eventSystem (Ready _ _ _ _ _ _ (PartialApplication i _)) = do mapM_ (maybe (return ()) - (void . restCall . R.CreateGuildApplicationCommand i configServer) + (void . Discord.restCall . R.CreateGuildApplicationCommand i configServer) ) [ pingCommand , edtCommand conf @@ -146,10 +146,10 @@ onDiscordEvent conf@Config {..} eventSystem (Ready _ _ _ _ _ _ (PartialApplicati , helpCommand ] -onDiscordEvent conf@Config {..} eventSystem (InteractionCreate InteractionApplicationCommand { interactionDataApplicationCommand = InteractionDataApplicationCommandChatInput { interactionDataApplicationCommandName = name, interactionDataApplicationCommandOptions = opts, ..}, interactionChannelId = Just channel, interactionGuildId = Just guild, interactionUser = user, ..}) +onDiscordEvent conf@Config {..} eventSystem (InteractionCreate InteractionApplicationCommand { applicationCommandData = ApplicationCommandDataChatInput { applicationCommandDataName = name, optionsData = opts, ..}, interactionChannelId = Just channel, interactionGuildId = Just guild, interactionUser = user, ..}) = do response <- responseIO - void $ restCall + void $ Discord.restCall (R.CreateInteractionResponse interactionId interactionToken response) where responseIO = case name of @@ -162,7 +162,7 @@ onDiscordEvent conf@Config {..} eventSystem (InteractionCreate InteractionApplic return $ interactionResponseBasic $ "Unhandled Command: " `T.append` name onDiscordEvent _ _ _ = return () -pushgroupedt :: Config -> T.Text -> [(T.Text, Group)] -> DiscordHandler () +pushgroupedt :: Config -> T.Text -> [(T.Text, Group)] -> Discord.DiscordHandler () pushgroupedt conf@Config {..} day glist = do mapM_ (\(gn, Group { groupChannel = gc }) -> do @@ -175,7 +175,7 @@ pushgroupedt conf@Config {..} day glist = do <> T.pack (show gc) <> ":\n" <> edt - restCall $ R.CreateMessage gc edt + Discord.restCall $ R.CreateMessage gc edt return () ) glist diff --git a/stack.yaml b/stack.yaml index 93fa62f..584788d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -7,12 +7,9 @@ extra-deps: - emoji-0.1.0.2 - iCalendar-0.4.0.5 - mime-0.4.0.2 - - discord-haskell-1.12.5 - control-event-1.3 - HDBC-sqlite3-2.3.3.1 -## My fork of discord-haskell to PR bug fixes and have them before merge -# - github: Annwan/discord-haskell -# commit: -# discord-haskell repo when there is a bug in hackage -# - github: aquarial/discord-haskell -# commit: + - discord-haskell-1.15.1 +# discord-haskell repo when there is features/bug fixes not in hackage +# - github: discord-haskell/discord-haskell +# commit: