blob: bec4d529092cdcb209adfc6d6a447e9305f4c36e (
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
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Server where
import Blog
import BlogStore
import Control.Applicative (optional)
import Control.Monad (msum)
import Control.Monad.IO.Class (liftIO)
import Data.Maybe (maybe)
import qualified Data.Text as T
import Happstack.Server hiding (Session)
import RSS
pageSize :: Int
pageSize = 3
tmpPolicy :: BodyPolicy
tmpPolicy = defaultBodyPolicy "/tmp" 0 200000 1000
runBlog :: Int -> String -> IO ()
runBlog port respath = do
withCache "blog.tazj.in." $ \cache ->
simpleHTTP nullConf {port = port} $ tazblog cache respath
tazblog :: BlogCache -> String -> ServerPart Response
tazblog cache resDir = do
msum
[ -- legacy language-specific routes
dir "de" $ blogHandler cache,
dir "en" $ blogHandler cache,
dir "static" $ staticHandler resDir,
blogHandler cache,
staticHandler resDir,
notFound $ toResponse $ showError "Not found" "Page not found"
]
blogHandler :: BlogCache -> ServerPart Response
blogHandler cache =
msum
[ path $ \(eId :: Integer) -> showEntry cache $ EntryId eId,
nullDir >> showIndex cache,
dir "rss" $ nullDir >> showRSS cache,
dir "rss.xml" $ nullDir >> showRSS cache
]
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 -> EntryId -> ServerPart Response
showEntry cache eId = do
entry <- getEntry cache eId
tryEntry entry
tryEntry :: Maybe Entry -> ServerPart Response
tryEntry Nothing = notFound $ toResponse $ showError "Not found" "Blog entry not found"
tryEntry (Just entry) = ok $ toResponse $ blogTemplate eTitle $ renderEntry entry
where
eTitle = T.append ": " (title entry)
offset :: Maybe Int -> Int
offset = maybe 0 ((*) pageSize)
showIndex :: BlogCache -> ServerPart Response
showIndex cache = do
(page :: Maybe Int) <- optional $ lookRead "page"
entries <- listEntries cache (offset page) pageSize
ok $ toResponse $ blogTemplate ""
$ renderEntries entries (Just $ showLinks page)
showRSS :: BlogCache -> ServerPart Response
showRSS cache = do
entries <- listEntries cache 0 4
feed <- liftIO $ renderFeed entries
setHeaderM "content-type" "text/xml"
ok $ toResponse feed
|
