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

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
This diff is collapsed.
......@@ -53,10 +53,6 @@ data Location = Location
, locDescr :: Text -- ^ Description of location
} deriving (Show, Eq)
instance PathPiece Location where
toPathPiece = locId
fromPathPiece _ = Nothing -- Warning: not a round-trip!
-- | Construct locations, adding IDs like "locA", "locB".
makeLocs :: [(Text, Text)] -> [Location]
makeLocs = zipWith mk ['A' ..]
......
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-|
Module: TamperResistant
Description: TODO
TODO
-}
module TamperResistant
( TamperResistant(..)
) where
import ClassyPrelude.Yesod
import qualified Data.Binary as Bin
import qualified Data.ByteString.Base64 as B64
-- | A wrapper that adds some characters to the PathPiece
-- representation to detect casual tampering. This isn't safe against a
-- determined opponent, so make sure there's another validity check
-- too.
newtype TamperResistant a = TamperResistant
{ untamper :: a
} deriving (Show)
-- | Produce an ASCII string representing a simple checksum.
checksum :: Hashable a => a -> Text
checksum = decodeUtf8 . B64.encode . toStrict . Bin.encode . hash
-- | This cannot be a character that is used in Base64.
separator :: Char
separator = '*'
instance PathPiece a => PathPiece (TamperResistant a) where
toPathPiece (TamperResistant a) = checksum p <> singleton separator <> p
where
p = toPathPiece a
fromPathPiece = verify . (id *** drop 1) . break (== separator)
where
verify (s, p)
| s == checksum p = TamperResistant <$> fromPathPiece p
| otherwise = Nothing
$if null daysWithSlots
No appointments available in the next #{pluralN appLookaheadWeeks "week" "weeks"}.
$else
$forall eachDay <- daysWithSlots
$maybe firstSlot <- headMay eachDay
<h4>#{QF.showDate $ seStart firstSlot}
<p .slot-choices>
$forall eachSlot <- eachDay
<button type=submit name=#{QF.idTimeSlot}
value=#{toPathPiece $ QF.TimeSlot $ seStart eachSlot}
.btn.btn-default.btn-small>
#{QF.showTime queryTimeFmt $ seStart eachSlot}
<h1>Book an appointment
<form role=form method=post action=@{BookR} enctype=#{enctype}>
<div .form-group>
<label>When
<p .form-control-static>
#{QF.showDate slotLocal} #{QF.showTime queryTimeFmt slotLocal}
(#{toPathPiece queryTzLabel})
<div .form-group>
<label>Where
<p .form-control-static>
#{locDescr queryLocation}
^{bookWidget}
<button type=submit .btn .btn-primary>Book it
<p>
Thanks #{bookName}, your appointment details are below. You should
also receive a meeting invitation at your email
address, #
<b>#{bookEmail}#
. Please click the “Yes” link in that message to confirm.
<p>
Should you need to cancel, please click the “No” link and reply to the
message.
<div .form-group>
<label>Subject
<p .form-control-static>
#{bookSubject}
$maybe ct <- bookContact
<div .form-group>
<label>Contact information
<p .form-control-static>
#{ct}
<h2>Book an appointment
<form enctype=#{enctype} method=POST action=@{HomeR}>
^{widget}
<h1>Book an appointment
<form method=post action=@{HomeR} enctype=#{enctype}>
^{queryWidget}
<div ##{idAvail} style="display:none">
<p ##{idSpinner} style="font-size:150%">
......
......@@ -2,7 +2,7 @@
<p>
Show
^{fvInput lenView}
slots using
meeting times using
^{fvInput fmtView}
notation in
#{toPathPiece appDefaultTimeZone}
......
......@@ -5,9 +5,9 @@ $(function(){
function gatherQueryParams() {
return $.param({
_hasdata: 1,
#{rawJS idTzLabel}: $("##{rawJS idTzLabel}").val(),
#{rawJS idApptLength}: $("##{rawJS idApptLength}").val(),
#{rawJS idTimeFmt}: $("##{rawJS idTimeFmt}").val(),
#{rawJS idLocation}: $("input[name=#{rawJS idLocation}]:checked").val(),
#{idTzLabel}: $(#{qiSelector idTzLabel}).val(),
#{idApptLength}: $(#{qiSelector idApptLength}).val(),
#{idTimeFmt}: $(#{qiSelector idTimeFmt}).val(),
#{idLocation}: $(#{qiSelector idLocation}).val(),
});
}
<div .form-group>
$forall loc <- locs
<div .radio>
<label>
<input ##{i}-#{locId loc} name=#{name} type=radio
value=#{locId loc} :val == Right loc:checked
*{attrs}>
#{locDescr loc}
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