* displaying blog entries

* changed convertDB for BlogLang JSON representation

2 files changed, 86 insertions, 61 deletions

diff --git a/src/Blog.hs b/src/Blog.hs
index 983bae2366bb..bb74cbb16bef 100644
--- a/src/Blog.hs
+++ b/src/Blog.hs
@@ -1,7 +1,9 @@
-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable #-}
 
 module Blog where
 
+--import           Control.Monad(when)
+import           Data.Data (Data, Typeable)
 import           Data.Monoid (mempty)
 import           Text.Blaze (toValue, preEscapedString)
 import           Text.Blaze.Html5 (Html, (!), a, form, input, p, toHtml, label)
@@ -10,30 +12,37 @@ 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)
 
-repoURL = ("" :: String)
+data BlogError = NoEntries | NotFound | DBError
 
-{-
-</div>
-<div style=\"text-align:right;\">
-Proudly made with 
-<a href=\"http://golang.org\">Google Go</a> and without PHP, Java, Perl, MySQL and Python.
-<br>Idee zum simplen Blog von 
-<a href=\"http://blog.fefe.de\" target=\"_blank\">Fefe</a>
-<br>Version 2.1.3&nbsp;
-<a href=\"/impressum\">Impressum</a>
-</div>
-</div>
-</div>
-<div class=\"centerbox\"><img src=\"http://getpunchd.com/img/june/idiots.png\" alt=\"\"></div>
-</body>
-</html>"
+data BlogLang = EN | DE deriving (Data, Typeable)
 
--}
+instance Show BlogLang where
+    show EN = "en"
+    show DE = "de"
 
-blogTemplate :: String -> String -> String -> String -> String -> Html -- -> Html
-blogTemplate title ctext1 ortext lang version = H.docTypeHtml $ do --add body
+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"
@@ -49,7 +58,7 @@ blogTemplate title ctext1 ortext lang version = H.docTypeHtml $ do --add body
                 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
-            emptyTest lang
+            body
             showFooter lang version
         H.div ! A.class_ "centerbox" $
             H.img ! A.src "http://getpunchd.com/img/june/idiots.png" ! A.alt ""
@@ -63,16 +72,32 @@ blogTemplate title ctext1 ortext lang version = H.docTypeHtml $ do --add body
             H.a ! A.href (toValue imu) ! A.target "_blank" $ "iMessage"
             "."
 
-emptyTest :: String -> Html
+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
+            H.ul $ H.li $ toHtml noC
+    where
+        getTexts :: BlogLang -> (String, String)
+        getTexts EN = ("Comments:", " No comments yet")
+        getTexts DE = ("Kommentare:", " Keine Kommentare")
+        (cHead,noC) = getTexts (lang entry)
+
+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)
+    getTestText DE = toHtml ("Das ist doch schonmal was." :: String)
+    getTestText EN = toHtml ("This is starting to look like something." :: String)
 
-showFooter :: String -> String -> Html
+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"
@@ -84,6 +109,11 @@ showFooter l v = H.div ! A.class_ "rightbox" ! A.style "text-align:right;" $ do
     preEscapedString "&nbsp;"
     H.a ! A.href "/notice" $ toHtml $ noticeText l
   where
-    noticeText :: String -> String
-    noticeText "en" = "site notice"
-    noticeText "de" = "Impressum"
+    noticeText :: BlogLang -> String
+    noticeText EN = "site notice"
+    noticeText DE = "Impressum"
+
+
+-- Error pages
+showError :: BlogError -> Html
+showError _ = undefined
diff --git a/src/Server.hs b/src/Server.hs
index eefc9b1e7ad8..310c2ea1220c 100644
--- a/src/Server.hs
+++ b/src/Server.hs
@@ -1,15 +1,15 @@
-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
 
 module Main where
 
 import           Control.Monad (msum, mzero)
-import           Data.Data (Data, Typeable)
 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)
@@ -23,31 +23,6 @@ tmpPolicy :: BodyPolicy
 tmpPolicy = (defaultBodyPolicy "./tmp/" 0 1000 1000)
 
 
-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 BlogLang = EN | DE deriving (Data, Typeable)
-
-instance Show BlogLang where
-    show EN = "en"
-    show DE = "de"
-
 --TazBlog version
 version = ("2.2b" :: String)
 
@@ -71,24 +46,44 @@ tazBlog = do
 blogHandler :: BlogLang -> ServerPart Response
 blogHandler lang = 
     msum [ path $ \(year :: Int) -> path $ \(month :: Int) -> path $ --single entry
-                      \(day :: Int) -> path $ \(id_ :: String) -> showEntry lang year month day id_
+                      \(day :: Int) -> path $ \(id_ :: String) -> showEntry year month day id_
          , do nullDir
               ok $ showIndex lang
          ]
 
-showEntry :: BlogLang -> Int -> Int -> Int -> String -> ServerPart Response
-showEntry EN y m d i = undefined
-showEntry DE y m d i = undefined
+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 -> Response
 showIndex lang = toResponse $ renderBlogHeader lang
 
+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 " "de" version
-renderBlogHeader EN = blogTemplate "Tazjin's Blog" "Get in touch with me: " " or " "en" version
+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
+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); } }"