Commits

Luke Plant committed ccbf534

Added some rudimentary word based spam filtering

Comments (0)

Files changed (4)

src/Blog/Forms.hs

 where
 
 import Blog.Formats (Format(..), getFormatter)
-import Blog.Model (checkPassword)
+import Blog.Model (checkPassword, getSpamWords)
 import Control.Monad (liftM)
+import Data.List (isInfixOf)
 import Data.Maybe (fromJust, isNothing, catMaybes)
 import Ella.Forms.Base
 import Ella.GenUtils (exactParse, getTimestamp, utf8)
     --    this will catch most humans using a browser
 
       ts <- getTimestamp
+      spamwords <- getSpamWords
       let text = postedData "message" `captureOrDefault` ""
       let name = strip (postedData "name" `captureOrDefault` "")
       let email = postedData "email" `captureOrDefault` ""
                      ("name", "Name too long"))
                   , (test_ts == 0, -- field missing
                      ("timestamp", "Appears to be spam"))
-                  , (ts < test_ts + 10,
+                  , (ts < test_ts + 15,
                      ("timestamp", "That didn't take long to write! Spammer?"))
+                  , (any (\w -> w `isInfixOf` text) spamwords,
+                     ("text", "Spam.  No thanks."))
                   ]
       let errors = map snd $ filter fst $ tests
 

src/Blog/Model.hs

                   , checkPassword
                   , setCommentVisible
                   , setCommentResponse
+                  , getSpamWords
+                  , addSpamWord
                   ) where
 
 import Data.Digest.Pure.SHA (showDigest, sha1)
 setCommentHiddenQuery      = "UPDATE comments SET hidden = ? WHERE id = ?;"
 setCommentResponseQuery    = "UPDATE comments SET response = ? WHERE id = ?;"
 
+getSpamWordsQuery          = "SELECT word FROM spamwords;"
+addSpamWordQuery           = "INSERT into spamwords (word) VALUES (?);"
+
 ---- Constructors ----
 
 makePost row =
                                                          ]
                      )
   return ()
+
+getSpamWords :: IO [String]
+getSpamWords = do
+  cn <- DB.connect
+  res <- quickQuery' cn getSpamWordsQuery []
+  return [fromSql $ row !! 0 | row <- res]
+
+addSpamWord :: (IConnection conn) => conn -> String -> IO ()
+addSpamWord cn word = do
+  withTransaction cn (\cn ->
+                          run cn addSpamWordQuery [ toSql word ]
+                     )
+  return ()

src/Blog/Routes.hs

          , "admin/ajax/commentvisible/" <+/> empty    //-> adminCommentVisible    $ [adminRequired]
          , "admin/ajax/commentresponse/" <+/> empty   //-> adminCommentResponse   $ [adminRequired]
          , "admin/ajax/commentdelete/" <+/> empty     //-> adminCommentDelete     $ [adminRequired]
+         , "admin/ajax/addspamword/" <+/> empty       //-> addSpamWordView        $ [adminRequired]
          , "debug/" <+/> anyParam                     //-> debug                  $ []
          ]

src/Blog/Views.hs

        action cn commentId
        return $ Just success
 
+addSpamWordView req = do
+  let word = getPOST req "word" `captureOrDefault` ""
+  if null word
+     then return $ Just $ failure
+     else do
+       cn <- connect
+       addSpamWord cn word
+       return $ Just success
 
 -- Authentication
 createLoginCookies loginData timestamp =