* Pagination (finally!)
* slight CSS change
This commit is contained in:
parent
485e271475
commit
96093c9009
4 changed files with 43 additions and 18 deletions
|
@ -42,6 +42,7 @@ body {
|
|||
|
||||
.centerbox {
|
||||
text-align:center;
|
||||
min-height: 45px;
|
||||
}
|
||||
|
||||
.rightbox {
|
||||
|
@ -110,4 +111,4 @@ body {
|
|||
|
||||
.innerBoxComments {
|
||||
padding-left: 20px
|
||||
}
|
||||
}
|
||||
|
|
25
src/Blog.hs
25
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)
|
||||
|
|
|
@ -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: "
|
||||
|
|
21
src/Main.hs
21
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]
|
||||
|
|
Loading…
Reference in a new issue