{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE TupleSections     #-}
module Yesod.ReCaptcha2
  ( YesodReCaptcha(..)
    -- * ReCaptcha V2
  , reCaptcha
  , mReCaptcha
    -- * Invisible ReCaptcha
    -- $invisibleReCaptcha
  , 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)

-- | default key is testing. you should impl reCaptchaSiteKey and reCaptchaSecretKey
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"
  -- | with specific language from
  -- <https://developers.google.com/recaptcha/docs/language>
  --
  -- > reCaptchaLanguage = pure (Just "ru")
  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)

-- | for Applicative style form
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

-- | for Monadic style form
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
    }

-- $invisibleReCaptcha
--
-- The Invisible ReCaptcha is not as easy as the V2.
--
-- 1. Function to check the response: 'reCaptchaInvisible' or 'mReCaptchaInvisible'.
--
-- 2. Add the following to the code which creates the form:
--
--     > (reCaptchaFormId, reCaptchaWidget, reCaptchaButtonAttributes) <-
--     > reCaptchaInvisibleForm Nothing
--
-- 3. Add the id to the form, class and attributes to the button and the widget somewhere.
--    Example:
--
--     @
--     \<form \#\#{reCaptchaFormId} method=post action=@{route} enctype=#{enctype}\>
--       ^{widget}
--       ^{reCaptchaWidget}
--
--       \<button .g-recaptcha *{reCaptchaButtonAttributes}\>
--         Submit
--     @

-- | check for Applicative style form
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)

-- | check for Monadic style form
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

-- | 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
    -- ^ 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)])
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)]
    )