module Snap.Snaplet.ReCaptcha
(
ReCaptcha ()
, HasReCaptcha (..)
, initReCaptcha
, initReCaptcha'
, checkCaptcha
, withCaptcha
, getCaptcha
, Captcha(..)
, PrivateKey
, SiteKey
, cstate
, recaptchaScript, recaptchaDiv
) where
import qualified Blaze.ByteString.Builder as Blaze
import Control.Applicative
import Control.Lens
import Control.Monad.Reader (runReaderT)
import qualified Data.Aeson as JSON
import qualified Data.Aeson.TH as JSON
import qualified Data.ByteString.Char8 as BS
import qualified Data.Configurator as Conf
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Foldable (fold, for_, toList)
import Data.Monoid
import Data.Typeable
import Heist
import Heist.Compiled
import qualified Network.HTTP.Client.Conduit as HTTP
import Snap
import Snap.Snaplet.Heist.Compiled
type PrivateKey = BS.ByteString
type SiteKey = BS.ByteString
type UserIP = BS.ByteString
type UserAnswer = BS.ByteString
data Captcha
= Success
| Failure
| Errors [Text]
| InvalidServerResponse
| MissingResponseParam
deriving (Show, Typeable)
data ReCaptcha = ReCaptcha
{ connectionManager :: !HTTP.Manager
, recaptchaQuery :: !(UserIP -> UserAnswer -> HTTP.Request)
, _cstate :: !Captcha
} deriving (Typeable)
makeLenses ''ReCaptcha
class HasReCaptcha b where
captchaLens :: SnapletLens (Snaplet b) ReCaptcha
instance HasReCaptcha ReCaptcha where
captchaLens = id
data ReCaptchaResponse = ReCaptchaResponse
{ success :: !Bool
, error_codes :: !(Maybe [Text])
}
JSON.deriveJSON JSON.defaultOptions ''Captcha
JSON.deriveFromJSON JSON.defaultOptions
{ JSON.fieldLabelModifier = map $ \c -> case c of
'_' -> '-'
_ -> c
} ''ReCaptchaResponse
initialiser :: Maybe (Snaplet (Heist b)) -> (SiteKey, PrivateKey)
-> Initializer b v ReCaptcha
initialiser mheist (site,key) = do
req <- liftIO (HTTP.parseUrl "https://www.google.com/recaptcha/api/siteverify")
man <- liftIO HTTP.newManager
for_ mheist (\heist -> addReCaptchaHeist heist site)
return ReCaptcha
{ connectionManager = man
, recaptchaQuery = \ip answer ->
HTTP.urlEncodedBody
[ ("secret" , key)
, ("response" , answer)
, ("remoteip" , ip) ]
req
, _cstate = Failure
}
initReCaptcha :: Maybe (Snaplet (Heist b)) -> SnapletInit b ReCaptcha
initReCaptcha heist =
makeSnaplet "recaptcha" "ReCaptcha integration" Nothing $
initialiser heist =<< do
conf <- getSnapletUserConfig
(,) <$> require conf "site_key"
<*> require conf "secret_key"
where
require conf field = do
v <- liftIO (Conf.lookup conf field)
case v of
Just v' -> return v'
Nothing -> do
spath <- BS.pack `fmap` getSnapletFilePath
err <- errorMsg (encodeUtf8 field <> " not in the config " <> spath
<> "/devel.cfg")
fail (BS.unpack err)
initReCaptcha' :: Maybe (Snaplet (Heist b)) -> (SiteKey, PrivateKey)
-> SnapletInit b ReCaptcha
initReCaptcha' heist keys =
makeSnaplet "recaptcha" "ReCaptcha integration" Nothing
(initialiser heist keys)
addReCaptchaHeist :: Snaplet (Heist b) -> BS.ByteString -> Initializer b v ()
addReCaptchaHeist heist site = addConfig heist $ mempty &~ do
scCompiledSplices .= do
"recaptcha-div" ## pureSplice id (return (recaptchaDiv site))
"recaptcha-script" ## pureSplice id (return recaptchaScript)
recaptchaScript :: Blaze.Builder
recaptchaScript = Blaze.fromByteString
"<script src='https://www.google.com/recaptcha/api.js' async defer></script>"
recaptchaDiv :: BS.ByteString -> Blaze.Builder
recaptchaDiv site = Blaze.fromByteString $!
"<div class='g-recaptcha' data-sitekey='" <> site <> "'></div>"
getCaptcha :: HasReCaptcha b => Handler b c Captcha
getCaptcha = do
mresponse <- getPostParam "g-recaptcha-response"
case mresponse of
Just answer -> withTop' captchaLens $ do
manager <- gets connectionManager
getQuery <- gets recaptchaQuery
remoteip <- getsRequest rqRemoteAddr
response <- runReaderT (HTTP.httpLbs (getQuery remoteip answer)) manager
return $! case JSON.decode (HTTP.responseBody response) of
Just obj
| success obj -> Success
| invalidInput obj -> Failure
| otherwise -> Errors (fold (error_codes obj))
Nothing -> InvalidServerResponse
Nothing -> return MissingResponseParam
where
invalidInput obj = error_codes obj == Just ["invalid-input-response"]
withCaptcha
:: HasReCaptcha b
=> Handler b c ()
-> Handler b c ()
-> Handler b c ()
withCaptcha onFail onSuccess = do
s <- getCaptcha
withTop' captchaLens (cstate .= s)
case s of
Success -> onSuccess
_ -> onFail
checkCaptcha :: HasReCaptcha b => Handler b c ()
checkCaptcha = do
s <- getCaptcha
withTop' captchaLens (cstate .= s)
case s of
Success -> return ()
Failure -> pass
someError -> do
logError =<< errorMsg (BS.pack (show someError))
pass
errorMsg :: (MonadSnaplet m, Monad (m b v)) => BS.ByteString
-> m b v BS.ByteString
errorMsg err = do
ancestry <- getSnapletAncestry
name <- getSnapletName
return $! showTextList (ancestry++toList name) <> " (ReCaptcha) : " <> err
where
showTextList :: [Text] -> BS.ByteString
showTextList = BS.intercalate "/" . map encodeUtf8