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

* guarding showLinks against negative numbers

Browse source
This commit is contained in:
Vincent Ambo 2012-03-06 21:24:58 +01:00
parent 91d197945f
commit 6220988fc5
2 changed files with 29 additions and 22 deletions
Download patch file Download diff file Expand all files Collapse all files

48
src/Blog.hs
View file

@ -5,9 +5,11 @@ module Blog where
import Data.Data (Data, Typeable) import Data.Data (Data, Typeable)
import Data.List (intersperse) import Data.List (intersperse)
import Data.Monoid (mempty) import Data.Monoid (mempty)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time import Data.Time
import System.Locale (defaultTimeLocale) import System.Locale (defaultTimeLocale)
import Text.Blaze (toValue, preEscapedString) import Text.Blaze (toValue, preEscapedText)
import Text.Blaze.Html5 (Html, (!), a, form, input, p, toHtml, label) import Text.Blaze.Html5 (Html, (!), a, form, input, p, toHtml, label)
import Text.Blaze.Html5.Attributes (action, enctype, href, name, size, type_, value) import Text.Blaze.Html5.Attributes (action, enctype, href, name, size, type_, value)
import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5 as H
@ -34,13 +36,15 @@ data Entry = Entry{
comments :: [Comment] comments :: [Comment]
} deriving (Show, Data, Typeable) } deriving (Show, Data, Typeable)
data BlogError = NoEntries | NotFound | DBError blogText :: (a -> String) -> a -> Text
blogText f = T.pack . f
data BlogError = NoEntries | NotFound | DBError
intersperse' :: a -> [a] -> [a] intersperse' :: a -> [a] -> [a]
intersperse' sep l = sep : intersperse sep l intersperse' sep l = sep : intersperse sep l
blogTemplate :: BlogLang -> String -> Html -> Html blogTemplate :: BlogLang -> Text -> Html -> Html
blogTemplate lang t_append body = H.docTypeHtml $ do --add body blogTemplate lang t_append body = H.docTypeHtml $ do --add body
H.head $ do H.head $ do
H.title $ (toHtml $ blogTitle lang t_append) H.title $ (toHtml $ blogTitle lang t_append)
@ -59,20 +63,20 @@ blogTemplate lang t_append body = H.docTypeHtml $ do --add body
H.div ! A.class_ "myclear" $ mempty H.div ! A.class_ "myclear" $ mempty
body body
H.div ! A.class_ "myclear" $ mempty H.div ! A.class_ "myclear" $ mempty
showFooter lang version showFooter lang $ T.pack version
H.div ! A.class_ "centerbox" $ H.div ! A.class_ "centerbox" $
H.img ! A.src "http://getpunchd.com/img/june/idiots.png" ! A.alt "" H.img ! A.src "http://getpunchd.com/img/june/idiots.png" ! A.alt ""
where where
contactInfo (imu :: String) = do contactInfo (imu :: Text) = do
toHtml $ contactText lang toHtml $ contactText lang
H.a ! A.href (toValue mailTo) $ "Mail" H.a ! A.href (toValue mailTo) $ "Mail"
", " ", "
H.a ! A.href (toValue twitter) ! A.target "_blank" $ "Twitter" H.a ! A.href (toValue twitter) ! A.target "_blank" $ "Twitter"
toHtml $ orString lang toHtml $ orText lang
H.a ! A.href (toValue imu) ! A.target "_blank" $ "iMessage" H.a ! A.href (toValue imu) ! A.target "_blank" $ "iMessage"
"." "."
renderEntries :: Bool -> [Entry] -> String -> Maybe Html -> Html renderEntries :: Bool -> [Entry] -> Text -> Maybe Html -> Html
renderEntries showAll entries topText footerLinks = renderEntries showAll entries topText footerLinks =
H.div ! A.class_ "innerBox" $ do H.div ! A.class_ "innerBox" $ do
H.div ! A.class_ "innerBoxTop" $ toHtml topText H.div ! A.class_ "innerBoxTop" $ toHtml topText
@ -85,7 +89,7 @@ renderEntries showAll entries topText footerLinks =
showEntry :: Entry -> Html showEntry :: Entry -> Html
showEntry e = H.li $ do showEntry e = H.li $ do
entryLink e entryLink e
preEscapedString $ " " ++ (text e) ++ "<br>&nbsp;</br>" preEscapedText $ T.concat [" ", blogText text e, "<br>&nbsp;</br>"]
entryLink e = H.a ! A.href (toValue $ concat $ intersperse' "/" $ linkElems e) $ entryLink e = H.a ! A.href (toValue $ concat $ intersperse' "/" $ linkElems e) $
toHtml ("[" ++ show(length $ comments e) ++ "]") toHtml ("[" ++ show(length $ comments e) ++ "]")
linkElems e = [show(lang e), show(year e), show(month e), show(day e), _id e] linkElems e = [show(lang e), show(year e), show(month e), show(day e), _id e]
@ -97,8 +101,8 @@ renderEntry entry = H.div ! A.class_ "innerBox" $ do
H.div ! A.class_ "innerBoxTop" $ toHtml $ title entry H.div ! A.class_ "innerBoxTop" $ toHtml $ title entry
H.div ! A.class_ "innerBoxMiddle" $ do H.div ! A.class_ "innerBoxMiddle" $ do
H.article $ H.ul $ H.li $ do H.article $ H.ul $ H.li $ do
preEscapedString $ text entry preEscapedText $ blogText text entry
preEscapedString $ mtext entry preEscapedText $ blogText mtext entry
H.div ! A.class_ "innerBoxComments" $ do H.div ! A.class_ "innerBoxComments" $ do
H.div ! A.class_ "cHead" $ toHtml $ cHead (lang entry) -- ! A.style "font-size:large;font-weight:bold;" H.div ! A.class_ "cHead" $ toHtml $ cHead (lang entry) -- ! A.style "font-size:large;font-weight:bold;"
H.ul $ renderComments (comments entry) (lang entry) H.ul $ renderComments (comments entry) (lang entry)
@ -123,7 +127,7 @@ renderComments comments lang = sequence_ $ map showComment comments
showComment c = H.li $ do showComment c = H.li $ do
H.a ! A.name (toValue $ cdate c) ! A.href (toValue $ "#" ++ (show $ cdate c)) ! A.class_ "cl" $ H.a ! A.name (toValue $ cdate c) ! A.href (toValue $ "#" ++ (show $ cdate c)) ! A.class_ "cl" $
H.i $ toHtml $ (cauthor c ++ ": ") H.i $ toHtml $ (cauthor c ++ ": ")
preEscapedString $ ctext c preEscapedText $ blogText ctext c
H.p ! A.class_ "tt" $ toHtml (timeString $ cdate c) H.p ! A.class_ "tt" $ toHtml (timeString $ cdate c)
getTime :: Integer -> Maybe UTCTime getTime :: Integer -> Maybe UTCTime
getTime t = parseTime defaultTimeLocale "%s" (show t) getTime t = parseTime defaultTimeLocale "%s" (show t)
@ -132,23 +136,25 @@ renderComments comments lang = sequence_ $ map showComment comments
timeString = (showTime lang) . getTime timeString = (showTime lang) . getTime
showLinks :: Maybe Int -> BlogLang -> Html showLinks :: Maybe Int -> BlogLang -> Html
showLinks (Just i) lang = H.div ! A.class_ "centerbox" $ do showLinks (Just i) lang
H.a ! A.href (toValue $ "/?page=" ++ show (i+1)) $ toHtml $ backText lang | ( i > 1) = H.div ! A.class_ "centerbox" $ do
toHtml (" -- " :: String) H.a ! A.href (toValue $ "/?page=" ++ show (i+1)) $ toHtml $ backText lang
H.a ! A.href (toValue $ "/?page=" ++ show (i-1)) $ toHtml $ nextText lang toHtml (" -- " :: Text)
H.a ! A.href (toValue $ "/?page=" ++ show (i-1)) $ toHtml $ nextText lang
| ( i <= 1 ) = showLinks Nothing lang
showLinks Nothing lang = H.div ! A.class_ "centerbox" $ showLinks Nothing lang = H.div ! A.class_ "centerbox" $
H.a ! A.href "/?page=2" $ toHtml $ backText lang H.a ! A.href "/?page=2" $ toHtml $ backText lang
showFooter :: BlogLang -> String -> Html showFooter :: BlogLang -> Text -> Html
showFooter l v = H.div ! A.class_ "rightbox" ! A.style "text-align:right;" $ do showFooter l v = H.div ! A.class_ "rightbox" ! A.style "text-align:right;" $ do
toHtml ("Proudly made with " :: String) toHtml ("Proudly made with " :: Text)
H.a ! A.href "http://haskell.org" $ "Haskell" H.a ! A.href "http://haskell.org" $ "Haskell"
toHtml (", " :: String) toHtml (", " :: Text)
H.a ! A.href "http://couchdb.apache.org/" $ "CouchDB" H.a ! A.href "http://couchdb.apache.org/" $ "CouchDB"
toHtml (" and without PHP, Java, Perl, MySQL and Python." :: String) toHtml (" and without PHP, Java, Perl, MySQL and Python." :: Text)
H.br H.br
H.a ! A.href (toValue repoURL) $ toHtml $ ("Version " :: String) ++ v H.a ! A.href (toValue repoURL) $ toHtml $ T.append "Version " v
preEscapedString "&nbsp;" preEscapedText "&nbsp;"
H.a ! A.href "/notice" $ toHtml $ noticeText l H.a ! A.href "/notice" $ toHtml $ noticeText l
-- Error pages -- Error pages

3
src/Locales.hs
View file

@ -1,4 +1,4 @@
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, OverloadedStrings #-}
module Locales where module Locales where
@ -101,6 +101,7 @@ cwHead :: BlogLang -> Text
cwHead DE = "Kommentieren:" cwHead DE = "Kommentieren:"
cwHead EN = "Comment:" cwHead EN = "Comment:"
cSingle :: BlogLang -> Text
cSingle DE = "Kommentar:" --input label cSingle DE = "Kommentar:" --input label
cSingle EN = "Comment:" cSingle EN = "Comment:"