* Pagination (finally!)

* slight CSS change

res/blogstyle.css

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

src/Blog.hs

@@ -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 :: Bool -> [Entry] -> String -> Maybe Html -> Html
-renderEntries entries topText = H.div ! A.class_ "innerBox" $ do
+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 $ 
+            H.ul $ if' showAll
-            sequence_ . reverse $ map showEntry entries
+                (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)

src/Locales.hs

@@ -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"
+backText DE = "Früher"
-prevMonth EN = "Earlier"
+backText EN = "Earlier"
 
-nextMonth DE = "Später"
+nextText DE = "Später"
-nextMonth EN = "Later"
+nextText EN = "Later"
 
 -- contact information
 contactText DE = "Wer mich kontaktieren will: "

src/Main.hs

@@ -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)]
+    entries <- getLatest lang [("descending", showJSON True)]
-    ok $ toResponse $ blogTemplate lang "" $ renderEntries entries (topText lang)
+    (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]