Schedule.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}

module Schedule
  ( nextEvent
  , eventSummary
  , dayOfWeek
  , Schedule(..)
  ) where

import Control.Monad
import Data.Aeson
import Data.Aeson.Types
import Data.Either.Extra
import Data.Function
import Data.List
import qualified Data.Map as M
import Data.Maybe
import Data.Maybe.Extra
import Data.Monoid
import qualified Data.Text as T
import Data.Time
import Data.Time.Calendar.WeekDate
import Data.Time.Clock.POSIX
import Data.Time.Extra
import Data.Time.LocalTime (TimeZone)
import Safe
import Text.InterpolatedString.QM

data DayOfWeek
  = Monday
  | Tuesday
  | Wednesday
  | Thursday
  | Friday
  | Saturday
  | Sunday
  deriving (Eq, Ord, Enum, Show, Bounded)

dayOfWeek :: Day -> DayOfWeek
dayOfWeek day =
  toEnumNote
    [qms|{s} is not a correct week number according to
         ISO 8601 Week Date format.|]
    (s - 1)
  where
    (_, _, s) = toWeekDate day

newtype ScheduleTimeZone =
  ScheduleTimeZone TimeZone
  deriving (Show)

data Project = Project
  { projectName :: T.Text
  , projectDescription :: T.Text
  , projectUrl :: T.Text
  , projectDays :: [DayOfWeek]
  , projectTime :: TimeOfDay
  , projectChannel :: T.Text
  , projectStarts :: Maybe Day
  , projectEnds :: Maybe Day
  } deriving (Show)

data Event = Event
  { eventDate :: Day
  , eventTime :: TimeOfDay
  , eventTitle :: T.Text
  , eventDescription :: T.Text
  , eventUrl :: T.Text
  , eventChannel :: T.Text
  } deriving (Show)

eventId :: ScheduleTimeZone -> Event -> EventId
eventId timeZone event =
  EventId $ floor $ utcTimeToPOSIXSeconds $ eventUTCTime timeZone event

eventUTCTime :: ScheduleTimeZone -> Event -> UTCTime
eventUTCTime (ScheduleTimeZone timeZone) Event { eventDate = day
                                               , eventTime = timeOfDay
                                               } =
  localTimeToUTC timeZone localTime
  where
    localTime = LocalTime day timeOfDay

eventSummary :: ScheduleTimeZone -> UTCTime -> Event -> T.Text
eventSummary timezone now event = do
  let t = eventUTCTime timezone event
  -- TODO(#755): Diff time for past events in eventSummary should be `finished - (started + DURATION)`
  if t >= now
    then let d = diffUTCTime t now
          in [qms|{eventTitle event}
                  starts in {humanReadableDiffTime d}|]
    else let d = diffUTCTime now t
          in [qms|{eventTitle event}
                  finished {humanReadableDiffTime d} ago|]

newtype EventId =
  EventId Int
  deriving (Eq, Ord, Show)

data EventPatch = EventPatch
  { eventPatchTitle :: Maybe T.Text
  , eventPatchDescription :: Maybe T.Text
  , eventPatchUrl :: Maybe T.Text
  , eventPatchChannel :: Maybe T.Text
  } deriving (Show)

data Schedule = Schedule
  { scheduleProject :: [Project]
  , scheduleExtraEvents :: [Event]
  , scheduleCancelledEvents :: [EventId]
  , scheduleTimezone :: ScheduleTimeZone
  , schedulePatches :: M.Map EventId EventPatch
  } deriving (Show)

instance FromJSON Schedule where
  parseJSON (Object v) =
    Schedule <$> v .: "projects" <*> v .: "extraEvents" <*>
    v .: "cancelledEvents" <*>
    v .: "timezone" <*>
    v .: "eventPatches"
  parseJSON invalid = typeMismatch "Schedule" invalid

instance FromJSON Project where
  parseJSON (Object v) =
    Project <$> v .: "name" <*> v .: "description" <*> v .: "url" <*>
    v .: "days" <*>
    v .: "time" <*>
    v .: "channel" <*>
    v .:? "starts" <*>
    v .:? "ends"
  parseJSON invalid = typeMismatch "Project" invalid

instance FromJSON Event where
  parseJSON (Object v) =
    Event <$> v .: "date" <*> v .: "time" <*> v .: "title" <*>
    v .: "description" <*>
    v .: "url" <*>
    v .: "channel"
  parseJSON invalid = typeMismatch "Event" invalid

instance FromJSON EventId where
  parseJSON = fmap EventId . parseJSON

instance FromJSONKey EventId where
  fromJSONKey = EventId <$> fromJSONKey

parseTimeZone :: T.Text -> Parser TimeZone
parseTimeZone "Asia/Novosibirsk" = return $ minutesToTimeZone 420
parseTimeZone s = fail ("Unknown timezone: " ++ T.unpack s)

instance FromJSON ScheduleTimeZone where
  parseJSON (String s) = ScheduleTimeZone <$> parseTimeZone s
  parseJSON invalid = typeMismatch "ScheduleTimeZone" invalid

instance FromJSON EventPatch where
  parseJSON (Object v) =
    EventPatch <$> v .:? "title" <*> v .:? "description" <*> v .:? "url" <*>
    v .:? "channel"
  parseJSON invalid = typeMismatch "EventPatch" invalid

instance FromJSON DayOfWeek where
  parseJSON =
    maybeFail "Unknown day of week" . toEnumMay . (\x -> x - 1) <=< parseJSON

cancelEvents :: ScheduleTimeZone -> [EventId] -> [Event] -> [Event]
cancelEvents timeZone cancelledIds =
  filter (\e -> eventId timeZone e `notElem` cancelledIds)

makeEvent :: Day -> Project -> Event
makeEvent day project =
  Event
    { eventDate = day
    , eventTime = projectTime project
    , eventTitle = projectName project
    , eventDescription = projectDescription project
    , eventUrl = projectUrl project
    , eventChannel = projectChannel project
    }

between :: Day -> Project -> Bool
between day project =
  getAll $
  fromMaybe (All True) $
  mappend
    (All . (<= day) <$> projectStarts project)
    (All . (day <=) <$> projectEnds project)

projectsOfDay :: Day -> [Project] -> [Event]
projectsOfDay day projects =
  map (makeEvent day) $
  filter (\p -> weekDay `elem` projectDays p && between day p) projects
  where
    weekDay = dayOfWeek day

recurringEventsFrom :: Day -> [Project] -> [Event]
recurringEventsFrom day projects =
  projectsOfDay day projects ++ recurringEventsFrom (succ day) projects

eventsFrom :: Day -> Schedule -> [Event]
eventsFrom day schedule@Schedule { scheduleTimezone = timezone
                                 , scheduleCancelledEvents = cancelledIds
                                 , schedulePatches = patches
                                 } =
  sortBy
    (compare `on` eventDate)
    (map patchEvent (extraEvents <> recurringEvents))
  where
    recurringEvents =
      take 100 $
      cancelEvents timezone cancelledIds $
      recurringEventsFrom day $ scheduleProject schedule
    extraEvents =
      cancelEvents timezone cancelledIds $
      filter ((>= day) . eventDate) $ scheduleExtraEvents schedule
    applyPatch :: Event -> EventPatch -> Event
    applyPatch event patch =
      event
        { eventTitle = fromMaybe (eventTitle event) (eventPatchTitle patch)
        , eventDescription =
            fromMaybe (eventDescription event) (eventPatchDescription patch)
        , eventUrl = fromMaybe (eventUrl event) (eventPatchUrl patch)
        , eventChannel =
            fromMaybe (eventChannel event) (eventPatchChannel patch)
        }
    patchEvent :: Event -> Event
    patchEvent event =
      maybe event (applyPatch event) $ M.lookup (eventId timezone event) patches

nextEvent :: Schedule -> UTCTime -> Either String Event
nextEvent schedule timePoint =
  maybeToEither "No events found" $
  find ((> timePoint) . eventUTCTime (scheduleTimezone schedule)) $
  eventsFrom (utctDay timePoint) schedule