Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
B
bookme
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Christopher League
bookme
Commits
6e31f4e9
Commit
6e31f4e9
authored
Jun 20, 2018
by
Christopher League
🖥
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Recaptcha support!
parent
cea30e2e
Pipeline
#538
passed with stage
in 1 minute and 23 seconds
Changes
5
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
96 additions
and
3 deletions
+96
-3
config/settings.yml
config/settings.yml
+1
-0
package.yaml
package.yaml
+1
-0
src/BookingForm.hs
src/BookingForm.hs
+78
-2
src/Foundation.hs
src/Foundation.hs
+0
-1
src/Settings.hs
src/Settings.hs
+16
-0
No files found.
config/settings.yml
View file @
6e31f4e9
...
...
@@ -24,6 +24,7 @@ calendar-credentials:
client_id
:
"
_env:BOOKME_GOOGLE_ID:mock"
client_secret
:
"
_env:BOOKME_GOOGLE_SECRET:"
refresh_token
:
"
_env:BOOKME_GOOGLE_REFRESH:"
recaptcha
:
"
_env:BOOKME_RECAPTCHA"
free-calendar
:
_env:BOOKME_FREE_CAL:mock-free
busy-calendar
:
_env:BOOKME_BUSY_CAL:mock-busy
look-ahead-weeks
:
4
...
...
package.yaml
View file @
6e31f4e9
...
...
@@ -25,6 +25,7 @@ dependencies:
-
gogol-apps-calendar >=0.3.0 && <0.4
-
hjsmin >=0.1 && <0.3
-
http-client-tls >=0.3 && <0.4
-
http-conduit >=2.3 && <2.4
-
http-types >=0.12.1 && <0.13
-
lens >=4.16.1 && <4.17
-
monad-control >=0.3 && <1.1
...
...
src/BookingForm.hs
View file @
6e31f4e9
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
...
...
@@ -23,9 +24,13 @@ module BookingForm
import
Calendar
import
Control.Monad.Trans.Maybe
import
Data.Aeson
((
.!=
),
(
.:?
))
import
qualified
Data.Aeson
as
Js
import
Data.Function
((
&
))
import
Data.Time.Clock
(
addUTCTime
)
import
Data.Time.Zones
import
Import
import
qualified
Network.HTTP.Simple
as
H
import
qualified
QueryForm
as
QF
import
qualified
Yesod.Form.Bootstrap3
as
B3
...
...
@@ -57,13 +62,27 @@ fromSession = runMaybeT fromSessionMaybe >>= maybe QF.noSessionError return
bfs
::
Text
->
String
->
FieldSettings
site
bfs
label
help
=
(
B3
.
bfs
label
)
{
fsTooltip
=
Just
(
fromString
help
)}
submit
::
MForm
Handler
(
FormResult
()
,
[
FieldView
App
])
submit
=
do
useRecaptcha
<-
isJust
.
appRecaptcha
.
appSettings
<$>
getYesod
let
bs
::
B3
.
BootstrapSubmit
Text
bs
=
"Submit"
bs'
=
if
useRecaptcha
then
bs
{
B3
.
bsAttrs
=
[(
"disabled"
,
""
)]}
else
bs
f
<$>
B3
.
mbootstrapSubmit
bs'
where
f
(
r
,
v
)
=
(
r
,
[
v
])
bookingAForm
::
Maybe
Booking
->
AForm
Handler
Booking
bookingAForm
bOpt
=
Booking
<$>
areq
textField
name
(
bookName
<$>
bOpt
)
<*>
areq
emailField
email
(
bookEmail
<$>
bOpt
)
<*>
areq
textField
subject
(
bookSubject
<$>
bOpt
)
<*>
aopt
textField
contact
(
bookContact
<$>
bOpt
)
<*
B3
.
bootstrapSubmit
(
"Submit"
::
B3
.
BootstrapSubmit
Text
)
formToAForm
recaptcha
<*
formToAForm
submit
where
name
=
bfs
"*Name"
"Who are you?"
email
=
bfs
"*Email"
"You must use a valid email address"
...
...
@@ -71,6 +90,63 @@ bookingAForm bOpt =
bfs
"*Subject"
"What course are you in? What do you want to talk about?"
contact
=
bfs
"Contact"
"For online meetings, how do I reach you?"
data
RecaptchaResponse
=
RecaptchaResponse
{
rrSuccess
::
Bool
,
rrErrors
::
[
Text
]
}
deriving
(
Show
)
instance
Js
.
FromJSON
RecaptchaResponse
where
parseJSON
=
Js
.
withObject
"RecaptchaResponse"
$
\
o
->
do
rrSuccess
<-
o
.:
"success"
rrErrors
<-
o
.:?
"error-codes"
.!=
[]
return
RecaptchaResponse
{
..
}
recaptcha
::
MForm
Handler
(
FormResult
()
,
[
FieldView
App
])
recaptcha
=
appRecaptcha
.
appSettings
<$>
getYesod
>>=
\
case
Nothing
->
return
(
FormSuccess
()
,
[]
)
-- Don't use captcha
Just
(
Recaptcha
siteKey
secret
)
->
lookupPostParam
"g-recaptcha-response"
>>=
\
case
Nothing
->
return
(
FormMissing
,
[
recaptchaInput
siteKey
])
Just
response
->
do
mgr
<-
appHttpManager
<$>
getYesod
req'
<-
H
.
parseRequest
"POST https://www.google.com/recaptcha/api/siteverify"
let
req
=
req'
&
H
.
setRequestManager
mgr
&
H
.
setRequestBodyURLEncoded
[
(
"secret"
,
encodeUtf8
secret
)
,
(
"response"
,
encodeUtf8
response
)
]
resp
<-
H
.
getResponseBody
<$>
H
.
httpJSON
req
if
rrSuccess
resp
then
return
(
FormSuccess
()
,
[]
)
else
return
(
FormFailure
(
"reCAPTCHA failure"
:
rrErrors
resp
),
[]
)
recaptchaInput
::
Text
->
FieldView
App
recaptchaInput
key
=
FieldView
{
..
}
where
fvLabel
=
""
fvId
=
""
fvTooltip
=
Nothing
fvErrors
=
Nothing
fvRequired
=
True
fvInput
=
do
toWidgetHead
[
hamlet
|
<script src="https://www.google.com/recaptcha/api.js"></script>
|]
toWidgetHead
[
julius
|
function recaptchaAllowSubmit() {
$("button[type=submit]").removeAttr("disabled");
}
function recaptchaPreventSubmit() {
$("button[type=submit]").attr("disabled", "");
}
|]
[
whamlet
|
<div .g-recaptcha data-sitekey=#{key} data-callback=recaptchaAllowSubmit data-expired-callback=recaptchaPreventSubmit>
|]
horizOffset
::
B3
.
BootstrapGridOptions
horizOffset
=
B3
.
ColMd
0
...
...
@@ -78,7 +154,7 @@ labelSize :: B3.BootstrapGridOptions
labelSize
=
B3
.
ColMd
1
inputSize
::
B3
.
BootstrapGridOptions
inputSize
=
B3
.
ColMd
4
inputSize
=
B3
.
ColMd
11
b3Class
::
B3
.
BootstrapGridOptions
->
Text
b3Class
g
=
...
...
src/Foundation.hs
View file @
6e31f4e9
...
...
@@ -133,7 +133,6 @@ instance Yesod App where
,
"sha384-BVYiiSIFeK1dGmJRAkycuHAHRg32OmUcww7on3RYdg4Va+PmSTsz/K68vbdEjh4u"
)
,
(
"crossorigin"
,
"anonymous"
)
]
-- $ StaticR css_bootstrap_css
$
(
widgetFile
"default-layout"
)
withUrlRenderer
$
(
hamletFile
"templates/default-layout-wrapper.hamlet"
)
isAuthorized
::
...
...
src/Settings.hs
View file @
6e31f4e9
...
...
@@ -18,6 +18,7 @@ module Settings
,
TZLabelW
,
tzByLabel
,
Location
(
..
)
,
Recaptcha
(
..
)
,
varGoogleClientId
,
varGoogleSecret
,
varGoogleRefreshToken
...
...
@@ -60,6 +61,19 @@ makeLocs = zipWith mk ['A' ..]
where
mk
c
(
s
,
d
)
=
Location
(
snoc
"loc"
c
)
s
d
data
Recaptcha
=
Recaptcha
{
recaptchaSite
::
Text
,
recaptchaSecret
::
Text
}
deriving
(
Eq
)
-- | In JSON and environment, the Recaptcha site and secret keys are
-- separated should be separated by a semicolon.
instance
FromJSON
Recaptcha
where
parseJSON
v
=
splitElem
';'
<$>
parseJSON
v
>>=
\
case
[
recaptchaSite
,
recaptchaSecret
]
->
return
Recaptcha
{
..
}
_
->
Js
.
typeMismatch
"Recaptcha"
v
-- | Runtime settings to configure this application. These settings can be
-- loaded from various sources: defaults, environment variables, config files,
-- theoretically even a database.
...
...
@@ -115,6 +129,7 @@ data AppSettings = AppSettings
-- ^ Name of person/service providing appointments
,
appProviderAvatar
::
Maybe
Text
-- ^ URL to image of person/service providing appointments
,
appRecaptcha
::
Maybe
Recaptcha
}
-- | Wrap a time zone label, so we can specify type classes.
...
...
@@ -163,6 +178,7 @@ instance FromJSON AppSettings where
appProviderName
<-
o
.:?
"provider-name"
appProviderAvatar
<-
o
.:?
"provider-avatar"
appCredentials
<-
o
.:
"calendar-credentials"
appRecaptcha
<-
o
.:?
"recaptcha"
appCacheExpiry
<-
o
.:?
"calendar-refresh-seconds"
.!=
(
if
dev
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment