diff options
| -rw-r--r-- | src/Blog.hs | 5 | ||||
| -rw-r--r-- | src/Locales.hs | 4 | ||||
| -rw-r--r-- | src/Main.hs | 40 |
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 |