{-# 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 = Text -> HandlerFor site Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"6LeIxAcTAAAAAJcZVRqyHh71UMIEGNQ_MXjiZKhI"
reCaptchaSecretKey :: HandlerFor site Text
reCaptchaSecretKey = Text -> HandlerFor site Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"6LeIxAcTAAAAAGG-vFI1TnRWxMZNFuojJ4WifJWe"
reCaptchaLanguage :: HandlerFor site (Maybe Text)
reCaptchaLanguage = Maybe Text -> HandlerFor site (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
newtype SiteverifyResponse
= SiteverifyResponse
{ SiteverifyResponse -> Bool
success :: Bool
}
deriving (SiteverifyResponse -> SiteverifyResponse -> Bool
(SiteverifyResponse -> SiteverifyResponse -> Bool)
-> (SiteverifyResponse -> SiteverifyResponse -> Bool)
-> Eq SiteverifyResponse
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
Eq SiteverifyResponse
-> (SiteverifyResponse -> SiteverifyResponse -> Ordering)
-> (SiteverifyResponse -> SiteverifyResponse -> Bool)
-> (SiteverifyResponse -> SiteverifyResponse -> Bool)
-> (SiteverifyResponse -> SiteverifyResponse -> Bool)
-> (SiteverifyResponse -> SiteverifyResponse -> Bool)
-> (SiteverifyResponse -> SiteverifyResponse -> SiteverifyResponse)
-> (SiteverifyResponse -> SiteverifyResponse -> SiteverifyResponse)
-> Ord 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
$cp1Ord :: Eq SiteverifyResponse
Ord, ReadPrec [SiteverifyResponse]
ReadPrec SiteverifyResponse
Int -> ReadS SiteverifyResponse
ReadS [SiteverifyResponse]
(Int -> ReadS SiteverifyResponse)
-> ReadS [SiteverifyResponse]
-> ReadPrec SiteverifyResponse
-> ReadPrec [SiteverifyResponse]
-> Read 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
(Int -> SiteverifyResponse -> ShowS)
-> (SiteverifyResponse -> String)
-> ([SiteverifyResponse] -> ShowS)
-> Show SiteverifyResponse
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. SiteverifyResponse -> Rep SiteverifyResponse x)
-> (forall x. Rep SiteverifyResponse x -> SiteverifyResponse)
-> Generic SiteverifyResponse
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
(Value -> Parser SiteverifyResponse)
-> (Value -> Parser [SiteverifyResponse])
-> FromJSON 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
(SiteverifyResponse -> Value)
-> (SiteverifyResponse -> Encoding)
-> ([SiteverifyResponse] -> Value)
-> ([SiteverifyResponse] -> Encoding)
-> ToJSON SiteverifyResponse
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 :: AForm (HandlerFor site) ()
reCaptcha = MForm (HandlerFor site) (FormResult (), [FieldView site])
-> AForm (HandlerFor site) ()
forall (m :: * -> *) site a.
(HandlerSite m ~ site, Monad m) =>
MForm m (FormResult a, [FieldView site]) -> AForm m a
formToAForm MForm (HandlerFor site) (FormResult (), [FieldView site])
forall site.
YesodReCaptcha site =>
MForm (HandlerFor site) (FormResult (), [FieldView site])
mReCaptcha
mReCaptcha
:: YesodReCaptcha site
=> MForm (HandlerFor site) (FormResult (), [FieldView site])
mReCaptcha :: MForm (HandlerFor site) (FormResult (), [FieldView site])
mReCaptcha = do
FormResult ()
result <- HandlerFor site (FormResult ())
-> RWST
(Maybe (Env, FileEnv), site, [Text])
Enctype
Ints
(HandlerFor site)
(FormResult ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift HandlerFor site (FormResult ())
formResult
(FormResult (), [FieldView site])
-> RWST
(Maybe (Env, FileEnv), site, [Text])
Enctype
Ints
(HandlerFor site)
(FormResult (), [FieldView site])
forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult ()
result, [FieldView site
fieldViewSite])
where
formResult :: HandlerFor site (FormResult ())
formResult = do
Maybe Text
postParam <- Text -> HandlerFor site (Maybe Text)
forall (m :: * -> *).
(MonadResource m, MonadHandler m) =>
Text -> m (Maybe Text)
lookupPostParam Text
"g-recaptcha-response"
case Maybe Text
postParam of
Maybe Text
Nothing -> FormResult () -> HandlerFor site (FormResult ())
forall (m :: * -> *) a. Monad m => a -> m a
return FormResult ()
forall a. FormResult a
FormMissing
Just Text
response -> do
Text
secret <- HandlerFor site Text
forall site. YesodReCaptcha site => HandlerFor site Text
reCaptchaSecretKey
SiteverifyResponse { Bool
success :: Bool
success :: SiteverifyResponse -> Bool
success } <- IO SiteverifyResponse -> HandlerFor site SiteverifyResponse
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SiteverifyResponse -> HandlerFor site SiteverifyResponse)
-> IO SiteverifyResponse -> HandlerFor site SiteverifyResponse
forall a b. (a -> b) -> a -> b
$ do
Request
req <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest
String
"POST https://www.google.com/recaptcha/api/siteverify"
Response SiteverifyResponse
res <- Request -> IO (Response SiteverifyResponse)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON (Request -> IO (Response SiteverifyResponse))
-> Request -> IO (Response SiteverifyResponse)
forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)] -> Request -> Request
setRequestBodyURLEncoded
[(ByteString
"secret", Text -> ByteString
forall a. ToByteStringStrict a => a -> ByteString
toByteStringStrict Text
secret), (ByteString
"response", Text -> ByteString
forall a. ToByteStringStrict a => a -> ByteString
toByteStringStrict Text
response)]
Request
req
SiteverifyResponse -> IO SiteverifyResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (SiteverifyResponse -> IO SiteverifyResponse)
-> SiteverifyResponse -> IO SiteverifyResponse
forall a b. (a -> b) -> a -> b
$ Response SiteverifyResponse -> SiteverifyResponse
forall a. Response a -> a
getResponseBody Response SiteverifyResponse
res
FormResult () -> HandlerFor site (FormResult ())
forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult () -> HandlerFor site (FormResult ()))
-> FormResult () -> HandlerFor site (FormResult ())
forall a b. (a -> b) -> a -> b
$ if Bool
success
then () -> FormResult ()
forall a. a -> FormResult a
FormSuccess ()
else [Text] -> FormResult ()
forall a. [Text] -> FormResult a
FormFailure [Text
"reCaptcha error"]
fieldViewSite :: FieldView site
fieldViewSite = FieldView :: forall site.
Markup
-> Maybe Markup
-> Text
-> WidgetFor site ()
-> Maybe Markup
-> Bool
-> FieldView site
FieldView
{ fvLabel :: Markup
fvLabel = Markup
forall a. Monoid a => a
mempty
, fvTooltip :: Maybe Markup
fvTooltip = Maybe Markup
forall a. Maybe a
Nothing
, fvId :: Text
fvId = Text
""
, fvInput :: WidgetFor site ()
fvInput = do
Maybe Text
mReCaptchaLanguage <- HandlerFor site (Maybe Text) -> WidgetFor site (Maybe Text)
forall site a. HandlerFor site a -> WidgetFor site a
handlerToWidget HandlerFor site (Maybe Text)
forall site. YesodReCaptcha site => HandlerFor site (Maybe Text)
reCaptchaLanguage
case Maybe Text
mReCaptchaLanguage of
Maybe Text
Nothing -> Text -> WidgetFor site ()
forall (m :: * -> *). MonadWidget m => Text -> m ()
addScriptRemote Text
"https://www.google.com/recaptcha/api.js"
Just Text
hl ->
Text -> WidgetFor site ()
forall (m :: * -> *). MonadWidget m => Text -> m ()
addScriptRemote (Text -> WidgetFor site ()) -> Text -> WidgetFor site ()
forall a b. (a -> b) -> a -> b
$ Text
"https://www.google.com/recaptcha/api.js?hl=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hl
Text
siteKey <- HandlerFor site Text -> WidgetFor site Text
forall site a. HandlerFor site a -> WidgetFor site a
handlerToWidget HandlerFor site Text
forall site. YesodReCaptcha site => HandlerFor site Text
reCaptchaSiteKey
[whamlet|<div .g-recaptcha data-sitekey=#{siteKey}>|]
, fvErrors :: Maybe Markup
fvErrors = Maybe Markup
forall a. Maybe a
Nothing
, fvRequired :: Bool
fvRequired = Bool
True
}
reCaptchaInvisible :: YesodReCaptcha site => AForm (HandlerFor site) ()
reCaptchaInvisible :: AForm (HandlerFor site) ()
reCaptchaInvisible = MForm (HandlerFor site) (FormResult (), [FieldView site])
-> AForm (HandlerFor site) ()
forall (m :: * -> *) site a.
(HandlerSite m ~ site, Monad m) =>
MForm m (FormResult a, [FieldView site]) -> AForm m a
formToAForm ((, []) (FormResult () -> (FormResult (), [FieldView site]))
-> RWST
(Maybe (Env, FileEnv), site, [Text])
Enctype
Ints
(HandlerFor site)
(FormResult ())
-> RWST
(Maybe (Env, FileEnv), site, [Text])
Enctype
Ints
(HandlerFor site)
(FormResult (), [FieldView site])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST
(Maybe (Env, FileEnv), site, [Text])
Enctype
Ints
(HandlerFor site)
(FormResult ())
forall site.
YesodReCaptcha site =>
MForm (HandlerFor site) (FormResult ())
mReCaptchaInvisible)
mReCaptchaInvisible
:: YesodReCaptcha site => MForm (HandlerFor site) (FormResult ())
mReCaptchaInvisible :: MForm (HandlerFor site) (FormResult ())
mReCaptchaInvisible = (FormResult (), [FieldView site]) -> FormResult ()
forall a b. (a, b) -> a
fst ((FormResult (), [FieldView site]) -> FormResult ())
-> RWST
(Maybe (Env, FileEnv), site, [Text])
Enctype
Ints
(HandlerFor site)
(FormResult (), [FieldView site])
-> RWST
(Maybe (Env, FileEnv), site, [Text])
Enctype
Ints
(HandlerFor site)
(FormResult ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST
(Maybe (Env, FileEnv), site, [Text])
Enctype
Ints
(HandlerFor site)
(FormResult (), [FieldView site])
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 :: Maybe Text
-> Maybe Text
-> HandlerFor site (Text, WidgetFor site (), [(Text, Text)])
reCaptchaInvisibleForm Maybe Text
mIdent Maybe Text
mScript = do
Maybe Text
mReCaptchaLanguage <- HandlerFor site (Maybe Text)
forall site. YesodReCaptcha site => HandlerFor site (Maybe Text)
reCaptchaLanguage
Text
siteKey <- HandlerFor site Text
forall site. YesodReCaptcha site => HandlerFor site Text
reCaptchaSiteKey
Text
identForm <- HandlerFor site Text
-> (Text -> HandlerFor site Text)
-> Maybe Text
-> HandlerFor site Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HandlerFor site Text
forall (m :: * -> *). MonadHandler m => m Text
newIdent Text -> HandlerFor site Text
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
mIdent
Text
scriptName <- HandlerFor site Text
-> (Text -> HandlerFor site Text)
-> Maybe Text
-> HandlerFor site Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((Text
"reCaptchaOnSubmit_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> HandlerFor site Text -> HandlerFor site Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandlerFor site Text
forall (m :: * -> *). MonadHandler m => m Text
newIdent) Text -> HandlerFor site Text
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 -> Text -> WidgetFor site ()
forall (m :: * -> *). MonadWidget m => Text -> m ()
addScriptRemote Text
"https://www.google.com/recaptcha/api.js"
Just Text
hl ->
Text -> WidgetFor site ()
forall (m :: * -> *). MonadWidget m => Text -> m ()
addScriptRemote
(Text -> WidgetFor site ()) -> Text -> WidgetFor site ()
forall a b. (a -> b) -> a -> b
$ Text
"https://www.google.com/recaptcha/api.js?hl="
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hl
Bool -> WidgetFor site () -> WidgetFor site ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Text
mScript) (WidgetFor site () -> WidgetFor site ())
-> WidgetFor site () -> WidgetFor site ()
forall a b. (a -> b) -> a -> b
$ (RY site -> Markup) -> WidgetFor site ()
forall site a (m :: * -> *).
(ToWidgetHead site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidgetHead [hamlet|
<script>function #{scriptName}(token) { document.getElementById("#{identForm}").submit(); }
|]
(Text, WidgetFor site (), [(Text, Text)])
-> HandlerFor site (Text, WidgetFor site (), [(Text, Text)])
forall (m :: * -> *) a. Monad m => a -> m a
return
( Text
identForm
, WidgetFor site ()
widget
, [(Text
"data-sitekey", Text
siteKey), (Text
"data-callback", Text
scriptName)]
)