* one step closer to adding comments

* generic Doc update function
* redirect /<commentID> to appropriate full link

3 files changed, 46 insertions, 3 deletions

diff --git a/src/Blog.hs b/src/Blog.hs
index 8905bc11ca0b..201851cba01d 100644
--- a/src/Blog.hs
+++ b/src/Blog.hs
@@ -14,6 +14,7 @@ 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
+import           System.Locale (defaultTimeLocale)
 
 import           Locales
 
@@ -53,8 +54,9 @@ blogTemplate lang t_append body = H.docTypeHtml $ do --add body
     H.body $ do
         H.div ! A.class_ "mainshell" $ H.div ! A.class_ "gradBox" $ do
             H.div ! A.class_ "header" $ do
+                H.a ! A.href (toValue $ "/" ++ show lang) ! 
+                    A.style "text-decoration:none;color:black;font-size:x-large;font-weight:bold;" $
                         toHtml $ blogTitle lang ""
-                H.a ! A.href "/" ! A.style "text-decoration:none;color:black;font-size:x-large;font-weight:bold;" $
                 H.p ! A.style "clear: both;" $ do
                     H.span ! A.style "float: left;" ! A.id "cosx" $ H.b $ contactInfo iMessage
                    -- H.span ! A.id "cios" ! A.style "display:none;" $ H.b $ contactInfo "sms:tazjin@me.com"
@@ -117,6 +119,7 @@ renderCommentBox cLang cId = do
         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
+        H.p $ H.input ! A.type_ "submit" ! A.value (toValue $ cSend cLang)
 
 renderComments :: [Comment] -> BlogLang -> Html
 renderComments [] lang = H.li $ toHtml $ noComments lang
diff --git a/src/Locales.hs b/src/Locales.hs
index 047beb8aad9b..56bc42d10ba5 100644
--- a/src/Locales.hs
+++ b/src/Locales.hs
@@ -112,6 +112,10 @@ cTimeFormat :: BlogLang -> String --formatTime expects a String
 cTimeFormat DE = "[Am %d.%m.%y um %H:%M Uhr]"
 cTimeFormat EN = "[On %D at %H:%M]"
 
+cSend :: BlogLang -> Text
+cSend DE = "Absenden"
+cSend EN = "Submit"
+
 -- right side text (this is inserted AS IS. Escape HTML!)
 rightText :: BlogLang -> Text
 rightText DE = "English version <a href=\"/en\" style=\"color: black;\">available here</a>."
diff --git a/src/Main.hs b/src/Main.hs
index e0714c95e5b4..769e2180a3aa 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -2,7 +2,7 @@
 
 module Main where
 
-import           Control.Applicative (optional)
+import           Control.Applicative ((<$>), (<*>), optional, pure)
 import           Control.Monad (msum)
 import           Data.Monoid (mempty)
 import           Data.ByteString.Char8 (ByteString)
@@ -18,6 +18,7 @@ import           Text.Blaze.Html5.Attributes (action, enctype, href, name, size,
 import qualified Text.Blaze.Html5 as H
 import qualified Text.Blaze.Html5.Attributes as A
 import           Text.JSON.Generic
+import           System.Locale (defaultTimeLocale)
 
 import           Blog
 import           Locales
@@ -38,6 +39,7 @@ tazBlog = do
               showIndex DE
          , do dir " " $ nullDir
               seeOther ("https://plus.google.com/115916629925754851590" :: String) (toResponse ())
+         , path $ \(id_ :: Int) -> getEntryLink id_
          , dir "res" $ serveDirectory DisableBrowsing [] "../res"
          , dir "notice" $ ok $ toResponse showSiteNotice
          , serveDirectory DisableBrowsing [] "../res"
@@ -68,6 +70,16 @@ tryEntry (Just entry) _ = toResponse $ blogTemplate eLang eTitle $ renderEntry e
         eTitle = T.pack $ ": " ++ title entry
         eLang = lang entry
 
+getEntryLink :: Int -> ServerPart Response
+getEntryLink id_ = do
+    entryJS <- liftIO $ runCouchDB' $ getDoc (db "tazblog") (doc $ show id_)
+    let entry = maybeDoc entryJS
+    seeOther (makeLink entry) (toResponse())
+  where
+    makeLink :: Maybe Entry -> String
+    makeLink (Just e) = concat $ intersperse' "/" [show $ lang e, show $ year e, show $ month e, show $ day e, show id_]
+    makeLink Nothing = "/"
+
 showIndex :: BlogLang -> ServerPart Response
 showIndex lang = do
     entries <- getLatest lang [("descending", showJSON True)]
@@ -90,10 +102,23 @@ showMonth y m lang = do
     endkey = JSArray [toJSON y, toJSON m, JSObject (toJSObject [] )]
 
 addComment :: String -> ServerPart Response
-addComment id_ = undefined
+addComment id_ = do
+  rda <- liftIO $ currentSeconds >>= return
+  nComment <- Comment <$> look "cname"
+                      <*> look "ctext"
+                      <*> pure rda
+  rev <- updateDBDoc (doc id_) $ insertComment nComment
+  liftIO $ putStrLn $ show rev
+  seeOther ("/" ++ id_) (toResponse())
 
 -- http://tazj.in/2012/02/10.155234
 
+currentSeconds :: IO Integer
+currentSeconds = do
+    now <- getCurrentTime
+    let s =  read (formatTime defaultTimeLocale "%s" now) :: Integer
+    return s
+
 -- CouchDB functions
 getLatest :: BlogLang -> [(String, JSValue)] -> ServerPart [Entry]
 getLatest lang arg = do
@@ -105,6 +130,11 @@ getLatest lang arg = do
                 EN -> "latestEN"
                 DE -> "latestDE"
 
+insertComment :: Comment -> JSValue -> IO JSValue
+insertComment c jEntry = return $ toJSON $ e { comments = c : (comments e)}
+  where
+    e = convertJSON jEntry :: Entry
+
 makeQuery :: JSON a => a -> a -> [(String, JSValue)]
 makeQuery qsk qek = [("startkey", (showJSON qsk))
                     ,("endkey", (showJSON qek))]
@@ -116,10 +146,16 @@ maybeDoc :: Data a => Maybe (Doc, Rev, JSValue) -> Maybe a
 maybeDoc (Just(_,_,v)) = Just( stripResult $ fromJSON v)
 maybeDoc Nothing = Nothing
 
+updateDBDoc :: JSON a => Doc -> (a -> IO a) -> ServerPart (Maybe Rev)
+updateDBDoc docn f = liftIO $ runCouchDB' $ getAndUpdateDoc (db "tazblog") docn f
+
 stripResult :: Result a -> a
 stripResult (Ok z) = z
 stripResult (Error s) = error $ "JSON error: " ++ s
 
+convertJSON :: Data a => JSValue -> a
+convertJSON = stripResult . fromJSON
+
 getMonthCount :: BlogLang -> Int -> Int -> ServerPart Int
 getMonthCount lang y m  = do
     count <- queryDB (view lang) $ makeQuery startkey endkey