about summary refs log tree commit diff
path: root/src/Server.hs
diff options
context:
space:
mode:
author"Vincent Ambo ext:(%22) <tazjin@me.com>2012-02-23T12·20+0100
committer"Vincent Ambo ext:(%22) <tazjin@me.com>2012-02-23T12·20+0100
commita4119e1cfd3f599cf67012535a5a55bcbf4800c6 (patch)
tree02a7723e4fe79f085f7668e6f511f23f3b5fb30e /src/Server.hs
parent47dbfe900e57738dc44c4bfe06c624e725102a03 (diff)
* displaying blog entries
* changed convertDB for BlogLang JSON representation
Diffstat (limited to 'src/Server.hs')
-rw-r--r--src/Server.hs61
1 files changed, 28 insertions, 33 deletions
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); } }"