tvl-depot/src/Server.hs

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

module Main where

import           Control.Monad (msum, mzero)
import           Data.Data (Data, Typeable)
import           Data.Monoid (mempty)
import           Data.ByteString.Char8 (ByteString)
import           Data.Text hiding (map, length, zip, head)
import           Data.Time
import           Database.CouchDB
import           Happstack.Server
import           Text.Blaze (toValue, preEscapedString)
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           Text.JSON.Generic

import           Blog

tmpPolicy :: BodyPolicy
tmpPolicy = (defaultBodyPolicy "./tmp/" 0 1000 1000)


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)

data BlogLang = EN | DE deriving (Data, Typeable)

instance Show BlogLang where
    show EN = "en"
    show DE = "de"

--TazBlog version
version = ("2.2b" :: String)

main :: IO()
main = do
    putStrLn ("TazBlog " ++ version ++ " in Haskell starting")
    simpleHTTP nullConf tazBlog

tazBlog :: ServerPart Response
tazBlog = do
    msum [ dir "en" $ blogHandler EN
         , dir "de" $ blogHandler DE
         , do nullDir
              ok $ showIndex DE
         , do dir " " $ nullDir
              seeOther ("https://plus.google.com/115916629925754851590" :: String) (toResponse ())
         , dir "res" $ serveDirectory DisableBrowsing [] "../res"
         , serveDirectory DisableBrowsing [] "../res"
         ]

blogHandler :: BlogLang -> ServerPart Response
blogHandler lang = 
    msum [ path $ \(year :: Int) -> path $ \(month :: Int) -> path $ --single entry
                      \(day :: Int) -> path $ \(id_ :: String) -> showEntry lang year month day id_
         , do nullDir
              ok $ showIndex lang
         ]

showEntry :: BlogLang -> Int -> Int -> Int -> String -> ServerPart Response
showEntry EN y m d i = undefined
showEntry DE y m d i = undefined

showIndex :: BlogLang -> Response
showIndex lang = toResponse $ renderBlogHeader lang

renderBlogHeader :: BlogLang -> Html
renderBlogHeader DE = blogTemplate "Tazjins Blog" "Wer mich kontaktieren will: " " oder " "de" version
renderBlogHeader EN = blogTemplate "Tazjin's Blog" "Get in touch with me: " " or " "en" version

-- http://tazj.in/2012/02/10.155234

-- CouchDB View Setup
latestDEView = "function(doc){ if(doc.lang == \"de\"){ emit([doc.year, doc.month, doc.day, doc.id_], doc); } }"
latestENView = "function(doc){ if(doc.lang == \"en\"){ emit([doc.year, doc.month, doc.day, doc.id_]], doc); } }"

latestDE = ViewMap "latestDE" latestDEView
latestEN = ViewMap "latestEN" latestENView

setupBlogViews :: IO ()
setupBlogViews = runCouchDB' $ 
    newView "tazblog" "entries" [latestDE, latestEN]