|
sourcecode:
|
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-}
module HTML.Base
( Attrs,
HTML, htmlText, htmlStruct, hStruct, updAttrs, fromHtmlText, fromHtmlStruct,
BaseHtml(..), StaticHtml(..), fromStaticHtml, toStaticHtml,
HtmlExp(..), toHtmlExp, fromHtmlExp, textOf,
HtmlPage(..), PageParam(..),
FormReader, fromFormReader, toFormReader,
HtmlFormDef, simpleFormDef, simpleFormDefWithID, formDef, formDefWithID,
formDefId, setFormDefId, formDefRead, formDefView,
CookieParam(..),
HtmlRef, idOfHtmlRef, instHtmlRefs, HtmlEnv, HtmlHandler,
defaultEncoding,
answerText, answerEncText,
getCookies,
page, headerPage,
pageEnc, pageCookie, pageCSS, pageMetaInfo,
pageLinkInfo, pageBodyAttr, addPageParam, addCookies, addHttpHeader,
addPageBody,
htxt, htxts, hempty, nbsp, h1, h2, h3, h4, h5, h6,
par, section, header, footer, emphasize, strong, bold, italic, nav, code,
center, blink, teletype, pre, verbatim, address, href, anchor,
ulist, ulistWithClass, ulistWithItemClass,
olist, olistWithClass, olistWithItemClass,
litem, dlist,
table, tableWithClass, headedTable,
hrule, breakline, image,
styleSheet, style, textstyle, blockstyle, inline, block, hiddenField,
redirectPage, expires,
formElem, formElemWithAttrs,
button, resetButton, imageButton, coordinates,
textField, password, textArea, checkBox, checkedBox,
radioMain, radioMainOff, radioOther,
selection, selectionInitial, multipleSelection,
htmlQuote, htmlIsoUmlauts, addAttr, addAttrs, addClass,
showStaticHtmls, showBaseHtmls, showHtmls, showHtml, showHtmlPage,
htmlPrelude, htmlTagAttrs,
getUrlParameter, formatCookie
) where
import Data.Char ( isAlphaNum, isSpace )
import Numeric ( readNat, readHex )
import System.Environment ( getEnv )
import Data.Time ( CalendarTime(..), ClockTime, toTimeString, toUTCTime )
import Network.URL ( string2urlencoded, urlencoded2string )
infixl 0 `addAttr`
infixl 0 `addAttrs`
infixl 0 `addClass`
infixl 0 `addPageParam`
------------------------------------------------------------------------------
--- The default encoding used in generated HTML documents.
defaultEncoding :: String
defaultEncoding = "utf-8" --"iso-8859-1"
------------------------------------------------------------------------------
-- Basic types for (static) HTML documents.
--- The attributes for HTML structures consists of a list of
--- name/value pairs.
type Attrs = [(String,String)]
--- A type is an instance of class `HTML` if it has operations to construct
--- HTML documents, i.e., constructors for basic text strings and
--- structures with tags and attributes, update the attributes in structures,
--- and selectors for basic text and structures which returns the contents
--- of these elements (or `Nothing` for different elements).
class HTML a where
htmlText :: String -> a
htmlStruct :: String -> Attrs -> [a] -> a
updAttrs :: (Attrs -> Attrs) -> a -> a
fromHtmlText :: a -> Maybe String
fromHtmlStruct :: a -> Maybe (String,Attrs,[a])
-- Some useful abbreviations:
--- Basic text as an HTML expression.
--- The text may contain special HTML chars (like <,>,&,")
--- which will be quoted so that they appear as in the parameter string.
htxt :: HTML h => String -> h
htxt s = htmlText (htmlQuote s)
--- A list of strings represented as a list of HTML expressions.
--- The strings may contain special HTML chars that will be quoted.
htxts :: HTML h => [String] -> [h]
htxts = map htxt
--- An HTML structure with a given tag and no attributes.
hStruct :: HTML h => String -> [h] -> h
hStruct tag = htmlStruct tag []
------------------------------------------------------------------------------
--- The data type to represent static HTML expressions in web scripts.
--- @cons BaseText s - a text string without any further structure
--- @cons BaseStruct t as hs - a structure with a tag, attributes, and
--- HTML expressions inside the structure
--- @cons BaseAction act - an action that computes a general HTML expression
--- which will be inserted when the HTML document
--- is shown (used to implement form expressions)
data BaseHtml =
BaseText String
| BaseStruct String Attrs [BaseHtml]
| BaseAction (IO HtmlExp)
--- Updates the attributes in a basic HTML expression.
updBaseAttrs :: (Attrs -> Attrs) -> BaseHtml -> BaseHtml
updBaseAttrs _ (BaseText s) = BaseText s
updBaseAttrs f (BaseStruct tag attrs hexps) = BaseStruct tag (f attrs) hexps
updBaseAttrs _ (BaseAction act) = BaseAction act
--- The type of basic HTML expressions is an instance of class `HTML`.
instance HTML BaseHtml where
htmlText = BaseText
htmlStruct = BaseStruct
updAttrs = updBaseAttrs
fromHtmlText (BaseText s) = Just s
fromHtmlText (BaseStruct _ _ _) = Nothing
fromHtmlText (BaseAction _) = Nothing
fromHtmlStruct (BaseText _) = Nothing
fromHtmlStruct (BaseStruct t ats hs) = Just (t,ats,hs)
fromHtmlStruct (BaseAction _) = Nothing
------------------------------------------------------------------------------
--- The data type to represent static HTML expressions which can be
--- persistently stored, e.g., read from or written into files.
--- It is similar to type `BaseHtml` except that there
--- is no constructor `BaseAction` so this type has instances
--- for standard classes like `Eq`, `Data`, `Read`, and `Show`.
--- @cons HText s - a text string without any further structure
--- @cons HStruct t as hs - a structure with a tag, attributes, and
--- HTML expressions inside the structure
data StaticHtml =
HText String
| HStruct String Attrs [StaticHtml]
deriving (Eq, Read, Show)
--- The type of static HTML expressions is an instance of class `HTML`.
instance HTML StaticHtml where
htmlText = HText
htmlStruct = HStruct
updAttrs = updStaticAttrs
fromHtmlText (HText s) = Just s
fromHtmlText (HStruct _ _ _) = Nothing
fromHtmlStruct (HText _) = Nothing
fromHtmlStruct (HStruct t ats hs) = Just (t,ats,hs)
--- Updates the attributes in a basic HTML expression.
updStaticAttrs :: (Attrs -> Attrs) -> StaticHtml -> StaticHtml
updStaticAttrs _ (HText s) = HText s
updStaticAttrs f (HStruct tag attrs hexps) = HStruct tag (f attrs) hexps
--- Transforms a `StaticHtml` expression into a generic HTML expression.
fromStaticHtml :: HTML h => StaticHtml -> h
fromStaticHtml (HText s) = htmlText s
fromStaticHtml (HStruct t attrs hs) = htmlStruct t attrs (map fromStaticHtml hs)
--- Transforms a `BaseHtml` expression into a `StaticHtml` expression
--- provided that `BaseAction` constructors do not occur (otherwise,
--- an error is raised).
toStaticHtml :: BaseHtml -> StaticHtml
toStaticHtml (BaseText s) = HText s
toStaticHtml (BaseStruct t atts hs) = HStruct t atts (map toStaticHtml hs)
toStaticHtml (BaseAction _) =
error "HTML.Base.toStaticHtml: BaseAction occurred in base HTML expression"
------------------------------------------------------------------------------
-- CGI references and environments.
--- The (abstract) data type for representing references to input elements
--- in HTML forms.
data HtmlRef = HtmlRef String
--- Internal identifier of a HtmlRef (intended only for internal use in other
--- libraries!).
idOfHtmlRef :: HtmlRef -> String
idOfHtmlRef (HtmlRef i) = i
--- The type for representing cgi environments, i.e., mappings
--- from cgi references to the corresponding values of the input elements.
type HtmlEnv = HtmlRef -> String
--- The type of event handlers occurring in HTML forms.
type HtmlHandler = HtmlEnv -> IO HtmlPage
------------------------------------------------------------------------------
--- The data type for representing HTML expressions with input elements,
--- i.e., all elements which might occur inside a form.
--- @cons HtmlText s - a text string without any further structure
--- @cons HtmlStruct t as hs - a structure with a tag, attributes, and
--- HTML expressions inside the structure
--- @cons HtmlInput ref h - an input element (described by the second
--- argument) with a cgi reference
--- @cons HtmlEvent h ref hdlr - an input element (first arg) identified
--- by a cgi reference with an associated
--- event handler (typically, a submit button)
--- @cons HtmlAction act - an action that computes an HTML expression
--- which will be inserted when the HTML document
--- is shown (used to implement form expressions)
data HtmlExp =
HtmlText String
| HtmlStruct String Attrs [HtmlExp]
| HtmlAction (IO HtmlExp)
| HtmlInput HtmlRef HtmlExp
| HtmlEvent HtmlRef HtmlHandler HtmlExp
--- Updates the attributes in an HTML expression.
updHtmlAttrs :: (Attrs -> Attrs) -> HtmlExp -> HtmlExp
updHtmlAttrs _ (HtmlText s) = HtmlText s
updHtmlAttrs f (HtmlStruct tag attrs hexps) = HtmlStruct tag (f attrs) hexps
updHtmlAttrs f (HtmlEvent ref handler he) =
HtmlEvent ref handler (updHtmlAttrs f he)
updHtmlAttrs f (HtmlInput ref he) = HtmlInput ref (updHtmlAttrs f he)
updHtmlAttrs _ (HtmlAction act) = HtmlAction act
--- Transforms a static into a dynamic HTML document.
toHtmlExp :: BaseHtml -> HtmlExp
toHtmlExp (BaseText s) = HtmlText s
toHtmlExp (BaseStruct t ps hs) = HtmlStruct t ps (map toHtmlExp hs)
toHtmlExp (BaseAction a) = HtmlAction a
--- Transforms a dynamic HTML into a static one by dropping references
--- and event handlers.
fromHtmlExp :: HtmlExp -> BaseHtml
fromHtmlExp (HtmlText s) = BaseText s
fromHtmlExp (HtmlStruct t ps hs) = BaseStruct t ps (map fromHtmlExp hs)
fromHtmlExp (HtmlAction a) = BaseAction a
fromHtmlExp (HtmlEvent _ _ hs) = fromHtmlExp hs
fromHtmlExp (HtmlInput _ hs) = fromHtmlExp hs
--- The type of HTML expressions is an instance of class `HTML`.
instance HTML HtmlExp where
htmlText = HtmlText
htmlStruct = HtmlStruct
updAttrs = updHtmlAttrs
fromHtmlText (HtmlText s) = Just s
fromHtmlText (HtmlStruct _ _ _) = Nothing
fromHtmlText (HtmlAction _) = Nothing
fromHtmlText (HtmlEvent _ _ _) = Nothing
fromHtmlText (HtmlInput _ _) = Nothing
fromHtmlStruct (HtmlText _) = Nothing
fromHtmlStruct (HtmlStruct t ats hs) = Just (t,ats,hs)
fromHtmlStruct (HtmlAction _) = Nothing
fromHtmlStruct (HtmlEvent _ _ _) = Nothing
fromHtmlStruct (HtmlInput _ _) = Nothing
------------------------------------------------------------------------------
--- Extracts the textual contents of a list of HTML expressions.
--- For instance,
---
--- textOf [BaseText "xy", BaseStruct "a" [] [BaseText "bc"]] == "xy bc"
---
textOf :: HTML h => [h] -> String
textOf = unwords . filter (not . null) . map textOfHtmlElem
where
textOfHtmlElem he =
maybe (maybe ""
(\ (_,_,hs) -> textOf hs)
(fromHtmlStruct he))
id
(fromHtmlText he)
------------------------------------------------------------------------------
-- HTML forms.
--- The type `FormReader` is a monad with operations to read data
--- to invoke an HTML form.
--- It is assumed that a `FormReader` action reads only data and does not
--- change the environment, since the action is applied twice
--- when executing a form.
--- A typical action of this kind is `HTML.Session.getSessionData`.
---
--- The `FormReader` type encapsulates IO actions in order to enforce
--- the correct use of forms.
data FormReader a = FormReader (IO a)
--- Transforms a `FormReader` action into a standard IO action.
fromFormReader :: FormReader a -> IO a
fromFormReader (FormReader a) = a
--- Transforms an IO action into a `FormReader` action.
--- This operation should be used with care since it must be
--- ensured that the action only reads data and does not
--- change the environment, since the action is applied twice
--- when executing a form.
toFormReader :: IO a -> FormReader a
toFormReader = FormReader
instance Functor FormReader where
fmap f (FormReader x) = FormReader (fmap f x)
instance Applicative FormReader where
pure x = FormReader (return x)
f <*> v = f >>= \f' -> fmap f' v
instance Monad FormReader where
return = pure
a >>= f = FormReader (fromFormReader a >>= \x -> fromFormReader (f x))
--- The data type for representing HTML forms embedded into HTML pages.
---
--- A form definition consists of a unique identifier of form (usually,
--- the qualified name of the operation defining the form),
--- a `FormReader` action and a mapping from data
--- into an HTML expression (which usually contains event handlers
--- to produce the form answers).
data HtmlFormDef a = HtmlFormDef String (FormReader a) (a -> [HtmlExp])
--- A definition of a simple form which does not require session data.
---
--- The unique identifier required for the implementation of forms
--- is added by the `curry2cgi` translator.
simpleFormDef :: [HtmlExp] -> HtmlFormDef ()
simpleFormDef hexps = HtmlFormDef "" (return ()) (const hexps)
--- A definition of a simple form, which does not require session data,
--- with a unique identifier (usually, the qualified name of the
--- operation defining the form).
simpleFormDefWithID :: String -> [HtmlExp] -> HtmlFormDef ()
simpleFormDefWithID fid hexps = HtmlFormDef fid (return ()) (const hexps)
--- A definition of a form which consists of a `FormReader` action
--- and a mapping from data into an HTML expression
--- (which usually contains event handlers to produce the form answers).
--- It is assumed that the `FormReader` action reads only data and does not
--- change it, since it is applied twice when executing a form.
---
--- The unique identifier required for the implementation of forms
--- is added by the `curry2cgi` translator.
formDef :: FormReader a -> (a -> [HtmlExp]) -> HtmlFormDef a
formDef = HtmlFormDef ""
--- A definition of a form with a unique identifier (usually,
--- the qualified name of the operation defining the form).
--- A form contains a `FormReader` action and a mapping from data
--- into an HTML expression (which usually contains event handlers
--- to produce the form answers).
--- It is assumed that the `FormReader` action reads only data and does not
--- change it, since it is applied twice when executing a form.
formDefWithID :: String -> FormReader a -> (a -> [HtmlExp]) -> HtmlFormDef a
formDefWithID = HtmlFormDef
--- Returns the identifier of a form definition.
formDefId :: HtmlFormDef a -> String
formDefId (HtmlFormDef s _ _) = s
--- Sets the identifier of a form definition.
--- Only intended for internal use in the `curry2cgi` translator.
setFormDefId :: String -> HtmlFormDef a -> HtmlFormDef a
setFormDefId fid (HtmlFormDef _ readact formgen) =
HtmlFormDef fid readact formgen
--- Returns the `FormReader` action of a form definition.
formDefRead :: HtmlFormDef a -> IO a
formDefRead (HtmlFormDef _ ra _) = fromFormReader ra
--- Returns the view operation of a form definition.
formDefView :: HtmlFormDef a -> (a -> [HtmlExp])
formDefView (HtmlFormDef _ _ v) = v
-- Auxiliary operations for executing forms.
--- Computes the initial form of a form definition.
genInitForm :: HtmlFormDef a -> IO [HtmlExp]
genInitForm (HtmlFormDef _ readact formgen) =
fromFormReader readact >>= return . formgen
--- Instantiates all HtmlRefs with a unique tag in HTML expressions.
--- Only internally used.
--- Parameters: HTML expressions, number for cgi-refs
--- Result: translated HTML expressions, new number for cgi-refs
instHtmlRefs :: [HtmlExp] -> Int -> ([HtmlExp],Int)
instHtmlRefs [] i = ([],i)
instHtmlRefs (HtmlText s : hexps) i =
case instHtmlRefs hexps i of
(nhexps,j) -> (HtmlText s : nhexps, j)
instHtmlRefs (HtmlStruct tag attrs hexps1 : hexps2) i =
case instHtmlRefs hexps1 i of
(nhexps1,j) -> case instHtmlRefs hexps2 j of
(nhexps2,k) -> (HtmlStruct tag attrs nhexps1 : nhexps2, k)
instHtmlRefs (HtmlEvent cgiref handler (HtmlStruct tag attrs hes) : hexps) i
| idOfHtmlRef cgiref =:= ("FIELD_" ++ show i)
= case instHtmlRefs hexps (i+1) of
(nhexps,j) ->
(HtmlEvent cgiref handler (HtmlStruct tag attrs hes) : nhexps, j)
instHtmlRefs (HtmlInput cgiref hexp : hexps) i
| idOfHtmlRef cgiref =:= ("FIELD_" ++ show i)
= case instHtmlRefs [hexp] (i+1) of
([nhexp],j) -> case instHtmlRefs hexps j of
(nhexps,k) -> (nhexp : nhexps, k)
instHtmlRefs (HtmlAction _ : _) _ =
error "HTML.Base.instHtmlRefs: HtmlAction occurred"
------------------------------------------------------------------------------
--- The data type for representing HTML pages. Since the HTML document
--- shown in this page is a base HTML expression, it is ensured that
--- input elements and event handlers occur only in embedded forms.
--- @cons HtmlPage t ps hs - an HTML page with title t, optional parameters
--- (e.g., cookies) ps, and contents hs
--- @cons HtmlAnswer t c - an answer in an arbitrary format where t
--- is the content type (e.g., "text/plain") and c is the contents
data HtmlPage = HtmlPage String [PageParam] [BaseHtml]
| HtmlAnswer String String
--- The possible parameters of an HTML page.
--- The parameters of a cookie (`PageCookie`) are its name and value and
--- optional parameters (expiration date, domain, path (e.g., the path "/"
--- makes the cookie valid for all documents on the server), security) which
--- are collected in a list.
--- @cons PageEnc - the encoding scheme of this page
--- @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 HttpHeader key value - additional HTTP header included in this page
--- @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
--- @cons PageHeadInclude he - HTML expression to be included in page header
--- @cons PageBodyAttr attr - optional attribute for the body element of the
--- page (more than one occurrence is allowed)
data PageParam = PageEnc String
| PageCookie String String [CookieParam]
| PageCSS String
| HttpHeader String String
| PageJScript String
| PageMeta [(String,String)]
| PageLink [(String,String)]
| PageHeadInclude BaseHtml
| PageBodyAttr (String,String)
--- An encoding scheme for a HTML page.
pageEnc :: String -> PageParam
pageEnc = PageEnc
--- A cookie to be sent to the client's browser when a HTML page is
--- requested.
pageCookie :: (String,String) -> PageParam
pageCookie (n,v) = PageCookie n v []
--- A URL for a CSS file for a HTML page.
pageCSS :: String -> PageParam
pageCSS = PageCSS
--- A header to be sent to the client's browser when a HTML page is
--- requested.
httpHeader :: String -> String -> PageParam
httpHeader = HttpHeader
--- 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
pageMetaInfo = PageMeta
--- Link information for a HTML page. The argument is a list of
--- attributes included in the `link`-tag in the header for this page.
pageLinkInfo :: [(String,String)] -> PageParam
pageLinkInfo = PageLink
--- Optional attribute for the body element of the web page.
--- More than one occurrence is allowed, i.e., all such attributes are
--- collected.
pageBodyAttr :: (String,String) -> PageParam
pageBodyAttr = PageBodyAttr
--- A basic HTML web page with the default encoding.
--- @param title - the title of the page
--- @param hexps - the page's body (list of HTML expressions)
--- @return an HTML page
page :: String -> [BaseHtml] -> HtmlPage
page title hexps = HtmlPage title [PageEnc defaultEncoding] hexps
--- A standard HTML web page where the title is included
--- in the body as the first header.
--- @param title - the title of the page
--- @param hexps - the page's body (list of HTML expressions)
--- @return an HTML page with the title as the first header
headerPage :: String -> [BaseHtml] -> HtmlPage
headerPage title hexps = page title (h1 [htxt title] : hexps)
--- Adds a parameter to an HTML page.
--- @param page - a page
--- @param param - a page's parameter
--- @return an HTML page
addPageParam :: HtmlPage -> PageParam -> HtmlPage
addPageParam (HtmlPage title params hexps) param =
HtmlPage title (param:params) hexps
addPageParam hexp@(HtmlAnswer _ _) _ = hexp
--- Adds a list of HTML expressions to the body of an HTML page.
--- @param page - a page
--- @param hexps - HTML expressions added at the end of the page's body
--- @return an HTML page
addPageBody :: HtmlPage -> [BaseHtml] -> HtmlPage
addPageBody (HtmlPage title params hexps) morehexps =
HtmlPage title params (hexps ++ morehexps)
addPageBody hpage@(HtmlAnswer _ _) _ = hpage
--- Adds simple cookie to an HTML page.
--- The cookies are sent to the client's browser together with this page.
--- @param cs - the cookies as a list of name/value pairs
--- @param form - the form to add cookies to
--- @return a new HTML page
addCookies :: [(String,String)] -> HtmlPage -> HtmlPage
addCookies cs (HtmlPage title params hexps) =
HtmlPage title (map pageCookie cs ++ params) hexps
addCookies _ (HtmlAnswer _ _) =
error "addCookies: cannot add cookie to HTML answer"
--- Adds a HTTP header to a HTML page.
--- Headers are sent to the client's browser together with the page.
--- @param key - the name of the HTTP header field
--- @param value - the value of the HTTP header field
--- @param page - the page to which the header is added
--- @return a new HTML page
addHttpHeader :: String -> String -> HtmlPage -> HtmlPage
addHttpHeader key value (HtmlPage t fas hs) =
HtmlPage t (HttpHeader key value : fas) hs
addHttpHeader _ _ (HtmlAnswer _ _) =
error "addHttpHeader: cannot add HTTP header to HTML answer"
------------------------------------------------------------------------------
--- The possible parameters of a cookie.
data CookieParam = CookieExpire ClockTime
| CookieDomain String
| CookiePath String
| CookieSecure
-- Shows the cookie in standard syntax:
formatCookie :: (String,String,[CookieParam]) -> String
formatCookie (name,value,params) =
"Set-Cookie: " ++ name ++ "=" ++ string2urlencoded value ++
concatMap (\p -> "; " ++ formatCookieParam p) params
-- Formats a cookie parameter:
formatCookieParam :: CookieParam -> String
formatCookieParam (CookieExpire e) = "expires=" ++ toCookieDateString e
formatCookieParam (CookieDomain d) = "domain=" ++ d
formatCookieParam (CookiePath p) = "path=" ++ p
formatCookieParam CookieSecure = "secure"
-- Formats a clock time into a date string for cookies:
toCookieDateString :: ClockTime -> String
toCookieDateString time =
let (CalendarTime y mo d h mi s tz) = toUTCTime time
in (show d ++ "-" ++ shortMonths!!(mo-1) ++ "-" ++ show y ++ " " ++
toTimeString (CalendarTime y mo d h mi s tz) ++ " UTC")
where shortMonths = ["Jan","Feb","Mar","Apr","May","Jun",
"Jul","Aug","Sep","Oct","Nov","Dec"]
--- A textual result instead of an HTML page as a result for active web pages.
--- @param txt - the contents of the result page
--- @return an HTML answer page
answerText :: String -> HtmlPage
answerText = HtmlAnswer "text/plain"
--- A textual result instead of an HTML page as a result for active web pages
--- where the encoding is given as the first parameter.
--- @param enc - the encoding of the text(e.g., "utf-8" or "iso-8859-1")
--- @param txt - the contents of the result page
--- @return an HTML answer page
answerEncText :: String -> String -> HtmlPage
answerEncText enc = HtmlAnswer ("text/plain; charset=" ++ enc)
--- Generates a redirection page to a given URL.
--- This is implemented via the HTTP response header `Location` (see also
--- <https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Location>).
--- @param url - The URL target of the redirection
--- @param page - The redirection page
redirectPage :: String -> HtmlPage
redirectPage url = addHttpHeader "Location" url $ page "Redirect" []
--- Adds expire time to given HTML page.
--- @param secs - Number of seconds before document expires
--- @param page - The page to add the header information to
expires :: Int -> HtmlPage -> HtmlPage
expires secs hpage =
hpage `addPageParam`
PageHeadInclude (BaseStruct "meta" [("http-equiv","expires"),
("content",show secs)] [])
------------------------------------------------------------------------------
-- some useful abbreviations:
--- An empty HTML expression.
hempty :: HTML h => h
hempty = htmlText ""
--- Non breaking Space
nbsp :: HTML h => h
nbsp = htmlText " "
--- Header 1
h1 :: HTML h => [h] -> h
h1 = hStruct "h1"
--- Header 2
h2 :: HTML h => [h] -> h
h2 = hStruct "h2"
--- Header 3
h3 :: HTML h => [h] -> h
h3 = hStruct "h3"
--- Header 4
h4 :: HTML h => [h] -> h
h4 = hStruct "h4"
--- Header 5
h5 :: HTML h => [h] -> h
h5 = hStruct "h5"
--- Header 6
h6 :: HTML h => [h] -> h
h6 = hStruct "h6"
--- Paragraph
par :: HTML h => [h] -> h
par = hStruct "p"
--- Section
section :: HTML h => [h] -> h
section = hStruct "section"
--- Header
header :: HTML h => [h] -> h
header = hStruct "header"
--- Footer
footer :: HTML h => [h] -> h
footer = hStruct "footer"
--- Emphasize
emphasize :: HTML h => [h] -> h
emphasize = hStruct "em"
--- Strong (more emphasized) text.
strong :: HTML h => [h] -> h
strong = hStruct "strong"
--- Boldface
bold :: HTML h => [h] -> h
bold = hStruct "b"
--- Italic
italic :: HTML h => [h] -> h
italic = hStruct "i"
--- Navigation
nav :: HTML h => [h] -> h
nav = hStruct "nav"
--- Program code
code :: HTML h => [h] -> h
code = hStruct "code"
--- Centered text
center :: HTML h => [h] -> h
center = hStruct "center"
--- Blinking text
blink :: HTML h => [h] -> h
blink = hStruct "blink"
--- Teletype font
teletype :: HTML h => [h] -> h
teletype = hStruct "tt"
--- Unformatted input, i.e., keep spaces and line breaks and
--- don't quote special characters.
pre :: HTML h => [h] -> h
pre = hStruct "pre"
--- Verbatim (unformatted), special characters (<,>,&,")
--- are quoted.
verbatim :: HTML h => String -> h
verbatim s = hStruct "pre" [htmlText (htmlQuote s)]
--- Address
address :: HTML h => [h] -> h
address = hStruct "address"
--- Hypertext reference
href :: HTML h => String -> [h] -> h
href ref = htmlStruct "a" [("href",ref)]
--- An anchored text with a hypertext reference inside a document.
anchor :: HTML h => String -> [h] -> h
anchor anc = htmlStruct "span" [("id",anc)]
--- Unordered list.
--- @param items - the list items where each item is a list of HTML expressions
ulist :: HTML h => [[h]] -> h
ulist items = hStruct "ul" (map litem items)
--- An unordered list with classes for the entire list and the list elements.
--- The class annotation will be ignored if it is empty.
--- @param listclass - the class for the entire list structure
--- @param itemclass - the class for the list items
--- @param items - the list items where each item is a list of HTML expressions
ulistWithClass :: HTML h => String -> String -> [[h]] -> h
ulistWithClass listclass itemclass items =
hStruct "ul" (map litemWC items) `addClass` listclass
where
litemWC i = litem i `addClass` itemclass
--- An unordered list with classes for the entire list
--- individual classes for the list elements.
--- The class annotation will be ignored if it is empty.
--- @param listclass - the class for the entire list structure
--- @param classitems - the list items together with their classes
ulistWithItemClass :: HTML h => String -> [(String,[h])] -> h
ulistWithItemClass listclass classeditems =
hStruct "ul" (map litemWC classeditems) `addClass` listclass
where
litemWC (c,i) = litem i `addClass` c
--- Ordered list.
--- @param items - the list items where each item is a list of HTML expressions
olist :: HTML h => [[h]] -> h
olist items = hStruct "ol" (map litem items)
--- An ordered list with classes for the entire list and the list elements.
--- The class annotation will be ignored if it is empty.
--- @param listclass - the class for the entire list structure
--- @param itemclass - the class for the list items
--- @param items - the list items where each item is a list of HTML expressions
olistWithClass :: HTML h => String -> String -> [[h]] -> h
olistWithClass listclass itemclass items =
hStruct "ol" (map litemWC items) `addClass` listclass
where
litemWC i = litem i `addClass` itemclass
--- An ordered list with classes for the entire list
--- individual classes for the list elements.
--- The class annotation will be ignored if it is empty.
--- @param listclass - the class for the entire list structure
--- @param classitems - the list items together with their classes
olistWithItemClass :: HTML h => String -> [(String,[h])] -> h
olistWithItemClass listclass classeditems =
hStruct "ol" (map litemWC classeditems) `addClass` listclass
where
litemWC (c,i) = litem i `addClass` c
--- A single list item (usually not explicitly used)
litem :: HTML h => [h] -> h
litem = hStruct "li"
--- Description list
--- @param items - a list of (title/description) pairs (of HTML expressions)
dlist :: HTML h => [([h],[h])] -> h
dlist items = hStruct "dl" (concatMap ditem items)
where
ditem (hexps1,hexps2) = [htmlStruct "dt" [] hexps1,
htmlStruct "dd" [] hexps2]
--- Table with a matrix of items where each item is a list of HTML expressions.
table :: HTML h => [[[h]]] -> h
table = hStruct "table" . map (\row -> hStruct "tr" (map (hStruct "td") row))
--- Table with a matrix of items (each item is a list of HTML expressions)
--- with classes for the entire table, each row, and each data element.
--- The class annotation will be ignored if it is empty.
--- @param tableclass - the class for the entire table structure
--- @param rowclass - the class for the table rows
--- @param dataclass - the class for the table data items
--- @param items - the matrix of table items where each item is a
--- list of HTML expressions
tableWithClass :: HTML h => String -> String -> String -> [[[h]]] -> h
tableWithClass tableclass rowclass dataclass items =
hStruct "table"
(map (\row -> hStruct "tr"
(map (\d -> hStruct "td" d `addClass` dataclass) row)
`addClass` rowclass)
items) `addClass` tableclass
--- Similar to `table` but introduces header tags for the first row.
headedTable :: HTML h => [[[h]]] -> h
headedTable = hStruct "table" . headedItems
where
headedItems [] = []
headedItems (row:rows) = hStruct "tr" (map (hStruct "th") row) :
map (\r -> hStruct "tr" (map (hStruct "td") r)) rows
--- Horizontal rule
hrule :: HTML h => h
hrule = hStruct "hr" []
--- Break a line
breakline :: HTML h => h
breakline = hStruct "br" []
--- Image
--- @param src - the URL of the image
--- @param alt - the alternative text shown instead of the image
image :: HTML h => String -> String -> h
image src alt = htmlStruct "img" [("src",src),("alt",htmlQuote alt)] []
-------------- styles and document structuring:
--- Defines a style sheet to be used in this HTML document.
--- @param css - a string in CSS format
styleSheet :: HTML h => String -> h
styleSheet css = htmlStruct "style" [("type","text/css")] [htmlText css]
--- Provides a style for HTML elements.
--- The style argument is the name of a style class defined in a
--- style definition (see `styleSheet`) or in an external
--- style sheet (see form and page parameters `FormCSS` and `PageCSS`).
--- @param st - name of a style class
--- @param hexps - list of HTML expressions
style :: HTML h => String -> [h] -> h
style st = htmlStruct "span" [("class",st)]
--- Provides a style for a basic text.
--- The style argument is the name of a style class defined in an
--- external style sheet.
--- @param st - name of a style class
--- @param txt - a string (special characters will be quoted)
textstyle :: HTML h => String -> String -> h
textstyle st txt = htmlStruct "span" [("class",st)] [htxt txt]
--- Provides a style for a block of HTML elements.
--- The style argument is the name of a style class defined in an
--- external style sheet. This element is used (in contrast to "style")
--- for larger blocks of HTML elements since a line break is placed
--- before and after these elements.
--- @param st - name of a style class
--- @param hexps - list of HTML expressions
blockstyle :: HTML h => String -> [h] -> h
blockstyle st = htmlStruct "div" [("class",st)]
--- Joins a list of HTML elements into a single HTML element.
--- Although this construction has no rendering, it is sometimes useful
--- for programming when several HTML elements must be put together.
--- @param hexps - list of HTML expressions
inline :: HTML h => [h] -> h
inline = hStruct "span"
--- Joins a list of HTML elements into a block.
--- A line break is placed before and after these elements.
--- @param hexps - list of HTML expressions
block :: HTML h => [h] -> h
block = hStruct "div"
--- A hidden field to pass a value referenced by a fixed name.
--- This function should be used with care since it may cause
--- conflicts with the CGI-based implementation of this library.
hiddenField :: HTML h => String -> String -> h
hiddenField name value =
htmlStruct "input" [("type","hidden"),("name",name),("value",value)] []
------------------------------------------------------------------------------
-- Forms and input fields:
--- A form embedded in an HTML expression.
--- The parameter is a form defined as an exported top-level operation
--- in the CGI program so that it can be accessed by the main program.
--- The URL of the generated form is the same as the main page, i.e.,
--- the current URL parameter is passed to the form (which is
--- useful for REST-based programming with URL parameters).
--- The form uses a hidden field named `FORMID` to identify the form
--- in the submitted form controller.
---
--- Since form elements can not be nested, see
--- [HTML](https://html.spec.whatwg.org/multipage/forms.html#the-form-element),
--- the form element itself is a static HTML expression.
formElem :: HtmlFormDef a -> BaseHtml
formElem formspec = formElemWithAttrs formspec []
--- A form element (see 'formElem') where some attributes are added
--- to the resulting HTML `form` structure.
--- The attributes must be different from the standard form
--- attributes `method` and `action`.
formElemWithAttrs :: HtmlFormDef a -> Attrs -> BaseHtml
formElemWithAttrs formspec attrs = BaseAction formAction
where
formAction = do
urlparam <- getUrlParameter
he <- genInitForm formspec
return $
HtmlStruct "form"
([("method", "post"), ("action", '?' : urlparam)] ++ attrs)
(hiddenField "FORMID" (formDefId formspec) : fst (instHtmlRefs he 0))
--- A button to submit a form with a label string and an event handler.
button :: String -> HtmlHandler -> HtmlExp
button label handler
| cref =:= HtmlRef ref -- instantiate cref argument
= HtmlEvent cref handler
(HtmlStruct "input" [("type","submit"), ("name",ref),
("value",htmlQuote label)] [])
where
cref,ref free
--- Reset button with a label string
resetButton :: String -> HtmlExp
resetButton label =
HtmlStruct "input" [("type","reset"),("value",htmlQuote label)] []
--- Submit button in form of an imag.
--- @param src - url of the image
--- @param handler - event handler
imageButton :: String -> HtmlHandler -> HtmlExp
imageButton src handler
| cref =:= HtmlRef ref -- instantiate cref argument
= HtmlEvent cref handler
(HtmlStruct "input" [("type","image"),("name",ref),("src",src)] [])
where
cref,ref free
--- Input text field with a reference and an initial contents
textField :: HtmlRef -> String -> HtmlExp
textField cref contents
| cref =:= HtmlRef ref -- instantiate cref argument
= HtmlInput cref
(HtmlStruct "input" [("type","text"),("name",ref),
("value",htmlQuote contents)] [])
where ref free
--- Input text field (where the entered text is obscured) with a reference
password :: HtmlRef -> HtmlExp
password cref
| cref =:= HtmlRef ref -- instantiate cref argument
= HtmlInput cref
(HtmlStruct "input" [("type","password"),("name",ref)] [])
where
ref free
--- Input text area with a reference, height/width, and initial contents
textArea :: HtmlRef -> (Int,Int) -> String -> HtmlExp
textArea cref (height,width) contents
| cref =:= HtmlRef ref -- instantiate cref argument
= HtmlInput cref
(HtmlStruct "textarea" [("name",ref),
("rows",show height),("cols",show width)]
[htxt contents])
where
ref free
--- A checkbox with a reference and a value.
--- The value is returned if checkbox is on, otherwise "" is returned.
checkBox :: HtmlRef -> String -> HtmlExp
checkBox cref value
| cref =:= HtmlRef ref -- instantiate cref argument
= HtmlInput cref
(HtmlStruct "input" [("type","checkbox"),("name",ref),
("value",htmlQuote value)] [])
where
ref free
--- A checkbox that is initially checked with a reference and a value.
--- The value is returned if checkbox is on, otherwise "" is returned.
checkedBox :: HtmlRef -> String -> HtmlExp
checkedBox cref value
| cref =:= HtmlRef ref -- instantiate cref argument
= HtmlInput cref
(HtmlStruct "input" [("type","checkbox"),("name",ref),
("value",htmlQuote value),("checked","checked")] [])
where
ref free
--- A main button of a radio (initially "on") with a reference and a value.
--- The value is returned of this button is on.
--- A complete radio button suite always consists of a main button
--- (radio_main) and some further buttons (radio_others) with the
--- same reference. Initially, the main button is selected
--- (or nothing is selected if one uses radio_main_off instead of radio_main).
--- The user can select another button but always at most one button
--- of the radio can be selected. The value corresponding to the
--- selected button is returned in the environment for this radio reference.
radioMain :: HtmlRef -> String -> HtmlExp
radioMain cref value
| cref =:= HtmlRef ref -- instantiate cref argument
= HtmlInput cref
(HtmlStruct "input" [("type","radio"),("name",ref),
("value",htmlQuote value),("checked","yes")] [])
where
ref free
--- A main button of a radio (initially "off") with a reference and a value.
--- The value is returned of this button is on.
radioMainOff :: HtmlRef -> String -> HtmlExp
radioMainOff cref value
| cref =:= HtmlRef ref -- instantiate cref argument
= HtmlInput cref
(HtmlStruct "input" [("type","radio"),("name",ref),
("value",htmlQuote value)] [])
where
ref free
--- A further button of a radio (initially "off") with a reference (identical
--- to the main button of this radio) and a value.
--- The value is returned of this button is on.
radioOther :: HtmlRef -> String -> HtmlExp
radioOther cref value
| cref =:= HtmlRef ref -- instantiate cref argument
= HtmlStruct "input"
[("type","radio"),("name",ref),("value",htmlQuote value)] []
where
ref free
--- A selection button with a reference and a list of name/value pairs.
--- The names are shown in the selection and the value is returned
--- for the selected name.
selection :: HtmlRef -> [(String,String)] -> HtmlExp
selection cref menue
| cref =:= HtmlRef ref -- instantiate cref argument
= HtmlInput cref
(HtmlStruct "select" [("name",ref)]
((concat . map (\(n,v)->[HtmlStruct "option" [("value",v)] [htxt n]]))
menue))
where
ref free
--- A selection button with a reference, a list of name/value pairs,
--- and a preselected item in this list.
--- The names are shown in the selection and the value is returned
--- for the selected name.
--- @param ref - a CGI reference
--- @param nvs - list of name/value pairs
--- @param sel - the index of the initially selected item in the list nvs
--- @return an HTML expression representing the selection button
selectionInitial :: HtmlRef -> [(String,String)] -> Int -> HtmlExp
selectionInitial cref sellist sel
| cref =:= HtmlRef ref -- instantiate cref argument
= HtmlInput cref (HtmlStruct "select" [("name",ref)] (selOption sellist sel))
where
ref free
selOption [] _ = []
selOption ((n,v):nvs) i =
HtmlStruct "option"
([("value",v)] ++ if i==0 then [("selected","selected")] else [])
[htxt n] : selOption nvs (i-1)
--- A selection button with a reference and a list of name/value/flag pairs.
--- The names are shown in the selection and the value is returned
--- if the corresponding name is selected. If flag is True, the
--- corresonding name is initially selected. If more than one name
--- has been selected, all values are returned in one string
--- where the values are separated by newline (`'\n'`) characters.
multipleSelection :: HtmlRef -> [(String,String,Bool)] -> HtmlExp
multipleSelection cref sellist
| cref =:= HtmlRef ref -- instantiate cref argument
= HtmlInput cref
(HtmlStruct "select" [("name",ref),("multiple","multiple")]
(map selOption sellist))
where
ref free
selOption (n,v,flag) =
HtmlStruct "option"
([("value",v)] ++ if flag then [("selected","selected")] else [])
[htxt n]
------------------------------------------------------------------------------
--- Quotes special characters (`<`,`>`,`&`,`"`, umlauts) in a string
--- as HTML special characters.
htmlQuote :: String -> String
htmlQuote [] = []
htmlQuote (c:cs) | c=='<' = "<" ++ htmlQuote cs
| c=='>' = ">" ++ htmlQuote cs
| c=='&' = "&" ++ htmlQuote cs
| c=='"' = """ ++ htmlQuote cs
| otherwise = htmlIsoUmlauts [c] ++ htmlQuote cs
--- Translates umlauts in iso-8859-1 encoding into HTML special characters.
htmlIsoUmlauts :: String -> String
htmlIsoUmlauts [] = []
htmlIsoUmlauts (c:cs) | oc==228 = "ä" ++ htmlIsoUmlauts cs
| oc==246 = "ö" ++ htmlIsoUmlauts cs
| oc==252 = "ü" ++ htmlIsoUmlauts cs
| oc==196 = "Ä" ++ htmlIsoUmlauts cs
| oc==214 = "Ö" ++ htmlIsoUmlauts cs
| oc==220 = "Ü" ++ htmlIsoUmlauts cs
| oc==223 = "ß" ++ htmlIsoUmlauts cs
| oc==197 = "Å" ++ htmlIsoUmlauts cs
| oc==250 = "ú"++ htmlIsoUmlauts cs
| oc==237 = "í"++ htmlIsoUmlauts cs
| oc==225 = "á"++ htmlIsoUmlauts cs
| otherwise = c : htmlIsoUmlauts cs
where oc = ord c
------------------------------------------------------------------------------
--- Adds an attribute (name/value pair) to an HTML element.
addAttr :: HTML h => h -> (String,String) -> h
addAttr hexp attr = addAttrs hexp [attr]
--- Adds a list of attributes (name/value pair) to an HTML element.
addAttrs :: HTML h => h -> Attrs -> h
addAttrs h newattrs = updAttrs (++newattrs) h
--- Adds a class attribute to an HTML element
--- (if the class attribute is not empty).
addClass :: HTML h => h -> String -> h
addClass hexp cls | null cls = hexp
| otherwise = addAttr hexp ("class",cls)
------------------------------------------------------------------------------
--- Transforms a list of static HTML expressions into its
--- string representation (in the standard HTML syntax).
--- Only included for compatibility.
showStaticHtmls :: [StaticHtml] -> String
showStaticHtmls = showHtmls
--- Transforms a list of basic HTML expressions into its
--- string representation (in the standard HTML syntax).
--- Only included for compatibility.
showBaseHtmls :: [BaseHtml] -> String
showBaseHtmls = showHtmls
--- Transforms a list of HTML expressions into its
--- string representation (in the standard HTML syntax).
showHtmls :: HTML h => [h] -> String
showHtmls hexps = showsHtmls 0 hexps ""
-- is this a tag where a line break can be safely added?
tagWithLn :: String -> Bool
tagWithLn t = t/="" &&
t `elem` ["br","p","li","ul","ol","dl","dt","dd","hr",
"h1","h2","h3","h4","h5","h6","div",
"html","title","head","body","link","meta","script",
"form","table","tr","td"]
--- Transforms a single HTML expression into string representation.
showHtml :: HTML h => h -> String
showHtml hexp = showsHtml 0 hexp ""
--- HTML tags that have no end tag in HTML:
noEndTags :: [String]
noEndTags = ["img","input","link","meta"]
showsHtml :: HTML h => Int -> h -> ShowS
showsHtml i hexp =
maybe (maybe (error "HTML.Base.showsHtml: illegal action/event occurred")
showsHtmlStruct
(fromHtmlStruct hexp))
showString
(fromHtmlText hexp)
where
showsHtmlStruct (tag, attrs, hexps) =
let maybeLn j = if tagWithLn tag then nl . showTab j else id
in maybeLn i .
(if null hexps && (null attrs || tag `elem` noEndTags)
then showsHtmlOpenTag tag attrs "/>"
else showsHtmlOpenTag tag attrs ">" . maybeLn (i+2) . showExps hexps .
maybeLn i . showString "</" . showString tag . showChar '>'
) . maybeLn i
where
showExps = if tag=="pre"
then concatS . map (showsHtml 0)
else showsHtmls (i+2)
showsHtmls :: HTML h => Int -> [h] -> ShowS
showsHtmls _ [] = id
showsHtmls i (he:hes) = showsWithLnPrefix he . showsHtmls i hes
where
showsWithLnPrefix hexp = let s = maybe "" id (fromHtmlText hexp)
in if s /= "" && isSpace (head s)
then nl . showTab i . showString (tail s)
else showsHtml i hexp
showTab :: Int -> ShowS
showTab n = showString (take n (repeat ' '))
showsHtmlOpenTag :: String -> Attrs -> String -> ShowS
showsHtmlOpenTag tag attrs close =
showChar '<' . showString tag .
concatS (map attr2string attrs) . showString close
where
attr2string (attr,value) =
showChar ' ' . showString attr .
showString "=\"" . encodeQuotes value . showChar '"'
-- encode double quotes as """:
encodeQuotes [] = id
encodeQuotes (c:cs) | c=='"' = showString """ . encodeQuotes cs
| otherwise = showChar c . encodeQuotes cs
nl :: ShowS
nl = showChar '\n'
concatS :: [ShowS] -> ShowS
concatS [] = id
concatS xs@(_:_) = foldr1 (\ f g -> f . g) xs
------------------------------------------------------------------------------
--- Transforms HTML page into string representation.
--- @param page - the HTML page
--- @return string representation of the HTML document
showHtmlPage :: HtmlPage -> String
showHtmlPage (HtmlAnswer _ cont) = cont
showHtmlPage (HtmlPage title params html) =
htmlPrelude ++
showHtml (BaseStruct "html" htmlTagAttrs
[BaseStruct "head" []
([BaseStruct "title" [] [BaseText (htmlQuote title)]] ++
concatMap pageParam2HTML params),
BaseStruct "body" bodyattrs html])
where
bodyattrs = [attr | (PageBodyAttr attr) <- params]
--- Translates page parameters into HTML expressions.
--- Used to show HTML pages.
pageParam2HTML :: PageParam -> [BaseHtml]
pageParam2HTML (PageEnc enc) =
[BaseStruct "meta" [("http-equiv","Content-Type"),
("content","text/html; charset="++enc)] []]
pageParam2HTML (PageCookie _ _ _) = [] -- cookies are differently processed
pageParam2HTML (PageCSS css) =
[BaseStruct "link" [("rel","stylesheet"),("type","text/css"),("href",css)]
[]]
pageParam2HTML (HttpHeader _ _) = [] -- page headers are differently processed
pageParam2HTML (PageJScript js) =
[BaseStruct "script" [("type","text/javascript"),("src",js)] []]
pageParam2HTML (PageMeta attrs) = [BaseStruct "meta" attrs []]
pageParam2HTML (PageLink attrs) = [BaseStruct "link" attrs []]
pageParam2HTML (PageHeadInclude hexp) = [hexp]
pageParam2HTML (PageBodyAttr _) = [] --these attributes are separately processed
--- Standard header for generated HTML pages.
htmlPrelude :: String
htmlPrelude = "<!DOCTYPE html>\n"
--- Standard attributes for element "html".
htmlTagAttrs :: Attrs
htmlTagAttrs = [("lang","en")]
------------------------------------------------------------------------------
--- Gets the parameter attached to the URL of the script.
--- For instance, if the script is called with URL
--- "http://.../script.cgi?parameter", then "parameter" is
--- returned by this I/O action.
--- Note that an URL parameter should be "URL encoded" to avoid
--- the appearance of characters with a special meaning.
--- Use `urlencoded2string` and `string2urlencoded` from `Network.URL`
--- to decode and encode such parameters, respectively.
getUrlParameter :: IO String
getUrlParameter = getEnv "QUERY_STRING"
------------------------------------------------------------------------------
--- Gets the cookies sent from the browser for the current CGI script.
--- The cookies are represented in the form of name/value pairs since
--- no other components are important here.
getCookies :: IO [(String,String)]
getCookies = do
cookiestring <- getEnv "HTTP_COOKIE"
return $ parseCookies cookiestring
-- translate a string of cookies (of the form "NAME1=VAL1; NAME2=VAL")
-- into a list of name/value pairs:
parseCookies :: String -> [(String,String)]
parseCookies str =
if null str
then []
else let (c1,cs) = break (==';') str
in parseCookie c1 :
parseCookies (dropWhile (==' ') (if null cs then "" else tail cs))
where
parseCookie s =
let (name,evalue) = break (=='=') s
in (name, if null evalue then "" else urlencoded2string (tail evalue))
--- For image buttons: retrieve the coordinates where the user clicked
--- within the image.
coordinates :: HtmlEnv -> Maybe (Int,Int)
coordinates env = let x = env (HtmlRef "x")
y = env (HtmlRef "y")
in if x/="" && y/=""
then Just (tryReadNat 0 x, tryReadNat 0 y)
else Nothing
where
tryReadNat d s = case readNat s of [(i,"")] -> i
_ -> d
------------------------------------------------------------------------------
|