Miscellaneous features

The code of this tutorial has been tested with Eliom 3.

Multi-user collaborative drawing application

We now want to take back our collaborative drawing application and turn it to a multi user one. Each user will have his own drawing, where everyone can draw, and the owner will have the ability to save the drawing he wants and create an Atom feed containing all saved drawings.

Download the full code of the examples or browse it online.

Split application into multiple files and using several canvas

In this first section, we will 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 be able to handle separately different drawings. To do this, we will turn all global variable, like the bus, in local ones.

When an application grows, it start being useful to split it in multiple files. For sake of 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
graffiti.eliom the only part where we need to include both client and server code

common.ml

It contains what was in {shared{ ... }}

type messages = (string * 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 function init_client is now in the function launch_client_canvas.

open Eliom_content
open Common
open Lwt

let draw ctx (color, size, (x1, y1), (x2, y2)) =
  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 =
    { drawing_thread : unit Lwt.t;
      (* the thread reading messages from the bus *)
      drawing_event_thread : unit Lwt.t;
      (* the thread handling mouse events *)
    }

let stop_drawing { drawing_thread; drawing_event_thread } =
  Lwt.cancel drawing_thread;
  (* cancelling this thread also closes the bus *)
  Lwt.cancel drawing_event_thread

Notice that the client does not keep data from pages it left. Lwt.cancel t stops the 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 =
  let canvas = Html5.To_dom.of_canvas canvas_elt in
  let ctx = canvas##getContext (Dom_html._2d_) in
  ctx##lineCap <- Js.string "round";

  let img = Html5.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);

  (* Size of the brush *)
  let slider = jsnew Goog.Ui.slider(Js.null) in
  slider##setMinimum(1.);
  slider##setMaximum(80.);
  slider##setValue(10.);
  slider##setMoveToPointEnabled(Js._true);
  slider##render(Js.some Dom_html.document##body);

  (* The color palette: *)
  let pSmall =
    jsnew Goog.Ui.hsvPalette(Js.null, Js.null,
                             Js.some (Js.string "goog-hsv-palette-sm"))
  in
  pSmall##render(Js.some Dom_html.document##body);

  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 color = Js.to_string (pSmall##getColor()) in
    let size = int_of_float (Js.to_float (slider##getValue())) in
    (color, 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_event_thread =
    let open Lwt_js_events in
    mousedowns canvas
      (fun ev _ -> set_coord ev; line ev >>= fun () ->
        Lwt.pick [mousemoves Dom_html.document (fun x _ -> line x);
		  mouseup Dom_html.document >>= line])
  in
  { drawing_thread = t;
    drawing_event_thread = drawing_event_thread }

server.ml

It contains almost all the server parts of the code.

open Eliom_content
open Eliom_content.Html5.D
open Common

module My_app =
  Eliom_registration.App (
    struct
      let application_name = "graffiti"
    end)

let rgb_from_string color = (* color is in format "#rrggbb" *)
  let get_color i =
    (float_of_string ("0x"^(String.sub color (1+2*i) 2))) /. 255.
  in
  try get_color 0, get_color 1, get_color 2 with | _ -> 0.,0.,0.

The main difference is that the bus is now local.

let launch_server_canvas () =
  let bus = Eliom_bus.create Json.t<messages> in

  let draw_server, image_string =
    let surface = Cairo.image_surface_create
      Cairo.FORMAT_ARGB32 ~width ~height in
    let ctx = Cairo.create surface in
    ((fun ((color : string), size, (x1, y1), (x2, y2)) ->

      (* Set thickness of brush *)
      Cairo.set_line_width ctx (float size) ;
      Cairo.set_line_join ctx Cairo.LINE_JOIN_ROUND ;
      Cairo.set_line_cap ctx Cairo.LINE_CAP_ROUND ;
      let red, green, blue =  rgb_from_string color in
      Cairo.set_source_rgb ctx ~red ~green ~blue ;

      Cairo.move_to ctx (float x1) (float y1) ;
      Cairo.line_to ctx (float x2) (float y2) ;
      Cairo.close_path ctx ;

      (* Apply the ink *)
      Cairo.stroke ctx ;
     ),
     (fun () ->
       let b = Buffer.create 10000 in
       (* Output a PNG in a string *)
       Cairo_png.surface_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.register_service
    ~path:["image"]
    ~headers:Http_headers.dyn_headers
    ~get_params:(let open Eliom_parameter in string "name" ** int "q")
    (* we add an int parameter for the browser not to cache the image:
       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 -> raise_lwt 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.service ~path:[""]
  ~get_params:(Eliom_parameter.unit) ()
let multigraffiti_service = Eliom_service.service ~path:[""]
  ~get_params:(Eliom_parameter.suffix (Eliom_parameter.string "name")) ()

let choose_drawing_form () =
  get_form ~service:multigraffiti_service
    (fun (name) ->
      [fieldset
          [label ~a:[a_for name]
             [pcdata "drawing name: "];
           string_input ~input_type:`Text ~name ();
           br ();
           string_input ~input_type:`Submit ~value:"Go" ()
          ]])

let oclosure_script =
  Html5.Id.create_global_elt
    (js_script
       ~uri:(make_uri  (Eliom_service.static_dir ())
               ["graffiti_oclosure.js"]) ())

let make_page content =
  Lwt.return
    (html
       (head
	  (title (pcdata "Graffiti"))
       [ css_link
           ~uri:(make_uri (Eliom_service.static_dir ())
                  ["css";"common.css"]) ();
         css_link
           ~uri:(make_uri (Eliom_service.static_dir ())
                  ["css";"hsvpalette.css"]) ();
         css_link
           ~uri:(make_uri (Eliom_service.static_dir ())
                  ["css";"slider.css"]) ();
         oclosure_script;
         css_link
           ~uri:(make_uri (Eliom_service.static_dir ())
                  ["css";"graffiti.css"]) ();
       ])
       (body content))

let () = My_app.register ~service:main_service
  (fun () () ->
    make_page [h1 [pcdata "Welcome to Multigraffiti"];
	       choose_drawing_form ()])

Concept: Global node and scripts

Sometimes we need to control when a script is loaded and reloaded on page change. Since clicking on links in an Eliom application do not reload the entire page, already loaded libraries stay loaded. But if we simply add a script to each page, it will be loaded each time. We usually don't want that.

Using Eliom_content.Html5.Id.create_global_elt we can create an xml node manipulated 'by reference'. If a reference to a script node is included in a page, it will only be loaded the first time it appears in the header. Such a node can be created that way:

let oclosure_script =
  Eliom_content.Html5.Id.create_global_elt
    (js_script
       ~uri:(make_uri  (Eliom_service.static_dir ())
               ["graffiti_oclosure.js"]) ())

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.Html5.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 =
  let bus = get_bus name in
  ignore {unit{
    let canceller = launch_client_canvas %bus %image %canvas in
    Eliom_client.onunload (fun () -> stop_drawing canceller)
  }}

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 canvas =
      canvas ~a:[ a_width width; a_height height ]
        [pcdata "your browser doesn't support canvas"; br (); image] in
    start_drawing name image canvas;
    make_page
      [h1 [pcdata name];
       choose_drawing_form ();
       canvas;])

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 this Makefile.common and configured it using graffiti.conf.in as groundwork of 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.post_coservice' ~post_params:
    (let open Eliom_parameter in (string "name" ** string "password")) ()
let disconnection_service = Eliom_service.post_coservice'
  ~post_params:Eliom_parameter.unit ()
let create_account_service =
  Eliom_service.post_coservice ~fallback:main_service ~post_params:
  (let open Eliom_parameter in (string "name" ** string "password")) ()

let username = Eliom_reference.eref ~scope:Eliom_common.default_session_scope None

let users = ref ["user","password";"test","test"]

let check_pwd name pwd =
 try Lwt.return (List.assoc name !users = pwd) with
   | Not_found -> Lwt.return false

let () = Eliom_registration.Action.register
  ~service:create_account_service
  (fun () (name, pwd) ->
    users := (name, pwd)::!users;
    Lwt.return ())

let () = Eliom_registration.Action.register
  ~service:connection_service
  (fun () (name, password) ->
    match_lwt check_pwd name password with
      | true -> Eliom_reference.set username (Some name)
      | false -> Lwt.return ())

let () =
  Eliom_registration.Action.register
    ~service:disconnection_service
    (fun () () -> Eliom_state.discard ~scope:Eliom_common.default_session_scope ())

let disconnect_box () =
  post_form disconnection_service
    (fun _ -> [fieldset
                 [string_input ~input_type:`Submit ~value:"Log out" ()]]) ()

let login_name_form service button_text =
  post_form ~service
    (fun (name1, name2) ->
      [fieldset
         [label ~a:[a_for name1] [pcdata "login: "];
          string_input ~input_type:`Text ~name:name1 ();
          br ();
          label ~a:[a_for name2] [pcdata "password: "];
          string_input ~input_type:`Password ~name:name2 ();
          br ();
          string_input ~input_type:`Submit ~value:button_text ()
         ]]) ()

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. That way the other pages can assume that the username is always available.

let default_content () =
  make_page
    [h1 [pcdata "Welcome to Multigraffiti"];
     h2 [pcdata "log in"];
     login_name_form connection_service "Connect";
     h2 [pcdata "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_lwt Eliom_reference.get username 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 [pcdata "Welcome to Multigraffiti"];
	       choose_drawing_form ()])

by :

let () = Connected.register ~service:main_service
  (fun () () ->
    Lwt.return
      (fun username ->
        make_page
          [h1 [pcdata ("Welcome to Multigraffiti " ^ username)];
          choose_drawing_form ()]))

to use that, in graffiti.eliom we just replace add a call to disconnect_box

[h1 [pcdata name];
       disconnect_box ();
       choose_drawing_form ();
       canvas;])