Traditional web interaction in a client-server app
The code of this tutorial has been tested with Eliom 6.0.
Multi-user collaborative drawing application
We now want to turn our collaborative drawing application into a multi-user one. Each user will have their own drawing, where everyone can draw.
See the full code of examples.
Split application into multiple files and using several canvases
We first build a multi-canvas drawing application. Each drawing has its own URL. Everyone can create a new drawing by going to the corresponding URL.
We need to refactor some parts. In particular, we need to handle different drawings separately. To do this, we turn all global variables, like the bus, into local ones.
When an application grows, it becomes useful to split it into multiple files. For example, we will split graffiti into 4 files.
- common.ml, which will be part of both client and server, containing shared types and declarations,
- client.ml, client-only part of the application,
- server.ml, server-only part of the application, and
- graffiti.eliom, which is the only part where we need to include both client-side and server-side code
common.ml
It contains what was previously in [%shared ... ]
type messages =
((int * int * int) * int * (int * int) * (int * int))
[@@deriving json]
let width = 700
let height = 400
client.ml
It is almost the same code as what was enclosed in {{{ {client{ ... }} }}}, with the difference that what was previously in the client value init_client is now in the function launch_client_canvas.
open Common
open Js_of_ocaml
open Eliom_content
let draw ctx ((r, g, b), size, (x1, y1), (x2, y2)) =
let color = CSS.Color.string_of_t (CSS.Color.rgb r g b) in
ctx##.strokeStyle := (Js.string color);
ctx##.lineWidth := float size;
ctx##beginPath;
ctx##(moveTo (float x1) (float y1));
ctx##(lineTo (float x2) (float y2));
ctx##stroke
(* type containing all informations we need to stop interaction
inside the page *)
type drawing_canceller =
{ message_thread : unit Lwt.t;
(* the thread reading messages from the bus *)
drawing_thread : unit Lwt.t;
(* the arrow handling mouse events *)
}
let stop_drawing { message_thread; drawing_thread } =
Lwt.cancel message_thread;
(* cancelling this thread also close the bus *)
Lwt.cancel drawing_thread
Lwt.cancel t stops thread t. In this case it also closes the bus on which t is listening. For more informations see the Lwt programming guide and Eliom_bus.
let launch_client_canvas bus image_elt canvas_elt slider =
let canvas = Html.To_dom.of_canvas canvas_elt in
let ctx = canvas##(getContext (Dom_html._2d_)) in
ctx##.lineCap := Js.string "round";
let img = Html.To_dom.of_img image_elt in
let copy_image () = ctx##(drawImage img (0.) (0.)) in
if Js.to_bool (img##.complete)
then copy_image ()
else img##.onload := Dom_html.handler
(fun ev -> copy_image (); Js._false);
(* The color palette: *)
let colorpicker, cp_sig = Ot_color_picker.make () in
Html.(Manip.appendChild (Manip.Elt.body ()) colorpicker);
let x = ref 0 and y = ref 0 in
let set_coord ev =
let x0, y0 = Dom_html.elementClientPosition canvas in
x := ev##.clientX - x0; y := ev##.clientY - y0 in
let compute_line ev =
let oldx = !x and oldy = !y in
set_coord ev;
let h, s, v = Eliom_shared.React.S.value cp_sig in
let r, g, b = Ot_color_picker.hsv_to_rgb h s v in
let rgb = int_of_float r, int_of_float g, int_of_float b in
let size_slider = Html.To_dom.of_input slider in
let size = int_of_string (Js.to_string size_slider##.value) in
(rgb, size, (oldx, oldy), (!x, !y))
in
let line ev =
let v = compute_line ev in
let _ = Eliom_bus.write bus v in
draw ctx v;
Lwt.return ()
in
let t = Lwt_stream.iter (draw ctx) (Eliom_bus.stream bus) in
let drawing_thread =
Js_of_ocaml_lwt.Lwt_js_events.(
mousedowns canvas (fun ev elt ->
Dom.preventDefault ev;
set_coord ev;
let%lwt () = line ev in
Lwt.pick [mousemoves Dom_html.document (fun a _ -> line a);
let%lwt ev = mouseup Dom_html.document in line ev]))
in
{ message_thread = t;
drawing_thread = drawing_thread }
server.ml
It contains almost all the server parts of the code.
open Eliom_content
open Common
open Lwt
module My_app =
Eliom_registration.App (struct
let application_name = "graffiti"
let global_data_path = None
end)
The main difference is that the bus is now local.
let launch_server_canvas () =
let bus = Eliom_bus.create [%json: messages] in
let draw_server, image_string =
let rgb_ints_to_floats (r, g, b) =
float r /. 255., float g /. 255., float b /. 255. in
let surface = Cairo.Image.create Cairo.Image.ARGB32 ~w:width ~h:height in
let ctx = Cairo.create surface in
((fun (rgb, size, (x1, y1), (x2, y2)) ->
(* Set thickness of brush *)
let r, g, b = rgb_ints_to_floats rgb in
Cairo.set_line_width ctx (float size) ;
Cairo.set_line_join ctx Cairo.JOIN_ROUND ;
Cairo.set_line_cap ctx Cairo.ROUND ;
Cairo.set_source_rgb ctx r g b ;
Cairo.move_to ctx (float x1) (float y1) ;
Cairo.line_to ctx (float x2) (float y2) ;
Cairo.Path.close ctx ;
(* Apply the ink *)
Cairo.stroke ctx ;
),
(fun () ->
let b = Buffer.create 10000 in
(* Output a PNG in a string *)
Cairo.PNG.write_to_stream surface (Buffer.add_string b);
Buffer.contents b
))
in
let _ = Lwt_stream.iter draw_server (Eliom_bus.stream bus) in
bus,image_string
let graffiti_info = Hashtbl.create 0
let imageservice =
Eliom_registration.String.create
~path:(Eliom_service.Path ["image"])
~headers:
(Cohttp.Header.add_list (Cohttp.Header.init ())
[(Ocsigen_header.Name.(to_string cache_control), "no-cache") ;
(Ocsigen_header.Name.(to_string expires), string_of_int 0)])
~meth:
(Eliom_service.Get
(let open Eliom_parameter in string "name" ** int "q"))
(* we add another parameter for the browser not to cache: at least
for chrome, there is no way to force the browser to reload the
image without leaving the application *)
(fun (name,_) () ->
try%lwt
let _ ,image_string = Hashtbl.find graffiti_info name in
Lwt.return (image_string (), "image/png")
with
| Not_found -> Lwt.fail Eliom_common.Eliom_404)
let get_bus (name:string) =
(* create a new bus and image_string function only if it did not exists *)
try
fst (Hashtbl.find graffiti_info name)
with
| Not_found ->
let bus,image_string = launch_server_canvas () in
Hashtbl.add graffiti_info name (bus, image_string);
bus
The main page now contains only a form to choose to which drawing you want to go. The drawing will be sent by the multigraffiti_service service, registered in graffiti.eliom.
let main_service =
Eliom_service.create
~path:(Eliom_service.Path [""])
~meth:(Eliom_service.Get (Eliom_parameter.unit))
()
let multigraffiti_service =
Eliom_service.create
~path:(Eliom_service.Path [""])
~meth:(Eliom_service.Get (Eliom_parameter.(suffix (string "name"))))
()
let choose_drawing_form () =
Html.D.Form.get_form ~service:multigraffiti_service
(fun (name) ->
[Html.D.p [
Html.D.txt "drawing name: ";
Html.D.Form.input ~input_type:`Text ~name
Html.D.Form.string;
Html.D.br ();
Html.D.Form.input ~input_type:`Submit ~value:"Go"
Html.D.Form.string
]])
let oclosure_script =
Html.Id.create_global_elt
(Html.D.js_script
~uri:(Html.D.Raw.uri_of_string "./graffiti_oclosure.js") ())
let make_page body =
Lwt.return
(Html.D.html
(Html.D.head
(Html.D.title (Html.D.txt "Graffiti"))
[
Html.D.css_link
~uri:(Html.D.Raw.uri_of_string"./css/closure/common.css") ();
Html.D.css_link
~uri:(Html.D.Raw.uri_of_string"./css/closure/hsvpalette.css") ();
Html.D.css_link
~uri:(Html.D.Raw.uri_of_string"./css/slider.css") ();
oclosure_script;
Html.D.css_link
~uri:(Html.D.Raw.uri_of_string"./css/graffiti.css") ();
])
(Html.D.body body))
let () = My_app.register ~service:main_service
(fun () () ->
make_page [h1 [txt "Welcome to Multigraffiti"];
choose_drawing_form ()])
graffiti.eliom
Here is the code that mixes client and server parts.
We first open the corresponding modules for each parts of the application.
[%%shared
open Eliom_content.Html.D
open Common
]
[%%client
open Client
]
open Server
And then we define a function initializing the client application by side effects in a client value.
let start_drawing name image canvas slider =
let bus = get_bus name in
ignore [%client
(let canceller =
launch_client_canvas ~%bus ~%image ~%canvas ~%slider
in
Eliom_client.onunload (fun () -> stop_drawing canceller; None)
: unit)
]
The function registered by Eliom_service.onunload will be called when the page change inside the application.
And we finally register the service sending a drawing:
let counter = ref 0
let () =
My_app.register ~service:multigraffiti_service (fun name () ->
(* Some browsers won't reload the image, so we force
them by changing the url each time. *)
incr counter;
let image =
img ~alt:name
~src:(make_uri ~service:imageservice (name,!counter)) ()
in
let slider =
Form.input
~a:[
a_id "slider";
a_input_min (`Number 1);
a_input_max (`Number 80)
]
~input_type:`Range
Form.int
in
let canvas =
canvas ~a:[a_width width; a_height height]
[txt "your browser doesn't support canvas"; br (); image]
in
start_drawing name image canvas slider;
make_page
[h1 [txt name];
choose_drawing_form ();
canvas;
div [slider]])
At this point, you can run your application on the server provided that you installed the css and images directories in the main directory of your application, build it using this Makefile along with the appropriate Makefile.options, and configured it using graffiti.conf.in, as the basis for your configuration file.
Mixing client-server application with traditional web interaction
We now want to restrict the site to connected users.
From the previous chapter, we copy the code handling users to server.ml:
let connection_service = Eliom_service.create
~path:Eliom_service.No_path
~meth:(Eliom_service.Post (
Eliom_parameter.unit,
Eliom_parameter.(string "name" ** string "password")
))
()
let disconnection_service = Eliom_service.create
~path:Eliom_service.No_path
~meth:(Eliom_service.Post (Eliom_parameter.unit, Eliom_parameter.unit))
()
let create_account_service =
Eliom_service.create
~path:(Eliom_service.Path [""])
~meth:(Eliom_service.Post
(Eliom_parameter.unit,
Eliom_parameter.(string "name" ** string "password")))
let user_table = Ocsipersist.Polymorphic.open_table "user_table"
let check_pwd name pwd =
try%lwt
let%lwt saved_password = Ocsipersist.Polymorphic.find user_table name in
Lwt.return (pwd = saved_password)
with Not_found -> Lwt.return false
let () = Eliom_registration.Action.register
~service:create_account_service
(fun () (name, pwd) -> Ocsipersist.Polymorphic.add user_table name pwd)
let () = Eliom_registration.Action.register
~service:connection_service
(fun () (name, password) ->
match%lwt check_pwd name password with
| true -> Eliom_state.set_volatile_data_session_group
~scope:Eliom_common.default_session_scope name;
Lwt.return ()
| false -> Lwt.return ())
let () =
Eliom_registration.Action.register
~service:disconnection_service
(fun () () ->
Eliom_state.discard ~scope:Eliom_common.default_session_scope ())
let disconnect_box () =
Html.D.Form.post_form ~service:disconnection_service
(fun _ ->
[Html.D.p [
Html.D.Form.input
~input_type:`Submit ~value:"Log out"
Html.D.Form.string
]
]) ()
let login_name_form service button_text =
Html.D.Form.post_form ~service
(fun (name1, name2) ->
[Html.D.p [
Html.D.txt "login: ";
Html.D.Form.input ~input_type:`Text ~name:name1
Html.D.Form.string;
Html.D.br ();
Html.D.txt "password: ";
Html.D.Form.input ~input_type:`Password ~name:name2
Html.D.Form.string;
Html.D.br ();
Html.D.Form.input ~input_type:`Submit ~value:button_text
Html.D.Form.string
]]) ()
We make a customized registration module such that disconnected users (those for which the username reference is not set), are automaticaly shown a connection box. This way the other pages can assume that the username is always available.
let default_content () =
make_page
[Html.D.h1 [Html.D.txt "Welcome to Multigraffiti"];
Html.D.h2 [Html.D.txt "log in"];
login_name_form connection_service "Connect";
Html.D.h2 [Html.D.txt "create account"];
login_name_form create_account_service "Create account";]
module Connected_translate =
struct
type page = string -> My_app.page Lwt.t
let translate page =
match Eliom_state.get_volatile_data_session_group
~scope:Eliom_common.default_session_scope () with
| None -> default_content ()
| Some username -> page username
end
module Connected =
Eliom_registration.Customize (My_app) (Connected_translate)
We replace the previous main_service registration :
let () = My_app.register ~service:main_service
(fun () () ->
make_page [h1 [txt "Welcome to Multigraffiti"];
choose_drawing_form ()])
by :
let ( !% ) f = fun a b -> return (fun c -> f a b c)
let () = Connected.register
~service:main_service
!% (fun () () username ->
make_page
[Html.D.h1 [Html.D.txt ("Welcome to Multigraffiti " ^ username)];
choose_drawing_form ()])
to use that, in graffiti.eliom we just replace add a call to disconnect_box
[h1 [txt name];
disconnect_box ();
choose_drawing_form ();
canvas;])