* Pagination (finally!)

* slight CSS change
This commit is contained in:
Vincent Ambo 2012-03-03 16:39:15 +01:00
parent 485e271475
commit 96093c9009
4 changed files with 43 additions and 18 deletions

View file

@ -42,6 +42,7 @@ body {
.centerbox {
text-align:center;
min-height: 45px;
}
.rightbox {

View file

@ -72,12 +72,15 @@ blogTemplate lang t_append body = H.docTypeHtml $ do --add body
H.a ! A.href (toValue imu) ! A.target "_blank" $ "iMessage"
"."
renderEntries :: [Entry] -> String-> Html
renderEntries entries topText = H.div ! A.class_ "innerBox" $ do
renderEntries :: Bool -> [Entry] -> String -> Maybe Html -> Html
renderEntries showAll entries topText footerLinks =
H.div ! A.class_ "innerBox" $ do
H.div ! A.class_ "innerBoxTop" $ toHtml topText
H.div ! A.class_ "innerBoxMiddle" $ do
H.ul $
sequence_ . reverse $ map showEntry entries
H.ul $ if' showAll
(sequence_ $ map showEntry entries)
(sequence_ . take 6 $ map showEntry entries)
getFooterLinks footerLinks
where
showEntry :: Entry -> Html
showEntry e = H.li $ do
@ -86,6 +89,8 @@ renderEntries entries topText = H.div ! A.class_ "innerBox" $ do
entryLink e = H.a ! A.href (toValue $ concat $ intersperse' "/" $ linkElems e) $
toHtml ("[" ++ show(length $ comments e) ++ "]")
linkElems e = [show(lang e), show(year e), show(month e), show(day e), _id e]
getFooterLinks (Just h) = h
getFooterLinks Nothing = mempty
renderEntry :: Entry -> Html
renderEntry entry = H.div ! A.class_ "innerBox" $ do
@ -114,6 +119,14 @@ renderComments comments lang = sequence_ $ map showComment comments
showTime _ Nothing = "[???]" -- this can not happen??
timeString = (showTime lang) . getTime
showLinks :: Maybe Int -> BlogLang -> Html
showLinks (Just i) lang = H.div ! A.class_ "centerbox" $ do
H.a ! A.href (toValue $ "/?page=" ++ show (i+1)) $ toHtml $ backText lang
toHtml (" -- " :: String)
H.a ! A.href (toValue $ "/?page=" ++ show (i-1)) $ toHtml $ nextText lang
showLinks Nothing lang = H.div ! A.class_ "centerbox" $
H.a ! A.href "/?page=2" $ toHtml $ backText lang
showFooter :: BlogLang -> String -> Html
showFooter l v = H.div ! A.class_ "rightbox" ! A.style "text-align:right;" $ do
toHtml ("Proudly made with " :: String)

View file

@ -17,6 +17,10 @@ version = ("2.2b" :: String)
allLang = [EN, DE]
if' :: Bool -> a -> a -> a
if' True x _ = x
if' False _ y = y
blogTitle :: BlogLang -> String -> String
blogTitle DE s = "Tazjins Blog" ++ s
blogTitle EN s = "Tazjin's Blog" ++ s
@ -59,11 +63,11 @@ getMonth l y m = monthName l m ++ show y
entireMonth DE = "Ganzer Monat"
entireMonth EN = "Entire month"
prevMonth DE = "Früher"
prevMonth EN = "Earlier"
backText DE = "Früher"
backText EN = "Earlier"
nextMonth DE = "Später"
nextMonth EN = "Later"
nextText DE = "Später"
nextText EN = "Later"
-- contact information
contactText DE = "Wer mich kontaktieren will: "

View file

@ -2,10 +2,11 @@
module Main where
import Control.Monad (msum, mzero)
import Control.Applicative (optional)
import Control.Monad (msum)
import Data.Monoid (mempty)
import Data.ByteString.Char8 (ByteString)
import Data.Text hiding (map, length, zip, head)
import Data.Text hiding (map, length, zip, head, drop)
import Data.Time
import Database.CouchDB
import Happstack.Server
@ -64,14 +65,20 @@ tryEntry (Just entry) = toResponse $ blogTemplate eLang eTitle $ renderEntry ent
showIndex :: BlogLang -> ServerPart Response
showIndex lang = do
entries <- getLatest lang [("limit", toJSON (7 :: Int)), ("descending", toJSON True)]
ok $ toResponse $ blogTemplate lang "" $ renderEntries entries (topText lang)
entries <- getLatest lang [("descending", showJSON True)]
(page :: Maybe Int) <- optional $ lookRead "page"
ok $ toResponse $ blogTemplate lang "" $
renderEntries False (eDrop page entries) (topText lang) (Just $ showLinks page lang)
where
eDrop :: Maybe Int -> [a] -> [a]
eDrop (Just i) = drop ((i-1) * 6)
eDrop Nothing = drop 0
showMonth :: Int -> Int -> BlogLang -> ServerPart Response
showMonth y m lang = do
entries <- getLatest lang $ makeQuery startkey endkey
entries <- getLatest lang $ ("descending", showJSON True) : makeQuery startkey endkey
ok $ toResponse $ blogTemplate lang month
$ renderEntries entries month
$ renderEntries True entries month Nothing
where
month = getMonth lang y m
startkey = JSArray [toJSON y, toJSON m]