Skip to content

GitLab

Commit 96de7e74 authored by Christopher League's avatar Christopher League 🖥
Browse files
Options

Progress in QueryForm/BookingForm interaction

parent ae8c5aa6
Hide whitespace changes
Inline Side-by-side
Showing with 249 additions and 331 deletions
config/routes
View file @ 96de7e74
...@@ -6,6 +6,6 @@ ...@@ -6,6 +6,6 @@
/favicon.ico FaviconR GET /favicon.ico FaviconR GET
/robots.txt RobotsR GET /robots.txt RobotsR GET
/ HomeR GET / HomeR GET POST
/confirm ConfirmR POST
/available AvailR GET /available AvailR GET
/confirm ConfirmR POST
src/BookingForm.hs 0 → 100644
View file @ 96de7e74
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-|
Module: BookingForm
Description: TODO
TODO
-}
module BookingForm
( Booking(..)
, bookingForm
) where
import Import
import QueryForm
import Data.Time.LocalTime (LocalTime)
import qualified Yesod.Form.Bootstrap3 as B3
data Booking =
Booking
{ bookName :: Text
, bookEmail :: Text
, bookContact :: Maybe Text
, bookSubject :: Text
} deriving (Show)
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}>
|]
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
src/Foundation.hs
View file @ 96de7e74
...@@ -109,14 +109,6 @@ instance Yesod App where ...@@ -109,14 +109,6 @@ instance Yesod App where
defaultLayout widget = do defaultLayout widget = do
master <- getYesod master <- getYesod
mmsg <- getMessage mmsg <- getMessage
mcurrentRoute <- getCurrentRoute
-- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
(title, parents) <- breadcrumbs
-- We break up the default layout into two components:
-- default-layout is the contents of the body tag, and
-- default-layout-wrapper is the entire page. Since the final
-- value passed to hamletToRepHtml cannot be a widget, this allows
-- you to use normal widget features in default-layout.
pc <- pc <-
widgetToPageContent $ do widgetToPageContent $ do
let fontFamily = let fontFamily =
......
src/Handler/Home.hs
View file @ 96de7e74
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
...@@ -10,11 +10,14 @@ ...@@ -10,11 +10,14 @@
module Handler.Home where module Handler.Home where
import qualified Calendar as Cal import qualified Calendar as Cal
import Control.Monad.Logger (logInfoN)
import Data.Time.LocalTime (LocalTime)
import Yesod.Form.Bootstrap3
import Import import Import
import Text.Julius (RawJS (..)) import qualified QueryForm as QF
import Data.Time.LocalTime (LocalTime) import qualified BookingForm as BF
import qualified QueryForm as QF import Text.Julius (RawJS (..))
getHomeR :: Handler Html getHomeR :: Handler Html
getHomeR = do getHomeR = do
...@@ -23,48 +26,73 @@ getHomeR = do ...@@ -23,48 +26,73 @@ getHomeR = do
void $ async $ appGetCalendar Nothing void $ async $ appGetCalendar Nothing
(widget, enctype) <- generateFormPost QF.queryForm (widget, enctype) <- generateFormPost QF.queryForm
(idSpinner, idAvail, idAlert) <- (,,) <$> newIdent <*> newIdent <*> newIdent (idSpinner, idAvail, idAlert) <- (,,) <$> newIdent <*> newIdent <*> newIdent
defaultLayout $(widgetFile "step1") defaultLayout $(widgetFile "homepage")
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
showD = QF.showDate . Cal.seStart
showT fmt = QF.showTime fmt . Cal.seStart
slotVal = tshow . Cal.seStart
getAvailR :: Handler Html getAvailR :: Handler Html
getAvailR = getAvailR = do
fst . fst <$> runFormGet QF.queryForm >>= \case QF.QueryForm{..} <- formSuccess =<< runFormGet QF.queryForm
FormMissing -> invalidArgs ["missing"] App {appSettings = AppSettings {..}, ..} <- getYesod
FormFailure errs -> invalidArgs errs let tz = tzByLabel queryTzLabel
FormSuccess QF.QueryForm{..} -> do avail <-
App {appSettings = AppSettings {..}, ..} <- getYesod Cal.groupByDay .
let tz = tzByLabel queryTzLabel map (Cal.applyTz tz) .
showT = QF.showTime queryTimeFmt . Cal.seStart Cal.partitionSlots queryApptLength .
showD = QF.showDate . Cal.seStart filter (isInfixOf (locSearch queryLocation) . Cal.seSummary) <$>
slotVal = tshow . Cal.seStart appGetCalendar Nothing
avail <- withUrlRenderer
Cal.groupByDay . [hamlet|
map (Cal.applyTz tz) . $if null avail
Cal.partitionSlots queryApptLength . No appointments available in the next #{pluralN appLookaheadWeeks "week" "weeks"}.
filter (isInfixOf (locSearch queryLocation) . Cal.seSummary) <$> $forall eachDay <- avail
appGetCalendar Nothing $maybe firstSlot <- headMay eachDay
withUrlRenderer <h4>#{showD firstSlot}
[hamlet| <p .slot-choices>
$if null avail $forall eachSlot <- eachDay
No appointments available in the next #{pluralN appLookaheadWeeks "week" "weeks"}. <button type=submit name=slot value=#{slotVal eachSlot}
$forall eachDay <- avail .btn.btn-default.btn-small>
$maybe firstSlot <- headMay eachDay #{showT queryTimeFmt eachSlot}
<h4>#{showD firstSlot} |]
<p .slot-choices>
$forall eachSlot <- eachDay
<button type=submit name=slot value=#{slotVal eachSlot} .btn.btn-default.btn-small>#{showT eachSlot}
|]
postConfirmR :: Handler Html postHomeR :: Handler Html
postConfirmR = do postHomeR = do
((qr, _), _) <- runFormPost QF.queryForm q@QF.QueryForm {..} <- formSuccess =<< runFormPost QF.queryForm
let zz :: Maybe LocalTime slot <- maybe (invalidArgs ["Missing time slot"]) (return . QF.slotLocal) querySlot
zz = case qr of (widget, enctype) <- generateFormPost
FormSuccess QF.QueryForm{QF.querySlot = Just txt} -> readMay txt $ renderBootstrap3 BootstrapBasicForm
$ BF.bookingForm q
defaultLayout defaultLayout
[whamlet| [whamlet|
<p>OK? <p>OK?
<p> <p>#{tshow q}
#{tshow qr} <form role=form method=post action=@{ConfirmR} enctype=#{enctype}>
<p> <input type=hidden name=#{QF.idApptLength} value=#{toPathPiece queryApptLength}>
#{tshow zz} <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}>
<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
|]
postConfirmR :: Handler Html
postConfirmR = error "postConfirmR"
src/QueryForm.hs
View file @ 96de7e74
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
...@@ -16,9 +17,17 @@ location, appointment length, time format, and time zone. ...@@ -16,9 +17,17 @@ location, appointment length, time format, and time zone.
module QueryForm module QueryForm
( QueryForm(..) ( QueryForm(..)
, TimeFmt(..) , TimeFmt(..)
, Slot(..)
, queryForm , queryForm
, showDate , showDate
, showTime , showTime
, getLocationById
, parseLocationField
, idApptLength
, idTimeFmt
, idTzLabel
, idLocation
, idSlot
) where ) where
import qualified Data.Time.Format as TF import qualified Data.Time.Format as TF
...@@ -41,14 +50,33 @@ instance PathPiece TimeFmt where ...@@ -41,14 +50,33 @@ instance PathPiece TimeFmt where
instance Default TimeFmt where instance Default TimeFmt where
def = Time12h def = Time12h
newtype Slot = Slot { slotLocal :: LocalTime }
deriving Show
instance PathPiece Slot where
toPathPiece = tshow . slotLocal
fromPathPiece t = Slot <$> readMay t
data QueryForm = QueryForm data QueryForm = QueryForm
{ queryApptLength :: Int { queryApptLength :: Int
, queryTimeFmt :: TimeFmt , queryTimeFmt :: TimeFmt
, queryTzLabel :: TZLabelW , queryTzLabel :: TZLabelW
, queryLocation :: Location , queryLocation :: Location
, querySlot :: Maybe Text -- TBD , querySlot :: Maybe Slot
} deriving (Show) } deriving (Show)
idApptLength :: Text
idTimeFmt :: Text
idTzLabel :: Text
idLocation :: Text
idSlot :: Text
idApptLength = "len"
idTimeFmt = "fmt"
idTzLabel = "tz"
idLocation = "loc"
idSlot = "slot"
apptLengthOptions :: Handler (OptionList Int) apptLengthOptions :: Handler (OptionList Int)
apptLengthOptions = do apptLengthOptions = do
lengths <- appApptLengthsMinutes . appSettings <$> getYesod lengths <- appApptLengthsMinutes . appSettings <$> getYesod
...@@ -79,16 +107,23 @@ timeFmtOptions = ...@@ -79,16 +107,23 @@ timeFmtOptions =
] ]
} }
locationField :: Field Handler Location getLocationById :: Text -> Handler (Maybe Location)
locationField = Field {..} getLocationById i = do
find ((== i) . locId) . appLocations . appSettings <$> getYesod
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
locationChoiceField :: Field Handler Location
locationChoiceField = Field {..}
where where
fieldParse [] _ = return $ Left $ SomeMessage $ MsgInputNotFound "location" fieldEnctype = UrlEncoded
fieldParse (txt:_) _ = do fieldParse = parseLocationField
locs <- appLocations . appSettings <$> getYesod
return $
case find ((== txt) . locId) locs of
Nothing -> Left $ SomeMessage $ MsgInvalidEntry txt
Just loc -> Right $ Just loc
fieldView i _ attrs val _ = do fieldView i _ attrs val _ = do
locs <- appLocations . appSettings <$> getYesod locs <- appLocations . appSettings <$> getYesod
[whamlet| [whamlet|
...@@ -101,7 +136,7 @@ locationField = Field {..} ...@@ -101,7 +136,7 @@ locationField = Field {..}
*{attrs}> *{attrs}>
#{locDescr loc} #{locDescr loc}
|] |]
fieldEnctype = UrlEncoded
queryForm :: Html -> MForm Handler (FormResult QueryForm, Widget) queryForm :: Html -> MForm Handler (FormResult QueryForm, Widget)
queryForm extra = do queryForm extra = do
...@@ -111,14 +146,15 @@ queryForm extra = do ...@@ -111,14 +146,15 @@ queryForm extra = do
(lenRes, lenView) <- (lenRes, lenView) <-
mreq mreq
(selectField apptLengthOptions) (selectField apptLengthOptions)
(qs "len") (qs idApptLength)
(headMay appApptLengthsMinutes) (headMay appApptLengthsMinutes)
(fmtRes, fmtView) <- mreq (selectField timeFmtOptions) (qs "fmt") (Just def) (fmtRes, fmtView) <- mreq (selectField timeFmtOptions) (qs idTimeFmt) (Just def)
(locRes, locView) <- mreq locationField (qs "loc") (headMay appLocations) (locRes, locView) <- mreq locationChoiceField (qs idLocation) (headMay appLocations)
(slotRes, _) <- mopt textField (qs "slot") Nothing (slotRes, _) <- mopt textField (qs idSlot) Nothing
(tzRes, _) <- mreq hiddenField (qs idTzLabel) (Just appDefaultTimeZone)
let q = let q =
QueryForm <$> lenRes <*> fmtRes <*> pure appDefaultTimeZone <*> locRes <*> QueryForm <$> lenRes <*> fmtRes <*> tzRes <*> locRes <*>
slotRes ((>>= fromPathPiece) <$> slotRes)
widget = $(widgetFile "query-form") widget = $(widgetFile "query-form")
return (q, widget) return (q, widget)
......
src/Settings.hs
View file @ 96de7e74
...@@ -53,6 +53,10 @@ data Location = Location ...@@ -53,6 +53,10 @@ data Location = Location
, locDescr :: Text -- ^ Description of location , locDescr :: Text -- ^ Description of location
} deriving (Show, Eq) } deriving (Show, Eq)
instance PathPiece Location where
toPathPiece = locId
fromPathPiece _ = Nothing -- Warning: not a round-trip!
-- | Construct locations, adding IDs like "locA", "locB". -- | Construct locations, adding IDs like "locA", "locB".
makeLocs :: [(Text, Text)] -> [Location] makeLocs :: [(Text, Text)] -> [Location]
makeLocs = zipWith mk ['A' ..] makeLocs = zipWith mk ['A' ..]
......
templates/default-layout.hamlet
View file @ 96de7e74
<!-- Page Contents -->
<div .container> <div .container>
$if not $ Just HomeR == mcurrentRoute $maybe msg <- mmsg
<ul .breadcrumb> <div .alert.alert-info #message>#{msg}
$forall bc <- parents
<li>
<a href="@{fst bc}">#{snd bc}
<li .active>#{title}
$maybe msg <- mmsg
<div .alert.alert-info #message>#{msg}
<div .container> <div .container>
<div .row> <div .row>
<div .col-md-12> <div .col-md-12>
^{widget} ^{widget}
templates/homepage.hamlet
View file @ 96de7e74
<div .masthead> <h2>Book an appointment
<div .container>
<div .row>
<h1 .header>
Yesod—a modern framework for blazing fast websites
<h2>
Fast, stable & spiced with great community
<a href="http://www.yesodweb.com/book/" .btn.btn-info.btn-lg>
Read the Book
<div .container> <form enctype=#{enctype} method=POST action=@{HomeR}>
<!-- Starting ^{widget}
================================================== -->
<div .bs-docs-section>
<div .row>
<div .col-lg-12>
<div .page-header>
<h1 #start>Starting
<p> <div ##{idAvail} style="display:none">
Now that you have a working project you should use the
<a href=http://www.yesodweb.com/book/>Yesod book</a> to learn more.
<p>
You can also use this scaffolded site to explore some concepts, and best practices.
<ul .list-group> <p ##{idSpinner} style="font-size:150%">
<span .glyphicon.glyphicon-off.fast-right-spinner>
<li .list-group-item> <div ##{idAlert} .alert.alert-danger style="display:none" role=alert>
This page was generated by the <tt>#{handlerName}</tt> handler in <p>
<tt>Handler/Home.hs</tt>. <b>Oops
<li .list-group-item>
The <tt>#{handlerName}</tt> handler is set to generate your
site's home screen in Routes file
<tt>config/routes
<li .list-group-item>
The HTML you are seeing now is actually composed by a number of <em>widgets</em>, #
most of them are brought together by the <tt>defaultLayout</tt> function which #
is defined in the <tt>Foundation.hs</tt> module, and used by <tt>#{handlerName}</tt>. #
All the files for templates and wigdets are in <tt>templates</tt>.
<li .list-group-item>
A Widget's Html, Css and Javascript are separated in three files with the
<tt>.hamlet</tt>, <tt>.lucius</tt> and <tt>.julius</tt> extensions.
<li .list-group-item ##{aDomId}>
If you had javascript enabled then you wouldn't be seeing this.
<hr>
<!-- Forms
================================================== -->
<div .bs-docs-section>
<div .row>
<div .col-lg-12>
<div .page-header>
<h1 #forms>Forms
<p>
This is an example of a form. Read the
<a href="http://www.yesodweb.com/book/forms">Forms chapter</a> #
on the yesod book to learn more about them.
<div .row>
<div .col-lg-6>
<div .bs-callout bs-callout-info well>
<form .form-horizontal method=post action=@{HomeR}#forms enctype=#{formEnctype}>
^{formWidget}
<button .btn.btn-primary type="submit">
Upload it!
<div .col-lg-4.col-lg-offset-1>
<div .bs-callout.bs-callout-info.upload-response>
$maybe (FileForm info con) <- submission
Your file type is <em>#{fileContentType info}</em>. You say it has: <em>#{con}</em>
$nothing
File upload result will be here...
<hr>
<!-- JSON
================================================== -->
<div .bs-docs-section>
<div .row>
<div .col-lg-12>
<div .page-header>
<h1 #json>JSON
<p>
Yesod has JSON support baked-in.
The form below makes an AJAX request with Javascript,
then updates the page with your submission.
(see <tt>Handler/Comment.hs</tt>, <tt>templates/homepage.julius</tt>,
and <tt>Handler/Home.hs</tt> for the implementation).
<div .row>
<div .col-lg-6>
<div .bs-callout.bs-callout-info.well>
<form .form-horizontal ##{commentFormId}>
<div .field>
<textarea rows="2" ##{commentTextareaId} placeholder="Your comment here..." required></textarea>
<button .btn.btn-primary type=submit>
Create comment
<div .col-lg-4.col-lg-offset-1>
<div .bs-callout.bs-callout-info>
<small>
Your comments will appear here. You can also open the
console log to see the raw response from the server.
<ul ##{commentListId}>
<hr>
<!-- Testing
================================================== -->
<div .bs-docs-section>
<div .row>
<div .col-lg-12>
<div .page-header>
<h1 #test>Testing
<p>
And last but not least, Testing. In <tt>test/Spec.hs</tt> you will find a #
test suite that performs tests on this page.
<p>
You can run your tests by doing: <code>stack test</code>
templates/homepage.julius
View file @ 96de7e74
document.getElementById(#{toJSON aDomId}).innerHTML = "This text was added by the Javascript part of the homepage widget."; // -*- js -*-
$(function() { function sendQuery() {
$("##{rawJS commentFormId}").submit(function(event) { $("##{rawJS idSpinner}").show();
event.preventDefault(); $("##{rawJS idAvail}").hide();
var url = "@{AvailR}?" + gatherQueryParams();
var message = $("##{rawJS commentTextareaId}").val();
// (Browsers that enforce the "required" attribute on the textarea won't see this alert)
if (!message) {
alert("Please fill out the comment form first.");
return;
}
// Make an AJAX request to the server to create a new comment
$.ajax({ $.ajax({
url: '@{CommentR}', url: url,
type: 'POST', success: function(data) {
contentType: "application/json", $("##{rawJS idAvail}").html(data);
data: JSON.stringify({ $("##{rawJS idAvail}").show();
message: message, },
}), error: function(data) {
success: function (data) { $("##{rawJS idAlert}").html(data.statusText).show();
var newNode = $("<li></li>"); },
newNode.text(data.message); complete: function() {
console.log(data); $("##{rawJS idSpinner}").hide();
$("##{rawJS commentListId}").append(newNode); },
}, })
error: function (data) { }
console.log("Error creating comment: " + data);
},
});
});
});
templates/homepage.lucius
View file @ 96de7e74
h2##{aDomId} { /* step1.lucius -*- css -*- */
color: #990