diff options
| -rw-r--r-- | res/blogstyle.css | 3 | ||||
| -rw-r--r-- | src/Blog.hs | 21 | ||||
| -rw-r--r-- | src/Server.hs | 35 |
3 files changed, 45 insertions, 14 deletions
diff --git a/res/blogstyle.css b/res/blogstyle.css index 5a27f550930f..d830ee2e23d0 100644 --- a/res/blogstyle.css +++ b/res/blogstyle.css @@ -37,6 +37,7 @@ body { .myclear { clear: both; + height: 20px; } .centerbox { @@ -101,7 +102,7 @@ body { -webkit-border-bottom-right-radius: 6px; border-top: 0px hidden; background-color: #FFFFFF; - min-height: 200px; + min-height: 500px; height: auto; padding-top: 21px; padding-right: 2px; diff --git a/src/Blog.hs b/src/Blog.hs index 80d6c45871c1..e22a8d9efed8 100644 --- a/src/Blog.hs +++ b/src/Blog.hs @@ -4,6 +4,7 @@ module Blog where --import Control.Monad(when) import Data.Data (Data, Typeable) +import Data.List (intersperse) import Data.Monoid (mempty) import Data.Time import System.Locale (defaultTimeLocale) @@ -61,6 +62,7 @@ blogTemplate title ctext1 ortext version lang body = H.docTypeHtml $ do --add bo -- H.span ! A.id "cios" ! A.style "display:none;" $ H.b $ contactInfo "sms:tazjin@me.com" H.div ! A.class_ "myclear" $ mempty body + H.div ! A.class_ "myclear" $ mempty showFooter lang version H.div ! A.class_ "centerbox" $ H.img ! A.src "http://getpunchd.com/img/june/idiots.png" ! A.alt "" @@ -74,6 +76,21 @@ blogTemplate title ctext1 ortext version lang body = H.docTypeHtml $ do --add bo H.a ! A.href (toValue imu) ! A.target "_blank" $ "iMessage" "." +renderEntries :: [Entry] -> Int -> String-> Html +renderEntries entries num topText = H.div ! A.class_ "innerBox" $ do + H.div ! A.class_ "innerBoxTop" $ toHtml topText + H.div ! A.class_ "innerBoxMiddle" $ do + H.ul $ + sequence_ $ take num $ reverse $ map showEntry entries + where + showEntry :: Entry -> Html + showEntry e = H.li $ do + entryLink e + 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] + renderEntry :: Entry -> Html renderEntry entry = H.div ! A.class_ "innerBox" $ do H.div ! A.class_ "innerBoxTop" $ toHtml $ title entry @@ -102,12 +119,10 @@ renderComments comments lang = sequence_ $ map showComment comments 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 EN (Just t) = formatTime defaultTimeLocale "[On %D at %H:%M]" 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" diff --git a/src/Server.hs b/src/Server.hs index a95b72cd7bba..8b513595e00c 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -36,7 +36,7 @@ tazBlog = do msum [ dir "en" $ blogHandler EN , dir "de" $ blogHandler DE , do nullDir - ok $ showIndex DE + showIndex DE , do dir " " $ nullDir seeOther ("https://plus.google.com/115916629925754851590" :: String) (toResponse ()) , dir "res" $ serveDirectory DisableBrowsing [] "../res" @@ -48,7 +48,7 @@ blogHandler lang = msum [ path $ \(year :: Int) -> path $ \(month :: Int) -> path $ --single entry \(day :: Int) -> path $ \(id_ :: String) -> showEntry year month day id_ , do nullDir - ok $ showIndex lang + showIndex lang ] showEntry :: Int -> Int -> Int -> String -> ServerPart Response @@ -63,20 +63,35 @@ tryEntry (Just entry) = toResponse $ renderBlog eLang $ renderEntry entry where eLang = lang entry -showIndex :: BlogLang -> Response -showIndex lang = toResponse $ renderBlogHeader lang +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 -renderBlogHeader :: BlogLang -> Html -renderBlogHeader DE = blogTemplate "Tazjins Blog" "Wer mich kontaktieren will: " " oder " version DE (emptyTest DE) -renderBlogHeader EN = blogTemplate "Tazjin's Blog" "Get in touch with me: " " or " version EN (emptyTest EN) - -- 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 @@ -85,8 +100,8 @@ 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); } }" +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 |