diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Blog.hs | 25 | ||||
| -rw-r--r-- | src/Locales.hs | 6 | ||||
| -rw-r--r-- | src/Main.hs | 32 |
3 files changed, 49 insertions, 14 deletions
diff --git a/src/Blog.hs b/src/Blog.hs index 631bfa013d34..2d3fe305bf85 100644 --- a/src/Blog.hs +++ b/src/Blog.hs @@ -9,12 +9,14 @@ import Data.Monoid (mempty) import Data.Text (Text) import qualified Data.Text as T import Data.Time +import Network.Captcha.ReCaptcha import System.Locale (defaultTimeLocale) -import Text.Blaze (toValue, preEscapedText) +import Text.Blaze (toValue, preEscapedText, preEscapedString) import Text.Blaze.Html5 (Html, (!), a, form, input, p, toHtml, label) import Text.Blaze.Html5.Attributes (action, enctype, href, name, size, type_, value) import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A +import Text.XHtml.Strict (showHtmlFragment) import Locales import BlogDB @@ -26,6 +28,21 @@ intersperse' sep l = sep : intersperse sep l replace :: Eq a => a -> a -> [a] -> [a] replace x y = map (\z -> if z == x then y else z) +-- javascript and others + +captcha :: Html +captcha = H.div ! A.class_ "cCaptcha" $ + do H.script ! A.src "http://api.recaptcha.net/challenge?k=6LfQXccSAAAAAIjKm26XlFnBMAgvaKlOAjVWEEnM" ! A.type_ "text/javascript" $ "" + H.noscript $ H.iframe ! A.src "http://api.recaptcha.net/noscript?k=6LfQXccSAAAAAIjKm26XlFnBMAgvaKlOAjVWEEnM" ! A.height "300" ! + A.width "500" ! A.seamless "" $ do + H.br + H.textarea ! A.name "recaptcha_challenge_field" ! A.rows "3" ! A.cols "40" $ "" + H.input ! A.type_ "hidden" ! A.name "recaptcha_response_field" ! A.value "manual_challenge" + +captchaOptions :: BlogLang -> Html +captchaOptions lang = H.script ! A.type_ "text/javascript" $ toHtml $ + T.concat ["var RecaptchaOptions = { theme: 'clean', lang: '", showLangText lang, "'};"] + analytics :: Text analytics = T.pack $ unlines ["<script type=\"text/javascript\">" ," var _gaq = _gaq || [];" @@ -38,12 +55,14 @@ analytics = T.pack $ unlines ["<script type=\"text/javascript\">" ," })();" ,"</script>"] +-- blog HTML + blogTemplate :: BlogLang -> Text -> Html -> Html blogTemplate lang t_append body = H.docTypeHtml $ do --add body H.head $ do H.title $ (toHtml $ blogTitle lang t_append) H.link ! A.rel "alternate" ! A.type_ "application/rss+xml" ! A.title "RSS-Feed" ! A.href (toValue feedURL) - H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/static/blogv312.css" ! A.media "all" + H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/static/blogv33.css" ! A.media "all" --H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/res/blogstyle.css" ! A.media "all" H.meta ! A.httpEquiv "content-type" ! A.content "text/html;charset=UTF-8" --H.style ! A.type_ "text/css" ! A.title "iOS iMessage" ! A.media "screen and (max-device-width: 1024px)" $ "#cosx{display:none;}" @@ -116,10 +135,12 @@ renderEntry (Entry{..}) = do renderCommentBox :: BlogLang -> EntryId -> Html renderCommentBox cLang cId = do H.div ! A.class_ "cHead" $ toHtml $ cwHead cLang + captchaOptions cLang H.form ! A.method "POST" ! A.action (toValue $ "/" ++ (show cLang) ++ "/postcomment/" ++ show cId) $ do H.p $ H.input ! A.name "cname" ! A.placeholder "Name" ! A.class_ "cInput" H.p $ H.label $ H.textarea ! A.name "ctext" ! A.cols "50" ! A.rows "13" ! A.class_ "cInput" ! A.placeholder (toValue $ cTextPlaceholder cLang) $ mempty + H.p $ H.label $ captcha H.p $ H.input ! A.class_ "cInput" ! A.style "width: 120px;" ! A.type_ "submit" ! A.value (toValue $ cSend cLang) renderComments :: [Comment] -> BlogLang -> Html diff --git a/src/Locales.hs b/src/Locales.hs index 8041c4178b0f..b49434303658 100644 --- a/src/Locales.hs +++ b/src/Locales.hs @@ -16,7 +16,7 @@ import BlogDB (BlogLang (..)) data BlogError = NotFound | DBError -version = "3.2" +version = "3.3" allLang = [EN, DE] @@ -28,6 +28,10 @@ blogTitle :: BlogLang -> Text -> Text blogTitle DE s = T.concat ["Tazjins Blog", s] blogTitle EN s = T.concat ["Tazjin's Blog", s] +showLangText :: BlogLang -> Text +showLangText EN = "en" +showLangText DE = "de" + -- index site headline topText DE = "Aktuelle Einträge" topText EN = "Latest entries" 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 |