diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/snaplet-recaptcha.cabal b/snaplet-recaptcha.cabal new file mode 100644 --- /dev/null +++ b/snaplet-recaptcha.cabal @@ -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 + + diff --git a/src/Snap/Snaplet/ReCaptcha.hs b/src/Snap/Snaplet/ReCaptcha.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/ReCaptcha.hs @@ -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 + diff --git a/src/recaptcha-test.hs b/src/recaptcha-test.hs new file mode 100644 --- /dev/null +++ b/src/recaptcha-test.hs @@ -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"