Ocsigen

Home

Doc

Eliom

Js_of_ocaml

Server

Lwt

Tyxml

Start

Warning: Reason support is experimental. We are looking for beta-tester and contributors.

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;])

prev