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.
181 lines
7.7 KiB
181 lines
7.7 KiB
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module Main where
|
|
|
|
import Commands ( edtCommand
|
|
, edtResponse
|
|
, groupCommand
|
|
, groupResponse
|
|
, helpCommand
|
|
, helpResponse
|
|
, pingCommand
|
|
, pingResponse
|
|
, remindCommand
|
|
, remindResponse
|
|
)
|
|
import Commands.EDT ( getEdt )
|
|
import Commands.Reminds ( Remind(..)
|
|
, scheduleRemind
|
|
, setupRemindDb
|
|
)
|
|
import Conf ( Config(..)
|
|
, Group(..)
|
|
, readConfig
|
|
)
|
|
import qualified Control.Concurrent
|
|
import qualified Control.Event as E
|
|
import Control.Monad ( void
|
|
, when
|
|
)
|
|
import Control.Monad.IO.Unlift ( liftIO
|
|
, toIO
|
|
, withRunInIO
|
|
)
|
|
import qualified Data.Map.Strict as Map
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.IO as TIO
|
|
import Data.Time ( getCurrentTime )
|
|
import qualified Database.HDBC as DB
|
|
import qualified Database.HDBC.Sqlite3 as DB.SQ3
|
|
import Discord ( DiscordHandler
|
|
, RunDiscordOpts(..)
|
|
, def
|
|
, restCall
|
|
, runDiscord
|
|
, sendCommand
|
|
)
|
|
import Discord.Interactions ( Interaction(..)
|
|
, InteractionDataApplicationCommand(..)
|
|
, interactionResponseBasic
|
|
)
|
|
import qualified Discord.Requests as R
|
|
import Discord.Types ( Activity(..)
|
|
, ActivityType(..)
|
|
, Event(..)
|
|
, GatewaySendable(..)
|
|
, PartialApplication(..)
|
|
, Snowflake(Snowflake)
|
|
, UpdateStatusOpts(..)
|
|
, UpdateStatusType(..)
|
|
)
|
|
import qualified System.Cron.Schedule as Cron
|
|
import UnliftIO.Directory ( doesFileExist
|
|
, removeFile
|
|
)
|
|
|
|
main :: IO ()
|
|
main = do
|
|
tok <- TIO.readFile "./auth.secret"
|
|
conf <- readConfig "./conf.yaml"
|
|
eventSystem <- E.initEventSystem
|
|
|
|
err <- runDiscord $ def
|
|
{ discordToken = tok
|
|
, discordOnStart = onDiscordStart conf eventSystem
|
|
, discordOnEnd = liftIO $ putStrLn "Ended"
|
|
, discordOnEvent = onDiscordEvent conf eventSystem
|
|
, discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn ""
|
|
}
|
|
TIO.putStrLn err
|
|
|
|
onDiscordStart :: Config -> E.EventSystem -> DiscordHandler ()
|
|
onDiscordStart conf@Config {..} eventSystem = 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)
|
|
|
|
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
|
|
|
|
-- Ensure the database is setup
|
|
|
|
liftIO setupRemindDb
|
|
|
|
-- Get the reminders out of the database
|
|
conn <- liftIO $ DB.SQ3.connectSqlite3 "db.sqlite3"
|
|
|
|
query <- liftIO $ DB.prepare
|
|
conn
|
|
"SELECT user, channel, message, dt \
|
|
\FROM reminds \
|
|
\WHERE (datetime(dt) > datetime('now'));"
|
|
liftIO $ DB.execute query []
|
|
|
|
reminds <- liftIO $ DB.fetchAllRows' query
|
|
mapM_
|
|
(\[u, c, m, d] -> do
|
|
liftIO $ print [u, c, m, d]
|
|
scheduleRemind
|
|
eventSystem
|
|
Remind { rmdUser = Snowflake $ DB.fromSql u
|
|
, rmdChannel = Snowflake $ DB.fromSql c
|
|
, rmdMessage = DB.fromSql m
|
|
, rmdDatetime = DB.fromSql d
|
|
}
|
|
)
|
|
reminds
|
|
liftIO $ putStrLn "Started"
|
|
|
|
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
|
|
, helpCommand
|
|
]
|
|
|
|
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
|
|
"help" -> liftIO helpResponse
|
|
_ ->
|
|
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
|