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 ^ "" ^ label ^ ">"
+ | 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 (""^label^">")))
+ | 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.
+
+