{-# LANGUAGE QuasiQuotes #-}
module Main where

import Control.Monad.Trans(MonadIO(liftIO))
import qualified Data.ByteString.Char8      as B
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map                   as M
import qualified Data.Text.Lazy.Encoding    as T    

import Text.Hamlet
import Text.Hamlet.Monad (hamletToText)
import Data.Text (pack)
import Happstack.Server

data Person = Person
    { name :: IO HtmlContent -- maybe it requires a database lookup
    , age :: HtmlContent
    , page :: PersonUrls
    , isMarried :: Bool
    , children :: [HtmlContent]
    }
data PersonUrls = Homepage | PersonPage String

renderUrls :: PersonUrls -> String
renderUrls Homepage = "/"
renderUrls (PersonPage name) = '/' : name

footer :: Monad m => a -> Hamlet url m ()
footer = [$hamlet|
#footer Thank you, come again
|]

template :: Person -> Hamlet PersonUrls IO ()
template = [$hamlet|
!!!
%html
    %head
        %title Hamlet Demo
    %body
        %h1 Information on $*name$
        %p $*name$ is $age$ years old.
        %h2
            $if isMarried
                <b>Married</b>
            $else
                Not <b>married</b>
        %ul
            $forall children child
                %li $child$
        %p
            %a!href=@page@ See the page.
        ^footer^
|]

person :: Person
person = Person
            { name = return $ Unencoded $ pack "Michael"
            , age = Unencoded $ pack "twenty five & a half"
            , page = PersonPage "michael"
            , isMarried = True
            , children = [ Unencoded $ pack "Adam"
                         , Unencoded $ pack "Ben"
                         , Unencoded $ pack "Chris"
                         ]
            }

-- happstack changes

main :: IO ()
main = simpleHTTP nullConf $ liftIO $ hamletToResponse renderUrls $ template person

hamletToResponse :: (Monad m) => (url -> String) -> Hamlet url m () -> m Response
hamletToResponse showFn hamlet = 
    do msg <- hamletToText showFn hamlet
       return $ toResponse_ (B.pack "text/html; charset=UTF-8") (T.encodeUtf8 msg)

toResponse_ :: B.ByteString -> L.ByteString -> Response
toResponse_ contentType message =
    let res = Response 200 M.empty nullRsFlags message Nothing
    in setHeaderBS (B.pack "Content-Type") contentType res