Calendar.hs 12.8 KB
Newer Older
Christopher League's avatar
Christopher League committed
1
2
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
3
{-# LANGUAGE OverloadedStrings #-}
Christopher League's avatar
Christopher League committed
4
5
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
6
{-# LANGUAGE NoImplicitPrelude #-}
7

8
9
10
11
12
13
14
-- |
-- 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.
15
module Calendar
Christopher League's avatar
Christopher League committed
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
  ( CalendarScope,
    CalendarCredentials,
    CalendarContext,
    CalendarId,
    SimpleEvent (..),
    SimpleEventUTC,
    SimpleEventLocal,
    Attendee (..),
    initialize,
    applyTz,
    groupByDay,
    listAvailMinusBusy,
    partitionSlots,
    summaryMatches,
    isWithin,
31
32
    addEvent,
  )
Christopher League's avatar
Christopher League committed
33
34
35
where

import ClassyPrelude.Yesod
36
37
import Control.Lens ((.~), (^.))
import Control.Monad.Fail (fail)
Christopher League's avatar
Christopher League committed
38
39
40
41
import Control.Monad.Logger
  ( Loc,
    LogSource,
    LogStr,
42
43
    defaultLoc,
  )
Christopher League's avatar
Christopher League committed
44
45
46
47
48
49
50
51
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,
52
53
    addUTCTime,
  )
Christopher League's avatar
Christopher League committed
54
55
56
57
58
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
59
import qualified Network.Google.Auth.ApplicationDefault as Google
Christopher League's avatar
Christopher League committed
60
import System.Log.FastLogger (toLogStr)
61

62
-- | Google authorization scope representing calendar operations.
Christopher League's avatar
Christopher League committed
63
type CalendarScope = '["https://www.googleapis.com/auth/calendar"]
64

65
-- | Credentials needed for accessing the calendar.
66
data CalendarCredentials
67
  = MockCreds
68
  | GoogleCreds (Google.Credentials CalendarScope)
69

70
71
-- | Doesn't reveal the credentials, but simply allows to distinguish
-- whether they are for Google or mocked.
72
instance Show CalendarCredentials where
Christopher League's avatar
Christopher League committed
73
  show MockCreds = "<mock>"
74
75
  show (GoogleCreds _) = "<google>"

76
77
78
-- | 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.
79
instance FromJSON CalendarCredentials where
80
  parseJSON =
81
    Js.withObject "CalendarCredentials" $ \o ->
82
83
84
      o .: "client_id" >>= \c ->
        if c == asText "mock"
          then return MockCreds
Christopher League's avatar
Christopher League committed
85
86
87
88
          else
            either fail (return . GoogleCreds)
              $ Google.fromJSONCredentials
              $ Js.encode o
89

90
91
-- | This represents a ready-to-use environment for calendar
-- operations.
92
data CalendarContext
Christopher League's avatar
Christopher League committed
93
  = MockCxt (MVar (Map Text (SL.SortedList SimpleEventUTC)))
94
  | GoogleCxt (Google.Env CalendarScope)
95

Christopher League's avatar
Christopher League committed
96
97
98
99
100
101
mockBusyId :: Text
mockBusyId = "mock-busy"

mockFreeId :: Text
mockFreeId = "mock-free"

102
103
104
105
-- | 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.
106
107
108
109
110
initialize ::
  (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) ->
  Manager ->
  CalendarCredentials ->
  IO CalendarContext
111
112
initialize appLog _ MockCreds = do
  appLog defaultLoc "" LevelWarn "Using mock calendar"
Christopher League's avatar
Christopher League committed
113
114
  day <- succ . utctDay <$> getCurrentTime
  let free =
115
116
117
118
119
120
121
122
123
124
125
        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)
            ]
Christopher League's avatar
Christopher League committed
126
      busy =
127
128
129
130
131
132
133
134
135
136
137
138
139
140
        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)
            ]
Christopher League's avatar
Christopher League committed
141
  MockCxt <$> newMVar (Map.fromList [(mockFreeId, free), (mockBusyId, busy)])
142
initialize appLog manager (GoogleCreds creds) =
Christopher League's avatar
Christopher League committed
143
144
  GoogleCxt
    <$> (Google.newEnvWith creds gooLog manager <&> Google.envScopes .~ calendarScope)
145
146
147
148
  where
    gooLog level builder =
      appLog defaultLoc "" lv (toLogStr (toLazyByteString builder))
      where
149
150
        lv =
          case level of
Christopher League's avatar
Christopher League committed
151
            Google.Info -> LevelInfo
152
153
154
155
156
157
            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.
Christopher League's avatar
Christopher League committed
158
159
160
161
162
163
164
165
data SimpleEvent t
  = SimpleEvent
      { seSummary :: Text,
        seStart :: t,
        seEnd :: t,
        seDescr :: Text,
        seLocation :: Text,
        seAttendees :: [Attendee]
166
      }
Christopher League's avatar
Christopher League committed
167
  deriving (Eq, Show)
Christopher League's avatar
Christopher League committed
168
169
170

instance Ord t => Ord (SimpleEvent t) where
  compare x y = compare (seStart x) (seStart y)
171
172
173
174
175

type SimpleEventUTC = SimpleEvent UTCTime

type SimpleEventLocal = SimpleEvent LocalTime

Christopher League's avatar
Christopher League committed
176
177
178
179
data Attendee
  = Attendee
      { atName :: Text,
        atEmail :: Text
180
      }
Christopher League's avatar
Christopher League committed
181
  deriving (Show, Eq)
Christopher League's avatar
Christopher League committed
182

183
184
185
186
-- | Extract essential event data from a Google @Event@ object.
simplifyEvent :: Event -> Maybe SimpleEventUTC
simplifyEvent e = do
  let seSummary = fromMaybe "" $ e ^. eSummary
Christopher League's avatar
Christopher League committed
187
188
189
      seDescr = fromMaybe "" $ e ^. eDescription
      seLocation = fromMaybe "" $ e ^. eLocation
      seAttendees = mapMaybe simplifyAttendee $ e ^. eAttendees
190
191
192
193
  seStart <- e ^. eStart >>= (^. edtDateTime)
  seEnd <- e ^. eEnd >>= (^. edtDateTime)
  return SimpleEvent {..}

Christopher League's avatar
Christopher League committed
194
195
expandEvent :: SimpleEventUTC -> Event
expandEvent SimpleEvent {..} =
Christopher League's avatar
Christopher League committed
196
197
198
199
200
201
202
203
204
205
206
207
208
  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
209
210
211
212
      ( eventReminders & erOverrides .~ defaultReminders
          & erUseDefault
          .~ Just False
      )
Christopher League's avatar
Christopher League committed
213

214
defaultReminders :: [EventReminder]
Christopher League's avatar
Christopher League committed
215
defaultReminders =
Christopher League's avatar
Christopher League committed
216
217
  [ eventReminder & erMethod .~ Just "email" & erMinutes .~ Just 1440,
    eventReminder & erMethod .~ Just "popup" & erMinutes .~ Just 10
218
  ]
Christopher League's avatar
Christopher League committed
219
220
221
222
223
224
225
226
227
228
229

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

230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
-- | 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
Christopher League's avatar
Christopher League committed
254
255
256
257
258
259
    { seSummary = summary,
      seStart = UTCTime (f d) (toSec hmm1),
      seEnd = UTCTime (f d) (toSec hmm2),
      seDescr = "",
      seLocation = "",
      seAttendees = []
260
    }
261
262

-- | Fetch events from a single calendar.
263
264
265
266
267
268
269
listUpcoming ::
  MonadResource m =>
  CalendarContext ->
  CalendarId ->
  -- | How far to look ahead
  NominalDiffTime ->
  m (SL.SortedList SimpleEventUTC)
Christopher League's avatar
Christopher League committed
270
271
listUpcoming (MockCxt v) cid _ =
  fromMaybe mempty . Map.lookup cid <$> readMVar v
272
273
274
275
listUpcoming (GoogleCxt env) cid lookahead = do
  now <- liftIO getCurrentTime
  let end = addUTCTime lookahead now
  xs <-
Christopher League's avatar
Christopher League committed
276
277
278
    Google.runGoogle env
      $ Google.send
      $ eventsList cid
279
280
281
282
283
284
        & elTimeMin
        .~ Just now
        & elTimeMax
        .~ Just end
        & elSingleEvents
        .~ Just True
Christopher League's avatar
Christopher League committed
285
  let es = SL.toSortedList $ mapMaybe simplifyEvent $ xs ^. eveItems
Christopher League's avatar
Christopher League committed
286
  --forM_ (SL.fromSortedList es) $ sayEvent $ take 4 cid
Christopher League's avatar
Christopher League committed
287
288
  return es

Christopher League's avatar
Christopher League committed
289
290
291
-- sayEvent :: MonadIO m => Text -> SimpleEventUTC -> m ()
-- sayEvent prefix SimpleEvent {..} =
--   say $ prefix <> " " <> tshow seStart <> " " <> tshow seEnd <> " " <> seSummary
292

293
294
295
-- | Convert an event into a local time zone.
applyTz :: TZ -> SimpleEventUTC -> SimpleEventLocal
applyTz tz ev =
Christopher League's avatar
Christopher League committed
296
  ev
Christopher League's avatar
Christopher League committed
297
298
    { seStart = utcToLocalTimeTZ tz (seStart ev),
      seEnd = utcToLocalTimeTZ tz (seEnd ev)
299
    }
300

Christopher League's avatar
Christopher League committed
301
302
groupByDay :: SL.SortedList SimpleEventLocal -> [[SimpleEventLocal]]
groupByDay = groupAllOn (localDay . seStart) . SL.fromSortedList
303
304
305
306

-- | Construct a stream of events that represent available times with
-- chunks of busy times removed. Requires that the event streams are
-- already ordered.
307
308
309
310
311
312
313
314
availMinusBusy ::
  Ord t =>
  -- | Available times
  SL.SortedList (SimpleEvent t) ->
  -- | Busy times
  SL.SortedList (SimpleEvent t) ->
  -- | Remaining available times
  SL.SortedList (SimpleEvent t)
Christopher League's avatar
Christopher League committed
315
316
317
318
319
availMinusBusy aaa bbb =
  case (SL.uncons aaa, SL.uncons bbb) of
    (Nothing, _) -> mempty -- No available times
    (_, Nothing) -> aaa
    (Just (a, aa), Just (b, bb))
Christopher League's avatar
Christopher League committed
320
      -- A ends before B starts, so keep A and consider next A
Christopher League's avatar
Christopher League committed
321
      | seEnd a <= seStart b -> SL.insert a $ availMinusBusy aa bbb
Christopher League's avatar
Christopher League committed
322
      -- B ends before A starts, so consider next B.
Christopher League's avatar
Christopher League committed
323
      | seEnd b <= seStart a -> availMinusBusy aaa bb
Christopher League's avatar
Christopher League committed
324
      -- A is contained within B, so omit A and consider next A
Christopher League's avatar
Christopher League committed
325
      | seStart b <= seStart a && seEnd a <= seEnd b -> availMinusBusy aa bbb
Christopher League's avatar
Christopher League committed
326
      -- B is contained wholly within A, so split A and consider next B
Christopher League's avatar
Christopher League committed
327
328
329
330
      | 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
Christopher League's avatar
Christopher League committed
331
      -- B overlaps beginning of A, so adjust A and consider next B
Christopher League's avatar
Christopher League committed
332
333
334
      | seStart b <= seStart a && seEnd b <= seEnd a ->
        let a' = a {seStart = seEnd b}
         in availMinusBusy (SL.insert a' aa) bb
Christopher League's avatar
Christopher League committed
335
      -- B overlaps end of A, so keep truncated A and consider next A
336
      | otherwise {-seStart a <= seStart b && seEnd a <= seEnd b-} ->
Christopher League's avatar
Christopher League committed
337
338
        let a' = a {seEnd = seStart b}
         in SL.insert a' $ availMinusBusy aa bbb
339
340
341

-- | Simultaneously fetch two calendars and return the difference
-- between them.
342
343
344
345
346
347
348
349
350
351
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)
352
353
354
listAvailMinusBusy cxt cidAvail cidBusy lookahead = do
  availT <- async $ listUpcoming cxt cidAvail lookahead
  busyT <- async $ listUpcoming cxt cidBusy (lookahead + 86400)
Christopher League's avatar
Christopher League committed
355
  es <- availMinusBusy <$> waitAsync availT <*> waitAsync busyT
Christopher League's avatar
Christopher League committed
356
  --forM_ (SL.fromSortedList es) $ sayEvent "DIFF"
Christopher League's avatar
Christopher League committed
357
  return es
358
359
360

-- | Take a stream of available times and split them into slots exactly
-- N minutes long.
361
362
363
364
365
366
367
partitionSlots ::
  -- | Offset of each new slot, in minutes
  Maybe Int ->
  -- | Length of each slot, in minutes
  Int ->
  SL.SortedList SimpleEventUTC ->
  SL.SortedList SimpleEventUTC
Christopher League's avatar
Christopher League committed
368
partitionSlots offsetM lengthM evs = loop evs
369
  where
Christopher League's avatar
Christopher League committed
370
    lengthT = fromIntegral $ lengthM * 60
371
    offsetT = fromIntegral $ (fromMaybe lengthM offsetM) * 60
Christopher League's avatar
Christopher League committed
372
373
374
375
376
377
378
    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
Christopher League's avatar
Christopher League committed
379
380
381
382
                then
                  SL.insert e {seEnd = thisEnd}
                    $ loop
                    $ SL.insert e {seStart = nextStart} es
Christopher League's avatar
Christopher League committed
383
384
385
386
387
                else loop es

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

388
389
isWithin :: Ord t => SimpleEvent t -> SimpleEvent t -> Bool
isWithin e1 e2 = seStart e2 <= seStart e1 && seEnd e1 <= seEnd e2
Christopher League's avatar
Christopher League committed
390

391
392
393
394
395
396
addEvent ::
  (MonadUnliftIO m, MonadResource m) =>
  CalendarContext ->
  CalendarId ->
  SimpleEventUTC ->
  m ()
Christopher League's avatar
Christopher League committed
397
398
399
400
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 =
Christopher League's avatar
Christopher League committed
401
402
403
404
  void
    $ Google.runGoogle env
    $ Google.send
    $ eventsInsert cid (expandEvent e)
405
406
      & eveSendNotifications
      .~ Just True