Should be done

3 years ago · 532c332416
7 changed files with 620 additions and 104 deletions
--- 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"
--- a/app/Commands.hsCommands.hs
+++ b/app/Commands.hsCommands.hs
--- 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)
--- a/app/Conf.hs
+++ 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
--- 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
--- 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
--- 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: <insert pactch commit>
 # discord-haskell repo when there is a bug in hackage
 #  - github: aquarial/discord-haskell
 #    commit: <insert master commit>