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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable #-}
module Blog where
--import Control.Monad(when)
import Data.Data (Data, Typeable)
import Data.Monoid (mempty)
import Data.Time
import System.Locale (defaultTimeLocale)
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
data Comment = Comment{
cauthor :: String,
ctext :: String,
cdate :: Integer
} deriving (Show, Data, Typeable)
data Entry = Entry{
_id :: String,
year :: Int,
month :: Int,
day :: Int,
lang :: BlogLang,
title :: String,
author :: String,
text :: String,
mtext :: String,
comments :: [Comment]
} deriving (Show, Data, Typeable)
data BlogError = NoEntries | NotFound | DBError
data BlogLang = EN | DE deriving (Data, Typeable)
instance Show BlogLang where
show EN = "en"
show DE = "de"
repoURL = ("https://bitbucket.org/tazjin/tazblog-haskell" :: String)
blogTemplate :: String -> String -> String -> String -> BlogLang -> Html -> Html
blogTemplate title ctext1 ortext version lang body = H.docTypeHtml $ do --add body
H.head $ do
H.title $ (toHtml title)
H.link ! A.rel "alternate" ! A.type_ "application/rss+xml" ! A.title "RSS-Feed" ! A.href "/rss"
H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/res/blogstyle.css" ! A.media "all"
H.meta ! A.httpEquiv "content-type" ! A.content "text/html;charset=UTF-8"
--H.style ! A.type_ "text/css" ! A.title "iOS iMessage" ! A.media "screen and (max-device-width: 1024px)" $ "#cosx{display:none;}"
H.body $ do
H.div ! A.class_ "mainshell" $ H.div ! A.class_ "gradBox" $ do
H.div ! A.class_ "header" $ do
H.a ! A.href "/" ! A.style "text-decoration:none;color:black;font-size:x-large;font-weight:bold;" $
(toHtml title)
H.br
H.span ! A.id "cosx" ! A.style "display:block;" $ H.b $ contactInfo "imessage:tazjin@me.com"
-- H.span ! A.id "cios" ! A.style "display:none;" $ H.b $ contactInfo "sms:tazjin@me.com"
H.div ! A.class_ "myclear" $ mempty
body
showFooter lang version
H.div ! A.class_ "centerbox" $
H.img ! A.src "http://getpunchd.com/img/june/idiots.png" ! A.alt ""
where
contactInfo (imu :: String) = do
toHtml ctext1
H.a ! A.href "mailto:hej@tazj.in" $ "Mail"
", "
H.a ! A.href "http://twitter.com/#!/tazjin" ! A.target "_blank" $ "Twitter"
toHtml ortext
H.a ! A.href (toValue imu) ! A.target "_blank" $ "iMessage"
"."
renderEntry :: Entry -> Html
renderEntry entry = H.div ! A.class_ "innerBox" $ do
H.div ! A.class_ "innerBoxTop" $ toHtml $ title entry
H.div ! A.class_ "innerBoxMiddle" $ do
H.article $ H.ul $ H.li $ do
preEscapedString $ text entry
preEscapedString $ mtext entry
H.div ! A.class_ "innerBoxComments" $ do
H.div ! A.name "cHead" ! A.style "font-size:large;font-weight:bold;" $ toHtml $ cHead (lang entry)
H.ul $ renderComments (comments entry) (lang entry)
where
cHead EN = ("Comments:" :: String)
cHead DE = ("Kommentare:" :: String)
renderComments :: [Comment] -> BlogLang -> Html
renderComments [] DE = H.li $ toHtml (" Keine Kommentare" :: String)
renderComments [] EN = H.li $ toHtml (" No comments yet" :: String)
renderComments comments lang = sequence_ $ map showComment comments
where
showComment :: Comment -> Html
showComment c = H.li $ do
H.a ! A.name (toValue $ cdate c) ! A.href (toValue $ "#" ++ (show $ cdate c)) ! A.class_ "cl" $
H.i $ toHtml $ (cauthor c ++ ": ")
preEscapedString $ ctext c
H.p ! A.class_ "tt" $ toHtml (timeString $ cdate c)
getTime :: Integer -> Maybe UTCTime
getTime t = parseTime defaultTimeLocale "%s" (show t)
showTime DE (Just t) = formatTime defaultTimeLocale "[Am %d.%m.%y um %H:%M Uhr]" t
showTime EN (Just t) = formatTime defaultTimeLocale "[On %D at %H:%M Uhr]" t
showTime _ Nothing = "[???]" -- this can not happen??
timeString = (showTime lang) . getTime
--[Am %d.%m.%y um %H:%M Uhr]
emptyTest :: BlogLang -> Html
emptyTest lang = H.div ! A.class_ "innerBox" $ do
H.div ! A.class_ "innerBoxTop" $ "Test"
H.div ! A.class_ "innerBoxMiddle" $ getTestText lang
H.div ! A.class_ "myclear" $ mempty
where
getTestText DE = toHtml ("Das ist doch schonmal was." :: String)
getTestText EN = toHtml ("This is starting to look like something." :: String)
showFooter :: BlogLang -> String -> Html
showFooter l v = H.div ! A.class_ "rightbox" ! A.style "text-align:right;" $ do
toHtml ("Proudly made with " :: String)
H.a ! A.href "http://haskell.org" $ "Haskell"
toHtml (", " :: String)
H.a ! A.href "http://couchdb.apache.org/" $ "CouchDB"
toHtml (" and without PHP, Java, Perl, MySQL and Python." :: String)
H.br
H.a ! A.href (toValue repoURL) $ toHtml $ ("Version " :: String) ++ v
preEscapedString " "
H.a ! A.href "/notice" $ toHtml $ noticeText l
where
noticeText :: BlogLang -> String
noticeText EN = "site notice"
noticeText DE = "Impressum"
-- Error pages
showError :: BlogError -> Html
showError _ = undefined
|
