Commit 4ab25cd8 authored by Michael Hanus 's avatar Michael Hanus

Add support for HTTP page headers (see example `Redirect.curry` for usage)

parent 6de3e9c8
------------------------------------------------------------------------------
-- Example for a form to redirect to another URL typed in a text input field.
-- The example exploits the HTTP head field `Location` for redirection.
------------------------------------------------------------------------------
import HTML.Base
-- Example: a form with a text input field and two submit buttons.
redirectForm :: HtmlFormDef String
redirectForm = formDefWithID "Redirect.redirectForm" (return "") formHtml
where
formHtml _ =
[ htxt "Enter a URL: ", textField ref "http://www.google.com"
, hrule
, button "Go to the URL" redirectHandler
]
where
ref free
redirectHandler env =
return $ addHeader "Location" (env ref) $ page "Answer" []
-- main HTML page containing the form
main :: IO HtmlPage
main = return $ page "Redirection"
[ h1 [htxt "This is simple example for redirection"],
formExp redirectForm ]
-- Install with:
-- > cypm exec curry2cgi -o ~/public_html/cgi-bin/redirect.cgi Redirect
-------------------------------------------------------------------------
......@@ -32,7 +32,7 @@ module HTML.Base
getCookies,
page,standardPage,
pageEnc, pageCookie, pageCSS, pageMetaInfo,
pageLinkInfo, pageBodyAttr, addPageParam, addPageCookies,
pageLinkInfo, pageBodyAttr, addPageParam, addCookies, addHeader,
htxt,htxts,hempty,nbsp,h1,h2,h3,h4,h5,
par,section,header,footer,emphasize,strong,bold,italic,nav,code,
center,blink,teletype,pre,verbatim,address,href,anchor,
......@@ -193,6 +193,7 @@ data HtmlPage = HtmlPage String [PageParam] [HtmlExp]
--- @cons PageCookie name value params - a cookie to be sent to the
--- client's browser
--- @cons PageCSS s - a URL for a CSS file for this page
--- @cons PageHeader key value - additional HTTP header to be included
--- @cons PageJScript s - a URL for a Javascript file for this page
--- @cons PageMeta as - meta information (in form of attributes) for this page
--- @cons PageLink as - link information (in form of attributes) for this page
......@@ -202,6 +203,7 @@ data HtmlPage = HtmlPage String [PageParam] [HtmlExp]
data PageParam = PageEnc String
| PageCookie String String [CookieParam]
| PageCSS String
| PageHeader String String
| PageJScript String
| PageMeta [(String,String)]
| PageLink [(String,String)]
......@@ -221,6 +223,11 @@ pageCookie (n,v) = PageCookie n v []
pageCSS :: String -> PageParam
pageCSS css = PageCSS css
--- A header to be sent to the client's browser when a HTML page is
--- requested.
pageHeader :: String -> String -> PageParam
pageHeader k v = PageHeader k v
--- Meta information for a HTML page. The argument is a list of
--- attributes included in the `meta`-tag in the header for this page.
pageMetaInfo :: [(String,String)] -> PageParam
......@@ -253,7 +260,7 @@ standardPage :: String -> [HtmlExp] -> HtmlPage
standardPage title hexps = page title (h1 [htxt title] : hexps)
--- Adds a parameter to an HTML page.
--- @param form - a page
--- @param page - a page
--- @param param - a page's parameter
--- @return an HTML page
addPageParam :: HtmlPage -> PageParam -> HtmlPage
......@@ -266,11 +273,22 @@ addPageParam hexp@(HtmlAnswer _ _) _ = hexp
--- @param cs - the cookies as a list of name/value pairs
--- @param form - the form to add cookies to
--- @return a new HTML page
addPageCookies :: [(String,String)] -> HtmlPage -> HtmlPage
addPageCookies cs (HtmlPage title params hexps) =
addCookies :: [(String,String)] -> HtmlPage -> HtmlPage
addCookies cs (HtmlPage title params hexps) =
HtmlPage title (map pageCookie cs ++ params) hexps
addPageCookies _ (HtmlAnswer _ _) =
error "addPageCookies: cannot add cookie to HTML answer"
addCookies _ (HtmlAnswer _ _) =
error "addCookies: cannot add cookie to HTML answer"
--- Add a header to HTML page.
--- Headers are sent to the client's browser together with this page.
--- @param key - the cookies as a list of name/value pairs
--- @param page - the page to add cookies to
--- @return a new HTML page
addHeader :: String -> String -> HtmlPage -> HtmlPage
addHeader key value (HtmlPage t fas hs) =
HtmlPage t (PageHeader key value : fas) hs
addHeader _ _ (HtmlAnswer _ _) =
error "addHeader: cannot add header to Html answer"
------------------------------------------------------------------------------
--- The possible parameters of a cookie.
......@@ -948,6 +966,7 @@ showHtmlPage (HtmlPage title params html) =
param2html (PageCSS css) =
[HtmlStruct "link" [("rel","stylesheet"),("type","text/css"),("href",css)]
[]]
param2html (PageHeader _ _) = [] -- page headers are differently processed
param2html (PageJScript js) =
[HtmlStruct "script" [("type","text/javascript"),("src",js)] []]
param2html (PageMeta attrs) = [HtmlStruct "meta" attrs []]
......
......@@ -77,29 +77,34 @@ printPage (HtmlAnswer ctype cont) = do
putStrLn $ "Content-Length: " ++ show (length cont) ++
"\nContent-Type: " ++ ctype ++ "\n\n" ++ cont
printPage p@(HtmlPage _ _ _) = do
let (cookiestring,hpage) = extractCookies p
putStrLn $ cookiestring ++
let (headerstring,hpage) = extractHeader p
putStrLn $ headerstring ++
"Content-type: text/html\n\n" ++ showHtmlPage hpage
-- Extract the cookies contained in a HTML page and return the
-- "set cookie" string and the HTML page without the cookies:
extractCookies :: HtmlPage -> (String,HtmlPage)
extractCookies (HtmlAnswer ctype cont) = ("", HtmlAnswer ctype cont)
extractCookies (HtmlPage title params hexp) =
let cookiestring = if null cookies
then ""
else "Cache-control: no-cache=\"set-cookie\"\n" ++
concatMap ((++"\n") . formatCookie) cookies
in (cookiestring, HtmlPage title otherparams hexp)
where
(cookies,otherparams) = splitFormParams params
splitFormParams [] = ([],[])
splitFormParams (fparam:fps) =
let (cs,ops) = splitFormParams fps
in case fparam of
PageCookie n v ps -> ((n,v,ps) : cs, ops)
_ -> (cs, fparam:ops)
-- Extract the headers contained in a form as well as the cookies
-- and return a string for the HTTP header of the page
-- if any cookie is set, also return the cache-control header
extractHeader :: HtmlPage -> (String, HtmlPage)
extractHeader (HtmlAnswer ctype cont) = ("",HtmlAnswer ctype cont)
extractHeader (HtmlPage title params hexp) =
(headerstring ++ cookiestring, HtmlPage title otherparams hexp)
where
headerstring = concatMap (++"\n") headers
cookiestring = if null cookies
then ""
else "Cache-control: no-cache=\"set-cookie\"\n" ++
concatMap ((++"\n") . formatCookie) cookies
(headers, cookies, otherparams) = splitPageParams params
splitPageParams [] = ([],[],[])
splitPageParams (fparam:fps) =
let (hs,cs,ops) = splitPageParams fps
in case fparam of
PageCookie n v ps -> (hs, (n,v,ps) : cs, ops)
PageHeader k v -> ((k ++ ": " ++ v):hs, cs, ops)
_ -> (hs, cs, fparam:ops)
-- Generates HTML page to show in illegal invocation of a form.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment