maurice/snix
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

chore(tazblog): Format source files with ormolu

Browse source 
Ormolu's formatting is quite annoying (it uses a lot of unnecessary
vertical space and doesn't align elements), but I can't be bothered to
do manual formatting - especially because whatever formatting
haskell-mode in Emacs produces seems to depend on an opaque state
machine or something.
This commit is contained in:
Vincent Ambo 2019-08-25 20:15:53 +01:00
parent 2fdc872228
commit 1747df418e
5 changed files with 187 additions and 151 deletions
Download patch file Download diff file Expand all files Collapse all files

75
services/tazblog/src/Server.hs
View file

@ -1,16 +1,19 @@
{-# LANGUAGE RecordWildCards, ScopedTypeVariables, OverloadedStrings, FlexibleContexts #-}
module Server where
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
import Control.Applicative (optional)
import Control.Monad (msum)
import Control.Monad.IO.Class (liftIO)
import Data.Char (toLower)
import qualified Data.Text as T
import Happstack.Server hiding (Session)
import Data.Maybe (maybe)
module Server where
import Blog
import BlogStore
import Control.Applicative (optional)
import Control.Monad (msum)
import Control.Monad.IO.Class (liftIO)
import Data.Char (toLower)
import Data.Maybe (maybe)
import qualified Data.Text as T
import Happstack.Server hiding (Session)
import Locales
import RSS
@ -19,7 +22,7 @@ instance FromReqURI BlogLang where
case map toLower sub of
"de" -> Just DE
"en" -> Just EN
_ -> Nothing
_ -> Nothing
pageSize :: Int
pageSize = 3
@ -34,21 +37,23 @@ runBlog port respath = do
tazBlog :: BlogCache -> String -> ServerPart Response
tazBlog cache resDir = do
msum [ path $ \(lang :: BlogLang) -> blogHandler cache lang
, dir "static" $ staticHandler resDir
, blogHandler cache EN
, staticHandler resDir
, notFound $ toResponse $ showError NotFound DE
]
msum
[ path $ \(lang :: BlogLang) -> blogHandler cache lang,
dir "static" $ staticHandler resDir,
blogHandler cache EN,
staticHandler resDir,
notFound $ toResponse $ showError NotFound DE
]
blogHandler :: BlogCache -> BlogLang -> ServerPart Response
blogHandler cache lang =
msum [ path $ \(eId :: Integer) -> showEntry cache lang $ EntryId eId
, nullDir >> showIndex cache lang
, dir "rss" $ nullDir >> showRSS cache lang
, dir "rss.xml" $ nullDir >> showRSS cache lang
, notFound $ toResponse $ showError NotFound lang
]
msum
[ path $ \(eId :: Integer) -> showEntry cache lang $ EntryId eId,
nullDir >> showIndex cache lang,
dir "rss" $ nullDir >> showRSS cache lang,
dir "rss.xml" $ nullDir >> showRSS cache lang,
notFound $ toResponse $ showError NotFound lang
]
staticHandler :: String -> ServerPart Response
staticHandler resDir = do
@ -58,29 +63,29 @@ staticHandler resDir = do
showEntry :: BlogCache -> BlogLang -> EntryId -> ServerPart Response
showEntry cache lang eId = do
entry <- getEntry cache eId
tryEntry entry lang
entry <- getEntry cache eId
tryEntry entry lang
tryEntry :: Maybe Entry -> BlogLang -> ServerPart Response
tryEntry Nothing lang = notFound $ toResponse $ showError NotFound lang
tryEntry (Just entry) _ = ok $ toResponse $ blogTemplate eLang eTitle $ renderEntry entry
where
eTitle = T.append ": " (title entry)
eLang = lang entry
where
eTitle = T.append ": " (title entry)
eLang = lang entry
offset :: Maybe Int -> Int
offset = maybe 0 ((*) pageSize)
showIndex :: BlogCache -> BlogLang -> ServerPart Response
showIndex cache lang = do
(page :: Maybe Int) <- optional $ lookRead "page"
entries <- listEntries cache (offset page) pageSize
ok $ toResponse $ blogTemplate lang "" $
renderEntries entries (Just $ showLinks page lang)
(page :: Maybe Int) <- optional $ lookRead "page"
entries <- listEntries cache (offset page) pageSize
ok $ toResponse $ blogTemplate lang ""
$ renderEntries entries (Just $ showLinks page lang)
showRSS :: BlogCache -> BlogLang -> ServerPart Response
showRSS cache lang = do
entries <- listEntries cache 0 4
feed <- liftIO $ renderFeed lang entries
setHeaderM "content-type" "text/xml"
ok $ toResponse feed
entries <- listEntries cache 0 4
feed <- liftIO $ renderFeed lang entries
setHeaderM "content-type" "text/xml"
ok $ toResponse feed