snaplet-recaptcha (empty) → 0.1
raw patch · 5 files changed
+325/−0 lines, 5 filesdep +basedep +blaze-htmldep +bytestringsetup-changed
Dependencies added: base, blaze-html, bytestring, conduit, data-lens, data-lens-template, failure, http-conduit, http-types, snap, snap-core, snap-server, text
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- snaplet-recaptcha.cabal +87/−0
- src/Snap/Snaplet/ReCaptcha.hs +138/−0
- src/recaptcha-test.hs +68/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2012, Lars Petersen++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Lars Petersen nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ snaplet-recaptcha.cabal view
@@ -0,0 +1,87 @@+-- 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++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++Source-Repository head+ type: git+ location: http://github.com/lpeterse/snaplet-recaptcha.git++
+ src/Snap/Snaplet/ReCaptcha.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell #-}+-- |+-- Module : Snap.Snaplet.ReCaptcha+-- Copyright : (c) Lars Petersen 2012+-- License : BSD-style+--+-- Maintainer : 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, ... }+--+ +module Snap.Snaplet.ReCaptcha + ( -- * Snaplet and Initialization+ ReCaptcha ()+ , HasReCaptcha (..)+ , initReCaptcha+ -- * Handlers+ , verifyCaptcha+ -- * Types+ , PrivateKey+ , ReCaptchaResult (..)+ ) where++import Data.Lens.Common+import Data.Lens.Template++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL++import Data.Monoid+import Control.Applicative+import Control.Failure+import Control.Exception (throw, try)+import Control.Monad.Trans.Resource (runResourceT)++import Network.HTTP.Types (renderSimpleQuery)+import Network.HTTP.Conduit as HTTP+import Snap++data ReCaptcha+ = ReCaptcha+ { privateKey :: PrivateKey+ , connectionManager :: Manager + }++class HasReCaptcha b where+ recaptchaLens :: Lens (Snaplet b) (Snaplet ReCaptcha)++type PrivateKey = BS.ByteString++-- | 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++data ReCaptchaResult+ = Success+ -- Taken from the official ReCaptcha Api documentation+ | Failure BSL.ByteString+ | ConnectionError HttpException+ -- Misc+ | MissingArguments++instance Failure HttpException (Handler b ReCaptcha) where+ failure = throw++-- | You may use captcha verification troughout your whole application like this:+--+-- > myHandler :: (HasReCaptcha b) => Handler b SomeSubSnaplet ()+-- > myHandler+-- > = do c <- verifyCaptcha+-- > case c of+-- > Success -> .. -- captcha successfully solved+-- > _ -> .. -- something went wrong+--+-- 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`.+--+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+
+ src/recaptcha-test.hs view
@@ -0,0 +1,68 @@+{-# 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"