maurice/snix
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

* entries by month

Browse source
This commit is contained in:
"Vincent Ambo ext:(%22) 2012-02-24 17:01:36 +01:00
parent 35a5557e17
commit 0f0d874aa7
2 changed files with 65 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

30
src/Server.hs
View file

@ -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)
where
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); } }"