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
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 2
      .gitignore
  2. 12
      README.org
  3. 257
      app/Commands.hs
  4. 116
      app/Commands/EDT.hs
  5. 78
      app/Commands/Reminds.hs
  6. 77
      app/Conf.hs
  7. 196
      app/Main.hs
  8. 4
      botiut.cabal
  9. 1
      stack.yaml

2
.gitignore
View File

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

12
README.org
View File

@ -1,9 +1,11 @@
#+title: botiut
#+author: Annwan
#+date: <2022-03-16 Wed>
#+options: h:0 num:nil toc:nil
** TODO List
- [ ] Reminders
- [ ] Room availability
- [ ] Write example configuration
** Setup
@ -22,17 +24,17 @@ stack build
*** 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
- 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
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
working directory.

257
app/Commands.hs
View File

@ -3,52 +3,56 @@
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.IO.Class ( liftIO )
import qualified Data.Map.Strict as Map
import Data.Maybe ( fromMaybe )
import Data.Time ( getCurrentTime, addUTCTime )
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 Commands.EDT ( getEdt )
import Conf ( Config(..), Group(..) )
groupNames :: Config -> [T.Text]
groupNames Config {..} = map fst $ Map.toList configGroups
pingCommand :: Maybe CreateApplicationCommand
pingCommand =
createApplicationCommandChatInput
"ping"
"pong"
pingCommand = createApplicationCommandChatInput "ping" "pong"
pingResponse :: Config -> IO InteractionResponse
pingResponse _ = return $ interactionResponseBasic "Pong"
@ -56,157 +60,115 @@ pingResponse _ = return $ interactionResponseBasic "Pong"
edtCommand :: Config -> Maybe CreateApplicationCommand
edtCommand c =
createApplicationCommandChatInput "edt" "Gets the planning for a group"
>>=
\cac ->
return
$ cac
>>= \cac -> return $ cac
{ createApplicationCommandOptions =
Just
$ ApplicationCommandOptionsValues
Just $ ApplicationCommandOptionsValues
[ ApplicationCommandOptionValueString
"group"
"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
"day"
( "The day(s) for which the planning is requested "
`T.append` "(today, tomorrow, week or DD/MM/YYYY)")
`T.append` "(today, tomorrow, week or DD/MM/YYYY)"
)
False
(Left False)
]
}
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")
edtResponse :: Config
edtResponse
:: Config
-> Maybe InteractionDataApplicationCommandOptions
-> IO InteractionResponse
edtResponse conf@Config{..} (Just (InteractionDataApplicationCommandOptionsValues opts)) = do
edtResponse conf@Config {..} (Just (InteractionDataApplicationCommandOptionsValues opts))
= do
planning <- getEdt conf parsedOpts
return $ interactionResponseBasic planning
where
parsedOpts :: Map.Map T.Text T.Text
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"
remindCommand :: Maybe CreateApplicationCommand
remindCommand =
createApplicationCommandChatInput "remind" "reminds you of something later on"
>>=
\cac ->
return
$ cac
>>= \cac -> return $ cac
{ 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
-> ChannelId
-> MemberOrUser
-> DiscordHandler InteractionResponse
remindResponse (Just (InteractionDataApplicationCommandOptionsValues opts)) evts ch mou = do
let userid = case mou of
MemberOrUser (Left GuildMember{memberUser = Just 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"
let d = delay'
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
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
$ interactionResponseBasic
$ "Reminder registered sucessfully for "
`T.append` T.pack (show remindDateTime)
)
else
return $ interactionResponseBasic "couldn't parse your delay :/"
else return $ interactionResponseBasic "couldn't parse your delay :/"
where
parsedOpts = Map.fromList $ map parseOpt opts
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
remindResponse _ _ _ _= return $ interactionResponseBasic
remindResponse _ _ _ _ =
return
$ interactionResponseBasic
"The remind command has mandatory params, yet you managed not to give any, WOW"
groupCommand :: Config -> Maybe CreateApplicationCommand
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
"group"
"Your group"
@ -215,18 +177,18 @@ groupCommand c =
]
}
groupResponse :: Config
groupResponse
:: Config
-> MemberOrUser
-> GuildId
-> Maybe InteractionDataApplicationCommandOptions
-> DiscordHandler InteractionResponse
groupResponse c
mou
gid
(Just (InteractionDataApplicationCommandOptionsValues opts)) =
do
let uid = case mou of
MemberOrUser (Left GuildMember{memberUser = Just 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
let rid =
@ -235,27 +197,28 @@ groupResponse c
$ Map.lookup group
$ configGroups c
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
group =
fromMaybe (error "required option")
$ Map.lookup "group"
$ Map.fromList
$ map parseOpt opts
groupResponse _ _ _ _ =
return $ interactionResponseBasic
return
$ interactionResponseBasic
"the group command has mandatory params, yet you managed not to give any, WOW"
helpCommand :: Maybe CreateApplicationCommand
helpCommand =
createApplicationCommandChatInput
"help"
"help"
helpCommand = createApplicationCommandChatInput "help" "help"
helpResponse :: IO InteractionResponse
helpResponse = return . interactionResponseBasic
helpResponse =
return
. interactionResponseBasic
$ "**__Help for Bot IUT__**\n\n"
`T.append` "`/help` shows this help message\n"
`T.append` "`/group <group>` join a group\n"

116
app/Commands/EDT.hs
View File

@ -3,47 +3,49 @@
{-# LANGUAGE DataKinds #-}
{-# 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 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.Lazy.Encoding as TE
import qualified Data.CaseInsensitive as CI
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.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 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 :: Config -> Map.Map TS.Text TS.Text -> IO TS.Text
getEdt conf@Config {..} opts = do
cal_req <- HTTP.httpLBS req
let cal = IP.parseICalendar (IP.DecodingFunctions
TE.decodeUtf8
(CI.mk . TE.decodeUtf8)
) (TS.unpack group) (HTTP.getResponseBody cal_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
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"
Right (vcal@IT.VCalendar { IT.vcEvents = evm } : _, _) ->
TS.unlines . map (\d ->
if not (null (ev d)) then
TS.unlines
. map
(\d -> if not (null (ev d))
then
"**"
`TS.append` TS.pack (show d)
`TS.append` "**\n"
@ -54,11 +56,7 @@ getEdt conf@Config{..} opts = do
where
ev :: DT.Day -> [IT.VEvent]
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"
return message
where
@ -92,11 +90,7 @@ readDate dtT = do
lastweek = DT.addDays (-6) today
lastSunday = DT.sundayAfter lastweek
[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]
inDate :: DT.Day -> IT.VEvent -> Bool
@ -104,10 +98,8 @@ inDate date ev@IT.VEvent{veDTStart = mdts} = evDay == date
where
evDay :: DT.Day
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.UTCDateTime ut -> DT.utctDay ut
IT.ZonedDateTime lt _ -> DT.localDay lt
@ -118,22 +110,21 @@ renderEvents :: DT.TimeZone -> [IT.VEvent] -> TS.Text
renderEvents tz = TS.unlines . map renderEvent
where
renderEvent :: IT.VEvent -> TS.Text
renderEvent ev =
TS.pack
$ printf
renderEvent ev = TS.pack $ printf
"*%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 { veDTStart = Just (IT.DTStartDateTime dt _) } = case dt of
IT.FloatingDateTime lt -> DT.localTimeOfDay lt
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
startT _ = DT.TimeOfDay 0 0 0
endT :: IT.VEvent -> DT.TimeOfDay
@ -141,10 +132,7 @@ renderEvents tz = TS.unlines . map renderEvent
case dt of
IT.FloatingDateTime lt -> DT.localTimeOfDay lt
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
endT _ = DT.TimeOfDay 0 0 0
summary IT.VEvent { veSummary = Just IT.Summary { summaryValue = x } } = x
@ -152,22 +140,16 @@ renderEvents tz = TS.unlines . map renderEvent
room IT.VEvent { veLocation = Just IT.Location { locationValue = x } } = x
room _ = "Unknown"
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
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
matches = Re.matchAllText teacherRe $ T.unpack val
teacher _ = "Unknown"
teacherRe = Re.makeRegexOpts
Re.compMultiline
teacherRe = Re.makeRegexOpts Re.compMultiline
Re.execBlank
("^\\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

77
app/Conf.hs
View File

@ -1,28 +1,34 @@
{-# LANGUAGE OverloadedStrings #-}
{-# 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 Discord.Types as D
import Data.Yaml ( Object
import Data.Yaml ( (.:)
, FromJSON
, Object
, Parser
, Value(Number, Object, String)
, decodeFileThrow
, (.:)
, parseJSON
, parseMaybe
, Parser
, 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.Scientific ( Scientific
, floatingOrInteger
)
import Data.Word ( Word64 )
data Group = Group
{ groupChannel :: D.Snowflake
@ -37,13 +43,12 @@ hmToGroup hm = Group
. valueNum "channel"
. errorRequired "channel"
$ 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
@ -61,8 +66,7 @@ readConfig fp = do
return $ ymlToConf conf_yml
ymlToConf :: Object -> Config
ymlToConf v = Config
{ configServer = server
ymlToConf v = Config { configServer = server
, configGroups = groups
, configAutoEDTCronDay = autoEdtCronDay
, configAutoEDTCronWeek = autoEdtCronWeek
@ -72,22 +76,26 @@ ymlToConf v = Config
server = scitosno $ valueNum "server" server'
groups = parseGroups groupsObject
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
Object u -> u
_ -> error "groups are objects")
) o
_ -> error "groups are objects"
)
)
o
in Map.fromList $ H.toList groupList'
parseGroups _ = error "Wrong format for groups"
autoEdtCronDay =
valueText "autoEdtCronDay"
$ fromMaybe "0 15 * * 0-4"
$ H.lookup "autoEdtCronDay" v
valueText "autoEdtCronDay" $ fromMaybe "0 15 * * 0-4" $ H.lookup
"autoEdtCronDay"
v
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
@ -100,7 +108,8 @@ valueNum _ (Number n) = n
valueNum name _ = error $ name ++ " should be an integer"
scitosno :: Scientific -> D.Snowflake
scitosno = D.Snowflake
scitosno =
D.Snowflake
. (fromInteger :: Integer -> Word64)
. fromRight (error "Cant read that as an int")
. floatingOrInteger

196
app/Main.hs
View File

@ -4,41 +4,66 @@
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.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(..)
, def
, restCall
, runDiscord
, sendCommand
)
import Discord.Types ( Event(..), PartialApplication(..)
, GatewaySendable(..)
, UpdateStatusOpts(..)
, UpdateStatusType(..)
, Activity(..), ActivityType(..)
)
import Discord.Interactions ( interactionResponseBasic
, Interaction(..)
import Discord.Interactions ( Interaction(..)
, InteractionDataApplicationCommand(..)
, interactionResponseBasic
)
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 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 = do
@ -46,20 +71,18 @@ main = do
conf <- readConfig "./conf.yaml"
eventSystem <- E.initEventSystem
err <- runDiscord $ def { discordToken = tok
err <- runDiscord $ def
{ discordToken = tok
, discordOnStart = onDiscordStart conf eventSystem
, discordOnEnd = liftIO $ putStrLn "Ended"
, discordOnEvent = onDiscordEvent conf eventSystem
, discordOnLog =
\s -> TIO.putStrLn s >> TIO.putStrLn ""
, discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn ""
}
TIO.putStrLn err
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"
, activityType = ActivityTypeGame
, activityUrl = Nothing
@ -71,41 +94,50 @@ onDiscordStart conf eventSystem = do
, updateStatusOptsAFK = False
}
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
, edtCommand conf
@ -113,29 +145,9 @@ onDiscordEvent conf@Config{..} eventSystem (Ready _ _ _ _ _ _ (PartialApplicatio
, groupCommand conf
, 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
void $ restCall
(R.CreateInteractionResponse interactionId interactionToken response)
@ -146,12 +158,14 @@ onDiscordEvent conf@Config{..} eventSystem
"remind" -> remindResponse opts eventSystem channel user
"group" -> groupResponse conf user guild opts
"help" -> liftIO helpResponse
_ -> return $ interactionResponseBasic $ "Unhandled Command: " `T.append` name
_ ->
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
mapM_
(\(gn, Group { groupChannel = gc }) -> do
edt <- liftIO $ getEdt conf $ Map.fromList [("group", gn), ("day", day)]
liftIO
$ TIO.putStrLn
@ -163,5 +177,5 @@ pushgroupedt conf@Config{..} day glist = do
`T.append` edt
restCall $ R.CreateMessage gc (edt `T.append` "\nAutomatic time table")
return ()
) glist
)
glist

4
botiut.cabal
View File

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

1
stack.yaml
View File

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

Write Preview
Loading…
Cancel
Save