Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tag: v0.2
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 122 lines (90 sloc) 4.079 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings, FlexibleContexts #-}

-- | This module contains the top-level handler for the website.

module Homepage.Handlers (topLevelHandler) where

import Control.Monad.State.Strict

import Data.List
import Data.Monoid
import qualified Data.ByteString.Lazy.Char8 as B

import Happstack.Helpers
import Happstack.Server
--import Happstack.Server.Parts

import Homepage.Types
import Homepage.Util.Templates
import Homepage.Util.Delicious as Delicious

import Text.StringTemplate


topLevelHandler :: HomepageHandler
topLevelHandler =
-- gzip currently doesn't work. augh
--
-- do
-- compressedResponseFilter
      frontpage `mappend`
        aboutpage `mappend`
        contactpage `mappend`
        (liftH staticfiles) `mappend`
        temporaryPosts `mappend`
        fourohfour


frontpage :: HomepageHandler
frontpage =
    exactdir "/" $ do
      bookmarks <- lift Delicious.getRecent
      serveTemplate' "." "home" (setAttribute "recentBookmarks" bookmarks .
                                 setAttribute "whichCss" ("home" :: String))

aboutpage :: HomepageHandler
aboutpage =
    exactdir "/about" $ do
      serveTemplate' "." "about" (setAttribute "whichCss"
                                               ("posts" :: String))


contactpage :: HomepageHandler
contactpage =
    exactdir "/contact" $ do
      serveTemplate' "." "contact" (setAttribute "whichCss"
                                   ("posts" :: String))


tempPost1 :: HomepageHandler
tempPost1 = prefixdir "/posts/2009/03/28/building-a-website-part-1" $ do
    postContent <- lift $ (getTemplate "." "temppost1") >>=
                            (return . B.unpack . render)

    let attrs :: [(String,String)]
        attrs = [ ("websiteTitleExtra",
                   ": Building a website with Haskell, part 1")
                , ("whichCss", "posts")
                , ("postContent", postContent)
                , ("postTitle", "Building a website with Haskell, part 1")
                , ("postSummary", "Using the <a href=\"\
\http://www.happstack.com/\">happstack</a> \
\web framework to power a simple personal \
\website.")
                , ("postDate", "march 28, 2009") ]

    serveTemplate' "." "post" (setManyAttrib attrs)


tempPost2 :: HomepageHandler
tempPost2 = prefixdir "/posts/2009/03/30/building-a-website-part-2" $ do
    postContent <- lift $ (getTemplate "." "temppost2") >>=
                            (return . B.unpack . render)

    let attrs :: [(String,String)]
        attrs = [ ("websiteTitleExtra",
                   ": Building a website with Haskell, part 2")
                , ("whichCss", "posts")
                , ("postContent", postContent)
                , ("postTitle", "Building a website with Haskell, part 2")
                , ("postSummary", "In the second part of the series, we \
\discuss the design of this <a href=\"\
\http://www.happstack.com/\">happstack</a> \
\website.")
                , ("postDate", "march 30, 2009") ]

    serveTemplate' "." "post" (setManyAttrib attrs)



temporaryPosts :: HomepageHandler
temporaryPosts = tempPost1 `mappend` tempPost2


prefixdir :: (Monad m) => String -> ServerPartT m a -> ServerPartT m a
prefixdir staticPath sps = do
    rq <- askRq
    if staticPath `isPrefixOf` (rqURL rq) then sps else mzero


fourohfour :: HomepageHandler
fourohfour = serveTemplate' "." "404" (setAttribute "whichCss"
                                      ("posts" :: String))


-- N.B. "fileServeStrict" here is like normal "fileServe" from
-- happstack 0.2.1, except modified to consume the file strictly
-- (avoiding handle leaks). You'll need the darcs truck version of
-- happstack to run this.
staticfiles :: WebHandler
staticfiles = staticserve "static"
  where staticserve d = dir d (fileServeStrict [] d)
Something went wrong with that request. Please try again.