blob: 57b1463268c22c360eb15b33547358be659cb337 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
|
{-# LANGUAGE RecordWildCards, ScopedTypeVariables, OverloadedStrings, FlexibleContexts #-}
module Server where
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)
import Blog
import BlogStore
import Locales
import RSS
instance FromReqURI BlogLang where
fromReqURI sub =
case map toLower sub of
"de" -> Just DE
"en" -> Just EN
_ -> Nothing
pageSize :: Integer
pageSize = 3
tmpPolicy :: BodyPolicy
tmpPolicy = defaultBodyPolicy "/tmp" 0 200000 1000
runBlog :: Int -> String -> IO ()
runBlog port respath = do
cache <- newCache "blog.tazj.in."
simpleHTTP nullConf {port = port} $ tazBlog cache respath
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
]
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
]
staticHandler :: String -> ServerPart Response
staticHandler resDir = do
setHeaderM "cache-control" "max-age=630720000"
setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT"
serveDirectory DisableBrowsing [] resDir
showEntry :: BlogCache -> BlogLang -> EntryId -> ServerPart Response
showEntry cache lang eId = do
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
offset :: Maybe Integer -> Integer
offset = maybe 0 ((*) pageSize)
showIndex :: BlogCache -> BlogLang -> ServerPart Response
showIndex cache lang = do
(page :: Maybe Integer) <- 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
|
