100 lines
3.2 KiB
OCaml
100 lines
3.2 KiB
OCaml
(* Copyright 2012 Tony Garnock-Jones <tonygarnockjones@gmail.com>. *)
|
|
|
|
(* 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 <http://www.gnu.org/licenses/>. *)
|
|
|
|
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 ^ "</" ^ label ^ ">"
|
|
| 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 ("</"^label^">")
|
|
| 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 "<!DOCTYPE html>" in
|
|
html_generator (tag_of_document d) yield)
|