module Yesod.ReCAPTCHA
( YesodReCAPTCHA(..)
, recaptchaAForm
, recaptchaMForm
, recaptchaOptions
, RecaptchaOptions(..)
) where
import Control.Applicative
import Data.Typeable (Typeable)
import Yesod.Widget (whamlet)
import qualified Control.Exception.Lifted as E
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.Conduit as C
import qualified Data.Default as D
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TEE
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Network.HTTP.Conduit as H
import qualified Network.HTTP.Types as HT
import qualified Network.Info as NI
import qualified Network.Socket as HS
import qualified Network.Wai as W
import qualified Yesod.Auth as YA
import qualified Yesod.Core as YC
import qualified Yesod.Form.Fields as YF
import qualified Yesod.Form.Functions as YF
import qualified Yesod.Form.Types as YF
class YA.YesodAuth master => YesodReCAPTCHA master where
recaptchaPublicKey :: YC.GHandler sub master T.Text
recaptchaPrivateKey :: YC.GHandler sub master T.Text
insecureRecaptchaBackdoor :: YC.GHandler sub master (Maybe T.Text)
insecureRecaptchaBackdoor = return Nothing
recaptchaAForm :: YesodReCAPTCHA master => YF.AForm sub master ()
recaptchaAForm = YF.formToAForm recaptchaMForm
recaptchaMForm :: YesodReCAPTCHA master =>
YF.MForm sub master ( YF.FormResult ()
, [YF.FieldView sub master] )
recaptchaMForm = do
challengeField <- fakeField "recaptcha_challenge_field"
responseField <- fakeField "recaptcha_response_field"
ret <- maybe (return Nothing)
(YC.lift . fmap Just . uncurry check)
((,) <$> challengeField <*> responseField)
let view = recaptchaWidget $ case ret of
Just (Error err) -> Just err
_ -> Nothing
formRet = case ret of
Nothing -> YF.FormMissing
Just Ok -> YF.FormSuccess ()
Just (Error _) -> YF.FormFailure []
formView = YF.FieldView
{ YF.fvLabel = ""
, YF.fvTooltip = Nothing
, YF.fvId = "recaptcha_challenge_field"
, YF.fvInput = view
, YF.fvErrors = Nothing
, YF.fvRequired = True
}
return (formRet, [formView])
recaptchaWidget :: YesodReCAPTCHA master =>
Maybe T.Text
-> YC.GWidget sub master ()
recaptchaWidget merr = do
publicKey <- YC.lift recaptchaPublicKey
isSecure <- W.isSecure <$> YC.lift YC.waiRequest
let proto | isSecure = "https"
| otherwise = "http" :: T.Text
err = maybe "" (T.append "&error=") merr
[whamlet|
<script src="#{proto}://www.google.com/recaptcha/api/challenge?k=#{publicKey}#{err}">
<noscript>
<iframe src="#{proto}://www.google.com/recaptcha/api/noscript?k=#{publicKey}#{err}"
height="300" width="500" frameborder="0">
<br>
<textarea name="recaptcha_challenge_field" rows="3" cols="40">
<input type="hidden" name="recaptcha_response_field" value="manual_challenge">
|]
check :: YesodReCAPTCHA master =>
T.Text
-> T.Text
-> YC.GHandler sub master CheckRet
check "" _ = return $ Error "invalid-request-cookie"
check _ "" = return $ Error "incorrect-captcha-sol"
check challenge response = do
backdoor <- insecureRecaptchaBackdoor
if Just response == backdoor
then return Ok
else do
manager <- YA.authHttpManager <$> YC.getYesod
privateKey <- recaptchaPrivateKey
sockaddr <- W.remoteHost <$> YC.waiRequest
case sockaddr of
HS.SockAddrUnix _ -> do
$(YC.logError) $ "Yesod.ReCAPTCHA: Couldn't find out remote IP, \
\are you using a reverse proxy? If yes, then \
\please file a bug report at \
\<https://github.com/meteficha/yesod-recaptcha>."
fail "Could not find remote IP address for reCAPTCHA."
_ -> do
let remoteip = case sockaddr of
HS.SockAddrInet _ hostAddr ->
show $ NI.IPv4 hostAddr
HS.SockAddrInet6 _ _ (w1, w2, w3, w4) _ ->
show $ NI.IPv6 w1 w2 w3 w4
HS.SockAddrUnix _ -> error "ReCAPTCHA.check"
req = H.def
{ H.method = HT.methodPost
, H.host = "www.google.com"
, H.path = "/recaptcha/api/verify"
, H.queryString = HT.renderSimpleQuery False query
}
query = [ ("privatekey", TE.encodeUtf8 privateKey)
, ("remoteip", B8.pack remoteip)
, ("challenge", TE.encodeUtf8 challenge)
, ("response", TE.encodeUtf8 response)
]
eresp <- E.try $ C.runResourceT $ H.httpLbs req manager
case (L8.lines . H.responseBody) <$> eresp of
Right ("true":_) -> return Ok
Right ("false":why:_) -> return . Error . TL.toStrict $
TLE.decodeUtf8With TEE.lenientDecode why
Right other -> do
$(YC.logError) $ T.concat [ "Yesod.ReCAPTCHA: could not parse "
, T.pack (show other) ]
return (Error "recaptcha-not-reachable")
Left exc -> do
$(YC.logError) $ T.concat [ "Yesod.ReCAPTCHA: could not contact server ("
, T.pack (show (exc :: E.SomeException))
, ")" ]
return (Error "recaptcha-not-reachable")
data CheckRet = Ok | Error T.Text
fakeField :: (YC.RenderMessage master YF.FormMessage) =>
T.Text
-> YF.MForm sub master (Maybe T.Text)
fakeField fid = YC.lift $ do mt1 <- YC.lookupGetParam fid
case mt1 of
Nothing -> YC.lookupPostParam fid
Just _ -> return mt1
recaptchaOptions :: YC.Yesod master =>
RecaptchaOptions
-> YC.GWidget sub master ()
recaptchaOptions s | s == D.def = return ()
recaptchaOptions s =
[whamlet|
<script>
var RecaptchaOptions = {
$maybe t <- theme s
theme : '#{t}',
$maybe l <- lang s
lang : '#{l}',
x : 'x'
};
|]
data RecaptchaOptions =
RecaptchaOptions {
theme :: Maybe T.Text
, lang :: Maybe T.Text
}
deriving (Eq, Ord, Show, Typeable)
instance D.Default RecaptchaOptions where
def = RecaptchaOptions Nothing Nothing