From 532c332416195a59ed739eb0f922925813d51656 Mon Sep 17 00:00:00 2001 From: Antoine COMBET Date: Wed, 2 Mar 2022 13:18:53 +0100 Subject: [PATCH] Should be done --- app/Commands.hs | 278 ++++++++++++++++++++++++++++++------- app/Commands.hsCommands.hs | 0 app/Commands/EDT.hs | 174 ++++++++++++++++++++++- app/Conf.hs | 106 ++++++++++++++ app/Main.hs | 134 ++++++++++++------ botiut.cabal | 17 ++- stack.yaml | 15 +- 7 files changed, 620 insertions(+), 104 deletions(-) delete mode 100644 app/Commands.hsCommands.hs create mode 100644 app/Conf.hs diff --git a/app/Commands.hs b/app/Commands.hs index bd31f81..e2647d8 100644 --- a/app/Commands.hs +++ b/app/Commands.hs @@ -3,61 +3,239 @@ module Commands where -import Discord -import Discord.Types -import Discord.Interactions -import qualified Discord.Requests as R -import qualified Data.Text as T -import qualified Data.Map.Strict as Map +import Discord ( restCall, DiscordHandler ) +import Discord.Types ( ChannelId + , User(..) + , GuildMember(..) + , GuildId + ) +import Discord.Interactions ( interactionResponseBasic + , createApplicationCommandChatInput + , MemberOrUser(..) + , InteractionDataApplicationCommandOptions(..) + , InteractionDataApplicationCommandOptionValue(..) + , Choice(..) + , ApplicationCommandOptionValue(..) + , ApplicationCommandOptions(..) + , InteractionResponse + , CreateApplicationCommand(..) + ) +import Discord.Requests ( ChannelRequest(..) + , GuildRequest(..) + ) -import Commands.EDT -pingCommand :: CreateApplicationCommand +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(..) ) + +groupNames :: Config -> [T.Text] +groupNames Config{..} = map fst $ Map.toList configGroups + +pingCommand :: Maybe CreateApplicationCommand pingCommand = - CreateApplicationCommand + createApplicationCommandChatInput "ping" "pong" - (Just []) - Nothing - Nothing - -pingResponse :: InteractionResponse -pingResponse = interactionResponseBasic "Pong" - -edtCommand :: CreateApplicationCommand -edtCommand = CreateApplicationCommand - "edt" - "Gets the planning for a group" - (Just $ toInternal <$> - [ ApplicationCommandOptionValueString - "group" - "Group to get the planning for" - (Just True) - Nothing - Nothing - , ApplicationCommandOptionValueString - "day" - "The day you want the planning for as DD/MM(/YYYY)" - Nothing Nothing Nothing - ]) - Nothing - Nothing - -edtResponse :: Maybe InteractionDataApplicationCommandOptions -> InteractionResponse -edtResponse (Just (InteractionDataApplicationCommandOptionsValues opts)) = - interactionResponseBasic $ - "You gave:\n```hs\n" `T.append` T.pack (show parsedOpts) `T.append` "\n```" + +pingResponse :: Config -> IO InteractionResponse +pingResponse _ = return $ interactionResponseBasic "Pong" + +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) + ] + } + + +parseOpt :: InteractionDataApplicationCommandOptionValue -> (T.Text, T.Text) +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 - parseOpt :: InteractionDataApplicationCommandOptionValue -> (T.Text, T.Text) - parseOpt (InteractionDataApplicationCommandOptionValue - { interactionDataApplicationCommandOptionValueName = name - , interactionDataApplicationCommandOptionValueValue = - ApplicationCommandInteractionDataValueString val - , ..} - ) = (name, val) - parseOpt _ = ("INVALID FORMAT", "INVALID FORMAT") - -edtResponse _ = interactionResponseBasic - "The edt command should have params yet you managed not to give any: wow" + +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) + ] + } + +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 () + ) + return + $ 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" + +groupCommand :: Config -> Maybe CreateApplicationCommand +groupCommand c = + createApplicationCommandChatInput "group" "grab your group" + >>= + \cac -> + return + $ cac + { createApplicationCommandOptions = + Just + $ ApplicationCommandOptionsValues + [ ApplicationCommandOptionValueString + "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 + let rid = + groupRole + $ 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") + $ 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" diff --git a/app/Commands.hsCommands.hs b/app/Commands.hsCommands.hs deleted file mode 100644 index e69de29..0000000 diff --git a/app/Commands/EDT.hs b/app/Commands/EDT.hs index 074ab2e..e3e5eab 100644 --- a/app/Commands/EDT.hs +++ b/app/Commands/EDT.hs @@ -1,5 +1,171 @@ -module Commands.EDT where +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} -import qualified Data.Map.Strict as Map -import qualified Text.ICalendar.Parser as IP -import qualified Text.ICalendar.Types as IT +module Commands.EDT (getEdt) where + +import qualified Data.Map.Strict as Map +import qualified Text.ICalendar.Parser as IP +import qualified Text.ICalendar.Types as IT +import qualified Data.Text as TS +import qualified Data.Text.Lazy.Encoding as TE +import qualified Data.CaseInsensitive as CI +import qualified Data.Text.Lazy as T +import qualified Text.URI as Uri +import qualified Network.HTTP.Simple as HTTP +import Conf ( Group(..), Config(..) ) +import Data.Maybe ( fromMaybe ) +import Control.Monad.IO.Class ( MonadIO, liftIO ) +import qualified Data.Time as DT +import qualified Data.Time.Calendar.Easter as DT +import Data.List ( sortOn ) +import Text.Printf ( printf ) +import qualified Text.Regex.PCRE as Re +import qualified Data.Array as Ar + +getEdt ::Config + -> Map.Map TS.Text TS.Text + -> IO TS.Text +getEdt conf@Config{..} opts = do + cal_req <- HTTP.httpLBS req + let cal = IP.parseICalendar (IP.DecodingFunctions + TE.decodeUtf8 + (CI.mk . TE.decodeUtf8) + ) (TS.unpack group) (HTTP.getResponseBody cal_req) + dates <-readDate date + tz <- DT.getTimeZone + $ DT.UTCTime (head dates) + $ DT.secondsToDiffTime 43200 + let message = case cal of + Left _ -> "I don't know this group, alternatively ADE doesn't work" + Right (vcal@IT.VCalendar{IT.vcEvents = evm}:_, _) -> + TS.unlines . map (\d -> + if not (null (ev d)) then + "**" + `TS.append` TS.pack (show d) + `TS.append` "**\n" + `TS.append` renderEvents tz (ev d) + else "" + ) + $ dates + where + ev :: DT.Day -> [IT.VEvent] + ev d = + sortOn IT.veDTStart + . filter (inDate d) + . map snd + . Map.toList + $ evm + _ -> "An unexpected error has occured" + return message + where + group :: TS.Text + group = fromMaybe "" $ Map.lookup "group" opts + date :: TS.Text + date = fromMaybe "week" $ Map.lookup "day" opts + url :: String + url = + TS.unpack + . groupAde + . fromMaybe (Group 0 0 dummyAddress) + . (`Map.lookup` configGroups) + . fromMaybe "" + . Map.lookup "group" + $ opts + req = HTTP.parseRequest_ url + +-- not a place where you'll find valid ICS so we know the group must be wrong +dummyAddress :: TS.Text +dummyAddress = "https://example.com" + +readDate :: TS.Text -> IO [DT.Day] +readDate dtT = do + DT.UTCTime today _ <- DT.getCurrentTime + return $ case TS.unpack dtT of + "today" -> [today] + "tomorrow" -> [DT.addDays 1 today] + "week" -> map (`DT.addDays` lastSunday) [1..7] where + lastweek :: DT.Day + lastweek = DT.addDays (-6) today + lastSunday = DT.sundayAfter lastweek + [dd, du, '/', md, mu, '/', yk, yh, yd, yu] -> + [ DT.fromGregorian + (read [yk,yh,yd,yu]) + (read [md,mu]) + (read [dd,du]) + ] + _ -> [today] + +inDate :: DT.Day -> IT.VEvent -> Bool +inDate date ev@IT.VEvent{veDTStart = mdts} = evDay == date + where + evDay :: DT.Day + evDay = case mdts of + Just dts -> + case dts of + IT.DTStartDateTime dt _ -> + case dt of + IT.FloatingDateTime lt -> DT.localDay lt + IT.UTCDateTime ut -> DT.utctDay ut + IT.ZonedDateTime lt _ -> DT.localDay lt + IT.DTStartDate da _ -> IT.dateValue da + Nothing -> DT.fromGregorian 0 0 0 + +renderEvents :: DT.TimeZone -> [IT.VEvent] -> TS.Text +renderEvents tz = TS.unlines . map renderEvent + where + renderEvent :: IT.VEvent -> TS.Text + renderEvent ev = + TS.pack + $ printf + "*%02d:%02d → %02d:%02d* : **%s** with **%s** in **%s**" + (DT.todHour $ startT ev) (DT.todMin $ startT ev) + (DT.todHour $ endT ev) (DT.todMin $ endT ev) + (summary ev) (teacher ev) (room ev) + + startT :: IT.VEvent -> DT.TimeOfDay + startT IT.VEvent{veDTStart = Just (IT.DTStartDateTime dt _)} = case dt of + IT.FloatingDateTime lt -> DT.localTimeOfDay lt + IT.UTCDateTime ut -> + snd + . DT.utcToLocalTimeOfDay tz + . DT.timeToTimeOfDay + $ DT.utctDayTime ut + IT.ZonedDateTime lt _ -> DT.localTimeOfDay lt + startT _ = DT.TimeOfDay 0 0 0 + endT :: IT.VEvent -> DT.TimeOfDay + endT IT.VEvent{veDTEndDuration = Just (Left (IT.DTEndDateTime dt _))} = + case dt of + IT.FloatingDateTime lt -> DT.localTimeOfDay lt + IT.UTCDateTime ut -> + snd + . DT.utcToLocalTimeOfDay tz + . DT.timeToTimeOfDay + $ DT.utctDayTime ut + IT.ZonedDateTime lt txt -> DT.localTimeOfDay lt + endT _ = DT.TimeOfDay 0 0 0 + summary IT.VEvent{veSummary = Just IT.Summary{summaryValue = x}} = x + summary _ = "Unknown" + room IT.VEvent{veLocation = Just IT.Location{locationValue = x}} = x + room _ = "Unknown" + teacher :: IT.VEvent -> String + teacher IT.VEvent{veDescription = Just IT.Description{descriptionValue = val}} = + if '\n' `elem` teacher' then + "Unknown" + else + teacher' + where + teacher' = + if uncurry (>) (Ar.bounds marray) then + "Unknown" + else + fst . last . Ar.elems $ marray + + marray = if null matches then Ar.listArray (1,0) [] else head matches + matches = Re.matchAllText teacherRe $ T.unpack val + teacher _ = "Unknown" + teacherRe = Re.makeRegexOpts + Re.compMultiline + Re.execBlank + ("^\\n\\n.+\\n(.+)\\n" :: String) diff --git a/app/Conf.hs b/app/Conf.hs new file mode 100644 index 0000000..07c5264 --- /dev/null +++ b/app/Conf.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +module Conf ( Group(..) , Config(..) , readConfig ) where + +import qualified Data.Text as T +import qualified Discord.Types as D +import Data.Yaml ( Object + , decodeFileThrow + , (.:) + , parseMaybe + , Parser + , withObject + , FromJSON + , Value (Object, Number, String) + , parseJSON + ) +import qualified Data.HashMap.Strict as H +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Control.Monad (mzero) + +import Data.Word (Word64) +import Data.Scientific (Scientific, floatingOrInteger) +import Data.Either (fromRight) + +data Group = Group + { groupChannel :: D.Snowflake + , groupRole :: D.Snowflake + , groupAde :: T.Text + } + deriving (Show, Eq, Read) + +hmToGroup :: H.HashMap T.Text Value -> Group +hmToGroup hm = Group + { groupChannel = scitosno + . 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 + } + +data Config = Config + { configServer :: D.Snowflake + , configGroups :: Map.Map T.Text Group + , configAutoEDTCronDay :: T.Text + , configAutoEDTCronWeek :: T.Text + } + deriving (Show, Eq, Read) + +readConfig :: FilePath -> IO Config +readConfig fp = do + conf_yml <- decodeFileThrow fp :: IO Object +-- print conf_yml + return $ ymlToConf conf_yml + +ymlToConf :: Object -> Config +ymlToConf v = Config + { configServer = server + , configGroups = groups + , configAutoEDTCronDay = autoEdtCronDay + , configAutoEDTCronWeek = autoEdtCronWeek + } + where + server' = errorRequired "server" $ H.lookup "server" v + server = scitosno $ valueNum "server" server' + groups = parseGroups groupsObject + groupsObject = H.lookup "groups" v + parseGroups (Just (Object o)) = let groupList' :: H.HashMap T.Text Group + groupList' = fmap ( hmToGroup + . (\case + Object u -> u + _ -> error "groups are objects") + ) o + in Map.fromList $ H.toList groupList' + parseGroups _ = error "Wrong format for groups" + autoEdtCronDay = + valueText "autoEdtCronDay" + $ fromMaybe "0 15 * * 0-4" + $ H.lookup "autoEdtCronDay" v + autoEdtCronWeek = + valueText "autoEdtCronWeek" + $ fromMaybe "30 9 * * 0" + $ H.lookup "autoEdtCronWeek" v + + +errorRequired :: [Char] -> Maybe a -> a +errorRequired name = fromMaybe (error $ "required field: " ++ name) +valueText :: [Char] -> Value -> T.Text +valueText _ (String t) = t +valueText name _ = error $ name ++ " should be a string" +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 969f98b..055e79b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,80 +1,134 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main where -import Control.Monad (when, void) -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import UnliftIO (liftIO) -import Discord -import Discord.Types -import Discord.Interactions -import qualified Discord.Requests as R -import Commands -import qualified Data.ByteString as BS -import qualified Data.Yaml as YAML -import qualified Data.HashMap.Strict as Map +import Control.Monad (when, void) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Control.Monad.IO.Unlift (toIO, liftIO, withRunInIO) +import Discord ( def, restCall + , runDiscord, sendCommand + , DiscordHandler + , RunDiscordOpts(..) + ) +import Discord.Types ( Event(..), PartialApplication(..) + , GatewaySendable(..) + , UpdateStatusOpts(..) + , UpdateStatusType(..) + , Activity(..), ActivityType(..) + ) +import Discord.Interactions ( interactionResponseBasic + , Interaction(..) + , InteractionDataApplicationCommand(..) + ) +import qualified Discord.Requests as R +import Commands ( edtResponse, edtCommand + , pingResponse, pingCommand + , remindResponse, remindCommand, groupCommand, groupResponse + ) +import Conf ( Config(..), Group(..), readConfig ) +import qualified System.Cron.Schedule as Cron +import qualified Data.Map.Strict as Map +import Commands.EDT (getEdt) +import qualified Control.Concurrent +import qualified Control.Event as E -testServer :: Snowflake -testServer = 740862954454646814 main :: IO () main = do tok <- TIO.readFile "./auth.secret" - conf <- YAML.decodeFileThrow "./conf.yaml" :: IO YAML.Value - putStrLn $ show conf + conf <- readConfig "./conf.yaml" + eventSystem <- E.initEventSystem + print conf err <- runDiscord $ def { discordToken = tok , discordOnStart = onDiscordStart conf , discordOnEnd = liftIO $ putStrLn "Ended" - , discordOnEvent = onDiscordEvent conf + , discordOnEvent = onDiscordEvent conf eventSystem , discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn "" } TIO.putStrLn err -onDiscordStart :: YAML.Value -> DiscordHandler () +onDiscordStart :: Config -> DiscordHandler () onDiscordStart conf = do - let activity = Activity { activityName = "Doing stuff" - , activityType = ActivityTypeGame - , activityUrl = Nothing - } - let opts = UpdateStatusOpts { updateStatusOptsSince = Nothing - , updateStatusOptsGame = Just activity - , updateStatusOptsNewStatus = UpdateStatusOnline - , updateStatusOptsAFK = False - } + let + activity :: Activity + activity = def { activityName = "Doing stuff" + , activityType = ActivityTypeGame + , activityUrl = Nothing + } + opts :: UpdateStatusOpts + opts = UpdateStatusOpts { updateStatusOptsSince = Nothing + , updateStatusOptsGame = Just activity + , updateStatusOptsNewStatus = UpdateStatusOnline + , updateStatusOptsAFK = False + } sendCommand (UpdateStatus opts) -onDiscordEvent :: YAML.Value -> Event -> DiscordHandler () -onDiscordEvent conf (Ready _ _ _ _ _ _ (PartialApplication i _)) = +onDiscordEvent :: Config -> E.EventSystem -> Event -> DiscordHandler () +onDiscordEvent conf@Config{..} eventSystem (Ready _ _ _ _ _ _ (PartialApplication i _)) = do mapM_ (maybe ( return () ) ( void . restCall - . R.CreateGuildApplicationCommand i testServer + . R.CreateGuildApplicationCommand i configServer ) ) - [ Just pingCommand - , Just edtCommand + [ pingCommand + , edtCommand conf + , remindCommand + , groupCommand conf ] -onDiscordEvent conf + let glist = Map.toList configGroups + withRunInIO $ \runInIO -> Cron.execSchedule $ do + Cron.addJob ( runInIO + $ pushgroupedt conf "tomorrow" glist + ) configAutoEDTCronDay + Cron.addJob ( runInIO + $ pushgroupedt conf "week" glist + ) configAutoEDTCronWeek + liftIO $ putStrLn "Started" +onDiscordEvent conf@Config{..} eventSystem ( InteractionCreate InteractionApplicationCommand { interactionDataApplicationCommand = - Just InteractionDataApplicationCommandChatInput + InteractionDataApplicationCommandChatInput { interactionDataApplicationCommandName = name , interactionDataApplicationCommandOptions = opts , .. } + , interactionChannelId = Just channel + , interactionGuildId = Just guild + , interactionUser = user , .. } ) = do - void $ restCall + response <- responseIO + void $ restCall (R.CreateInteractionResponse interactionId interactionToken response) where - response = case name of - "ping" -> pingResponse - "edt" -> edtResponse opts - _ -> interactionResponseBasic $ "Unhandled Command: " `T.append` name -onDiscordEvent _ _ = return () + responseIO = case name of + "ping" -> liftIO $ pingResponse conf + "edt" -> liftIO $ edtResponse conf opts + "remind" -> remindResponse opts eventSystem channel user + "group" -> groupResponse conf user guild opts + _ -> return $ interactionResponseBasic $ "Unhandled Command: " `T.append` name +onDiscordEvent _ _ _ = return () + +pushgroupedt :: Config -> T.Text ->[(T.Text, Group)] -> DiscordHandler () +pushgroupedt conf@Config{..} day glist = do + mapM_ (\(gn, Group{groupChannel = gc}) -> do + edt <- liftIO $ getEdt conf $ Map.fromList [("group", gn), ("day", day )] + liftIO + $ TIO.putStrLn + $ "Putting out time table for group " + `T.append` gn + `T.append` " in " + `T.append` T.pack (show gc) + `T.append` ":\n" + `T.append` edt + restCall $ R.CreateMessage gc (edt `T.append` "\nAutomatic time table") + return () + ) glist diff --git a/botiut.cabal b/botiut.cabal index 2655480..23d107a 100644 --- a/botiut.cabal +++ b/botiut.cabal @@ -27,19 +27,28 @@ executable botiut other-modules: Commands , Commands.EDT + , Conf - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: build-depends: base ^>=4.14.0.0 , discord-haskell - , control-event + , cron , text - , unliftio + , unliftio-core , containers , unordered-containers , iCalendar , bytestring , yaml + , scientific + , http-conduit + , modern-uri + , case-insensitive + , time + , regex-pcre + , array + , unliftio + , mtl + , control-event hs-source-dirs: app default-language: Haskell2010 diff --git a/stack.yaml b/stack.yaml index ee98e75..f0228ab 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,14 +1,17 @@ -resolver: lts-18.24 +resolver: lts-18.27 packages: - . allow-newer: true extra-deps: # Stuff not in stackage - emoji-0.1.0.2 - - control-event-1.3 - iCalendar-0.4.0.5 - mime-0.4.0.2 - # My fork of discord-haskell to fix a bug - - github: Annwan/discord-haskell - commit: 830e3a0bcc2586e40e167a1ec14e357e6396a7d2 - + - discord-haskell-1.12.1 + - control-event-1.3 +## 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: