Migration to Eio

Makefile

@@ -62,7 +62,7 @@ eliomdep=$(3)
 # endif
 objs=$(patsubst %.ml,$(1)/%.$(2),$(patsubst %.eliom,$(1)/%.$(2),$(filter %.eliom %.ml,$(3))))
 #depsort=$(call objs,$(1),$(2),$(call eliomdep,$(3),$(4),$(5)))
-depsort=$(shell ocaml tools/sort_deps.ml .depend $(patsubst %.ml,$(1)/%.$(2),$(patsubst %.eliom,$(1)/%.$(2),$(filter %.eliom %.ml,$(5)))))
+depsort=$(shell ocaml tools/sort_deps.ml .depend -I str $(patsubst %.ml,$(1)/%.$(2),$(patsubst %.eliom,$(1)/%.$(2),$(filter %.eliom %.ml,$(5)))))
 
 $(LIBDIR):
 	mkdir $(LIBDIR)
@@ -231,7 +231,7 @@ COMMON_OPTIONS := -colorize-code -stars -sort
 eliomdoc_wiki = ODOC_WIKI_SUBPROJECT="$(1)" \
                 eliomdoc \
                 -$(1) \
-                -ppx -package resource-pooling,pgocaml,yojson,calendar,ocsigen-toolkit.$(1) \
+                -ppx -package pgocaml,yojson,calendar,ocsigen-toolkit.$(1) \
                 -intro doc/indexdoc.$(1) $(COMMON_OPTIONS) \
                 -i $(shell ocamlfind query wikidoc) \
                 -g odoc_wiki.cma \
@@ -242,7 +242,7 @@ eliomdoc_wiki = ODOC_WIKI_SUBPROJECT="$(1)" \
 eliomdoc_html = ODOC_WIKI_SUBPROJECT="$(1)" \
                 eliomdoc \
                 -$(1) \
-                -ppx -package resource-pooling,pgocaml,yojson,calendar,ocsigen-toolkit.$(1) \
+                -ppx -package pgocaml,yojson,calendar,ocsigen-toolkit.$(1) \
                 -intro doc/indexdoc.$(1) \
                 $(COMMON_OPTIONS) \
                 -html \

Makefile.options

@@ -54,8 +54,8 @@ SASS_TEMPORARY_PROJECT_NAME := os_temporary_project_name
 ##----------------------------------------------------------------------
 
 # OCamlfind packages for the server
-SERVER_PACKAGES    := calendar safepass \
-                      ocsigen-toolkit.server yojson re.str cohttp-lwt-unix
+SERVER_PACKAGES    := calendar safepass pgocaml \
+                      ocsigen-toolkit.server yojson re.str cohttp-eio
 
 SERVER_PPX_PACKAGES := js_of_ocaml-ppx_deriving_json ocsigen-ppx-rpc
 

opam

@@ -28,10 +28,10 @@ depends: [
   "ocsigen-ppx-rpc"
   "ocsigen-i18n" {>= "3.7.0"}
   "yojson" {>= "1.6.0"}
-  "resource-pooling" {>= "1.0" & < "2.0"}
   "cohttp-lwt-unix"
   "js_of_ocaml" {>= "6.0.0"}
   "re" {>= "1.7.2"}
+  "resource-pooling"
 ]
 depexts: [
   ["imagemagick" "ruby-sass" "postgresql" "postgresql-common"] {os-family = "debian"}

src/os_comet.eliom

@@ -18,12 +18,11 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-open%client Lwt.Syntax
-open%client Js_of_ocaml
-open%client Js_of_ocaml_lwt
-
 let%shared __link = () (* to make sure os_comet is linked *)
 
+open%client Js_of_ocaml
+open%client Js_of_ocaml_eio
+
 let%client cookies_enabled () =
   try
     Dom_html.document##.cookie := Js.string "cookietest=1";
@@ -51,8 +50,12 @@ let%client restart_process () =
   then Eliom_client.exit_to ~service:Eliom_service.reload_action () ()
 
 let%client _ =
-  Eliom_comet.set_handle_exn_function (fun ?exn:_ () ->
-    restart_process (); Lwt.return_unit)
+  Eliom_comet.set_handle_exn_function (fun ?exn () ->
+    Logs.err (fun fmt ->
+      fmt "Eliom_comet exception: %s"
+        (match exn with Some e -> Printexc.to_string e | None -> "unknown"))
+    (* TODO: re-enable restart_process () after fixing comet channel issues *)
+  )
 
 (* We create a channel on scope user_indep_process_scope,
    to monitor the application.
@@ -86,25 +89,23 @@ let already_send_ref =
 
 let%client handle_error =
   ref (fun exn ->
-    Logs.info (fun fmt ->
+    Logs.err (fun fmt ->
       fmt
         ("Exception received on Os_comet's monitor channel: " ^^ "@\n%s")
-        (Printexc.to_string exn));
-    restart_process ();
-    Lwt.return_unit)
+        (Printexc.to_string exn))
+    (* TODO: re-enable restart_process () after fixing comet channel issues *)
+    )
 
 let%client set_error_handler f = handle_error := f
 
 let%client handle_message = function
   | Error exn -> !handle_error exn
-  | Ok Heartbeat ->
-      Logs.info (fun fmt -> fmt "poum");
-      Lwt.return_unit
+  | Ok Heartbeat -> Logs.info (fun fmt -> fmt "poum")
   | Ok Connection_changed ->
       Os_msg.msg ~level:`Err
         "Connection has changed from outside. Program will restart.";
-      let* () = Lwt_js.sleep 2. in
-      restart_process (); Lwt.return_unit
+      Eio_js.sleep 2.;
+      restart_process ()
 
 let%server warn_state c state =
   match Eliom_reference.Volatile.Ext.get state monitor_channel_ref with
@@ -118,13 +119,15 @@ let%server _ =
   Os_session.on_start_process (fun _ ->
     let channel = create_monitor_channel () in
     Eliom_reference.Volatile.set monitor_channel_ref (Some channel);
+    Logs.info (fun fmt -> fmt "[Os_comet] Monitor channel created on server");
     ignore
       [%client
-        (Lwt.async (fun () ->
-           Lwt_stream.iter_s handle_message
-             (Lwt_stream.wrap_exn ~%(fst channel)))
-         : unit)];
-    Lwt.return_unit);
+        (Logs.info (fun fmt -> fmt "[Os_comet] Client starting monitor channel listener");
+         Eio_js.start (fun () ->
+           Logs.info (fun fmt -> fmt "[Os_comet] Inside Eio_js.start, about to iter_s");
+           Eliom_stream.iter_s handle_message
+             (Eliom_stream.wrap_exn ~%(fst channel)))
+         : unit)]);
   let warn c =
     (* User connected or disconnected.
        I want to send the message on all tabs of the browser: *)
@@ -138,8 +141,7 @@ let%server _ =
              ~scope:Os_session.user_indep_session_scope ()) (fun state ->
         match Eliom_reference.Volatile.Ext.get state monitor_channel_ref with
         | Some (_, send) as v -> if not (v == cur) then send c
-        | None -> ()));
-    Lwt.return_unit
+        | None -> ()))
   in
   let warn_connection_change _ = warn Connection_changed in
   Os_session.on_open_session warn_connection_change;

src/os_comet.eliomi

@@ -39,4 +39,4 @@ val restart_process : unit -> unit
     subproject="server" | module Eliom_client.exit_to>>
  *)
 
-val set_error_handler : (exn -> unit Lwt.t) -> unit
+val set_error_handler : (exn -> unit) -> unit

src/os_connect_phone.eliom

@@ -18,8 +18,6 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-open%server Lwt.Syntax
-
 type%shared sms_error_core = [`Unknown | `Send | `Limit | `Invalid_number]
 type%shared sms_error = [`Ownership | sms_error_core]
 
@@ -46,112 +44,99 @@ let send_sms_handler =
   Printf.printf
     "INFO: send SMS %s to %s\nYou have not defined an SMS handler.\nPlease see Os_connect_phone.set_send_sms_handler\n%!"
     message number;
-  Lwt.return (Error `Send)
+  Error `Send
 
 let set_send_sms_handler = ( := ) send_sms_handler
 
-let send_sms ~number message : (unit, sms_error_core) result Lwt.t =
+let send_sms ~number message : (unit, sms_error_core) result =
   !send_sms_handler ~number message
 
 let%server request_code reference number =
-  Lwt.catch
-    (fun () ->
-       let* attempt =
-         Lwt.bind (Eliom_reference.get reference) (function
-           | Some (_, _, attempt) -> Lwt.return attempt
-           | None -> Lwt.return 0)
-       in
-       if attempt <= 3
-       then
-         let attempt = attempt + 1 and code = activation_code () in
-         let* () =
-           Eliom_reference.set reference (Some (number, code, attempt))
-         in
-         Lwt.catch
-           (fun () -> (send_sms ~number code :> (unit, sms_error) result Lwt.t))
-           (fun _ -> Lwt.return (Error `Send))
-       else Lwt.return (Error `Limit))
-    (fun _ -> Lwt.return (Error `Unknown))
+  try
+    let attempt =
+      match Eliom_reference.get reference with
+      | Some (_, _, attempt) -> attempt
+      | None -> 0
+    in
+    if attempt <= 3
+    then
+      let attempt = attempt + 1 and code = activation_code () in
+      let () = Eliom_reference.set reference (Some (number, code, attempt)) in
+      try (send_sms ~number code :> (unit, sms_error) result)
+      with _ -> Error `Send
+    else Error `Limit
+  with _ -> Error `Unknown
 
 let%server request_wrapper number f =
   if Re.Str.string_match Os_lib.phone_regexp number 0
   then f number
-  else Lwt.return (Error `Invalid_number)
+  else Error `Invalid_number
 
-let%rpc request_recovery_code (number : string) : (unit, sms_error) result Lwt.t
-  =
+let%rpc request_recovery_code (number : string) : (unit, sms_error) result =
   request_wrapper number @@ fun number ->
-  let* b = Os_db.Phone.exists number in
-  if not b
-  then Lwt.return (Error `Ownership)
-  else request_code recovery_code_ref number
+  let b = Os_db.Phone.exists number in
+  if not b then Error `Ownership else request_code recovery_code_ref number
 
-let%rpc request_code (number : string) : (unit, sms_error) result Lwt.t =
+let%rpc request_code (number : string) : (unit, sms_error) result =
   request_wrapper number @@ fun number ->
-  let* b = Os_db.Phone.exists number in
-  if b
-  then Lwt.return (Error `Ownership)
-  else request_code activation_code_ref number
+  let b = Os_db.Phone.exists number in
+  if b then Error `Ownership else request_code activation_code_ref number
 
 let%server confirm_code myid code =
-  Lwt.bind (Eliom_reference.get activation_code_ref) (function
-    | Some (number, code', _) when code = code' -> Os_db.Phone.add myid number
-    | _ -> Lwt.return_false)
+  match Eliom_reference.get activation_code_ref with
+  | Some (number, code', _) when code = code' -> Os_db.Phone.add myid number
+  | _ -> false
 
-let%rpc confirm_code_extra myid (code : string) : bool Lwt.t =
-  confirm_code myid code
+let%rpc confirm_code_extra myid (code : string) : bool = confirm_code myid code
 
 let%server
     confirm_code_signup_no_connect ~first_name ~last_name ~code ~password ()
   =
-  Lwt.bind (Eliom_reference.get activation_code_ref) (function
-    | Some (number, code', _) when code = code' ->
-        let* () = Eliom_reference.set activation_code_ref None in
-        let* user =
-          Os_user.create ~password ~firstname:first_name ~lastname:last_name ()
-        in
-        let userid = Os_user.userid_of_user user in
-        let* _ = Os_db.Phone.add userid number in
-        Lwt.return_some userid
-    | _ -> Lwt.return_none)
+  match Eliom_reference.get activation_code_ref with
+  | Some (number, code', _) when code = code' ->
+      let () = Eliom_reference.set activation_code_ref None in
+      let user =
+        Os_user.create ~password ~firstname:first_name ~lastname:last_name ()
+      in
+      let userid = Os_user.userid_of_user user in
+      let _ = Os_db.Phone.add userid number in
+      Some userid
+  | _ -> None
 
 let%rpc
     confirm_code_signup
       ~(first_name : string)
       ~(last_name : string)
       ~(code : string)
       ~(password : string)
-      () : bool Lwt.t
+      () : bool
   =
-  Lwt.bind
-    (confirm_code_signup_no_connect ~first_name ~last_name ~code ~password ())
-    (function
-    | None -> Lwt.return_false
+  match
+    confirm_code_signup_no_connect ~first_name ~last_name ~code ~password ()
+  with
+  | None -> false
+  | Some userid ->
+      let () = Os_session.connect userid in
+      true
+
+let%rpc confirm_code_recovery (code : string) : bool =
+  match Eliom_reference.get recovery_code_ref with
+  | Some (number, code', _) when code = code' -> (
+    match Os_db.Phone.userid number with
     | Some userid ->
-        let* () = Os_session.connect userid in
-        Lwt.return_true)
-
-let%rpc confirm_code_recovery (code : string) : bool Lwt.t =
-  Lwt.bind (Eliom_reference.get recovery_code_ref) (function
-    | Some (number, code', _) when code = code' ->
-        Lwt.bind (Os_db.Phone.userid number) (function
-          | Some userid ->
-              let* () = Os_session.connect userid in
-              Lwt.return_true
-          | None -> Lwt.return_false)
-    | _ -> Lwt.return_false)
+        let () = Os_session.connect userid in
+        true
+    | None -> false)
+  | _ -> false
 
 let%rpc connect ~(keepmeloggedin : bool) ~(password : string) (number : string)
-  : [`Login_ok | `Wrong_password | `No_such_user | `Password_not_set] Lwt.t
+  : [`Login_ok | `Wrong_password | `No_such_user | `Password_not_set]
   =
-  Lwt.catch
-    (fun () ->
-       let* userid = Os_db.User.verify_password_phone ~password ~number in
-       let* () = Os_session.connect ~expire:(not keepmeloggedin) userid in
-       Lwt.return `Login_ok)
-    (function
-      | Os_db.Empty_password | Os_db.Wrong_password ->
-          Lwt.return `Wrong_password
-      | Os_db.No_such_user -> Lwt.return `No_such_user
-      | Os_db.Password_not_set -> Lwt.return `Password_not_set
-      | exc -> Lwt.reraise exc)
+  try
+    let userid = Os_db.User.verify_password_phone ~password ~number in
+    let () = Os_session.connect ~expire:(not keepmeloggedin) userid in
+    `Login_ok
+  with
+  | Os_db.Empty_password | Os_db.Wrong_password -> `Wrong_password
+  | Os_db.No_such_user -> `No_such_user
+  | Os_db.Password_not_set -> `Password_not_set

src/os_connect_phone.eliomi

@@ -26,7 +26,7 @@ type sms_error_core = [`Unknown | `Send | `Limit | `Invalid_number]
 [%%server.start]
 
 val set_send_sms_handler :
-   (number:string -> string -> (unit, sms_error_core) result Lwt.t)
+   (number:string -> string -> (unit, sms_error_core) result)
   -> unit
 (** [set_send_sms_handler f] registers [f] as the function to be
     called to send SMS messages. Used to send activation codes for
@@ -38,25 +38,25 @@ val confirm_code_signup_no_connect :
   -> code:string
   -> password:string
   -> unit
-  -> Os_types.User.id option Lwt.t
+  -> Os_types.User.id option
 (** Confirm validation code and create corresponding user. *)
 
-val confirm_code : Os_types.User.id -> string -> bool Lwt.t
+val confirm_code : Os_types.User.id -> string -> bool
 (** Confirm validation code and add extra phone to account of the given
     user *)
 
 [%%shared.start]
 
 type sms_error = [`Ownership | sms_error_core]
 
-val request_code : string -> (unit, sms_error) result Lwt.t
+val request_code : string -> (unit, sms_error) result
 (** Send a validation code for a new e-mail address (corresponds to
     [confirm_code_signup] and [confirm_code_extra]). *)
 
-val request_recovery_code : string -> (unit, sms_error) result Lwt.t
+val request_recovery_code : string -> (unit, sms_error) result
 (** Send a validation code for recovering an existing address. *)
 
-val confirm_code_extra : string -> bool Lwt.t
+val confirm_code_extra : string -> bool
 (** Confirm validation code and add extra phone to account of the currently
     connected user*)
 
@@ -66,16 +66,16 @@ val confirm_code_signup :
   -> code:string
   -> password:string
   -> unit
-  -> bool Lwt.t
+  -> bool
 (** Confirm validation code and complete sign-up with the phone
     number. *)
 
-val confirm_code_recovery : string -> bool Lwt.t
+val confirm_code_recovery : string -> bool
 (** Confirm validation code and recover account. We redirect to the
     settings page for setting a new password. *)
 
 val connect :
    keepmeloggedin:bool
   -> password:string
   -> string
-  -> [`Login_ok | `No_such_user | `Wrong_password | `Password_not_set] Lwt.t
+  -> [`Login_ok | `No_such_user | `Wrong_password | `Password_not_set]