You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 

134 lines
5.5 KiB

{-# 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 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
main :: IO ()
main = do
tok <- TIO.readFile "./auth.secret"
conf <- readConfig "./conf.yaml"
eventSystem <- E.initEventSystem
print conf
err <- runDiscord $ def { discordToken = tok
, discordOnStart = onDiscordStart conf
, discordOnEnd = liftIO $ putStrLn "Ended"
, discordOnEvent = onDiscordEvent conf eventSystem
, discordOnLog =
\s -> TIO.putStrLn s >> TIO.putStrLn ""
}
TIO.putStrLn err
onDiscordStart :: Config -> DiscordHandler ()
onDiscordStart conf = do
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 :: Config -> E.EventSystem -> Event -> DiscordHandler ()
onDiscordEvent conf@Config{..} eventSystem (Ready _ _ _ _ _ _ (PartialApplication i _)) = do
mapM_ (maybe ( return () )
( void
. restCall
. R.CreateGuildApplicationCommand i configServer
)
)
[ pingCommand
, edtCommand conf
, remindCommand
, groupCommand 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 =
InteractionDataApplicationCommandChatInput
{ interactionDataApplicationCommandName = name
, interactionDataApplicationCommandOptions = opts
, ..
}
, interactionChannelId = Just channel
, interactionGuildId = Just guild
, interactionUser = user
, ..
}
) = do
response <- responseIO
void $ restCall
(R.CreateInteractionResponse interactionId interactionToken response)
where
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