botiut/app/Commands/EDT.hs

{-# 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)