path: root/src/Blog.hs

{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable #-}

module Blog where

import           Data.Data (Data, Typeable)
import           Data.List (intersperse)
import           Data.Monoid (mempty)
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.Time
import           System.Locale (defaultTimeLocale)
import           Text.Blaze (toValue, preEscapedText)
import           Text.Blaze.Html5 (Html, (!), a, form, input, p, toHtml, label)
import           Text.Blaze.Html5.Attributes (action, enctype, href, name, size, type_, value)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A

import           Locales

data Comment = Comment{
    cauthor :: String,
    ctext   :: String,
    cdate   :: Integer
} deriving (Show, Data, Typeable)

data Entry = Entry{
    _id      :: String,
    year     :: Int,
    month    :: Int,
    day      :: Int,
    lang     :: BlogLang,
    title    :: String,
    author   :: String,
    text     :: String,
    mtext    :: String,
    comments :: [Comment]
} deriving (Show, Data, Typeable)

blogText :: (a -> String) -> a -> Text
blogText f = T.pack . f


-- custom list functions
intersperse' :: a -> [a] -> [a]
intersperse' sep l = sep : intersperse sep l

replace :: Eq a => a -> a -> [a] -> [a]
replace x y = map (\z -> if z == x then y else z)

blogTemplate :: BlogLang -> Text -> Html -> Html
blogTemplate lang t_append body = H.docTypeHtml $ do --add body
    H.head $ do
        H.title $ (toHtml $ blogTitle lang t_append)
        H.link ! A.rel "alternate" ! A.type_ "application/rss+xml" ! A.title "RSS-Feed" ! A.href "/rss"
        H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/res/blogstyle.css" ! A.media "all"
        H.meta ! A.httpEquiv "content-type" ! A.content "text/html;charset=UTF-8"
        --H.style ! A.type_ "text/css" ! A.title "iOS iMessage" ! A.media "screen and (max-device-width: 1024px)" $ "#cosx{display:none;}"
    H.body $ do
        H.div ! A.class_ "mainshell" $ H.div ! A.class_ "gradBox" $ do
            H.div ! A.class_ "header" $ do
                H.a ! A.href (toValue $ "/" ++ show lang) ! 
                    A.style "text-decoration:none;color:black;font-size:x-large;font-weight:bold;" $
                        toHtml $ blogTitle lang ""
                H.p ! A.style "clear: both;" $ do
                    H.span ! A.style "float: left;" ! A.id "cosx" $ H.b $ contactInfo iMessage
                   -- H.span ! A.id "cios" ! A.style "display:none;" $ H.b $ contactInfo "sms:tazjin@me.com"
                    H.span ! A.style "float:right;" $ preEscapedText $ rightText lang
            H.div ! A.class_ "myclear" $ mempty
            body
            H.div ! A.class_ "myclear" $ mempty
            showFooter lang $ T.pack version
        H.div ! A.class_ "centerbox" $
            H.img ! A.src "http://getpunchd.com/img/june/idiots.png" ! A.alt ""
    where
        contactInfo (imu :: Text) = do
            toHtml $ contactText lang
            H.a ! A.href (toValue mailTo) $ "Mail"
            ", "
            H.a ! A.href (toValue twitter) ! A.target "_blank" $ "Twitter"
            toHtml $ orText lang
            H.a ! A.href (toValue imu) ! A.target "_blank" $ "iMessage"
            "."

renderEntries :: Bool -> [Entry] -> Text -> 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 
            entryLink e
            preEscapedText $ T.concat [" ", blogText text e, "<br>&nbsp;</br>"]
        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
    H.div ! A.class_ "innerBoxTop" $ toHtml $ title entry
    H.div ! A.class_ "innerBoxMiddle" $ do
        H.article $ H.ul $ H.li $ do
            preEscapedText $ blogText text entry
            preEscapedText $ blogText mtext entry
        H.div ! A.class_ "innerBoxComments" $ do
            H.div ! A.class_ "cHead" $ toHtml $ cHead (lang entry) -- ! A.style "font-size:large;font-weight:bold;"
            H.ul $ renderComments (comments entry) (lang entry)
            renderCommentBox (lang entry) (_id entry)

renderCommentBox :: BlogLang -> String -> Html
renderCommentBox cLang cId = do
    H.div ! A.class_ "cHead" $ toHtml $ cwHead cLang
    H.form ! A.method "POST" ! A.action (toValue $ "/" ++ (show cLang) ++  "/postcomment/" ++ cId) $ do
        H.p $ H.label $ do
            H.span $ "Name:" --toHtml ("Name:" :: String)
            H.input ! A.name "cname"
        H.p $ H.label $ do
            H.span $ toHtml $ cSingle cLang -- toHtml (cSingle lang)
            H.textarea ! A.name "ctext" ! A.cols "50" ! A.rows "13" $ mempty
        H.p $ H.input ! A.type_ "submit" ! A.value (toValue $ cSend cLang)

renderComments :: [Comment] -> BlogLang -> Html
renderComments [] lang = H.li $ toHtml $ noComments lang
renderComments comments lang = sequence_ $ map showComment comments
    where
        showComment :: Comment -> Html
        showComment c = H.li $ do
            H.a ! A.name (toValue $ cdate c) ! A.href (toValue $ "#" ++ (show $ cdate c)) ! A.class_ "cl" $
               H.i $ toHtml $ (cauthor c ++ ": ")
            preEscapedText $ blogText ctext c
            H.p ! A.class_ "tt" $ toHtml (timeString $ cdate c)
        getTime :: Integer -> Maybe UTCTime
        getTime t = parseTime defaultTimeLocale "%s" (show t)
        showTime lang (Just t) = formatTime defaultTimeLocale (cTimeFormat lang) t
        showTime _ Nothing = "[???]" -- this can not happen??
        timeString = (showTime lang) . getTime

showLinks :: Maybe Int -> BlogLang -> Html
showLinks (Just i) lang
    | ( i > 1) = H.div ! A.class_ "centerbox" $ do
        H.a ! A.href (toValue $ "/?page=" ++ show (i+1)) $ toHtml $ backText 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" $
    H.a ! A.href "/?page=2" $ toHtml $  backText lang

showFooter :: BlogLang -> Text -> Html
showFooter l v = H.div ! A.class_ "rightbox" ! A.style "text-align:right;" $ do
    toHtml ("Proudly made with " :: Text)
    H.a ! A.href "http://haskell.org" $ "Haskell"
    toHtml (", " :: Text)
    H.a ! A.href "http://couchdb.apache.org/" $ "CouchDB"
    toHtml (" and without PHP, Java, Perl, MySQL and Python." :: Text)
    H.br
    H.a ! A.href (toValue repoURL) $ toHtml $ T.append "Version " v
    preEscapedText "&nbsp;"
    H.a ! A.href "/notice" $ toHtml $ noticeText l

showSiteNotice :: Html
showSiteNotice = H.docTypeHtml $ do
    H.title $ "Impressum"
    H.h2 $ preEscapedText "Impressum und <a alt=\"Verantwortlich im Sinne des Presserechtes\">ViSdP</a>"
    H.i $ "[German law demands this]"
    H.br
    H.p $ do
        toHtml ("Vincent Ambo" :: Text)
        H.br
        toHtml ("Benfleetstr. 8" :: Text)
        H.br 
        toHtml ("50858 Köln" :: Text)
        H.p $ H.a ! A.href "/" ! A.style "color:black" $ "Back"

{- Administration pages -}

adminTemplate :: Html -> Text -> Html
adminTemplate body title = H.docTypeHtml $ do
    H.head $ do
        H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/res/admin.css" ! A.media "all"
        H.meta ! A.httpEquiv "content-type" ! A.content "text/html;charset=UTF-8"
        H.title $ toHtml $ T.append "TazBlog Admin: " title
    H.body
        body

adminLogin :: Html
adminLogin = H.div ! A.class_ "loginBox" $ do
    H.div ! A.class_ "loginBoxTop" $ "TazBlog Admin: Login"
    H.div ! A.class_ "loginBoxMiddle" $ H.form ! A.action "/login" ! A.method "post" $ do
        H.p $ "Account ID"
        H.p $ H.input ! A.type_ "text" ! A.style "font-size: 2;" 
            ! A.name "account" ! A.value "tazjin" ! A.readonly "1"
        H.p $ "Passwort"
        H.p $ H.input ! A.type_ "password" ! A.style "font-size: 2;" ! A.name "pass"

-- Error pages
showError :: BlogError -> BlogLang -> Html
showError NotFound l = undefined