projects
/
botiut
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

Fixed reminders

master
Annwan 3 years ago
parent
e7d01960f5
commit
0bf994ca55
9 changed files with 642 additions and 587 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 2
      .gitignore
  2. 12
      README.org
  3. 265
      app/Commands.hs
  4. 136
      app/Commands/EDT.hs
  5. 78
      app/Commands/Reminds.hs
  6. 81
      app/Conf.hs
  7. 202
      app/Main.hs
  8. 4
      botiut.cabal
  9. 1
      stack.yaml

2
.gitignore
View File

@ -5,3 +5,5 @@ dist-newstyle
*# *#
.#* .#*
conf.yaml conf.yaml
db.sqlite3
*.data

12
README.org
View File

@ -1,9 +1,11 @@
#+title: botiut #+title: botiut
#+author: Annwan #+author: Annwan
#+date: <2022-03-16 Wed>
#+options: h:0 num:nil toc:nil #+options: h:0 num:nil toc:nil
** TODO List ** TODO List
- [ ] Reminders
- [ ] Room availability
- [ ] Write example configuration
** Setup ** Setup
@ -22,17 +24,17 @@ stack build
*** Configuring *** Configuring
- Put your discord token in =auth.secret= in the working directory,
- Put your discord token in ~auth.secret~ in the working directory,
without trailing new lines without trailing new lines
- Put the yaml format configuration in =conf.yaml=. An commented
configuration example is given in [[./conf.example.yaml][conf.example.yaml]].
- Put the yaml format configuration in ~conf.yaml~. +A commented
configuration example is given in [[./conf.example.yaml][conf.example.yaml]].+
*** Running *** Running
There is two options There is two options
1) Run =stack run= from the repository
1) Run ~stack run~ from the repository
2) Copy the executable somewhere else, then call it from the expected 2) Copy the executable somewhere else, then call it from the expected
working directory. working directory.

265
app/Commands.hs
View File

@ -3,52 +3,56 @@
module Commands where module Commands where
import Discord ( restCall, DiscordHandler )
import Discord.Types ( ChannelId
, User(..)
, GuildMember(..)
, GuildId, UTCTime, Snowflake
import Commands.EDT ( getEdt )
import Commands.Reminds ( Remind(..)
, registerRemind
, scheduleRemind
) )
import Discord.Interactions ( interactionResponseBasic
, createApplicationCommandChatInput
, MemberOrUser(..)
, InteractionDataApplicationCommandOptions(..)
, InteractionDataApplicationCommandOptionValue(..)
, Choice(..)
, ApplicationCommandOptionValue(..)
, ApplicationCommandOptions(..)
, InteractionResponse
, CreateApplicationCommand(..)
import Conf ( Config(..)
, Group(..)
) )
import Discord.Requests ( ChannelRequest(..)
, GuildRequest(..)
import Control.Event ( EventSystem
, addEvent
) )
import Control.Event ( EventSystem, addEvent )
import Control.Monad ( when ) import Control.Monad ( when )
import Control.Monad.IO.Class ( liftIO ) import Control.Monad.IO.Class ( liftIO )
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.Maybe ( fromMaybe ) import Data.Maybe ( fromMaybe )
import Data.Time ( getCurrentTime, addUTCTime )
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time ( addUTCTime
, getCurrentTime
)
import Discord ( DiscordHandler
, restCall
)
import Discord.Interactions ( ApplicationCommandOptionValue(..)
, ApplicationCommandOptions(..)
, Choice(..)
, CreateApplicationCommand(..)
, InteractionDataApplicationCommandOptionValue(..)
, InteractionDataApplicationCommandOptions(..)
, InteractionResponse
, MemberOrUser(..)
, createApplicationCommandChatInput
, interactionResponseBasic
)
import Discord.Requests ( ChannelRequest(..)
, GuildRequest(..)
)
import Discord.Types ( ChannelId
, GuildId
, GuildMember(..)
, Snowflake
, UTCTime
, User(..)
)
import UnliftIO ( withRunInIO ) import UnliftIO ( withRunInIO )
import Commands.EDT ( getEdt )
import Conf ( Config(..), Group(..) )
groupNames :: Config -> [T.Text] groupNames :: Config -> [T.Text]
groupNames Config{..} = map fst $ Map.toList configGroups
groupNames Config {..} = map fst $ Map.toList configGroups
pingCommand :: Maybe CreateApplicationCommand pingCommand :: Maybe CreateApplicationCommand
pingCommand =
createApplicationCommandChatInput
"ping"
"pong"
pingCommand = createApplicationCommandChatInput "ping" "pong"
pingResponse :: Config -> IO InteractionResponse pingResponse :: Config -> IO InteractionResponse
pingResponse _ = return $ interactionResponseBasic "Pong" pingResponse _ = return $ interactionResponseBasic "Pong"
@ -56,157 +60,115 @@ pingResponse _ = return $ interactionResponseBasic "Pong"
edtCommand :: Config -> Maybe CreateApplicationCommand edtCommand :: Config -> Maybe CreateApplicationCommand
edtCommand c = edtCommand c =
createApplicationCommandChatInput "edt" "Gets the planning for a group" createApplicationCommandChatInput "edt" "Gets the planning for a group"
>>=
\cac ->
return
$ cac
>>= \cac -> return $ cac
{ createApplicationCommandOptions = { createApplicationCommandOptions =
Just
$ ApplicationCommandOptionsValues
Just $ ApplicationCommandOptionsValues
[ ApplicationCommandOptionValueString [ ApplicationCommandOptionValueString
"group" "group"
"The group for which the planning is requested" "The group for which the planning is requested"
True (Right $ map (\x -> Choice x x) $ groupNames c)
True
(Right $ map (\x -> Choice x x) $ groupNames c)
, ApplicationCommandOptionValueString , ApplicationCommandOptionValueString
"day" "day"
("The day(s) for which the planning is requested "
`T.append` "(today, tomorrow, week or DD/MM/YYYY)")
( "The day(s) for which the planning is requested "
`T.append` "(today, tomorrow, week or DD/MM/YYYY)"
)
False False
(Left False) (Left False)
] ]
} }
parseOpt :: InteractionDataApplicationCommandOptionValue -> (T.Text, T.Text) parseOpt :: InteractionDataApplicationCommandOptionValue -> (T.Text, T.Text)
parseOpt InteractionDataApplicationCommandOptionValueString
{ interactionDataApplicationCommandOptionValueName = name
, interactionDataApplicationCommandOptionValueStringValue =
Right val
, ..
} =
(name, val)
parseOpt InteractionDataApplicationCommandOptionValueString { interactionDataApplicationCommandOptionValueName = name, interactionDataApplicationCommandOptionValueStringValue = Right val, ..}
= (name, val)
parseOpt _ = ("INVALID Option", "INVALID type") parseOpt _ = ("INVALID Option", "INVALID type")
edtResponse :: Config
edtResponse
:: Config
-> Maybe InteractionDataApplicationCommandOptions -> Maybe InteractionDataApplicationCommandOptions
-> IO InteractionResponse -> IO InteractionResponse
edtResponse conf@Config{..} (Just (InteractionDataApplicationCommandOptionsValues opts)) = do
edtResponse conf@Config {..} (Just (InteractionDataApplicationCommandOptionsValues opts))
= do
planning <- getEdt conf parsedOpts planning <- getEdt conf parsedOpts
return $ interactionResponseBasic planning return $ interactionResponseBasic planning
where where
parsedOpts :: Map.Map T.Text T.Text parsedOpts :: Map.Map T.Text T.Text
parsedOpts = Map.fromList $ map parseOpt opts parsedOpts = Map.fromList $ map parseOpt opts
edtResponse _ _ =
return $ interactionResponseBasic
edtResponse _ _ = return $ interactionResponseBasic
"The edt command has mandatory params yet you managed not to give any, WOW" "The edt command has mandatory params yet you managed not to give any, WOW"
remindCommand :: Maybe CreateApplicationCommand remindCommand :: Maybe CreateApplicationCommand
remindCommand = remindCommand =
createApplicationCommandChatInput "remind" "reminds you of something later on" createApplicationCommandChatInput "remind" "reminds you of something later on"
>>=
\cac ->
return
$ cac
>>= \cac -> return $ cac
{ createApplicationCommandOptions = { createApplicationCommandOptions =
Just
$ ApplicationCommandOptionsValues
[ ApplicationCommandOptionValueString "delay" "delay" True (Left False)
, ApplicationCommandOptionValueString "message" "message" True (Left False)
Just $ ApplicationCommandOptionsValues
[ ApplicationCommandOptionValueString "delay"
"delay"
True
(Left False)
, ApplicationCommandOptionValueString "message"
"message"
True
(Left False)
] ]
} }
data Remind = Remind { rmdWhen :: UTCTime
, rmdWhat :: T.Text
, rmdWhere :: Snowflake
, rmdWho :: Snowflake
}
deriving (Read, Show, Eq)
remindResponse :: Maybe InteractionDataApplicationCommandOptions
remindResponse
:: Maybe InteractionDataApplicationCommandOptions
-> EventSystem -> EventSystem
-> ChannelId -> ChannelId
-> MemberOrUser -> MemberOrUser
-> DiscordHandler InteractionResponse -> DiscordHandler InteractionResponse
remindResponse (Just (InteractionDataApplicationCommandOptionsValues opts)) evts ch mou = do
let userid = case mou of
MemberOrUser (Left GuildMember{memberUser = Just User{userId = uid}}) -> uid
MemberOrUser (Right User{userId = uid}) -> uid
remindResponse (Just (InteractionDataApplicationCommandOptionsValues opts)) evts ch mou
= do
let
userid = case mou of
MemberOrUser (Left GuildMember { memberUser = Just User { userId = uid } })
-> uid
MemberOrUser (Right User { userId = uid }) -> uid
_ -> error "Couldnt get user id" _ -> error "Couldnt get user id"
let d = delay' let d = delay'
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let remindDateTime =
case T.last d of
's' -> addUTCTime ( fromInteger
$ read
$ init
$ T.unpack d
) now
'm' -> addUTCTime ( (*60)
$ fromInteger
$ read
$ init
$ T.unpack d
) now
'h' -> addUTCTime ( (*3600)
$ fromInteger
$ read
$ init
$ T.unpack d
) now
'd' -> addUTCTime ( (*86400)
$ fromInteger
$ read
$ init
$ T.unpack d
) now
let
remindDateTime = case T.last d of
's' -> addUTCTime (fromInteger $ read $ init $ T.unpack d) now
'm' -> addUTCTime ((* 60) $ fromInteger $ read $ init $ T.unpack d) now
'h' ->
addUTCTime ((* 3600) $ fromInteger $ read $ init $ T.unpack d) now
'd' ->
addUTCTime ((* 86400) $ fromInteger $ read $ init $ T.unpack d) now
_ -> now _ -> now
if remindDateTime /= now if remindDateTime /= now
then
( do
withRunInIO $ \runInIO ->
addEvent evts remindDateTime
( do
runInIO ( restCall
$ CreateMessage ch
$ "<@"
`T.append` T.pack (show userid)
`T.append` "> **Reminder**\n"
`T.append` message
)
return ()
)
liftIO $ appendFile "reminds.data" $ show (Remind remindDateTime message ch userid) ++ "\n"
then do
let rmd = Remind { rmdUser = userid
, rmdChannel = ch
, rmdMessage = message
, rmdDatetime = remindDateTime
}
scheduleRemind evts rmd
liftIO $ registerRemind rmd
return return
$ interactionResponseBasic $ interactionResponseBasic
$ "Reminder registered sucessfully for " $ "Reminder registered sucessfully for "
`T.append` T.pack (show remindDateTime) `T.append` T.pack (show remindDateTime)
)
else
return $ interactionResponseBasic "couldn't parse your delay :/"
else return $ interactionResponseBasic "couldn't parse your delay :/"
where where
parsedOpts = Map.fromList $ map parseOpt opts parsedOpts = Map.fromList $ map parseOpt opts
delay' = delay' =
fromMaybe (error "delay must exist wtf")
$ Map.lookup "delay" parsedOpts
message =
fromMaybe (error "message must exist, wtf")
fromMaybe (error "delay must exist wtf") $ Map.lookup "delay" parsedOpts
message = fromMaybe (error "message must exist, wtf")
$ Map.lookup "message" parsedOpts $ Map.lookup "message" parsedOpts
remindResponse _ _ _ _= return $ interactionResponseBasic
remindResponse _ _ _ _ =
return
$ interactionResponseBasic
"The remind command has mandatory params, yet you managed not to give any, WOW" "The remind command has mandatory params, yet you managed not to give any, WOW"
groupCommand :: Config -> Maybe CreateApplicationCommand groupCommand :: Config -> Maybe CreateApplicationCommand
groupCommand c = groupCommand c =
createApplicationCommandChatInput "group" "grab your group"
>>=
\cac ->
return
$ cac
{ createApplicationCommandOptions =
Just
$ ApplicationCommandOptionsValues
createApplicationCommandChatInput "group" "grab your group" >>= \cac ->
return $ cac
{ createApplicationCommandOptions = Just $ ApplicationCommandOptionsValues
[ ApplicationCommandOptionValueString [ ApplicationCommandOptionValueString
"group" "group"
"Your group" "Your group"
@ -215,19 +177,19 @@ groupCommand c =
] ]
} }
groupResponse :: Config
groupResponse
:: Config
-> MemberOrUser -> MemberOrUser
-> GuildId -> GuildId
-> Maybe InteractionDataApplicationCommandOptions -> Maybe InteractionDataApplicationCommandOptions
-> DiscordHandler InteractionResponse -> DiscordHandler InteractionResponse
groupResponse c
mou
gid
(Just (InteractionDataApplicationCommandOptionsValues opts)) =
do
let uid = case mou of
MemberOrUser (Left GuildMember{memberUser = Just User{userId = uid}}) -> uid
MemberOrUser (Right User{userId = uid}) -> uid
groupResponse c mou gid (Just (InteractionDataApplicationCommandOptionsValues opts))
= do
let
uid = case mou of
MemberOrUser (Left GuildMember { memberUser = Just User { userId = uid } })
-> uid
MemberOrUser (Right User { userId = uid }) -> uid
_ -> -1 _ -> -1
let rid = let rid =
groupRole groupRole
@ -235,27 +197,28 @@ groupResponse c
$ Map.lookup group $ Map.lookup group
$ configGroups c $ configGroups c
restCall $ AddGuildMemberRole gid uid rid restCall $ AddGuildMemberRole gid uid rid
return $ interactionResponseBasic $
"You are now part of group " `T.append` group
return
$ interactionResponseBasic
$ "You are now part of group "
`T.append` group
where where
group = group =
fromMaybe (error "required option") fromMaybe (error "required option")
$ Map.lookup "group" $ Map.lookup "group"
$ Map.fromList $ Map.fromList
$ map parseOpt opts $ map parseOpt opts
groupResponse _ _ _ _ = groupResponse _ _ _ _ =
return $ interactionResponseBasic
return
$ interactionResponseBasic
"the group command has mandatory params, yet you managed not to give any, WOW" "the group command has mandatory params, yet you managed not to give any, WOW"
helpCommand :: Maybe CreateApplicationCommand helpCommand :: Maybe CreateApplicationCommand
helpCommand =
createApplicationCommandChatInput
"help"
"help"
helpCommand = createApplicationCommandChatInput "help" "help"
helpResponse :: IO InteractionResponse helpResponse :: IO InteractionResponse
helpResponse = return . interactionResponseBasic
helpResponse =
return
. interactionResponseBasic
$ "**__Help for Bot IUT__**\n\n" $ "**__Help for Bot IUT__**\n\n"
`T.append` "`/help` shows this help message\n" `T.append` "`/help` shows this help message\n"
`T.append` "`/group <group>` join a group\n" `T.append` "`/group <group>` join a group\n"

136
app/Commands/EDT.hs
View File

@ -3,47 +3,49 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} {-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-}
module Commands.EDT (getEdt) where
module Commands.EDT
( getEdt
) where
import Conf ( Config(..)
, Group(..)
)
import Control.Monad.IO.Class ( MonadIO
, liftIO
)
import qualified Data.Array as Ar
import qualified Data.CaseInsensitive as CI
import Data.List ( sortOn )
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import qualified Text.ICalendar.Parser as IP
import qualified Text.ICalendar.Types as IT
import Data.Maybe ( fromMaybe )
import qualified Data.Text as TS import qualified Data.Text as TS
import qualified Data.Text.Lazy.Encoding as TE
import qualified Data.CaseInsensitive as CI
import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy as T
import qualified Text.URI as Uri
import qualified Network.HTTP.Simple as HTTP
import Conf ( Group(..), Config(..) )
import Data.Maybe ( fromMaybe )
import Control.Monad.IO.Class ( MonadIO, liftIO )
import qualified Data.Text.Lazy.Encoding as TE
import qualified Data.Time as DT import qualified Data.Time as DT
import qualified Data.Time.Calendar.Easter as DT import qualified Data.Time.Calendar.Easter as DT
import Data.List ( sortOn )
import qualified Network.HTTP.Simple as HTTP
import qualified Text.ICalendar.Parser as IP
import qualified Text.ICalendar.Types as IT
import Text.Printf ( printf ) import Text.Printf ( printf )
import qualified Text.Regex.PCRE as Re import qualified Text.Regex.PCRE as Re
import qualified Data.Array as Ar
import qualified Text.URI as Uri
getEdt ::Config
-> Map.Map TS.Text TS.Text
-> IO TS.Text
getEdt conf@Config{..} opts = do
getEdt :: Config -> Map.Map TS.Text TS.Text -> IO TS.Text
getEdt conf@Config {..} opts = do
cal_req <- HTTP.httpLBS req cal_req <- HTTP.httpLBS req
let cal = IP.parseICalendar (IP.DecodingFunctions
TE.decodeUtf8
(CI.mk . TE.decodeUtf8)
) (TS.unpack group) (HTTP.getResponseBody cal_req)
dates <-readDate date
tz <- DT.getTimeZone
$ DT.UTCTime (head dates)
$ DT.secondsToDiffTime 43200
let
message =
case cal of
let cal = IP.parseICalendar
(IP.DecodingFunctions TE.decodeUtf8 (CI.mk . TE.decodeUtf8))
(TS.unpack group)
(HTTP.getResponseBody cal_req)
dates <- readDate date
tz <- DT.getTimeZone $ DT.UTCTime (head dates) $ DT.secondsToDiffTime 43200
let message = case cal of
Left _ -> "I don't know this group, alternatively ADE doesn't work" Left _ -> "I don't know this group, alternatively ADE doesn't work"
Right (vcal@IT.VCalendar{IT.vcEvents = evm}:_, _) ->
TS.unlines . map (\d ->
if not (null (ev d)) then
Right (vcal@IT.VCalendar { IT.vcEvents = evm } : _, _) ->
TS.unlines
. map
(\d -> if not (null (ev d))
then
"**" "**"
`TS.append` TS.pack (show d) `TS.append` TS.pack (show d)
`TS.append` "**\n" `TS.append` "**\n"
@ -54,11 +56,7 @@ getEdt conf@Config{..} opts = do
where where
ev :: DT.Day -> [IT.VEvent] ev :: DT.Day -> [IT.VEvent]
ev d = ev d =
sortOn IT.veDTStart
. filter (inDate d)
. map snd
. Map.toList
$ evm
sortOn IT.veDTStart . filter (inDate d) . map snd . Map.toList $ evm
_ -> "An unexpected error has occured" _ -> "An unexpected error has occured"
return message return message
where where
@ -87,27 +85,21 @@ readDate dtT = do
return $ case TS.unpack dtT of return $ case TS.unpack dtT of
"today" -> [today] "today" -> [today]
"tomorrow" -> [DT.addDays 1 today] "tomorrow" -> [DT.addDays 1 today]
"week" -> map (`DT.addDays` lastSunday) [1..7] where
"week" -> map (`DT.addDays` lastSunday) [1 .. 7] where
lastweek :: DT.Day lastweek :: DT.Day
lastweek = DT.addDays (-6) today lastweek = DT.addDays (-6) today
lastSunday = DT.sundayAfter lastweek lastSunday = DT.sundayAfter lastweek
[dd, du, '/', md, mu, '/', yk, yh, yd, yu] -> [dd, du, '/', md, mu, '/', yk, yh, yd, yu] ->
[ DT.fromGregorian
(read [yk,yh,yd,yu])
(read [md,mu])
(read [dd,du])
]
[DT.fromGregorian (read [yk, yh, yd, yu]) (read [md, mu]) (read [dd, du])]
_ -> [today] _ -> [today]
inDate :: DT.Day -> IT.VEvent -> Bool inDate :: DT.Day -> IT.VEvent -> Bool
inDate date ev@IT.VEvent{veDTStart = mdts} = evDay == date
inDate date ev@IT.VEvent { veDTStart = mdts } = evDay == date
where where
evDay :: DT.Day evDay :: DT.Day
evDay = case mdts of evDay = case mdts of
Just dts ->
case dts of
IT.DTStartDateTime dt _ ->
case dt of
Just dts -> case dts of
IT.DTStartDateTime dt _ -> case dt of
IT.FloatingDateTime lt -> DT.localDay lt IT.FloatingDateTime lt -> DT.localDay lt
IT.UTCDateTime ut -> DT.utctDay ut IT.UTCDateTime ut -> DT.utctDay ut
IT.ZonedDateTime lt _ -> DT.localDay lt IT.ZonedDateTime lt _ -> DT.localDay lt
@ -118,56 +110,46 @@ renderEvents :: DT.TimeZone -> [IT.VEvent] -> TS.Text
renderEvents tz = TS.unlines . map renderEvent renderEvents tz = TS.unlines . map renderEvent
where where
renderEvent :: IT.VEvent -> TS.Text renderEvent :: IT.VEvent -> TS.Text
renderEvent ev =
TS.pack
$ printf
renderEvent ev = TS.pack $ printf
"*%02d:%02d → %02d:%02d* : **%s** with **%s** in **%s**" "*%02d:%02d → %02d:%02d* : **%s** with **%s** in **%s**"
(DT.todHour $ startT ev) (DT.todMin $ startT ev)
(DT.todHour $ endT ev) (DT.todMin $ endT ev)
(summary ev) (teacher ev) (room ev)
(DT.todHour $ startT ev)
(DT.todMin $ startT ev)
(DT.todHour $ endT ev)
(DT.todMin $ endT ev)
(summary ev)
(teacher ev)
(room ev)
startT :: IT.VEvent -> DT.TimeOfDay startT :: IT.VEvent -> DT.TimeOfDay
startT IT.VEvent{veDTStart = Just (IT.DTStartDateTime dt _)} = case dt of
startT IT.VEvent { veDTStart = Just (IT.DTStartDateTime dt _) } = case dt of
IT.FloatingDateTime lt -> DT.localTimeOfDay lt IT.FloatingDateTime lt -> DT.localTimeOfDay lt
IT.UTCDateTime ut -> IT.UTCDateTime ut ->
snd
. DT.utcToLocalTimeOfDay tz
. DT.timeToTimeOfDay
$ DT.utctDayTime ut
snd . DT.utcToLocalTimeOfDay tz . DT.timeToTimeOfDay $ DT.utctDayTime ut
IT.ZonedDateTime lt _ -> DT.localTimeOfDay lt IT.ZonedDateTime lt _ -> DT.localTimeOfDay lt
startT _ = DT.TimeOfDay 0 0 0 startT _ = DT.TimeOfDay 0 0 0
endT :: IT.VEvent -> DT.TimeOfDay endT :: IT.VEvent -> DT.TimeOfDay
endT IT.VEvent{veDTEndDuration = Just (Left (IT.DTEndDateTime dt _))} =
endT IT.VEvent { veDTEndDuration = Just (Left (IT.DTEndDateTime dt _)) } =
case dt of case dt of
IT.FloatingDateTime lt -> DT.localTimeOfDay lt IT.FloatingDateTime lt -> DT.localTimeOfDay lt
IT.UTCDateTime ut -> IT.UTCDateTime ut ->
snd
. DT.utcToLocalTimeOfDay tz
. DT.timeToTimeOfDay
$ DT.utctDayTime ut
snd . DT.utcToLocalTimeOfDay tz . DT.timeToTimeOfDay $ DT.utctDayTime ut
IT.ZonedDateTime lt txt -> DT.localTimeOfDay lt IT.ZonedDateTime lt txt -> DT.localTimeOfDay lt
endT _ = DT.TimeOfDay 0 0 0 endT _ = DT.TimeOfDay 0 0 0
summary IT.VEvent{veSummary = Just IT.Summary{summaryValue = x}} = x
summary IT.VEvent { veSummary = Just IT.Summary { summaryValue = x } } = x
summary _ = "Unknown" summary _ = "Unknown"
room IT.VEvent{veLocation = Just IT.Location{locationValue = x}} = x
room IT.VEvent { veLocation = Just IT.Location { locationValue = x } } = x
room _ = "Unknown" room _ = "Unknown"
teacher :: IT.VEvent -> String teacher :: IT.VEvent -> String
teacher IT.VEvent{veDescription = Just IT.Description{descriptionValue = val}} =
if '\n' `elem` teacher' then
"Unknown"
else
teacher'
teacher IT.VEvent { veDescription = Just IT.Description { descriptionValue = val } }
= if '\n' `elem` teacher' then "Unknown" else teacher'
where where
teacher' =
if uncurry (>) (Ar.bounds marray) then
"Unknown"
else
fst . last . Ar.elems $ marray
teacher' = if uncurry (>) (Ar.bounds marray)
then "Unknown"
else fst . last . Ar.elems $ marray
marray = if null matches then Ar.listArray (1,0) [] else head matches
marray = if null matches then Ar.listArray (1, 0) [] else head matches
matches = Re.matchAllText teacherRe $ T.unpack val matches = Re.matchAllText teacherRe $ T.unpack val
teacher _ = "Unknown" teacher _ = "Unknown"
teacherRe = Re.makeRegexOpts
Re.compMultiline
teacherRe = Re.makeRegexOpts Re.compMultiline
Re.execBlank Re.execBlank
("^\\n\\n.+\\n(.+)\\n" :: String) ("^\\n\\n.+\\n(.+)\\n" :: String)

78
app/Commands/Reminds.hs
View File

@ -0,0 +1,78 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- | Manages all about reminders
module Commands.Reminds where
import Conf ( )
import qualified Control.Event as E
import Control.Monad ( void )
import Control.Monad.IO.Unlift ( MonadUnliftIO(withRunInIO) )
import Data.Convertible ( ConvertResult
, Convertible(safeConvert)
)
import qualified Data.Text as T
import Data.Time ( UTCTime )
import qualified Database.HDBC as DB
import qualified Database.HDBC.Sqlite3 as DB.SQ3
import Discord ( DiscordHandler
, restCall
)
import Discord.Interactions ( )
import Discord.Requests ( ChannelRequest(CreateMessage)
)
import Discord.Types ( Snowflake(..) )
data Remind = Remind
{ rmdUser :: Snowflake
, rmdChannel :: Snowflake
, rmdMessage :: T.Text
, rmdDatetime :: UTCTime
}
instance Convertible Snowflake DB.SqlValue where
safeConvert (Snowflake v) = safeConvert v
setupRemindDb :: IO ()
setupRemindDb = do
conn <- DB.SQ3.connectSqlite3 "db.sqlite3"
DB.run
conn
"CREATE TABLE IF NOT EXISTS reminds\
\(id INTEGER PRIMARY KEY AUTOINCREMENT UNIQUE NOT NULL,\
\user INTEGER NOT NULL,\
\channel INTEGER NOT NULL,\
\message INTEGER NOT NULL,\
\dt DATETIME);"
[]
DB.commit conn
DB.disconnect conn
scheduleRemind :: E.EventSystem -> Remind -> DiscordHandler ()
scheduleRemind ev Remind {..} = do
void $ withRunInIO $ \runInIo ->
E.addEvent ev rmdDatetime
$ void
$ runInIo
$ restCall
$ CreateMessage rmdChannel
$ "<@"
`T.append` T.pack (show rmdUser)
`T.append` "> **Reminder**\n"
`T.append` rmdMessage
registerRemind :: Remind -> IO ()
registerRemind Remind {..} = do
conn <- DB.SQ3.connectSqlite3 "db.sqlite3"
DB.run
conn
"INSERT INTO reminds(user, channel, message, dt)\
\VALUES (?,?,?,?)"
[ DB.toSql rmdUser
, DB.toSql rmdChannel
, DB.toSql rmdMessage
, DB.toSql rmdDatetime
]
DB.commit conn
DB.disconnect conn

81
app/Conf.hs
View File

@ -1,28 +1,34 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
module Conf ( Group(..) , Config(..) , readConfig ) where
module Conf
( Group(..)
, Config(..)
, readConfig
) where
import Control.Monad ( mzero )
import qualified Data.HashMap.Strict as H
import qualified Data.Map.Strict as Map
import Data.Maybe ( fromMaybe )
import qualified Data.Text as T import qualified Data.Text as T
import qualified Discord.Types as D
import Data.Yaml ( Object
import Data.Yaml ( (.:)
, FromJSON
, Object
, Parser
, Value(Number, Object, String)
, decodeFileThrow , decodeFileThrow
, (.:)
, parseJSON
, parseMaybe , parseMaybe
, Parser
, withObject , withObject
, FromJSON
, Value (Object, Number, String)
, parseJSON
) )
import qualified Data.HashMap.Strict as H
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Control.Monad (mzero)
import qualified Discord.Types as D
import Data.Word (Word64)
import Data.Scientific (Scientific, floatingOrInteger)
import Data.Either (fromRight)
import Data.Either ( fromRight )
import Data.Scientific ( Scientific
, floatingOrInteger
)
import Data.Word ( Word64 )
data Group = Group data Group = Group
{ groupChannel :: D.Snowflake { groupChannel :: D.Snowflake
@ -37,13 +43,12 @@ hmToGroup hm = Group
. valueNum "channel" . valueNum "channel"
. errorRequired "channel" . errorRequired "channel"
$ H.lookup "channel" hm $ H.lookup "channel" hm
, groupRole = scitosno
. valueNum "role"
. errorRequired "role"
$ H.lookup "role" hm
, groupAde = valueText "edturl"
. errorRequired "edturl"
$ H.lookup "edturl" hm
, groupRole = scitosno . valueNum "role" . errorRequired "role" $ H.lookup
"role"
hm
, groupAde = valueText "edturl" . errorRequired "edturl" $ H.lookup
"edturl"
hm
} }
data Config = Config data Config = Config
@ -57,12 +62,11 @@ data Config = Config
readConfig :: FilePath -> IO Config readConfig :: FilePath -> IO Config
readConfig fp = do readConfig fp = do
conf_yml <- decodeFileThrow fp :: IO Object conf_yml <- decodeFileThrow fp :: IO Object
-- print conf_yml
-- print conf_yml
return $ ymlToConf conf_yml return $ ymlToConf conf_yml
ymlToConf :: Object -> Config ymlToConf :: Object -> Config
ymlToConf v = Config
{ configServer = server
ymlToConf v = Config { configServer = server
, configGroups = groups , configGroups = groups
, configAutoEDTCronDay = autoEdtCronDay , configAutoEDTCronDay = autoEdtCronDay
, configAutoEDTCronWeek = autoEdtCronWeek , configAutoEDTCronWeek = autoEdtCronWeek
@ -72,22 +76,26 @@ ymlToConf v = Config
server = scitosno $ valueNum "server" server' server = scitosno $ valueNum "server" server'
groups = parseGroups groupsObject groups = parseGroups groupsObject
groupsObject = H.lookup "groups" v groupsObject = H.lookup "groups" v
parseGroups (Just (Object o)) = let groupList' :: H.HashMap T.Text Group
groupList' = fmap ( hmToGroup
parseGroups (Just (Object o)) =
let groupList' :: H.HashMap T.Text Group
groupList' = fmap
( hmToGroup
. (\case . (\case
Object u -> u Object u -> u
_ -> error "groups are objects")
) o
_ -> error "groups are objects"
)
)
o
in Map.fromList $ H.toList groupList' in Map.fromList $ H.toList groupList'
parseGroups _ = error "Wrong format for groups" parseGroups _ = error "Wrong format for groups"
autoEdtCronDay = autoEdtCronDay =
valueText "autoEdtCronDay"
$ fromMaybe "0 15 * * 0-4"
$ H.lookup "autoEdtCronDay" v
valueText "autoEdtCronDay" $ fromMaybe "0 15 * * 0-4" $ H.lookup
"autoEdtCronDay"
v
autoEdtCronWeek = autoEdtCronWeek =
valueText "autoEdtCronWeek"
$ fromMaybe "30 9 * * 0"
$ H.lookup "autoEdtCronWeek" v
valueText "autoEdtCronWeek" $ fromMaybe "30 9 * * 0" $ H.lookup
"autoEdtCronWeek"
v
errorRequired :: [Char] -> Maybe a -> a errorRequired :: [Char] -> Maybe a -> a
@ -100,7 +108,8 @@ valueNum _ (Number n) = n
valueNum name _ = error $ name ++ " should be an integer" valueNum name _ = error $ name ++ " should be an integer"
scitosno :: Scientific -> D.Snowflake scitosno :: Scientific -> D.Snowflake
scitosno = D.Snowflake
scitosno =
D.Snowflake
. (fromInteger :: Integer -> Word64) . (fromInteger :: Integer -> Word64)
. fromRight (error "Cant read that as an int") . fromRight (error "Cant read that as an int")
. floatingOrInteger . floatingOrInteger

202
app/Main.hs
View File

@ -4,41 +4,66 @@
module Main where module Main where
import Control.Monad (when, void)
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 as T
import qualified Data.Text.IO as TIO import qualified Data.Text.IO as TIO
import Control.Monad.IO.Unlift (toIO, liftIO, withRunInIO)
import Discord ( def, restCall
, runDiscord, sendCommand
, DiscordHandler
import Data.Time ( getCurrentTime )
import qualified Database.HDBC as DB
import qualified Database.HDBC.Sqlite3 as DB.SQ3
import Discord ( DiscordHandler
, RunDiscordOpts(..) , RunDiscordOpts(..)
, def
, restCall
, runDiscord
, sendCommand
) )
import Discord.Types ( Event(..), PartialApplication(..)
, GatewaySendable(..)
, UpdateStatusOpts(..)
, UpdateStatusType(..)
, Activity(..), ActivityType(..)
)
import Discord.Interactions ( interactionResponseBasic
, Interaction(..)
import Discord.Interactions ( Interaction(..)
, InteractionDataApplicationCommand(..) , InteractionDataApplicationCommand(..)
, interactionResponseBasic
) )
import qualified Discord.Requests as R import qualified Discord.Requests as R
import Commands ( edtResponse, edtCommand
, pingResponse, pingCommand
, remindResponse, remindCommand
, groupCommand, groupResponse
, helpCommand, helpResponse
, Remind(..)
import Discord.Types ( Activity(..)
, ActivityType(..)
, Event(..)
, GatewaySendable(..)
, PartialApplication(..)
, Snowflake(Snowflake)
, UpdateStatusOpts(..)
, UpdateStatusType(..)
) )
import Conf ( Config(..), Group(..), readConfig )
import qualified System.Cron.Schedule as Cron 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
import UnliftIO.Directory (doesFileExist, removeFile)
import Data.Time (getCurrentTime)
import UnliftIO.Directory ( doesFileExist
, removeFile
)
main :: IO () main :: IO ()
main = do main = do
@ -46,20 +71,18 @@ main = do
conf <- readConfig "./conf.yaml" conf <- readConfig "./conf.yaml"
eventSystem <- E.initEventSystem eventSystem <- E.initEventSystem
err <- runDiscord $ def { discordToken = tok
err <- runDiscord $ def
{ discordToken = tok
, discordOnStart = onDiscordStart conf eventSystem , discordOnStart = onDiscordStart conf eventSystem
, discordOnEnd = liftIO $ putStrLn "Ended" , discordOnEnd = liftIO $ putStrLn "Ended"
, discordOnEvent = onDiscordEvent conf eventSystem , discordOnEvent = onDiscordEvent conf eventSystem
, discordOnLog =
\s -> TIO.putStrLn s >> TIO.putStrLn ""
, discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn ""
} }
TIO.putStrLn err TIO.putStrLn err
onDiscordStart :: Config -> E.EventSystem -> DiscordHandler () onDiscordStart :: Config -> E.EventSystem -> DiscordHandler ()
onDiscordStart conf eventSystem = do
let
activity :: Activity
onDiscordStart conf@Config {..} eventSystem = do
let activity :: Activity
activity = def { activityName = "Doing stuff" activity = def { activityName = "Doing stuff"
, activityType = ActivityTypeGame , activityType = ActivityTypeGame
, activityUrl = Nothing , activityUrl = Nothing
@ -71,41 +94,50 @@ onDiscordStart conf eventSystem = do
, updateStatusOptsAFK = False , updateStatusOptsAFK = False
} }
sendCommand (UpdateStatus opts) sendCommand (UpdateStatus opts)
remindDataExist <- liftIO $ doesFileExist "reminds.data"
when remindDataExist $ do
remindfile <- liftIO $ readFile "reminds.data"
let reminddata :: [Remind]
reminddata = map read $ lines remindfile
now <- liftIO getCurrentTime
liftIO $ removeFile "reminds.data"
mapM_ (\r -> do
withRunInIO $ \runInIO ->
if now > rmdWhen r then
void $ E.addEvent eventSystem (rmdWhen r)
( do
runInIO ( restCall
$ R.CreateMessage (rmdWhere r)
$ "<@"
`T.append` T.pack (show $rmdWho r)
`T.append` "> **Reminder**\n"
`T.append` rmdWhat r
)
appendFile "reminds.data" $ show r
return ()
)
else
pure ()
) reminddata
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
onDiscordEvent :: Config -> E.EventSystem -> Event -> DiscordHandler ()
onDiscordEvent conf@Config{..} eventSystem (Ready _ _ _ _ _ _ (PartialApplication i _)) = do
mapM_ (maybe ( return () )
( void
. restCall
. R.CreateGuildApplicationCommand i configServer
-- 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 [ pingCommand
, edtCommand conf , edtCommand conf
@ -113,29 +145,9 @@ onDiscordEvent conf@Config{..} eventSystem (Ready _ _ _ _ _ _ (PartialApplicatio
, groupCommand conf , groupCommand conf
, helpCommand , helpCommand
] ]
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
onDiscordEvent conf@Config {..} eventSystem (InteractionCreate InteractionApplicationCommand { interactionDataApplicationCommand = InteractionDataApplicationCommandChatInput { interactionDataApplicationCommandName = name, interactionDataApplicationCommandOptions = opts, ..}, interactionChannelId = Just channel, interactionGuildId = Just guild, interactionUser = user, ..})
= do
response <- responseIO response <- responseIO
void $ restCall void $ restCall
(R.CreateInteractionResponse interactionId interactionToken response) (R.CreateInteractionResponse interactionId interactionToken response)
@ -146,13 +158,15 @@ onDiscordEvent conf@Config{..} eventSystem
"remind" -> remindResponse opts eventSystem channel user "remind" -> remindResponse opts eventSystem channel user
"group" -> groupResponse conf user guild opts "group" -> groupResponse conf user guild opts
"help" -> liftIO helpResponse "help" -> liftIO helpResponse
_ -> return $ interactionResponseBasic $ "Unhandled Command: " `T.append` name
_ ->
return $ interactionResponseBasic $ "Unhandled Command: " `T.append` name
onDiscordEvent _ _ _ = return () 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 )]
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 liftIO
$ TIO.putStrLn $ TIO.putStrLn
$ "Putting out time table for group " $ "Putting out time table for group "
@ -163,5 +177,5 @@ pushgroupedt conf@Config{..} day glist = do
`T.append` edt `T.append` edt
restCall $ R.CreateMessage gc (edt `T.append` "\nAutomatic time table") restCall $ R.CreateMessage gc (edt `T.append` "\nAutomatic time table")
return () return ()
) glist
)
glist

4
botiut.cabal
View File

@ -27,6 +27,7 @@ executable botiut
other-modules: other-modules:
Commands Commands
, Commands.EDT , Commands.EDT
, Commands.Reminds
, Conf , Conf
build-depends: build-depends:
@ -50,5 +51,8 @@ executable botiut
, unliftio , unliftio
, mtl , mtl
, control-event , control-event
, HDBC
, HDBC-sqlite3
, convertible
hs-source-dirs: app hs-source-dirs: app
default-language: Haskell2010 default-language: Haskell2010

1
stack.yaml
View File

@ -9,6 +9,7 @@ extra-deps:
- mime-0.4.0.2 - mime-0.4.0.2
- discord-haskell-1.12.1 - discord-haskell-1.12.1
- control-event-1.3 - control-event-1.3
- HDBC-sqlite3-2.3.3.1
## My fork of discord-haskell to PR bug fixes and have them before merge ## My fork of discord-haskell to PR bug fixes and have them before merge
# - github: Annwan/discord-haskell # - github: Annwan/discord-haskell
# commit: <insert pactch commit> # commit: <insert pactch commit>

Write Preview
Loading…
Cancel
Save