diff --git a/src/Yesod/ReCaptcha2.hs b/src/Yesod/ReCaptcha2.hs --- a/src/Yesod/ReCaptcha2.hs +++ b/src/Yesod/ReCaptcha2.hs @@ -5,46 +5,44 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TupleSections #-} module Yesod.ReCaptcha2 - ( YesodReCaptcha(..) - -- * ReCaptcha V2 - , reCaptcha - , mReCaptcha - -- * Invisible ReCaptcha - -- $invisibleReCaptcha - , reCaptchaInvisible - , mReCaptchaInvisible - , reCaptchaInvisibleForm - ) where + ( YesodReCaptcha(..) + -- * ReCaptcha V2 + , reCaptcha + , mReCaptcha + -- * Invisible ReCaptcha + -- $invisibleReCaptcha + , reCaptchaInvisible + , mReCaptchaInvisible + , reCaptchaInvisibleForm + ) +where import ClassyPrelude import Data.Aeson import Network.HTTP.Simple import Yesod.Auth import Yesod.Core -import Yesod.Core.Handler -import Yesod.Core.Types -import Yesod.Core.Widget import Yesod.Form.Functions import Yesod.Form.Types -- | default key is testing. you should impl reCaptchaSiteKey and reCaptchaSecretKey class YesodAuth site => YesodReCaptcha site where - reCaptchaSiteKey :: HandlerFor site Text - reCaptchaSiteKey = pure "6LeIxAcTAAAAAJcZVRqyHh71UMIEGNQ_MXjiZKhI" - reCaptchaSecretKey :: HandlerFor site Text - reCaptchaSecretKey = pure "6LeIxAcTAAAAAGG-vFI1TnRWxMZNFuojJ4WifJWe" - -- | with specific language from - -- - -- - -- > reCaptchaLanguage = pure (Just "ru") - reCaptchaLanguage :: HandlerFor site (Maybe Text) - reCaptchaLanguage = pure Nothing + reCaptchaSiteKey :: HandlerFor site Text + reCaptchaSiteKey = pure "6LeIxAcTAAAAAJcZVRqyHh71UMIEGNQ_MXjiZKhI" + reCaptchaSecretKey :: HandlerFor site Text + reCaptchaSecretKey = pure "6LeIxAcTAAAAAGG-vFI1TnRWxMZNFuojJ4WifJWe" + -- | with specific language from + -- + -- + -- > reCaptchaLanguage = pure (Just "ru") + reCaptchaLanguage :: HandlerFor site (Maybe Text) + reCaptchaLanguage = pure Nothing newtype SiteverifyResponse - = SiteverifyResponse - { success :: Bool - } - deriving (Eq, Ord, Read, Show, Generic, FromJSON, ToJSON) + = SiteverifyResponse + { success :: Bool + } + deriving (Eq, Ord, Read, Show, Generic, FromJSON, ToJSON) -- | for Applicative style form reCaptcha :: YesodReCaptcha site => AForm (HandlerFor site) () @@ -52,48 +50,43 @@ -- | for Monadic style form mReCaptcha - :: YesodReCaptcha site => - MForm (HandlerFor site) (FormResult (), [FieldView site]) + :: YesodReCaptcha site + => MForm (HandlerFor site) (FormResult (), [FieldView site]) mReCaptcha = do - result <- lift formResult - return (result, [fieldViewSite]) - where formResult = do - postParam <- lookupPostParam "g-recaptcha-response" - case postParam of - Nothing -> return FormMissing - Just response -> do - secret <- reCaptchaSecretKey - SiteverifyResponse{success} <- liftIO $ do - req <- - parseRequest - "POST https://www.google.com/recaptcha/api/siteverify" - res <- httpJSON $ - setRequestBodyURLEncoded - [ ("secret", encodeUtf8 secret) - , ("response", encodeUtf8 response) - ] - req - return $ getResponseBody res - return $ if success - then FormSuccess () - else FormFailure ["reCaptcha error"] - fieldViewSite = FieldView - { fvLabel = mempty - , fvTooltip = Nothing - , fvId = "" - , fvInput = do - mReCaptchaLanguage <- handlerToWidget reCaptchaLanguage - case mReCaptchaLanguage of - Nothing -> - addScriptRemote "https://www.google.com/recaptcha/api.js" - Just hl -> - addScriptRemote $ - "https://www.google.com/recaptcha/api.js?hl=" <> hl - siteKey <- handlerToWidget reCaptchaSiteKey - [whamlet|
|] - , fvErrors = Nothing - , fvRequired = True - } + result <- lift formResult + return (result, [fieldViewSite]) + where + formResult = do + postParam <- lookupPostParam "g-recaptcha-response" + case postParam of + Nothing -> return FormMissing + Just response -> do + secret <- reCaptchaSecretKey + SiteverifyResponse { success } <- liftIO $ do + req <- parseRequest + "POST https://www.google.com/recaptcha/api/siteverify" + res <- httpJSON $ setRequestBodyURLEncoded + [("secret", encodeUtf8 secret), ("response", encodeUtf8 response)] + req + return $ getResponseBody res + return $ if success + then FormSuccess () + else FormFailure ["reCaptcha error"] + fieldViewSite = FieldView + { fvLabel = mempty + , fvTooltip = Nothing + , fvId = "" + , fvInput = do + mReCaptchaLanguage <- handlerToWidget reCaptchaLanguage + case mReCaptchaLanguage of + Nothing -> addScriptRemote "https://www.google.com/recaptcha/api.js" + Just hl -> + addScriptRemote $ "https://www.google.com/recaptcha/api.js?hl=" <> hl + siteKey <- handlerToWidget reCaptchaSiteKey + [whamlet|
|] + , fvErrors = Nothing + , fvRequired = True + } -- $invisibleReCaptcha -- @@ -120,7 +113,7 @@ -- | check for Applicative style form reCaptchaInvisible :: YesodReCaptcha site => AForm (HandlerFor site) () -reCaptchaInvisible = formToAForm ((,[]) <$> mReCaptchaInvisible) +reCaptchaInvisible = formToAForm ((, []) <$> mReCaptchaInvisible) -- | check for Monadic style form mReCaptchaInvisible @@ -129,30 +122,29 @@ -- | generate all required parts (except the check) for a Invisible ReCaptcha reCaptchaInvisibleForm - :: YesodReCaptcha site - => Maybe Text -- ^ The id of the form, a new will be created when 'Nothing' is passed - -> Maybe Text + :: YesodReCaptcha site + => Maybe Text -- ^ The id of the form, a new will be created when 'Nothing' is passed + -> Maybe Text -- ^ The javascript to call after a successful captcha, -- it has to submit the form, a simple one will be generated when 'Nothing' is passed - -> HandlerFor site (Text, WidgetFor site (), [(Text, Text)]) + -> HandlerFor site (Text, WidgetFor site (), [(Text, Text)]) reCaptchaInvisibleForm mIdent mScript = do - mReCaptchaLanguage <- reCaptchaLanguage - siteKey <- reCaptchaSiteKey - identForm <- maybe newIdent return mIdent - scriptName <- maybe (("reCaptchaOnSubmit_" <>) <$> newIdent) return mScript - let - widget = do + mReCaptchaLanguage <- reCaptchaLanguage + siteKey <- reCaptchaSiteKey + identForm <- maybe newIdent return mIdent + scriptName <- maybe (("reCaptchaOnSubmit_" <>) <$> newIdent) return mScript + let widget = do case mReCaptchaLanguage of - Nothing -> - addScriptRemote "https://www.google.com/recaptcha/api.js" + Nothing -> addScriptRemote "https://www.google.com/recaptcha/api.js" Just hl -> - addScriptRemote $ "https://www.google.com/recaptcha/api.js?hl=" <> hl - when (isNothing mScript) $ - toWidgetHead [hamlet| + addScriptRemote + $ "https://www.google.com/recaptcha/api.js?hl=" + <> hl + when (isNothing mScript) $ toWidgetHead [hamlet|