Commit 96de7e74 authored by Christopher League's avatar Christopher League 🖥

Progress in QueryForm/BookingForm interaction

parent ae8c5aa6
......@@ -6,6 +6,6 @@
/favicon.ico FaviconR GET
/robots.txt RobotsR GET
/ HomeR GET
/confirm ConfirmR POST
/ HomeR GET POST
/available AvailR GET
/confirm ConfirmR POST
{-# 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
......@@ -109,14 +109,6 @@ instance Yesod App where
defaultLayout widget = do
master <- getYesod
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 <-
widgetToPageContent $ do
let fontFamily =
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
......@@ -10,11 +10,14 @@
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 Text.Julius (RawJS (..))
import Data.Time.LocalTime (LocalTime)
import qualified QueryForm as QF
import qualified QueryForm as QF
import qualified BookingForm as BF
import Text.Julius (RawJS (..))
getHomeR :: Handler Html
getHomeR = do
......@@ -23,48 +26,73 @@ getHomeR = do
void $ async $ appGetCalendar Nothing
(widget, enctype) <- generateFormPost QF.queryForm
(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 =
fst . fst <$> runFormGet QF.queryForm >>= \case
FormMissing -> invalidArgs ["missing"]
FormFailure errs -> invalidArgs errs
FormSuccess QF.QueryForm{..} -> do
App {appSettings = AppSettings {..}, ..} <- getYesod
let tz = tzByLabel queryTzLabel
showT = QF.showTime queryTimeFmt . Cal.seStart
showD = QF.showDate . Cal.seStart
slotVal = tshow . Cal.seStart
avail <-
Cal.groupByDay .
map (Cal.applyTz tz) .
Cal.partitionSlots queryApptLength .
filter (isInfixOf (locSearch queryLocation) . Cal.seSummary) <$>
appGetCalendar Nothing
withUrlRenderer
[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 eachSlot}
|]
getAvailR = do
QF.QueryForm{..} <- formSuccess =<< runFormGet QF.queryForm
App {appSettings = AppSettings {..}, ..} <- getYesod
let tz = tzByLabel queryTzLabel
avail <-
Cal.groupByDay .
map (Cal.applyTz tz) .
Cal.partitionSlots queryApptLength .
filter (isInfixOf (locSearch queryLocation) . Cal.seSummary) <$>
appGetCalendar Nothing
withUrlRenderer
[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}
|]
postConfirmR :: Handler Html
postConfirmR = do
((qr, _), _) <- runFormPost QF.queryForm
let zz :: Maybe LocalTime
zz = case qr of
FormSuccess QF.QueryForm{QF.querySlot = Just txt} -> readMay txt
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
defaultLayout
[whamlet|
<p>OK?
<p>
#{tshow qr}
<p>
#{tshow zz}
|]
<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 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"
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
......@@ -16,9 +17,17 @@ location, appointment length, time format, and time zone.
module QueryForm
( QueryForm(..)
, TimeFmt(..)
, Slot(..)
, queryForm
, showDate
, showTime
, getLocationById
, parseLocationField
, idApptLength
, idTimeFmt
, idTzLabel
, idLocation
, idSlot
) where
import qualified Data.Time.Format as TF
......@@ -41,14 +50,33 @@ instance PathPiece TimeFmt where
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
data QueryForm = QueryForm
{ queryApptLength :: Int
, queryTimeFmt :: TimeFmt
, queryTzLabel :: TZLabelW
, queryLocation :: Location
, querySlot :: Maybe Text -- TBD
, querySlot :: Maybe Slot
} 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 = do
lengths <- appApptLengthsMinutes . appSettings <$> getYesod
......@@ -79,16 +107,23 @@ timeFmtOptions =
]
}
locationField :: Field Handler Location
locationField = Field {..}
getLocationById :: Text -> Handler (Maybe Location)
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
fieldParse [] _ = return $ Left $ SomeMessage $ MsgInputNotFound "location"
fieldParse (txt:_) _ = do
locs <- appLocations . appSettings <$> getYesod
return $
case find ((== txt) . locId) locs of
Nothing -> Left $ SomeMessage $ MsgInvalidEntry txt
Just loc -> Right $ Just loc
fieldEnctype = UrlEncoded
fieldParse = parseLocationField
fieldView i _ attrs val _ = do
locs <- appLocations . appSettings <$> getYesod
[whamlet|
......@@ -101,7 +136,7 @@ locationField = Field {..}
*{attrs}>
#{locDescr loc}
|]
fieldEnctype = UrlEncoded
queryForm :: Html -> MForm Handler (FormResult QueryForm, Widget)
queryForm extra = do
......@@ -111,14 +146,15 @@ queryForm extra = do
(lenRes, lenView) <-
mreq
(selectField apptLengthOptions)
(qs "len")
(qs idApptLength)
(headMay appApptLengthsMinutes)
(fmtRes, fmtView) <- mreq (selectField timeFmtOptions) (qs "fmt") (Just def)
(locRes, locView) <- mreq locationField (qs "loc") (headMay appLocations)
(slotRes, _) <- mopt textField (qs "slot") Nothing
(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 =
QueryForm <$> lenRes <*> fmtRes <*> pure appDefaultTimeZone <*> locRes <*>
slotRes
QueryForm <$> lenRes <*> fmtRes <*> tzRes <*> locRes <*>
((>>= fromPathPiece) <$> slotRes)
widget = $(widgetFile "query-form")
return (q, widget)
......
......@@ -53,6 +53,10 @@ 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' ..]
......
<!-- Page Contents -->
<div .container>
$if not $ Just HomeR == mcurrentRoute
<ul .breadcrumb>
$forall bc <- parents
<li>
<a href="@{fst bc}">#{snd bc}
<li .active>#{title}
$maybe msg <- mmsg
<div .alert.alert-info #message>#{msg}
$maybe msg <- mmsg
<div .alert.alert-info #message>#{msg}
<div .container>
<div .row>
<div .col-md-12>
^{widget}
<div .row>
<div .col-md-12>
^{widget}
<div .masthead>
<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
<h2>Book an appointment
<div .container>
<!-- Starting
================================================== -->
<div .bs-docs-section>
<div .row>
<div .col-lg-12>
<div .page-header>
<h1 #start>Starting
<form enctype=#{enctype} method=POST action=@{HomeR}>
^{widget}
<p>
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.
<div ##{idAvail} style="display:none">
<ul .list-group>
<p ##{idSpinner} style="font-size:150%">
<span .glyphicon.glyphicon-off.fast-right-spinner>
<li .list-group-item>
This page was generated by the <tt>#{handlerName}</tt> handler in
<tt>Handler/Home.hs</tt>.
<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>
<div ##{idAlert} .alert.alert-danger style="display:none" role=alert>
<p>
<b>Oops
document.getElementById(#{toJSON aDomId}).innerHTML = "This text was added by the Javascript part of the homepage widget.";
// -*- js -*-
$(function() {
$("##{rawJS commentFormId}").submit(function(event) {
event.preventDefault();
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
function sendQuery() {
$("##{rawJS idSpinner}").show();
$("##{rawJS idAvail}").hide();
var url = "@{AvailR}?" + gatherQueryParams();
$.ajax({
url: '@{CommentR}',
type: 'POST',
contentType: "application/json",
data: JSON.stringify({
message: message,
}),
success: function (data) {
var newNode = $("<li></li>");
newNode.text(data.message);
console.log(data);
$("##{rawJS commentListId}").append(newNode);
},
error: function (data) {
console.log("Error creating comment: " + data);
},
});
});
});
url: url,
success: function(data) {
$("##{rawJS idAvail}").html(data);
$("##{rawJS idAvail}").show();
},
error: function(data) {
$("##{rawJS idAlert}").html(data.statusText).show();
},
complete: function() {
$("##{rawJS idSpinner}").hide();
},
})
}
h2##{aDomId} {
color: #990
/* step1.lucius -*- css -*- */
/* Glyphicons spinner from https://bootsnipp.com/snippets/djeAk */
.fast-right-spinner {
-webkit-animation: glyphicon-spin-r 1s infinite linear;
animation: glyphicon-spin-r 1s infinite linear;
}
li {
line-height: 2em;
font-size: 16px
.slot-choices button {
margin: 0 8px 10px 0;
}
##{commentTextareaId} {
width: 400px;
height: 100px;
@-webkit-keyframes glyphicon-spin-r {
0% {
-webkit-transform: rotate(0deg);
transform: rotate(0deg);
}
100% {
-webkit-transform: rotate(359deg);
transform: rotate(359deg);
}
}
@keyframes glyphicon-spin-r {
0% {
-webkit-transform: rotate(0deg);
transform: rotate(0deg);
}
100% {
-webkit-transform: rotate(359deg);
transform: rotate(359deg);
}
}
......@@ -5,9 +5,9 @@ $(function(){
function gatherQueryParams() {
return $.param({
_hasdata: 1,
tz: $("#tz").val(),
len: $("#len").val(),
fmt: $("#fmt").val(),
loc: $("input[name=loc]:checked").val(),
#{rawJS idTzLabel}: $("##{rawJS idTzLabel}").val(),
#{rawJS idApptLength}: $("##{rawJS idApptLength}").val(),
#{rawJS idTimeFmt}: $("##{rawJS idTimeFmt}").val(),
#{rawJS idLocation}: $("input[name=#{rawJS idLocation}]:checked").val(),
});
}
<h2>Book an appointment
<form enctype=#{enctype} method=POST action=@{ConfirmR}>
^{widget}
<div ##{idAvail} style="display:none">
<p ##{idSpinner} style="font-size:150%">
<span .glyphicon.glyphicon-off.fast-right-spinner>
<div ##{idAlert} .alert.alert-danger style="display:none" role=alert>
<p>
<b>Oops
// -*- js -*-
function sendQuery() {
$("##{rawJS idSpinner}").show();
$("##{rawJS idAvail}").hide();
var url = "@{AvailR}?" + gatherQueryParams();
$.ajax({
url: url,
success: function(data) {
$("##{rawJS idAvail}").html(data);
$("##{rawJS idAvail}").show();
},
error: function(data) {
$("##{rawJS idAlert}").html(data.statusText).show();
},
complete: function() {