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           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
          (case cal of
            Left _ -> "Je ne connaît pas ce groupe. Il se peux aussi que ADE ne fonctionne pas actuellement"
            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
            _ -> "Une erreur innatendue a survenue :/"
          )
        of
          "" -> "Aucune classe pour la periode en cours"
          s  -> s
  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** avec **%s** en **%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 "Inconnu" else teacher'
   where
    teacher' = if uncurry (>) (Ar.bounds marray)
      then "Inconnu"
      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 _ = "Inconnu"
  teacherRe = Re.makeRegexOpts Re.compMultiline
                               Re.execBlank
                               ("^\\n\\n.+\\n(.+)\\n" :: String)