{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TupleSections #-}
module Yesod.ReCaptcha2
( YesodReCaptcha(..)
, reCaptcha
, mReCaptcha
, reCaptchaInvisible
, mReCaptchaInvisible
, reCaptchaInvisibleForm
) where
import Control.Monad (when)
import Data.Maybe (isNothing)
import Data.String.Transform (ToByteStringStrict (toByteStringStrict))
import Data.Text (Text)
import GHC.Generics (Generic)
import Network.HTTP.Simple (getResponseBody, httpJSON, parseRequest,
setRequestBodyURLEncoded)
import Yesod.Core (FromJSON, HandlerFor, MonadIO (liftIO), MonadTrans (lift),
ToJSON, ToWidgetHead (toWidgetHead), WidgetFor,
addScriptRemote, hamlet, handlerToWidget, lookupPostParam,
newIdent, whamlet)
import Yesod.Form.Functions (formToAForm)
import Yesod.Form.Types (AForm, FieldView (..), FormResult (..), MForm)
class YesodReCaptcha site where
reCaptchaSiteKey :: HandlerFor site Text
reCaptchaSiteKey = forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"6LeIxAcTAAAAAJcZVRqyHh71UMIEGNQ_MXjiZKhI"
reCaptchaSecretKey :: HandlerFor site Text
reCaptchaSecretKey = forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"6LeIxAcTAAAAAGG-vFI1TnRWxMZNFuojJ4WifJWe"
reCaptchaLanguage :: HandlerFor site (Maybe Text)
reCaptchaLanguage = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
newtype SiteverifyResponse
= SiteverifyResponse
{ SiteverifyResponse -> Bool
success :: Bool
}
deriving (SiteverifyResponse -> SiteverifyResponse -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SiteverifyResponse -> SiteverifyResponse -> Bool
$c/= :: SiteverifyResponse -> SiteverifyResponse -> Bool
== :: SiteverifyResponse -> SiteverifyResponse -> Bool
$c== :: SiteverifyResponse -> SiteverifyResponse -> Bool
Eq, Eq SiteverifyResponse
SiteverifyResponse -> SiteverifyResponse -> Bool
SiteverifyResponse -> SiteverifyResponse -> Ordering
SiteverifyResponse -> SiteverifyResponse -> SiteverifyResponse
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SiteverifyResponse -> SiteverifyResponse -> SiteverifyResponse
$cmin :: SiteverifyResponse -> SiteverifyResponse -> SiteverifyResponse
max :: SiteverifyResponse -> SiteverifyResponse -> SiteverifyResponse
$cmax :: SiteverifyResponse -> SiteverifyResponse -> SiteverifyResponse
>= :: SiteverifyResponse -> SiteverifyResponse -> Bool
$c>= :: SiteverifyResponse -> SiteverifyResponse -> Bool
> :: SiteverifyResponse -> SiteverifyResponse -> Bool
$c> :: SiteverifyResponse -> SiteverifyResponse -> Bool
<= :: SiteverifyResponse -> SiteverifyResponse -> Bool
$c<= :: SiteverifyResponse -> SiteverifyResponse -> Bool
< :: SiteverifyResponse -> SiteverifyResponse -> Bool
$c< :: SiteverifyResponse -> SiteverifyResponse -> Bool
compare :: SiteverifyResponse -> SiteverifyResponse -> Ordering
$ccompare :: SiteverifyResponse -> SiteverifyResponse -> Ordering
Ord, ReadPrec [SiteverifyResponse]
ReadPrec SiteverifyResponse
Int -> ReadS SiteverifyResponse
ReadS [SiteverifyResponse]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SiteverifyResponse]
$creadListPrec :: ReadPrec [SiteverifyResponse]
readPrec :: ReadPrec SiteverifyResponse
$creadPrec :: ReadPrec SiteverifyResponse
readList :: ReadS [SiteverifyResponse]
$creadList :: ReadS [SiteverifyResponse]
readsPrec :: Int -> ReadS SiteverifyResponse
$creadsPrec :: Int -> ReadS SiteverifyResponse
Read, Int -> SiteverifyResponse -> ShowS
[SiteverifyResponse] -> ShowS
SiteverifyResponse -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SiteverifyResponse] -> ShowS
$cshowList :: [SiteverifyResponse] -> ShowS
show :: SiteverifyResponse -> String
$cshow :: SiteverifyResponse -> String
showsPrec :: Int -> SiteverifyResponse -> ShowS
$cshowsPrec :: Int -> SiteverifyResponse -> ShowS
Show, forall x. Rep SiteverifyResponse x -> SiteverifyResponse
forall x. SiteverifyResponse -> Rep SiteverifyResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SiteverifyResponse x -> SiteverifyResponse
$cfrom :: forall x. SiteverifyResponse -> Rep SiteverifyResponse x
Generic, Value -> Parser [SiteverifyResponse]
Value -> Parser SiteverifyResponse
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [SiteverifyResponse]
$cparseJSONList :: Value -> Parser [SiteverifyResponse]
parseJSON :: Value -> Parser SiteverifyResponse
$cparseJSON :: Value -> Parser SiteverifyResponse
FromJSON, [SiteverifyResponse] -> Encoding
[SiteverifyResponse] -> Value
SiteverifyResponse -> Encoding
SiteverifyResponse -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [SiteverifyResponse] -> Encoding
$ctoEncodingList :: [SiteverifyResponse] -> Encoding
toJSONList :: [SiteverifyResponse] -> Value
$ctoJSONList :: [SiteverifyResponse] -> Value
toEncoding :: SiteverifyResponse -> Encoding
$ctoEncoding :: SiteverifyResponse -> Encoding
toJSON :: SiteverifyResponse -> Value
$ctoJSON :: SiteverifyResponse -> Value
ToJSON)
reCaptcha :: YesodReCaptcha site => AForm (HandlerFor site) ()
reCaptcha :: forall site. YesodReCaptcha site => AForm (HandlerFor site) ()
reCaptcha = forall (m :: * -> *) site a.
(HandlerSite m ~ site, Monad m) =>
MForm m (FormResult a, [FieldView site]) -> AForm m a
formToAForm forall site.
YesodReCaptcha site =>
MForm (HandlerFor site) (FormResult (), [FieldView site])
mReCaptcha
mReCaptcha
:: YesodReCaptcha site
=> MForm (HandlerFor site) (FormResult (), [FieldView site])
mReCaptcha :: forall site.
YesodReCaptcha site =>
MForm (HandlerFor site) (FormResult (), [FieldView site])
mReCaptcha = do
FormResult ()
result <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift HandlerFor site (FormResult ())
formResult
forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult ()
result, [FieldView site
fieldViewSite])
where
formResult :: HandlerFor site (FormResult ())
formResult = do
Maybe Text
postParam <- forall (m :: * -> *).
(MonadResource m, MonadHandler m) =>
Text -> m (Maybe Text)
lookupPostParam Text
"g-recaptcha-response"
case Maybe Text
postParam of
Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. FormResult a
FormMissing
Just Text
response -> do
Text
secret <- forall site. YesodReCaptcha site => HandlerFor site Text
reCaptchaSecretKey
SiteverifyResponse { Bool
success :: Bool
success :: SiteverifyResponse -> Bool
success } <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Request
req <- forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest
String
"POST https://www.google.com/recaptcha/api/siteverify"
Response SiteverifyResponse
res <- forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)] -> Request -> Request
setRequestBodyURLEncoded
[(ByteString
"secret", forall a. ToByteStringStrict a => a -> ByteString
toByteStringStrict Text
secret), (ByteString
"response", forall a. ToByteStringStrict a => a -> ByteString
toByteStringStrict Text
response)]
Request
req
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Response a -> a
getResponseBody Response SiteverifyResponse
res
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
success
then forall a. a -> FormResult a
FormSuccess ()
else forall a. [Text] -> FormResult a
FormFailure [Text
"reCaptcha error"]
fieldViewSite :: FieldView site
fieldViewSite = FieldView
{ fvLabel :: Markup
fvLabel = forall a. Monoid a => a
mempty
, fvTooltip :: Maybe Markup
fvTooltip = forall a. Maybe a
Nothing
, fvId :: Text
fvId = Text
""
, fvInput :: WidgetFor site ()
fvInput = do
Maybe Text
mReCaptchaLanguage <- forall site a. HandlerFor site a -> WidgetFor site a
handlerToWidget forall site. YesodReCaptcha site => HandlerFor site (Maybe Text)
reCaptchaLanguage
case Maybe Text
mReCaptchaLanguage of
Maybe Text
Nothing -> forall (m :: * -> *). MonadWidget m => Text -> m ()
addScriptRemote Text
"https://www.google.com/recaptcha/api.js"
Just Text
hl ->
forall (m :: * -> *). MonadWidget m => Text -> m ()
addScriptRemote forall a b. (a -> b) -> a -> b
$ Text
"https://www.google.com/recaptcha/api.js?hl=" forall a. Semigroup a => a -> a -> a
<> Text
hl
Text
siteKey <- forall site a. HandlerFor site a -> WidgetFor site a
handlerToWidget forall site. YesodReCaptcha site => HandlerFor site Text
reCaptchaSiteKey
[whamlet|<div .g-recaptcha data-sitekey=#{siteKey}>|]
, fvErrors :: Maybe Markup
fvErrors = forall a. Maybe a
Nothing
, fvRequired :: Bool
fvRequired = Bool
True
}
reCaptchaInvisible :: YesodReCaptcha site => AForm (HandlerFor site) ()
reCaptchaInvisible :: forall site. YesodReCaptcha site => AForm (HandlerFor site) ()
reCaptchaInvisible = forall (m :: * -> *) site a.
(HandlerSite m ~ site, Monad m) =>
MForm m (FormResult a, [FieldView site]) -> AForm m a
formToAForm ((, []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall site.
YesodReCaptcha site =>
MForm (HandlerFor site) (FormResult ())
mReCaptchaInvisible)
mReCaptchaInvisible
:: YesodReCaptcha site => MForm (HandlerFor site) (FormResult ())
mReCaptchaInvisible :: forall site.
YesodReCaptcha site =>
MForm (HandlerFor site) (FormResult ())
mReCaptchaInvisible = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall site.
YesodReCaptcha site =>
MForm (HandlerFor site) (FormResult (), [FieldView site])
mReCaptcha
reCaptchaInvisibleForm
:: YesodReCaptcha site
=> Maybe Text
-> Maybe Text
-> HandlerFor site (Text, WidgetFor site (), [(Text, Text)])
reCaptchaInvisibleForm :: forall site.
YesodReCaptcha site =>
Maybe Text
-> Maybe Text
-> HandlerFor site (Text, WidgetFor site (), [(Text, Text)])
reCaptchaInvisibleForm Maybe Text
mIdent Maybe Text
mScript = do
Maybe Text
mReCaptchaLanguage <- forall site. YesodReCaptcha site => HandlerFor site (Maybe Text)
reCaptchaLanguage
Text
siteKey <- forall site. YesodReCaptcha site => HandlerFor site Text
reCaptchaSiteKey
Text
identForm <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *). MonadHandler m => m Text
newIdent forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
mIdent
Text
scriptName <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((Text
"reCaptchaOnSubmit_" forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadHandler m => m Text
newIdent) forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
mScript
let widget :: WidgetFor site ()
widget = do
case Maybe Text
mReCaptchaLanguage of
Maybe Text
Nothing -> forall (m :: * -> *). MonadWidget m => Text -> m ()
addScriptRemote Text
"https://www.google.com/recaptcha/api.js"
Just Text
hl ->
forall (m :: * -> *). MonadWidget m => Text -> m ()
addScriptRemote
forall a b. (a -> b) -> a -> b
$ Text
"https://www.google.com/recaptcha/api.js?hl="
forall a. Semigroup a => a -> a -> a
<> Text
hl
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe Text
mScript) forall a b. (a -> b) -> a -> b
$ forall site a (m :: * -> *).
(ToWidgetHead site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidgetHead [hamlet|
<script>function #{scriptName}(token) { document.getElementById("#{identForm}").submit(); }
|]
forall (m :: * -> *) a. Monad m => a -> m a
return
( Text
identForm
, WidgetFor site ()
widget
, [(Text
"data-sitekey", Text
siteKey), (Text
"data-callback", Text
scriptName)]
)