Web UI
This commit is contained in:
parent
ac7541e571
commit
e968d78fc4
|
@ -0,0 +1,98 @@
|
||||||
|
(* Copyright 2012 Tony Garnock-Jones <tonygarnockjones@gmail.com>. *)
|
||||||
|
|
||||||
|
(* 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 <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 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 "<!DOCTYPE html>") (stream_of_html (tag_of_document d))
|
|
@ -0,0 +1,227 @@
|
||||||
|
(* Copyright 2012 Tony Garnock-Jones <tonygarnockjones@gmail.com>. *)
|
||||||
|
|
||||||
|
(* 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 <http://www.gnu.org/licenses/>. *)
|
||||||
|
|
||||||
|
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
|
|
@ -0,0 +1,105 @@
|
||||||
|
(* Copyright 2012 Tony Garnock-Jones <tonygarnockjones@gmail.com>. *)
|
||||||
|
|
||||||
|
(* 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 <http://www.gnu.org/licenses/>. *)
|
||||||
|
|
||||||
|
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])
|
|
@ -35,5 +35,6 @@ let _ =
|
||||||
Meta.init ();
|
Meta.init ();
|
||||||
hook_log ();
|
hook_log ();
|
||||||
Amqp_relay.init ();
|
Amqp_relay.init ();
|
||||||
|
Ui_main.init ();
|
||||||
(* Speedtest.init (); *)
|
(* Speedtest.init (); *)
|
||||||
Net.start_net "Hop" 5671 Relay.start
|
Net.start_net "Hop" 5671 Relay.start
|
||||||
|
|
|
@ -0,0 +1,70 @@
|
||||||
|
(* Copyright 2012 Tony Garnock-Jones <tonygarnockjones@gmail.com>. *)
|
||||||
|
|
||||||
|
(* 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 <http://www.gnu.org/licenses/>. *)
|
||||||
|
|
||||||
|
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)
|
|
@ -0,0 +1,38 @@
|
||||||
|
(* Copyright 2012 Tony Garnock-Jones <tonygarnockjones@gmail.com>. *)
|
||||||
|
|
||||||
|
(* 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 <http://www.gnu.org/licenses/>. *)
|
||||||
|
|
||||||
|
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)
|
6
util.ml
6
util.ml
|
@ -44,3 +44,9 @@ let with_mutex m f arg =
|
||||||
raise e
|
raise e
|
||||||
|
|
||||||
let with_mutex0 m thunk = with_mutex m thunk ()
|
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
|
||||||
|
|
|
@ -0,0 +1,9 @@
|
||||||
|
<html>
|
||||||
|
<head>
|
||||||
|
<title>Ocamlmsg</title>
|
||||||
|
</head>
|
||||||
|
<body>
|
||||||
|
<h1>Ocamlmsg</h1>
|
||||||
|
<p>Welcome to Ocamlmsg.</p>
|
||||||
|
</body>
|
||||||
|
</html>
|
Loading…
Reference in New Issue