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.

168 lines
6.9 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 Control.Monad (when, void)
  6. import qualified Data.Text as T
  7. import qualified Data.Text.IO as TIO
  8. import Control.Monad.IO.Unlift (toIO, liftIO, withRunInIO)
  9. import Discord ( def, restCall
  10. , runDiscord, sendCommand
  11. , DiscordHandler
  12. , RunDiscordOpts(..)
  13. )
  14. import Discord.Types ( Event(..), PartialApplication(..)
  15. , GatewaySendable(..)
  16. , UpdateStatusOpts(..)
  17. , UpdateStatusType(..)
  18. , Activity(..), ActivityType(..)
  19. )
  20. import Discord.Interactions ( interactionResponseBasic
  21. , Interaction(..)
  22. , InteractionDataApplicationCommand(..)
  23. )
  24. import qualified Discord.Requests as R
  25. import Commands ( edtResponse, edtCommand
  26. , pingResponse, pingCommand
  27. , remindResponse, remindCommand
  28. , groupCommand, groupResponse
  29. , helpCommand, helpResponse
  30. , Remind(..)
  31. )
  32. import Conf ( Config(..), Group(..), readConfig )
  33. import qualified System.Cron.Schedule as Cron
  34. import qualified Data.Map.Strict as Map
  35. import Commands.EDT (getEdt)
  36. import qualified Control.Concurrent
  37. import qualified Control.Event as E
  38. import UnliftIO.Directory (doesFileExist, removeFile)
  39. import Data.Time (getCurrentTime)
  40. main :: IO ()
  41. main = do
  42. tok <- TIO.readFile "./auth.secret"
  43. conf <- readConfig "./conf.yaml"
  44. eventSystem <- E.initEventSystem
  45. err <- runDiscord $ def { discordToken = tok
  46. , discordOnStart = onDiscordStart conf eventSystem
  47. , discordOnEnd = liftIO $ putStrLn "Ended"
  48. , discordOnEvent = onDiscordEvent conf eventSystem
  49. , discordOnLog =
  50. \s -> TIO.putStrLn s >> TIO.putStrLn ""
  51. }
  52. TIO.putStrLn err
  53. onDiscordStart :: Config -> E.EventSystem -> DiscordHandler ()
  54. onDiscordStart conf eventSystem = do
  55. let
  56. activity :: Activity
  57. activity = def { activityName = "Doing stuff"
  58. , activityType = ActivityTypeGame
  59. , activityUrl = Nothing
  60. }
  61. opts :: UpdateStatusOpts
  62. opts = UpdateStatusOpts { updateStatusOptsSince = Nothing
  63. , updateStatusOptsGame = Just activity
  64. , updateStatusOptsNewStatus = UpdateStatusOnline
  65. , updateStatusOptsAFK = False
  66. }
  67. sendCommand (UpdateStatus opts)
  68. remindDataExist <- liftIO $ doesFileExist "reminds.data"
  69. when remindDataExist $ do
  70. remindfile <- liftIO $ readFile "reminds.data"
  71. let reminddata :: [Remind]
  72. reminddata = map read $ lines remindfile
  73. now <- liftIO getCurrentTime
  74. liftIO $ removeFile "reminds.data"
  75. mapM_ (\r -> do
  76. withRunInIO $ \runInIO ->
  77. if now > rmdWhen r then
  78. void $ E.addEvent eventSystem (rmdWhen r)
  79. ( do
  80. runInIO ( restCall
  81. $ R.CreateMessage (rmdWhere r)
  82. $ "<@"
  83. `T.append` T.pack (show $rmdWho r)
  84. `T.append` "> **Reminder**\n"
  85. `T.append` rmdWhat r
  86. )
  87. appendFile "reminds.data" $ show r
  88. return ()
  89. )
  90. else
  91. pure ()
  92. ) reminddata
  93. liftIO $ removeFile "reminds.data"
  94. onDiscordEvent :: Config -> E.EventSystem -> Event -> DiscordHandler ()
  95. onDiscordEvent conf@Config{..} eventSystem (Ready _ _ _ _ _ _ (PartialApplication i _)) = do
  96. mapM_ (maybe ( return () )
  97. ( void
  98. . restCall
  99. . R.CreateGuildApplicationCommand i configServer
  100. )
  101. )
  102. [ pingCommand
  103. , edtCommand conf
  104. , remindCommand
  105. , groupCommand conf
  106. , helpCommand
  107. ]
  108. let glist = Map.toList configGroups
  109. withRunInIO $ \runInIO -> Cron.execSchedule $ do
  110. Cron.addJob ( runInIO
  111. $ pushgroupedt conf "tomorrow" glist
  112. ) configAutoEDTCronDay
  113. Cron.addJob ( runInIO
  114. $ pushgroupedt conf "week" glist
  115. ) configAutoEDTCronWeek
  116. liftIO $ putStrLn "Started"
  117. onDiscordEvent conf@Config{..} eventSystem
  118. ( InteractionCreate InteractionApplicationCommand
  119. { interactionDataApplicationCommand =
  120. InteractionDataApplicationCommandChatInput
  121. { interactionDataApplicationCommandName = name
  122. , interactionDataApplicationCommandOptions = opts
  123. , ..
  124. }
  125. , interactionChannelId = Just channel
  126. , interactionGuildId = Just guild
  127. , interactionUser = user
  128. , ..
  129. }
  130. ) = do
  131. response <- responseIO
  132. void $ restCall
  133. (R.CreateInteractionResponse interactionId interactionToken response)
  134. where
  135. responseIO = case name of
  136. "ping" -> liftIO $ pingResponse conf
  137. "edt" -> liftIO $ edtResponse conf opts
  138. "remind" -> remindResponse opts eventSystem channel user
  139. "group" -> groupResponse conf user guild opts
  140. "help" -> liftIO helpResponse
  141. _ -> return $ interactionResponseBasic $ "Unhandled Command: " `T.append` name
  142. onDiscordEvent _ _ _ = return ()
  143. pushgroupedt :: Config -> T.Text ->[(T.Text, Group)] -> DiscordHandler ()
  144. pushgroupedt conf@Config{..} day glist = do
  145. mapM_ (\(gn, Group{groupChannel = gc}) -> do
  146. edt <- liftIO $ getEdt conf $ Map.fromList [("group", gn), ("day", day )]
  147. liftIO
  148. $ TIO.putStrLn
  149. $ "Putting out time table for group "
  150. `T.append` gn
  151. `T.append` " in "
  152. `T.append` T.pack (show gc)
  153. `T.append` ":\n"
  154. `T.append` edt
  155. restCall $ R.CreateMessage gc (edt `T.append` "\nAutomatic time table")
  156. return ()
  157. ) glist