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

Some improvement of form handling.

parent af8a7f43
......@@ -6,6 +6,7 @@
/favicon.ico FaviconR GET
/robots.txt RobotsR GET
/ HomeR GET POST
/available AvailR GET
/confirm ConfirmR POST
/ HomeR GET POST
/avail AvailR GET
/book BookR GET POST
/final FinalR GET
......@@ -15,6 +15,8 @@ dependencies:
- classy-prelude-yesod >=1.4 && <1.5
- conduit >=1.0 && <2.0
- containers
- base64-bytestring
- binary
- data-default
- directory >=1.1 && <1.4
- exceptions
......@@ -37,6 +39,8 @@ dependencies:
- text >=0.11 && <2.0
- time
- tz
- transformers
- blaze-markup
- unordered-containers
- vector
- wai
......
......@@ -22,6 +22,7 @@ module Application
import qualified Calendar as Cal
import Control.Monad.Logger (liftLoc, logInfoN)
import qualified FreshCache as FC
import Handlers
import Import
import Language.Haskell.TH.Syntax (qLocation)
import Network.HTTP.Client.TLS (getGlobalManager)
......@@ -42,11 +43,6 @@ import System.Log.FastLogger (defaultBufSize,
newStdoutLoggerSet,
toLogStr)
-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
import Handler.Common
import Handler.Home
-- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
-- comments there for more details.
......
......@@ -12,18 +12,44 @@ TODO
module BookingForm
( Booking(..)
, bookingMForm
, eventFromBooking
, toSession
, fromSession
) where
import Calendar
import Control.Monad.Trans.Maybe
import Data.Time.Clock (addUTCTime)
import Data.Time.Zones
import Import
import qualified Yesod.Form.Bootstrap3 as B3
import qualified QueryForm as QF
import qualified Yesod.Form.Bootstrap3 as B3
data Booking = Booking
{ bookName :: Text
, bookEmail :: Text
, bookContact :: Maybe Text
, bookSubject :: Text
, bookContact :: Maybe Text
} deriving (Show)
toSession :: MonadHandler m => Booking -> m ()
toSession Booking {..} = do
setSession "name" bookName
setSession "email" bookEmail
setSession "subject" bookSubject
forM_ bookContact $ setSession "contact"
fromSession' :: MonadHandler m => MaybeT m Booking
fromSession' = do
bookName <- MaybeT $ lookupSession "name"
bookEmail <- MaybeT $ lookupSession "email"
bookSubject <- MaybeT $ lookupSession "subject"
bookContact <- lookupSession "contact"
return Booking {..}
fromSession :: Handler Booking
fromSession = runMaybeT fromSession' >>= maybe QF.noSessionError return
bfs :: Text -> FieldSettings site
bfs = B3.bfs . asText
......@@ -31,8 +57,19 @@ 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
areq textField (bfs "Subject") Nothing <*>
aopt textField (bfs "Contact") Nothing
bookingMForm :: Html -> MForm Handler (FormResult Booking, Widget)
bookingMForm = B3.renderBootstrap3 B3.BootstrapBasicForm bookingAForm
eventFromBooking :: Booking -> QF.QueryForm -> QF.TimeSlot -> SimpleEventUTC
eventFromBooking Booking {..} QF.QueryForm {..} slot = SimpleEvent {..}
where
seStart = tzByLabel queryTzLabel `localTimeToUTCTZ` QF.slotLocal slot
seEnd = fromMinutes queryApptLength `addUTCTime` seStart
seDescr =
"Subject: " <> bookSubject <> maybe "" ("\nContact: " <>) bookContact
seSummary = bookName
seLocation = locDescr queryLocation
seAttendees = [Attendee bookName bookEmail]
......@@ -28,7 +28,7 @@ module Calendar
, listAvailMinusBusy
, partitionSlots
, summaryMatches
, withinEvent
, isWithin
, addEvent
) where
......@@ -191,6 +191,7 @@ expandEvent SimpleEvent {..} =
(eventReminders & erOverrides .~ defaultReminders &
erUseDefault .~ Just False)
defaultReminders :: [EventReminder]
defaultReminders =
[ eventReminder & erMethod .~ Just "email" & erMinutes .~ Just 1440
, eventReminder & erMethod .~ Just "popup" & erMinutes .~ Just 10
......@@ -325,14 +326,14 @@ listAvailMinusBusy cxt cidAvail cidBusy lookahead = do
-- | Take a stream of available times and split them into slots exactly
-- N minutes long.
partitionSlots ::
Int -- ^ Offset of each new slot, in minutes
Maybe 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
offsetT = fromIntegral $ offsetM * 60
lengthT = fromIntegral $ lengthM * 60
offsetT = fromIntegral $ (fromMaybe lengthM offsetM) * 60
loop eee =
case SL.uncons eee of
Nothing -> mempty
......@@ -347,8 +348,8 @@ partitionSlots offsetM lengthM evs = loop evs
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
isWithin :: Ord t => SimpleEvent t -> SimpleEvent t -> Bool
isWithin e1 e2 = seStart e2 <= seStart e1 && seEnd e1 <= seEnd e2
addEvent ::
(MonadUnliftIO m, MonadResource m)
......
......@@ -18,8 +18,9 @@ import Data.Time.Zones
import qualified FreshCache as FC
import Import
import qualified QueryForm as QF
import Text.Hamlet (hamletFile)
import Text.Julius (RawJS (..))
{-
getHomeR :: Handler Html
getHomeR = do
App {..} <- getYesod
......@@ -27,7 +28,9 @@ getHomeR = do
void $ async $ FC.readCache appCalendarCache
(widget, enctype) <- generateFormPost QF.queryForm
(idSpinner, idAvail, idAlert) <- (,,) <$> newIdent <*> newIdent <*> newIdent
defaultLayout $(widgetFile "homepage")
defaultLayout $ do
setTitle "Book an appointment"
$(widgetFile "homepage")
formSuccess :: MonadHandler m => ((FormResult a, b), c) -> m a
formSuccess ((formResult, _), _) =
......@@ -61,14 +64,16 @@ getAvailR = do
[hamlet|
$if null avail
No appointments available in the next #{pluralN appLookaheadWeeks "week" "weeks"}.
$forall eachDay <- avail
$maybe firstSlot <- headMay eachDay
<h4>#{showD firstSlot}
<p .slot-choices>
$forall eachSlot <- eachDay
<button type=submit name=slot value=#{slotVal eachSlot}
.btn.btn-default.btn-small>
#{showT queryTimeFmt eachSlot}
$else
$forall eachDay <- avail
$maybe firstSlot <- headMay eachDay
<h4>#{showD firstSlot}
<form .slot-choices>
<input type=hidden name=fooo value=12345>
$forall eachSlot <- eachDay
<button type=submit name=slot value=#{slotVal eachSlot}
.btn.btn-default.btn-small>
#{showT queryTimeFmt eachSlot}
|]
postHomeR :: Handler Html
......@@ -76,28 +81,9 @@ postHomeR = do
q@QF.QueryForm {..} <- formSuccess =<< runFormPost QF.queryForm
slot <- maybe (invalidArgs ["Missing time slot"]) return querySlot
(widget, enctype) <- generateFormPost BF.bookingMForm
defaultLayout
[whamlet|
<p>OK?
<p>#{tshow q}
<form role=form method=post action=@{ConfirmR} enctype=#{enctype}>
<input type=hidden name=#{QF.idApptLength} value=#{toPathPiece queryApptLength}>
<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 slot}>
<div .form-group>
<label>When
<p .form-control-static>
#{QF.showDate' slot} #{QF.showTime' queryTimeFmt slot}
(#{toPathPiece queryTzLabel})
<div .form-group>
<label>Where
<p .form-control-static>
#{locDescr queryLocation}
^{widget}
<button type=submit .btn .btn-primary>Book it
|]
defaultLayout $ do
setTitle "Book an appointment"
$(widgetFile "confirm")
postConfirmR :: Handler Html
postConfirmR = do
......@@ -127,10 +113,13 @@ postConfirmR = do
, seAttendees = [Attendee bookName bookEmail]
}
FC.invalidateCache appCalendarCache
defaultLayout
[whamlet|
<p>#{tshow b}
<p>#{tshow q}
<p>#{tshow utcStart}
<p>#{tshow e}
|]
defaultLayout $ do
setTitle "Appointment created"
$(widgetFile "final")
getFinalR :: Handler Html
getFinalR = do
defaultLayout $ do
setTitle "Appointment details"
[whamlet|OKOK|]
-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module: Handlers
Description: TODO
TODO
-}
module Handlers
( getFaviconR
, getRobotsR
, getHomeR
, getAvailR
, postHomeR
, getBookR
, postBookR
, getFinalR
) where
import qualified BookingForm as BF
import Calendar
import Control.Monad.Trans.Maybe
import Data.FileEmbed (embedFile)
import qualified Data.SortedList as SL
import qualified FreshCache as FC
import Import
import qualified QueryForm as QF
import Text.Hamlet (shamletFile)
import Text.Julius (RawJS (..))
-- | Home page, which shows query settings. Also has an AJAX facility
-- to get the available slots and show them as buttons.
getHomeR :: Handler Html
getHomeR
-- Start refresh of calendar, but don't wait for result.
= do
App {appCalendarCache} <- getYesod
void $ async $ FC.readCache appCalendarCache
-- Produce form for query and display parameters: appointment length,
-- 12/24-hour time, time zone, location.
qOpt <- runMaybeT QF.fromSession
(queryWidget, enctype) <- generateFormPost $ QF.queryForm qOpt
(idSpinner, idAvail, idAlert) <- newIdent3
defaultLayout $(widgetFile "homepage")
-- | Ensure a successful form submission, or else throw a 400.
formSuccess :: MonadHandler m => ((FormResult a, b), c) -> m a
formSuccess ((formResult, _), _) =
case formResult of
FormMissing -> invalidArgs ["Missing form data!"]
FormFailure errors -> invalidArgs errors
FormSuccess result -> return result
-- | AJAX facility to retrieve available times matching the query
-- parameters, and show them as buttons.
getAvailR :: Handler Html
getAvailR = do
QF.QueryForm {..} <- formSuccess =<< runFormGet (QF.queryForm Nothing)
App { appSettings = AppSettings {appApptLengthsMinutes, appLookaheadWeeks}
, appCalendarCache
} <- getYesod
daysWithSlots <-
groupByDay .
SL.map (applyTz (tzByLabel queryTzLabel)) .
partitionSlots (headMay appApptLengthsMinutes) queryApptLength .
SL.filter (summaryMatches (locSearch queryLocation)) <$>
FC.readCache appCalendarCache
return $(shamletFile "templates/avail.hamlet")
postHomeR :: Handler Html
postHomeR = do
q@QF.QueryForm {..} <- formSuccess =<< runFormPost (QF.queryForm Nothing)
slot <- runInputPost QF.timeInput
QF.toSessionWithSlot q slot
redirect BookR
-- | Show for to collect client's personal data.
getBookR :: Handler Html
getBookR = do
(QF.QueryForm {..}, QF.TimeSlot {..}) <- QF.fromSessionWithSlot
(bookWidget, enctype) <- generateFormPost BF.bookingMForm
defaultLayout $(widgetFile "confirm")
postBookR :: Handler Html
postBookR = do
(q, slot) <- QF.fromSessionWithSlot
b <- formSuccess =<< runFormPost BF.bookingMForm
BF.toSession b
let event = BF.eventFromBooking b q slot
matches e =
summaryMatches (locSearch (QF.queryLocation q)) e && event `isWithin` e
App {..} <- getYesod
r <- find matches . SL.fromSortedList <$> FC.readCache appCalendarCache
case r of
Nothing -> do
setMessage "Selected time is no longer available! Please try again."
redirect HomeR
Just _ -> do
addEvent appCalendarCxt (appBusyCalendarId appSettings) event
FC.invalidateCache appCalendarCache
redirect FinalR
getFinalR :: Handler Html
getFinalR = do
(q, QF.TimeSlot {..}) <- QF.fromSessionWithSlot
b <- BF.fromSession
defaultLayout
[whamlet|
<p>#{tshow q}
<p>#{tshow slotLocal}
<p>#{tshow b}
|]
-- These handlers embed files in the executable at compile time to avoid a
-- runtime dependency, and for efficiency.
getFaviconR :: Handler TypedContent
getFaviconR = do
cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month
return $
TypedContent "image/x-icon" $ toContent $(embedFile "config/favicon.ico")
getRobotsR :: Handler TypedContent
getRobotsR =
return $ TypedContent typePlain $ toContent $(embedFile "config/robots.txt")
......@@ -4,3 +4,6 @@ module Import
import Foundation as Import
import Import.NoFoundation as Import
newIdent3 :: MonadHandler m => m (Text, Text, Text)
newIdent3 = (,,) <$> newIdent <*> newIdent <*> newIdent
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-|
Module: QueryForm
......@@ -15,33 +16,41 @@ Form for front page, to query available times. Consists of the
location, appointment length, time format, and time zone.
-}
module QueryForm
( QueryForm(..)
, TimeFmt(..)
, Slot(..)
, queryForm
, showDate
, showDate'
, showTime
, showTime'
, getLocationById
, parseLocationField
( TimeFmt(..)
, QueryForm(..)
, QueryName(qiName)
, idApptLength
, idTimeFmt
, idTzLabel
, idLocation
, idSlot
, toParams
, toSession
, fromSession
, queryForm
, TimeSlot(..)
, idTimeSlot
, timeInput
, toSessionWithSlot
, fromSessionWithSlot
, noSessionError
, showDate
, showTime
) where
import qualified Data.Time.Format as TF
import Data.Time.LocalTime (LocalTime)
import Control.Monad.Trans.Maybe
import qualified Data.Time.Format as TF
import Data.Time.LocalTime (LocalTime)
import Import
import Text.Julius (RawJS (..))
import Text.Blaze (ToMarkup (..))
import Text.Julius (RawJS (..), ToJavascript (..))
-- | Times can be displayed in 12- or 24-hour format.
data TimeFmt
= Time12h
| Time24h
deriving (Eq, Show, Enum, Bounded)
-- | Time format serialization for session and GET/POST parameters.
instance PathPiece TimeFmt where
toPathPiece Time12h = "12h"
toPathPiece Time24h = "24h"
......@@ -49,59 +58,124 @@ instance PathPiece TimeFmt where
fromPathPiece "24h" = Just Time24h
fromPathPiece _ = Nothing
-- | Default is 12-hour time.
instance Default TimeFmt where
def = Time12h
newtype Slot = Slot
{ slotLocal :: LocalTime
} deriving (Show)
instance PathPiece Slot where
toPathPiece = tshow . slotLocal
fromPathPiece t = Slot <$> readMay t
-- | Format strings to be used with 'Data.Time.Format'.
timeFmt :: TimeFmt -> String
timeFmt Time12h = "%l:%M %p"
timeFmt Time24h = "%H:%M"
-- | Query data from the front page. The time slot chosen will be
-- packaged separately.
data QueryForm = QueryForm
{ queryApptLength :: Int
, queryTimeFmt :: TimeFmt
, queryTzLabel :: TZLabelW
, queryLocation :: Location
, querySlot :: Maybe Slot
} deriving (Show)
idApptLength :: Text
idTimeFmt :: Text
idTzLabel :: Text
idLocation :: Text
idSlot :: Text
idApptLength = "len"
-- | Represent field names used in a form. This abstraction gives
-- cleaner access to fields from jQuery and JS.
data QueryName
= QueryInput { qiName :: Text }
| QuerySelect { qiName :: Text }
| QueryChecked { qiName :: Text }
deriving (Eq, Show)
idTimeFmt = "fmt"
instance ToJavascript QueryName where
toJavascript = toJavascript . String . qiName
instance ToMarkup QueryName where
toMarkup = toMarkup . qiName
-- | Produce a jQuery selector for the given field name.
qiSelector :: QueryName -> Value
qiSelector qi =
case qi of
QueryInput n -> sel "input" n ""
QuerySelect n -> sel "select" n ""
QueryChecked n -> sel "input" n ":checked"
where
sel elt nm attr = String $ elt <> "[name=" <> nm <> "]" <> attr
-- | Name of the appointment-length field.
idApptLength :: QueryName
idApptLength = QuerySelect "len"
-- | Name of the time format field.
idTimeFmt :: QueryName
idTimeFmt = QuerySelect "fmt"
-- | Name of the time zone field.
idTzLabel :: QueryName
idTzLabel = QueryInput "tz"
-- | Name of the location field.
idLocation :: QueryName
idLocation = QueryChecked "loc"
-- | Serialize the query settings to a set of HTTP parameters.
toParams :: QueryForm -> [(Text, Text)]
toParams QueryForm {..} =
[ (qiName idApptLength, toPathPiece queryApptLength)
, (qiName idTimeFmt, toPathPiece queryTimeFmt)
, (qiName idTzLabel, toPathPiece queryTzLabel)
, (qiName idLocation, locId queryLocation)
]
-- | Save query settings to session.
toSession :: MonadHandler m => QueryForm -> m ()
toSession = mapM_ (uncurry setSession) . toParams
-- | A version of 'lookupSession' that uses 'QueryName' and 'MaybeT'.
lookupSession' :: MonadHandler m => QueryName -> MaybeT m Text
lookupSession' = MaybeT . lookupSession . qiName
-- | Get a path piece name from the session.
getSessionField :: (MonadHandler m, PathPiece a) => QueryName -> MaybeT m a
getSessionField = lookupSession' >=> MaybeT . pure . fromPathPiece
-- | Look up a location by ID.
getLocationById :: Text -> MaybeT Handler Location
getLocationById i = do
MaybeT $ find ((== i) . locId) . appLocations . appSettings <$> getYesod
idTzLabel = "tz"
-- | Get query location from session.
getLocationFromSession :: MaybeT Handler Location
getLocationFromSession = lookupSession' idLocation >>= getLocationById
idLocation = "loc"
-- | Retrieve query settings from session.
fromSession :: MaybeT Handler QueryForm
fromSession =
QueryForm <$> getSessionField idApptLength <*> getSessionField idTimeFmt <*>
getSessionField idTzLabel <*>
getLocationFromSession
idSlot = "slot"
-- | Option field for appointment length.
apptLengthOption :: Int -> Option Int
apptLengthOption m =
Option
{ optionDisplay = tshow m <> " minute"
, optionInternalValue = m
, optionExternalValue = tshow m
}
-- | Option list for all supported appointment lengths.
apptLengthOptions :: Handler (OptionList Int)
apptLengthOptions = do
lengths <- appApptLengthsMinutes . appSettings <$> getYesod
let toOption m =
Option
{ optionDisplay = tshow m <> " minute"
, optionInternalValue = m
, optionExternalValue = tshow m
}
okLength m =
if m `elem` lengths
then Just m
else Nothing
return $
let ok n
| n `elem` lengths = Just n
ok _ = Nothing
return
OptionList
{ olOptions = map toOption lengths
, olReadExternal = fromPathPiece >=> okLength
{ olOptions = map apptLengthOption lengths
, olReadExternal = fromPathPiece >=> ok
}
-- | Option list for supported time formats.
timeFmtOptions :: Handler (OptionList TimeFmt)
timeFmtOptions =
return $
......@@ -113,72 +187,91 @@ timeFmtOptions =