Recaptcha support!

config/settings.yml

@@ -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

@@ -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

+{-# 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

@@ -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

@@ -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