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.

241 lines
7.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
  1. {-# LANGUAGE OverloadedStrings #-}
  2. {-# LANGUAGE RecordWildCards #-}
  3. module Commands where
  4. import Discord ( restCall, DiscordHandler )
  5. import Discord.Types ( ChannelId
  6. , User(..)
  7. , GuildMember(..)
  8. , GuildId
  9. )
  10. import Discord.Interactions ( interactionResponseBasic
  11. , createApplicationCommandChatInput
  12. , MemberOrUser(..)
  13. , InteractionDataApplicationCommandOptions(..)
  14. , InteractionDataApplicationCommandOptionValue(..)
  15. , Choice(..)
  16. , ApplicationCommandOptionValue(..)
  17. , ApplicationCommandOptions(..)
  18. , InteractionResponse
  19. , CreateApplicationCommand(..)
  20. )
  21. import Discord.Requests ( ChannelRequest(..)
  22. , GuildRequest(..)
  23. )
  24. import Control.Event ( EventSystem, addEvent )
  25. import Control.Monad ( when )
  26. import Control.Monad.IO.Class ( liftIO )
  27. import qualified Data.Map.Strict as Map
  28. import Data.Maybe ( fromMaybe )
  29. import Data.Time ( getCurrentTime, addUTCTime )
  30. import qualified Data.Text as T
  31. import UnliftIO ( withRunInIO )
  32. import Commands.EDT ( getEdt )
  33. import Conf ( Config(..), Group(..) )
  34. groupNames :: Config -> [T.Text]
  35. groupNames Config{..} = map fst $ Map.toList configGroups
  36. pingCommand :: Maybe CreateApplicationCommand
  37. pingCommand =
  38. createApplicationCommandChatInput
  39. "ping"
  40. "pong"
  41. pingResponse :: Config -> IO InteractionResponse
  42. pingResponse _ = return $ interactionResponseBasic "Pong"
  43. edtCommand :: Config -> Maybe CreateApplicationCommand
  44. edtCommand c =
  45. createApplicationCommandChatInput "edt" "Gets the planning for a group"
  46. >>=
  47. \cac ->
  48. return
  49. $ cac
  50. { createApplicationCommandOptions =
  51. Just
  52. $ ApplicationCommandOptionsValues
  53. [ ApplicationCommandOptionValueString
  54. "group"
  55. "The group for which the planning is requested"
  56. True (Right $ map (\x -> Choice x x) $ groupNames c)
  57. , ApplicationCommandOptionValueString
  58. "day"
  59. ("The day(s) for which the planning is requested "
  60. `T.append` "(today, tomorrow, week or DD/MM/YYYY)")
  61. False
  62. (Left False)
  63. ]
  64. }
  65. parseOpt :: InteractionDataApplicationCommandOptionValue -> (T.Text, T.Text)
  66. parseOpt InteractionDataApplicationCommandOptionValueString
  67. { interactionDataApplicationCommandOptionValueName = name
  68. , interactionDataApplicationCommandOptionValueStringValue =
  69. Right val
  70. , ..
  71. } =
  72. (name, val)
  73. parseOpt _ = ("INVALID Option", "INVALID type")
  74. edtResponse :: Config
  75. -> Maybe InteractionDataApplicationCommandOptions
  76. -> IO InteractionResponse
  77. edtResponse conf@Config{..} (Just (InteractionDataApplicationCommandOptionsValues opts)) = do
  78. planning <- getEdt conf parsedOpts
  79. return $ interactionResponseBasic planning
  80. where
  81. parsedOpts :: Map.Map T.Text T.Text
  82. parsedOpts = Map.fromList $ map parseOpt opts
  83. edtResponse _ _ =
  84. return $ interactionResponseBasic
  85. "The edt command has mandatory params yet you managed not to give any, WOW"
  86. remindCommand :: Maybe CreateApplicationCommand
  87. remindCommand =
  88. createApplicationCommandChatInput "remind" "reminds you of something later on"
  89. >>=
  90. \cac ->
  91. return
  92. $ cac
  93. { createApplicationCommandOptions =
  94. Just
  95. $ ApplicationCommandOptionsValues
  96. [ ApplicationCommandOptionValueString "delay" "delay" True (Left False)
  97. , ApplicationCommandOptionValueString "message" "message" True (Left False)
  98. ]
  99. }
  100. remindResponse :: Maybe InteractionDataApplicationCommandOptions
  101. -> EventSystem
  102. -> ChannelId
  103. -> MemberOrUser
  104. -> DiscordHandler InteractionResponse
  105. remindResponse (Just (InteractionDataApplicationCommandOptionsValues opts)) evts ch mou = do
  106. let userid = case mou of
  107. MemberOrUser (Left GuildMember{memberUser = Just User{userId = uid}}) -> uid
  108. MemberOrUser (Right User{userId = uid}) -> uid
  109. _ -> error "Couldnt get user id"
  110. let d = delay'
  111. now <- liftIO $ getCurrentTime
  112. let remindDateTime =
  113. case T.last d of
  114. 's' -> addUTCTime ( fromInteger
  115. $ read
  116. $ init
  117. $ T.unpack d
  118. ) now
  119. 'm' -> addUTCTime ( (*60)
  120. $ fromInteger
  121. $ read
  122. $ init
  123. $ T.unpack d
  124. ) now
  125. 'h' -> addUTCTime ( (*3600)
  126. $ fromInteger
  127. $ read
  128. $ init
  129. $ T.unpack d
  130. ) now
  131. 'd' -> addUTCTime ( (*86400)
  132. $ fromInteger
  133. $ read
  134. $ init
  135. $ T.unpack d
  136. ) now
  137. _ -> now
  138. if remindDateTime /= now
  139. then
  140. ( do
  141. withRunInIO $ \runInIO ->
  142. addEvent evts remindDateTime
  143. ( do
  144. runInIO ( restCall
  145. $ CreateMessage ch
  146. $ "<@"
  147. `T.append` T.pack (show userid)
  148. `T.append` "> **Reminder**\n"
  149. `T.append` message
  150. )
  151. return ()
  152. )
  153. return
  154. $ interactionResponseBasic
  155. $ "Reminder registered sucessfully for "
  156. `T.append` T.pack (show remindDateTime)
  157. )
  158. else
  159. return $ interactionResponseBasic "couldn't parse your delay :/"
  160. where
  161. parsedOpts = Map.fromList $ map parseOpt opts
  162. delay' =
  163. fromMaybe (error "delay must exist wtf")
  164. $ Map.lookup "delay" parsedOpts
  165. message =
  166. fromMaybe (error "message must exist, wtf")
  167. $ Map.lookup "message" parsedOpts
  168. remindResponse _ _ _ _= return $ interactionResponseBasic
  169. "The remind command has mandatory params, yet you managed not to give any, WOW"
  170. groupCommand :: Config -> Maybe CreateApplicationCommand
  171. groupCommand c =
  172. createApplicationCommandChatInput "group" "grab your group"
  173. >>=
  174. \cac ->
  175. return
  176. $ cac
  177. { createApplicationCommandOptions =
  178. Just
  179. $ ApplicationCommandOptionsValues
  180. [ ApplicationCommandOptionValueString
  181. "group"
  182. "Your group"
  183. True
  184. (Right $ map (\x -> Choice x x) $ groupNames c)
  185. ]
  186. }
  187. groupResponse :: Config
  188. -> MemberOrUser
  189. -> GuildId
  190. -> Maybe InteractionDataApplicationCommandOptions
  191. -> DiscordHandler InteractionResponse
  192. groupResponse c
  193. mou
  194. gid
  195. (Just (InteractionDataApplicationCommandOptionsValues opts)) =
  196. do
  197. let uid = case mou of
  198. MemberOrUser (Left GuildMember{memberUser = Just User{userId = uid}}) -> uid
  199. MemberOrUser (Right User{userId = uid}) -> uid
  200. _ -> -1
  201. let rid =
  202. groupRole
  203. $ fromMaybe (error "group must exist")
  204. $ Map.lookup group
  205. $ configGroups c
  206. restCall $ AddGuildMemberRole gid uid rid
  207. return $ interactionResponseBasic $
  208. "You are now part of group " `T.append` group
  209. where
  210. group =
  211. fromMaybe (error "required option")
  212. $ Map.lookup "group"
  213. $ Map.fromList
  214. $ map parseOpt opts
  215. groupResponse _ _ _ _ =
  216. return $ interactionResponseBasic
  217. "the group command has mandatory params, yet you managed not to give any, WOW"