Used stylish-haskell on all source files

This commit is contained in:
"Vincent Ambo ext:(%22) 2013-04-28 14:30:00 +02:00
parent 8f1b6b5c4e
commit 9719b5a62d
5 changed files with 125 additions and 105 deletions

View file

@ -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 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
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

View file

@ -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 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 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

View file

@ -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]"

View file

@ -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

View file

@ -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)
renderFeed l e = createFeed l e >>= (\feed -> return $ showXML $ rssToXML feed)