mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Used stylish-haskell on all source files

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

43
src/Blog.hs
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 module Blog where
import Control.Monad (when, unless) import BlogDB
import Data.Data (Data, Typeable) import Control.Monad (unless, when)
import Data.List (intersperse) import Data.Data (Data, Typeable)
import Data.Maybe (fromJust) import Data.List (intersperse)
import Data.Monoid (mempty) import Data.Maybe (fromJust)
import Data.Text (Text, append, pack, empty) import Data.Monoid (mempty)
import Data.Text.Lazy (fromStrict) import Data.Text (Text, append, empty, pack)
import Data.Time import Data.Text.Lazy (fromStrict)
import Network.Captcha.ReCaptcha import Data.Time
import System.Locale (defaultTimeLocale) import Locales
import Text.Blaze.Html (preEscapedToHtml) import Network.Captcha.ReCaptcha
import Text.Hamlet import System.Locale (defaultTimeLocale)
import Text.Lucius import Text.Blaze.Html (preEscapedToHtml)
import Text.Markdown import Text.Hamlet
import Locales import Text.Lucius
import BlogDB import Text.Markdown
import qualified Data.Text as T import qualified Data.Text as T
-- custom list functions -- custom list functions
intersperse' :: a -> [a] -> [a] intersperse' :: a -> [a] -> [a]
@ -39,7 +44,7 @@ data BlogURL = BlogURL
-- blog CSS (admin is still static) -- blog CSS (admin is still static)
stylesheetSource = $(luciusFile "res/blogstyle.lucius") stylesheetSource = $(luciusFile "res/blogstyle.lucius")
blogStyle = renderCssUrl undefined stylesheetSource blogStyle = renderCssUrl undefined stylesheetSource
-- blog HTML -- blog HTML
blogTemplate :: BlogLang -> Text -> Html -> Html blogTemplate :: BlogLang -> Text -> Html -> Html

82
src/BlogDB.hs
View file

@ -1,30 +1,36 @@
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, RecordWildCards, {-# LANGUAGE DeriveDataTypeable #-}
TemplateHaskell, TypeFamilies, OverloadedStrings, ScopedTypeVariables, BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module BlogDB where module BlogDB where
import Control.Monad.Reader (ask) import Control.Monad.Reader (ask)
import Control.Monad.State (get, put) import Control.Monad.State (get, put)
import Data.Acid import Data.Acid
import Data.Acid.Advanced import Data.Acid.Advanced
import Data.Acid.Local import Data.Acid.Local
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Char (toLower) import Data.Char (toLower)
import Data.Data (Data, Typeable) import Data.Data (Data, Typeable)
import Data.IxSet (Indexable(..), IxSet(..), (@=), Proxy(..), getOne, ixFun, ixSet) import Data.IxSet (Indexable (..), IxSet (..), Proxy (..),
import Data.List (insert) getOne, ixFun, ixSet, (@=))
import Data.SafeCopy (SafeCopy, base, deriveSafeCopy) import Data.List (insert)
import Data.Text (Text, pack) import Data.SafeCopy (SafeCopy, base, deriveSafeCopy)
import Data.Text.Lazy (toStrict) import Data.Text (Text, pack)
import Data.Time import Data.Text.Lazy (toStrict)
import Happstack.Server (FromReqURI(..)) import Data.Time
import System.Environment (getEnv) import Happstack.Server (FromReqURI (..))
import System.Environment (getEnv)
import qualified Crypto.Hash.SHA512 as SHA (hash) import qualified Crypto.Hash.SHA512 as SHA (hash)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Base64 as B64 (encode) import qualified Data.ByteString.Base64 as B64 (encode)
import qualified Data.IxSet as IxSet import qualified Data.ByteString.Char8 as B
import qualified Data.Text as Text import qualified Data.IxSet as IxSet
import qualified Data.Text as Text
newtype EntryId = EntryId { unEntryId :: Integer } newtype EntryId = EntryId { unEntryId :: Integer }
@ -33,7 +39,7 @@ newtype EntryId = EntryId { unEntryId :: Integer }
instance Show EntryId where instance Show EntryId where
show = show . unEntryId show = show . unEntryId
data BlogLang = EN | DE data BlogLang = EN | DE
deriving (Eq, Ord, Data, Typeable) deriving (Eq, Ord, Data, Typeable)
instance Show BlogLang where instance Show BlogLang where
@ -41,7 +47,7 @@ instance Show BlogLang where
show EN = "en" show EN = "en"
instance FromReqURI BlogLang where instance FromReqURI BlogLang where
fromReqURI sub = fromReqURI sub =
case map toLower sub of case map toLower sub of
"de" -> Just DE "de" -> Just DE
"en" -> Just EN "en" -> Just EN
@ -58,14 +64,14 @@ data Comment = Comment {
$(deriveSafeCopy 0 'base ''Comment) $(deriveSafeCopy 0 'base ''Comment)
data Entry = Entry { data Entry = Entry {
entryId :: EntryId, entryId :: EntryId,
lang :: BlogLang, lang :: BlogLang,
author :: Text, author :: Text,
title :: Text, title :: Text,
btext :: Text, btext :: Text,
mtext :: Text, mtext :: Text,
edate :: UTCTime, edate :: UTCTime,
tags :: [Text], tags :: [Text],
comments :: [Comment] comments :: [Comment]
} deriving (Eq, Ord, Show, Data, Typeable) } 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 Username = Username Text deriving (Eq, Ord, Data, Typeable, SafeCopy)
newtype SessionID = SessionID 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] empty = ixSet [ ixFun $ \e -> [ entryId e]
, ixFun $ (:[]) . lang , ixFun $ (:[]) . lang
, ixFun $ \e -> [ Author $ author e ] , ixFun $ \e -> [ Author $ author e ]
@ -111,7 +117,7 @@ $(deriveSafeCopy 0 'base ''Session)
instance Indexable User where instance Indexable User where
empty = ixSet [ ixFun $ \u -> [Username $ username u] empty = ixSet [ ixFun $ \u -> [Username $ username u]
, ixFun $ (:[]) . password , ixFun $ (:[]) . password
] ]
instance Indexable Session where instance Indexable Session where
@ -128,8 +134,8 @@ data Blog = Blog {
$(deriveSafeCopy 0 'base ''Blog) $(deriveSafeCopy 0 'base ''Blog)
initialBlogState :: Blog initialBlogState :: Blog
initialBlogState = initialBlogState =
Blog { blogSessions = empty Blog { blogSessions = empty
, blogUsers = empty , blogUsers = empty
, blogEntries = empty } , blogEntries = empty }
@ -137,7 +143,7 @@ initialBlogState =
-- acid-state database functions (purity is necessary!) -- acid-state database functions (purity is necessary!)
insertEntry :: Entry -> Update Blog Entry insertEntry :: Entry -> Update Blog Entry
insertEntry e = insertEntry e =
do b@Blog{..} <- get do b@Blog{..} <- get
put $ b { blogEntries = IxSet.insert e blogEntries } put $ b { blogEntries = IxSet.insert e blogEntries }
return e return e
@ -159,7 +165,7 @@ deleteComment eId cDate =
return newEntry return newEntry
updateEntry :: Entry -> Update Blog Entry updateEntry :: Entry -> Update Blog Entry
updateEntry e = updateEntry e =
do b@Blog{..} <- get do b@Blog{..} <- get
put $ b { blogEntries = IxSet.updateIx (entryId e) e blogEntries} put $ b { blogEntries = IxSet.updateIx (entryId e) e blogEntries}
return e return e

18
src/Locales.hs
View file

@ -1,15 +1,17 @@
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Locales where module Locales where
import Data.Data (Data, Typeable) import Data.Data (Data, Typeable)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Network.URI import Network.URI
import BlogDB (BlogLang (..)) import BlogDB (BlogLang (..))
{- to add a language simply define its abbreviation and Show instance then {- to add a language simply define its abbreviation and Show instance then
- translate the appropriate strings and add CouchDB views in Server.hs -} - 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 getMonth l y m = T.append (monthName l m) $ T.pack $ show y
where where
monthName :: BlogLang -> Int -> Text monthName :: BlogLang -> Int -> Text
monthName DE m = case m of monthName DE m = case m of
1 -> "Januar " 1 -> "Januar "
2 -> "Februar " 2 -> "Februar "
3 -> "März " 3 -> "März "
@ -116,7 +118,7 @@ cwHead EN = "Comment:"
cSingle :: BlogLang -> Text cSingle :: BlogLang -> Text
cSingle DE = "Kommentar:" --input label cSingle DE = "Kommentar:" --input label
cSingle EN = "Comment:" cSingle EN = "Comment:"
cTimeFormat :: BlogLang -> String --formatTime expects a String cTimeFormat :: BlogLang -> String --formatTime expects a String
cTimeFormat DE = "[Am %d.%m.%y um %H:%M Uhr]" cTimeFormat DE = "[Am %d.%m.%y um %H:%M Uhr]"

69
src/Main.hs
View file

@ -1,36 +1,43 @@
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, GeneralizedNewtypeDeriving, {-# LANGUAGE DeriveDataTypeable #-}
DeriveDataTypeable, FlexibleContexts, MultiParamTypeClasses, TemplateHaskell, {-# LANGUAGE FlexibleContexts #-}
TypeFamilies, RecordWildCards, BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Main where module Main where
import Control.Applicative ((<$>), (<*>), optional, pure) import Control.Applicative (optional, pure, (<$>), (<*>))
import Control.Exception (bracket) import Control.Exception (bracket)
import Control.Monad (msum, mzero, when, unless) import Control.Monad (msum, mzero, unless, when)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.State (get, put) import Control.Monad.Reader (ask)
import Control.Monad.Reader (ask) import Control.Monad.State (get, put)
import qualified Crypto.Hash.SHA512 as SHA import qualified Crypto.Hash.SHA512 as SHA
import Data.Acid import Data.Acid
import Data.Acid.Advanced import Data.Acid.Advanced
import Data.Acid.Local import Data.Acid.Local
import qualified Data.ByteString.Base64 as B64 (encode) import qualified Data.ByteString.Base64 as B64 (encode)
import Data.ByteString.Char8 (ByteString, pack, unpack) import Data.ByteString.Char8 (ByteString, pack, unpack)
import Data.Data (Data, Typeable) import Data.Data (Data, Typeable)
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Data.Monoid (mempty) import Data.Monoid (mempty)
import Data.Text (Text) import Data.SafeCopy (base, deriveSafeCopy)
import qualified Data.Text as T import Data.Text (Text)
import qualified Data.Text as T
import Data.Time import Data.Time
import Data.SafeCopy (base, deriveSafeCopy) import Happstack.Server hiding (Session)
import Happstack.Server hiding (Session)
import Happstack.Server.Compression import Happstack.Server.Compression
import Network.Captcha.ReCaptcha import Network.Captcha.ReCaptcha
import Options import Options
import System.Locale (defaultTimeLocale) import System.Locale (defaultTimeLocale)
import Blog import Blog
import BlogDB hiding (addComment, updateEntry, deleteComment) import BlogDB hiding (addComment, deleteComment,
updateEntry)
import Locales import Locales
import RSS import RSS
@ -86,7 +93,7 @@ tazBlog acid captchakey = do
, do dir "admin" $ nullDir , do dir "admin" $ nullDir
guardSession acid guardSession acid
ok $ toResponse $ adminIndex ("tazjin" :: Text) ok $ toResponse $ adminIndex ("tazjin" :: Text)
, dir "admin" $ ok $ toResponse $ adminLogin , dir "admin" $ ok $ toResponse $ adminLogin
, dir "dologin" $ processLogin acid , dir "dologin" $ processLogin acid
, do dirs "static/blogv34.css" $ nullDir , do dirs "static/blogv34.css" $ nullDir
setHeaderM "content-type" "text/css" setHeaderM "content-type" "text/css"
@ -101,10 +108,10 @@ tazBlog acid captchakey = do
] ]
blogHandler :: AcidState Blog -> BlogLang -> String -> ServerPart Response blogHandler :: AcidState Blog -> BlogLang -> String -> ServerPart Response
blogHandler acid lang captchakey = blogHandler acid lang captchakey =
msum [ path $ \(eId :: Integer) -> showEntry acid lang $ EntryId eId msum [ path $ \(eId :: Integer) -> showEntry acid lang $ EntryId eId
, do decodeBody tmpPolicy , do decodeBody tmpPolicy
dir "postcomment" $ path $ dir "postcomment" $ path $
\(eId :: Integer) -> addComment acid lang captchakey $ EntryId eId \(eId :: Integer) -> addComment acid lang captchakey $ EntryId eId
, nullDir >> showIndex acid lang , nullDir >> showIndex acid lang
, dir "rss" $ nullDir >> showRSS acid lang , dir "rss" $ nullDir >> showRSS acid lang
@ -113,8 +120,8 @@ blogHandler acid lang captchakey =
] ]
formatOldLink :: Int -> Int -> String -> ServerPart Response formatOldLink :: Int -> Int -> String -> ServerPart Response
formatOldLink y m id_ = formatOldLink y m id_ =
flip seeOther (toResponse ()) $ flip seeOther (toResponse ()) $
concat $ intersperse' "/" ["de", show y, show m, replace '.' '/' id_] concat $ intersperse' "/" ["de", show y, show m, replace '.' '/' id_]
showEntry :: AcidState Blog -> BlogLang -> EntryId -> ServerPart Response showEntry :: AcidState Blog -> BlogLang -> EntryId -> ServerPart Response
@ -133,12 +140,12 @@ showIndex :: AcidState Blog -> BlogLang -> ServerPart Response
showIndex acid lang = do showIndex acid lang = do
entries <- query' acid (LatestEntries lang) entries <- query' acid (LatestEntries lang)
(page :: Maybe Int) <- optional $ lookRead "page" (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) renderEntries False (eDrop page entries) (topText lang) (Just $ showLinks page lang)
where where
eDrop :: Maybe Int -> [a] -> [a] eDrop :: Maybe Int -> [a] -> [a]
eDrop (Just i) = drop ((i-1) * 6) eDrop (Just i) = drop ((i-1) * 6)
eDrop Nothing = drop 0 eDrop Nothing = drop 0
showRSS :: AcidState Blog -> BlogLang -> ServerPart Response showRSS :: AcidState Blog -> BlogLang -> ServerPart Response
showRSS acid lang = do showRSS acid lang = do
@ -159,8 +166,8 @@ addComment acid lang captchakey eId = do
response <- look "recaptcha_response_field" response <- look "recaptcha_response_field"
(userIp, _) <- askRq >>= return . rqPeer (userIp, _) <- askRq >>= return . rqPeer
validation <- liftIO $ validateCaptcha captchakey userIp challenge response validation <- liftIO $ validateCaptcha captchakey userIp challenge response
case validation of case validation of
Right _ -> update' acid (AddComment eId nComment) Right _ -> update' acid (AddComment eId nComment)
>> seeOther ("/" ++ show lang ++ "/" ++ show eId) (toResponse()) >> seeOther ("/" ++ show lang ++ "/" ++ show eId) (toResponse())
Left _ -> (liftIO $ putStrLn "Captcha failed") >> 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;" ltEscape = T.replace "<" "&lt;"
gtEscape = T.replace ">" "&gt;" gtEscape = T.replace ">" "&gt;"
{- ADMIN stuff -} {- ADMIN stuff -}
postEntry :: AcidState Blog -> ServerPart Response postEntry :: AcidState Blog -> ServerPart Response
postEntry acid = do postEntry acid = do

18
src/RSS.hs
View file

@ -2,15 +2,15 @@
module RSS (renderFeed) where module RSS (renderFeed) where
import qualified Data.Text as T import qualified Data.Text as T
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Time (getCurrentTime, UTCTime) import Data.Time (UTCTime, getCurrentTime)
import Network.URI import Network.URI
import Text.RSS import Text.RSS
import Locales import BlogDB hiding (Title)
import BlogDB hiding (Title) import Locales
createChannel :: BlogLang -> UTCTime -> [ChannelElem] createChannel :: BlogLang -> UTCTime -> [ChannelElem]
createChannel l now = [ Language $ show l 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 createRSS l t i = RSS (rssTitle l) (rssLink l) (rssDesc l) (createChannel l t) i
createItem :: Entry -> Item createItem :: Entry -> Item
createItem Entry{..} = [ Title $ T.unpack title createItem Entry{..} = [ Title $ T.unpack title
, Link $ makeLink lang entryId , Link $ makeLink lang entryId
, Description $ T.unpack btext , Description $ T.unpack btext
, PubDate edate] , PubDate edate]
@ -39,4 +39,4 @@ createFeed :: BlogLang -> [Entry] -> IO RSS
createFeed l e = getCurrentTime >>= (\t -> return $ createRSS l t $ createItems e ) createFeed l e = getCurrentTime >>= (\t -> return $ createRSS l t $ createItems e )
renderFeed :: BlogLang -> [Entry] -> IO String 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)