about summary refs log tree commit diff
path: root/src/Main.hs
diff options
context:
space:
mode:
authorVincent Ambo <v.ambo@me.com>2012-04-04T00·20+0200
committerVincent Ambo <v.ambo@me.com>2012-04-04T00·20+0200
commit3e16a443e67932ffa99d33e45591f14c0e44ef5a (patch)
tree4c331621ccec19f58caf40bc4db218955175999a /src/Main.hs
parent5b80f528c7c518c7d82e70635f265be3c0120327 (diff)
version 3.3:
* added reCaptcha again (got too much spam)
Diffstat (limited to 'src/Main.hs')
-rw-r--r--src/Main.hs32
1 files changed, 21 insertions, 11 deletions
diff --git a/src/Main.hs b/src/Main.hs
index 0ad5d979c288..203d0af0af85 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -24,6 +24,7 @@ import           Data.Time
 import           Data.SafeCopy (base, deriveSafeCopy)
 import           Happstack.Server hiding (Session)
 import           Happstack.Server.Compression
+import           Network.Captcha.ReCaptcha
 import           Options
 import           System.Locale (defaultTimeLocale)
 
@@ -38,6 +39,8 @@ defineOptions "MainOptions" $ do
   stringOption "optState" "statedir" "../"
     "Directory in which the /BlogState dir is located.\
     \ The default is ../ (if run from src/)"
+  stringOption "optCaptcha" "captchakey" ""
+    "The reCaptcha private key"
   intOption "optPort" "port" 8000
     "The port to run the web server on. Default is 8000"
 
@@ -50,12 +53,12 @@ main = do
     runCommand $ \opts args ->
       bracket (openLocalStateFrom (optState opts ++ "BlogState") initialBlogState)
               (createCheckpointAndClose)
-              (\acid -> simpleHTTP nullConf {port = optPort opts} $ tazBlog acid)
+              (\acid -> simpleHTTP nullConf {port = optPort opts} $ tazBlog acid $ optCaptcha opts)
 
-tazBlog :: AcidState Blog -> ServerPart Response
-tazBlog acid = do
+tazBlog :: AcidState Blog -> String -> ServerPart Response
+tazBlog acid captchakey = do
     compr <- compressedResponseFilter
-    msum [ path $ \(lang :: BlogLang) -> blogHandler acid lang
+    msum [ path $ \(lang :: BlogLang) -> blogHandler acid lang captchakey
          , nullDir >> showIndex acid DE
          , dir " " $ nullDir >>
             seeOther ("https://plus.google.com/115916629925754851590" :: Text) (toResponse ())
@@ -87,12 +90,12 @@ tazBlog acid = do
          , notFound $ toResponse $ showError NotFound DE
          ]
 
-blogHandler :: AcidState Blog -> BlogLang -> ServerPart Response
-blogHandler acid lang = 
+blogHandler :: AcidState Blog -> BlogLang -> String -> ServerPart Response
+blogHandler acid lang captchakey = 
     msum [ path $ \(eId :: Integer) -> showEntry acid lang $ EntryId eId
          , do decodeBody tmpPolicy
               dir "postcomment" $ path $ 
-                \(eId :: Integer) -> addComment acid lang $ EntryId eId
+                \(eId :: Integer) -> addComment acid lang captchakey $ EntryId eId
          , nullDir >> showIndex acid lang
          , dir "rss" $ nullDir >> showRSS acid lang
          , dir "rss.xml" $ nullDir >> showRSS acid lang
@@ -134,15 +137,22 @@ showRSS acid lang = do
     setHeaderM "content-type" "text/xml"
     ok $ toResponse feed
 
-addComment :: AcidState Blog -> BlogLang -> EntryId -> ServerPart Response
-addComment acid lang eId = do
+addComment :: AcidState Blog -> BlogLang -> String -> EntryId -> ServerPart Response
+addComment acid lang captchakey eId = do
   now <- liftIO $ getCurrentTime >>= return
   nCtext <- lookText' "ctext"
   nComment <- Comment <$> pure now
                       <*> lookText' "cname"
                       <*> pure (commentEscape nCtext)
-  update' acid (AddComment eId nComment)
-  seeOther ("/" ++ show lang ++ "/" ++ show eId) (toResponse())
+  -- captcha verification
+  challenge <- look "recaptcha_challenge_field"
+  response <- look "recaptcha_response_field"
+  (userIp, _) <- askRq >>= return . rqPeer
+  validation <- liftIO $ validateCaptcha captchakey userIp challenge response
+  case validation of 
+    Right _ -> update' acid (AddComment eId nComment) 
+                >> seeOther ("/" ++ show lang ++ "/" ++ show eId) (toResponse())
+    Left _ -> (liftIO $ putStrLn "Captcha failed") >> seeOther ("/" ++ show lang ++ "/" ++ show eId) (toResponse())
 
 commentEscape :: Text -> Text
 commentEscape = newlineEscape . ltEscape . gtEscape . ampEscape