(* Copyright 2012 Tony Garnock-Jones . *) (* This file is part of Hop. *) (* Hop is free software: you can redistribute it and/or modify it *) (* under the terms of the GNU General Public License as published by the *) (* Free Software Foundation, either version 3 of the License, or (at your *) (* option) any later version. *) (* Hop is distributed in the hope that it will be useful, but *) (* WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *) (* General Public License for more details. *) (* You should have received a copy of the GNU General Public License *) (* along with Hop. If not, see . *) type html_content = | Tag of string * (string * string) list * html_content list * bool | Text of string type html_document = { html_title: string; html_headers: html_content list; html_body: html_content list } let html_document title headers body = {html_title = title; html_headers = headers; html_body = body} let tag label attrs contents = Tag (label, attrs, contents, false) let unclosed_tag label attrs contents = Tag (label, attrs, contents, true) let text str = Text str let tag_of_document doc = tag "html" [] [tag "head" [] ([unclosed_tag "meta" ["charset", "utf-8"] []; tag "title" [] [text doc.html_title]] @ doc.html_headers); tag "body" [] doc.html_body] let escape_html_char c = match c with | '&' -> Some (fun (s, pos) -> ("&", pos + 1)) | '<' -> Some (fun (s, pos) -> ("<", pos + 1)) | '>' -> Some (fun (s, pos) -> (">", pos + 1)) | _ -> None let html_escape s = Util.strsub escape_html_char s let escape_html_attribute_char c = match c with | '\'' -> Some (fun (s, pos) -> ("'", pos + 1)) | '\"' -> Some (fun (s, pos) -> (""", pos + 1)) | _ -> None let html_attribute_escape s = Util.strsub escape_html_attribute_char s let string_of_html_attribute (k, v) = k ^ "=\"" ^ html_attribute_escape v ^ "\"" let string_of_html_attributes attrs = String.concat " " (List.map string_of_html_attribute attrs) let html_open_tag_string label attrs = match attrs with | [] -> "<" ^ label ^ ">" | _ -> "<" ^ label ^ " " ^ string_of_html_attributes attrs ^ ">" let rec string_of_html_contents cs = String.concat "" (List.map string_of_html cs) and string_of_html c = match c with | Tag (label, attrs, [], true) -> html_open_tag_string label attrs | Tag (label, attrs, contents, _) -> html_open_tag_string label attrs ^ string_of_html_contents contents ^ "" | Text str -> html_escape str let html_generator c yield = let rec o c = match c with | Tag (label, attrs, [], true) -> yield (html_open_tag_string label attrs) | Tag (label, attrs, contents, _) -> lwt () = yield (html_open_tag_string label attrs) in lwt () = Lwt_list.iter_s o contents in yield ("") | Text str -> yield str in o c let stream_of_html c = Streamutil.stream_generator (html_generator c) let stream_of_html_doc d = Streamutil.stream_generator (fun yield -> lwt () = yield "" in html_generator (tag_of_document d) yield)