diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Blog.hs | 62 | ||||
| -rw-r--r-- | src/Locales.hs | 5 | ||||
| -rw-r--r-- | src/Main.hs | 6 |
3 files changed, 38 insertions, 35 deletions
diff --git a/src/Blog.hs b/src/Blog.hs index 649329cfb3f8..9c35c1ec742f 100644 --- a/src/Blog.hs +++ b/src/Blog.hs @@ -5,11 +5,9 @@ module Blog where import Data.Data (Data, Typeable) import Data.List (intersperse) import Data.Monoid (mempty) -import Data.Text (Text) -import qualified Data.Text as T import Data.Time import System.Locale (defaultTimeLocale) -import Text.Blaze (toValue, preEscapedText) +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 @@ -38,13 +36,11 @@ data Entry = Entry{ data BlogError = NoEntries | NotFound | DBError -blogText :: (a -> String) -> a -> Text -blogText f = T.pack . f intersperse' :: a -> [a] -> [a] intersperse' sep l = sep : intersperse sep l -blogTemplate :: BlogLang -> Text -> Html -> Html +blogTemplate :: BlogLang -> String -> Html -> Html blogTemplate lang t_append body = H.docTypeHtml $ do --add body H.head $ do H.title $ (toHtml $ blogTitle lang t_append) @@ -63,20 +59,20 @@ blogTemplate lang t_append body = H.docTypeHtml $ do --add body H.div ! A.class_ "myclear" $ mempty body H.div ! A.class_ "myclear" $ mempty - showFooter lang $ T.pack version + showFooter lang version H.div ! A.class_ "centerbox" $ H.img ! A.src "http://getpunchd.com/img/june/idiots.png" ! A.alt "" where - contactInfo (imu :: Text) = do + contactInfo (imu :: String) = do toHtml $ contactText lang H.a ! A.href (toValue mailTo) $ "Mail" ", " H.a ! A.href (toValue twitter) ! A.target "_blank" $ "Twitter" - toHtml $ orText lang + toHtml $ orString lang H.a ! A.href (toValue imu) ! A.target "_blank" $ "iMessage" "." -renderEntries :: Bool -> [Entry] -> Text -> Maybe Html -> Html +renderEntries :: Bool -> [Entry] -> String -> Maybe Html -> Html renderEntries showAll entries topText footerLinks = H.div ! A.class_ "innerBox" $ do H.div ! A.class_ "innerBoxTop" $ toHtml topText @@ -89,7 +85,7 @@ renderEntries showAll entries topText footerLinks = showEntry :: Entry -> Html showEntry e = H.li $ do entryLink e - preEscapedText $ T.concat [" ", blogText text e, "<br> </br>"] + preEscapedString $ " " ++ (text e) ++ "<br> </br>" entryLink e = H.a ! A.href (toValue $ concat $ intersperse' "/" $ linkElems e) $ toHtml ("[" ++ show(length $ comments e) ++ "]") linkElems e = [show(lang e), show(year e), show(month e), show(day e), _id e] @@ -101,25 +97,23 @@ 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 - preEscapedText $ blogText text entry - preEscapedText $ blogText mtext entry + 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.div ! A.class_ "cHead" $ toHtml $ cHead (lang entry) -- ! A.style "font-size:large;font-weight:bold;" H.ul $ renderComments (comments entry) (lang entry) - renderCommentBox $ lang entry + renderCommentBox (lang entry) (_id entry) -renderCommentBox :: BlogLang -> Html -renderCommentBox lang = do - H.div ! A.name "cHead" $ toHtml $ cwHead lang - H.form $ do +renderCommentBox :: BlogLang -> String -> Html +renderCommentBox cLang cId = do + H.div ! A.class_ "cHead" $ toHtml $ cwHead cLang + H.form ! A.method "POST" ! A.action (toValue $ "/" ++ (show cLang) ++ "/postcomment/" ++ cId) $ do H.p $ H.label $ do - toHtml ("Name:" :: Text) - H.input -{- -<form> - <p><label>Customer name: <input></label></p> -</form> --} + H.span $ "Name:" --toHtml ("Name:" :: String) + H.input ! A.name "cname" + H.p $ H.label $ do + H.span $ toHtml $ cSingle cLang -- toHtml (cSingle lang) + H.textarea ! A.name "ctext" ! A.cols "50" ! A.rows "13" $ mempty renderComments :: [Comment] -> BlogLang -> Html renderComments [] lang = H.li $ toHtml $ noComments lang @@ -129,7 +123,7 @@ renderComments comments lang = sequence_ $ map showComment comments 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 ++ ": ") - preEscapedText $ blogText ctext c + preEscapedString $ ctext c H.p ! A.class_ "tt" $ toHtml (timeString $ cdate c) getTime :: Integer -> Maybe UTCTime getTime t = parseTime defaultTimeLocale "%s" (show t) @@ -140,21 +134,21 @@ renderComments comments lang = sequence_ $ map showComment comments showLinks :: Maybe Int -> BlogLang -> Html showLinks (Just i) lang = H.div ! A.class_ "centerbox" $ do H.a ! A.href (toValue $ "/?page=" ++ show (i+1)) $ toHtml $ backText lang - toHtml (" -- " :: Text) + toHtml (" -- " :: String) H.a ! A.href (toValue $ "/?page=" ++ show (i-1)) $ toHtml $ nextText lang showLinks Nothing lang = H.div ! A.class_ "centerbox" $ H.a ! A.href "/?page=2" $ toHtml $ backText lang -showFooter :: BlogLang -> Text -> Html +showFooter :: BlogLang -> String -> Html showFooter l v = H.div ! A.class_ "rightbox" ! A.style "text-align:right;" $ do - toHtml ("Proudly made with " :: Text) + toHtml ("Proudly made with " :: String) H.a ! A.href "http://haskell.org" $ "Haskell" - toHtml (", " :: Text) + toHtml (", " :: String) H.a ! A.href "http://couchdb.apache.org/" $ "CouchDB" - toHtml (" and without PHP, Java, Perl, MySQL and Python." :: Text) + toHtml (" and without PHP, Java, Perl, MySQL and Python." :: String) H.br - H.a ! A.href (toValue repoURL) $ toHtml $ T.concat ["Version ", v] - preEscapedText " " + H.a ! A.href (toValue repoURL) $ toHtml $ ("Version " :: String) ++ v + preEscapedString " " H.a ! A.href "/notice" $ toHtml $ noticeText l -- Error pages diff --git a/src/Locales.hs b/src/Locales.hs index f629dbe6f347..9b9002ab24c3 100644 --- a/src/Locales.hs +++ b/src/Locales.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} module Locales where @@ -101,6 +101,9 @@ cwHead :: BlogLang -> Text cwHead DE = "Kommentieren:" cwHead EN = "Comment:" +cSingle DE = "Kommentar:" --input label +cSingle EN = "Comment:" + cTimeFormat :: BlogLang -> String --formatTime expects a String cTimeFormat DE = "[Am %d.%m.%y um %H:%M Uhr]" cTimeFormat EN = "[On %D at %H:%M]" diff --git a/src/Main.hs b/src/Main.hs index c851d9a05203..5bc2ef2ce46d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -47,6 +47,9 @@ blogHandler lang = msum [ path $ \(year :: Int) -> path $ \(month :: Int) -> path $ --single entry \(day :: Int) -> path $ \(id_ :: String) -> showEntry year month day id_ , path $ \(year :: Int ) -> path $ \(month :: Int) -> showMonth year month lang + , do + decodeBody tmpPolicy + dir "postcomment" $ path $ \(id_ :: String) -> addComment id_ , do nullDir showIndex lang ] @@ -85,6 +88,9 @@ showMonth y m lang = do startkey = JSArray [toJSON y, toJSON m] endkey = JSArray [toJSON y, toJSON m, JSObject (toJSObject [] )] +addComment :: String -> ServerPart Response +addComment id_ = undefined + -- http://tazj.in/2012/02/10.155234 -- CouchDB functions |