You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
155 lines
5.8 KiB
155 lines
5.8 KiB
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-}
|
|
|
|
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 Data.Maybe ( fromMaybe )
|
|
import qualified Data.Text as TS
|
|
import qualified Data.Text.Lazy as T
|
|
import qualified Data.Text.Lazy.Encoding as TE
|
|
import qualified Data.Time as DT
|
|
import qualified Data.Time.Calendar.Easter as DT
|
|
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 Text.URI as Uri
|
|
|
|
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 "No classes for the selected dates"
|
|
)
|
|
$ 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)
|