{-# 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 = 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"
  -- | with specific language from
  -- <https://developers.google.com/recaptcha/docs/language>
  --
  -- > reCaptchaLanguage = pure (Just "ru")
  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)

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

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

-- $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 :: 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)

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

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