gistfile1.hs

{-# LANGUAGE OverloadedStrings, TemplateHaskell, EmptyDataDecls, TypeFamilies #-}
module Main where

import Debug.Trace (trace)

import Happstack.Server

import Web.Routes.Site
import Web.Routes.PathInfo (PathInfo (..), parseSegments)
import Web.Routes.Happstack 
import Web.Routes.Regular

import Generics.Regular (deriveAll)
import Generics.Regular.Base (PF (..), from, to)

import Control.Monad (forM_)
import Control.Monad.Identity

import Blaze

import Text.Blaze.Renderer.String
import Text.Blaze.Html5
import Text.Blaze.Html5.Attributes
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A

import Network.URI

data BlogURL = Index
             | Post Int -- idTutorial

$(deriveAll ''BlogURL "PFBlogURL")

type instance PF BlogURL = PFBlogURL

instance PathInfo BlogURL where
  -- toPathSegments :: BlogURL -> [String]
  toPathSegments = gtoPathSegments . from   
  -- fromPathSegments :: Web.Routes.PathInfo.URLParser BlogURL
  fromPathSegments = fmap to gfromPathSegments

type TServer = ServerPartT IO Html

testSite :: Site BlogURL TServer
testSite = Site {
       handleSite           = trace "handleSite" blogHandle
    ,  formatPathSegments   = trace "formatPathSegments" toPathSegments
    ,  parsePathSegments    = trace "parsePathSegments" (parseSegments fromPathSegments)
}

blogHandle :: (BlogURL -> String) -> BlogURL -> TServer
blogHandle f (Post idPost) = ok $ H.showHtml $ "Post ID: " ++ (show idPost)
blogHandle f (Index) = ok $ H.showHtml "Index"

main :: IO ()
main = do
    let server :: TServer
        server = implSite "http://localhost:8000/" "." testSite
    simpleHTTP nullConf server