diff options
| -rw-r--r-- | res/blogstyle.css | 3 | ||||
| -rw-r--r-- | src/Blog.hs | 25 | ||||
| -rw-r--r-- | src/Locales.hs | 12 | ||||
| -rw-r--r-- | src/Main.hs | 21 |
4 files changed, 43 insertions, 18 deletions
diff --git a/res/blogstyle.css b/res/blogstyle.css index d830ee2e23d0..6315ffd06ff1 100644 --- a/res/blogstyle.css +++ b/res/blogstyle.css @@ -42,6 +42,7 @@ body { .centerbox { text-align:center; + min-height: 45px; } .rightbox { @@ -110,4 +111,4 @@ body { .innerBoxComments { padding-left: 20px -} \ No newline at end of file +} diff --git a/src/Blog.hs b/src/Blog.hs index 7b39fe5c9928..575ec04fcf8a 100644 --- a/src/Blog.hs +++ b/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 entries topText = 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 +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 $ 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) diff --git a/src/Locales.hs b/src/Locales.hs index c3d11bc887af..6fb5849b8c0f 100644 --- a/src/Locales.hs +++ b/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" -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: " diff --git a/src/Main.hs b/src/Main.hs index debf02e3cc18..89f6179237f5 100644 --- a/src/Main.hs +++ b/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)] - 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] |