------------------------------------------------------------------------------ --- Library for constructing static and dynamic HTML pages. --- [This paper](https://www.informatik.uni-kiel.de/~mh/papers/PADL01.html) --- contains a description of the basic ideas behind an old version --- of this library. --- --- An application written with this library can be transformed into --- a cgi script by the command --- --- > cypm exec curry2cgi -m mainPage -o /home/joe/cgi-bin/prog.cgi Prog --- --- where `Prog` is the name of the Curry program with --- the cgi script, `/home/joe/cgi-bin/prog.cgi` is --- the desired location of the --- compiled cgi script, and `mainPage` is the Curry expression --- (of type `IO HtmlPage`) computing the HTML page (where `cypm` --- is the command calling the Curry Package Manager). --- --- @author Michael Hanus (with extensions by Bernd Brassel and Marco Comini) --- @version October 2020 ------------------------------------------------------------------------------ {-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-} module HTML.Base ( HTML, htmlText, htmlStruct, hStruct, updAttrs, toBaseHtml, HtmlExp(..), BaseHtml(..), 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, 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, button, resetButton, imageButton, coordinates, textField, password, textArea, checkBox, checkedBox, radioMain, radioMainOff, radioOther, selection, selectionInitial, multipleSelection, htmlQuote, htmlIsoUmlauts, addAttr, addAttrs, addClass, showBaseHtmls, showBaseHtml, showHtmlPage, htmlPrelude, htmlTagAttrs, getUrlParameter, urlencoded2string, string2urlencoded, formatCookie ) where import Data.Char ( isAlphaNum, isSpace ) import Numeric ( readNat, readHex ) import System.Environment ( getEnv ) import Data.Time ( CalendarTime(..), ClockTime, toTimeString, toUTCTime ) 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)] --- The data type to represent static HTML expressions. --- @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 --- 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 extracting the basic HTML structure, i.e., --- transforming a document into a basic HTML document. class HTML a where htmlText :: String -> a htmlStruct :: String -> Attrs -> [a] -> a updAttrs :: (Attrs -> Attrs) -> a -> a toBaseHtml :: a -> BaseHtml --- An HTML structure with a given tag and no attributes. hStruct :: HTML h => String -> [h] -> h hStruct tag = htmlStruct tag [] --- The type of basic HTML expressions is an instance of class `HTML`. instance HTML BaseHtml where htmlText = BaseText htmlStruct = BaseStruct updAttrs = updBaseAttrs toBaseHtml = id ------------------------------------------------------------------------------ -- 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 toBaseHtml = fromHtmlExp ------------------------------------------------------------------------------ --- Extracts the textual contents of a list of HTML expressions. --- For instance, --- --- textOf [BaseText "xy", BaseStruct "a" [] [BaseText "bc"]] == "xy bc" --- textOf :: [BaseHtml] -> String textOf = unwords . filter (not . null) . map textOfBaseHtml where textOfBaseHtml (BaseText s) = s textOfBaseHtml (BaseStruct _ _ hs) = textOf hs textOfBaseHtml (BaseAction _) = "" ------------------------------------------------------------------------------ -- 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 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 --- ). --- @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: --- Basic text as 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 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 = BaseAction formAction where formAction = do urlparam <- getUrlParameter he <- genInitForm formspec return $ HtmlStruct "form" [("method", "post"), ("action", '?' : urlparam)] (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 HTML expressions into string representation. showBaseHtmls :: [BaseHtml] -> String showBaseHtmls hexps = showsBaseHtmls 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. showBaseHtml :: BaseHtml -> String showBaseHtml hexp = showsBaseHtml 0 hexp "" --- HTML tags that have no end tag in HTML: noEndTags :: [String] noEndTags = ["img","input","link","meta"] showsBaseHtml :: Int -> BaseHtml -> ShowS showsBaseHtml _ (BaseText s) = showString s showsBaseHtml i (BaseStruct 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 "' ) . maybeLn i where showExps = if tag=="pre" then concatS . map (showsBaseHtml 0) else showsBaseHtmls (i+2) showsBaseHtml _ (BaseAction _) = error "HTML.Base.showsBaseHtml: BaseAction occurred" showsBaseHtmls :: Int -> [BaseHtml] -> ShowS showsBaseHtmls _ [] = id showsBaseHtmls i (he:hes) = showsWithLnPrefix he . showsBaseHtmls i hes where showsWithLnPrefix hexp = let s = textOfBaseHtml hexp in if s /= "" && isSpace (head s) then nl . showTab i . showString (tail s) else showsBaseHtml i hexp -- get the string contents of an HTML expression: textOfBaseHtml :: BaseHtml -> String textOfBaseHtml (BaseText s) = s textOfBaseHtml (BaseStruct _ _ _) = "" textOfBaseHtml (BaseAction _) = "" 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 ++ showBaseHtml (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 = "\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 the functions "urlencoded2string" and "string2urlencoded" --- to decode and encode such parameters, respectively. getUrlParameter :: IO String getUrlParameter = getEnv "QUERY_STRING" --- Translates an URL encoded string into equivalent ASCII string. urlencoded2string :: String -> String urlencoded2string [] = [] urlencoded2string (c:cs) | c == '+' = ' ' : urlencoded2string cs | c == '%' = chr (case readHex (take 2 cs) of [(n,"")] -> n _ -> 0) : urlencoded2string (drop 2 cs) | otherwise = c : urlencoded2string cs --- Translates arbitrary strings into equivalent URL encoded strings. string2urlencoded :: String -> String string2urlencoded [] = [] string2urlencoded (c:cs) | isAlphaNum c = c : string2urlencoded cs | c == ' ' = '+' : string2urlencoded cs | otherwise = let oc = ord c in '%' : int2hex(oc `div` 16) : int2hex(oc `mod` 16) : string2urlencoded cs where int2hex i = if i<10 then chr (ord '0' + i) else chr (ord 'A' + i - 10) ------------------------------------------------------------------------------ --- 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 cs=="" then "" else tail cs)) where parseCookie s = let (name,evalue) = break (=='=') s in (name, if 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 ------------------------------------------------------------------------------