diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Blog.hs | 45 | ||||
| -rw-r--r-- | src/BlogDB.hs | 84 | ||||
| -rw-r--r-- | src/Locales.hs | 18 | ||||
| -rw-r--r-- | src/Main.hs | 69 | ||||
| -rw-r--r-- | src/RSS.hs | 18 |
5 files changed, 127 insertions, 107 deletions
diff --git a/src/Blog.hs b/src/Blog.hs index 9c66a20101c8..2c1a546a2a57 100644 --- a/src/Blog.hs +++ b/src/Blog.hs @@ -1,25 +1,30 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable, TemplateHaskell, QuasiQuotes, RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Blog where -import Control.Monad (when, unless) -import Data.Data (Data, Typeable) -import Data.List (intersperse) -import Data.Maybe (fromJust) -import Data.Monoid (mempty) -import Data.Text (Text, append, pack, empty) -import Data.Text.Lazy (fromStrict) -import Data.Time -import Network.Captcha.ReCaptcha -import System.Locale (defaultTimeLocale) -import Text.Blaze.Html (preEscapedToHtml) -import Text.Hamlet -import Text.Lucius -import Text.Markdown -import Locales -import BlogDB - -import qualified Data.Text as T +import BlogDB +import Control.Monad (unless, when) +import Data.Data (Data, Typeable) +import Data.List (intersperse) +import Data.Maybe (fromJust) +import Data.Monoid (mempty) +import Data.Text (Text, append, empty, pack) +import Data.Text.Lazy (fromStrict) +import Data.Time +import Locales +import Network.Captcha.ReCaptcha +import System.Locale (defaultTimeLocale) +import Text.Blaze.Html (preEscapedToHtml) +import Text.Hamlet +import Text.Lucius +import Text.Markdown + +import qualified Data.Text as T -- custom list functions intersperse' :: a -> [a] -> [a] @@ -39,7 +44,7 @@ data BlogURL = BlogURL -- blog CSS (admin is still static) stylesheetSource = $(luciusFile "res/blogstyle.lucius") -blogStyle = renderCssUrl undefined stylesheetSource +blogStyle = renderCssUrl undefined stylesheetSource -- blog HTML blogTemplate :: BlogLang -> Text -> Html -> Html diff --git a/src/BlogDB.hs b/src/BlogDB.hs index 611a08914a09..b2551ecc3d99 100644 --- a/src/BlogDB.hs +++ b/src/BlogDB.hs @@ -1,30 +1,36 @@ -{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, RecordWildCards, -TemplateHaskell, TypeFamilies, OverloadedStrings, ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module BlogDB where -import Control.Monad.Reader (ask) -import Control.Monad.State (get, put) -import Data.Acid -import Data.Acid.Advanced -import Data.Acid.Local -import Data.ByteString (ByteString) -import Data.Char (toLower) -import Data.Data (Data, Typeable) -import Data.IxSet (Indexable(..), IxSet(..), (@=), Proxy(..), getOne, ixFun, ixSet) -import Data.List (insert) -import Data.SafeCopy (SafeCopy, base, deriveSafeCopy) -import Data.Text (Text, pack) -import Data.Text.Lazy (toStrict) -import Data.Time -import Happstack.Server (FromReqURI(..)) -import System.Environment (getEnv) - -import qualified Crypto.Hash.SHA512 as SHA (hash) -import qualified Data.ByteString.Char8 as B +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) +import Data.Acid +import Data.Acid.Advanced +import Data.Acid.Local +import Data.ByteString (ByteString) +import Data.Char (toLower) +import Data.Data (Data, Typeable) +import Data.IxSet (Indexable (..), IxSet (..), Proxy (..), + getOne, ixFun, ixSet, (@=)) +import Data.List (insert) +import Data.SafeCopy (SafeCopy, base, deriveSafeCopy) +import Data.Text (Text, pack) +import Data.Text.Lazy (toStrict) +import Data.Time +import Happstack.Server (FromReqURI (..)) +import System.Environment (getEnv) + +import qualified Crypto.Hash.SHA512 as SHA (hash) import qualified Data.ByteString.Base64 as B64 (encode) -import qualified Data.IxSet as IxSet -import qualified Data.Text as Text +import qualified Data.ByteString.Char8 as B +import qualified Data.IxSet as IxSet +import qualified Data.Text as Text newtype EntryId = EntryId { unEntryId :: Integer } @@ -33,7 +39,7 @@ newtype EntryId = EntryId { unEntryId :: Integer } instance Show EntryId where show = show . unEntryId -data BlogLang = EN | DE +data BlogLang = EN | DE deriving (Eq, Ord, Data, Typeable) instance Show BlogLang where @@ -41,7 +47,7 @@ instance Show BlogLang where show EN = "en" instance FromReqURI BlogLang where - fromReqURI sub = + fromReqURI sub = case map toLower sub of "de" -> Just DE "en" -> Just EN @@ -58,14 +64,14 @@ data Comment = Comment { $(deriveSafeCopy 0 'base ''Comment) data Entry = Entry { - entryId :: EntryId, - lang :: BlogLang, - author :: Text, - title :: Text, - btext :: Text, - mtext :: Text, - edate :: UTCTime, - tags :: [Text], + entryId :: EntryId, + lang :: BlogLang, + author :: Text, + title :: Text, + btext :: Text, + mtext :: Text, + edate :: UTCTime, + tags :: [Text], comments :: [Comment] } deriving (Eq, Ord, Show, Data, Typeable) @@ -82,7 +88,7 @@ newtype SDate = SDate UTCTime deriving (Eq, Ord, Data, Typeable, SafeCopy) newtype Username = Username Text deriving (Eq, Ord, Data, Typeable, SafeCopy) newtype SessionID = SessionID Text deriving (Eq, Ord, Data, Typeable, SafeCopy) -instance Indexable Entry where +instance Indexable Entry where empty = ixSet [ ixFun $ \e -> [ entryId e] , ixFun $ (:[]) . lang , ixFun $ \e -> [ Author $ author e ] @@ -111,7 +117,7 @@ $(deriveSafeCopy 0 'base ''Session) instance Indexable User where empty = ixSet [ ixFun $ \u -> [Username $ username u] - , ixFun $ (:[]) . password + , ixFun $ (:[]) . password ] instance Indexable Session where @@ -128,8 +134,8 @@ data Blog = Blog { $(deriveSafeCopy 0 'base ''Blog) -initialBlogState :: Blog -initialBlogState = +initialBlogState :: Blog +initialBlogState = Blog { blogSessions = empty , blogUsers = empty , blogEntries = empty } @@ -137,7 +143,7 @@ initialBlogState = -- acid-state database functions (purity is necessary!) insertEntry :: Entry -> Update Blog Entry -insertEntry e = +insertEntry e = do b@Blog{..} <- get put $ b { blogEntries = IxSet.insert e blogEntries } return e @@ -159,7 +165,7 @@ deleteComment eId cDate = return newEntry updateEntry :: Entry -> Update Blog Entry -updateEntry e = +updateEntry e = do b@Blog{..} <- get put $ b { blogEntries = IxSet.updateIx (entryId e) e blogEntries} return e diff --git a/src/Locales.hs b/src/Locales.hs index aaddb484cb26..351485943725 100644 --- a/src/Locales.hs +++ b/src/Locales.hs @@ -1,15 +1,17 @@ -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Locales where -import Data.Data (Data, Typeable) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T +import Data.Data (Data, Typeable) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T import Network.URI -import BlogDB (BlogLang (..)) +import BlogDB (BlogLang (..)) {- to add a language simply define its abbreviation and Show instance then - translate the appropriate strings and add CouchDB views in Server.hs -} @@ -40,7 +42,7 @@ getMonth :: BlogLang -> Int -> Int -> Text getMonth l y m = T.append (monthName l m) $ T.pack $ show y where monthName :: BlogLang -> Int -> Text - monthName DE m = case m of + monthName DE m = case m of 1 -> "Januar " 2 -> "Februar " 3 -> "März " @@ -116,7 +118,7 @@ cwHead EN = "Comment:" cSingle :: BlogLang -> Text cSingle DE = "Kommentar:" --input label -cSingle EN = "Comment:" +cSingle EN = "Comment:" cTimeFormat :: BlogLang -> String --formatTime expects a String cTimeFormat DE = "[Am %d.%m.%y um %H:%M Uhr]" diff --git a/src/Main.hs b/src/Main.hs index a6f59acc2870..09215ba9d54f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,36 +1,43 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, GeneralizedNewtypeDeriving, - DeriveDataTypeable, FlexibleContexts, MultiParamTypeClasses, TemplateHaskell, - TypeFamilies, RecordWildCards, BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Main where -import Control.Applicative ((<$>), (<*>), optional, pure) -import Control.Exception (bracket) -import Control.Monad (msum, mzero, when, unless) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.State (get, put) -import Control.Monad.Reader (ask) -import qualified Crypto.Hash.SHA512 as SHA +import Control.Applicative (optional, pure, (<$>), (<*>)) +import Control.Exception (bracket) +import Control.Monad (msum, mzero, unless, when) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) +import qualified Crypto.Hash.SHA512 as SHA import Data.Acid import Data.Acid.Advanced import Data.Acid.Local -import qualified Data.ByteString.Base64 as B64 (encode) -import Data.ByteString.Char8 (ByteString, pack, unpack) -import Data.Data (Data, Typeable) -import Data.Maybe (fromJust) -import Data.Monoid (mempty) -import Data.Text (Text) -import qualified Data.Text as T +import qualified Data.ByteString.Base64 as B64 (encode) +import Data.ByteString.Char8 (ByteString, pack, unpack) +import Data.Data (Data, Typeable) +import Data.Maybe (fromJust) +import Data.Monoid (mempty) +import Data.SafeCopy (base, deriveSafeCopy) +import Data.Text (Text) +import qualified Data.Text as T import Data.Time -import Data.SafeCopy (base, deriveSafeCopy) -import Happstack.Server hiding (Session) +import Happstack.Server hiding (Session) import Happstack.Server.Compression import Network.Captcha.ReCaptcha import Options -import System.Locale (defaultTimeLocale) +import System.Locale (defaultTimeLocale) import Blog -import BlogDB hiding (addComment, updateEntry, deleteComment) +import BlogDB hiding (addComment, deleteComment, + updateEntry) import Locales import RSS @@ -86,7 +93,7 @@ tazBlog acid captchakey = do , do dir "admin" $ nullDir guardSession acid ok $ toResponse $ adminIndex ("tazjin" :: Text) - , dir "admin" $ ok $ toResponse $ adminLogin + , dir "admin" $ ok $ toResponse $ adminLogin , dir "dologin" $ processLogin acid , do dirs "static/blogv34.css" $ nullDir setHeaderM "content-type" "text/css" @@ -101,10 +108,10 @@ tazBlog acid captchakey = do ] blogHandler :: AcidState Blog -> BlogLang -> String -> ServerPart Response -blogHandler acid lang captchakey = +blogHandler acid lang captchakey = msum [ path $ \(eId :: Integer) -> showEntry acid lang $ EntryId eId , do decodeBody tmpPolicy - dir "postcomment" $ path $ + dir "postcomment" $ path $ \(eId :: Integer) -> addComment acid lang captchakey $ EntryId eId , nullDir >> showIndex acid lang , dir "rss" $ nullDir >> showRSS acid lang @@ -113,8 +120,8 @@ blogHandler acid lang captchakey = ] formatOldLink :: Int -> Int -> String -> ServerPart Response -formatOldLink y m id_ = - flip seeOther (toResponse ()) $ +formatOldLink y m id_ = + flip seeOther (toResponse ()) $ concat $ intersperse' "/" ["de", show y, show m, replace '.' '/' id_] showEntry :: AcidState Blog -> BlogLang -> EntryId -> ServerPart Response @@ -133,12 +140,12 @@ showIndex :: AcidState Blog -> BlogLang -> ServerPart Response showIndex acid lang = do entries <- query' acid (LatestEntries lang) (page :: Maybe Int) <- optional $ lookRead "page" - ok $ toResponse $ blogTemplate lang "" $ + ok $ toResponse $ blogTemplate lang "" $ renderEntries False (eDrop page entries) (topText lang) (Just $ showLinks page lang) where eDrop :: Maybe Int -> [a] -> [a] eDrop (Just i) = drop ((i-1) * 6) - eDrop Nothing = drop 0 + eDrop Nothing = drop 0 showRSS :: AcidState Blog -> BlogLang -> ServerPart Response showRSS acid lang = do @@ -159,8 +166,8 @@ addComment acid lang captchakey eId = do 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) + 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()) @@ -172,7 +179,7 @@ commentEscape = newlineEscape . ltEscape . gtEscape . ampEscape ltEscape = T.replace "<" "<" gtEscape = T.replace ">" ">" -{- ADMIN stuff -} +{- ADMIN stuff -} postEntry :: AcidState Blog -> ServerPart Response postEntry acid = do diff --git a/src/RSS.hs b/src/RSS.hs index 05ae40ece58f..50531c3f8065 100644 --- a/src/RSS.hs +++ b/src/RSS.hs @@ -2,15 +2,15 @@ module RSS (renderFeed) where -import qualified Data.Text as T +import qualified Data.Text as T -import Data.Maybe (fromMaybe) -import Data.Time (getCurrentTime, UTCTime) -import Network.URI -import Text.RSS +import Data.Maybe (fromMaybe) +import Data.Time (UTCTime, getCurrentTime) +import Network.URI +import Text.RSS -import Locales -import BlogDB hiding (Title) +import BlogDB hiding (Title) +import Locales createChannel :: BlogLang -> UTCTime -> [ChannelElem] createChannel l now = [ Language $ show l @@ -23,7 +23,7 @@ createRSS :: BlogLang -> UTCTime -> [Item] -> RSS createRSS l t i = RSS (rssTitle l) (rssLink l) (rssDesc l) (createChannel l t) i createItem :: Entry -> Item -createItem Entry{..} = [ Title $ T.unpack title +createItem Entry{..} = [ Title $ T.unpack title , Link $ makeLink lang entryId , Description $ T.unpack btext , PubDate edate] @@ -39,4 +39,4 @@ createFeed :: BlogLang -> [Entry] -> IO RSS createFeed l e = getCurrentTime >>= (\t -> return $ createRSS l t $ createItems e ) renderFeed :: BlogLang -> [Entry] -> IO String -renderFeed l e = createFeed l e >>= (\feed -> return $ showXML $ rssToXML feed) \ No newline at end of file +renderFeed l e = createFeed l e >>= (\feed -> return $ showXML $ rssToXML feed) |