snaplet-recaptcha 0.1 → 1.0
raw patch · 5 files changed
+433/−266 lines, 5 filesdep +MonadCatchIO-transformersdep +aesondep +blaze-builderdep −blaze-htmldep −conduitdep −data-lensdep ~basedep ~http-conduitdep ~snap
Dependencies added: MonadCatchIO-transformers, aeson, blaze-builder, configurator, heist, lens, mtl
Dependencies removed: blaze-html, conduit, data-lens, data-lens-template, failure, http-types, snap-core, snap-server
Dependency ranges changed: base, http-conduit, snap
Files
- LICENSE +1/−1
- snaplet-recaptcha.cabal +33/−83
- src/Snap/Snaplet/ReCaptcha.hs +249/−114
- src/Snap/Snaplet/ReCaptcha/Example.hs +150/−0
- src/recaptcha-test.hs +0/−68
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c)2012, Lars Petersen+Copyright (c)2012, Lars Petersen; (c)2014, Michael Ledger All rights reserved.
snaplet-recaptcha.cabal view
@@ -1,87 +1,37 @@--- snaplet-recaptcha.cabal auto-generated by cabal init. For--- additional options, see--- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.--- The name of the package.-Name: snaplet-recaptcha---- The package version. See the Haskell package versioning policy--- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for--- standards guiding when and how versions should be incremented.-Version: 0.1---- A short (one-line) description of the package.-Synopsis: A ReCAPTCHA verification snaplet with connection sharing.---- A longer description of the package.-Description: This snaplet handles the interfacing with Google's ReCaptcha verification API.- It uses `http-conduit` which manages a connection pool. On the one hand- this avoid the overhead of reconnecting for every single captcha request and- on the other hand limits the use of the server's resources.---- The license under which the package is released.-License: BSD3---- The file containing the license text.-License-file: LICENSE---- The package author(s).-Author: Lars Petersen---- An email address to which users can send suggestions, bug reports,--- and patches.-Maintainer: info@lars-petersen.net---- A copyright notice.--- Copyright: --Category: Web--Build-type: Simple---- Extra files to be distributed with the package, such as examples or--- a README.--- Extra-source-files: ---- Constraint on the version of Cabal needed to build this package.-Cabal-version: >=1.10--Library- Hs-Source-Dirs: src- Exposed-Modules: Snap.Snaplet.ReCaptcha- Default-Language: Haskell2010- Build-Depends: base >= 4 && < 5- , data-lens- , data-lens-template- , bytestring- , failure- , conduit- , http-conduit- , http-types- , snap-core- , snap+-- Initial snaplet-recaptcha.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/ -Executable recaptcha-test- Main-Is: recaptcha-test.hs- Hs-Source-Dirs: src- Other-Modules: Snap.Snaplet.ReCaptcha- Default-Language: Haskell2010- Build-Depends: base >= 4 && < 5- , data-lens- , data-lens-template- , bytestring- , text- , failure- , snap-core- , snap-server- , snap- , blaze-html- , failure- , conduit- , http-conduit- , http-types+name: snaplet-recaptcha+version: 1.0+synopsis: A ReCAPTCHA verification snaplet with Heist integration and connection sharing.+-- description:+homepage: http://github.com/mikeplus64/snaplet-recaptcha+license: BSD3+license-file: LICENSE+author: Mike Ledger, Lars Petersen+maintainer: Mike Ledger <eleventynine@gmail.com>+-- copyright:+category: Web+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10 -Source-Repository head- type: git- location: http://github.com/lpeterse/snaplet-recaptcha.git+library+ exposed-modules: Snap.Snaplet.ReCaptcha+ , Snap.Snaplet.ReCaptcha.Example + build-depends: base < 5+ , lens+ , heist >= 0.14 && <0.15+ , snap >= 0.13 && <0.14+ , blaze-builder+ , MonadCatchIO-transformers+ , mtl+ , aeson+ , bytestring+ , configurator+ , text+ , http-conduit >=2.1 + hs-source-dirs: src+ default-language: Haskell2010
src/Snap/Snaplet/ReCaptcha.hs view
@@ -1,138 +1,273 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} -- | -- Module : Snap.Snaplet.ReCaptcha--- Copyright : (c) Lars Petersen 2012+-- Copyright : (c) Mike Ledger 2014+-- (c) Lars Petersen 2012+-- -- License : BSD-style ----- Maintainer : info@lars-petersen.net+-- Maintainer : mike@quasimal.com, info@lars-petersen.net -- Stability : experimental -- Portability : portable--- --- This is a snaplet for google's ReCaptcha verification api. This library uses `http-conduit` and keeps connections alive (a maximum of 10 by now). This is an important point in order to avoid denial of service attacks.--- --- Include it into your application like this: ----- > import Snap.Snaplet.ReCaptcha--- >--- > data MyApplication = MyApplication { _recaptcha :: Snaplet ReCaptcha, ... }--- >--- > $(makeLenses [''MyApplication])--- >--- > instance HasReCaptcha MyApplicaiton where--- > recaptchaLens = subSnaplet recaptcha--- >--- > myApplication :: SnapletInit MyApplication--- > myApplication--- > = makeSnaplet--- > "MyApplication"--- > ""--- > Nothing--- > $ do r <- embedSnaplet "recaptcha" recaptcha $ initReCaptcha "YOUR_PRIVATE_KEY"--- > return $ MyApplication { _recaptcha = r, ... }+-- This is a snaplet for google's ReCaptcha verification api. This library uses+-- `http-conduit` and keeps connections alive (a maximum of 10). This is an+-- important point in order to avoid denial of service attacks. --- -module Snap.Snaplet.ReCaptcha - ( -- * Snaplet and Initialization- ReCaptcha ()- , HasReCaptcha (..)- , initReCaptcha- -- * Handlers- , verifyCaptcha- -- * Types- , PrivateKey- , ReCaptchaResult (..)- ) where+-- See 'Snap.Snaplet.ReCaptcha.Example' and the docs provided here for example+-- usage.+-- -import Data.Lens.Common-import Data.Lens.Template+module Snap.Snaplet.ReCaptcha+ ( -- * Snaplet and Initialization+ ReCaptcha ()+ , HasReCaptcha (..)+ , initReCaptcha+ , initReCaptcha'+ -- * Handlers+ , checkCaptcha+ , withCaptcha+ , getCaptcha+ -- * Types+ , Captcha(..)+ , PrivateKey+ , SiteKey+ -- * Extra+ , cstate+ , recaptchaScript, recaptchaDiv+ ) where -import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL+import qualified Blaze.ByteString.Builder as Blaze+import Control.Applicative+import Control.Lens+import Control.Monad.Reader (runReaderT) -import Data.Monoid-import Control.Applicative-import Control.Failure-import Control.Exception (throw, try)-import Control.Monad.Trans.Resource (runResourceT)+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 Network.HTTP.Types (renderSimpleQuery)-import Network.HTTP.Conduit as HTTP-import Snap+import Data.Foldable (fold, for_, toList)+import Data.Monoid+import Data.Typeable -data ReCaptcha- = ReCaptcha- { privateKey :: PrivateKey- , connectionManager :: Manager - }+import Heist+import Heist.Compiled -class HasReCaptcha b where- recaptchaLens :: Lens (Snaplet b) (Snaplet ReCaptcha)+import qualified Network.HTTP.Client.Conduit as HTTP -type PrivateKey = BS.ByteString+import Snap+import Snap.Snaplet.Heist.Compiled --- | The private key must be 40 characters long and encoded just like you get it from Google. -initReCaptcha :: PrivateKey -> SnapletInit b ReCaptcha-initReCaptcha key- = makeSnaplet- "ReCaptcha"- ""- Nothing- $ do man <- liftIO (newManager def)- if BS.length key /= 40- then fail "ReCaptcha: private key must be exactly 40 chars long"- else return $ ReCaptcha key man+type PrivateKey = BS.ByteString+type SiteKey = BS.ByteString+type UserIP = BS.ByteString+type UserAnswer = BS.ByteString -data ReCaptchaResult+data Captcha = Success- -- Taken from the official ReCaptcha Api documentation- | Failure BSL.ByteString- | ConnectionError HttpException- -- Misc- | MissingArguments+ | Failure+ -- | Errors returned by the Captcha. See <https://developers.google.com/recaptcha/docs/verify>+ -- for possible error codes. Note that 'Failure' is used for the case that the+ -- only error code returned is "invalid-input-response".+ | Errors [Text]+ -- | The server didn't respond with the JSON object required as per+ -- <https://developers.google.com/recaptcha/docs/verify>+ | InvalidServerResponse+ -- | There was no "recaptcha_response_field" parameter set in the user request.+ | MissingResponseParam+ deriving (Show, Typeable) -instance Failure HttpException (Handler b ReCaptcha) where- failure = throw+data ReCaptcha = ReCaptcha+ { connectionManager :: !HTTP.Manager+ , recaptchaQuery :: !(UserIP -> UserAnswer -> HTTP.Request)+ , _cstate :: !Captcha+ } deriving (Typeable) --- | You may use captcha verification troughout your whole application like this:+makeLenses ''ReCaptcha++class HasReCaptcha b where+ captchaLens :: SnapletLens (Snaplet b) ReCaptcha++instance HasReCaptcha ReCaptcha where+ captchaLens = id++-- This is kinda lame - should we just parse it manually?+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+ -- this has to parse for the snaplet to work at all+ 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+ }++-- | Initialise the 'ReCaptcha' snaplet. You are required to have "site_key" and+-- "secret_key" set in the snaplet's configuration file. See 'initReCaptcha\''+-- if you don't want to use Snap's snaplet configuration mechanism. ----- > myHandler :: (HasReCaptcha b) => Handler b SomeSubSnaplet ()--- > myHandler--- > = do c <- verifyCaptcha--- > case c of--- > Success -> .. -- captcha successfully solved--- > _ -> .. -- something went wrong+-- This provides optional Heist support, which is implemented using+-- 'recaptchaScript' and 'recaptchaDiv'.+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)++-- | Same as 'initReCaptcha', but passing the site key and private key+-- explicitly - no configuration on the filesystem is required.+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)++-- | @<script src='https://www.google.com/recaptcha/api.js' async defer></script> @+recaptchaScript :: Blaze.Builder+recaptchaScript = Blaze.fromByteString+ "<script src='https://www.google.com/recaptcha/api.js' async defer></script>"++-- | For use in a HTML form.+recaptchaDiv :: BS.ByteString -> Blaze.Builder+recaptchaDiv site = Blaze.fromByteString $!+ "<div class='g-recaptcha' data-sitekey='" <> site <> "'></div>"++-- | Get the ReCaptcha result by querying Google's API. ----- You don't need to extract the challenge and response paramters from the request. This is all handled by the snaplet. Just make sure the parameters `recaptcha_challenge_field` and `recaptcha_response_field` are contained in the user's request. Otherwise the `verifyCaptcha` call will return `MissingArguments`.+-- This requires a "g-recaptcha-response" (POST) parameter to be set in the+-- current request. ---verifyCaptcha :: (HasReCaptcha b) => Handler b c ReCaptchaResult -verifyCaptcha- = do mchallenge <- getParam "recaptcha_challenge_field"- mresponse <- getParam "recaptcha_response_field"- case (mchallenge, mresponse) of- (Just challenge, Just response)- -> do man <- withTop' recaptchaLens (gets connectionManager)- privatekey <- withTop' recaptchaLens (gets privateKey)- rq <- withTop' recaptchaLens (parseUrl "http://www.google.com/recaptcha/api/verify")- remoteip <- rqRemoteAddr <$> getRequest- let request = rq- { HTTP.method = "POST"- , queryString = renderSimpleQuery False- [ ("privatekey", privatekey)- , ("remoteip", remoteip)- , ("challenge", challenge)- , ("response", response)- ]- }- result <- liftIO $ Control.Exception.try $ runResourceT $ httpLbs request man- case result of- Left e -> do return (ConnectionError (e :: HttpException))- Right r -> do let ls = BSL.split 0x0a $ responseBody r- let ua = return (Failure $ responseBody r)- if length ls < 2- then ua- else case ls !! 0 of- "true" -> return $ Success- "false" -> return $ Failure (ls !! 1) - _ -> ua- _ -> return MissingArguments+-- See 'ReCaptchaResult' for possible failure types.+--+-- @+-- cstate <- getCaptcha+-- case cstate of+-- Success -> writeText "Congratulations! You won."+-- Failure -> writeText "Incorrect cstate answer."+-- MissingResponseParam -> writeText "No g-recaptcha-response in POST"+-- InvalidServerResponse -> writeText "Did Google change their API?"+-- Errors errs -> writeText ("Errors: " <> 'T.pack' ('show' errs))+-- @+--+-- This may throw a 'HTTP.HttpException' if there is a connection-related error.+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+ -- The reply is a JSON object looking like+ -- {+ -- "success": true|false,+ -- "error-codes": [...] // optional+ -- }+ -- see <https://developers.google.com/recaptcha/docs/verify>+ -- we just use aeson and the derived FromJSON instance here+ 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"] +-- | Run one of two handlers on either failing or succeeding a captcha.+--+-- @+-- 'withCaptcha' banForever $ do+-- postId <- 'getParam' "id"+-- thing <- 'getPostParam' thing+-- addCommentToDB postId thing+-- @+--+-- See 'getCaptcha'+withCaptcha+ :: HasReCaptcha b+ => Handler b c () -- ^ Ran on failure+ -> Handler b c () -- ^ Ran on success+ -> Handler b c ()+withCaptcha onFail onSuccess = do+ s <- getCaptcha+ withTop' captchaLens (cstate .= s)+ case s of+ Success -> onSuccess+ _ -> onFail++-- | 'pass' if the cstate failed. Logs errors (not incorrect captchas) with+-- 'logError'.+--+-- @ 'checkCaptcha' '<|>' 'writeText' "Captcha failed!" @+--+-- See 'getCaptcha'+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
+ src/Snap/Snaplet/ReCaptcha/Example.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+module Snap.Snaplet.ReCaptcha.Example+ ( -- * Main+ main+ , initSample+ -- * Necessities+ , sampleTemplate+ -- * Implementation+ , initBlog+ ) where+import qualified Blaze.ByteString.Builder as Blaze+import Heist+import Heist.Compiled++import Snap+import Snap.Snaplet.Heist.Compiled+import Snap.Snaplet.ReCaptcha++import Control.Lens++import qualified Data.ByteString.Char8 as BS+import Data.Monoid+import Data.Text (Text)++-- | Simple sample snaplet, built using 'ReCaptcha' in order to demonstrate how+-- one might use it in the scenario of adding comments to a blog.+data Sample = Sample+ { _recaptcha :: !(Snaplet ReCaptcha)+ , _heist :: !(Snaplet (Heist Sample))+ , _blog :: !(Snaplet Blog)+ }++-- | Not actually a blog+data Blog = Blog+ { _currentPost :: !(Maybe BS.ByteString)+ }++makeLenses ''Sample+makeLenses ''Blog++instance HasReCaptcha Sample where+ captchaLens = subSnaplet recaptcha++instance HasHeist Sample where+ heistLens = subSnaplet heist++-- | A "blog" snaplet which reads hypothetical "posts" by their 'id', routing+-- GET on \/posts\/:id to display a post, and POST on \/posts\/:id to add a+-- comment to them. For loose, useless definitions of "post" and "comment" -+-- this snaplet is only for demonstration purposes.+initBlog :: forall b. (HasReCaptcha b, HasHeist b) => Snaplet (Heist b)+ -> SnapletInit b Blog+initBlog heist = makeSnaplet "blog" "simple blog" Nothing $ do+ me <- getLens++ addRoutes+ -- Hypothetical comments are just sent as POST to the respective post they+ -- are replying to+ [("/posts/:id", method GET displayPost <|> method POST commentOnPost)]++ addConfig heist $ mempty &~ do+ -- Just 'blog-post' to be whatever is in 'post' at the time+ -- (hopefully set by 'displayPost' after being routed to /posts/:id)+ scCompiledSplices .=+ ("blog-post" ## pureSplice Blaze.fromByteString . lift $ do+ post' <- withTop' me (use currentPost)+ case post' of+ Just post -> return post+ Nothing -> fail "Couldn't find that.")++ return (Blog Nothing)+ where+ displayPost :: Handler b Blog ()+ displayPost = do+ Just postId <- getParam "id"+ currentPost .= Just ("there is no post #" <> postId <> ". only me.")+ render "recaptcha-example" <|> fail "Couldn't load recaptcha-example.tpl"++ commentOnPost :: Handler b Blog ()+ commentOnPost = do+ Just postId <- getParam "id"+ Just captcha <- getPostParam "g-recaptcha-response"+ checkCaptcha <|> fail "Bad captcha response."+ -- if we reach here, the captcha was OK+ Just name <- getPostParam "name"+ Just email <- getPostParam "email"+ Just content <- getPostParam "content"+ writeBS $ BS.concat [postId, " < (", name,", ", email, ", ", content, ")"]++-- | Heist template, written to $PWD\/snaplets\/heist\/recaptcha-example.tpl+--+-- >sampleTemplate ≈+-- > <html>+-- > <head>+-- > <recaptcha-script />+-- > </head>+-- > <body>+-- > <form method='POST'>+-- > <input type='text' name='name' placeholder='Name'>+-- > <input type='text' name='email' placeholder='Email'>+-- > <br>+-- > <textarea class='field' name='content' rows='20' placeholder='Content'></textarea>+-- > <br>+-- > <recaptcha-div />+-- > <input type='submit' value='Comment'>+-- > </form>+-- > </body>+-- > </html>+--+sampleTemplate :: Text+sampleTemplate =+ "<html>\+ \ <head>\+ \ <recaptcha-script />\+ \ </head>\+ \ <body>\+ \ <form method='POST'>\+ \ <input type='text' name='name' placeholder='Name'>\+ \ <input type='text' name='email' placeholder='Email'>\+ \ <br>\+ \ <textarea class='field' name='content' rows='20' placeholder='Content'></textarea>\+ \ <br>\+ \ <recaptcha-div />\+ \ <input type='submit' value='Comment'>\+ \ </form>\+ \ </body>\+ \</html>"++-- | Requires 'snaplets/heist/templates/sample.tpl' - a suggested version of which+-- is available in this module as 'sampleTemplate'.+--+-- This simple asks for your site and private key through stdin.+initSample :: SnapletInit Sample Sample+initSample = makeSnaplet "sample" "" Nothing $ do+ h <- nestSnaplet "heist" heist (heistInit "templates")+ c <- nestSnaplet "submit" recaptcha (initReCaptcha (Just h))+ t <- nestSnaplet "blog" blog (initBlog h)+ return (Sample c h t)++-- | @ 'main' = 'serveSnaplet' 'defaultConfig' 'initSample' @+--+-- You can load this into GHCi and run it, with full logging to stdout/stderr+--+-- >>> :main --verbose --access-log= --error-log=+main :: IO ()+main = serveSnaplet defaultConfig initSample
− src/recaptcha-test.hs
@@ -1,68 +0,0 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell #-}-module Main where--import Data.Lens.Common-import Data.Lens.Template--import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Text.Blaze.Html5 as H-import Text.Blaze.Html5.Attributes as A-import Data.Monoid-import Control.Applicative-import Text.Blaze.Renderer.Utf8 (renderHtml)--import Snap-import Snap.Snaplet.ReCaptcha--data ReCaptchaTest- = ReCaptchaTest- { _recaptcha :: Snaplet ReCaptcha- }--$(makeLenses [''ReCaptchaTest])--instance HasReCaptcha ReCaptchaTest where- recaptchaLens = subSnaplet recaptcha--main :: IO ()-main- = do putStrLn "Please enter your ReCaptcha public key:"- puk <- getLine- putStrLn "Please enter your ReCaptcha private key:"- prk <- T.encodeUtf8 <$> T.pack <$> getLine- putStrLn "Now point your browser to localhost:8000!"- serveSnaplet defaultConfig (snaplet puk prk)- where- snaplet puk prk - = makeSnaplet- "ReCaptchaTest"- ""- Nothing- $ do r <- embedSnaplet "recaptcha" recaptcha $ initReCaptcha prk- addRoutes [("", writeLBS $ renderHtml $ template puk)- ,("verify", do r <- verifyCaptcha- case r of- Success -> writeBS "Success."- Failure x -> writeBS "Failure: " >> writeLBS x- ConnectionError x -> writeBS "ConnectionError: " >> writeText (T.pack $ show x)- MissingArguments -> writeBS "MissingArguments"- )- ] - return (ReCaptchaTest r) - template puk- = H.docTypeHtml- $ do H.head- $ do H.script ""- ! A.type_ "text/javascript"- ! A.src "http://www.google.com/recaptcha/api/js/recaptcha_ajax.js"- H.body- ! A.onload ( "Recaptcha.create('" `mappend` toValue puk `mappend` "', 'recaptcha');" )- $ do H.form- ! A.action "verify"- ! A.method "POST"- $ do H.div ""- ! A.id "recaptcha"- H.button "Test"