about summary refs log tree commit diff
diff options
context:
space:
mode:
-rw-r--r--src/Blog.hs45
-rw-r--r--src/BlogDB.hs84
-rw-r--r--src/Locales.hs18
-rw-r--r--src/Main.hs69
-rw-r--r--src/RSS.hs18
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 "<" "&lt;"
         gtEscape = T.replace ">" "&gt;"
 
-{- 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)