diff options
| -rw-r--r-- | src/Locales.hs | 40 | ||||
| -rw-r--r-- | src/Server.hs | 28 |
2 files changed, 64 insertions, 4 deletions
diff --git a/src/Locales.hs b/src/Locales.hs index 266f4e752d9a..fb9435195987 100644 --- a/src/Locales.hs +++ b/src/Locales.hs @@ -24,6 +24,46 @@ blogTitle EN = "Tazjin's Blog" topText DE = "Aktuelle Einträge" topText EN = "Latest entries" +getMonth :: BlogLang -> Int -> Int -> String +getMonth l y m = monthName l m ++ show y + where + monthName :: BlogLang -> Int -> String + monthName DE m = case m of + 1 -> "Januar " + 2 -> "Februar " + 3 -> "März " + 4 -> "April " + 5 -> "Mai " + 6 -> "Juni " + 7 -> "Juli " + 8 -> "August " + 9 -> "September " + 10 -> "Oktober " + 11 -> "November" + 12 -> "Dezember" + monthName EN m = case m of + 1 -> "January " + 2 -> "February " + 3 -> "March " + 4 -> "April " + 5 -> "May " + 6 -> "June " + 7 -> "July " + 8 -> "August " + 9 -> "September " + 10 -> "October " + 11 -> "November " + 12 -> "December " + +entireMonth DE = "Ganzer Monat" +entireMonth EN = "Entire month" + +prevMonth DE = "Früher" +prevMonth EN = "Earlier" + +nextMonth DE = "Später" +nextMonth EN = "Later" + -- contact information contactText DE = "Wer mich kontaktieren will: " contactText EN = "Get in touch with me: " diff --git a/src/Server.hs b/src/Server.hs index 764d3c9055aa..b50de2debcd9 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -44,6 +44,10 @@ blogHandler :: BlogLang -> ServerPart Response blogHandler lang = msum [ path $ \(year :: Int) -> path $ \(month :: Int) -> path $ --single entry \(day :: Int) -> path $ \(id_ :: String) -> showEntry year month day id_ + , path $ \(year :: Int) -> path $ \(month :: Int) -> path $ + \(day :: Int) -> showDay year month day lang + , path $ \(year :: Int ) -> path $ \(month :: Int) -> showMonth year month lang + , path $ \(year :: Int ) -> showYear year lang , do nullDir showIndex lang ] @@ -56,18 +60,29 @@ showEntry y m d i = do tryEntry :: Maybe Entry -> Response tryEntry Nothing = toResponse $ showError NotFound -tryEntry (Just entry) = toResponse $ renderBlog eLang $ renderEntry entry +tryEntry (Just entry) = toResponse $ blogTemplate eLang $ renderEntry entry where eLang = lang entry showIndex :: BlogLang -> ServerPart Response showIndex lang = do entries <- getLatest lang [] - ok $ toResponse $ renderBlog lang $ renderEntries entries 6 (topText lang) + ok $ toResponse $ blogTemplate lang $ renderEntries entries 6 (topText lang) + +showDay :: Int -> Int -> Int -> BlogLang -> ServerPart Response +showDay y m d lang = undefined + +showMonth :: Int -> Int -> BlogLang -> ServerPart Response +showMonth y m lang = do + entries <- getLatest lang $ makeQuery startkey endkey + ok $ toResponse $ blogTemplate lang $ renderEntries entries (length entries) $ getMonth lang y m where + startkey = JSArray [toJSON y, toJSON m] + endkey = JSArray [toJSON y, toJSON m, JSObject (toJSObject [] )] + +showYear :: Int -> BlogLang -> ServerPart Response +showYear y lang = undefined -renderBlog :: BlogLang -> Html -> Html -renderBlog lang body = blogTemplate lang body -- http://tazj.in/2012/02/10.155234 @@ -82,6 +97,10 @@ getLatest lang arg = do EN -> "latestEN" DE -> "latestDE" +makeQuery :: JSON a => a -> a -> [(String, JSValue)] +makeQuery qsk qek = [("startkey", (showJSON qsk)) + ,("endkey", (showJSON qek))] + queryDB :: JSON a => String -> [(String, JSValue)] -> ServerPart [(Doc, a)] queryDB view arg = liftIO $ runCouchDB' $ queryView (db "tazblog") (doc "entries") (doc view) arg @@ -92,6 +111,7 @@ 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); } }" |