Used stylish-haskell on all source files
This commit is contained in:
parent
8f1b6b5c4e
commit
9719b5a62d
5 changed files with 125 additions and 105 deletions
43
src/Blog.hs
43
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 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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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]"
|
||||
|
|
69
src/Main.hs
69
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
|
||||
|
|
18
src/RSS.hs
18
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)
|
||||
renderFeed l e = createFeed l e >>= (\feed -> return $ showXML $ rssToXML feed)
|
||||
|
|
Loading…
Reference in a new issue