mirror of
https://github.com/c-cube/ocaml-containers.git
synced 2025-12-06 11:15:31 -05:00
358 lines
9.8 KiB
OCaml
358 lines
9.8 KiB
OCaml
|
|
(*
|
|
copyright (c) 2013, simon cruanes
|
|
all rights reserved.
|
|
|
|
redistribution and use in source and binary forms, with or without
|
|
modification, are permitted provided that the following conditions are met:
|
|
|
|
redistributions of source code must retain the above copyright notice, this
|
|
list of conditions and the following disclaimer. redistributions in binary
|
|
form must reproduce the above copyright notice, this list of conditions and the
|
|
following disclaimer in the documentation and/or other materials provided with
|
|
the distribution.
|
|
|
|
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
|
|
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
|
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
|
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
|
|
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
|
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
|
|
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
|
|
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
|
|
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
|
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
*)
|
|
|
|
(** {1 Expose the State of a Program to the Web}
|
|
|
|
We export some values (and associated functions for converting them to
|
|
html, and update them) as a FastCGI interface.
|
|
|
|
This module depends on CamlGI.
|
|
*)
|
|
|
|
(** {2 Some combinators to build HTML documents} *)
|
|
|
|
module HTML = struct
|
|
type t =
|
|
| Str of string (* content *)
|
|
| List of t list
|
|
| Url of url
|
|
| Img of image
|
|
| Concat of t list
|
|
| H of int * t
|
|
| Link of link
|
|
| Tag of string * t
|
|
| TagWith of string * (string * string) list * t
|
|
and url = {
|
|
url_alt : string option;
|
|
url_url : string;
|
|
url_descr : string;
|
|
}
|
|
and image = {
|
|
img_alt : string option;
|
|
img_url : string;
|
|
}
|
|
and link = {
|
|
link_rel : string;
|
|
link_url : string;
|
|
}
|
|
|
|
let str s = Str s
|
|
|
|
let bprintf format =
|
|
let buffer = Buffer.create 64 in
|
|
let r = ref (str "") in
|
|
Printf.kbprintf
|
|
(fun x -> r := str (Buffer.contents buffer))
|
|
buffer
|
|
format;
|
|
!r
|
|
|
|
let sprintf format =
|
|
let r = ref (str "") in
|
|
Printf.ksprintf
|
|
(fun s -> r := str s)
|
|
format;
|
|
!r
|
|
|
|
let list l = List l
|
|
|
|
let url ?alt ~url ~descr = Url {
|
|
url_alt = alt;
|
|
url_url = url;
|
|
url_descr = descr;
|
|
}
|
|
|
|
let img ?alt url = Img {
|
|
img_alt = alt;
|
|
img_url = url;
|
|
}
|
|
|
|
let append a b = Concat [a; b]
|
|
|
|
let concat l = Concat l
|
|
|
|
let h1 x = H (1, x)
|
|
|
|
let h2 x = H (2, x)
|
|
|
|
let h3 x = H (3, x)
|
|
|
|
let h n x = H (n, x)
|
|
|
|
let p x = Tag ("p", x)
|
|
|
|
let div ?id ?class_ x =
|
|
match id, class_ with
|
|
| None, None -> Tag ("div", x)
|
|
| Some i, None -> TagWith ("div", ["id", i], x)
|
|
| None, Some c -> TagWith ("div", ["class", c], x)
|
|
| Some i, Some c -> TagWith ("div", ["id", i; "class", c], x)
|
|
|
|
let span ?id ?class_ x =
|
|
match id, class_ with
|
|
| None, None -> Tag ("span", x)
|
|
| Some i, None -> TagWith ("span", ["id", i], x)
|
|
| None, Some c -> TagWith ("span", ["class", c], x)
|
|
| Some i, Some c -> TagWith ("span", ["id", i; "class", c], x)
|
|
|
|
let link ~rel ~url = Link {
|
|
link_rel = rel;
|
|
link_url = url;
|
|
}
|
|
|
|
let head x = Tag ("head", x)
|
|
|
|
let body x = Tag ("body", x)
|
|
|
|
let html x = Tag ("html", x)
|
|
|
|
let _to_hex n = match n with
|
|
| _ when n >= 0 && n < 10 -> Char.chr (Char.code '0' + n)
|
|
| 10 -> 'A'
|
|
| 11 -> 'B'
|
|
| 12 -> 'C'
|
|
| 13 -> 'D'
|
|
| 14 -> 'E'
|
|
| 15 -> 'F'
|
|
| _ -> failwith "not an hexadecimal digit"
|
|
|
|
let _encode_char buf c =
|
|
Buffer.add_string buf "&#x";
|
|
let h, l = Char.code c / 16, Char.code c mod 16 in
|
|
Buffer.add_char buf (_to_hex h);
|
|
Buffer.add_char buf (_to_hex l)
|
|
|
|
let encode str =
|
|
let b = Buffer.create (String.length str + 10) in
|
|
for i = 0 to String.length str - 1 do
|
|
match str.[i] with
|
|
| ';' | '/' | '?' | ':' | '@' | '&' | '=' | '+' | '$' | ',' | '<'
|
|
| '>' | '#' | '%' | '"' | '{' | '}' | '|' | '\\' | '^' | '[' | ']'
|
|
| '`' -> _encode_char b str.[i]
|
|
| c when Char.code c < 32 -> _encode_char b str.[i]
|
|
| c when Char.code c > 127 -> _encode_char b str.[i]
|
|
| _ -> Buffer.add_char b str.[i]
|
|
done;
|
|
Buffer.contents b
|
|
|
|
(* real rendering is always into a buffer (for now) *)
|
|
let rec to_buf buf x =
|
|
match x with
|
|
| Str s -> Buffer.add_string buf (encode s)
|
|
| List l ->
|
|
Buffer.add_string buf "<ul>";
|
|
List.iter
|
|
(fun y -> Printf.bprintf buf "<li>%a</li>" to_buf y)
|
|
l;
|
|
Buffer.add_string buf "</ul>"
|
|
| Url url ->
|
|
begin match url.url_alt with
|
|
| None ->
|
|
Printf.bprintf buf "<a href=\"%s\">%s</a>" url.url_url
|
|
(encode url.url_descr)
|
|
| Some alt ->
|
|
Printf.bprintf buf "<a href=\"%s\" alt=\"%s\">%s</a>"
|
|
url.url_url (encode alt) (encode url.url_descr)
|
|
end
|
|
| Img i -> failwith "img: not implemented"
|
|
| Concat l ->
|
|
List.iteri
|
|
(fun i y ->
|
|
if i > 0 then Buffer.add_char buf ' ';
|
|
to_buf buf y)
|
|
l
|
|
| H (n, y) ->
|
|
Printf.bprintf buf "<h%i> %a </h%i>" n to_buf y n
|
|
| Link _ -> failwith "link: not implemented"
|
|
| Tag (str, y) -> Printf.bprintf buf "<%s> %a </%s>" str to_buf y str
|
|
| TagWith (str, attrs, y) ->
|
|
Printf.bprintf buf "<%s " str;
|
|
List.iter (fun (name,attr) -> Printf.bprintf buf "%s=\"%s\"" name attr) attrs;
|
|
Printf.bprintf buf "> %a </%s>" to_buf y str
|
|
|
|
let render x =
|
|
let buf = Buffer.create 256 in
|
|
to_buf buf x;
|
|
Buffer.contents buf
|
|
|
|
let to_chan oc x =
|
|
let buf = Buffer.create 256 in
|
|
to_buf buf x;
|
|
Buffer.output_buffer oc buf
|
|
end
|
|
|
|
(** {2 Stateful Object on the Web} *)
|
|
|
|
module State = struct
|
|
type 'a t = {
|
|
mutable content : 'a;
|
|
mutable callbacks : ('a -> unit) list;
|
|
id : ('a -> string) option;
|
|
export : 'a -> HTML.t;
|
|
update : (string * string) list -> 'a -> 'a;
|
|
} (** A value that can be exposed to the Web.
|
|
The [export] function is used to print the current state of
|
|
the object into HTML (when requested).
|
|
The [update] optional function can be used to update
|
|
the value, given a query with parameters. *)
|
|
|
|
type wrap = Wrap : 'a t -> wrap
|
|
(** Hides the type parameter in a GADT. *)
|
|
|
|
let create ?(update=fun _ x -> x) ?id ~export content = {
|
|
content;
|
|
export;
|
|
id;
|
|
callbacks = [];
|
|
update;
|
|
}
|
|
|
|
let on_change st f =
|
|
st.callbacks <- f :: st.callbacks
|
|
|
|
let handle_request st req =
|
|
let cgi = new CamlGI.Cgi.cgi req in
|
|
(* update value? *)
|
|
try
|
|
let x = st.content in
|
|
let params = cgi#params in
|
|
(* update [x] using the parameters? *)
|
|
let y = st.update params x in
|
|
let changed = match st.id with
|
|
| None -> x != y
|
|
| Some id -> id x <> id y
|
|
in
|
|
(* notify callbacks that we have a new object *)
|
|
if changed then
|
|
List.iter (fun f -> f y) st.callbacks;
|
|
(* now print [y] *)
|
|
(* TODO: add a head, declaration, etc. *)
|
|
let html = st.export y in
|
|
let final_output = HTML.render html in
|
|
(* render output *)
|
|
let template = object
|
|
method output f = f final_output
|
|
end in
|
|
cgi#template template
|
|
with e ->
|
|
let msg = Printf.sprintf "error: %s" (Printexc.to_string e) in
|
|
cgi#log msg
|
|
end
|
|
|
|
(** {2 Routing} *)
|
|
|
|
module Router = struct
|
|
type t = {
|
|
mutable default : State.wrap;
|
|
log : out_channel option;
|
|
tbl : (string, State.wrap) Hashtbl.t;
|
|
}
|
|
|
|
let __default =
|
|
State.Wrap (State.create ~export:HTML.str "<no default handler>")
|
|
|
|
let _log router fmt = match router.log with
|
|
| None ->
|
|
Printf.ifprintf stdout fmt
|
|
| Some oc ->
|
|
Printf.kfprintf
|
|
(fun oc ->
|
|
output_char oc '\n';
|
|
flush oc)
|
|
oc
|
|
fmt
|
|
|
|
let create ?(default=__default) ?log () =
|
|
let router = {
|
|
default;
|
|
log;
|
|
tbl = Hashtbl.create 15;
|
|
} in
|
|
_log router "new router created";
|
|
router
|
|
|
|
let default router default =
|
|
router.default <- default
|
|
|
|
let unregister router name =
|
|
Hashtbl.remove router.tbl name
|
|
|
|
let register ?(weak=false) router name state =
|
|
if Hashtbl.mem router.tbl name
|
|
then failwith "Router: name already registered"
|
|
else begin
|
|
Hashtbl.add router.tbl name state;
|
|
if weak then match state with
|
|
| State.Wrap st ->
|
|
Gc.finalise (fun _ -> unregister router name) st.State.content
|
|
end
|
|
|
|
let add_list router l =
|
|
List.iter
|
|
(fun (name, state) -> register router name state)
|
|
l
|
|
|
|
let to_list router =
|
|
Hashtbl.fold
|
|
(fun name state acc -> (name,state) :: acc)
|
|
router.tbl []
|
|
|
|
let random_id () =
|
|
CamlGI.Cgi.random_sessionid ()
|
|
|
|
let handle_request router req =
|
|
let cgi = new CamlGI.Cgi.cgi req in
|
|
let url = cgi#url () in
|
|
let st =
|
|
try
|
|
let last_part_i = String.rindex url '/' in
|
|
let last_part = String.sub url (last_part_i+1) (String.length url -last_part_i-1) in
|
|
_log router "received request for url /%s" last_part;
|
|
Hashtbl.find router.tbl last_part
|
|
with Not_found ->
|
|
router.default
|
|
in
|
|
match st with
|
|
| State.Wrap st -> State.handle_request st req
|
|
end
|
|
|
|
(** {2 Main Interface} *)
|
|
|
|
let serve_state ?sockfile ?sockaddr st =
|
|
match sockfile with
|
|
| None ->
|
|
CamlGI.Cgi.register_script ?sockaddr (State.handle_request st)
|
|
| Some f ->
|
|
let sockaddr = Unix.ADDR_UNIX f in
|
|
CamlGI.Cgi.register_script ~sockaddr (State.handle_request st)
|
|
|
|
let serve_router ?sockfile ?sockaddr router =
|
|
match sockfile with
|
|
| None ->
|
|
CamlGI.Cgi.register_script ?sockaddr (Router.handle_request router)
|
|
| Some f ->
|
|
let sockaddr = Unix.ADDR_UNIX f in
|
|
CamlGI.Cgi.register_script ~sockaddr (Router.handle_request router)
|