Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Christopher League
bookme
Commits
96de7e74
Commit
96de7e74
authored
May 31, 2018
by
Christopher League
Browse files
Progress in QueryForm/BookingForm interaction
parent
ae8c5aa6
Changes
14
Hide whitespace changes
Inline
Side-by-side
config/routes
View file @
96de7e74
...
...
@@ -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
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
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
=
...
...
src/Handler/Home.hs
View file @
96de7e74
{-# 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"
src/QueryForm.hs
View file @
96de7e74
{-# 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
)
...
...
src/Settings.hs
View file @
96de7e74
...
...
@@ -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'
..
]
...
...
templates/default-layout.hamlet
View file @
96de7e74
<!-- 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}
templates/homepage.hamlet
View file @
96de7e74
<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
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() {
$("##{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
();
},
})
}
templates/homepage.lucius
View file @
96de7e74
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
);
}
}
templates/query-form.julius
View file @
96de7e74
...
...
@@ -5,9 +5,9 @@ $(function(){
function gatherQueryParams() {
return $.param({
_hasdata: 1,
tz: $("#tz
").val(),
len: $("#len
").val(),
f
mt: $("#
f
mt").val(),
loc: $("input[name=loc
]:checked").val(),
#{rawJS idTzLabel}: $("##{rawJS idTzLabel}
").val(),
#{rawJS idApptLength}: $("##{rawJS idApptLength}
").val(),
#{rawJS idTimeF
mt
}
:
$("#
#{rawJS idTimeF
mt
}
").val(),
#{rawJS idLocation}: $("input[name=#{rawJS idLocation}
]:checked").val(),
});
}
templates/step1.hamlet
deleted
100644 → 0