Should be done

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 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 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
+import Commands.EDT ( getEdt )
+import Conf         ( Config(..), Group(..) )
 
-pingCommand :: CreateApplicationCommand
+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 <$>
+
+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"
-        "Group to get the planning for"
-        (Just True)
-        Nothing
-        Nothing
+          "The group for which the planning is requested"
+          True (Right $ map (\x -> Choice x x) $ groupNames c)
         , 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```"
+          ("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"

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 #-}
+
+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)

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

app/Main.hs

@@ -1,45 +1,66 @@
 {-# 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           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
-import qualified Data.ByteString  as BS
-import qualified Data.Yaml        as YAML
-import qualified Data.HashMap.Strict as  Map
+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"
+  let
+    activity :: Activity
+    activity = def { activityName = "Doing stuff"
                    , activityType = ActivityTypeGame
                    , activityUrl = Nothing
                    }
-  let opts = UpdateStatusOpts { updateStatusOptsSince = Nothing
+    opts :: UpdateStatusOpts
+    opts = UpdateStatusOpts { updateStatusOptsSince = Nothing
                             , updateStatusOptsGame = Just activity
                             , updateStatusOptsNewStatus = UpdateStatusOnline
                             , updateStatusOptsAFK = False
@@ -47,34 +68,67 @@ onDiscordStart conf = do
   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
+  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
 

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

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>