Commit 6e31f4e9 authored by Christopher League's avatar Christopher League

Recaptcha support!

parent cea30e2e
Pipeline #538 passed with stage
in 1 minute and 23 seconds
......@@ -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
......
......@@ -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
......
{-# 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 =
......
......@@ -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 ::
......
......@@ -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
......
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