Commit af8a7f43 authored by Christopher League's avatar Christopher League 🖥
Browse files

Great! Pretty close.

parent 96de7e74
......@@ -22,8 +22,8 @@ calendar-credentials:
client_id: "_env:BOOKME_GOOGLE_ID:mock"
client_secret: "_env:BOOKME_GOOGLE_SECRET:"
refresh_token: "_env:BOOKME_GOOGLE_REFRESH:"
free-calendar: _env:BOOKME_FREE_CAL:free
busy-calendar: _env:BOOKME_BUSY_CAL:busy
free-calendar: _env:BOOKME_FREE_CAL:mock-free
busy-calendar: _env:BOOKME_BUSY_CAL:mock-busy
look-ahead-weeks: 4
development: "_env:BOOKME_DEVEL:false"
......
......@@ -32,6 +32,7 @@ dependencies:
- monad-logger >=0.3 && <0.4
- safe
- shakespeare >=2.0 && <2.1
- sorted-list >=0.2.0.0 && <0.3
- template-haskell
- text >=0.11 && <2.0
- time
......
......@@ -21,7 +21,6 @@ module Application
import qualified Calendar as Cal
import Control.Monad.Logger (liftLoc, logInfoN)
import Data.Time.Clock (NominalDiffTime)
import qualified FreshCache as FC
import Import
import Language.Haskell.TH.Syntax (qLocation)
......@@ -53,9 +52,6 @@ import Handler.Home
-- comments there for more details.
mkYesodDispatch "App" resourcesApp
fromWeeks :: Int -> NominalDiffTime
fromWeeks w = 24 * 7 * 60 * 60 * fromIntegral w
-- | This function allocates resources (such as a database connection pool),
-- performs initialization and returns a foundation datatype value. This is also
-- the place to put your migrate statements to have automatic database
......@@ -72,18 +68,17 @@ makeFoundation appSettings@AppSettings {..} = do
let partialApp = App {..}
where
appCalendarCxt = error "partialApp loop: Accessing appCalendarCxt"
appGetCalendar = error "partialApp loop: Accessing appGetCalendar"
appCalendarCache = error "partialApp loop: Accessing appCalendarCache"
logFunc loc src lv =
whenM (shouldLogIO partialApp "" lv) .
messageLoggerSource partialApp appLogger loc src lv
appCalendarCxt <- Cal.initialize logFunc appHttpManager appCredentials
cache <-
appCalendarCache <-
unsafeHandler partialApp $
FC.newCache $ do
FC.newCache appCacheExpiry $ do
logInfoN "Refreshing calendar cache"
Cal.listAvailMinusBusy appCalendarCxt appFreeCalendarId appBusyCalendarId $
fromWeeks appLookaheadWeeks
let appGetCalendar = FC.readCache cache . fromMaybe appCacheExpiry
return App {..}
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
......
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-|
Module: BookingForm
......@@ -11,39 +11,28 @@ TODO
-}
module BookingForm
( Booking(..)
, bookingForm
, bookingMForm
) where
import Import
import QueryForm
import Data.Time.LocalTime (LocalTime)
import Import
import qualified Yesod.Form.Bootstrap3 as B3
data Booking =
Booking
{ bookName :: Text
, bookEmail :: Text
, bookContact :: Maybe Text
, bookSubject :: Text
data Booking = Booking
{ bookName :: Text
, bookEmail :: Text
, bookContact :: Maybe Text
, bookSubject :: Text
} deriving (Show)
bfs :: Text -> FieldSettings site
bfs = B3.bfs . asText
locationShowField :: Field Handler Location
locationShowField = Field{..}
where
fieldEnctype = UrlEncoded
fieldParse = parseLocationField
fieldView i _ attrs (Right val) _ =
[whamlet|
<p .form-control-static>#{locDescr val}
<input type=hidden name=#{i}>
|]
bookingAForm :: AForm Handler Booking
bookingAForm =
Booking <$> areq textField (bfs "Name") Nothing <*>
areq emailField (bfs "Email") Nothing <*>
aopt textField (bfs "Contact") Nothing <*>
areq textField (bfs "Subject") Nothing
bookingForm :: QueryForm -> AForm Handler Booking
bookingForm QueryForm{..} =
Booking
<$> areq textField (bfs "Name") Nothing
<*> areq emailField (bfs "Email") Nothing
<*> aopt textField (bfs "Contact") Nothing
<*> areq textField (bfs "Subject") Nothing
bookingMForm :: Html -> MForm Handler (FormResult Booking, Widget)
bookingMForm = B3.renderBootstrap3 B3.BootstrapBasicForm bookingAForm
......@@ -21,11 +21,15 @@ module Calendar
, SimpleEvent(..)
, SimpleEventUTC
, SimpleEventLocal
, Attendee(..)
, initialize
, applyTz
, groupByDay
, listAvailMinusBusy
, partitionSlots
, summaryMatches
, withinEvent
, addEvent
) where
import ClassyPrelude.Yesod
......@@ -35,6 +39,8 @@ import Control.Monad.Logger (Loc, LogSource, LogStr,
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)
......@@ -75,9 +81,15 @@ instance FromJSON CalendarCredentials where
-- | This represents a ready-to-use environment for calendar
-- operations.
data CalendarContext
= MockCxt Day
= 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
......@@ -89,7 +101,35 @@ initialize ::
-> IO CalendarContext
initialize appLog _ MockCreds = do
appLog defaultLoc "" LevelWarn "Using mock calendar"
MockCxt . succ . utctDay <$> getCurrentTime
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)
......@@ -107,23 +147,65 @@ initialize appLog manager (GoogleCreds creds) =
-- | 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
} deriving (Show)
{ 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 & 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.
......@@ -151,6 +233,9 @@ sampleEvent d (summary, f, hmm1, hmm2) =
{ seSummary = summary
, seStart = UTCTime (f d) (toSec hmm1)
, seEnd = UTCTime (f d) (toSec hmm2)
, seDescr = ""
, seLocation = ""
, seAttendees = []
}
-- | Fetch events from a single calendar.
......@@ -159,86 +244,67 @@ listUpcoming ::
=> CalendarContext
-> CalendarId
-> NominalDiffTime -- ^How far to look ahead
-> m [SimpleEventUTC]
listUpcoming (MockCxt d) cid _ =
return $
map (sampleEvent d) $
if cid == "busy"
then busy
else free
where
busy =
[ ("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)
]
free =
[ ("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)
]
-> 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
return $ mapMaybe simplifyEvent $ xs ^. eveItems
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 =
SimpleEvent
{ seSummary = seSummary ev
, seStart = utcToLocalTimeTZ tz (seStart ev)
ev
{ seStart = utcToLocalTimeTZ tz (seStart ev)
, seEnd = utcToLocalTimeTZ tz (seEnd ev)
}
groupByDay :: [SimpleEventLocal] -> [[SimpleEventLocal]]
groupByDay = groupAllOn (localDay . seStart)
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
=> [SimpleEvent t] -- ^Available times
-> [SimpleEvent t] -- ^Busy times
-> [SimpleEvent t] -- ^Remaining available times
availMinusBusy [] _ = []
availMinusBusy aa [] = aa
availMinusBusy (a:aa) (b:bb)
-- A ends before B starts, so keep A and consider next A
| seEnd a <= seStart b = a : availMinusBusy aa (b : bb)
-- B ends before A starts, so consider next B.
| seEnd b <= seStart a = availMinusBusy (a : aa) bb
-- A is contained within B, so omit A and consider next A
| seStart b <= seStart a && seEnd a <= seEnd b = availMinusBusy aa (b : bb)
-- 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 a1 : availMinusBusy (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 (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 a' : availMinusBusy aa (b : bb)
=> SL.SortedList (SimpleEvent t) -- ^Available times
-> SL.SortedList (SimpleEvent t) -- ^Busy times
-> SL.SortedList (SimpleEvent t) -- ^Remaining available times
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.
......@@ -248,25 +314,53 @@ listAvailMinusBusy ::
-> CalendarId -- ^Calendar with available times
-> CalendarId -- ^Calendar with busy times
-> NominalDiffTime -- ^How far to look ahead
-> m [SimpleEventUTC]
-> m (SL.SortedList SimpleEventUTC)
listAvailMinusBusy cxt cidAvail cidBusy lookahead = do
availT <- async $ listUpcoming cxt cidAvail lookahead
busyT <- async $ listUpcoming cxt cidBusy (lookahead + 86400)
availMinusBusy <$> waitAsync availT <*> waitAsync busyT
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 ::
Int -- ^How many minutes per slot?
-> [SimpleEventUTC]
-> [SimpleEventUTC]
partitionSlots _ [] = []
partitionSlots minutes evs = loop evs
Int -- ^ Offset of each new slot, in minutes
-> Int -- ^ Length of each slot, in minutes
-> SL.SortedList SimpleEventUTC
-> SL.SortedList SimpleEventUTC
partitionSlots offsetM lengthM evs = loop evs
where
dt = fromIntegral $ minutes * 60
loop [] = []
loop (e:es) =
let et = addUTCTime dt (seStart e)
in if et <= seEnd e
then e {seEnd = et} : loop (e {seStart = et} : es)
else loop es
offsetT = fromIntegral $ offsetM * 60
lengthT = fromIntegral $ lengthM * 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
withinEvent :: UTCTime -> UTCTime -> SimpleEventUTC -> Bool
withinEvent start end e = seStart e <= start && end <= seEnd e
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
......@@ -22,8 +22,9 @@ module Foundation
import qualified Control.Monad.Catch as MC
import Control.Monad.Logger (LogSource)
import qualified Data.CaseInsensitive as CI
import qualified Data.SortedList as SL
import qualified Data.Text.Encoding as TE
import Data.Time.Clock (NominalDiffTime)
import qualified FreshCache as FC
import Import.NoFoundation as Pre
import Text.Hamlet (hamletFile)
import Text.Jasmine (minifym)
......@@ -36,12 +37,12 @@ import Yesod.Default.Util (addStaticContentExternal)
-- starts running, such as database connections. Every handler will have
-- access to the data present here.
data App = App
{ appSettings :: AppSettings
, appStatic :: Static -- ^ Settings for static file serving.
, appHttpManager :: Manager
, appLogger :: Logger
, appCalendarCxt :: CalendarContext
, appGetCalendar :: Maybe NominalDiffTime -> HandlerFor App [SimpleEventUTC]
{ appSettings :: AppSettings
, appStatic :: Static -- ^ Settings for static file serving.
, appHttpManager :: Manager
, appLogger :: Logger
, appCalendarCxt :: CalendarContext
, appCalendarCache :: FC.Cache (HandlerFor App) (SL.SortedList SimpleEventUTC)
-- ^ Fetch latest available times from the calendars. Return cached
-- version if it's less than given age, which defaults to
-- 'appCacheExpiry'.
......
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-|
......@@ -15,6 +16,7 @@ module FreshCache
( Cache
, newCache
, readCache
, invalidateCache
, cacheDemo
) where
......@@ -22,30 +24,45 @@ import ClassyPrelude.Yesod
import Control.Concurrent (threadDelay)
import Data.Time.Clock (NominalDiffTime, diffUTCTime)
data CacheData a = CacheData
{ value :: a
, retrievedAt :: UTCTime
}
data CacheMeta m a = CacheMeta
{ content :: Maybe (CacheData a)
, maxAge :: NominalDiffTime
, refresh :: m a
}
-- | The cache structure. Saves the value 'a' which can be refreshed or
-- accessed within the monad 'm'.
newtype Cache m a =
Cache (MVar (a, UTCTime, m a))
Cache (MVar (CacheMeta m a))
-- | Create a new cache by running the action and saving it with a
-- timestamp.
newCache :: MonadIO m => m a -> m (Cache m a)
newCache refresh = do
now <- liftIO getCurrentTime
result <- refresh
Cache <$> newMVar (result, now, refresh)
newCache :: MonadIO m => NominalDiffTime -> m a -> m (Cache m a)
newCache maxAge refresh = Cache <$> newMVar CacheMeta {..}
where
content = Nothing
-- | Retrieve the value from the cache if it's within the specified
-- maximum age. Otherwise, refresh it and return the new value.
readCache :: MonadUnliftIO m => Cache m a -> NominalDiffTime -> m a
readCache (Cache mvar) maxAge =
modifyMVar mvar $ \val@(result, prev, refresh) -> do
now <- liftIO getCurrentTime
if now `diffUTCTime` prev < maxAge
then return (val, result)
else do
newResult <- refresh
return ((newResult, now, refresh), newResult)
invalidateCache :: MonadUnliftIO m => Cache m a -> m ()
invalidateCache (Cache mvar) =
modifyMVar_ mvar $ \meta -> return meta {content = Nothing}
-- | Retrieve the value from the cache if it's within the maximum age.
-- Otherwise, refresh it and return the new value.
readCache :: MonadUnliftIO m => Cache m a -> m a
readCache (Cache mvar) = do
now <- liftIO getCurrentTime
modifyMVar mvar $ \meta@CacheMeta {..} ->
case content of
Just CacheData {..}
| now `diffUTCTime` retrievedAt < maxAge -> return (meta, value)
_ -> do
newValue <- refresh
return (meta {content = Just (CacheData newValue now)}, newValue)
-- | A little concurrent test program using the cache.
cacheDemo :: IO ()
......@@ -54,7 +71,7 @@ cacheDemo = do
pr :: Int -> Text -> IO ()
pr i r = say (tshow i <> ": " <> r)
k <-
newCache $ do
newCache 6 $ do
say "Refreshing..."
w 2
say "Refreshing...done"
......@@ -62,11 +79,12 @@ cacheDemo = do
threads <-
forM [1 .. 5] $ \i ->
async $ do
readCache k 6 >>= pr i
readCache k >>= pr i
w (i + 1)
readCache k 6 >>= pr i
readCache k >>= pr i
w (i + 2)
readCache k 6 >>= pr i
readCache k >>= pr i
mapM_ waitAsync threads
say "Now forcing an immediate refresh"
readCache k 0 >>= pr 0
invalidateCache k
readCache k >>= pr 0
......@@ -10,46 +10,53 @@
module Handler.Home where