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
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
module Main where
import Control.Monad (msum, mzero)
import Data.Monoid (mempty)
import Data.ByteString.Char8 (ByteString)
import Data.Text hiding (map, length, zip, head)
import Data.Time
import Database.CouchDB
import Happstack.Server
import Network.CGI (liftIO)
import Text.Blaze (toValue, preEscapedString)
import Text.Blaze.Html5 (Html, (!), a, form, input, p, toHtml, label)
import Text.Blaze.Html5.Attributes (action, enctype, href, name, size, type_, value)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Text.JSON.Generic
import Blog
tmpPolicy :: BodyPolicy
tmpPolicy = (defaultBodyPolicy "./tmp/" 0 1000 1000)
--TazBlog version
version = ("2.2b" :: String)
main :: IO()
main = do
putStrLn ("TazBlog " ++ version ++ " in Haskell starting")
simpleHTTP nullConf tazBlog
tazBlog :: ServerPart Response
tazBlog = do
msum [ dir "en" $ blogHandler EN
, dir "de" $ blogHandler DE
, do nullDir
showIndex DE
, do dir " " $ nullDir
seeOther ("https://plus.google.com/115916629925754851590" :: String) (toResponse ())
, dir "res" $ serveDirectory DisableBrowsing [] "../res"
, serveDirectory DisableBrowsing [] "../res"
]
blogHandler :: BlogLang -> ServerPart Response
blogHandler lang =
msum [ path $ \(year :: Int) -> path $ \(month :: Int) -> path $ --single entry
\(day :: Int) -> path $ \(id_ :: String) -> showEntry year month day id_
, do nullDir
showIndex lang
]
showEntry :: Int -> Int -> Int -> String -> ServerPart Response
showEntry y m d i = do
entryJS <- liftIO $ runCouchDB' $ getDoc (db "tazblog") (doc i)
let entry = maybeDoc entryJS
ok $ tryEntry entry
tryEntry :: Maybe Entry -> Response
tryEntry Nothing = toResponse $ showError NotFound
tryEntry (Just entry) = toResponse $ renderBlog eLang $ renderEntry entry
where
eLang = lang entry
showIndex :: BlogLang -> ServerPart Response
showIndex lang = do
entries <- getLatest lang []
ok $ toResponse $ renderBlog lang $ renderEntries entries 6 (topText lang)
where
topText EN = "Latest entries"
topText DE = "Aktuelle Einträge"
renderBlog :: BlogLang -> Html -> Html
renderBlog DE body = blogTemplate "Tazjins Blog" "Wer mich kontaktieren will: " " oder " version DE body
renderBlog EN body = blogTemplate "Tazjin's Blog" "Get in touch with me: " " or " version EN body
-- http://tazj.in/2012/02/10.155234
-- CouchDB functions
getLatest :: BlogLang -> [(String, JSValue)] -> ServerPart [Entry]
getLatest lang arg = do
queryResult <- queryDB view arg
let entries = map (stripResult . fromJSON . snd) queryResult
return entries
where
view = case lang of
EN -> "latestEN"
DE -> "latestDE"
queryDB :: JSON a => String -> [(String, JSValue)] -> ServerPart [(Doc, a)]
queryDB view arg = liftIO $ runCouchDB' $ queryView (db "tazblog") (doc "entries") (doc view) arg
maybeDoc :: Data a => Maybe (Doc, Rev, JSValue) -> Maybe a
maybeDoc (Just(_,_,v)) = Just( stripResult $ fromJSON v)
maybeDoc Nothing = Nothing
stripResult :: Result a -> a
stripResult (Ok z) = z
stripResult (Error s) = error $ "JSON error: " ++ s
-- CouchDB View Setup
latestDEView = "function(doc){ if(doc.lang == 'DE'){ emit([doc.year, doc.month, doc.day, doc.id_], doc); } }"
latestENView = "function(doc){ if(doc.lang == 'EN'){ emit([doc.year, doc.month, doc.day, doc.id_], doc); } }"
latestDE = ViewMap "latestDE" latestDEView
latestEN = ViewMap "latestEN" latestENView
setupBlogViews :: IO ()
setupBlogViews = runCouchDB' $
newView "tazblog" "entries" [latestDE, latestEN]
|
