From e968d78fc4c1772dab585eb3e635ad39fb9ea873 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 28 Apr 2012 17:17:04 -0400 Subject: [PATCH] Web UI --- html.ml | 98 +++++++++++++++++++++ httpd.ml | 227 ++++++++++++++++++++++++++++++++++++++++++++++++ httpd_file.ml | 105 ++++++++++++++++++++++ ocamlmsg.ml | 1 + stringstream.ml | 70 +++++++++++++++ ui_main.ml | 38 ++++++++ util.ml | 6 ++ web/index.html | 9 ++ 8 files changed, 554 insertions(+) create mode 100644 html.ml create mode 100644 httpd.ml create mode 100644 httpd_file.ml create mode 100644 stringstream.ml create mode 100644 ui_main.ml create mode 100644 web/index.html diff --git a/html.ml b/html.ml new file mode 100644 index 0000000..3686018 --- /dev/null +++ b/html.ml @@ -0,0 +1,98 @@ +(* Copyright 2012 Tony Garnock-Jones . *) + +(* This file is part of Ocamlmsg. *) + +(* Ocamlmsg 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. *) + +(* Ocamlmsg 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 Ocamlmsg. 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 html_escape_re = Str.regexp "[&<>]" +let escape_html_char s = + match s with + | "&" -> "&" + | "<" -> "<" + | ">" -> ">" + | _ -> failwith ("Unexpected HTML char to escape: " ^ s) +let html_escape s = Str.global_substitute html_escape_re escape_html_char s + +let html_attribute_escape_re = Str.regexp "['\"]" +let escape_html_attribute_char s = + match s with + | "'" -> "'" + | "\"" -> """ + | _ -> failwith ("Unexpected HTML attribute char to escape: " ^ s) +let html_attribute_escape s = + Str.global_substitute html_attribute_escape_re 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 rec stream_of_html_contents cs = Stringstream.map stream_of_html cs +and stream_of_html c = + Stringstream.make (fun () -> + match c with + | Tag (label, attrs, [], true) -> + Some (html_open_tag_string label attrs, Stringstream.empty) + | Tag (label, attrs, contents, _) -> + Some (html_open_tag_string label attrs, + Stringstream.seq + (stream_of_html_contents contents) (Stringstream.const (""))) + | Text str -> + Some (str, Stringstream.empty)) + +let stream_of_html_doc d = + Stringstream.seq (Stringstream.const "") (stream_of_html (tag_of_document d)) diff --git a/httpd.ml b/httpd.ml new file mode 100644 index 0000000..cd89f5d --- /dev/null +++ b/httpd.ml @@ -0,0 +1,227 @@ +(* Copyright 2012 Tony Garnock-Jones . *) + +(* This file is part of Ocamlmsg. *) + +(* Ocamlmsg 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. *) + +(* Ocamlmsg 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 Ocamlmsg. If not, see . *) + +open Unix + +type version = [`HTTP_1_0 | `HTTP_1_1] +type resp_version = [version | `SAME_AS_REQUEST] +type content = Fixed of string | Variable of Stringstream.t + +type body = { + headers: (string * string) list; + content: content + } + +let empty_body = {headers = []; content = Fixed ""} + +type req = { + verb: string; + path: string; + query: string; + req_version: version; + req_body: body + } + +type resp = { + resp_version: resp_version; + status: int; + reason: string; + resp_body: body + } + +exception HTTPError of (int * string * body) + +let html_content_type = "text/html;charset=utf-8" +let text_content_type = "text/plain;charset=utf-8" + +let content_type_header_name = "Content-Type" + +let html_content_type_header = (content_type_header_name, html_content_type) +let text_content_type_header = (content_type_header_name, text_content_type) + +let http_error code reason body = raise (HTTPError (code, reason, body)) + +let http_error_plain code reason = + http_error code reason + {headers = [text_content_type_header]; content = Fixed reason} + +let http_error_html_doc code reason doc = + http_error code reason + {headers = [html_content_type_header]; + content = Variable (Html.stream_of_html_doc doc)} + +let html_error_doc code reason extra_body = + let code_str = string_of_int code in + (Html.html_document (code_str^" "^reason) [] + ((Html.tag "h1" [] [Html.text reason]) :: extra_body)) + +let http_error_html code reason extra_body = + http_error_html_doc code reason (html_error_doc code reason extra_body) + +let resp_generic code reason headers content = + { resp_version = `SAME_AS_REQUEST; + status = code; + reason = reason; + resp_body = {headers = headers; content = content} } + +let resp_generic_ok headers content = + resp_generic 200 "OK" headers content + +let resp_html_doc code reason extra_headers doc = + resp_generic code reason + (html_content_type_header :: extra_headers) + (Variable (Html.stream_of_html_doc doc)) + +let resp_html_doc_ok extra_headers doc = resp_html_doc 200 "OK" extra_headers doc + +let resp_html code reason extra_headers title content = + resp_html_doc code reason extra_headers (Html.html_document title [] content) + +let resp_html_ok extra_headers title content = + resp_html 200 "OK" extra_headers title content + +let resp_redirect_permanent new_path = + resp_html_doc 301 "Moved permanently" ["Location", new_path] + (html_error_doc 301 "Moved permanently" + [Html.text "The document has moved "; + Html.tag "a" ["href", new_path] [Html.text "here"]; + Html.text "."]) + +let url_escape_re = Str.regexp "[% ]" +let escape_url_char s = + match s with + | "%" -> "%25" + | " " -> "%20" + | _ -> failwith ("Unexpected URL char to escape: " ^ s) +let url_escape s = Str.global_substitute url_escape_re escape_url_char s + +let url_unescape_re = Str.regexp "%[0-9a-zA-Z][0-9a-zA-Z]" +let unhex_char c = + match c with + | '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9' -> Char.code c - Char.code '0' + | 'a' | 'b' | 'c' | 'd' | 'e' | 'f' -> Char.code c - Char.code 'a' + | 'A' | 'B' | 'C' | 'D' | 'E' | 'F' -> Char.code c - Char.code 'A' + | _ -> 0 +let unescape_url_char s = + String.make 1 (Char.chr (unhex_char (String.get s 1) * 16 + unhex_char (String.get s 2))) +let url_unescape s = Str.global_substitute url_unescape_re unescape_url_char s + +let render_header cout (k, v) = + output_string cout k; + output_string cout ": "; + output_string cout v; + output_string cout "\r\n" + +let render_chunk cout chunk = + match chunk with + | "" -> () + | _ -> + output_string cout (Printf.sprintf "%x\r\n" (String.length chunk)); + output_string cout chunk; + output_string cout "\r\n" + +let render_fixed_content cout s = + render_header cout ("Content-Length", string_of_int (String.length s)); + output_string cout "\r\n"; + output_string cout s + +let render_content cout v c = + match c with + | Fixed s -> + render_fixed_content cout s + | Variable s -> + match v with + | `HTTP_1_0 -> + render_fixed_content cout (Stringstream.to_string s) + | `HTTP_1_1 -> + render_header cout ("Transfer-Encoding", "chunked"); + output_string cout "\r\n"; + Stringstream.iter (render_chunk cout) s; + output_string cout "0\r\n\r\n" + +let render_body cout v b = + List.iter (render_header cout) b.headers; + render_content cout v b.content + +let string_of_version v = + match v with + | `HTTP_1_0 -> "HTTP/1.0" + | `HTTP_1_1 -> "HTTP/1.1" + +let version_of_string v = + match v with + | "HTTP/1.0" -> `HTTP_1_0 + | "HTTP/1.1" -> `HTTP_1_1 + | _ -> http_error_html 400 "Invalid HTTP version" [] + +let render_req cout r = + output_string cout (r.verb^" "^url_escape r.path^" "^string_of_version r.req_version^"\r\n"); + render_body cout r.req_version r.req_body + +let render_resp cout req_version r = + let resp_version = + (match r.resp_version with + | `SAME_AS_REQUEST -> req_version + | #version as v -> v) + in + output_string cout + (string_of_version resp_version^" "^string_of_int r.status^" "^r.reason^"\r\n"); + render_body cout resp_version r.resp_body + +let split_query p = + match Str.bounded_split (Str.regexp "\\?") p 2 with + | path :: query :: _ -> (path, query) + | path :: [] -> (path, "") + | [] -> ("", "") + +let parse_body cin = empty_body + +let input_crlf cin = + let line = input_line cin in + let len = String.length line in + if len > 0 && String.get line (len - 1) = '\r' + then String.sub line 0 (len - 1) + else line + +let rec parse_req cin spurious_newline_credit = + match Str.bounded_split (Str.regexp " ") (input_crlf cin) 3 with + | [] -> + (* HTTP spec requires that we ignore leading CRLFs. We choose to do so, up to a point. *) + if spurious_newline_credit = 0 + then http_error_html 400 "Bad request: too many leading CRLFs" [] + else parse_req cin (spurious_newline_credit - 1) + | [verb; path; version_str] -> + let version = version_of_string version_str in + let body = parse_body cin in + let path = url_unescape path in + let (path, query) = split_query path in + { verb = verb; path = path; query = query; req_version = version; req_body = body } + | _ -> http_error_html 400 "Bad request line" [] + +let main handle_req (s, peername) = + let cin = in_channel_of_descr s in + let cout = out_channel_of_descr s in + (try + (try + let req = parse_req cin 512 in + render_resp cout req.req_version (handle_req req) + with HTTPError (code, reason, body) -> + render_resp cout `HTTP_1_0 + { resp_version = `HTTP_1_0; status = code; reason = reason; resp_body = body }) + with _ -> ()); + (try flush cout with _ -> ()); + close s diff --git a/httpd_file.ml b/httpd_file.ml new file mode 100644 index 0000000..15be68c --- /dev/null +++ b/httpd_file.ml @@ -0,0 +1,105 @@ +(* Copyright 2012 Tony Garnock-Jones . *) + +(* This file is part of Ocamlmsg. *) + +(* Ocamlmsg 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. *) + +(* Ocamlmsg 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 Ocamlmsg. If not, see . *) + +let visible_path_component s = + match s with + | "" -> false + | "." -> false + | ".." -> false + | _ -> if String.get s 0 = '.' then false else true + +let sanitize_path_re = Str.regexp "/" +let sanitize_path p = + String.concat "/" (List.filter visible_path_component (Str.split sanitize_path_re p)) + +let extension_map ext = + match String.lowercase ext with + | ".txt" -> Httpd.text_content_type + | ".html" | ".htm" -> Httpd.html_content_type + | ".bin" -> "application/octet-stream" + | ".jpg" | ".jpeg" -> "image/jpeg" + | ".gif" -> "image/gif" + | ".png" -> "image/png" + | ".css" -> "text/css" + | ".js" -> "text/javascript" + | ".json" -> "application/json" + | _ -> "application/octet-stream" + +let analyze_path p = + let p = sanitize_path p in + let chopped_p = (try Filename.chop_extension p with _ -> p) in + let ext = String.sub p (String.length chopped_p) (String.length p - String.length chopped_p) in + let p = if p = "" then "." else p in + (p, extension_map ext) + +let read_and_close_file handle = + let buflen = 4096 in + let buffer = String.make buflen '\000' in + fun () -> + let count = + (try + input handle buffer 0 buflen + with e -> (close_in handle; raise e)) + in + if count > 0 + then Some (String.sub buffer 0 count) + else (close_in handle; + None) + +let rec read_dir dirhandle = + try + let n = Unix.readdir dirhandle in + n :: read_dir dirhandle + with End_of_file -> + [] + +let render_directory_listing path = + let dir = Unix.opendir path in + let entries = List.filter visible_path_component (read_dir dir) in + Unix.closedir dir; + Html.html_document path [] + [Html.tag "h1" [] [Html.text "Directory listing for "; Html.tag "tt" [] [Html.text path]]; + Html.tag "ul" [] + (List.map + (fun e -> Html.tag "li" [] [Html.tag "a" ["href", e] [Html.text e]]) + entries); + Html.unclosed_tag "hr" [] []] + +let resp_raw_file mime_type path = + Httpd.resp_generic_ok + [Httpd.content_type_header_name, mime_type] + (Httpd.Variable (Stringstream.from_iter (read_and_close_file (open_in_bin path)))) + +let resp_file raw_path = + let (path, mime_type) = analyze_path raw_path in + (try + (if Sys.is_directory path + then + let maybe_index_html = Filename.concat path "index.html" in + if Sys.file_exists maybe_index_html && not (Sys.is_directory maybe_index_html) + then resp_raw_file Httpd.html_content_type maybe_index_html + else + if path = "." || Str.last_chars raw_path 1 = "/" + then Httpd.resp_html_doc_ok [] (render_directory_listing path) + else Httpd.resp_redirect_permanent ("/"^path^"/") + else if Sys.file_exists path + then + resp_raw_file mime_type path + else + Httpd.http_error_html 404 "Not found" []) + with Sys_error message -> + Httpd.http_error_html 403 "Forbidden" [Html.text message]) diff --git a/ocamlmsg.ml b/ocamlmsg.ml index 20fa5ae..ba59004 100644 --- a/ocamlmsg.ml +++ b/ocamlmsg.ml @@ -35,5 +35,6 @@ let _ = Meta.init (); hook_log (); Amqp_relay.init (); + Ui_main.init (); (* Speedtest.init (); *) Net.start_net "Hop" 5671 Relay.start diff --git a/stringstream.ml b/stringstream.ml new file mode 100644 index 0000000..19e1680 --- /dev/null +++ b/stringstream.ml @@ -0,0 +1,70 @@ +(* Copyright 2012 Tony Garnock-Jones . *) + +(* This file is part of Ocamlmsg. *) + +(* Ocamlmsg 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. *) + +(* Ocamlmsg 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 Ocamlmsg. If not, see . *) + +type t = Stream of (unit -> (string * t) option) + +let make f = Stream f + +let run (Stream f) = f () + +let empty = Stream (fun () -> None) +let const v = Stream (fun () -> Some (v, empty)) + +let rec seq s1 s2 = + Stream (fun () -> + match run s1 with + | None -> run s2 + | Some (v, k) -> Some (v, seq k s2)) + +let rec from_list vs = + Stream (fun () -> + match vs with + | [] -> None + | v :: vs -> Some (v, (from_list vs))) + +let rec map f vs = + Stream (fun () -> + match vs with + | [] -> None + | v :: vs -> run (seq (f v) (map f vs))) + +let rec from_iter f = + let cache = ref None in + Stream (fun () -> + match !cache with + | Some v -> v + | None -> + let result = + (match f () with + | Some str -> Some (str, from_iter f) + | None -> None) + in + cache := Some result; + result) + +let rec iter f (Stream s_f) = + match s_f () with + | None -> () + | Some (v, k) -> (f v; iter f k) + +let rec to_list (Stream f) = + match f () with + | None -> [] + | Some (v, k) -> v :: to_list k + +let rec to_string s = + String.concat "" (to_list s) diff --git a/ui_main.ml b/ui_main.ml new file mode 100644 index 0000000..0febb2d --- /dev/null +++ b/ui_main.ml @@ -0,0 +1,38 @@ +(* Copyright 2012 Tony Garnock-Jones . *) + +(* This file is part of Ocamlmsg. *) + +(* Ocamlmsg 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. *) + +(* Ocamlmsg 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 Ocamlmsg. If not, see . *) + +open Html + +let handle_dynamic_req r = + Httpd.http_error_html 500 "Not yet implemented" [] + +let handle_req r = + if Util.starts_with r.Httpd.path "/_" + then handle_dynamic_req r + else + match r.Httpd.verb with + | "GET" -> Httpd_file.resp_file (Filename.concat "./web" r.Httpd.path) + | _ -> Httpd.http_error_html 400 ("Unsupported HTTP method "^r.Httpd.verb) [] + +let start (s, peername) = + Util.create_thread (Connections.endpoint_name peername ^ " HTTP service") + None + (Httpd.main handle_req) + (s, peername) + +let init () = + ignore (Util.create_thread "HTTP listener" None (Net.start_net "HTTP" 5678) start) diff --git a/util.ml b/util.ml index 1b4badb..3093f50 100644 --- a/util.ml +++ b/util.ml @@ -44,3 +44,9 @@ let with_mutex m f arg = raise e let with_mutex0 m thunk = with_mutex m thunk () + +let starts_with s1 s2 = + try Str.first_chars s1 (String.length s2) = s2 with _ -> false + +let ends_with s1 s2 = + try Str.last_chars s1 (String.length s2) = s2 with _ -> false diff --git a/web/index.html b/web/index.html new file mode 100644 index 0000000..c8df4fd --- /dev/null +++ b/web/index.html @@ -0,0 +1,9 @@ + + + Ocamlmsg + + +

Ocamlmsg

+

Welcome to Ocamlmsg.

+ +