Antoine COMBET
3 years ago
7 changed files with 620 additions and 104 deletions
-
278app/Commands.hs
-
0app/Commands.hsCommands.hs
-
174app/Commands/EDT.hs
-
106app/Conf.hs
-
134app/Main.hs
-
17botiut.cabal
-
15stack.yaml
@ -1,5 +1,171 @@ |
|||
module Commands.EDT where |
|||
{-# LANGUAGE RecordWildCards #-} |
|||
{-# LANGUAGE OverloadedStrings #-} |
|||
{-# LANGUAGE DataKinds #-} |
|||
{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} |
|||
|
|||
import qualified Data.Map.Strict as Map |
|||
import qualified Text.ICalendar.Parser as IP |
|||
import qualified Text.ICalendar.Types as IT |
|||
module Commands.EDT (getEdt) where |
|||
|
|||
import qualified Data.Map.Strict as Map |
|||
import qualified Text.ICalendar.Parser as IP |
|||
import qualified Text.ICalendar.Types as IT |
|||
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.Time as DT |
|||
import qualified Data.Time.Calendar.Easter as DT |
|||
import Data.List ( sortOn ) |
|||
import Text.Printf ( printf ) |
|||
import qualified Text.Regex.PCRE as Re |
|||
import qualified Data.Array as Ar |
|||
|
|||
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) |
|||
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" |
|||
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` "**\n" |
|||
`TS.append` renderEvents tz (ev d) |
|||
else "" |
|||
) |
|||
$ dates |
|||
where |
|||
ev :: DT.Day -> [IT.VEvent] |
|||
ev d = |
|||
sortOn IT.veDTStart |
|||
. filter (inDate d) |
|||
. map snd |
|||
. Map.toList |
|||
$ evm |
|||
_ -> "An unexpected error has occured" |
|||
return message |
|||
where |
|||
group :: TS.Text |
|||
group = fromMaybe "" $ Map.lookup "group" opts |
|||
date :: TS.Text |
|||
date = fromMaybe "week" $ Map.lookup "day" opts |
|||
url :: String |
|||
url = |
|||
TS.unpack |
|||
. groupAde |
|||
. fromMaybe (Group 0 0 dummyAddress) |
|||
. (`Map.lookup` configGroups) |
|||
. fromMaybe "" |
|||
. Map.lookup "group" |
|||
$ opts |
|||
req = HTTP.parseRequest_ url |
|||
|
|||
-- not a place where you'll find valid ICS so we know the group must be wrong |
|||
dummyAddress :: TS.Text |
|||
dummyAddress = "https://example.com" |
|||
|
|||
readDate :: TS.Text -> IO [DT.Day] |
|||
readDate dtT = do |
|||
DT.UTCTime today _ <- DT.getCurrentTime |
|||
return $ case TS.unpack dtT of |
|||
"today" -> [today] |
|||
"tomorrow" -> [DT.addDays 1 today] |
|||
"week" -> map (`DT.addDays` lastSunday) [1..7] where |
|||
lastweek :: DT.Day |
|||
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]) |
|||
] |
|||
_ -> [today] |
|||
|
|||
inDate :: DT.Day -> IT.VEvent -> Bool |
|||
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 |
|||
IT.FloatingDateTime lt -> DT.localDay lt |
|||
IT.UTCDateTime ut -> DT.utctDay ut |
|||
IT.ZonedDateTime lt _ -> DT.localDay lt |
|||
IT.DTStartDate da _ -> IT.dateValue da |
|||
Nothing -> DT.fromGregorian 0 0 0 |
|||
|
|||
renderEvents :: DT.TimeZone -> [IT.VEvent] -> TS.Text |
|||
renderEvents tz = TS.unlines . map renderEvent |
|||
where |
|||
renderEvent :: IT.VEvent -> TS.Text |
|||
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) |
|||
|
|||
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 |
|||
IT.ZonedDateTime lt _ -> DT.localTimeOfDay lt |
|||
startT _ = DT.TimeOfDay 0 0 0 |
|||
endT :: IT.VEvent -> DT.TimeOfDay |
|||
endT IT.VEvent{veDTEndDuration = Just (Left (IT.DTEndDateTime dt _))} = |
|||
case dt of |
|||
IT.FloatingDateTime lt -> DT.localTimeOfDay lt |
|||
IT.UTCDateTime 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 |
|||
summary _ = "Unknown" |
|||
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' |
|||
where |
|||
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 |
|||
Re.execBlank |
|||
("^\\n\\n.+\\n(.+)\\n" :: String) |
|||
@ -0,0 +1,106 @@ |
|||
{-# LANGUAGE OverloadedStrings #-} |
|||
{-# LANGUAGE LambdaCase #-} |
|||
|
|||
module Conf ( Group(..) , Config(..) , readConfig ) where |
|||
|
|||
import qualified Data.Text as T |
|||
import qualified Discord.Types as D |
|||
import Data.Yaml ( Object |
|||
, decodeFileThrow |
|||
, (.:) |
|||
, 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 Data.Word (Word64) |
|||
import Data.Scientific (Scientific, floatingOrInteger) |
|||
import Data.Either (fromRight) |
|||
|
|||
data Group = Group |
|||
{ groupChannel :: D.Snowflake |
|||
, groupRole :: D.Snowflake |
|||
, groupAde :: T.Text |
|||
} |
|||
deriving (Show, Eq, Read) |
|||
|
|||
hmToGroup :: H.HashMap T.Text Value -> Group |
|||
hmToGroup hm = Group |
|||
{ groupChannel = scitosno |
|||
. 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 |
|||
} |
|||
|
|||
data Config = Config |
|||
{ configServer :: D.Snowflake |
|||
, configGroups :: Map.Map T.Text Group |
|||
, configAutoEDTCronDay :: T.Text |
|||
, configAutoEDTCronWeek :: T.Text |
|||
} |
|||
deriving (Show, Eq, Read) |
|||
|
|||
readConfig :: FilePath -> IO Config |
|||
readConfig fp = do |
|||
conf_yml <- decodeFileThrow fp :: IO Object |
|||
-- print conf_yml |
|||
return $ ymlToConf conf_yml |
|||
|
|||
ymlToConf :: Object -> Config |
|||
ymlToConf v = Config |
|||
{ configServer = server |
|||
, configGroups = groups |
|||
, configAutoEDTCronDay = autoEdtCronDay |
|||
, configAutoEDTCronWeek = autoEdtCronWeek |
|||
} |
|||
where |
|||
server' = errorRequired "server" $ H.lookup "server" v |
|||
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 |
|||
. (\case |
|||
Object u -> u |
|||
_ -> 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 |
|||
autoEdtCronWeek = |
|||
valueText "autoEdtCronWeek" |
|||
$ fromMaybe "30 9 * * 0" |
|||
$ H.lookup "autoEdtCronWeek" v |
|||
|
|||
|
|||
errorRequired :: [Char] -> Maybe a -> a |
|||
errorRequired name = fromMaybe (error $ "required field: " ++ name) |
|||
valueText :: [Char] -> Value -> T.Text |
|||
valueText _ (String t) = t |
|||
valueText name _ = error $ name ++ " should be a string" |
|||
valueNum :: [Char] -> Value -> Scientific |
|||
valueNum _ (Number n) = n |
|||
valueNum name _ = error $ name ++ " should be an integer" |
|||
|
|||
scitosno :: Scientific -> D.Snowflake |
|||
scitosno = D.Snowflake |
|||
. (fromInteger :: Integer -> Word64) |
|||
. fromRight (error "Cant read that as an int") |
|||
. floatingOrInteger |
|||
@ -1,80 +1,134 @@ |
|||
{-# LANGUAGE OverloadedStrings #-} |
|||
{-# LANGUAGE RecordWildCards #-} |
|||
{-# LANGUAGE ScopedTypeVariables #-} |
|||
|
|||
module Main where |
|||
|
|||
import Control.Monad (when, void) |
|||
import qualified Data.Text as T |
|||
import qualified Data.Text.IO as TIO |
|||
import UnliftIO (liftIO) |
|||
import Discord |
|||
import Discord.Types |
|||
import Discord.Interactions |
|||
import qualified Discord.Requests as R |
|||
import Commands |
|||
import qualified Data.ByteString as BS |
|||
import qualified Data.Yaml as YAML |
|||
import qualified Data.HashMap.Strict as Map |
|||
import Control.Monad (when, void) |
|||
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 |
|||
, RunDiscordOpts(..) |
|||
) |
|||
import Discord.Types ( Event(..), PartialApplication(..) |
|||
, GatewaySendable(..) |
|||
, UpdateStatusOpts(..) |
|||
, UpdateStatusType(..) |
|||
, Activity(..), ActivityType(..) |
|||
) |
|||
import Discord.Interactions ( interactionResponseBasic |
|||
, Interaction(..) |
|||
, InteractionDataApplicationCommand(..) |
|||
) |
|||
import qualified Discord.Requests as R |
|||
import Commands ( edtResponse, edtCommand |
|||
, pingResponse, pingCommand |
|||
, remindResponse, remindCommand, groupCommand, groupResponse |
|||
) |
|||
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 |
|||
|
|||
testServer :: Snowflake |
|||
testServer = 740862954454646814 |
|||
|
|||
main :: IO () |
|||
main = do |
|||
tok <- TIO.readFile "./auth.secret" |
|||
conf <- YAML.decodeFileThrow "./conf.yaml" :: IO YAML.Value |
|||
putStrLn $ show conf |
|||
conf <- readConfig "./conf.yaml" |
|||
eventSystem <- E.initEventSystem |
|||
print conf |
|||
err <- runDiscord $ def { discordToken = tok |
|||
, discordOnStart = onDiscordStart conf |
|||
, discordOnEnd = liftIO $ putStrLn "Ended" |
|||
, discordOnEvent = onDiscordEvent conf |
|||
, discordOnEvent = onDiscordEvent conf eventSystem |
|||
, discordOnLog = |
|||
\s -> TIO.putStrLn s >> TIO.putStrLn "" |
|||
} |
|||
TIO.putStrLn err |
|||
|
|||
onDiscordStart :: YAML.Value -> DiscordHandler () |
|||
onDiscordStart :: Config -> DiscordHandler () |
|||
onDiscordStart conf = do |
|||
let activity = Activity { activityName = "Doing stuff" |
|||
, activityType = ActivityTypeGame |
|||
, activityUrl = Nothing |
|||
} |
|||
let opts = UpdateStatusOpts { updateStatusOptsSince = Nothing |
|||
, updateStatusOptsGame = Just activity |
|||
, updateStatusOptsNewStatus = UpdateStatusOnline |
|||
, updateStatusOptsAFK = False |
|||
} |
|||
let |
|||
activity :: Activity |
|||
activity = def { activityName = "Doing stuff" |
|||
, activityType = ActivityTypeGame |
|||
, activityUrl = Nothing |
|||
} |
|||
opts :: UpdateStatusOpts |
|||
opts = UpdateStatusOpts { updateStatusOptsSince = Nothing |
|||
, updateStatusOptsGame = Just activity |
|||
, updateStatusOptsNewStatus = UpdateStatusOnline |
|||
, updateStatusOptsAFK = False |
|||
} |
|||
sendCommand (UpdateStatus opts) |
|||
|
|||
|
|||
onDiscordEvent :: YAML.Value -> Event -> DiscordHandler () |
|||
onDiscordEvent conf (Ready _ _ _ _ _ _ (PartialApplication i _)) = |
|||
onDiscordEvent :: Config -> E.EventSystem -> Event -> DiscordHandler () |
|||
onDiscordEvent conf@Config{..} eventSystem (Ready _ _ _ _ _ _ (PartialApplication i _)) = do |
|||
mapM_ (maybe ( return () ) |
|||
( void |
|||
. restCall |
|||
. R.CreateGuildApplicationCommand i testServer |
|||
. R.CreateGuildApplicationCommand i configServer |
|||
) |
|||
) |
|||
[ Just pingCommand |
|||
, Just edtCommand |
|||
[ pingCommand |
|||
, edtCommand conf |
|||
, remindCommand |
|||
, groupCommand conf |
|||
] |
|||
onDiscordEvent conf |
|||
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 = |
|||
Just InteractionDataApplicationCommandChatInput |
|||
InteractionDataApplicationCommandChatInput |
|||
{ interactionDataApplicationCommandName = name |
|||
, interactionDataApplicationCommandOptions = opts |
|||
, .. |
|||
} |
|||
, interactionChannelId = Just channel |
|||
, interactionGuildId = Just guild |
|||
, interactionUser = user |
|||
, .. |
|||
} |
|||
) = do |
|||
void $ restCall |
|||
response <- responseIO |
|||
void $ restCall |
|||
(R.CreateInteractionResponse interactionId interactionToken response) |
|||
where |
|||
response = case name of |
|||
"ping" -> pingResponse |
|||
"edt" -> edtResponse opts |
|||
_ -> interactionResponseBasic $ "Unhandled Command: " `T.append` name |
|||
onDiscordEvent _ _ = return () |
|||
responseIO = case name of |
|||
"ping" -> liftIO $ pingResponse conf |
|||
"edt" -> liftIO $ edtResponse conf opts |
|||
"remind" -> remindResponse opts eventSystem channel user |
|||
"group" -> groupResponse conf user guild opts |
|||
_ -> 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 |
|||
edt <- liftIO $ getEdt conf $ Map.fromList [("group", gn), ("day", day )] |
|||
liftIO |
|||
$ TIO.putStrLn |
|||
$ "Putting out time table for group " |
|||
`T.append` gn |
|||
`T.append` " in " |
|||
`T.append` T.pack (show gc) |
|||
`T.append` ":\n" |
|||
`T.append` edt |
|||
restCall $ R.CreateMessage gc (edt `T.append` "\nAutomatic time table") |
|||
return () |
|||
) glist |
|||
|
|||
@ -1,14 +1,17 @@ |
|||
resolver: lts-18.24 |
|||
resolver: lts-18.27 |
|||
packages: |
|||
- . |
|||
allow-newer: true |
|||
extra-deps: |
|||
# Stuff not in stackage |
|||
- emoji-0.1.0.2 |
|||
- control-event-1.3 |
|||
- iCalendar-0.4.0.5 |
|||
- mime-0.4.0.2 |
|||
# My fork of discord-haskell to fix a bug |
|||
- github: Annwan/discord-haskell |
|||
commit: 830e3a0bcc2586e40e167a1ec14e357e6396a7d2 |
|||
|
|||
- discord-haskell-1.12.1 |
|||
- control-event-1.3 |
|||
## My fork of discord-haskell to PR bug fixes and have them before merge |
|||
# - github: Annwan/discord-haskell |
|||
# commit: <insert pactch commit> |
|||
# discord-haskell repo when there is a bug in hackage |
|||
# - github: aquarial/discord-haskell |
|||
# commit: <insert master commit> |
|||
Write
Preview
Loading…
Cancel
Save
Reference in new issue