Antoine COMBET
3 years ago
7 changed files with 620 additions and 104 deletions
-
268app/Commands.hs
-
0app/Commands.hsCommands.hs
-
168app/Commands/EDT.hs
-
106app/Conf.hs
-
110app/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 #-} |
|||
|
|||
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,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