Miscellaneous features

The code of this tutorial has been tested with the 2.1 release of the Ocsigen bundle.

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 Eliom_services.onload {{ }} is now in the function launch_client_canvas.

open Eliom_pervasives
open Common
open Event_arrows

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()

let launch_client_canvas bus image_elt canvas_elt =
  let canvas = Eliom_client.Html5.of_canvas canvas_elt in
  let ctx = canvas##getContext (Dom_html._2d_) in
  ctx##lineCap <- Js.string "round";

  let img = Eliom_client.Html5.of_img image_elt in
  let copy_image () = ctx##drawImage(img, 0., 0.) in
  if Js.to_bool (img##complete)
  then copy_image ()
  else (Eliom_client.Html5.of_img image_elt)##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
  in
  let _ = Lwt_stream.iter (draw ctx) (Eliom_bus.stream bus) in
  ignore (run (mousedowns canvas
                 (arr (fun ev -> set_coord ev; line ev)
                          >>> first [mousemoves Dom_html.document (arr line);
                                      mouseup Dom_html.document >>>
                                        (arr line)])) ())

server.ml

It contains almost all the server parts of the code.

open HTML5
open Common
open Lwt

module My_appl =
  Eliom_output.Eliom_appl (
    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 in 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_output.Text.register_service
    ~path:["image"]
    ~headers:Http_headers.dyn_headers
    ~get_params:(let open Eliom_parameters 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_services.service ~path:[""]
  ~get_params:(Eliom_parameters.unit) ()
let multigraffiti_service = Eliom_services.service ~path:[""]
  ~get_params:(Eliom_parameters.suffix (Eliom_parameters.string "name")) ()

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

let oclosure_script =
  HTML5.create_global_elt
    (Eliom_output.Html5_forms.js_script
       ~uri:(Eliom_output.Html5.make_uri  (Eliom_services.static_dir ())
               ["graffiti_oclosure.js"]) ())

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

let () = My_appl.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_pervasives.HTML5.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 =
  HTML5.create_global_elt
    (Eliom_output.Html5_forms.js_script
       ~uri:(Eliom_output.Html5.make_uri  (Eliom_services.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 HTML5
  open Common
}}
{client{
  open Client
}}
open Server

And then we define the function adding the onload handler.

let start_drawing name image canvas =
  let bus = get_bus name in
  Eliom_services.onload
    {{
      let canceller = launch_client_canvas %bus %image %canvas in
      Eliom_client.on_unload (fun () -> stop_drawing canceller)
    }}

And we finally register the service sending a drawing:

let counter = ref 0

let () = My_appl.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 = unique (img ~alt:name
      ~src:(Eliom_output.Html5.make_string_uri
      ~service:imageservice (name,!counter)) ()) in
    let canvas = unique
      (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;])

Makefile

We now need to change the makefile to adapt to these changes. First, we add the files to the list of files which need to be compiled. The order is important, the makefile does not resolve dependencies.

SERVER_FILES := common.ml server.ml ${wildcard *.eliom}
CLIENT_FILES := common.ml client.ml ${wildcard *.eliom}

Cleaning previous pages

A problem with the current version is that the client keeps receiving data from pages it left.

Add this to client.ml

(* 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_arrow : Event_arrows.canceller;
      (* the arrow handling mouse events *)
    }

let stop_drawing { drawing_thread; drawing_arrow } =
  Lwt.cancel drawing_thread;
  (* cancelling this thread also close the bus *)
  Event_arrows.cancel drawing_arrow

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.

We now need to keep the event arrow and the thread receiving data to build the drawing_canceller. We replace their delarations in client.ml by:

let t = Lwt_stream.iter (draw ctx) (Eliom_bus.stream bus) in
  let drawing_arrow =
    run (mousedowns canvas
           (arr (fun ev -> set_coord ev; line ev) >>>
            first [mousemoves Dom_html.document (arr line);
                   mouseup Dom_html.document >>> (arr line)])) () in
  { drawing_thread = t;
    drawing_arrow = drawing_arrow }

And keep it in graffiti.eliom:

Eliom_services.onload
    {{
      let canceller =
        launch_client_canvas
          %bus %imageservice (Eliom_client.Html5.of_div %canvas_box)
      in
      Eliom_client.on_unload (fun () -> stop_drawing canceller)
    }}

The function registered by Eliom_services.on_unload will be called when the page change inside the application.

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_services.post_coservice' ~post_params:
    (let open Eliom_parameters in (string "name" ** string "password")) ()
let disconnection_service = Eliom_services.post_coservice'
  ~post_params:Eliom_parameters.unit ()
let create_account_service =
  Eliom_services.post_coservice ~fallback:main_service ~post_params:
  (let open Eliom_parameters in (string "name" ** string "password")) ()

let username = Eliom_references.eref ~scope:`Session 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_output.Action.register
  ~service:create_account_service
  (fun () (name, pwd) ->
    users := (name, pwd)::!users;
    Lwt.return ())

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

let () =
  Eliom_output.Action.register
    ~service:disconnection_service
    (fun () () -> Eliom_state.close_session ())

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

let login_name_form service button_text =
  My_appl.post_form ~service
    (fun (name1, name2) ->
      [fieldset
         [label ~a:[Eliom_output.Html5.a_for name1] [pcdata "login: "];
          My_appl.string_input ~input_type:`Text ~name:name1 ();
          br ();
          label ~a:[Eliom_output.Html5.a_for name2] [pcdata "password: "];
          My_appl.string_input ~input_type:`Password ~name:name2 ();
          br ();
          My_appl.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 () =
  [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 ->
    [ HTML5_types.body_content_fun ] HTML5.elt list Lwt.t
  let translate page =
    Eliom_references.get username >>= function
      | None -> Lwt.return (create_page (default_content ()))
      | Some username -> page username >|= fun v ->
        create_page ((disconnect_box ())::v)
end

module Connected =
  Eliom_output.Customize (struct
    type options = Eliom_output.appl_service_options
    type return = My_appl.return
    type page = Eliom_output.Html5.page
    type result = My_appl.result
  end) (My_appl) (Connected_translate)

let ( !% ) f = fun a b -> return (fun c -> f a b c)

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

to use that, in graffiti.eliom we just replace

let () = My_appl.register ~service:multigraffiti_service
  (fun name () -> ... )

let () = Connected.register ~service:multigraffiti_service
  !% (fun name () username -> ...

Type safe database requests using Macaque

In this section we will replace our dumb user handling code (check_pwd and create_account_service) by one using a real database backend.

We will implement our database access function using the Macaque library, that allows easy manipulation of Postgresql database fully compatible with Lwt. (For more information see Macaque manual).

We will store the login and the password of users in a Postgresql database. For more information on how to set up and run it, see Postgresql manual.

When the base is up and running, we create the base by running is a shell:

$ createdb testbase

Then we create the users table, by executing this sql script:

CREATE TABLE users (
       login text NOT NULL,
       password text NOT NULL
);

We save it under create_table.sql and run

$ psql -d testbase -f create_table.sql

Macaque can use any thread library that provides a monadic interface. The default one provides simple blocking access to the database. It isn't good for us because an access to the base by one user will prevent the server from handling anything else until the request is finished. We need a version of Macaque specialised for Lwt. It is obtained by

module Lwt_thread = struct
  include Lwt
  include Lwt_chan
end
module Lwt_PGOCaml = PGOCaml_generic.Make(Lwt_thread)
module Lwt_Query = Query.Make_with_Db(Lwt_thread)(Lwt_PGOCaml)

We can now open the database with our newly created Lwt_PGOCaml.connect.

let get_db : unit -> unit Lwt_PGOCaml.t Lwt.t =
  let db_handler = ref None in
  fun () ->
    match !db_handler with
      | Some h -> Lwt.return h
      | None -> Lwt_PGOCaml.connect ~database:"testbase" ()

Then we declare the table on which we will work and the different requests we do on it.

let table = <:table< users (
  login text NOT NULL,
  password text NOT NULL
) >>

let find name =
  (get_db () >>= fun dbh ->
   Lwt_Query.view dbh
   <:view< {password = row.password} |
            row in $table$;
            row.login = $string:name$; >>)

let insert name pwd =
  get_db () >>= fun dbh ->
  Lwt_Query.query dbh
  <:insert< $table$ := { login = $string:name$; password = $string:pwd$; } >>

let check_pwd name pwd =
  (get_db () >>= fun dbh ->
   Lwt_Query.view dbh
   <:view< {password = row.password} |
            row in $table$;
            row.login = $string:name$;
	    row.password = $string:pwd$ >>)
  >|= (function [] -> false | _ -> true)

Finally, we change a bit the handler of create_account_service to check for the presence of an account before creating it.

let () = Eliom_output.Action.register
  ~service:create_account_service
  (fun () (name, pwd) ->
    find name >>=
      (function
	| [] -> insert name pwd
	| _ -> Lwt.return ()) )

We need to add macaque.syntax in the makefile and <extension findlib-package="macaque"/> in graffiti.conf

Lightweight database using Ocsipersist

For maintaining the list of user and password, we do not need the full power of a SQL database, a key/value table is sufficient. Ocsigen has such a simple table mechanism directly integrated: Ocsipersist.

We first create a table holding ocaml values:

let user_table = Ocsipersist.open_table "user_table"

Then we can easily replace the user management code:

let check_pwd name pwd =
  try_lwt
    lwt saved_password = Ocsipersist.find user_table name in
    Lwt.return (pwd = saved_password)
  with
    Not_found -> Lwt.return false

let () = Eliom_output.Action.register
  ~service:create_account_service
  (fun () (name, pwd) -> Ocsipersist.add user_table name pwd)

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

Saving favorite pictures

We will now add a button to the application to save the current image. The images will be saved to the filesystem using the module Lwt_io. We will then make an Atom feed with the saved images using Atom_feed.

We save the images in the directory containing the static contents under the directory graffiti_saved/username. The username directory is created if needed. If it already exists mkdir fails and we do nothing.

We will add this code in a new file:

feed.ml

let static_dir = "/tmp/static/"

let image_dir name =
  let dir = static_dir ^ "/graffiti_saved/" ^ (Url.encode name) in
  (try_lwt Lwt_unix.mkdir dir 511 with
    | _ -> debug "could not create the directory %s" dir; Lwt.return ())
  >|= (fun () -> dir)

let make_filename name number =
  image_dir name >|= fun dir ->
  dir ^ "/" ^ (string_of_int number) ^ ".png"

let save image name number =
  lwt file_name = make_filename name number in
  lwt out_chan = Lwt_io.open_file ~mode:Lwt_io.output file_name in
  Lwt_io.write out_chan image

We number images and associate to each image the time of creation. It is stocked in an Ocsipersist table.

let image_info_table = Ocsipersist.open_table "image_info_table"

For each user, we stock a value of type
int * CalendarLib.Calendar.t * ((int * CalendarLib.Calendar.t) list). The first integer is the name under which will be saved the image, the first time is the last update for that user and the list contains the names and times of old images. We need those times to timestamp the entries of the feed.

let save_image username =
  let now = CalendarLib.Calendar.now () in
  lwt number,_,list =
    try_lwt Ocsipersist.find image_info_table username with
      | Not_found -> Lwt.return (0,now,[])
      | e -> Lwt.fail e
  in
  lwt () = Ocsipersist.add image_info_table
    username (number+1,now,(number,now)::list) in
  let (_,image_string) = Hashtbl.find graffiti_info username in
  save (image_string ()) username number

let save_image_box name =
  let save_image_service =
    Eliom_output.Action.register_post_coservice'
      ~post_params:Eliom_parameters.unit
      (fun () () -> save_image name)
  in
  Eliom_output.Html5.post_form save_image_service
    (fun _ ->
      [fieldset
          [Eliom_output.Html5.string_input
             ~input_type:`Submit ~value:"save" ()]]) ()

We find the url of the images with Eliom_services.static_dir. It is a service taking file path as parameter, serving the content of the static directory. We use Eliom_uri.make_string_uri to get the url as a string.

let feed_service = Eliom_services.service ~path:["feed"]
  ~get_params:(Eliom_parameters.string "name") ()

let local_filename name number =
  ["graffiti_saved"; Url.encode name ; (string_of_int number) ^ ".png"]

let rec entries name list = function
  | 0 -> []
  | len ->
    match list with
      | [] -> []
      | (n,saved)::q ->
	let title = Atom_feed.plain
	  ("graffiti " ^ name ^ " " ^ (string_of_int n)) in
	let uri =
	  Eliom_output.Xhtml.make_uri ~absolute:true
	    ~service:(Eliom_services.static_dir ())
	    (local_filename name n)
	in
	let entry =
	  Atom_feed.entry ~title ~id:uri ~updated:saved
            [Atom_feed.xhtmlC [ XHTML.M.img ~src:uri ~alt:"image" ()]] in
	entry::(entries name q (len - 1))

let feed name () =
  let id = Eliom_output.Xhtml.make_uri ~absolute:true
    ~service:feed_service name in
  let title = Atom_feed.plain ("Nice drawings by " ^ name) in
  try_lwt
    Ocsipersist.find image_info_table name >|=
      (fun (number,updated,list) ->
	Atom_feed.feed ~id ~updated ~title (entries name list 10))
  with
    | Not_found ->
      let now = CalendarLib.Calendar.now () in
      Lwt.return (Atom_feed.feed ~id ~updated:now ~title [])
    | e -> Lwt.fail e

let () = Eliom_atom.Reg.register ~service:feed_service feed

In graffiti.eliom, we add a link to the feed and a save button that appears only if the user owns the page.

Eliom_output.Html5.a feed_service [pcdata "atom feed"] name;
    div (if name = username
      then [save_image_box name]
      else [pcdata "no saving"]);

Before running, add the graffiti_saved directory in your directory containing static contents and edit let static_dir = "/tmp/static/" to adapt to your configuration.

Custom configuration options

It is not convenient to have to edit the code to change some configurations, like the location where are saved the favorite images. Fortunately Ocsigen provides a mechanism to extend its configuration file.

let static_dir =
  match Eliom_config.get_config () with
    | [Simplexmlparser.Element
     ("staticdir", [], [Simplexmlparser.PCData dir])] ->
        dir
    | [] ->
      raise (Ocsigen_extensions.Error_in_config_file
               ("staticdir must be configured"))
    | _ ->
      raise (Ocsigen_extensions.Error_in_config_file
               ("Unexpected content inside graffiti config"))

This will add a mandatory child to the eliom tag of graffiti in the configuration file:

<eliom module="path/to/graffiti.cma">
  <staticdir>/tmp/static</staticdir>
</eliom>

Connection with external accounts

Listening music

We will add an audio player to the page that will stay when page change. This emphasises the fact that browsing inside an application does not stop the client side code: the music keeps playing when the content of the page and the url change.

We first create the player node at toplevel.

let player =
  create_global_elt
    (audio
       ~srcs:(Eliom_output.Html5.make_uri (Eliom_services.static_dir ())
                  ["music.ogg"],
              [])
       ~a:[a_autoplay (`Autoplay);a_controls (`Controls)]
       [pcdata "Your browser does not support audio element" ])

And we insert the player in the page:

...
       canvas;
       player])

And that's all ! Since the player node is declared unique, no new player is created when the page changed: this is exact same node.

To run this example, you will need to add an ogg file in the static directory. If you can't find one, there is one here: http://www.gnu.org/music/free-software-song.html.