Calendar.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- |
-- Module: Calendar
-- Description: Query and manipulate calendars and events.
--
-- This module contains facilities for querying and manipulating
-- calendars and their events. It supports both Google calendars and a
-- mock calendar for used for testing and debugging.
module Calendar
  ( CalendarScope,
    CalendarCredentials,
    CalendarContext,
    CalendarId,
    SimpleEvent (..),
    SimpleEventUTC,
    SimpleEventLocal,
    Attendee (..),
    initialize,
    applyTz,
    groupByDay,
    listAvailMinusBusy,
    partitionSlots,
    summaryMatches,
    isWithin,
    addEvent,
  )
where

import ClassyPrelude.Yesod
import Control.Lens ((.~), (^.))
import Control.Monad.Fail (fail)
import Control.Monad.Logger
  ( Loc,
    LogSource,
    LogStr,
    defaultLoc,
  )
import qualified Data.Aeson as Js
import Data.ByteString.Builder (toLazyByteString)
import Data.Function ((&))
import qualified Data.Map as Map
import qualified Data.SortedList as SL
import Data.Time.Clock
  ( DiffTime,
    NominalDiffTime,
    addUTCTime,
  )
import Data.Time.LocalTime (LocalTime (..))
import Data.Time.Zones (TZ, utcToLocalTimeTZ)
import qualified Network.Google as Google
import Network.Google.AppsCalendar
import qualified Network.Google.Auth as Google
import qualified Network.Google.Auth.ApplicationDefault as Google
import System.Log.FastLogger (toLogStr)

-- | Google authorization scope representing calendar operations.
type CalendarScope = '["https://www.googleapis.com/auth/calendar"]

-- | Credentials needed for accessing the calendar.
data CalendarCredentials
  = MockCreds
  | GoogleCreds (Google.Credentials CalendarScope)

-- | Doesn't reveal the credentials, but simply allows to distinguish
-- whether they are for Google or mocked.
instance Show CalendarCredentials where
  show MockCreds = "<mock>"
  show (GoogleCreds _) = "<google>"

-- | If the field @client_id@ is just the string @"mock"@, then we use
-- a mock calender. Otherwise, we attempt to use @client_id@,
-- @client_secret@, and @refresh_token@ as Google credentials.
instance FromJSON CalendarCredentials where
  parseJSON =
    Js.withObject "CalendarCredentials" $ \o ->
      o .: "client_id" >>= \c ->
        if c == asText "mock"
          then return MockCreds
          else
            either fail (return . GoogleCreds)
              $ Google.fromJSONCredentials
              $ Js.encode o

-- | This represents a ready-to-use environment for calendar
-- operations.
data CalendarContext
  = MockCxt (MVar (Map Text (SL.SortedList SimpleEventUTC)))
  | GoogleCxt (Google.Env CalendarScope)

mockBusyId :: Text
mockBusyId = "mock-busy"

mockFreeId :: Text
mockFreeId = "mock-free"

-- | Use the static credentials to create a dynamic context for
-- calendar operations. The Google environment requires a logging
-- function and an HTTP manager. If using a mock calendar, a warning is
-- printed using the logging function.
initialize ::
  (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) ->
  Manager ->
  CalendarCredentials ->
  IO CalendarContext
initialize appLog _ MockCreds = do
  appLog defaultLoc "" LevelWarn "Using mock calendar"
  day <- succ . utctDay <$> getCurrentTime
  let free =
        SL.toSortedList $
          map
            (sampleEvent day)
            [ ("free1a", fwd 0, 1100, 1155),
              ("free1b #office", fwd 0, 1300, 1450),
              ("free1c #office", fwd 0, 1530, 1800),
              ("free2a #home", fwd 1, 1200, 1600),
              ("free2b #office", fwd 1, 1700, 1800),
              ("free3a #office", fwd 2, 1000, 1200),
              ("free3b #home", fwd 2, 1500, 1930)
            ]
      busy =
        SL.toSortedList $
          map
            (sampleEvent day)
            [ ("busy1a", fwd 0, 1210, 1300),
              ("busy1b", fwd 0, 1330, 1430),
              ("busy1c", fwd 0, 1500, 1550),
              ("busy1d", fwd 0, 1730, 1830),
              ("busy2a", fwd 1, 1130, 1215),
              ("busy2b", fwd 1, 1330, 1400),
              ("busy2c", fwd 1, 1430, 1500),
              ("busy2d", fwd 1, 1610, 1650),
              ("busy3a", fwd 2, 1100, 1400),
              ("busy3b", fwd 2, 1900, 2100)
            ]
  MockCxt <$> newMVar (Map.fromList [(mockFreeId, free), (mockBusyId, busy)])
initialize appLog manager (GoogleCreds creds) =
  GoogleCxt
    <$> (Google.newEnvWith creds gooLog manager <&> Google.envScopes .~ calendarScope)
  where
    gooLog level builder =
      appLog defaultLoc "" lv (toLogStr (toLazyByteString builder))
      where
        lv =
          case level of
            Google.Info -> LevelInfo
            Google.Error -> LevelError
            Google.Debug -> LevelDebug
            Google.Trace -> LevelOther "trace"

-- | A record containing just the essential event data, abstracted over
-- the type of the time-stamp.
data SimpleEvent t
  = SimpleEvent
      { seSummary :: Text,
        seStart :: t,
        seEnd :: t,
        seDescr :: Text,
        seLocation :: Text,
        seAttendees :: [Attendee]
      }
  deriving (Eq, Show)

instance Ord t => Ord (SimpleEvent t) where
  compare x y = compare (seStart x) (seStart y)

type SimpleEventUTC = SimpleEvent UTCTime

type SimpleEventLocal = SimpleEvent LocalTime

data Attendee
  = Attendee
      { atName :: Text,
        atEmail :: Text
      }
  deriving (Show, Eq)

-- | Extract essential event data from a Google @Event@ object.
simplifyEvent :: Event -> Maybe SimpleEventUTC
simplifyEvent e = do
  let seSummary = fromMaybe "" $ e ^. eSummary
      seDescr = fromMaybe "" $ e ^. eDescription
      seLocation = fromMaybe "" $ e ^. eLocation
      seAttendees = mapMaybe simplifyAttendee $ e ^. eAttendees
  seStart <- e ^. eStart >>= (^. edtDateTime)
  seEnd <- e ^. eEnd >>= (^. edtDateTime)
  return SimpleEvent {..}

expandEvent :: SimpleEventUTC -> Event
expandEvent SimpleEvent {..} =
  event & eSummary .~ Just seSummary
    & eStart
    .~ Just (eventDateTime & edtDateTime .~ Just seStart)
    & eEnd
    .~ Just (eventDateTime & edtDateTime .~ Just seEnd)
    & eDescription
    .~ Just seDescr
    & eLocation
    .~ Just seLocation
    & eAttendees
    .~ map expandAttendee seAttendees
    & eReminders
    .~ Just
      ( eventReminders & erOverrides .~ defaultReminders
          & erUseDefault
          .~ Just False
      )

defaultReminders :: [EventReminder]
defaultReminders =
  [ eventReminder & erMethod .~ Just "email" & erMinutes .~ Just 1440,
    eventReminder & erMethod .~ Just "popup" & erMinutes .~ Just 10
  ]

simplifyAttendee :: EventAttendee -> Maybe Attendee
simplifyAttendee at = do
  atName <- at ^. eaDisplayName
  atEmail <- at ^. eaEmail
  return Attendee {..}

expandAttendee :: Attendee -> EventAttendee
expandAttendee Attendee {..} =
  eventAttendee & eaDisplayName .~ Just atName & eaEmail .~ Just atEmail

-- | A synonym representing the ID of a calendar. For mock calendars,
-- the ID @"busy"@ simulates busy events, otherwise they are available
-- time slots.
type CalendarId = Text

-- | Advance forward the specified number of days.
fwd :: Int -> Day -> Day
fwd n
  | n <= 0 = id
  | otherwise = fwd (n - 1) . succ

-- | Convert an HMM-formatted integer to the number of seconds. By HMM,
-- we mean like writing the time without the colon, so @215@ represents
-- 02:15 AM (== 8100 seconds) rather than 215 minutes == 3 hours and 35
-- minutes. This is only used for constructing the mock calendar.
toSec :: Int -> DiffTime
toSec hmm = fromInteger $ h * 3600 + m * 60
  where
    (h, m) = divMod (toInteger hmm) 100

-- | Construct a sample event for the mock calendar.
sampleEvent :: Day -> (Text, Day -> Day, Int, Int) -> SimpleEventUTC
sampleEvent d (summary, f, hmm1, hmm2) =
  SimpleEvent
    { seSummary = summary,
      seStart = UTCTime (f d) (toSec hmm1),
      seEnd = UTCTime (f d) (toSec hmm2),
      seDescr = "",
      seLocation = "",
      seAttendees = []
    }

-- | Fetch events from a single calendar.
listUpcoming ::
  MonadResource m =>
  CalendarContext ->
  CalendarId ->
  -- | How far to look ahead
  NominalDiffTime ->
  m (SL.SortedList SimpleEventUTC)
listUpcoming (MockCxt v) cid _ =
  fromMaybe mempty . Map.lookup cid <$> readMVar v
listUpcoming (GoogleCxt env) cid lookahead = do
  now <- liftIO getCurrentTime
  let end = addUTCTime lookahead now
  xs <-
    Google.runGoogle env
      $ Google.send
      $ eventsList cid
        & elTimeMin
        .~ Just now
        & elTimeMax
        .~ Just end
        & elSingleEvents
        .~ Just True
  let es = SL.toSortedList $ mapMaybe simplifyEvent $ xs ^. eveItems
  --forM_ (SL.fromSortedList es) $ sayEvent $ take 4 cid
  return es

-- sayEvent :: MonadIO m => Text -> SimpleEventUTC -> m ()
-- sayEvent prefix SimpleEvent {..} =
--   say $ prefix <> " " <> tshow seStart <> " " <> tshow seEnd <> " " <> seSummary

-- | Convert an event into a local time zone.
applyTz :: TZ -> SimpleEventUTC -> SimpleEventLocal
applyTz tz ev =
  ev
    { seStart = utcToLocalTimeTZ tz (seStart ev),
      seEnd = utcToLocalTimeTZ tz (seEnd ev)
    }

groupByDay :: SL.SortedList SimpleEventLocal -> [[SimpleEventLocal]]
groupByDay = groupAllOn (localDay . seStart) . SL.fromSortedList

-- | Construct a stream of events that represent available times with
-- chunks of busy times removed. Requires that the event streams are
-- already ordered.
availMinusBusy ::
  Ord t =>
  -- | Available times
  SL.SortedList (SimpleEvent t) ->
  -- | Busy times
  SL.SortedList (SimpleEvent t) ->
  -- | Remaining available times
  SL.SortedList (SimpleEvent t)
availMinusBusy aaa bbb =
  case (SL.uncons aaa, SL.uncons bbb) of
    (Nothing, _) -> mempty -- No available times
    (_, Nothing) -> aaa
    (Just (a, aa), Just (b, bb))
      -- A ends before B starts, so keep A and consider next A
      | seEnd a <= seStart b -> SL.insert a $ availMinusBusy aa bbb
      -- B ends before A starts, so consider next B.
      | seEnd b <= seStart a -> availMinusBusy aaa bb
      -- A is contained within B, so omit A and consider next A
      | seStart b <= seStart a && seEnd a <= seEnd b -> availMinusBusy aa bbb
      -- B is contained wholly within A, so split A and consider next B
      | seStart a < seStart b && seEnd b < seEnd a ->
        let a1 = a {seEnd = seStart b}
            a2 = a {seStart = seEnd b}
         in SL.insert a1 $ availMinusBusy (SL.insert a2 aa) bb
      -- B overlaps beginning of A, so adjust A and consider next B
      | seStart b <= seStart a && seEnd b <= seEnd a ->
        let a' = a {seStart = seEnd b}
         in availMinusBusy (SL.insert a' aa) bb
      -- B overlaps end of A, so keep truncated A and consider next A
      | otherwise {-seStart a <= seStart b && seEnd a <= seEnd b-} ->
        let a' = a {seEnd = seStart b}
         in SL.insert a' $ availMinusBusy aa bbb

-- | Simultaneously fetch two calendars and return the difference
-- between them.
listAvailMinusBusy ::
  (MonadResource m, MonadUnliftIO m) =>
  CalendarContext ->
  -- | Calendar with available times
  CalendarId ->
  -- | Calendar with busy times
  CalendarId ->
  -- | How far to look ahead
  NominalDiffTime ->
  m (SL.SortedList SimpleEventUTC)
listAvailMinusBusy cxt cidAvail cidBusy lookahead = do
  availT <- async $ listUpcoming cxt cidAvail lookahead
  busyT <- async $ listUpcoming cxt cidBusy (lookahead + 86400)
  es <- availMinusBusy <$> waitAsync availT <*> waitAsync busyT
  --forM_ (SL.fromSortedList es) $ sayEvent "DIFF"
  return es

-- | Take a stream of available times and split them into slots exactly
-- N minutes long.
partitionSlots ::
  -- | Offset of each new slot, in minutes
  Maybe Int ->
  -- | Length of each slot, in minutes
  Int ->
  SL.SortedList SimpleEventUTC ->
  SL.SortedList SimpleEventUTC
partitionSlots offsetM lengthM evs = loop evs
  where
    lengthT = fromIntegral $ lengthM * 60
    offsetT = fromIntegral $ (fromMaybe lengthM offsetM) * 60
    loop eee =
      case SL.uncons eee of
        Nothing -> mempty
        Just (e, es) ->
          let thisEnd = addUTCTime lengthT (seStart e)
              nextStart = addUTCTime offsetT (seStart e)
           in if thisEnd <= seEnd e
                then
                  SL.insert e {seEnd = thisEnd}
                    $ loop
                    $ SL.insert e {seStart = nextStart} es
                else loop es

summaryMatches :: Text -> SimpleEvent t -> Bool
summaryMatches search = isInfixOf search . seSummary

isWithin :: Ord t => SimpleEvent t -> SimpleEvent t -> Bool
isWithin e1 e2 = seStart e2 <= seStart e1 && seEnd e1 <= seEnd e2

addEvent ::
  (MonadUnliftIO m, MonadResource m) =>
  CalendarContext ->
  CalendarId ->
  SimpleEventUTC ->
  m ()
addEvent (MockCxt v) cid e =
  modifyMVar_ v $ \m ->
    return $ Map.insert cid (SL.insert e $ Map.findWithDefault mempty cid m) m
addEvent (GoogleCxt env) cid e =
  void
    $ Google.runGoogle env
    $ Google.send
    $ eventsInsert cid (expandEvent e)
      & eveSendNotifications
      .~ Just True