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

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
This diff is collapsed.
......@@ -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
import qualified Calendar as Cal
import Control.Monad.Logger (logInfoN)
import Data.Time.LocalTime (LocalTime)
import Yesod.Form.Bootstrap3
import qualified BookingForm as BF
import Calendar
import qualified Data.SortedList as SL
import Data.Time.Clock (addUTCTime)
import Data.Time.Zones
import qualified FreshCache as FC
import Import
import qualified QueryForm as QF
import qualified BookingForm as BF
import Text.Julius (RawJS (..))
import qualified QueryForm as QF
import Text.Julius (RawJS (..))
getHomeR :: Handler Html
getHomeR = do
App {..} <- getYesod
-- Start refresh of calendar, but don't wait for result.
void $ async $ appGetCalendar Nothing
void $ async $ FC.readCache appCalendarCache
(widget, enctype) <- generateFormPost QF.queryForm
(idSpinner, idAvail, idAlert) <- (,,) <$> newIdent <*> newIdent <*> newIdent
defaultLayout $(widgetFile "homepage")
formSuccess :: MonadHandler m => ((FormResult a, b), c) -> m a
formSuccess ((formResult,_),_) =
formSuccess ((formResult, _), _) =
case formResult of
FormMissing -> invalidArgs ["Missing form data!"]
FormMissing -> invalidArgs ["Missing form data!"]
FormFailure errors -> invalidArgs errors
FormSuccess result -> return result
showD = QF.showDate . Cal.seStart
showT fmt = QF.showTime fmt . Cal.seStart
slotVal = tshow . Cal.seStart
showD :: SimpleEventLocal -> String
showD = QF.showDate . seStart
showT :: QF.TimeFmt -> SimpleEventLocal -> String
showT fmt = QF.showTime fmt . seStart
slotVal :: SimpleEventLocal -> Text
slotVal = tshow . seStart
getAvailR :: Handler Html
getAvailR = do
QF.QueryForm{..} <- formSuccess =<< runFormGet QF.queryForm
QF.QueryForm {..} <- formSuccess =<< runFormGet QF.queryForm
App {appSettings = AppSettings {..}, ..} <- getYesod
let tz = tzByLabel queryTzLabel
offset = fromMaybe queryApptLength $ headMay appApptLengthsMinutes
avail <-
Cal.groupByDay .
map (Cal.applyTz tz) .
Cal.partitionSlots queryApptLength .
filter (isInfixOf (locSearch queryLocation) . Cal.seSummary) <$>
appGetCalendar Nothing
groupByDay .
SL.map (applyTz tz) .
partitionSlots offset queryApptLength .
SL.filter (summaryMatches (locSearch queryLocation)) <$>
FC.readCache appCalendarCache
withUrlRenderer
[hamlet|
$if null avail
......@@ -67,10 +74,8 @@ $forall eachDay <- avail
postHomeR :: Handler Html
postHomeR = do
q@QF.QueryForm {..} <- formSuccess =<< runFormPost QF.queryForm
slot <- maybe (invalidArgs ["Missing time slot"]) (return . QF.slotLocal) querySlot
(widget, enctype) <- generateFormPost
$ renderBootstrap3 BootstrapBasicForm
$ BF.bookingForm q
slot <- maybe (invalidArgs ["Missing time slot"]) return querySlot
(widget, enctype) <- generateFormPost BF.bookingMForm
defaultLayout
[whamlet|
<p>OK?
......@@ -80,11 +85,11 @@ postHomeR = do
<input type=hidden name=#{QF.idTimeFmt} value=#{toPathPiece queryTimeFmt}>
<input type=hidden name=#{QF.idTzLabel} value=#{toPathPiece queryTzLabel}>
<input type=hidden name=#{QF.idLocation} value=#{toPathPiece queryLocation}>
<input type=hidden name=#{QF.idSlot} value=#{toPathPiece querySlot}>
<input type=hidden name=#{QF.idSlot} value=#{toPathPiece slot}>
<div .form-group>
<label>When
<p .form-control-static>
#{QF.showDate slot} #{QF.showTime queryTimeFmt slot}
#{QF.showDate' slot} #{QF.showTime' queryTimeFmt slot}
(#{toPathPiece queryTzLabel})
<div .form-group>
<label>Where
......@@ -95,4 +100,37 @@ postHomeR = do
|]
postConfirmR :: Handler Html
postConfirmR = error "postConfirmR"
postConfirmR = do
b@BF.Booking {..} <- formSuccess =<< runFormPost BF.bookingMForm
q@QF.QueryForm {..} <- formSuccess =<< runFormPostNoToken QF.queryForm
slot <- maybe (invalidArgs ["Missing time slot"]) return querySlot
App {..} <- getYesod
let utcStart = tzByLabel queryTzLabel `localTimeToUTCTZ` QF.slotLocal slot
utcEnd = fromMinutes queryApptLength `addUTCTime` utcStart
ok e =
summaryMatches (locSearch queryLocation) e &&
withinEvent utcStart utcEnd e
SL.uncons . SL.filter ok <$> FC.readCache appCalendarCache >>= \case
Nothing -> invalidArgs ["No longer available?"] -- TODO should be friendlier
Just (e, _) -> do
addEvent
appCalendarCxt
(appBusyCalendarId appSettings)
SimpleEvent
{ seSummary = bookName
, seStart = utcStart
, seEnd = utcEnd
, seDescr =
"Subject: " <> bookSubject <>
maybe "" ("\nContact: " <>) bookContact
, seLocation = locDescr queryLocation
, seAttendees = [Attendee bookName bookEmail]
}
FC.invalidateCache appCalendarCache
defaultLayout
[whamlet|
<p>#{tshow b}
<p>#{tshow q}
<p>#{tshow utcStart}
<p>#{tshow e}
|]
......@@ -3,11 +3,14 @@
module Import.NoFoundation
( module Import
, pluralN
, fromWeeks
, fromMinutes
) where
import Calendar as Import (CalendarContext,
SimpleEventUTC)
import ClassyPrelude.Yesod as Import
import Data.Time.Clock (NominalDiffTime)
import Settings as Import
import Settings.StaticFiles as Import
import Yesod.Core.Types as Import (loggerSet)
......@@ -16,3 +19,9 @@ import Yesod.Default.Config2 as Import
pluralN :: Int -> Text -> Text -> Text
pluralN 1 x _ = "1 " <> x
pluralN n _ y = tshow n <> " " <> y
fromWeeks :: Int -> NominalDiffTime
fromWeeks w = fromMinutes (24 * 7 * 60 * w)
fromMinutes :: Int -> NominalDiffTime
fromMinutes m = 60 * fromIntegral m
......@@ -20,7 +20,9 @@ module QueryForm
, Slot(..)
, queryForm
, showDate
, showDate'
, showTime
, showTime'
, getLocationById
, parseLocationField
, idApptLength
......@@ -50,8 +52,9 @@ instance PathPiece TimeFmt where
instance Default TimeFmt where
def = Time12h
newtype Slot = Slot { slotLocal :: LocalTime }
deriving Show
newtype Slot = Slot
{ slotLocal :: LocalTime
} deriving (Show)
instance PathPiece Slot where
toPathPiece = tshow . slotLocal
......@@ -66,16 +69,19 @@ data QueryForm = QueryForm
} deriving (Show)
idApptLength :: Text
idTimeFmt :: Text
idTzLabel :: Text
idLocation :: Text
idSlot :: Text
idTimeFmt :: Text
idTzLabel :: Text
idLocation :: Text
idSlot :: Text
idApptLength = "len"
idTimeFmt = "fmt"
idTzLabel = "tz"
idLocation = "loc"
idSlot = "slot"
idTimeFmt = "fmt"
idTzLabel = "tz"
idLocation = "loc"
idSlot = "slot"
apptLengthOptions :: Handler (OptionList Int)
apptLengthOptions = do
......@@ -111,13 +117,15 @@ getLocationById :: Text -> Handler (Maybe Location)
getLocationById i = do
find ((== i) . locId) . appLocations . appSettings <$> getYesod
parseLocationField :: [Text] -> [FileInfo] -> Handler (Either (SomeMessage App) (Maybe Location))
parseLocationField ::
[Text] -> [FileInfo] -> Handler (Either (SomeMessage App) (Maybe Location))
parseLocationField [] _ =
return $ Left $ SomeMessage $ MsgInputNotFound "location"
parseLocationField (txt:_) _ =
getLocationById txt >>= return . \case
Nothing -> Left $ SomeMessage $ MsgInvalidEntry txt
Just loc -> Right $ Just loc
getLocationById txt >>=
return . \case
Nothing -> Left $ SomeMessage $ MsgInvalidEntry txt
Just loc -> Right $ Just loc
locationChoiceField :: Field Handler Location
locationChoiceField = Field {..}
......@@ -137,7 +145,6 @@ locationChoiceField = Field {..}
#{locDescr loc}
|]
queryForm :: Html -> MForm Handler (FormResult QueryForm, Widget)
queryForm extra = do
AppSettings {..} <- appSettings <$> getYesod
......@@ -148,8 +155,10 @@ queryForm extra = do
(selectField apptLengthOptions)
(qs idApptLength)
(headMay appApptLengthsMinutes)
(fmtRes, fmtView) <- mreq (selectField timeFmtOptions) (qs idTimeFmt) (Just def)
(locRes, locView) <- mreq locationChoiceField (qs idLocation) (headMay appLocations)
(fmtRes, fmtView) <-
mreq (selectField timeFmtOptions) (qs idTimeFmt) (Just def)
(locRes, locView) <-
mreq locationChoiceField (qs idLocation) (headMay appLocations)
(slotRes, _) <- mopt textField (qs idSlot) Nothing
(tzRes, _) <- mreq hiddenField (qs idTzLabel) (Just appDefaultTimeZone)
let q =
......@@ -161,9 +170,15 @@ queryForm extra = do
showDate :: LocalTime -> String
showDate = TF.formatTime TF.defaultTimeLocale "%A %e %B"
showDate' :: Slot -> String
showDate' = showDate . slotLocal
timeFmt :: TimeFmt -> String
timeFmt Time12h = "%l:%M %p"
timeFmt Time24h = "%H:%M"
showTime :: TimeFmt -> LocalTime -> String
showTime = TF.formatTime TF.defaultTimeLocale . timeFmt
showTime' :: TimeFmt -> Slot -> String
showTime' f = showTime f . slotLocal
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment