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.6 KiB

3 years ago
3 years ago
3 years ago
3 years ago
3 years ago
3 years ago
3 years ago
3 years ago
3 years ago
3 years ago
3 years ago
3 years ago
3 years ago
3 years ago
3 years ago
3 years ago
3 years ago
3 years ago
3 years ago
3 years ago
3 years ago
3 years ago
3 years ago
  1. {-# LANGUAGE OverloadedStrings #-}
  2. {-# LANGUAGE RecordWildCards #-}
  3. {-# LANGUAGE ScopedTypeVariables #-}
  4. module Main where
  5. import Commands ( edtCommand
  6. , edtResponse
  7. , groupCommand
  8. , groupResponse
  9. , helpCommand
  10. , helpResponse
  11. , pingCommand
  12. , pingResponse
  13. , remindCommand
  14. , remindResponse
  15. )
  16. import Commands.EDT ( getEdt )
  17. import Commands.Reminds ( Remind(..)
  18. , scheduleRemind
  19. , setupRemindDb
  20. )
  21. import Conf ( Config(..)
  22. , Group(..)
  23. , readConfig
  24. )
  25. import qualified Control.Concurrent
  26. import qualified Control.Event as E
  27. import Control.Monad ( void
  28. , when
  29. )
  30. import Control.Monad.IO.Unlift ( liftIO
  31. , toIO
  32. , withRunInIO
  33. )
  34. import qualified Data.Map.Strict as Map
  35. import qualified Data.Text as T
  36. import qualified Data.Text.IO as TIO
  37. import Data.Time ( getCurrentTime )
  38. import qualified Database.HDBC as DB
  39. import qualified Database.HDBC.Sqlite3 as DB.SQ3
  40. import Discord ( DiscordHandler
  41. , RunDiscordOpts(..)
  42. , def
  43. , restCall
  44. , runDiscord
  45. , sendCommand
  46. )
  47. import Discord.Interactions ( Interaction(..)
  48. , InteractionDataApplicationCommand(..)
  49. , interactionResponseBasic
  50. )
  51. import qualified Discord.Requests as R
  52. import Discord.Types ( Activity(..)
  53. , ActivityType(..)
  54. , Event(..)
  55. , GatewaySendable(..)
  56. , PartialApplication(..)
  57. , Snowflake(Snowflake)
  58. , UpdateStatusOpts(..)
  59. , UpdateStatusType(..)
  60. )
  61. import qualified System.Cron.Schedule as Cron
  62. import UnliftIO.Directory ( doesFileExist
  63. , removeFile
  64. )
  65. main :: IO ()
  66. main = do
  67. tok <- TIO.readFile "./auth.secret"
  68. conf <- readConfig "./conf.yaml"
  69. eventSystem <- E.initEventSystem
  70. err <- runDiscord $ def
  71. { discordToken = tok
  72. , discordOnStart = onDiscordStart conf eventSystem
  73. , discordOnEnd = liftIO $ putStrLn "Ended"
  74. , discordOnEvent = onDiscordEvent conf eventSystem
  75. , discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn ""
  76. }
  77. TIO.putStrLn err
  78. onDiscordStart :: Config -> E.EventSystem -> DiscordHandler ()
  79. onDiscordStart conf@Config {..} eventSystem = do
  80. let activity :: Activity
  81. activity = def { activityName = "Doing stuff"
  82. , activityType = ActivityTypeGame
  83. , activityUrl = Nothing
  84. }
  85. opts :: UpdateStatusOpts
  86. opts = UpdateStatusOpts { updateStatusOptsSince = Nothing
  87. , updateStatusOptsGame = Just activity
  88. , updateStatusOptsNewStatus = UpdateStatusOnline
  89. , updateStatusOptsAFK = False
  90. }
  91. sendCommand (UpdateStatus opts)
  92. let glist = Map.toList configGroups
  93. withRunInIO $ \runInIO -> Cron.execSchedule $ do
  94. Cron.addJob (runInIO $ pushgroupedt conf "tomorrow" glist)
  95. configAutoEDTCronDay
  96. Cron.addJob (runInIO $ pushgroupedt conf "week" glist) configAutoEDTCronWeek
  97. -- Ensure the database is setup
  98. liftIO setupRemindDb
  99. -- Get the reminders out of the database
  100. conn <- liftIO $ DB.SQ3.connectSqlite3 "db.sqlite3"
  101. query <- liftIO $ DB.prepare
  102. conn
  103. "SELECT user, channel, message, dt \
  104. \FROM reminds \
  105. \WHERE (datetime(dt) > datetime('now'));"
  106. liftIO $ DB.execute query []
  107. reminds <- liftIO $ DB.fetchAllRows' query
  108. mapM_
  109. (\[u, c, m, d] -> do
  110. liftIO $ print [u, c, m, d]
  111. scheduleRemind
  112. eventSystem
  113. Remind { rmdUser = Snowflake $ DB.fromSql u
  114. , rmdChannel = Snowflake $ DB.fromSql c
  115. , rmdMessage = DB.fromSql m
  116. , rmdDatetime = DB.fromSql d
  117. }
  118. )
  119. reminds
  120. liftIO $ putStrLn "Started"
  121. onDiscordEvent :: Config -> E.EventSystem -> Event -> DiscordHandler ()
  122. onDiscordEvent conf@Config {..} eventSystem (Ready _ _ _ _ _ _ (PartialApplication i _))
  123. = do
  124. mapM_
  125. (maybe
  126. (return ())
  127. (void . restCall . R.CreateGuildApplicationCommand i configServer)
  128. )
  129. [ pingCommand
  130. , edtCommand conf
  131. , remindCommand
  132. , groupCommand conf
  133. , helpCommand
  134. ]
  135. onDiscordEvent conf@Config {..} eventSystem (InteractionCreate InteractionApplicationCommand { interactionDataApplicationCommand = InteractionDataApplicationCommandChatInput { interactionDataApplicationCommandName = name, interactionDataApplicationCommandOptions = opts, ..}, interactionChannelId = Just channel, interactionGuildId = Just guild, interactionUser = user, ..})
  136. = do
  137. response <- responseIO
  138. void $ restCall
  139. (R.CreateInteractionResponse interactionId interactionToken response)
  140. where
  141. responseIO = case name of
  142. "ping" -> liftIO $ pingResponse conf
  143. "edt" -> liftIO $ edtResponse conf opts
  144. "remind" -> remindResponse opts eventSystem channel user
  145. "group" -> groupResponse conf user guild opts
  146. "help" -> liftIO helpResponse
  147. _ ->
  148. return $ interactionResponseBasic $ "Unhandled Command: " `T.append` name
  149. onDiscordEvent _ _ _ = return ()
  150. pushgroupedt :: Config -> T.Text -> [(T.Text, Group)] -> DiscordHandler ()
  151. pushgroupedt conf@Config {..} day glist = do
  152. mapM_
  153. (\(gn, Group { groupChannel = gc }) -> do
  154. edt <- liftIO $ getEdt conf $ Map.fromList [("group", gn), ("day", day)]
  155. liftIO
  156. $ TIO.putStrLn
  157. $ "Putting out time table for group "
  158. <> gn
  159. <> " in "
  160. <> T.pack (show gc)
  161. <> ":\n"
  162. <> edt
  163. restCall $ R.CreateMessage gc edt
  164. return ()
  165. )
  166. glist