redHandlers-0.1: Example/GridExample.hs

module Main where

import Text.CxML
import Text.YuiGrid
import Network.HTTP.RedHandler
import Control.Monad.Reader (ask)


-----------------------------------------------
-- Responses with grids
-----------------------------------------------

type GridResp = HandlerRsp [GridElement ()]

gridRespToRsp :: GridResp -> BasicRsp
gridRespToRsp = basicRspWith (showNonCxmlStrict "Grid Example" . gridPage)

-----------------------------------------------
-- Utilities for Handlers with Grid responses
-----------------------------------------------

-- | add contextual grid elements to the dynamic response
inGridWithElems :: Monad m => [GridElement RequestContext] -> RqHandlerT m GridResp -> RqHandlerT m GridResp
inGridWithElems ges handl = do ges' <- fmap (runBoxes ges) ask
                               fmap (fmap (++ ges')) handl

-- | turn a contextual html into a grid response handler
okCxML :: Monad m => CxML RequestContext -> RqHandlerT m GridResp
okCxML cx = fmap ( return . (:[]) . boxInMain . runCxML cx) ask


-----------------------------------------------
-- Main daemon and port
-----------------------------------------------
main :: IO ()
main = runHttpServer 8080 mainHandlers

-----------------------------------------------
-- Routes and handlers
-----------------------------------------------
mainHandlers :: [IORqHandler BasicRsp]
mainHandlers = [staticFilesHandler, appHandlers]

staticFilesHandler = under "pictures" $ mapDir "./images/"

appHandlers = modResp gridRespToRsp $ appCtx $ anyOf [greetHandler, inputFormHandler]


inputFormHandler :: IORqHandler GridResp
inputFormHandler = okCxML inputForm

greetHandler :: IORqHandler GridResp
greetHandler =  ifPost $ 
                 withPostField "name" (\n -> if null n 
                                               then notMe 
                                               else okCxML (greet n)
                                       )


greet :: String -> CxML a
greet n = p /- [t $ "Hello " ++ n ++ "!"]

inputForm :: CxML a
inputForm = form!("method","post")
                /- [
                    p /- [t "My name is ", textfield "name"],
                    button!("name","action")!("value","submit") /- [t "Submit"]
                   ]



-----------------------------------------------
-- Application GRID context
-----------------------------------------------
appCtx :: Monad m => RqHandlerT m GridResp -> RqHandlerT m GridResp
appCtx h = do
              inGridWithElems [
                   boxInFooter (t "Footer goes here."),
                   boxInHeader (h1logo "Header image goes in the URL" "/pictures/header.gif"),
                   smallMarginBottomCSS $ nearLeft $ setColumnsVote 2 $ nearBottom $ boxInHeader (loginControl "Guest"),
                   smallMarginBottomCSS $ nearRight $ setColumnsVote 2 $ nearBottom $ boxInHeader searchForm,
                   boxInLeftSidebar (vertNav [("Home", "/"),
                                                  ("About", "/about"),
                                                  ("Contact", "/contact")])
                  ] $ h


-----------------------------------------------
-- More contextual htmls used in the example
-----------------------------------------------
searchForm :: CxML a
searchForm
           = form!("method","post")!("action","/search.html")
                /- [
                    textfield "search", 
                    button!("name","action")!("value","submit") /- [t "Search"]
                   ]


loginControl ::String -> CxML a
loginControl userName = t ("User: " ++ userName)