From 9d6661abdc2910f33a875bfd1aac8837e0b09e5c Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Fri, 14 Nov 2025 18:19:55 +0100 Subject: [PATCH 1/5] Automatic changes done with ciao-lwt --- src/os_comet.eliom | 6 +- src/os_connect_phone.eliom | 143 +++---- src/os_connect_phone.eliomi | 18 +- src/os_core_db.ml | 131 +++--- src/os_core_db.mli | 17 +- src/os_current_user.eliom | 24 +- src/os_current_user.eliomi | 10 +- src/os_date.eliom | 4 +- src/os_db.ml | 774 ++++++++++++++++++------------------ src/os_db.mli | 93 ++--- src/os_email.eliom | 3 +- src/os_email.eliomi | 4 +- src/os_fcm_notif.eliom | 24 +- src/os_fcm_notif.eliomi | 7 +- src/os_group.ml | 41 +- src/os_group.mli | 12 +- src/os_handlers.eliom | 295 +++++++------- src/os_handlers.eliomi | 28 +- src/os_lib.eliom | 27 +- src/os_lib.eliomi | 8 +- src/os_notif.eliom | 27 +- src/os_notif.eliomi | 2 +- src/os_page.eliom | 100 ++--- src/os_page.eliomi | 36 +- src/os_request_cache.eliom | 12 +- src/os_request_cache.eliomi | 4 +- src/os_session.eliom | 191 +++++---- src/os_session.eliomi | 56 +-- src/os_tips.eliom | 47 +-- src/os_tips.eliomi | 23 +- src/os_uploader.eliom | 28 +- src/os_uploader.eliomi | 10 +- src/os_user.eliom | 55 ++- src/os_user.eliomi | 57 ++- src/os_user_proxy.eliom | 2 +- src/os_user_proxy.eliomi | 11 +- src/os_user_view.eliom | 7 +- src/os_user_view.eliomi | 4 +- 38 files changed, 1087 insertions(+), 1254 deletions(-) diff --git a/src/os_comet.eliom b/src/os_comet.eliom index fe034207..10651a31 100644 --- a/src/os_comet.eliom +++ b/src/os_comet.eliom @@ -123,8 +123,7 @@ let%server _ = (Lwt.async (fun () -> Lwt_stream.iter_s handle_message (Lwt_stream.wrap_exn ~%(fst channel))) - : unit)]; - Lwt.return_unit); + : unit)]); let warn c = (* User connected or disconnected. I want to send the message on all tabs of the browser: *) @@ -138,8 +137,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; diff --git a/src/os_connect_phone.eliom b/src/os_connect_phone.eliom index ff854358..535b138b 100644 --- a/src/os_connect_phone.eliom +++ b/src/os_connect_phone.eliom @@ -1,3 +1,5 @@ +open Eio.Std + (* Ocsigen Start * http://www.ocsigen.org/ocsigen-start * @@ -18,8 +20,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,74 +46,64 @@ 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 Promise.t) + 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 @@ -121,37 +111,34 @@ let%rpc ~(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 diff --git a/src/os_connect_phone.eliomi b/src/os_connect_phone.eliomi index 296f3ee8..30877b00 100644 --- a/src/os_connect_phone.eliomi +++ b/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,10 +38,10 @@ 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 *) @@ -49,14 +49,14 @@ val confirm_code : Os_types.User.id -> string -> bool Lwt.t 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,11 +66,11 @@ 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. *) @@ -78,4 +78,4 @@ 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] diff --git a/src/os_core_db.ml b/src/os_core_db.ml index 033743d1..cd52df33 100644 --- a/src/os_core_db.ml +++ b/src/os_core_db.ml @@ -18,27 +18,32 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Lwt.Syntax open Resource_pooling let section = Logs.Src.create "os:db" -let ( >>= ) = Lwt.bind +let ( >>= ) = fun x1 x2 -> x2 x1 module Lwt_thread = struct - include Lwt + let close_in = fun x1 -> Eio.Resource.close x1 + + let really_input + (* TODO: ciao-lwt: [x2] should be a [Cstruct.t]. *) + (* TODO: ciao-lwt: [Eio.Flow.single_read] operates on a [Flow.source] but [x1] is likely of type [Eio.Buf_read.t]. Rewrite this code to use [Buf_read] (which contains an internal buffer) or change the call to [Eio.Buf_read.of_flow] used to create the buffer. *) + (* TODO: ciao-lwt: Dropped expression (buffer offset): [x3]. This will behave as if it was [0]. *) + (* TODO: ciao-lwt: Dropped expression (buffer length): [x4]. This will behave as if it was [Cstruct.length buffer]. *) + = + fun x1 x2 x3 x4 -> Eio.Flow.read_exact x1 x2 - let close_in = Lwt_io.close - let really_input = Lwt_io.read_into_exactly let input_binary_int = Lwt_io.BE.read_int let input_char = Lwt_io.read_char - let output_string = Lwt_io.write + let output_string = fun x1 x2 -> Eio.Buf_write.string x1 x2 let output_binary_int = Lwt_io.BE.write_int let output_char = Lwt_io.write_char - let flush = Lwt_io.flush + let flush = fun x1 -> Eio.Buf_write.flush x1 let open_connection x = Lwt_io.open_connection x - type out_channel = Lwt_io.output_channel - type in_channel = Lwt_io.input_channel + type out_channel = Eio.Buf_write.t + type in_channel = Eio.Buf_read.t end module Lwt_PGOCaml = PGOCaml_generic.Make (Lwt_thread) @@ -51,34 +56,30 @@ let password_r = ref None let database_r = ref None let unix_domain_socket_dir_r = ref None let init_r = ref None - -let dispose db = - Lwt.catch (fun () -> PGOCaml.close db) (fun _ -> Lwt.return_unit) +let dispose db = try PGOCaml.close db with _ -> () let connect () = - let* h = + let h = Lwt_PGOCaml.connect ?host:!host_r ?port:!port_r ?user:!user_r ?password:!password_r ?database:!database_r ?unix_domain_socket_dir:!unix_domain_socket_dir_r () in match !init_r with | Some init -> - let* () = - Lwt.catch - (fun () -> init h) - (fun exn -> - let* () = dispose h in - Lwt.fail exn) + let () = + try init h + with exn -> + let () = dispose h in + raise exn in - Lwt.return h - | None -> Lwt.return h + h + | None -> h let validate db = - Lwt.catch - (fun () -> - let* () = Lwt_PGOCaml.ping db in - Lwt.return_true) - (fun _ -> Lwt.return_false) + try + let () = Lwt_PGOCaml.ping db in + true + with _ -> false let pool : (string, bool) Hashtbl.t Lwt_PGOCaml.t Resource_pool.t ref = ref @@ Resource_pool.create 16 ~validate ~dispose connect @@ -107,8 +108,7 @@ let init let connection_pool () = !pool -type wrapper = - {f : 'a. PGOCaml.pa_pg_data PGOCaml.t -> (unit -> 'a Lwt.t) -> 'a Lwt.t} +type wrapper = {f : 'a. PGOCaml.pa_pg_data PGOCaml.t -> (unit -> 'a) -> 'a} let connection_wrapper = ref {f = (fun _ f -> f ())} let set_connection_wrapper f = connection_wrapper := f @@ -116,51 +116,44 @@ let set_connection_wrapper f = connection_wrapper := f let use_pool f = Resource_pool.use !pool @@ fun db -> !connection_wrapper.f db @@ fun () -> - Lwt.catch - (fun () -> f db) - (function - | Lwt_PGOCaml.Error msg as e -> - Logs.err ~src:section (fun fmt -> - fmt "postgresql protocol error: %s" msg); - let* () = Lwt_PGOCaml.close db in - Lwt.fail e - | (Unix.Unix_error _ | End_of_file) as e -> - Logs.err ~src:section (fun fmt -> - fmt ("unix error" ^^ "@\n%s") (Printexc.to_string e)); - let* () = Lwt_PGOCaml.close db in - Lwt.fail e - | Lwt.Canceled as e -> - Logs.err ~src:section (fun fmt -> fmt "thread canceled"); - let* () = PGOCaml.close db in - Lwt.fail e - | exc -> Lwt.reraise exc) + try f db with + | Lwt_PGOCaml.Error msg as e -> + Logs.err ~src:section (fun fmt -> fmt "postgresql protocol error: %s" msg); + let () = Lwt_PGOCaml.close db in + raise e + | (Unix.Unix_error _ | End_of_file) as e -> + Logs.err ~src:section (fun fmt -> + fmt ("unix error" ^^ "@\n%s") (Printexc.to_string e)); + let () = Lwt_PGOCaml.close db in + raise e + | Lwt.Canceled as e -> + Logs.err ~src:section (fun fmt -> fmt "thread canceled"); + let () = PGOCaml.close db in + raise e let transaction_block db f = - Lwt.catch - (fun () -> - Lwt_PGOCaml.begin_work db >>= fun _ -> - let* r = f () in - let* () = Lwt_PGOCaml.commit db in - Lwt.return r) - (function - | (Lwt_PGOCaml.Error _ | Lwt.Canceled | Unix.Unix_error _ | End_of_file) - as e -> - (* The connection is going to be closed by [use_pool], + try + Lwt_PGOCaml.begin_work db >>= fun _ -> + let r = f () in + let () = Lwt_PGOCaml.commit db in + r + with + | (Lwt_PGOCaml.Error _ | Lwt.Canceled | Unix.Unix_error _ | End_of_file) as e + -> + raise + (* The connection is going to be closed by [use_pool], so no need to try to rollback *) - Lwt.fail e - | e -> - let* () = - Lwt.catch - (fun () -> Lwt_PGOCaml.rollback db) - (function - | Lwt_PGOCaml.PostgreSQL_Error _ -> - (* If the rollback fails, for instance due to a timeout, + e + | e -> + let () = + try Lwt_PGOCaml.rollback db + with Lwt_PGOCaml.PostgreSQL_Error _ -> + (* If the rollback fails, for instance due to a timeout, it seems better to close the connection. *) - Logs.err ~src:section (fun fmt -> fmt "rollback failed"); - Lwt_PGOCaml.close db - | exc -> Lwt.reraise exc) - in - Lwt.fail e) + Logs.err ~src:section (fun fmt -> fmt "rollback failed"); + Lwt_PGOCaml.close db + in + raise e let full_transaction_block f = use_pool (fun db -> transaction_block db (fun () -> f db)) diff --git a/src/os_core_db.mli b/src/os_core_db.mli index 284264bf..2b7395cf 100644 --- a/src/os_core_db.mli +++ b/src/os_core_db.mli @@ -1,3 +1,5 @@ +open Eio.Std + (* Ocsigen-start * http://www.ocsigen.org/ocsigen-start @@ -22,7 +24,9 @@ (** This module defines low level functions for database requests. *) open Resource_pooling -module PGOCaml : PGOCaml_generic.PGOCAML_GENERIC with type 'a monad = 'a Lwt.t + +module PGOCaml : + PGOCaml_generic.PGOCAML_GENERIC with type 'a monad = 'a Promise.t val init : ?host:string @@ -32,7 +36,7 @@ val init : -> ?database:string -> ?unix_domain_socket_dir:string -> ?pool_size:int - -> ?init:(PGOCaml.pa_pg_data PGOCaml.t -> unit Lwt.t) + -> ?init:(PGOCaml.pa_pg_data PGOCaml.t -> unit) -> unit -> unit (** [init ?host ?port ?user ?password ?database ?unix_domain_socket_dir ?init ()] @@ -40,21 +44,18 @@ val init : function [init] invoked each time a connection is created. *) -val full_transaction_block : - (PGOCaml.pa_pg_data PGOCaml.t -> 'a Lwt.t) - -> 'a Lwt.t +val full_transaction_block : (PGOCaml.pa_pg_data PGOCaml.t -> 'a) -> 'a (** [full_transaction_block f] executes function [f] within a database transaction. The argument of [f] is a PGOCaml database handle. *) -val without_transaction : (PGOCaml.pa_pg_data PGOCaml.t -> 'a Lwt.t) -> 'a Lwt.t +val without_transaction : (PGOCaml.pa_pg_data PGOCaml.t -> 'a) -> 'a (** [without_transaction f] executes function [f] outside a database transaction. The argument of [f] is a PGOCaml database handle. *) val connection_pool : unit -> PGOCaml.pa_pg_data PGOCaml.t Resource_pool.t (** Direct access to the connection pool *) -type wrapper = - {f : 'a. PGOCaml.pa_pg_data PGOCaml.t -> (unit -> 'a Lwt.t) -> 'a Lwt.t} +type wrapper = {f : 'a. PGOCaml.pa_pg_data PGOCaml.t -> (unit -> 'a) -> 'a} (** Setup a wrapper function which is used each time a connection is acquired. This function can perform some actions before and/or after the connection is used. *) diff --git a/src/os_current_user.eliom b/src/os_current_user.eliom index 4a18996c..e5cf55cf 100644 --- a/src/os_current_user.eliom +++ b/src/os_current_user.eliom @@ -18,8 +18,6 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open%server Lwt.Syntax - [%%shared type current_user = | CU_idontknown @@ -87,9 +85,8 @@ end] let%client _ = Os_session.get_current_userid_o := Opt.get_current_userid let%server set_user_server myid = - let* u = Os_user.user_of_userid myid in - Eliom_reference.Volatile.set me (CU_user u); - Lwt.return_unit + let u = Os_user.user_of_userid myid in + Eliom_reference.Volatile.set me (CU_user u) let%server unset_user_server () = Eliom_reference.Volatile.set me CU_notconnected @@ -105,22 +102,21 @@ let%server () = Os_session.on_request (fun myid_o -> match myid_o with | Some myid -> set_user_server myid - | None -> unset_user_server (); Lwt.return_unit); + | None -> unset_user_server ()); Os_session.on_start_connected_process (fun myid -> - let* () = set_user_server myid in - set_user_client (); Lwt.return_unit); + let () = set_user_server myid in + set_user_client ()); Os_session.on_pre_close_session (fun () -> unset_user_client (); (*VVV!!! will affect only current tab!! *) - unset_user_server (); - (* ok this is a request reference *) - Lwt.return_unit) + unset_user_server () + (* ok this is a request reference *)) -let%rpc remove_email_from_user (email : string) : unit Lwt.t = +let%rpc remove_email_from_user (email : string) : unit = let myid = get_current_userid () in Os_user.remove_email_from_user ~userid:myid ~email -let%rpc update_main_email (email : string) : unit Lwt.t = +let%rpc update_main_email (email : string) : unit = let myid = get_current_userid () in Os_user.update_main_email ~userid:myid ~email @@ -132,6 +128,6 @@ let%server is_main_email email = let myid = get_current_userid () in Os_user.is_main_email ~userid:myid ~email -let%rpc update_language (language : string) : unit Lwt.t = +let%rpc update_language (language : string) : unit = let myid = get_current_userid () in Os_user.update_language ~userid:myid ~language diff --git a/src/os_current_user.eliomi b/src/os_current_user.eliomi index ea473c0c..8945bc20 100644 --- a/src/os_current_user.eliomi +++ b/src/os_current_user.eliomi @@ -52,7 +52,7 @@ module Opt : sig If no user is connected, [None] is returned. *) end -val remove_email_from_user : string -> unit Lwt.t +val remove_email_from_user : string -> unit (** [remove_email_from_user email] removes the email [email] of the current user. If no user is connected, it fails with {!Os_session.Not_connected}. If @@ -60,27 +60,27 @@ val remove_email_from_user : string -> unit Lwt.t {!Os_db.Main_email_removal_attempt}. *) -val update_main_email : string -> unit Lwt.t +val update_main_email : string -> unit (** [update_main_email email] sets the main email of the current user to [email]. If no user is connected, it fails with {!Os_session.Not_connected}. *) -val update_language : string -> unit Lwt.t +val update_language : string -> unit (** [update_language language] updates the language of the current user. If no user is connected, it fails with {!Os_session.Not_connected}. *) [%%server.start] -val is_email_validated : string -> bool Lwt.t +val is_email_validated : string -> bool (** [is_email_validated email] returns [true] if [email] is a valided email for the current user. If no user is connected, it fails with {!Os_session.Not_connected}. It returns [false] in all other cases. *) -val is_main_email : string -> bool Lwt.t +val is_main_email : string -> bool (** [is_main_email email] returns [true] if [email] is the main email of the current user. *) [%%client.start] diff --git a/src/os_date.eliom b/src/os_date.eliom index dcd8f091..045cd205 100644 --- a/src/os_date.eliom +++ b/src/os_date.eliom @@ -75,9 +75,7 @@ let initialize tz = Eliom_reference.Volatile.set user_tz_sr tz (* When the browser is loaded, we init the timezone *) -let%rpc init_time_rpc (tz : string) : unit Lwt.t = - initialize tz; Lwt.return_unit - +let%rpc init_time_rpc (tz : string) : unit = initialize tz let%client auto_init = ref true let%client disable_auto_init () = auto_init := false diff --git a/src/os_db.ml b/src/os_db.ml index 42c1e8b6..fbdeba08 100644 --- a/src/os_db.ml +++ b/src/os_db.ml @@ -1,5 +1,4 @@ (* GENERATED CODE, DO NOT EDIT! *) -open Lwt.Syntax include Os_core_db exception No_such_resource @@ -10,7 +9,7 @@ exception Empty_password exception Main_email_removal_attempt exception Account_not_activated -let ( >>= ) = Lwt.bind +let ( >>= ) = fun x1 x2 -> x2 x1 let one f ~success ~fail q = f q >>= function r :: _ -> success r | _ -> fail let pwd_crypt_ref = @@ -24,8 +23,8 @@ let pwd_crypt_ref = module Email = struct let available email = one without_transaction - ~success:(fun _ -> Lwt.return_false) - ~fail:Lwt.return_true + ~success:(fun _ -> false) + ~fail:true (fun dbh -> PGOCaml.bind (let dbh = dbh in @@ -37,7 +36,7 @@ module Email = struct in let split = [ `Text - "SELECT 1\n FROM ocsigen_start.emails\n JOIN ocsigen_start.users USING (userid)\n WHERE email = " + "SELECT 1\n\ FROM ocsigen_start.emails\n\ JOIN ocsigen_start.users USING (userid)\n\ WHERE email = " ; `Var ("email", false, false) ] in let i = ref 0 in @@ -84,7 +83,7 @@ module Email = struct (fun _rows -> PGOCaml.return (let original_query = - "SELECT 1\n FROM ocsigen_start.emails\n JOIN ocsigen_start.users USING (userid)\n WHERE email = $email" + "SELECT 1\n\ FROM ocsigen_start.emails\n\ JOIN ocsigen_start.users USING (userid)\n\ WHERE email = $email" in List.rev_map (fun row -> @@ -115,8 +114,8 @@ module User = struct let userid_of_email email = one without_transaction - ~success:(fun userid -> Lwt.return userid) - ~fail:(Lwt.fail No_such_resource) + ~success:(fun userid -> userid) + ~fail:(raise No_such_resource) (fun dbh -> PGOCaml.bind (let dbh = dbh in @@ -128,7 +127,7 @@ module User = struct in let split = [ `Text - "SELECT userid\n FROM ocsigen_start.users JOIN ocsigen_start.emails USING (userid)\n WHERE email = " + "SELECT userid\n\ FROM ocsigen_start.users JOIN ocsigen_start.emails USING (userid)\n\ WHERE email = " ; `Var ("email", false, false) ] in let i = ref 0 in @@ -175,7 +174,7 @@ module User = struct (fun _rows -> PGOCaml.return (let original_query = - "SELECT userid\n FROM ocsigen_start.users JOIN ocsigen_start.emails USING (userid)\n WHERE email = $email" + "SELECT userid\n\ FROM ocsigen_start.users JOIN ocsigen_start.emails USING (userid)\n\ WHERE email = $email" in List.rev_map (fun row -> @@ -203,16 +202,15 @@ module User = struct _rows))) let is_registered email = - Lwt.catch - (fun () -> - let* _ = userid_of_email email in - Lwt.return_true) - (function No_such_resource -> Lwt.return_false | exc -> Lwt.reraise exc) + try + let _ = userid_of_email email in + true + with No_such_resource -> false let is_email_validated userid email = one without_transaction - ~success:(fun _ -> Lwt.return_true) - ~fail:Lwt.return_false + ~success:(fun _ -> true) + ~fail:false (fun dbh -> PGOCaml.bind (let dbh = dbh in @@ -228,7 +226,7 @@ module User = struct in let split = [ `Text - "SELECT 1 FROM ocsigen_start.emails\n WHERE userid = " + "SELECT 1 FROM ocsigen_start.emails\n\ WHERE userid = " ; `Var ("userid", false, false) ; `Text " AND email = " ; `Var ("email", false, false) @@ -278,7 +276,7 @@ module User = struct (fun _rows -> PGOCaml.return (let original_query = - "SELECT 1 FROM ocsigen_start.emails\n WHERE userid = $userid AND email = $email AND validated" + "SELECT 1 FROM ocsigen_start.emails\n\ WHERE userid = $userid AND email = $email AND validated" in List.rev_map (fun row -> @@ -319,7 +317,7 @@ module User = struct in let split = [ `Text - "UPDATE ocsigen_start.emails SET validated = true\n WHERE userid = " + "UPDATE ocsigen_start.emails SET validated = true\n\ WHERE userid = " ; `Var ("userid", false, false) ; `Text " AND email = " ; `Var ("email", false, false) ] @@ -423,7 +421,7 @@ module User = struct in let split = [ `Text - "INSERT INTO ocsigen_start.activation\n (userid, email, action, autoconnect, data,\n validity, activationkey, expiry)\n VALUES (" + "INSERT INTO ocsigen_start.activation\n\ (userid, email, action, autoconnect, data,\n\ validity, activationkey, expiry)\n\ VALUES (" ; `Var ("userid", false, false) ; `Text ", " ; `Var ("email", false, false) @@ -603,8 +601,8 @@ module User = struct let is_preregistered email = one without_transaction - ~success:(fun _ -> Lwt.return_true) - ~fail:Lwt.return_false + ~success:(fun _ -> true) + ~fail:false (fun dbh -> PGOCaml.bind (let dbh = dbh in @@ -774,134 +772,136 @@ module User = struct let create ?password ?avatar ?language ?email ~firstname ~lastname () = if password = Some "" - then Lwt.fail_with "empty password" + then failwith "empty password" else full_transaction_block (fun dbh -> let password_o = Eliom_lib.Option.map (fun p -> fst !pwd_crypt_ref p) password in - let* userid = - Lwt.bind - (PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [ [ Some - ((let open PGOCaml in - string_of_string) - firstname) ] - ; [ Some - ((let open PGOCaml in - string_of_string) - lastname) ] - ; [ PGOCaml_aux.Option.map - (let open PGOCaml in - string_of_string) - email ] - ; [ PGOCaml_aux.Option.map - (let open PGOCaml in - string_of_string) - password_o ] - ; [ PGOCaml_aux.Option.map - (let open PGOCaml in + let userid = + match + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in string_of_string) - avatar ] - ; [ PGOCaml_aux.Option.map - (let open PGOCaml in + firstname) ] + ; [ Some + ((let open PGOCaml in string_of_string) - language ] ] - in - let split = - [ `Text - "INSERT INTO ocsigen_start.users\n (firstname, lastname, main_email, password, avatar, language)\n VALUES (" - ; `Var ("firstname", false, false) - ; `Text ", " - ; `Var ("lastname", false, false) - ; `Text ", " - ; `Var ("email", false, true) - ; `Text ",\n " - ; `Var ("password_o", false, true) - ; `Text ", " - ; `Var ("avatar", false, true) - ; `Text ", " - ; `Var ("language", false, true) - ; `Text ")\n RETURNING userid" ] - in - let i = ref 0 in - let j = ref 0 in - let query = - String.concat "" - (List.map - (function - | `Text text -> text - | `Var (_varname, false, _) -> - let () = incr i in - let () = incr j in - "$" ^ string_of_int j.contents - | `Var (_varname, true, _) -> - let param = List.nth params i.contents in - let () = incr i in - "(" - ^ String.concat "," - (List.map - (fun _ -> - let () = incr j in - "$" ^ string_of_int j.contents) - param) - ^ ")") - split) - in - let params = List.flatten params in - let name = "ppx_pgsql." ^ Digest.to_hex (Digest.string query) in - let hash = - try PGOCaml.private_data dbh - with Not_found -> - let hash = Hashtbl.create 17 in - PGOCaml.set_private_data dbh hash; - hash - in - let is_prepared = Hashtbl.mem hash name in - PGOCaml.bind - (if not is_prepared - then - PGOCaml.bind (PGOCaml.prepare dbh ~name ~query ()) - (fun () -> Hashtbl.add hash name true; PGOCaml.return ()) - else PGOCaml.return ()) - (fun () -> PGOCaml.execute_rev dbh ~name ~params ())) - (fun _rows -> - PGOCaml.return - (let original_query = - "INSERT INTO ocsigen_start.users\n (firstname, lastname, main_email, password, avatar, language)\n VALUES ($firstname, $lastname, $?email,\n $?password_o, $?avatar, $?language)\n RETURNING userid" - in - List.rev_map - (fun row -> - match row with - | c0 :: [] -> - (let open PGOCaml in - int64_of_string) - (try PGOCaml_aux.Option.get c0 - with _ -> - failwith - "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"") - | _ -> - let msg = - "ppx_pgsql: internal error: " - ^ "Incorrect number of columns returned from query: " - ^ original_query ^ ". Columns are: " - ^ String.concat "; " - (List.map - (function - | Some str -> Printf.sprintf "%S" str - | None -> "NULL") - row) - in - raise (PGOCaml.Error msg)) - _rows))) - (function userid :: [] -> Lwt.return userid | _ -> assert false) + lastname) ] + ; [ PGOCaml_aux.Option.map + (let open PGOCaml in + string_of_string) + email ] + ; [ PGOCaml_aux.Option.map + (let open PGOCaml in + string_of_string) + password_o ] + ; [ PGOCaml_aux.Option.map + (let open PGOCaml in + string_of_string) + avatar ] + ; [ PGOCaml_aux.Option.map + (let open PGOCaml in + string_of_string) + language ] ] + in + let split = + [ `Text + "INSERT INTO ocsigen_start.users\n\ (firstname, lastname, main_email, password, avatar, language)\n\ VALUES (" + ; `Var ("firstname", false, false) + ; `Text ", " + ; `Var ("lastname", false, false) + ; `Text ", " + ; `Var ("email", false, true) + ; `Text ",\n " + ; `Var ("password_o", false, true) + ; `Text ", " + ; `Var ("avatar", false, true) + ; `Text ", " + ; `Var ("language", false, true) + ; `Text ")\n RETURNING userid" ] + in + let i = ref 0 in + let j = ref 0 in + let query = + String.concat "" + (List.map + (function + | `Text text -> text + | `Var (_varname, false, _) -> + let () = incr i in + let () = incr j in + "$" ^ string_of_int j.contents + | `Var (_varname, true, _) -> + let param = List.nth params i.contents in + let () = incr i in + "(" + ^ String.concat "," + (List.map + (fun _ -> + let () = incr j in + "$" ^ string_of_int j.contents) + param) + ^ ")") + split) + in + let params = List.flatten params in + let name = "ppx_pgsql." ^ Digest.to_hex (Digest.string query) in + let hash = + try PGOCaml.private_data dbh + with Not_found -> + let hash = Hashtbl.create 17 in + PGOCaml.set_private_data dbh hash; + hash + in + let is_prepared = Hashtbl.mem hash name in + PGOCaml.bind + (if not is_prepared + then + PGOCaml.bind (PGOCaml.prepare dbh ~name ~query ()) + (fun () -> Hashtbl.add hash name true; PGOCaml.return ()) + else PGOCaml.return ()) + (fun () -> PGOCaml.execute_rev dbh ~name ~params ())) + (fun _rows -> + PGOCaml.return + (let original_query = + "INSERT INTO ocsigen_start.users\n\ (firstname, lastname, main_email, password, avatar, language)\n\ VALUES ($firstname, $lastname, $?email,\n\ $?password_o, $?avatar, $?language)\n\ RETURNING userid" + in + List.rev_map + (fun row -> + match row with + | c0 :: [] -> + (let open PGOCaml in + int64_of_string) + (try PGOCaml_aux.Option.get c0 + with _ -> + failwith + "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"") + | _ -> + let msg = + "ppx_pgsql: internal error: " + ^ "Incorrect number of columns returned from query: " + ^ original_query ^ ". Columns are: " + ^ String.concat "; " + (List.map + (function + | Some str -> Printf.sprintf "%S" str + | None -> "NULL") + row) + in + raise (PGOCaml.Error msg)) + _rows)) + with + | userid :: [] -> userid + | _ -> assert false in - let* () = + let () = match email with | Some email -> - let* () = + let () = PGOCaml.bind (let dbh = dbh in let params : string option list list = @@ -916,7 +916,7 @@ module User = struct in let split = [ `Text - "INSERT INTO ocsigen_start.emails (email, userid)\n VALUES (" + "INSERT INTO ocsigen_start.emails (email, userid)\n\ VALUES (" ; `Var ("email", false, false) ; `Text ", " ; `Var ("userid", false, false) @@ -969,13 +969,13 @@ module User = struct (fun _rows -> PGOCaml.return ()) in remove_preregister0 dbh email - | None -> Lwt.return_unit + | None -> () in - Lwt.return userid) + userid) let update ?password ?avatar ?language ~firstname ~lastname userid = if password = Some "" - then Lwt.fail_with "empty password" + then failwith "empty password" else let password = match password with @@ -1070,7 +1070,7 @@ module User = struct let update_password ~userid ~password = if password = "" - then Lwt.fail_with "empty password" + then failwith "empty password" else let password = fst !pwd_crypt_ref password in without_transaction @@ fun dbh -> @@ -1214,7 +1214,7 @@ module User = struct in let split = [ `Text - "UPDATE ocsigen_start.users u SET main_email = e.email\n FROM ocsigen_start.emails e\n WHERE e.email = " + "UPDATE ocsigen_start.users u SET main_email = e.email\n\ FROM ocsigen_start.emails e\n\ WHERE e.email = " ; `Var ("email", false, false) ; `Text " AND u.userid = " ; `Var ("userid", false, false) @@ -1328,7 +1328,7 @@ module User = struct let verify_password ~email ~password = if password = "" - then Lwt.fail Empty_password + then raise Empty_password else one without_transaction (fun dbh -> @@ -1342,7 +1342,7 @@ module User = struct in let split = [ `Text - "SELECT userid, password, validated\n FROM ocsigen_start.users\n JOIN ocsigen_start.emails USING (userid)\n WHERE email = " + "SELECT userid, password, validated\n\ FROM ocsigen_start.users\n\ JOIN ocsigen_start.emails USING (userid)\n\ WHERE email = " ; `Var ("email", false, false) ] in let i = ref 0 in @@ -1389,7 +1389,7 @@ module User = struct (fun _rows -> PGOCaml.return (let original_query = - "SELECT userid, password, validated\n FROM ocsigen_start.users\n JOIN ocsigen_start.emails USING (userid)\n WHERE email = $email" + "SELECT userid, password, validated\n\ FROM ocsigen_start.users\n\ JOIN ocsigen_start.emails USING (userid)\n\ WHERE email = $email" in List.rev_map (fun row -> @@ -1429,16 +1429,14 @@ module User = struct ~success:(fun (userid, password', validated) -> match password' with | Some password' when snd !pwd_crypt_ref userid password password' -> - if validated - then Lwt.return userid - else Lwt.fail Account_not_activated - | Some _ -> Lwt.fail Wrong_password - | _ -> Lwt.fail Password_not_set) - ~fail:(Lwt.fail No_such_user) + if validated then userid else raise Account_not_activated + | Some _ -> raise Wrong_password + | _ -> raise Password_not_set) + ~fail:(raise No_such_user) let verify_password_phone ~number ~password = if password = "" - then Lwt.fail Empty_password + then raise Empty_password else one without_transaction (fun dbh -> @@ -1452,7 +1450,7 @@ module User = struct in let split = [ `Text - "SELECT userid, password\n FROM ocsigen_start.users\n JOIN ocsigen_start.phones USING (userid)\n WHERE number = " + "SELECT userid, password\n\ FROM ocsigen_start.users\n\ JOIN ocsigen_start.phones USING (userid)\n\ WHERE number = " ; `Var ("number", false, false) ] in let i = ref 0 in @@ -1499,7 +1497,7 @@ module User = struct (fun _rows -> PGOCaml.return (let original_query = - "SELECT userid, password\n FROM ocsigen_start.users\n JOIN ocsigen_start.phones USING (userid)\n WHERE number = $number" + "SELECT userid, password\n\ FROM ocsigen_start.users\n\ JOIN ocsigen_start.phones USING (userid)\n\ WHERE number = $number" in List.rev_map (fun row -> @@ -1532,24 +1530,18 @@ module User = struct ~success:(fun (userid, password') -> match password' with | Some password' when snd !pwd_crypt_ref userid password password' -> - Lwt.return userid - | Some _ -> Lwt.fail Wrong_password - | _ -> Lwt.fail Password_not_set) - ~fail:(Lwt.fail No_such_user) + userid + | Some _ -> raise Wrong_password + | _ -> raise Password_not_set) + ~fail:(raise No_such_user) let user_of_userid userid = one without_transaction ~success: (fun (userid, firstname, lastname, avatar, has_password, language) -> - Lwt.return - ( userid - , firstname - , lastname - , avatar - , has_password = Some true - , language )) - ~fail:(Lwt.fail No_such_resource) + userid, firstname, lastname, avatar, has_password = Some true, language) + ~fail:(raise No_such_resource) (fun dbh -> PGOCaml.bind (let dbh = dbh in @@ -1561,7 +1553,7 @@ module User = struct in let split = [ `Text - "SELECT userid, firstname, lastname, avatar,\n password IS NOT NULL, language\n FROM ocsigen_start.users WHERE userid = " + "SELECT userid, firstname, lastname, avatar,\n\ password IS NOT NULL, language\n\ FROM ocsigen_start.users WHERE userid = " ; `Var ("userid", false, false) ] in let i = ref 0 in @@ -1608,7 +1600,7 @@ module User = struct (fun _rows -> PGOCaml.return (let original_query = - "SELECT userid, firstname, lastname, avatar,\n password IS NOT NULL, language\n FROM ocsigen_start.users WHERE userid = $userid" + "SELECT userid, firstname, lastname, avatar,\n\ password IS NOT NULL, language\n\ FROM ocsigen_start.users WHERE userid = $userid" in List.rev_map (fun row -> @@ -1663,7 +1655,7 @@ module User = struct full_transaction_block (fun dbh -> one (fun q -> q dbh) - ~fail:(Lwt.fail No_such_resource) + ~fail:(raise No_such_resource) (fun dbh -> PGOCaml.bind (let dbh = dbh in @@ -1675,7 +1667,7 @@ module User = struct in let split = [ `Text - "SELECT userid, email, validity, expiry, autoconnect, action, data\n FROM ocsigen_start.activation\n WHERE activationkey = " + "SELECT userid, email, validity, expiry, autoconnect, action, data\n\ FROM ocsigen_start.activation\n\ WHERE activationkey = " ; `Var ("act_key", false, false) ] in let i = ref 0 in @@ -1722,7 +1714,7 @@ module User = struct (fun _rows -> PGOCaml.return (let original_query = - "SELECT userid, email, validity, expiry, autoconnect, action, data\n FROM ocsigen_start.activation\n WHERE activationkey = $act_key" + "SELECT userid, email, validity, expiry, autoconnect, action, data\n\ FROM ocsigen_start.activation\n\ WHERE activationkey = $act_key" in List.rev_map (fun row -> @@ -1793,7 +1785,7 @@ module User = struct | c -> `Custom c in let v = max 0L (Int64.pred validity) in - let* () = + let () = if v = 0L then PGOCaml.bind @@ -1806,7 +1798,7 @@ module User = struct in let split = [ `Text - "UPDATE ocsigen_start.activation\n SET expiry = LEAST(NOW() AT TIME ZONE 'utc'\n + INTERVAL '20 seconds',\n expiry)\n WHERE activationkey = " + "UPDATE ocsigen_start.activation\n\ SET expiry = LEAST(NOW() AT TIME ZONE 'utc'\n\ + INTERVAL '20 seconds',\n\ expiry)\n\ WHERE activationkey = " ; `Var ("act_key", false, false) ] in let i = ref 0 in @@ -1869,7 +1861,7 @@ module User = struct in let split = [ `Text - "UPDATE ocsigen_start.activation\n SET validity = " + "UPDATE ocsigen_start.activation\n\ SET validity = " ; `Var ("v", false, false) ; `Text " WHERE activationkey = " ; `Var ("act_key", false, false) ] @@ -1920,9 +1912,8 @@ module User = struct (fun () -> PGOCaml.execute_rev dbh ~name ~params ())) (fun _rows -> PGOCaml.return ()) in - Lwt.return - (let open Os_types.Action_link_key in - {userid; email; validity; expiry; action; data; autoconnect}))) + let open Os_types.Action_link_key in + {userid; email; validity; expiry; action; data; autoconnect})) let emails_of_userid userid = without_transaction @@ fun dbh -> @@ -2021,7 +2012,7 @@ module User = struct in let split = [ `Text - "SELECT email, validated\n FROM ocsigen_start.emails WHERE userid = " + "SELECT email, validated\n\ FROM ocsigen_start.emails WHERE userid = " ; `Var ("userid", false, false) ] in let i = ref 0 in @@ -2068,7 +2059,7 @@ module User = struct (fun _rows -> PGOCaml.return (let original_query = - "SELECT email, validated\n FROM ocsigen_start.emails WHERE userid = $userid" + "SELECT email, validated\n\ FROM ocsigen_start.emails WHERE userid = $userid" in List.rev_map (fun row -> @@ -2104,8 +2095,8 @@ module User = struct let email_of_userid userid = one without_transaction - ~success:(fun main_email -> Lwt.return main_email) - ~fail:(Lwt.fail No_such_resource) + ~success:(fun main_email -> main_email) + ~fail:(raise No_such_resource) (fun dbh -> PGOCaml.bind (let dbh = dbh in @@ -2191,8 +2182,8 @@ module User = struct let is_main_email ~userid ~email = one without_transaction - ~success:(fun _ -> Lwt.return_true) - ~fail:Lwt.return_false + ~success:(fun _ -> true) + ~fail:false (fun dbh -> PGOCaml.bind (let dbh = dbh in @@ -2208,7 +2199,7 @@ module User = struct in let split = [ `Text - "SELECT 1 FROM ocsigen_start.users\n WHERE userid = " + "SELECT 1 FROM ocsigen_start.users\n\ WHERE userid = " ; `Var ("userid", false, false) ; `Text " AND main_email = " ; `Var ("email", false, false) ] @@ -2257,7 +2248,7 @@ module User = struct (fun _rows -> PGOCaml.return (let original_query = - "SELECT 1 FROM ocsigen_start.users\n WHERE userid = $userid AND main_email = $email" + "SELECT 1 FROM ocsigen_start.users\n\ WHERE userid = $userid AND main_email = $email" in List.rev_map (fun row -> @@ -2298,7 +2289,7 @@ module User = struct in let split = [ `Text - "INSERT INTO ocsigen_start.emails (email, userid)\n VALUES (" + "INSERT INTO ocsigen_start.emails (email, userid)\n\ VALUES (" ; `Var ("email", false, false) ; `Text ", " ; `Var ("userid", false, false) @@ -2348,9 +2339,9 @@ module User = struct (fun _rows -> PGOCaml.return ()) let remove_email_from_user ~userid ~email = - let* b = is_main_email ~userid ~email in + let b = is_main_email ~userid ~email in if b - then Lwt.fail Main_email_removal_attempt + then raise Main_email_removal_attempt else without_transaction @@ fun dbh -> PGOCaml.bind @@ -2416,8 +2407,8 @@ module User = struct let get_language userid = one without_transaction - ~success:(fun language -> Lwt.return language) - ~fail:(Lwt.fail No_such_resource) + ~success:(fun language -> language) + ~fail:(raise No_such_resource) (fun dbh -> PGOCaml.bind (let dbh = dbh in @@ -2501,7 +2492,7 @@ module User = struct _rows))) let get_users ?pattern () = - let* l = + let l = without_transaction (fun dbh -> match pattern with | None -> @@ -2510,7 +2501,7 @@ module User = struct let params : string option list list = [] in let split = [ `Text - "SELECT userid, firstname, lastname, avatar,\n password IS NOT NULL, language\n FROM ocsigen_start.users" + "SELECT userid, firstname, lastname, avatar,\n\ password IS NOT NULL, language\n\ FROM ocsigen_start.users" ] in let i = ref 0 in @@ -2557,7 +2548,7 @@ module User = struct (fun _rows -> PGOCaml.return (let original_query = - "SELECT userid, firstname, lastname, avatar,\n password IS NOT NULL, language\n FROM ocsigen_start.users" + "SELECT userid, firstname, lastname, avatar,\n\ password IS NOT NULL, language\n\ FROM ocsigen_start.users" in List.rev_map (fun row -> @@ -2619,7 +2610,7 @@ module User = struct in let split = [ `Text - "SELECT userid, firstname, lastname, avatar,\n password IS NOT NULL, language\n FROM ocsigen_start.users\n WHERE firstname <> '' -- avoids email addresses\n AND CONCAT_WS(' ', firstname, lastname) ~* " + "SELECT userid, firstname, lastname, avatar,\n\ password IS NOT NULL, language\n\ FROM ocsigen_start.users\n\ WHERE firstname <> '' -- avoids email addresses\n\ AND CONCAT_WS(' ', firstname, lastname) ~* " ; `Var ("pattern", false, false) ] in let i = ref 0 in @@ -2666,7 +2657,7 @@ module User = struct (fun _rows -> PGOCaml.return (let original_query = - "SELECT userid, firstname, lastname, avatar,\n password IS NOT NULL, language\n FROM ocsigen_start.users\n WHERE firstname <> '' -- avoids email addresses\n AND CONCAT_WS(' ', firstname, lastname) ~* $pattern" + "SELECT userid, firstname, lastname, avatar,\n\ password IS NOT NULL, language\n\ FROM ocsigen_start.users\n\ WHERE firstname <> '' -- avoids email addresses\n\ AND CONCAT_WS(' ', firstname, lastname) ~* $pattern" in List.rev_map (fun row -> @@ -2717,16 +2708,10 @@ module User = struct raise (PGOCaml.Error msg)) _rows))) in - Lwt.return - (List.map - (fun (userid, firstname, lastname, avatar, has_password, language) -> - ( userid - , firstname - , lastname - , avatar - , has_password = Some true - , language )) - l) + List.map + (fun (userid, firstname, lastname, avatar, has_password, language) -> + userid, firstname, lastname, avatar, has_password = Some true, language) + l end module Groups = struct @@ -2746,7 +2731,7 @@ module Groups = struct in let split = [ `Text - "INSERT INTO ocsigen_start.groups (description, name)\n VALUES (" + "INSERT INTO ocsigen_start.groups (description, name)\n\ VALUES (" ; `Var ("description", false, true) ; `Text ", " ; `Var ("name", false, false) @@ -2807,7 +2792,7 @@ module Groups = struct in let split = [ `Text - "SELECT groupid, name, description\n FROM ocsigen_start.groups WHERE name = " + "SELECT groupid, name, description\n\ FROM ocsigen_start.groups WHERE name = " ; `Var ("name", false, false) ] in let i = ref 0 in @@ -2854,7 +2839,7 @@ module Groups = struct (fun _rows -> PGOCaml.return (let original_query = - "SELECT groupid, name, description\n FROM ocsigen_start.groups WHERE name = $name" + "SELECT groupid, name, description\n\ FROM ocsigen_start.groups WHERE name = $name" in List.rev_map (fun row -> @@ -2891,8 +2876,8 @@ module Groups = struct raise (PGOCaml.Error msg)) _rows))) >>= function - | r :: [] -> Lwt.return r - | _ -> Lwt.fail No_such_resource + | r :: [] -> r + | _ -> raise No_such_resource let add_user_in_group ~groupid ~userid = without_transaction @@ fun dbh -> @@ -2910,7 +2895,7 @@ module Groups = struct in let split = [ `Text - "INSERT INTO ocsigen_start.user_groups (userid, groupid)\n VALUES (" + "INSERT INTO ocsigen_start.user_groups (userid, groupid)\n\ VALUES (" ; `Var ("userid", false, false) ; `Text ", " ; `Var ("groupid", false, false) @@ -3028,8 +3013,8 @@ module Groups = struct (match dbh with | None -> without_transaction | Some dbh -> fun f -> f dbh) - ~success:(fun _ -> Lwt.return_true) - ~fail:Lwt.return_false + ~success:(fun _ -> true) + ~fail:false (fun dbh -> PGOCaml.bind (let dbh = dbh in @@ -3045,7 +3030,7 @@ module Groups = struct in let split = [ `Text - "SELECT 1 FROM ocsigen_start.user_groups\n WHERE groupid = " + "SELECT 1 FROM ocsigen_start.user_groups\n\ WHERE groupid = " ; `Var ("groupid", false, false) ; `Text " AND userid = " ; `Var ("userid", false, false) ] @@ -3094,7 +3079,7 @@ module Groups = struct (fun _rows -> PGOCaml.return (let original_query = - "SELECT 1 FROM ocsigen_start.user_groups\n WHERE groupid = $groupid AND userid = $userid" + "SELECT 1 FROM ocsigen_start.user_groups\n\ WHERE groupid = $groupid AND userid = $userid" in List.rev_map (fun row -> @@ -3212,7 +3197,7 @@ end module Phone = struct let add userid number = without_transaction @@ fun dbh -> - let* l = + let l = PGOCaml.bind (let dbh = dbh in let params : string option list list = @@ -3227,7 +3212,7 @@ module Phone = struct in let split = [ `Text - "INSERT INTO ocsigen_start.phones (number, userid)\n VALUES (" + "INSERT INTO ocsigen_start.phones (number, userid)\n\ VALUES (" ; `Var ("number", false, false) ; `Text ", " ; `Var ("userid", false, false) @@ -3278,7 +3263,7 @@ module Phone = struct (fun _rows -> PGOCaml.return (let original_query = - "INSERT INTO ocsigen_start.phones (number, userid)\n VALUES ($number, $userid)\n ON CONFLICT DO NOTHING\n RETURNING 0" + "INSERT INTO ocsigen_start.phones (number, userid)\n\ VALUES ($number, $userid)\n\ ON CONFLICT DO NOTHING\n\ RETURNING 0" in List.rev_map (fun row -> @@ -3303,180 +3288,183 @@ module Phone = struct raise (PGOCaml.Error msg)) _rows)) in - Lwt.return (match l with _ :: [] -> true | _ -> false) + match l with _ :: [] -> true | _ -> false let exists number = - Lwt.bind - ( without_transaction @@ fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [ [ Some - ((let open PGOCaml in - string_of_string) - number) ] ] - in - let split = - [ `Text "SELECT 1 FROM ocsigen_start.phones WHERE number = " - ; `Var ("number", false, false) ] - in - let i = ref 0 in - let j = ref 0 in - let query = - String.concat "" - (List.map - (function - | `Text text -> text - | `Var (_varname, false, _) -> - let () = incr i in - let () = incr j in - "$" ^ string_of_int j.contents - | `Var (_varname, true, _) -> - let param = List.nth params i.contents in - let () = incr i in - "(" - ^ String.concat "," - (List.map - (fun _ -> - let () = incr j in - "$" ^ string_of_int j.contents) - param) - ^ ")") - split) - in - let params = List.flatten params in - let name = "ppx_pgsql." ^ Digest.to_hex (Digest.string query) in - let hash = - try PGOCaml.private_data dbh - with Not_found -> - let hash = Hashtbl.create 17 in - PGOCaml.set_private_data dbh hash; - hash - in - let is_prepared = Hashtbl.mem hash name in - PGOCaml.bind - (if not is_prepared - then - PGOCaml.bind (PGOCaml.prepare dbh ~name ~query ()) (fun () -> - Hashtbl.add hash name true; PGOCaml.return ()) - else PGOCaml.return ()) - (fun () -> PGOCaml.execute_rev dbh ~name ~params ())) - (fun _rows -> - PGOCaml.return - (let original_query = - "SELECT 1 FROM ocsigen_start.phones WHERE number = $number" - in - List.rev_map - (fun row -> - match row with - | c0 :: [] -> - PGOCaml_aux.Option.map - (let open PGOCaml in - int32_of_string) - c0 - | _ -> - let msg = - "ppx_pgsql: internal error: " - ^ "Incorrect number of columns returned from query: " - ^ original_query ^ ". Columns are: " - ^ String.concat "; " - (List.map - (function - | Some str -> Printf.sprintf "%S" str - | None -> "NULL") - row) - in - raise (PGOCaml.Error msg)) - _rows)) ) - (function _ :: _ -> Lwt.return_true | [] -> Lwt.return_false) + match + without_transaction @@ fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_string) + number) ] ] + in + let split = + [ `Text "SELECT 1 FROM ocsigen_start.phones WHERE number = " + ; `Var ("number", false, false) ] + in + let i = ref 0 in + let j = ref 0 in + let query = + String.concat "" + (List.map + (function + | `Text text -> text + | `Var (_varname, false, _) -> + let () = incr i in + let () = incr j in + "$" ^ string_of_int j.contents + | `Var (_varname, true, _) -> + let param = List.nth params i.contents in + let () = incr i in + "(" + ^ String.concat "," + (List.map + (fun _ -> + let () = incr j in + "$" ^ string_of_int j.contents) + param) + ^ ")") + split) + in + let params = List.flatten params in + let name = "ppx_pgsql." ^ Digest.to_hex (Digest.string query) in + let hash = + try PGOCaml.private_data dbh + with Not_found -> + let hash = Hashtbl.create 17 in + PGOCaml.set_private_data dbh hash; + hash + in + let is_prepared = Hashtbl.mem hash name in + PGOCaml.bind + (if not is_prepared + then + PGOCaml.bind (PGOCaml.prepare dbh ~name ~query ()) (fun () -> + Hashtbl.add hash name true; PGOCaml.return ()) + else PGOCaml.return ()) + (fun () -> PGOCaml.execute_rev dbh ~name ~params ())) + (fun _rows -> + PGOCaml.return + (let original_query = + "SELECT 1 FROM ocsigen_start.phones WHERE number = $number" + in + List.rev_map + (fun row -> + match row with + | c0 :: [] -> + PGOCaml_aux.Option.map + (let open PGOCaml in + int32_of_string) + c0 + | _ -> + let msg = + "ppx_pgsql: internal error: " + ^ "Incorrect number of columns returned from query: " + ^ original_query ^ ". Columns are: " + ^ String.concat "; " + (List.map + (function + | Some str -> Printf.sprintf "%S" str + | None -> "NULL") + row) + in + raise (PGOCaml.Error msg)) + _rows)) + with + | _ :: _ -> true + | [] -> false let userid number = - Lwt.bind - ( without_transaction @@ fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [ [ Some - ((let open PGOCaml in - string_of_string) - number) ] ] - in - let split = - [ `Text "SELECT userid FROM ocsigen_start.phones WHERE number = " - ; `Var ("number", false, false) ] - in - let i = ref 0 in - let j = ref 0 in - let query = - String.concat "" - (List.map - (function - | `Text text -> text - | `Var (_varname, false, _) -> - let () = incr i in - let () = incr j in - "$" ^ string_of_int j.contents - | `Var (_varname, true, _) -> - let param = List.nth params i.contents in - let () = incr i in - "(" - ^ String.concat "," - (List.map - (fun _ -> - let () = incr j in - "$" ^ string_of_int j.contents) - param) - ^ ")") - split) - in - let params = List.flatten params in - let name = "ppx_pgsql." ^ Digest.to_hex (Digest.string query) in - let hash = - try PGOCaml.private_data dbh - with Not_found -> - let hash = Hashtbl.create 17 in - PGOCaml.set_private_data dbh hash; - hash - in - let is_prepared = Hashtbl.mem hash name in - PGOCaml.bind - (if not is_prepared - then - PGOCaml.bind (PGOCaml.prepare dbh ~name ~query ()) (fun () -> - Hashtbl.add hash name true; PGOCaml.return ()) - else PGOCaml.return ()) - (fun () -> PGOCaml.execute_rev dbh ~name ~params ())) - (fun _rows -> - PGOCaml.return - (let original_query = - "SELECT userid FROM ocsigen_start.phones WHERE number = $number" - in - List.rev_map - (fun row -> - match row with - | c0 :: [] -> - (let open PGOCaml in - int64_of_string) - (try PGOCaml_aux.Option.get c0 - with _ -> - failwith - "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"") - | _ -> - let msg = - "ppx_pgsql: internal error: " - ^ "Incorrect number of columns returned from query: " - ^ original_query ^ ". Columns are: " - ^ String.concat "; " - (List.map - (function - | Some str -> Printf.sprintf "%S" str - | None -> "NULL") - row) - in - raise (PGOCaml.Error msg)) - _rows)) ) - (function - | userid :: _ -> Lwt.return (Some userid) | [] -> Lwt.return None) + match + without_transaction @@ fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_string) + number) ] ] + in + let split = + [ `Text "SELECT userid FROM ocsigen_start.phones WHERE number = " + ; `Var ("number", false, false) ] + in + let i = ref 0 in + let j = ref 0 in + let query = + String.concat "" + (List.map + (function + | `Text text -> text + | `Var (_varname, false, _) -> + let () = incr i in + let () = incr j in + "$" ^ string_of_int j.contents + | `Var (_varname, true, _) -> + let param = List.nth params i.contents in + let () = incr i in + "(" + ^ String.concat "," + (List.map + (fun _ -> + let () = incr j in + "$" ^ string_of_int j.contents) + param) + ^ ")") + split) + in + let params = List.flatten params in + let name = "ppx_pgsql." ^ Digest.to_hex (Digest.string query) in + let hash = + try PGOCaml.private_data dbh + with Not_found -> + let hash = Hashtbl.create 17 in + PGOCaml.set_private_data dbh hash; + hash + in + let is_prepared = Hashtbl.mem hash name in + PGOCaml.bind + (if not is_prepared + then + PGOCaml.bind (PGOCaml.prepare dbh ~name ~query ()) (fun () -> + Hashtbl.add hash name true; PGOCaml.return ()) + else PGOCaml.return ()) + (fun () -> PGOCaml.execute_rev dbh ~name ~params ())) + (fun _rows -> + PGOCaml.return + (let original_query = + "SELECT userid FROM ocsigen_start.phones WHERE number = $number" + in + List.rev_map + (fun row -> + match row with + | c0 :: [] -> + (let open PGOCaml in + int64_of_string) + (try PGOCaml_aux.Option.get c0 + with _ -> + failwith + "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"") + | _ -> + let msg = + "ppx_pgsql: internal error: " + ^ "Incorrect number of columns returned from query: " + ^ original_query ^ ". Columns are: " + ^ String.concat "; " + (List.map + (function + | Some str -> Printf.sprintf "%S" str + | None -> "NULL") + row) + in + raise (PGOCaml.Error msg)) + _rows)) + with + | userid :: _ -> Some userid + | [] -> None let delete userid number = without_transaction @@ fun dbh -> diff --git a/src/os_db.mli b/src/os_db.mli index cfc8ae55..65b3cdd1 100644 --- a/src/os_db.mli +++ b/src/os_db.mli @@ -55,7 +55,7 @@ val pwd_crypt_ref : (** This module is used for low-level email management with database. *) module Email : sig - val available : string -> bool Lwt.t + val available : string -> bool (** [available email] returns [true] if [email] is not already used. Else, it returns [false]. *) @@ -65,19 +65,19 @@ end module User : sig exception Invalid_action_link_key of Os_types.User.id - val userid_of_email : string -> Os_types.User.id Lwt.t + val userid_of_email : string -> Os_types.User.id (** [userid_of_email email] returns the userid of the user which has the email [email]. *) - val is_registered : string -> bool Lwt.t + val is_registered : string -> bool (** [is_registered email] returns [true] if the email is already registered. Else, it returns [false]. *) - val is_email_validated : Os_types.User.id -> string -> bool Lwt.t + val is_email_validated : Os_types.User.id -> string -> bool (** [is_email_validated userid email] returns [true] if [email] has been validated by the user with id [userid]. *) - val set_email_validated : Os_types.User.id -> string -> unit Lwt.t + val set_email_validated : Os_types.User.id -> string -> unit (** [set_email_validated userid email] valids [email] for the user with id [userid]. *) @@ -94,19 +94,19 @@ module User : sig -> userid:Os_types.User.id -> email:string -> unit - -> unit Lwt.t + -> unit - val add_preregister : string -> unit Lwt.t + val add_preregister : string -> unit (** [add_preregister email] preregisters [email] in the database. *) - val remove_preregister : string -> unit Lwt.t + val remove_preregister : string -> unit (** [remove_preregister email] removes [email] from the database. *) - val is_preregistered : string -> bool Lwt.t + val is_preregistered : string -> bool (** [is_preregistered email] returns [true] if [email] is already registered. Else, it returns [false]. *) - val all : ?limit:int64 -> unit -> string list Lwt.t + val all : ?limit:int64 -> unit -> string list (** [all ?limit ()] get all email addresses with a limit of [limit] (default is 10). *) @@ -118,7 +118,7 @@ module User : sig -> firstname:string -> lastname:string -> unit - -> Os_types.User.id Lwt.t + -> Os_types.User.id (** [create ?password ?avatar ?language ~firstname ~lastname email] creates a new user in the database and returns the userid of the new user. Email, first name, last name and language are mandatory to create a new @@ -134,37 +134,34 @@ module User : sig -> firstname:string -> lastname:string -> Os_types.User.id - -> unit Lwt.t + -> unit (** [update ?password ?avatar ?language ~firstname ~lastname userid] updates the user profile with [userid]. If [password] is passed as an empty string, it fails with the message ["empty password"]. TODO: change it to an exception? *) - val update_password : userid:Os_types.User.id -> password:string -> unit Lwt.t + val update_password : userid:Os_types.User.id -> password:string -> unit (** [update_password ~userid ~new_password] updates the password of the user with ID [userid]. If [password] is passed as an empty string, it fails with the message ["empty password"]. TODO: change it to an exception? *) - val update_avatar : userid:Os_types.User.id -> avatar:string -> unit Lwt.t + val update_avatar : userid:Os_types.User.id -> avatar:string -> unit (** [update_avatar ~userid ~avatar] updates the avatar of the user with ID [userid]. *) - val update_main_email : userid:Os_types.User.id -> email:string -> unit Lwt.t + val update_main_email : userid:Os_types.User.id -> email:string -> unit (** [update_main_email ~userid ~email] updates the main email of the user with ID [userid]. *) - val update_language : userid:Os_types.User.id -> language:string -> unit Lwt.t + val update_language : userid:Os_types.User.id -> language:string -> unit (** [update_language ~userid ~language] updates the language of the user with ID [userid]. *) - val verify_password : - email:string - -> password:string - -> Os_types.User.id Lwt.t + val verify_password : email:string -> password:string -> Os_types.User.id (** [verify_password ~email ~password] returns the userid if user with email [email] is registered with the password [password]. If [password] the password is wrong, @@ -178,7 +175,7 @@ module User : sig val verify_password_phone : number:string -> password:string - -> Os_types.User.id Lwt.t + -> Os_types.User.id (** [verify_password_phone ~number ~password] returns the userid if user who owns [number] and whose password is [password]. @@ -190,13 +187,7 @@ module User : sig val user_of_userid : Os_types.User.id - -> (Os_types.User.id - * string - * string - * string option - * bool - * string option) - Lwt.t + -> Os_types.User.id * string * string * string option * bool * string option (** [user_of_userid userid] returns a tuple [(userid, firstname, lastname, avatar, bool_password, language)] describing the information about the user with ID [userid]. @@ -205,51 +196,46 @@ module User : sig If there is no such user, it fails with {!No_such_resource}. *) - val get_actionlinkkey_info : string -> Os_types.Action_link_key.info Lwt.t + val get_actionlinkkey_info : string -> Os_types.Action_link_key.info (** [get_actionlinkkey_info key] returns the information about the action link [key] as a type {!Os_types.Action_link_key.info}. *) - val emails_of_userid : Os_types.User.id -> string list Lwt.t + val emails_of_userid : Os_types.User.id -> string list (** [emails_of_userid userid] returns all emails registered for the user with ID [userid]. If there is no user with [userid] as ID, it fails with {!No_such_resource}. *) - val emails_of_userid_with_status : - Os_types.User.id - -> (string * bool) list Lwt.t + val emails_of_userid_with_status : Os_types.User.id -> (string * bool) list (** Like [emails_of_userid], but also returns validation status. This way we perform fewer DB queries. *) - val email_of_userid : Os_types.User.id -> string option Lwt.t + val email_of_userid : Os_types.User.id -> string option (** [email_of_userid userid] returns the main email registered for the user with ID [userid]. If there is no such user, it fails with {!No_such_resource}. *) - val is_main_email : userid:Os_types.User.id -> email:string -> bool Lwt.t + val is_main_email : userid:Os_types.User.id -> email:string -> bool (** [is_main_email ~email ~userid] returns [true] if the main email of the user with ID [userid] is [email]. If there is no such user or if [email] is not the main email, it returns [false]. *) - val add_email_to_user : userid:Os_types.User.id -> email:string -> unit Lwt.t + val add_email_to_user : userid:Os_types.User.id -> email:string -> unit (** [add_email_to_user ~userid ~email] add [email] to user with ID [userid]. *) - val remove_email_from_user : - userid:Os_types.User.id - -> email:string - -> unit Lwt.t + val remove_email_from_user : userid:Os_types.User.id -> email:string -> unit (** [remove_email_from_user ~userid ~email] removes the email [email] from the emails list of user with ID [userid]. If [email] is the main email, it fails with {!Main_email_removal_attempt}. *) - val get_language : Os_types.User.id -> string option Lwt.t + val get_language : Os_types.User.id -> string option (** [get_language userid] returns the language of the user with ID [userid] *) val get_users : @@ -262,7 +248,6 @@ module User : sig * bool * string option) list - Lwt.t (** [get_users ~pattern ()] returns all users matching the pattern [pattern] as a tuple [(userid, firstname, lastname, avatar, bool_password, language)]. @@ -271,13 +256,11 @@ end (** This module is low-level and used to manage groups of user. *) module Groups : sig - val create : ?description:string -> string -> unit Lwt.t + val create : ?description:string -> string -> unit (** [create ?description name] creates a new group with name [name] and with description [description]. *) - val group_of_name : - string - -> (Os_types.Group.id * string * string option) Lwt.t + val group_of_name : string -> Os_types.Group.id * string * string option (** [group_of_name name] returns a tuple [(groupid, name, description)] describing the group. If no group has the name [name], it fails with {!No_such_resource}. @@ -286,14 +269,14 @@ module Groups : sig val add_user_in_group : groupid:Os_types.Group.id -> userid:Os_types.User.id - -> unit Lwt.t + -> unit (** [add_user_in_group ~groupid ~userid] adds the user with ID [userid] in the group with ID [groupid] *) val remove_user_in_group : groupid:Os_types.Group.id -> userid:Os_types.User.id - -> unit Lwt.t + -> unit (** [remove_user_in_group ~groupid ~userid] removes the user with ID [userid] in the group with ID [groupid] *) @@ -302,32 +285,32 @@ module Groups : sig -> groupid:Os_types.Group.id -> userid:Os_types.User.id -> unit - -> bool Lwt.t + -> bool (** [in_group ~groupid ~userid] returns [true] if the user with ID [userid] is in the group with ID [groupid]. *) - val all : unit -> (Os_types.Group.id * string * string option) list Lwt.t + val all : unit -> (Os_types.Group.id * string * string option) list (** [all ()] returns all groups as list of tuple [(groupid, name, description)]. *) end (** Manage user phone numbers *) module Phone : sig - val add : int64 -> string -> bool Lwt.t + val add : int64 -> string -> bool (** [add userid number] associates [number] with the user [userid]. Returns [true] on success. *) - val exists : string -> bool Lwt.t + val exists : string -> bool (** Does the number exist in the database? *) - val userid : string -> Os_types.User.id option Lwt.t + val userid : string -> Os_types.User.id option (** The user corresponding to a phone number (if any). *) - val delete : int64 -> string -> unit Lwt.t + val delete : int64 -> string -> unit (** [delete userid number] deletes [number], which has to be associated to [userid]. *) - val get_list : int64 -> string list Lwt.t + val get_list : int64 -> string list (** [get_list userid] returns the list of number associated to the user. *) end diff --git a/src/os_email.eliom b/src/os_email.eliom index 63c81560..dba6fa00 100644 --- a/src/os_email.eliom +++ b/src/os_email.eliom @@ -53,8 +53,7 @@ let default_send ?url:_ ~from_addr ~to_addrs ~subject:_ content = echo "]"; printf "[content]:\n%s\n" content; echo "Please set your own sendmail function using Os_email.set_send"; - flush (); - Lwt.return () + flush () let send_ref = ref default_send diff --git a/src/os_email.eliomi b/src/os_email.eliomi index 2c395e30..34ca4430 100644 --- a/src/os_email.eliomi +++ b/src/os_email.eliomi @@ -51,7 +51,7 @@ val send : -> to_addrs:(string * string) list -> subject:string -> string list - -> unit Lwt.t + -> unit (** Send an e-mail to [to_addrs] from [from_addr]. You have to define the [subject] of your email. The body of the email is a list of strings and each element of the list is automatically separated by a new line. @@ -64,7 +64,7 @@ val set_send : -> to_addrs:(string * string) list -> subject:string -> string list - -> unit Lwt.t) + -> unit) -> unit (** Customize email sending function. See {!send} for more details about the arguments. diff --git a/src/os_fcm_notif.eliom b/src/os_fcm_notif.eliom index 2820601a..0599e8c1 100644 --- a/src/os_fcm_notif.eliom +++ b/src/os_fcm_notif.eliom @@ -18,8 +18,6 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Lwt.Syntax - exception FCM_empty_response exception FCM_no_json_response of string exception FCM_missing_field of string @@ -346,20 +344,16 @@ module Response = struct if an error occurred. *) let t_of_http_response (r, b) = - Lwt.catch - (fun () -> - let status = Cohttp.(Code.code_of_status (Response.status r)) in - let* b = Cohttp_lwt.Body.to_string b in - Yojson.Safe.from_string b |> Yojson.Safe.to_basic |> t_of_json status - |> Lwt.return) - (function - (* Could be the case if the server key is wrong or if it's not + try + let status = Cohttp.(Code.code_of_status (Response.status r)) in + let b = Cohttp_lwt.Body.to_string b in + Yojson.Safe.from_string b |> Yojson.Safe.to_basic |> t_of_json status + with + (* Could be the case if the server key is wrong or if it's not registered only in FCM and not in FCM (since September 2016). *) - | Yojson.Json_error _ -> - Lwt.fail - (FCM_no_json_response "It could come from your server key.") - | exc -> Lwt.reraise exc) + | Yojson.Json_error _ -> + raise (FCM_no_json_response "It could come from your server key.") let multicast_id_of_t response = response.multicast_id let success_of_t response = response.success @@ -381,5 +375,5 @@ let send server_key notification ?(data = Data.empty ()) options = :: Options.to_list options) |> Yojson.Safe.to_string |> Cohttp_lwt.Body.of_string in - let* response = Cohttp_lwt_unix.Client.call ~headers ~body `POST gcm_url in + let response = Cohttp_lwt_unix.Client.call ~headers ~body `POST gcm_url in Response.t_of_http_response response diff --git a/src/os_fcm_notif.eliomi b/src/os_fcm_notif.eliomi index 52960d0d..7df35ee6 100644 --- a/src/os_fcm_notif.eliomi +++ b/src/os_fcm_notif.eliomi @@ -448,10 +448,5 @@ module Response : sig (** [results_of_t response] returns the status of the messages processed. *) end -val send : - string - -> Notification.t - -> ?data:Data.t - -> Options.t - -> Response.t Lwt.t +val send : string -> Notification.t -> ?data:Data.t -> Options.t -> Response.t (** [send server_key notification options] *) diff --git a/src/os_group.ml b/src/os_group.ml index b44da362..ad60b526 100644 --- a/src/os_group.ml +++ b/src/os_group.ml @@ -18,8 +18,6 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Lwt.Syntax - exception No_such_group type id = Os_types.Group.id [@@deriving json] @@ -44,35 +42,26 @@ module MCache = Os_request_cache.Make (struct let compare = compare let get key = - Lwt.catch - (fun () -> - let* g = Os_db.Groups.group_of_name key in - Lwt.return (create_group_from_db g)) - (function - | Os_db.No_such_resource -> Lwt.fail No_such_group - | exc -> Lwt.reraise exc) + try + let g = Os_db.Groups.group_of_name key in + create_group_from_db g + with Os_db.No_such_resource -> raise No_such_group end) (** Helper function which creates a new group and return it as * a record of type [Os_types.Group.t]. *) let create ?description name = let group_of_name name = - let* g = Os_db.Groups.group_of_name name in - Lwt.return (create_group_from_db g) + let g = Os_db.Groups.group_of_name name in + create_group_from_db g in - Lwt.catch - (fun () -> group_of_name name) - (function - | Os_db.No_such_resource -> - let* () = Os_db.Groups.create ?description name in - Lwt.catch - (fun () -> - let* g = group_of_name name in - Lwt.return g) - (function - | Os_db.No_such_resource -> Lwt.fail No_such_group - | exc -> Lwt.reraise exc) - | exc -> Lwt.reraise exc) + try group_of_name name + with Os_db.No_such_resource -> ( + let () = Os_db.Groups.create ?description name in + try + let g = group_of_name name in + g + with Os_db.No_such_resource -> raise No_such_group) (* Should never happen *) (** Overwrite the function [group_of_name] of [Os_db.Group] and use @@ -98,5 +87,5 @@ let in_group ?dbh ~(group : Os_types.Group.t) ~userid () = (** Returns all the groups of the database. *) let all () = - let* groups = Os_db.Groups.all () in - Lwt.return (List.map create_group_from_db groups) + let groups = Os_db.Groups.all () in + List.map create_group_from_db groups diff --git a/src/os_group.mli b/src/os_group.mli index b32c583f..1073db9e 100644 --- a/src/os_group.mli +++ b/src/os_group.mli @@ -50,11 +50,11 @@ val name_of_group : Os_types.Group.t -> string val desc_of_group : Os_types.Group.t -> string option (** [desc_of_group group] returns the group description. *) -val create : ?description:string -> string -> Os_types.Group.t Lwt.t +val create : ?description:string -> string -> Os_types.Group.t (** [create ~description name] creates a new group in the database and returns it as a record of type [Os_types.Group.t]. *) -val group_of_name : string -> Os_types.Group.t Lwt.t +val group_of_name : string -> Os_types.Group.t (** Overwrites the function [group_of_name] of [Os_db.Group] and use the [get] function of the cache module. *) @@ -69,14 +69,14 @@ val group_of_name : string -> Os_types.Group.t Lwt.t val add_user_in_group : group:Os_types.Group.t -> userid:Os_types.User.id - -> unit Lwt.t + -> unit (** [add_user_in_group ~group ~userid] adds the user with ID [userid] to [group]. *) val remove_user_in_group : group:Os_types.Group.t -> userid:Os_types.User.id - -> unit Lwt.t + -> unit (** [remove_user_in_group ~group ~userid] removes the user with ID [userid] from [group]. *) @@ -85,9 +85,9 @@ val in_group : -> group:Os_types.Group.t -> userid:Os_types.User.id -> unit - -> bool Lwt.t + -> bool (** [in_group ~group ~userid] returns [true] if the user with ID [userid] is in [group]. *) -val all : unit -> Os_types.Group.t list Lwt.t +val all : unit -> Os_types.Group.t list (** [all ()] returns all the groups of the database. *) diff --git a/src/os_handlers.eliom b/src/os_handlers.eliom index cdcde01b..90356f4e 100644 --- a/src/os_handlers.eliom +++ b/src/os_handlers.eliom @@ -1,3 +1,5 @@ +open Eio.Std + (* Ocsigen-start * http://www.ocsigen.org/ocsigen-start * @@ -20,7 +22,6 @@ (** Registration of default services *) -open%shared Lwt.Syntax open%client Eliom_content.Html.F open%client Js_of_ocaml @@ -38,11 +39,9 @@ let%server (((firstname, lastname), (pwd, pwd2)) as pd) = if firstname = "" || lastname = "" || pwd <> pwd2 - then ( - Eliom_reference.Volatile.set Os_msg.wrong_pdata (Some pd); - Lwt.return_unit) + then Eliom_reference.Volatile.set Os_msg.wrong_pdata (Some pd) else - let* user = Os_user.user_of_userid myid in + let user = Os_user.user_of_userid myid in let open Os_types.User in let record = {user with fn = firstname; ln = lastname} in Os_user.update' ~password:pwd record @@ -50,15 +49,13 @@ let%server (* Set password handler *) let%server set_password_handler myid () (pwd, pwd2) = if pwd <> pwd2 - then ( - Os_msg.msg ~level:`Err ~onload:true "Passwords do not match"; - Lwt.return_unit) + then Os_msg.msg ~level:`Err ~onload:true "Passwords do not match" else - let* user = Os_user.user_of_userid myid in + let user = Os_user.user_of_userid myid in Os_user.update' ~password:pwd user (* Set password RPC *) -let%rpc set_password_rpc myid (p : string * string) : unit Lwt.t = +let%rpc set_password_rpc myid (p : string * string) : unit = set_password_handler myid () p let%server @@ -81,13 +78,14 @@ let%server then print_endline ("Debug: action link created: " ^ act_link); if send_email then - Lwt.async (fun () -> - Lwt.catch - (fun () -> + Fiber.fork + ~sw:(Stdlib.Option.get (Fiber.get Ocsigen_lib.current_switch)) + (fun () -> + try Os_email.send ~to_addrs:["", email] - ~subject:"creation" ~url:act_link [text]) - (fun _ -> Lwt.return_unit)); + ~subject:"creation" ~url:act_link [text] + with _ -> ()); act_key (** For default value of [autoconnect], cf. [Os_user.add_actionlinkkey]. *) @@ -104,11 +102,11 @@ let%server = let act_key = generate_action_link_key ~service ~text:msg email in Eliom_reference.Volatile.set Os_msg.action_link_key_created true; - let* () = + let () = Os_user.add_actionlinkkey ?autoconnect ?action ?validity ?expiry ~act_key ~userid ~email () in - Lwt.return_unit + () (* Sign up *) let%server sign_up_handler () email = @@ -120,52 +118,42 @@ let%server sign_up_handler () email = ~expiry:CalendarLib.Calendar.(add (now ()) (Period.hour 1)) ~autoconnect:true msg Os_services.main_service email userid in - Lwt.catch - (fun () -> - let* user = Os_user.create ~firstname:"" ~lastname:"" ~email () in - let userid = Os_user.userid_of_user user in - Os_msg.msg ~onload:true ~level:`Msg ~duration:6. - "An e-mail was sent to this address. Click on the link it contains to activate your account."; - send_action_link email userid) - (function - | Os_user.Already_exists userid -> - let* - (* If email is not validated, the user never logged in, + try + let user = Os_user.create ~firstname:"" ~lastname:"" ~email () in + let userid = Os_user.userid_of_user user in + Os_msg.msg ~onload:true ~level:`Msg ~duration:6. + "An e-mail was sent to this address. Click on the link it contains to activate your account."; + send_action_link email userid + with Os_user.Already_exists userid -> + let + (* If email is not validated, the user never logged in, I send an action link, as if it were a new user. *) - validated - = - Os_db.User.is_email_validated userid email - in - if not validated - then send_action_link email userid - else ( - Eliom_reference.Volatile.set Os_user.user_already_exists true; - Os_msg.msg ~level:`Err ~onload:true "E-mail already exists"; - Lwt.return_unit) - | exc -> Lwt.reraise exc) - -let%rpc sign_up_handler_rpc (email : string) : unit Lwt.t = - sign_up_handler () email + validated + = + Os_db.User.is_email_validated userid email + in + if not validated + then send_action_link email userid + else ( + Eliom_reference.Volatile.set Os_user.user_already_exists true; + Os_msg.msg ~level:`Err ~onload:true "E-mail already exists") +let%rpc sign_up_handler_rpc (email : string) : unit = sign_up_handler () email let%client sign_up_handler () v = sign_up_handler_rpc v (* Forgot password *) let%server forgot_password_handler service () email = - Lwt.catch - (fun () -> - let* userid = Os_user.userid_of_email email in - let msg = "Hi,\r\nTo set a new password, please click on this link: " in - Os_msg.msg ~level:`Msg ~onload:true - "An email was sent to this address. Click on the link it contains to reset your password."; - send_action_link ~autoconnect:true ~action:`PasswordReset ~validity:1L - ~expiry:CalendarLib.Calendar.(add (now ()) (Period.hour 1)) - msg service email userid) - (function - | Os_db.No_such_resource -> - Eliom_reference.Volatile.set Os_user.user_does_not_exist true; - Os_msg.msg ~level:`Err ~onload:true "User does not exist"; - Lwt.return_unit - | exc -> Lwt.reraise exc) + try + let userid = Os_user.userid_of_email email in + let msg = "Hi,\r\nTo set a new password, please click on this link: " in + Os_msg.msg ~level:`Msg ~onload:true + "An email was sent to this address. Click on the link it contains to reset your password."; + send_action_link ~autoconnect:true ~action:`PasswordReset ~validity:1L + ~expiry:CalendarLib.Calendar.(add (now ()) (Period.hour 1)) + msg service email userid + with Os_db.No_such_resource -> + Eliom_reference.Volatile.set Os_user.user_does_not_exist true; + Os_msg.msg ~level:`Err ~onload:true "User does not exist" let%client restart ?url () = (* Restart the client. @@ -197,7 +185,7 @@ let%client restart ?url () = If [main_page] is true, it goes to the main page. *) let disconnect_handler ?(main_page = false) () () = - let* + let (* SECURITY: no check here because we disconnect the session cookie owner. *) () = @@ -213,8 +201,7 @@ let disconnect_handler ?(main_page = false) () () = Some (make_uri ~absolute:true ~service:Eliom_service.reload_action ())) () - : unit)]; - Lwt.return_unit + : unit)] let%rpc disconnect_handler_rpc (main_page : bool) = disconnect_handler ~main_page () () @@ -224,32 +211,27 @@ let%client disconnect_handler ?(main_page = false) () () = (* Connection *) let connect_handler () ((login, pwd), keepmeloggedin) = - Lwt.catch - (fun () -> - let* - (* SECURITY: no check here. *) - userid - = - Os_user.verify_password ~email:login ~password:pwd - in - let* () = disconnect_handler () () in - Os_session.connect ~expire:(not keepmeloggedin) userid) - (function - | Os_db.Account_not_activated -> - Eliom_reference.Volatile.set Os_user.account_not_activated true; - Os_msg.msg ~level:`Err ~onload:true "Account not activated"; - Lwt.return_unit - | Os_db.Empty_password | Os_db.Password_not_set | Os_db.Wrong_password -> - Eliom_reference.Volatile.set Os_user.wrong_password true; - Os_msg.msg ~level:`Err ~onload:true "Wrong password"; - Lwt.return_unit - | Os_db.No_such_user -> - Eliom_reference.Volatile.set Os_user.no_such_user true; - Os_msg.msg ~level:`Err ~onload:true "No such user"; - Lwt.return_unit - | exc -> Lwt.reraise exc) - -let%rpc connect_handler_rpc (v : (string * string) * bool) : unit Lwt.t = + try + let + (* SECURITY: no check here. *) + userid + = + Os_user.verify_password ~email:login ~password:pwd + in + let () = disconnect_handler () () in + Os_session.connect ~expire:(not keepmeloggedin) userid + with + | Os_db.Account_not_activated -> + Eliom_reference.Volatile.set Os_user.account_not_activated true; + Os_msg.msg ~level:`Err ~onload:true "Account not activated" + | Os_db.Empty_password | Os_db.Password_not_set | Os_db.Wrong_password -> + Eliom_reference.Volatile.set Os_user.wrong_password true; + Os_msg.msg ~level:`Err ~onload:true "Wrong password" + | Os_db.No_such_user -> + Eliom_reference.Volatile.set Os_user.no_such_user true; + Os_msg.msg ~level:`Err ~onload:true "No such user" + +let%rpc connect_handler_rpc (v : (string * string) * bool) : unit = connect_handler () v let%client connect_handler () v = connect_handler_rpc v @@ -277,67 +259,62 @@ let%rpc action_link_handler_common myid_o (akey : string) : | `No_such_resource | `Reload | `Restart_if_app ] - Lwt.t = - Lwt.catch - (fun () -> - let open Os_types.Action_link_key in - let* ({userid; email; validity; expiry; action; data = _; autoconnect} as - action_link) - = - Os_user.get_actionlinkkey_info akey - in - let* () = - if action = `AccountActivation && validity <= 0L - then - match myid_o with - | Some myid -> - Lwt.fail - (Account_already_activated_connected (action_link, myid)) - | None -> - Lwt.fail (Account_already_activated_unconnected action_link) - else Lwt.return_unit - in - let outdated = - match expiry with - | None -> false - | Some e -> e <= CalendarLib.Calendar.now () - in - let* () = - if validity <= 0L || outdated - then Lwt.fail (Invalid_action_key action_link) - else Lwt.return_unit - in - let* () = - if action = `AccountActivation || action = `PasswordReset - then Os_db.User.set_email_validated userid email - else Lwt.return_unit - in - if autoconnect && myid_o <> Some userid - then - let* () = Os_session.connect userid in - Lwt.return `Restart_if_app - else - match action with - | `Custom _s -> - let* existing_user = Os_db.User.is_email_validated userid email in - Lwt.return (`Custom_action_link (action_link, not existing_user)) - | _ -> Lwt.return `Reload) - (function - | Os_db.No_such_resource -> Lwt.return `No_such_resource - | Invalid_action_key action_link -> - Eliom_reference.Volatile.set Os_user.action_link_key_outdated true; - Lwt.return (`Invalid_action_key action_link) - | Account_already_activated_unconnected action_link -> - Eliom_reference.Volatile.set Os_user.action_link_key_outdated true; - Lwt.return (`Account_already_activated_unconnected action_link) - | Account_already_activated_connected (_action_link, _) -> - Eliom_reference.Volatile.set Os_user.action_link_key_outdated true; - (* Just reload the page without the GET parameters to get rid of the key. + try + let open Os_types.Action_link_key in + let ({userid; email; validity; expiry; action; data = _; autoconnect} as + action_link) + = + Os_user.get_actionlinkkey_info akey + in + let () = + if action = `AccountActivation && validity <= 0L + then + match myid_o with + | Some myid -> + raise (Account_already_activated_connected (action_link, myid)) + | None -> raise (Account_already_activated_unconnected action_link) + else () + in + let outdated = + match expiry with + | None -> false + | Some e -> e <= CalendarLib.Calendar.now () + in + let () = + if validity <= 0L || outdated + then raise (Invalid_action_key action_link) + else () + in + let () = + if action = `AccountActivation || action = `PasswordReset + then Os_db.User.set_email_validated userid email + else () + in + if autoconnect && myid_o <> Some userid + then + let () = Os_session.connect userid in + `Restart_if_app + else + match action with + | `Custom _s -> + let existing_user = Os_db.User.is_email_validated userid email in + `Custom_action_link (action_link, not existing_user) + | _ -> `Reload + with + | Os_db.No_such_resource -> `No_such_resource + | Invalid_action_key action_link -> + Eliom_reference.Volatile.set Os_user.action_link_key_outdated true; + `Invalid_action_key action_link + | Account_already_activated_unconnected action_link -> + Eliom_reference.Volatile.set Os_user.action_link_key_outdated true; + `Account_already_activated_unconnected action_link + | Account_already_activated_connected (_action_link, _) -> + Eliom_reference.Volatile.set Os_user.action_link_key_outdated true; + (* Just reload the page without the GET parameters to get rid of the key. If the user wasn't already logged in, let the exception pass to the next exception handler. *) - Lwt.return `Reload - | exc -> Lwt.reraise exc) + `Reload let%client restart_if_client_side () = restart @@ -347,33 +324,32 @@ let%client restart_if_client_side () = let%server restart_if_client_side () = () let%shared action_link_handler _myid_o akey () = - let* a = action_link_handler_common akey in + let a = action_link_handler_common akey in match a with | `Reload -> Eliom_registration.( appl_self_redirect Redirection.send (Redirection Eliom_service.reload_action)) - | `No_such_resource -> Lwt.fail No_such_resource - | `Invalid_action_key action_link -> Lwt.fail (Invalid_action_key action_link) + | `No_such_resource -> raise No_such_resource + | `Invalid_action_key action_link -> raise (Invalid_action_key action_link) | `Restart_if_app -> restart_if_client_side (); Eliom_registration.(appl_self_redirect Action.send) () | `Custom_action_link (action_link, phantom_user) -> - Lwt.fail (Custom_action_link (action_link, phantom_user)) + raise (Custom_action_link (action_link, phantom_user)) | `Account_already_activated_unconnected action_link -> - Lwt.fail (Account_already_activated_unconnected action_link) + raise (Account_already_activated_unconnected action_link) (* Preregister *) let preregister_handler () email = - let* is_preregistered = Os_user.is_preregistered email in - let* is_registered = Os_user.is_registered email in + let is_preregistered = Os_user.is_preregistered email in + let is_registered = Os_user.is_registered email in Printf.printf "%b:%b%!\n" is_preregistered is_registered; if not (is_preregistered || is_registered) then Os_user.add_preregister email else ( Eliom_reference.Volatile.set Os_user.user_already_preregistered true; - Os_msg.msg ~level:`Err ~onload:true "E-mail already preregistered"; - Lwt.return_unit) + Os_msg.msg ~level:`Err ~onload:true "E-mail already preregistered") (* Add email *) let add_email_handler = @@ -387,18 +363,16 @@ let add_email_handler = | None -> Os_services.main_service) in let add_email myid () email = - let* available = Os_db.Email.available email in + let available = Os_db.Email.available email in if available then - let* () = Os_db.User.add_email_to_user ~userid:myid ~email in + let () = Os_db.User.add_email_to_user ~userid:myid ~email in send_act () email myid - else ( - Eliom_reference.Volatile.set Os_user.user_already_exists true; - Lwt.return_unit) + else Eliom_reference.Volatile.set Os_user.user_already_exists true in Os_session.connected_fun add_email -let%rpc add_email_rpc (email : string) : unit Lwt.t = add_email_handler () email +let%rpc add_email_rpc (email : string) : unit = add_email_handler () email let%client add_email_handler () = add_email_rpc let%shared _ = Os_comet.__link (* to make sure os_comet is linked *) @@ -443,8 +417,7 @@ let%client confirm_code_popup ~dest f = client. Until we fix Eliom, we define dummy server-side handlers. *) let%server confirm_code_handler _ _ = - Lwt.fail_with - "Os_handlers.confirm_code_*_handler not implemented on the server" + failwith "Os_handlers.confirm_code_*_handler not implemented on the server" let%server confirm_code_signup_handler = confirm_code_handler let%server confirm_code_extra_handler = confirm_code_handler diff --git a/src/os_handlers.eliomi b/src/os_handlers.eliomi index e73bf7ae..51844c44 100644 --- a/src/os_handlers.eliomi +++ b/src/os_handlers.eliomi @@ -25,18 +25,18 @@ {!Os_services}. *) -val connect_handler : unit -> (string * string) * bool -> unit Lwt.t +val connect_handler : unit -> (string * string) * bool -> unit (** [connect_handler () ((login, password), keepMeLoggedIn)] connects the user with [login] and [password] and keeps the user logged in between different session if [keepMeLoggedIn] is set to [true]. *) -val disconnect_handler : ?main_page:bool -> unit -> unit -> unit Lwt.t +val disconnect_handler : ?main_page:bool -> unit -> unit -> unit (** [disconnect_handler ?main_page () ()] disconnects the current user. *) -val sign_up_handler : unit -> string -> unit Lwt.t +val sign_up_handler : unit -> string -> unit (** [sign_up_handler () email] signes up an user with email [email]. *) -val add_email_handler : unit -> string -> unit Lwt.t +val add_email_handler : unit -> string -> unit (** [add_email_handler () email] adds a new e-mail address for the current user and sends an activation link. Eliom reference [Os_user.user_already_exists] is set @@ -71,7 +71,7 @@ val action_link_handler : int64 option -> string -> unit - -> 'a Eliom_registration.application_content Eliom_registration.kind Lwt.t + -> 'a Eliom_registration.application_content Eliom_registration.kind (** [action_link_handler userid_o activation_key ()] is the handler for activation keys. @@ -83,18 +83,18 @@ val action_link_handler : val confirm_code_signup_handler : unit -> string * (string * (string * string)) - -> unit Lwt.t + -> unit (** [confirm_code_signup_handler () (first_name, (last_name, (pass, number)))] sends a verification code to [number], displays a popup for confirming the code, and creates the account if all goes well. *) -val confirm_code_extra_handler : unit -> string -> unit Lwt.t +val confirm_code_extra_handler : unit -> string -> unit (** [confirm_code_extra_handler () number] is like [confirm_code_signup_handler] but for adding an additional number to the account. The new phone is added to the account. *) -val confirm_code_recovery_handler : unit -> string -> unit Lwt.t +val confirm_code_recovery_handler : unit -> string -> unit (** [confirm_code_recovery_handler () number] is like [confirm_code_signup_handler] but for recovering a lost password. The user is redirected to the settings page for setting @@ -117,21 +117,17 @@ val forgot_password_handler : Eliom_service.t -> unit -> string - -> unit Lwt.t + -> unit (** [forgot_password_handler service () email] creates and sends an action link to [email] if the user forgot his password and redirects to [service]. If [email] doesn't correspond to any user, {!Os_user.user_does_not_exist} is set to [true] and {!Os_msg.msg} is called with the level [`Err]. *) -val preregister_handler : unit -> string -> unit Lwt.t +val preregister_handler : unit -> string -> unit (** [preregister_handler () email] preregisters the email [email]. *) -val set_password_handler : - Os_types.User.id - -> unit - -> string * string - -> unit Lwt.t +val set_password_handler : Os_types.User.id -> unit -> string * string -> unit (** [set_password_handler userid () (password, confirmation_password)] updates the password of the user with ID [userid] with the hashed value of [password] if [confirmation_password] corresponds to [password]. If they @@ -142,7 +138,7 @@ val set_personal_data_handler : Os_types.User.id -> unit -> (string * string) * (string * string) - -> unit Lwt.t + -> unit (** [set_personal_data_handler userid () ((firstname, lastname), (password, confirmation_password))] sets the corresponding data to given values. *) diff --git a/src/os_lib.eliom b/src/os_lib.eliom index 7a89e72c..2da6cf70 100644 --- a/src/os_lib.eliom +++ b/src/os_lib.eliom @@ -18,7 +18,6 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open%shared Lwt.Syntax open%client Js_of_ocaml open%client Js_of_ocaml_lwt @@ -30,11 +29,11 @@ let%shared memoizator f = let value_ref = ref None in fun () -> match !value_ref with - | Some value -> Lwt.return value + | Some value -> value | None -> - let* value = f () in + let value = f () in value_ref := Some value; - Lwt.return value + value let%shared string_repeat s n = let b = Buffer.create (n * String.length s) in @@ -142,13 +141,13 @@ let%shared ?(validate : (string -> bool) Eliom_client_value.t option) ?button (e : Html_types.input Eliom_content.Html.elt) - (f : (string -> unit Lwt.t) Eliom_client_value.t) + (f : (string -> unit) Eliom_client_value.t) = ignore [%client (let e = Eliom_content.Html.To_dom.of_input ~%e in let f = - let f = ~%(f : (string -> unit Lwt.t) Eliom_client_value.t) in + let f = ~%(f : (string -> unit) Eliom_client_value.t) in match ~%validate with | Some validate -> fun v -> @@ -180,13 +179,11 @@ let%shared lwt_bound_input_enter ?(a = []) ?button ?validate f = module Http = struct let string_of_stream ?(len = 16384) contents = - Lwt.try_bind - (fun () -> - Ocsigen_stream.string_of_stream len (Ocsigen_stream.get contents)) - (fun r -> - let* () = Ocsigen_stream.finalize contents `Success in - Lwt.return r) - (fun e -> - let* () = Ocsigen_stream.finalize contents `Failure in - Lwt.fail e) + match Ocsigen_stream.string_of_stream len (Ocsigen_stream.get contents) with + | r -> + let () = Ocsigen_stream.finalize contents `Success in + r + | exception e -> + let () = Ocsigen_stream.finalize contents `Failure in + raise e end diff --git a/src/os_lib.eliomi b/src/os_lib.eliomi index 02c61e4c..9b52d174 100644 --- a/src/os_lib.eliomi +++ b/src/os_lib.eliomi @@ -54,7 +54,7 @@ end val phone_regexp : Re.Str.regexp val email_regexp : Re.Str.regexp -val memoizator : (unit -> 'a Lwt.t) -> unit -> 'a Lwt.t +val memoizator : (unit -> 'a) -> unit -> 'a (** [memoizator f ()] caches the returned value of [f ()] *) val string_repeat : string -> int -> string @@ -64,7 +64,7 @@ val lwt_bound_input_enter : ?a:[< Html_types.input_attrib] Eliom_content.Html.attrib list -> ?button:[< Html_types.button] Eliom_content.Html.elt -> ?validate:(string -> bool) Eliom_client_value.t - -> (string -> unit Lwt.t) Eliom_client_value.t + -> (string -> unit) Eliom_client_value.t -> [> `Input] Eliom_content.Html.elt (** [lwt_bound_input_enter f] produces an input element bound to [f], i.e., when the user submits the input, we call [f]. *) @@ -73,7 +73,7 @@ val lwt_bind_input_enter : ?validate:(string -> bool) Eliom_client_value.t -> ?button:[< Html_types.button | Html_types.input] Eliom_content.Html.elt -> Html_types.input Eliom_content.Html.elt - -> (string -> unit Lwt.t) Eliom_client_value.t + -> (string -> unit) Eliom_client_value.t -> unit (** [lwt_bound_input_enter inp f] calls f whenever the user submits the contents of [inp]. *) @@ -82,7 +82,7 @@ val lwt_bind_input_enter : (** This module contains functions about HTTP request. *) module Http : sig - val string_of_stream : ?len:int -> string Ocsigen_stream.t -> string Lwt.t + val string_of_stream : ?len:int -> string Ocsigen_stream.t -> string (** [string_of_stream ?len stream] creates a string of maximum length [len] (default is [16384]) from the stream [stream]. *) diff --git a/src/os_notif.eliom b/src/os_notif.eliom index ab7d26b2..c0926dba 100644 --- a/src/os_notif.eliom +++ b/src/os_notif.eliom @@ -1,3 +1,5 @@ +open Eio.Std + (* Ocsigen-start * http://www.ocsigen.org/ocsigen-start * @@ -37,7 +39,7 @@ module type ARG = sig type server_notif type client_notif - val prepare : User.id option -> server_notif -> client_notif option Lwt.t + val prepare : User.id option -> server_notif -> client_notif option val equal_key : key -> key -> bool val max_resource : int val max_identity_per_resource : int @@ -57,10 +59,7 @@ module Make (A : ARG) : let prepare = A.prepare let equal_key = A.equal_key let equal_identity = ( = ) - - let get_identity () = - Lwt.return @@ Os_current_user.Opt.get_current_userid () - + let get_identity () = Os_current_user.Opt.get_current_userid () let max_resource = A.max_resource let max_identity_per_resource = A.max_identity_per_resource end) @@ -70,12 +69,14 @@ module Make (A : ARG) : Eliom_state.Ext.volatile_data_group_state ~scope:Eliom_common.default_group_scope (Int64.to_string userid) in - Lwt.async @@ fun () -> - (* Iterating on all sessions in group: *) - Eliom_state.Ext.iter_sub_states ?sitedata ~state @@ fun state -> - (* Iterating on all client processes in session: *) - Eliom_state.Ext.iter_sub_states ?sitedata ~state (fun state -> - Ext.unlisten state id; Lwt.return_unit) + Fiber.fork + ~sw:(Stdlib.Option.get (Fiber.get Ocsigen_lib.current_switch)) + (fun () -> + (* Iterating on all sessions in group: *) + Eliom_state.Ext.iter_sub_states ?sitedata ~state @@ fun state -> + (* Iterating on all client processes in session: *) + Eliom_state.Ext.iter_sub_states ?sitedata ~state (fun state -> + Ext.unlisten state id)) let notify ?notfor key notif = let notfor = @@ -88,7 +89,7 @@ module Make (A : ARG) : let _ = Os_session.on_start_process (fun _ -> init ()); - Os_session.on_post_close_session (fun () -> deinit (); Lwt.return_unit) + Os_session.on_post_close_session (fun () -> deinit ()) end module type ARG_SIMPLE = sig @@ -105,7 +106,7 @@ module Make_Simple (A : ARG_SIMPLE) : type server_notif = A.notification type client_notif = A.notification - let prepare _ n = Lwt.return_some n + let prepare _ n = Some n let equal_key = ( = ) let max_resource = 1000 let max_identity_per_resource = 10 diff --git a/src/os_notif.eliomi b/src/os_notif.eliomi index bbd531b3..0a3e75ea 100644 --- a/src/os_notif.eliomi +++ b/src/os_notif.eliomi @@ -51,7 +51,7 @@ module type ARG = sig type server_notif type client_notif - val prepare : User.id option -> server_notif -> client_notif option Lwt.t + val prepare : User.id option -> server_notif -> client_notif option val equal_key : key -> key -> bool val max_resource : int val max_identity_per_resource : int diff --git a/src/os_page.eliom b/src/os_page.eliom index 1b6e6dea..448d9032 100644 --- a/src/os_page.eliom +++ b/src/os_page.eliom @@ -18,7 +18,6 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open%shared Lwt.Syntax open%shared Eliom_content.Html.F open%client Js_of_ocaml @@ -52,22 +51,17 @@ module type PAGE = sig val css : string list list val local_css : string list list val other_head : Html_types.head_content_fun Eliom_content.Html.elt list - val default_error_page : 'a -> 'b -> exn -> content Lwt.t + val default_error_page : 'a -> 'b -> exn -> content val default_connected_error_page : Os_types.User.id option -> 'a -> 'b -> exn - -> content Lwt.t + -> content - val default_predicate : 'a -> 'b -> bool Lwt.t - - val default_connected_predicate : - Os_types.User.id option - -> 'a - -> 'b - -> bool Lwt.t + val default_predicate : 'a -> 'b -> bool + val default_connected_predicate : Os_types.User.id option -> 'a -> 'b -> bool end module Default_config = struct @@ -90,10 +84,10 @@ module Default_config = struct p [txt "You must be connected to see this page."] :: de | _ -> de in - Lwt.return (content [div ~a:[a_class ["errormsg"]] (h2 [txt "Error"] :: l)]) + content [div ~a:[a_class ["errormsg"]] (h2 [txt "Error"] :: l)] - let default_predicate _ _ = Lwt.return_true - let default_connected_predicate _ _ _ = Lwt.return_true + let default_predicate _ _ = true + let default_connected_predicate _ _ _ = true let default_error_page _ _ exn = err_page exn let default_connected_error_page _ _ _ exn = err_page exn end @@ -157,16 +151,15 @@ module Make (C : PAGE) = struct gp pp = - let* content = - Lwt.catch - (fun () -> - let* b = predicate gp pp in - if b - then Lwt.catch (fun () -> f gp pp) (fun exc -> fallback gp pp exc) - else fallback gp pp (Predicate_failed None)) - (fun exc -> fallback gp pp (Predicate_failed (Some exc))) + let content = + try + let b = predicate gp pp in + if b + then try f gp pp with exc -> fallback gp pp exc + else fallback gp pp (Predicate_failed None) + with exc -> fallback gp pp (Predicate_failed (Some exc)) in - Lwt.return (make_page content) + make_page content let connected_page ?allow @@ -178,31 +171,24 @@ module Make (C : PAGE) = struct pp = let f_wrapped myid gp pp = - Lwt.catch - (fun () -> - let* b = predicate (Some myid) gp pp in - if b - then - Lwt.catch - (fun () -> f myid gp pp) - (fun exc -> fallback (Some myid) gp pp exc) - else Lwt.fail (Predicate_failed None)) - (function - | Predicate_failed _ as exc -> fallback (Some myid) gp pp exc - | exc -> fallback (Some myid) gp pp (Predicate_failed (Some exc))) + try + let b = predicate (Some myid) gp pp in + if b + then try f myid gp pp with exc -> fallback (Some myid) gp pp exc + else raise (Predicate_failed None) + with + | Predicate_failed _ as exc -> fallback (Some myid) gp pp exc + | exc -> fallback (Some myid) gp pp (Predicate_failed (Some exc)) in - let* content = - Lwt.catch - (fun () -> - Os_session.connected_fun ?allow ?deny - ~deny_fun:(fun myid_o -> - fallback myid_o gp pp Os_session.Permission_denied) - f_wrapped gp pp) - (function - | Os_session.Not_connected as exc -> fallback None gp pp exc - | exc -> Lwt.reraise exc) + let content = + try + Os_session.connected_fun ?allow ?deny + ~deny_fun:(fun myid_o -> + fallback myid_o gp pp Os_session.Permission_denied) + f_wrapped gp pp + with Os_session.Not_connected as exc -> fallback None gp pp exc in - Lwt.return (make_page content) + make_page content module Opt = struct let connected_page @@ -215,25 +201,21 @@ module Make (C : PAGE) = struct pp = let f_wrapped (myid_o : Os_types.User.id option) gp pp = - Lwt.catch - (fun () -> - let* b = predicate myid_o gp pp in - if b - then - Lwt.catch - (fun () -> f myid_o gp pp) - (fun exc -> fallback myid_o gp pp exc) - else Lwt.fail (Predicate_failed None)) - (function - | Predicate_failed _ as exc -> fallback myid_o gp pp exc - | exc -> fallback myid_o gp pp (Predicate_failed (Some exc))) + try + let b = predicate myid_o gp pp in + if b + then try f myid_o gp pp with exc -> fallback myid_o gp pp exc + else raise (Predicate_failed None) + with + | Predicate_failed _ as exc -> fallback myid_o gp pp exc + | exc -> fallback myid_o gp pp (Predicate_failed (Some exc)) in - let* content = + let content = Os_session.Opt.connected_fun ?allow ?deny ~deny_fun:(fun myid_o -> fallback myid_o gp pp Os_session.Permission_denied) f_wrapped gp pp in - Lwt.return (make_page content) + make_page content end end] diff --git a/src/os_page.eliomi b/src/os_page.eliomi index 84ab8943..a4c17f3f 100644 --- a/src/os_page.eliomi +++ b/src/os_page.eliomi @@ -70,7 +70,7 @@ module type PAGE = sig (** [other_head] is a list of custom elements to add in the head section. It can be used to add elements, for example. *) - val default_error_page : 'a -> 'b -> exn -> content Lwt.t + val default_error_page : 'a -> 'b -> exn -> content (** [default_error_page get_param post_param exn] is the default error page. [get_param] (resp. [post_param]) is the GET (resp. POST) parameters sent to the error page. @@ -83,19 +83,15 @@ module type PAGE = sig -> 'a -> 'b -> exn - -> content Lwt.t + -> content (** [default_connected_error_page userid_o get_param post_param exn] is the default error page for connected pages. *) - val default_predicate : 'a -> 'b -> bool Lwt.t + val default_predicate : 'a -> 'b -> bool (** [default_predicate get_param post_param] is the default predicate. *) - val default_connected_predicate : - Os_types.User.id option - -> 'a - -> 'b - -> bool Lwt.t + val default_connected_predicate : Os_types.User.id option -> 'a -> 'b -> bool (** [default_connected_predicate userid_o get_param post_param] is the default predicate for connected pages. *) @@ -117,12 +113,12 @@ module Make (_ : PAGE) : sig for this app *) val page : - ?predicate:('a -> 'b -> bool Lwt.t) - -> ?fallback:('a -> 'b -> exn -> content Lwt.t) - -> ('a -> 'b -> content Lwt.t) + ?predicate:('a -> 'b -> bool) + -> ?fallback:('a -> 'b -> exn -> content) + -> ('a -> 'b -> content) -> 'a -> 'b - -> Html_types.html Eliom_content.Html.elt Lwt.t + -> Html_types.html Eliom_content.Html.elt (** Default wrapper for service handler generating pages. It takes as parameter a function generating page content (body content) and transforms it into a function generating @@ -138,12 +134,12 @@ module Make (_ : PAGE) : sig val connected_page : ?allow:Os_types.Group.t list -> ?deny:Os_types.Group.t list - -> ?predicate:(Os_types.User.id option -> 'a -> 'b -> bool Lwt.t) - -> ?fallback:(Os_types.User.id option -> 'a -> 'b -> exn -> content Lwt.t) - -> (Os_types.User.id option -> 'a -> 'b -> content Lwt.t) + -> ?predicate:(Os_types.User.id option -> 'a -> 'b -> bool) + -> ?fallback:(Os_types.User.id option -> 'a -> 'b -> exn -> content) + -> (Os_types.User.id option -> 'a -> 'b -> content) -> 'a -> 'b - -> Html_types.html Eliom_content.Html.elt Lwt.t + -> Html_types.html Eliom_content.Html.elt (** Wrapper for pages that first checks if the user is connected. See {!Os_session.Opt.connected_fun}. *) @@ -152,12 +148,12 @@ module Make (_ : PAGE) : sig val connected_page : ?allow:Os_types.Group.t list -> ?deny:Os_types.Group.t list - -> ?predicate:(Os_types.User.id option -> 'a -> 'b -> bool Lwt.t) - -> ?fallback:(Os_types.User.id option -> 'a -> 'b -> exn -> content Lwt.t) - -> (Os_types.User.id -> 'a -> 'b -> content Lwt.t) + -> ?predicate:(Os_types.User.id option -> 'a -> 'b -> bool) + -> ?fallback:(Os_types.User.id option -> 'a -> 'b -> exn -> content) + -> (Os_types.User.id -> 'a -> 'b -> content) -> 'a -> 'b - -> Html_types.html Eliom_content.Html.elt Lwt.t + -> Html_types.html Eliom_content.Html.elt (** Wrapper for pages that first checks if the user is connected. See {!Os_session.connected_fun}. *) diff --git a/src/os_request_cache.eliom b/src/os_request_cache.eliom index 2a62b498..297abf68 100644 --- a/src/os_request_cache.eliom +++ b/src/os_request_cache.eliom @@ -18,8 +18,6 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Lwt.Syntax - module type Cache_sig = sig type key type value @@ -27,7 +25,7 @@ module type Cache_sig = sig val has : key -> bool val set : key -> value -> unit val reset : key -> unit - val get : key -> value Lwt.t + val get : key -> value end module Make (M : sig @@ -35,7 +33,7 @@ module Make (M : sig type value val compare : key -> key -> int - val get : key -> value Lwt.t + val get : key -> value end) = struct type key = M.key @@ -74,9 +72,9 @@ struct then M.get k (* Not during a request. No cache. *) else let table = Eliom_reference.Volatile.get cache in - try Lwt.return (MMap.find k table) + try MMap.find k table with Not_found -> - let* ret = M.get k in + let ret = M.get k in Eliom_reference.Volatile.set cache (MMap.add k ret table); - Lwt.return ret + ret end diff --git a/src/os_request_cache.eliomi b/src/os_request_cache.eliomi index bc3856b1..8ca1268e 100644 --- a/src/os_request_cache.eliomi +++ b/src/os_request_cache.eliomi @@ -37,7 +37,7 @@ module type Cache_sig = sig val reset : key -> unit (** Remove a [value] for the given key. *) - val get : key -> value Lwt.t + val get : key -> value (** Get the value corresponding to the given key. *) end @@ -53,7 +53,7 @@ module Make : functor val compare : key -> key -> int (** The function used to compare keys. *) - val get : key -> value Lwt.t + val get : key -> value (** This function is called when the value corresponding to a key is not yet stored into the cache. *) end) diff --git a/src/os_session.eliom b/src/os_session.eliom index c966f1cc..f05003e4 100644 --- a/src/os_session.eliom +++ b/src/os_session.eliom @@ -18,8 +18,6 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Lwt.Syntax - let log_section = Logs.Src.create "os:session" let user_indep_state_hierarchy = Eliom_common.create_scope_hierarchy "userindep" let user_indep_process_scope = `Client_process user_indep_state_hierarchy @@ -33,12 +31,12 @@ let new_process_eref = Eliom_reference.Volatile.eref ~scope:user_indep_process_scope true let mk_action_queue name = - let r = ref (fun _ -> Lwt.return_unit) in + let r = ref (fun _ -> ()) in ( (fun f -> let oldf = !r in r := fun arg -> - let* () = oldf arg in + let () = oldf arg in f arg) , fun arg -> Logs.debug ~src:log_section (fun fmt -> @@ -65,11 +63,11 @@ let on_start_process, start_process_action = mk_action_queue "start process" let on_start_connected_process f = on_start_process (fun myid_o -> - match myid_o with Some myid -> f myid | None -> Lwt.return_unit) + match myid_o with Some myid -> f myid | None -> ()) let on_start_unconnected_process f = on_start_process (fun myid_o -> - match myid_o with Some _myid -> Lwt.return_unit | None -> f ()) + match myid_o with Some _myid -> () | None -> f ()) [%%shared exception Not_connected @@ -86,24 +84,24 @@ let connect_volatile uid = open_session_action uid let connect_string uid = - let* () = + let () = Eliom_state.set_persistent_data_session_group ~scope:Eliom_common.default_session_scope uid in - let* () = connect_volatile uid in + let () = connect_volatile uid in let uid = Int64.of_string uid in start_process_action (Some uid) let disconnect () = - let* () = pre_close_session_action () in - let* () = Eliom_state.discard ~scope:Eliom_common.default_session_scope () in - let* () = Eliom_state.discard ~scope:Eliom_common.default_process_scope () in - let* () = Eliom_state.discard ~scope:Eliom_common.request_scope () in + let () = pre_close_session_action () in + let () = Eliom_state.discard ~scope:Eliom_common.default_session_scope () in + let () = Eliom_state.discard ~scope:Eliom_common.default_process_scope () in + let () = Eliom_state.discard ~scope:Eliom_common.request_scope () in post_close_session_action () let connect ?(expire = false) userid = - let* () = disconnect () in - let* () = + let () = disconnect () in + let () = if expire then ( let open Eliom_common in @@ -111,13 +109,13 @@ let connect ?(expire = false) userid = Eliom_state.set_service_cookie_exp_date ~cookie_scope None; Eliom_state.set_volatile_data_cookie_exp_date ~cookie_scope None; Eliom_state.set_persistent_data_cookie_exp_date ~cookie_scope None) - else Lwt.return_unit + else () in connect_string (Int64.to_string userid) let set_warn_connection_change, warn_connection_changed = let r = ref (fun _ -> ()) in - (fun f -> r := f), fun state -> !r state; Lwt.return_unit + (fun f -> r := f), fun state -> !r state let disconnect_all ?sitedata @@ -127,9 +125,7 @@ let disconnect_all () = let close_my_sessions = userid = None in - let* () = - if close_my_sessions then pre_close_session_action () else Lwt.return_unit - in + let () = if close_my_sessions then pre_close_session_action () else () in let userid = match userid with | None -> ( @@ -138,7 +134,7 @@ let disconnect_all | Some userid -> Some userid in match userid with - | None -> Lwt.return_unit + | None -> () | Some userid -> (* We do not close the group, as it may contain user data. We close all sessions from group instead. *) @@ -151,23 +147,23 @@ let disconnect_all ; Eliom_state.Ext.service_group_state ~scope:Eliom_common.default_group_scope group_name ] in - let* ui_states = + let ui_states = List.fold_left (fun acc state -> - Lwt.bind - (Eliom_reference.Ext.get state - (current_user_indep_session_state - :> ( [< `Session_group | `Session | `Client_process] - , [< `Data | `Pers] ) - Eliom_state.Ext.state - option - Eliom_reference.eref)) - (function - | None -> acc - | Some s -> - let* acc = acc in - Lwt.return (s :: acc))) - Lwt.return_nil + match + Eliom_reference.Ext.get state + (current_user_indep_session_state + :> ( [< `Session_group | `Session | `Client_process] + , [< `Data | `Pers] ) + Eliom_state.Ext.state + option + Eliom_reference.eref) + with + | None -> acc + | Some s -> + let acc = acc in + s :: acc) + [] (Eliom_state.Ext.fold_volatile_sub_states ?sitedata ~state: (Eliom_state.Ext.volatile_data_group_state @@ -175,89 +171,86 @@ let disconnect_all (fun acc s -> s :: acc) []) in - let* + let (* Closing all sessions: *) () = - Lwt_list.iter_s + List.iter (fun state -> Eliom_state.Ext.iter_sub_states ?sitedata ~state @@ fun state -> Eliom_state.Ext.discard_state ?sitedata ~state ()) states in - let* () = - if close_my_sessions - then post_close_session_action () - else Lwt.return_unit - in - let* + let () = if close_my_sessions then post_close_session_action () else () in + let (* Warn every client process that the session is closed: *) () = - Lwt_list.iter_s + List.iter (fun state -> Eliom_state.Ext.iter_sub_states ?sitedata ~state warn_connection_changed) ui_states in - let* + let (* Closing user_indep states, if requested: *) () = if user_indep then - Lwt_list.iter_s + List.iter (fun state -> Eliom_state.Ext.discard_state ?sitedata ~state ()) ui_states - else Lwt.return_unit + else () in let () = if with_restart then ignore [%client (Os_handlers.restart () : unit)] in - Lwt.return_unit + () let check_allow_deny userid allow deny = - let* b = + let b = match allow with - | None -> Lwt.return_true (* By default allow all *) + | None -> true + (* By default allow all *) | Some l -> - (* allow only users from one of the groups of list l *) - Lwt_list.fold_left_s + List.fold_left + (* allow only users from one of the groups of list l *) (fun b group -> - let* b2 = Os_group.in_group ~userid ~group () in - Lwt.return (b || b2)) + let b2 = Os_group.in_group ~userid ~group () in + b || b2) false l in - let* b = + let b = match deny with - | None -> Lwt.return b (* By default deny nobody *) + | None -> b (* By default deny nobody *) | Some l -> - (* allow only users that are not + List.fold_left + (* allow only users that are not in one of the groups of list l *) - Lwt_list.fold_left_s (fun b group -> - let* b2 = Os_group.in_group ~userid ~group () in - Lwt.return (b && not b2)) + let b2 = Os_group.in_group ~userid ~group () in + b && not b2) b l in if b - then Lwt.return_unit + then () else - let* () = denied_request_action (Some userid) in - Lwt.fail Permission_denied + let () = denied_request_action (Some userid) in + raise Permission_denied let get_session () = let uids = Eliom_state.get_volatile_data_session_group () in let get_uid uid = try Eliom_lib.Option.map Int64.of_string uid with Failure _ -> None in - let* uid = + let uid = match get_uid uids with | None -> ( - let* uids = Eliom_state.get_persistent_data_session_group () in + let uids = Eliom_state.get_persistent_data_session_group () in match get_uid uids with | Some uid -> - let* + let (* A persistent session exists, but the volatile session has gone. It may be due to a timeout or may be the server has been relaunched. @@ -267,28 +260,25 @@ let get_session () = = connect_volatile (Int64.to_string uid) in - Lwt.return_some uid - | None -> Lwt.return_none) - | Some uid -> Lwt.return_some uid + Some uid + | None -> None) + | Some uid -> Some uid in (* Check if the user exists in the DB *) match uid with - | None -> Lwt.return_none - | Some uid -> - Lwt.catch - (fun () -> - let* _user = Os_user.user_of_userid uid in - Lwt.return_some uid) - (function - | Os_user.No_such_user -> - let* - (* If session exists and no user in DB, close the session *) - () - = - disconnect () - in - Lwt.return_none - | exc -> Lwt.reraise exc) + | None -> None + | Some uid -> ( + try + let _user = Os_user.user_of_userid uid in + Some uid + with Os_user.No_such_user -> + let + (* If session exists and no user in DB, close the session *) + () + = + disconnect () + in + None) (** The connection wrapper checks whether the user is connected, and calls the page generator accordingly. @@ -315,7 +305,7 @@ let%server ~allow ~deny ?(force_unconnected = false) - ?(deny_fun = fun _ -> Lwt.fail Permission_denied) + ?(deny_fun = fun _ -> raise Permission_denied) connected not_connected gp @@ -324,31 +314,30 @@ let%server let new_process = (not force_unconnected) && Eliom_reference.Volatile.get new_process_eref in - let* uid = if force_unconnected then Lwt.return_none else get_session () in - let* () = request_action uid in - let* () = + let uid = if force_unconnected then None else get_session () in + let () = request_action uid in + let () = if new_process then ( Eliom_reference.Volatile.set new_process_eref false; start_process_action uid) - else Lwt.return_unit + else () in match uid with | None -> if allow = None then - let* () = unconnected_request_action () in + let () = unconnected_request_action () in not_connected gp pp else - let* () = denied_request_action None in + let () = denied_request_action None in deny_fun None - | Some id -> - Lwt.catch - (fun () -> - let* () = check_allow_deny id allow deny in - let* () = connected_request_action id in - connected id gp pp) - (function Permission_denied -> deny_fun uid | exc -> Lwt.reraise exc) + | Some id -> ( + try + let () = check_allow_deny id allow deny in + let () = connected_request_action id in + connected id gp pp + with Permission_denied -> deny_fun uid) let%client get_current_userid_o = ref (fun () -> assert false) @@ -371,12 +360,12 @@ let%client | Some myid -> connected myid gp pp let%shared connected_fun ?allow ?deny ?deny_fun f gp pp = - gen_wrapper ~allow ~deny ?deny_fun f (fun _ _ -> Lwt.fail Not_connected) gp pp + gen_wrapper ~allow ~deny ?deny_fun f (fun _ _ -> raise Not_connected) gp pp let%shared connected_rpc ?allow ?deny ?deny_fun f pp = gen_wrapper ~allow ~deny ?deny_fun (fun myid _ p -> f myid p) - (fun _ _ -> Lwt.fail Not_connected) + (fun _ _ -> raise Not_connected) () pp let%shared connected_wrapper ?allow ?deny ?deny_fun ?force_unconnected f pp = diff --git a/src/os_session.eliomi b/src/os_session.eliomi index 0858a0d2..ad4b701c 100644 --- a/src/os_session.eliomi +++ b/src/os_session.eliomi @@ -22,39 +22,39 @@ restrict access to services or server functions, define actions to be executed at some points of the session. *) -val on_start_process : (Os_types.User.id option -> unit Lwt.t) -> unit +val on_start_process : (Os_types.User.id option -> unit) -> unit (** Call this to add an action to be done on server side when the process starts *) -val on_start_connected_process : (Os_types.User.id -> unit Lwt.t) -> unit +val on_start_connected_process : (Os_types.User.id -> unit) -> unit (** Call this to add an action to be done when the process starts in connected mode, or when the user logs in *) -val on_start_unconnected_process : (unit -> unit Lwt.t) -> unit +val on_start_unconnected_process : (unit -> unit) -> unit (** Call this to add an action to be done on server side when the process starts but only when not in connected mode *) -val on_connected_request : (Os_types.User.id -> unit Lwt.t) -> unit +val on_connected_request : (Os_types.User.id -> unit) -> unit (** Call this to add an action to be done at each connected request. The function takes the user id as parameter. *) -val on_unconnected_request : (unit -> unit Lwt.t) -> unit +val on_unconnected_request : (unit -> unit) -> unit (** Call this to add an action to be done at each unconnected request. *) -val on_open_session : (Os_types.User.id -> unit Lwt.t) -> unit +val on_open_session : (Os_types.User.id -> unit) -> unit (** Call this to add an action to be done just after opening a session The function takes the user id as parameter. *) -val on_pre_close_session : (unit -> unit Lwt.t) -> unit +val on_pre_close_session : (unit -> unit) -> unit (** Call this to add an action to be done just before closing the session *) -val on_post_close_session : (unit -> unit Lwt.t) -> unit +val on_post_close_session : (unit -> unit) -> unit (** Call this to add an action to be done just after closing the session *) -val on_request : (Os_types.User.id option -> unit Lwt.t) -> unit +val on_request : (Os_types.User.id option -> unit) -> unit (** Call this to add an action to be done just before handling a request *) -val on_denied_request : (Os_types.User.id option -> unit Lwt.t) -> unit +val on_denied_request : (Os_types.User.id option -> unit) -> unit (** Call this to add an action to be done just for each denied request. The function takes the user id as parameter, if some user is connected. *) @@ -74,7 +74,7 @@ exception Permission_denied [%%server.start] -val connect : ?expire:bool -> Os_types.User.id -> unit Lwt.t +val connect : ?expire:bool -> Os_types.User.id -> unit (** Close current session (if any) by calling disconnect, then open a new session for a user by setting a session group for the browser which initiated the current request. @@ -91,7 +91,7 @@ val disconnect_all : -> ?user_indep:bool -> ?with_restart:bool -> unit - -> unit Lwt.t + -> unit (** Close all sessions of current user (or [userid] if present). If [?user_indep] is [true] (default), will also affect [user_indep_session_scope]. @@ -117,7 +117,7 @@ val disconnect_all : ?user_indep:bool -> unit -> unit Lwt.t [%%shared.start] -val disconnect : unit -> unit Lwt.t +val disconnect : unit -> unit (** Close a session by discarding server side states for current browser (session and session group), current client process (tab) and current request. @@ -129,11 +129,11 @@ val disconnect : unit -> unit Lwt.t val connected_fun : ?allow:Os_types.Group.t list -> ?deny:Os_types.Group.t list - -> ?deny_fun:(Os_types.User.id option -> 'c Lwt.t) - -> (Os_types.User.id -> 'a -> 'b -> 'c Lwt.t) + -> ?deny_fun:(Os_types.User.id option -> 'c) + -> (Os_types.User.id -> 'a -> 'b -> 'c) -> 'a -> 'b - -> 'c Lwt.t + -> 'c (** Wrapper for service handlers that fetches automatically connection information. Register [(connected_fun f)] as handler for your services, @@ -161,20 +161,20 @@ val connected_fun : val connected_rpc : ?allow:Os_types.Group.t list -> ?deny:Os_types.Group.t list - -> ?deny_fun:(Os_types.User.id option -> 'b Lwt.t) - -> (Os_types.User.id -> 'a -> 'b Lwt.t) + -> ?deny_fun:(Os_types.User.id option -> 'b) + -> (Os_types.User.id -> 'a -> 'b) -> 'a - -> 'b Lwt.t + -> 'b (** Wrapper for server functions (see {!connected_fun}). *) val connected_wrapper : ?allow:Os_types.Group.t list -> ?deny:Os_types.Group.t list - -> ?deny_fun:(Os_types.User.id option -> 'b Lwt.t) + -> ?deny_fun:(Os_types.User.id option -> 'b) -> ?force_unconnected:bool - -> ('a -> 'b Lwt.t) + -> ('a -> 'b) -> 'a - -> 'b Lwt.t + -> 'b (** Wrapper for server functions when you do not need userid (see {!connected_fun}). It is recommended to use this wrapper for all your server functions! *) @@ -183,12 +183,12 @@ module Opt : sig val connected_fun : ?allow:Os_types.Group.t list -> ?deny:Os_types.Group.t list - -> ?deny_fun:(Os_types.User.id option -> 'c Lwt.t) + -> ?deny_fun:(Os_types.User.id option -> 'c) -> ?force_unconnected:bool - -> (Os_types.User.id option -> 'a -> 'b -> 'c Lwt.t) + -> (Os_types.User.id option -> 'a -> 'b -> 'c) -> 'a -> 'b - -> 'c Lwt.t + -> 'c (** Same as {!connected_fun} but instead of failing in case the user is not connected, the function given as parameter takes an [Os_types.User.id option] for user id. @@ -197,11 +197,11 @@ module Opt : sig val connected_rpc : ?allow:Os_types.Group.t list -> ?deny:Os_types.Group.t list - -> ?deny_fun:(Os_types.User.id option -> 'b Lwt.t) + -> ?deny_fun:(Os_types.User.id option -> 'b) -> ?force_unconnected:bool - -> (Os_types.User.id option -> 'a -> 'b Lwt.t) + -> (Os_types.User.id option -> 'a -> 'b) -> 'a - -> 'b Lwt.t + -> 'b (** Same as {!connected_rpc} but instead of failing in case the user is not connected, the function given as parameter takes an [Os_types.User.id option] for user id. diff --git a/src/os_tips.eliom b/src/os_tips.eliom index 12937646..6a37a057 100644 --- a/src/os_tips.eliom +++ b/src/os_tips.eliom @@ -18,7 +18,6 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open%shared Lwt.Syntax open%shared Eliom_content.Html open%shared Eliom_content.Html.F open%client Js_of_ocaml @@ -69,13 +68,12 @@ let%client get_tips_seen () = Lwt.return !tips_seen_client_ref let%server () = Os_session.on_start_connected_process (fun _ -> - let* tips = get_tips_seen () in - ignore [%client (tips_seen_client_ref := ~%tips : unit)]; - Lwt.return_unit) + let tips = get_tips_seen () in + ignore [%client (tips_seen_client_ref := ~%tips : unit)]) (* notify the server that a user has seen a tip *) -let%rpc set_tip_seen (name : string) : unit Lwt.t = - let* prev = Eliom_reference.Volatile.get seen_by_user in +let%rpc set_tip_seen (name : string) : unit = + let prev = Eliom_reference.Volatile.get seen_by_user in let newset = Stringset.add (name : string) prev in match Os_current_user.Opt.get_current_userid () with | None -> Eliom_reference.set tips_seen_not_connected newset @@ -86,8 +84,8 @@ let%client set_tip_seen name = set_tip_seen name (* counterpart of set_tip_seen *) -let%rpc unset_tip_seen (name : string) : unit Lwt.t = - let* prev = Eliom_reference.Volatile.get seen_by_user in +let%rpc unset_tip_seen (name : string) : unit = + let prev = Eliom_reference.Volatile.get seen_by_user in let newset = Stringset.remove name prev in match Os_current_user.Opt.get_current_userid () with | None -> Eliom_reference.set tips_seen_not_connected newset @@ -98,8 +96,8 @@ let%client unset_tip_seen name = unset_tip_seen name let%shared tip_seen name = - let* seen = get_tips_seen () in - Lwt.return @@ Stringset.mem name seen + let seen = get_tips_seen () in + Stringset.mem name seen (* I want to see the tips again *) let%server reset_tips_user myid_o = @@ -107,7 +105,7 @@ let%server reset_tips_user myid_o = | None -> Eliom_reference.set tips_seen_not_connected Stringset.empty | _ -> Eliom_reference.set tips_seen Stringset.empty -let%rpc reset_tips myid_o () : unit Lwt.t = reset_tips_user myid_o +let%rpc reset_tips myid_o () : unit = reset_tips_user myid_o let%server reset_tips_service = Eliom_service.create ~name:"resettips" ~path:Eliom_service.No_path @@ -130,7 +128,7 @@ let%shared block ?(a = []) ?(recipient = `All) - ?(onclose = [%client (fun () -> Lwt.return_unit : unit -> unit Lwt.t)]) + ?(onclose = [%client (fun () -> Lwt.return_unit : unit -> unit)]) ~name ~content () @@ -138,12 +136,12 @@ let%shared let myid_o = Os_current_user.Opt.get_current_userid () in match recipient, myid_o with | `All, _ | `Not_connected, None | `Connected, Some _ -> - let* seen = get_tips_seen () in + let seen = get_tips_seen () in if Stringset.mem name seen - then Lwt.return_none + then None else let box_ref = ref None in - let close : (unit -> unit Lwt.t) Eliom_client_value.t = + let close : (unit -> unit) Eliom_client_value.t = [%client fun () -> let* () = ~%onclose () in @@ -154,7 +152,7 @@ let%shared in set_tip_seen ~%name] in - let* c = content close in + let c = content close in let c = [div ~a:[a_class ["os-tip-content"]] c] in let box = D.div @@ -167,8 +165,8 @@ let%shared :: c) in box_ref := Some box; - Lwt.return_some box - | _ -> Lwt.return_none + Some box + | _ -> None let%client onload_waiter () = let* _ = Eliom_client.lwt_onload () in @@ -310,19 +308,18 @@ let%shared ?onclose ~(name : string) ~(content : - ((unit -> unit Lwt.t) - -> Html_types.div_content Eliom_content.Html.elt list Lwt.t) + ((unit -> unit) -> Html_types.div_content Eliom_content.Html.elt list) Eliom_client_value.t) () = let delay : float option = delay in - let onclose : (unit -> unit Lwt.t) Eliom_client_value.t option = onclose in + let onclose : (unit -> unit) Eliom_client_value.t option = onclose in let myid_o = Os_current_user.Opt.get_current_userid () in match recipient, myid_o with | `All, _ | `Not_connected, None | `Connected, Some _ -> - let* seen = get_tips_seen () in + let seen = get_tips_seen () in if Stringset.mem name seen - then Lwt.return_unit + then () else let _ = [%client @@ -334,5 +331,5 @@ let%shared ~content:~%content ()) : unit)] in - Lwt.return_unit - | _ -> Lwt.return_unit + () + | _ -> () diff --git a/src/os_tips.eliomi b/src/os_tips.eliomi index 8de51e18..6fac6c6a 100644 --- a/src/os_tips.eliomi +++ b/src/os_tips.eliomi @@ -36,14 +36,13 @@ val bubble : -> ?width:int Eliom_client_value.t -> ?parent_node:[< `Body | Html_types.body_content] Eliom_content.Html.elt -> ?delay:float - -> ?onclose:(unit -> unit Lwt.t) Eliom_client_value.t + -> ?onclose:(unit -> unit) Eliom_client_value.t -> name:string -> content: - ((unit -> unit Lwt.t) - -> Html_types.div_content Eliom_content.Html.elt list Lwt.t) + ((unit -> unit) -> Html_types.div_content Eliom_content.Html.elt list) Eliom_client_value.t -> unit - -> unit Lwt.t + -> unit (** Display tips in pages, as a speech bubble. One tip is displayed at a time. @@ -69,33 +68,33 @@ val bubble : val block : ?a:[< Html_types.div_attrib > `Class] Eliom_content.Html.D.attrib list -> ?recipient:[> `All | `Connected | `Not_connected] - -> ?onclose:(unit -> unit Lwt.t) Eliom_client_value.t + -> ?onclose:(unit -> unit) Eliom_client_value.t -> name:string -> content: - ((unit -> unit Lwt.t) Eliom_client_value.t - -> Html_types.div_content Eliom_content.Html.elt list Lwt.t) + ((unit -> unit) Eliom_client_value.t + -> Html_types.div_content Eliom_content.Html.elt list) -> unit - -> [> `Div] Eliom_content.Html.elt option Lwt.t + -> [> `Div] Eliom_content.Html.elt option (** Return a box containing a tip, to be inserted where you want in a page. The box contains a close button. Once it is closed, it is never displayed again for this user. In that case the function returns [None]. *) -val reset_tips : unit -> unit Lwt.t +val reset_tips : unit -> unit (** Call this function to reset tips for current user. Tips will be shown again from the beginning. *) -val set_tip_seen : string -> unit Lwt.t +val set_tip_seen : string -> unit (** Call this function to mark a tip as "already seen" by current user. This is done automatically when a tip is closed. *) -val unset_tip_seen : string -> unit Lwt.t +val unset_tip_seen : string -> unit (** Counterpart of set_tip_seen. Does not fail if the tip has not been seen yet *) -val tip_seen : string -> bool Lwt.t +val tip_seen : string -> bool (** Returns whether a tip has been seen or not. *) val reset_tips_service : diff --git a/src/os_uploader.eliom b/src/os_uploader.eliom index 04b88f68..566c2fcc 100644 --- a/src/os_uploader.eliom +++ b/src/os_uploader.eliom @@ -18,14 +18,12 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open%server Lwt.Syntax - [%%server exception Error_while_cropping of Unix.process_status exception Error_while_resizing of Unix.process_status] let%server resize_image ~src ?(dst = src) ~width ~height () = - let* resize_unix_result = + let resize_unix_result = Lwt_process.exec ( "" , [| "convert" @@ -48,20 +46,20 @@ let%server resize_image ~src ?(dst = src) ~width ~height () = ; "jpg:" ^ dst |] ) in match resize_unix_result with - | Unix.WEXITED status_code when status_code = 0 -> Lwt.return_unit - | unix_process_status -> Lwt.fail (Error_while_resizing unix_process_status) + | Unix.WEXITED status_code when status_code = 0 -> () + | unix_process_status -> raise (Error_while_resizing unix_process_status) let%server get_image_width file = - let* width = + let width = Lwt_process.pread ("", [|"convert"; file; "-print"; "%w"; "/dev/null"|]) in - Lwt.return (int_of_string width) + int_of_string width let%server get_image_height file = - let* height = + let height = Lwt_process.pread ("", [|"convert"; file; "-print"; "%h"; "/dev/null"|]) in - Lwt.return (int_of_string height) + int_of_string height let%server crop_image ~src ?(dst = src) ?ratio ~top ~right ~bottom ~left () = (* Given arguments are in percent. Use this to convert to pixel. The full size @@ -69,8 +67,8 @@ let%server crop_image ~src ?(dst = src) ?ratio ~top ~right ~bottom ~left () = let pixel_of_percent percent full_size_px = truncate percent * full_size_px / 100 in - let* width_src = get_image_width src in - let* height_src = get_image_height src in + let width_src = get_image_width src in + let height_src = get_image_height src in let left_px = pixel_of_percent left width_src in let top_px = pixel_of_percent top height_src in let width_cropped = width_src - left_px - pixel_of_percent right width_src in @@ -79,7 +77,7 @@ let%server crop_image ~src ?(dst = src) ?ratio ~top ~right ~bottom ~left () = | None -> height_src - top_px - pixel_of_percent bottom height_src | Some ratio -> truncate (float_of_int width_cropped /. ratio) in - let* crop_unix_result = + let crop_unix_result = Lwt_process.exec ( "" , [| "convert" @@ -92,7 +90,7 @@ let%server crop_image ~src ?(dst = src) ?ratio ~top ~right ~bottom ~left () = match crop_unix_result with | Unix.WEXITED status_code when status_code = 0 -> resize_image ~src:dst ~dst ~width:width_cropped ~height:height_cropped () - | unix_process_status -> Lwt.fail (Error_while_cropping unix_process_status) + | unix_process_status -> raise (Error_while_cropping unix_process_status) let%server record_image directory ?ratio ?cropping file = let make_file_saver cp () = @@ -103,8 +101,8 @@ let%server record_image directory ?ratio ?cropping file = fun file_info -> let fname = new_filename () in let fpath = directory ^ "/" ^ fname in - let* () = cp (Eliom_request_info.get_tmp_filename file_info) fpath in - Lwt.return fname + let () = cp (Eliom_request_info.get_tmp_filename file_info) fpath in + fname in let cp = match cropping with diff --git a/src/os_uploader.eliomi b/src/os_uploader.eliomi index eff8e522..ff8d6c3c 100644 --- a/src/os_uploader.eliomi +++ b/src/os_uploader.eliomi @@ -29,10 +29,10 @@ exception Error_while_cropping of Unix.process_status exception Error_while_resizing of Unix.process_status (** Raised if an error occurred while resizing a picture. The corresponding code status is given in parameter. *) -val get_image_height : string -> int Lwt.t +val get_image_height : string -> int (** Return the height of the given image. *) -val get_image_width : string -> int Lwt.t +val get_image_width : string -> int (** Return the width of the given image. *) val resize_image : @@ -41,7 +41,7 @@ val resize_image : -> width:int -> height:int -> unit - -> unit Lwt.t + -> unit (** Resize the given image ([src]) and save it to [dst] (default is the source file). If an error occurred, it raises the exception [Error_while_resizing] with the corresponding unix process status. @@ -56,7 +56,7 @@ val crop_image : -> bottom:float -> left:float -> unit - -> unit Lwt.t + -> unit (** [crop_image ~src ?dst ?ratio ~top ~right ~bottom ~left] crops the image saved in [src] and saves the result in [dst] (default is the source file). [top], [right], [bottom] and [left] are the number of pixels the image must @@ -71,7 +71,7 @@ val record_image : -> ?ratio:float -> ?cropping:float * float * float * float -> Ocsigen_extensions.file_info - -> string Lwt.t + -> string (** [record_image directory ?ratio ?cropping:(top, right, bottom, left) file] crops the image like [crop_image] and save it in the directory [directory]. If an error occurred, it raises the exception [Error_while_resizing] or diff --git a/src/os_user.eliom b/src/os_user.eliom index 372619b2..80c4cde9 100644 --- a/src/os_user.eliom +++ b/src/os_user.eliom @@ -18,8 +18,6 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Lwt.Syntax - [%%shared type id = Os_types.User.id [@@deriving json] @@ -100,24 +98,21 @@ module MCache = Os_request_cache.Make (struct let compare = compare let get key = - Lwt.catch - (fun () -> - let* g = Os_db.User.user_of_userid key in - Lwt.return (create_user_from_db0 g)) - (function - | Os_db.No_such_resource -> Lwt.fail No_such_user - | exc -> Lwt.reraise exc) + try + let g = Os_db.User.user_of_userid key in + create_user_from_db0 g + with Os_db.No_such_resource -> raise No_such_user end) (* Overwrite the function [user_of_userid] of [Os_db.User] and use the [get] function of the cache module. *) let user_of_userid userid = - let* u, _ = MCache.get userid in - Lwt.return u + let u, _ = MCache.get userid in + u let password_set userid = - let* _, s = MCache.get userid in - Lwt.return s + let _, s = MCache.get userid in + s (* ----------------------------------------------------------------- @@ -130,29 +125,27 @@ let password_set userid = let create ?password ?avatar ?language ?email ~firstname ~lastname () = let password = match password with Some "" -> None | _ -> password in let really_create () = - let* userid = + let userid = Os_db.User.create ~firstname ~lastname ?password ?avatar ?language ?email () in user_of_userid userid in match email with - | Some email -> - Lwt.catch - (fun () -> - let* userid = Os_db.User.userid_of_email email in - Lwt.fail (Already_exists userid)) - (function - | Os_db.No_such_resource -> really_create () | exc -> Lwt.reraise exc) + | Some email -> ( + try + let userid = Os_db.User.userid_of_email email in + raise (Already_exists userid) + with Os_db.No_such_resource -> really_create ()) | None -> really_create () (* Overwrites the function [update] of [Os_db.User] to reset the cache *) let update ?password ?avatar ?language ~firstname ~lastname userid = - let* () = + let () = Os_db.User.update ?password ?avatar ?language ~firstname ~lastname userid in - MCache.reset userid; Lwt.return_unit + MCache.reset userid let update' ?password user = update ?password ?avatar:(avatar_of_user user) @@ -160,22 +153,22 @@ let update' ?password user = ~lastname:(lastname_of_user user) (userid_of_user user) let update_password ~userid ~password = - let* () = Os_db.User.update_password ~userid ~password in - MCache.reset userid; Lwt.return_unit + let () = Os_db.User.update_password ~userid ~password in + MCache.reset userid let update_language ~userid ~language = - let* () = Os_db.User.update_language ~userid ~language in - MCache.reset userid; Lwt.return_unit + let () = Os_db.User.update_language ~userid ~language in + MCache.reset userid let update_avatar ~userid ~avatar = - let* () = Os_db.User.update_avatar ~userid ~avatar in - MCache.reset userid; Lwt.return_unit + let () = Os_db.User.update_avatar ~userid ~avatar in + MCache.reset userid let get_language userid = Os_db.User.get_language userid let get_users ?pattern () = - let* users = Os_db.User.get_users ?pattern () in - Lwt.return (List.map create_user_from_db users) + let users = Os_db.User.get_users ?pattern () in + List.map create_user_from_db users let set_pwd_crypt_fun a = Os_db.pwd_crypt_ref := a diff --git a/src/os_user.eliomi b/src/os_user.eliomi index 22b63831..f1ce2dea 100644 --- a/src/os_user.eliomi +++ b/src/os_user.eliomi @@ -44,7 +44,7 @@ exception Already_exists of Os_types.User.id exception No_such_user (** Exception used if an user doesn't exist. *) -val password_set : Os_types.User.id -> bool Lwt.t +val password_set : Os_types.User.id -> bool (** [password_set userid] returns [true] if the user with ID [userid] has set a password. Else [false]. *) @@ -133,12 +133,12 @@ val add_actionlinkkey : -> userid:Os_types.User.id -> email:string -> unit - -> unit Lwt.t + -> unit (** [add_actionlinkkey ?autoconnect ?action ?data ?validity ?expiry ~act_key ~userid ~email ()] adds the action key in the database. *) -val verify_password : email:string -> password:string -> Os_types.User.id Lwt.t +val verify_password : email:string -> password:string -> Os_types.User.id (** [verify_password ~email ~password] returns the userid if user with email [email] is registered with the password [password]. If [password] the password is wrong, @@ -149,12 +149,12 @@ val verify_password : email:string -> password:string -> Os_types.User.id Lwt.t If user is not found, it fails with exception {!No_such_user}. If password is empty, it fails with exception {!Empty_password}. *) -val user_of_userid : Os_types.User.id -> Os_types.User.t Lwt.t +val user_of_userid : Os_types.User.id -> Os_types.User.t (** [user_of_userid userid] returns the information about the user with ID [userid]. *) -val get_actionlinkkey_info : string -> Os_types.Action_link_key.info Lwt.t +val get_actionlinkkey_info : string -> Os_types.Action_link_key.info (** Retrieve the data corresponding to an action link key, each call decrements the validity of the key by [1] if it exists and [validity > 0] (it remains at [0] if it's already [0]). It is up to @@ -162,34 +162,34 @@ val get_actionlinkkey_info : string -> Os_types.Action_link_key.info Lwt.t Raises {!Os_db.No_such_resource} if the action link key is not found. *) -val userid_of_email : string -> Os_types.User.id Lwt.t +val userid_of_email : string -> Os_types.User.id (** [userid_of_email email] returns the userid of the user with email [email]. It raises the exception {!Os_db.No_such_resource} if the email [email] is not used. *) -val emails_of_userid : Os_types.User.id -> string list Lwt.t +val emails_of_userid : Os_types.User.id -> string list (** [emails_of_userid userid] returns the emails list of user with ID [userid]. *) -val email_of_userid : Os_types.User.id -> string option Lwt.t +val email_of_userid : Os_types.User.id -> string option (** [email_of_userid userid] returns the main email of user with ID [userid]. *) -val emails_of_user : Os_types.User.t -> string list Lwt.t +val emails_of_user : Os_types.User.t -> string list (** [emails_of_user user] returns the emails list of user [user]. *) -val email_of_user : Os_types.User.t -> string option Lwt.t +val email_of_user : Os_types.User.t -> string option (** [email_of_user user] returns the main email of user [user]. *) -val get_language : Os_types.User.id -> string option Lwt.t +val get_language : Os_types.User.id -> string option (** [get_language userid] returns the language of the user with ID [userid]. The language is retrieved from the database. *) -val get_users : ?pattern:string -> unit -> Os_types.User.t list Lwt.t +val get_users : ?pattern:string -> unit -> Os_types.User.t list (** [get_users ?pattern ()] gets users who match the [pattern] (useful for completion). *) @@ -202,7 +202,7 @@ val create : -> firstname:string -> lastname:string -> unit - -> Os_types.User.t Lwt.t + -> Os_types.User.t (** [create ?password ?avatar ?language ~firstname ~lastname email] creates a new user with the given information. An email, the first name and the last name are mandatory. *) @@ -214,52 +214,52 @@ val update : -> firstname:string -> lastname:string -> Os_types.User.id - -> unit Lwt.t + -> unit (** [update ?password ?avatar ?language ~firstname ~lastname userid] update the given information of the user with ID [userid]. Only given information are updated. *) -val update' : ?password:string -> Os_types.User.t -> unit Lwt.t +val update' : ?password:string -> Os_types.User.t -> unit (** Another version of [update] using a type {!Os_types.User.t} instead of label. *) -val update_password : userid:Os_types.User.id -> password:string -> unit Lwt.t +val update_password : userid:Os_types.User.id -> password:string -> unit (** [update_password ~userid ~password] updates the password only. [password] must not be hashed: it is done by the function [f_crypt] of the tuple {!Os_db.pwd_crypt_ref}. *) -val update_avatar : userid:Os_types.User.id -> avatar:string -> unit Lwt.t +val update_avatar : userid:Os_types.User.id -> avatar:string -> unit (** [update_avatar ~userid ~avatar] updates the avatar of the user with ID [userid]. *) -val update_language : userid:Os_types.User.id -> language:string -> unit Lwt.t +val update_language : userid:Os_types.User.id -> language:string -> unit (** [update_language ~userid ~language] updates the language of the user with ID [userid]. *) -val is_registered : string -> bool Lwt.t +val is_registered : string -> bool (** [is_registered email] returns [true] if a user exists with email [email]. Else, it returns [false]. *) -val is_preregistered : string -> bool Lwt.t +val is_preregistered : string -> bool (** [is_preregistered email] returns [true] if a user exists with email [email]. Else, it returns [false]. *) -val add_preregister : string -> unit Lwt.t +val add_preregister : string -> unit (** [add_preregister email] adds an email into the preregister collections. *) -val remove_preregister : string -> unit Lwt.t +val remove_preregister : string -> unit (** [remove_preregister email] removes an email from the preregister collections. *) -val all : ?limit:int64 -> unit -> string list Lwt.t +val all : ?limit:int64 -> unit -> string list (** Get [limit] (default: 10) emails from the preregister collections. *) val set_pwd_crypt_fun : @@ -274,26 +274,23 @@ val set_pwd_crypt_fun : by user, and as third parameter the hash found in database. *) -val remove_email_from_user : - userid:Os_types.User.id - -> email:string - -> unit Lwt.t +val remove_email_from_user : userid:Os_types.User.id -> email:string -> unit (** [remove_email_from_user ~userid ~email] removes the email [email] from the user with the id [userid]. If the email is registered as the main email for the user it fails with the exception {!Os_db.Main_email_removal_attempt}. *) -val is_email_validated : userid:Os_types.User.id -> email:string -> bool Lwt.t +val is_email_validated : userid:Os_types.User.id -> email:string -> bool (** [is_email_validated ~userid ~email] returns whether for a user designated by its id the given email has been validated. *) -val is_main_email : userid:Os_types.User.id -> email:string -> bool Lwt.t +val is_main_email : userid:Os_types.User.id -> email:string -> bool (** [is_main_email ~userid ~email] returns whether an email is the main email registered for a given user designated by its id. *) -val update_main_email : userid:Os_types.User.id -> email:string -> unit Lwt.t +val update_main_email : userid:Os_types.User.id -> email:string -> unit (** [update_mail_email ~userid ~email] sets the main email for a user with the ID [userid] as the email [email]. *) diff --git a/src/os_user_proxy.eliom b/src/os_user_proxy.eliom index 2ca0caed..34ed1c79 100644 --- a/src/os_user_proxy.eliom +++ b/src/os_user_proxy.eliom @@ -34,7 +34,7 @@ let%server cache : (Os_types.User.id, Os_types.User.t) Eliom_cscache.t = let%server get_data_from_db _myid_o userid = Os_user.user_of_userid userid -let%rpc get_data myid_o (userid : Os_types.User.id) : Os_types.User.t Lwt.t = +let%rpc get_data myid_o (userid : Os_types.User.id) : Os_types.User.t = get_data_from_db myid_o userid let%server get_data_from_db_for_client myid_o userid = diff --git a/src/os_user_proxy.eliomi b/src/os_user_proxy.eliomi index b76db3cd..f1acef6f 100644 --- a/src/os_user_proxy.eliomi +++ b/src/os_user_proxy.eliomi @@ -32,17 +32,14 @@ val cache : (Os_types.User.id, Os_types.User.t) Eliom_cscache.t (** Cache keeping userid and user information as a {!Os_types.user} type. *) -val get_data_from_db : 'a -> Os_types.User.id -> Os_types.User.t Lwt.t +val get_data_from_db : 'a -> Os_types.User.id -> Os_types.User.t (** [get_data_from_db myid_o userid] returns the user which has ID [userid]. For the moment, [myid_o] is not used but it will be use later. Data comes from the database, not the cache. *) -val get_data_from_db_for_client : - 'a - -> Os_types.User.id - -> Os_types.User.t Lwt.t +val get_data_from_db_for_client : 'a -> Os_types.User.id -> Os_types.User.t (** [get_data_from_db_for_client myid_o userid] returns the user which has ID [userid]. For the moment, [myid_o] is not used but it will be use later. @@ -51,14 +48,14 @@ val get_data_from_db_for_client : [%%shared.start] -val get_data : Os_types.User.id -> Os_types.User.t Lwt.t +val get_data : Os_types.User.id -> Os_types.User.t (** [get_data userid] returns the user which has ID [userid]. For the moment, [myid_o] is not used but it will be use later. Data comes from the database, not the cache. *) -val get_data_from_cache : Os_types.User.id -> Os_types.User.t Lwt.t +val get_data_from_cache : Os_types.User.id -> Os_types.User.t (** [get_data_from_cache userid] returns the user with ID [userid] saved in cache. *) diff --git a/src/os_user_view.eliom b/src/os_user_view.eliom index c7e96ba5..63a18d90 100644 --- a/src/os_user_view.eliom +++ b/src/os_user_view.eliom @@ -364,8 +364,7 @@ let%shared ?a ~button ~(popup_content : - ((unit -> unit Lwt.t) - -> [< Html_types.div_content] Eliom_content.Html.elt Lwt.t) + ((unit -> unit) -> [< Html_types.div_content] Eliom_content.Html.elt) Eliom_client_value.t) () = @@ -518,7 +517,7 @@ let%shared sign_up_button ~a_placeholder_email ~text_button:text_sign_up ~text_send_button () in - Lwt.return @@ div ~a:[a_class ["os-connection-box"]] [sign_in; sign_up] + div ~a:[a_class ["os-connection-box"]] [sign_in; sign_up] let%shared user_box @@ -538,6 +537,6 @@ let%shared connection_box ~a_placeholder_email ~a_placeholder_pwd ~text_keep_me_logged_in ~content_popup_forgotpwd ~text_button_forgotpwd ~text_sign_in ~text_sign_up ~text_send_button () - | Some user -> Lwt.return (connected_user_box ~user) + | Some user -> connected_user_box ~user let%shared enable_phone () = enable_phone := true diff --git a/src/os_user_view.eliomi b/src/os_user_view.eliomi index b6de330e..4c388794 100644 --- a/src/os_user_view.eliomi +++ b/src/os_user_view.eliomi @@ -315,7 +315,7 @@ val connection_box : -> ?text_sign_up:string -> ?text_send_button:string -> unit - -> [> Html_types.div] Eliom_content.Html.D.elt Lwt.t + -> [> Html_types.div] Eliom_content.Html.D.elt (** A box (in a div with the CSS class ["os-connection-box"]) with a sign in and a sign out button. [?text_sign_in] (resp. [text_sign_up]) is the text for the sign in (resp. sign up) button, default is ["Sign in"] (resp. ["Sign up"]). @@ -332,7 +332,7 @@ val user_box : -> ?text_send_button:string -> ?user:Os_types.User.t -> unit - -> [> Html_types.div] Eliom_content.Html.F.elt Lwt.t + -> [> Html_types.div] Eliom_content.Html.F.elt (** Return {!connection_box} if no user is connected (i.e. [user] is [None]). Else {!connected_user_box}. *) From 2e1bf07f9ba1c3b8d617ba12c505783232387d31 Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Fri, 19 Dec 2025 15:32:42 +0100 Subject: [PATCH 2/5] Switch to Eio: Manual changes --- Makefile | 6 +- Makefile.options | 4 +- opam | 1 - src/os_comet.eliom | 24 ++--- src/os_comet.eliomi | 2 +- src/os_connect_phone.eliom | 4 +- src/os_core_db.ml | 64 ++++-------- src/os_core_db.mli | 9 +- src/os_date.eliom | 3 +- src/os_db.ppx.ml | 173 ++++++++++++++++---------------- src/os_fcm_notif.eliom | 16 ++- src/os_group.mli | 2 +- src/os_handlers.eliom | 47 ++++----- src/os_handlers.eliomi | 2 +- src/os_lib.eliom | 14 +-- src/os_lib.eliomi | 2 +- src/os_msg.eliom | 15 ++- src/os_session.eliomi | 2 +- src/os_tips.eliom | 198 ++++++++++++++++++------------------- src/os_uploader.eliom | 82 ++++++++------- src/os_user_view.eliom | 110 +++++++++------------ 21 files changed, 354 insertions(+), 426 deletions(-) diff --git a/Makefile b/Makefile index 30f3e977..871ecb99 100644 --- a/Makefile +++ b/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 \ diff --git a/Makefile.options b/Makefile.options index 2282167e..3d0293df 100644 --- a/Makefile.options +++ b/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 diff --git a/opam b/opam index 5250bcf7..c74ea7d3 100644 --- a/opam +++ b/opam @@ -28,7 +28,6 @@ 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"} diff --git a/src/os_comet.eliom b/src/os_comet.eliom index 10651a31..21ad9559 100644 --- a/src/os_comet.eliom +++ b/src/os_comet.eliom @@ -17,10 +17,8 @@ * along with this program; if not, write to the Free Software * 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 +open%client Js_of_ocaml_eio let%shared __link = () (* to make sure os_comet is linked *) @@ -51,8 +49,7 @@ 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:_ () -> restart_process ()) (* We create a channel on scope user_indep_process_scope, to monitor the application. @@ -90,21 +87,18 @@ let%client handle_error = fmt ("Exception received on Os_comet's monitor channel: " ^^ "@\n%s") (Printexc.to_string exn)); - restart_process (); - Lwt.return_unit) + restart_process ()) 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 @@ -120,9 +114,9 @@ let%server _ = Eliom_reference.Volatile.set monitor_channel_ref (Some channel); ignore [%client - (Lwt.async (fun () -> - Lwt_stream.iter_s handle_message - (Lwt_stream.wrap_exn ~%(fst channel))) + (Eio_js.start (fun () -> + Eliom_stream.iter_s handle_message + (Eliom_stream.wrap_exn ~%(fst channel))) : unit)]); let warn c = (* User connected or disconnected. diff --git a/src/os_comet.eliomi b/src/os_comet.eliomi index 5cc5fbbe..ca382a8d 100644 --- a/src/os_comet.eliomi +++ b/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 diff --git a/src/os_connect_phone.eliom b/src/os_connect_phone.eliom index 535b138b..e963dcfb 100644 --- a/src/os_connect_phone.eliom +++ b/src/os_connect_phone.eliom @@ -1,5 +1,3 @@ -open Eio.Std - (* Ocsigen Start * http://www.ocsigen.org/ocsigen-start * @@ -64,7 +62,7 @@ let%server request_code reference number = 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 Promise.t) + try (send_sms ~number code :> (unit, sms_error) result) with _ -> Error `Send else Error `Limit with _ -> Error `Unknown diff --git a/src/os_core_db.ml b/src/os_core_db.ml index cd52df33..a46c572b 100644 --- a/src/os_core_db.ml +++ b/src/os_core_db.ml @@ -18,37 +18,8 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Resource_pooling - let section = Logs.Src.create "os:db" let ( >>= ) = fun x1 x2 -> x2 x1 - -module Lwt_thread = struct - let close_in = fun x1 -> Eio.Resource.close x1 - - let really_input - (* TODO: ciao-lwt: [x2] should be a [Cstruct.t]. *) - (* TODO: ciao-lwt: [Eio.Flow.single_read] operates on a [Flow.source] but [x1] is likely of type [Eio.Buf_read.t]. Rewrite this code to use [Buf_read] (which contains an internal buffer) or change the call to [Eio.Buf_read.of_flow] used to create the buffer. *) - (* TODO: ciao-lwt: Dropped expression (buffer offset): [x3]. This will behave as if it was [0]. *) - (* TODO: ciao-lwt: Dropped expression (buffer length): [x4]. This will behave as if it was [Cstruct.length buffer]. *) - = - fun x1 x2 x3 x4 -> Eio.Flow.read_exact x1 x2 - - let input_binary_int = Lwt_io.BE.read_int - let input_char = Lwt_io.read_char - let output_string = fun x1 x2 -> Eio.Buf_write.string x1 x2 - let output_binary_int = Lwt_io.BE.write_int - let output_char = Lwt_io.write_char - let flush = fun x1 -> Eio.Buf_write.flush x1 - let open_connection x = Lwt_io.open_connection x - - type out_channel = Eio.Buf_write.t - type in_channel = Eio.Buf_read.t -end - -module Lwt_PGOCaml = PGOCaml_generic.Make (Lwt_thread) -module PGOCaml = Lwt_PGOCaml - let host_r = ref None let port_r = ref None let user_r = ref None @@ -60,7 +31,7 @@ let dispose db = try PGOCaml.close db with _ -> () let connect () = let h = - Lwt_PGOCaml.connect ?host:!host_r ?port:!port_r ?user:!user_r + PGOCaml.connect ?host:!host_r ?port:!port_r ?user:!user_r ?password:!password_r ?database:!database_r ?unix_domain_socket_dir:!unix_domain_socket_dir_r () in @@ -77,14 +48,14 @@ let connect () = let validate db = try - let () = Lwt_PGOCaml.ping db in + let () = PGOCaml.ping db in true with _ -> false -let pool : (string, bool) Hashtbl.t Lwt_PGOCaml.t Resource_pool.t ref = - ref @@ Resource_pool.create 16 ~validate ~dispose connect +let pool : (string, bool) Hashtbl.t PGOCaml.t Eio.Pool.t ref = + ref @@ Eio.Pool.create 16 ~validate ~dispose connect -let set_pool_size n = pool := Resource_pool.create n ~validate ~dispose connect +let set_pool_size n = pool := Eio.Pool.create n ~validate ~dispose connect let init ?host @@ -114,44 +85,43 @@ let connection_wrapper = ref {f = (fun _ f -> f ())} let set_connection_wrapper f = connection_wrapper := f let use_pool f = - Resource_pool.use !pool @@ fun db -> + Eio.Pool.use !pool @@ fun db -> !connection_wrapper.f db @@ fun () -> try f db with - | Lwt_PGOCaml.Error msg as e -> + | PGOCaml.Error msg as e -> Logs.err ~src:section (fun fmt -> fmt "postgresql protocol error: %s" msg); - let () = Lwt_PGOCaml.close db in + let () = PGOCaml.close db in raise e | (Unix.Unix_error _ | End_of_file) as e -> Logs.err ~src:section (fun fmt -> fmt ("unix error" ^^ "@\n%s") (Printexc.to_string e)); - let () = Lwt_PGOCaml.close db in + let () = PGOCaml.close db in raise e - | Lwt.Canceled as e -> - Logs.err ~src:section (fun fmt -> fmt "thread canceled"); + | Eio.Cancel.Cancelled _ as e -> + Logs.err ~src:section (fun fmt -> fmt "fiber canceled"); let () = PGOCaml.close db in raise e let transaction_block db f = try - Lwt_PGOCaml.begin_work db >>= fun _ -> + PGOCaml.begin_work db >>= fun _ -> let r = f () in - let () = Lwt_PGOCaml.commit db in + let () = PGOCaml.commit db in r with - | (Lwt_PGOCaml.Error _ | Lwt.Canceled | Unix.Unix_error _ | End_of_file) as e - -> + | (PGOCaml.Error _ | Eio.Cancel.Cancelled _ | Unix.Unix_error _ | End_of_file) as e -> raise (* The connection is going to be closed by [use_pool], so no need to try to rollback *) e | e -> let () = - try Lwt_PGOCaml.rollback db - with Lwt_PGOCaml.PostgreSQL_Error _ -> + try PGOCaml.rollback db + with PGOCaml.PostgreSQL_Error _ -> (* If the rollback fails, for instance due to a timeout, it seems better to close the connection. *) Logs.err ~src:section (fun fmt -> fmt "rollback failed"); - Lwt_PGOCaml.close db + PGOCaml.close db in raise e diff --git a/src/os_core_db.mli b/src/os_core_db.mli index 2b7395cf..4d93e2e7 100644 --- a/src/os_core_db.mli +++ b/src/os_core_db.mli @@ -1,5 +1,3 @@ -open Eio.Std - (* Ocsigen-start * http://www.ocsigen.org/ocsigen-start @@ -23,11 +21,6 @@ open Eio.Std (** This module defines low level functions for database requests. *) -open Resource_pooling - -module PGOCaml : - PGOCaml_generic.PGOCAML_GENERIC with type 'a monad = 'a Promise.t - val init : ?host:string -> ?port:int @@ -52,7 +45,7 @@ val without_transaction : (PGOCaml.pa_pg_data PGOCaml.t -> 'a) -> 'a (** [without_transaction f] executes function [f] outside a database transaction. The argument of [f] is a PGOCaml database handle. *) -val connection_pool : unit -> PGOCaml.pa_pg_data PGOCaml.t Resource_pool.t +val connection_pool : unit -> PGOCaml.pa_pg_data PGOCaml.t Eio.Pool.t (** Direct access to the connection pool *) type wrapper = {f : 'a. PGOCaml.pa_pg_data PGOCaml.t -> (unit -> 'a) -> 'a} diff --git a/src/os_date.eliom b/src/os_date.eliom index 045cd205..1c3cb7ba 100644 --- a/src/os_date.eliom +++ b/src/os_date.eliom @@ -26,6 +26,7 @@ *) open%client Js_of_ocaml +open%client Js_of_ocaml_eio let%client timezone = (* Use Intl API if available. Revert to using the time zone offset @@ -82,7 +83,7 @@ let%client disable_auto_init () = auto_init := false let%client _ = (* We wait for the client process to be fully loaded: *) Eliom_client.onload (fun () -> - if !auto_init then Lwt.async (fun () -> init_time_rpc timezone)) + if !auto_init then Eio_js.start (fun () -> init_time_rpc timezone)) [%%shared open CalendarLib diff --git a/src/os_db.ppx.ml b/src/os_db.ppx.ml index e61c5233..e538c848 100644 --- a/src/os_db.ppx.ml +++ b/src/os_db.ppx.ml @@ -18,7 +18,6 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Lwt.Syntax include Os_core_db exception No_such_resource @@ -29,11 +28,9 @@ exception Empty_password exception Main_email_removal_attempt exception Account_not_activated -let ( >>= ) = Lwt.bind - (*****************************************************************************) -let one f ~success ~fail q = f q >>= function r :: _ -> success r | _ -> fail +let one f ~success ~fail q = match f q with r :: _ -> success r | _ -> fail () let pwd_crypt_ref = ref @@ -44,8 +41,8 @@ let pwd_crypt_ref = module Email = struct let available email = one without_transaction - ~success:(fun _ -> Lwt.return_false) - ~fail:Lwt.return_true + ~success:(fun _ -> false) + ~fail:(fun () -> true) (fun dbh -> [%pgsql dbh @@ -60,8 +57,8 @@ module User = struct let userid_of_email email = one without_transaction - ~success:(fun userid -> Lwt.return userid) - ~fail:(Lwt.fail No_such_resource) + ~success:(fun userid -> userid) + ~fail:(fun () -> raise No_such_resource) (fun dbh -> [%pgsql dbh @@ -70,16 +67,17 @@ module User = struct WHERE email = $email"]) let is_registered email = - Lwt.catch - (fun () -> - let* _ = userid_of_email email in - Lwt.return_true) - (function No_such_resource -> Lwt.return_false | exc -> Lwt.reraise exc) + try + ignore (userid_of_email email); + true + with + | No_such_resource -> false + | exc -> raise exc let is_email_validated userid email = one without_transaction - ~success:(fun _ -> Lwt.return_true) - ~fail:Lwt.return_false + ~success:(fun _ -> true) + ~fail:(fun () -> false) (fun dbh -> [%pgsql dbh @@ -131,8 +129,8 @@ module User = struct let is_preregistered email = one without_transaction - ~success:(fun _ -> Lwt.return_true) - ~fail:Lwt.return_false + ~success:(fun _ -> true) + ~fail:(fun () -> false) (fun dbh -> [%pgsql dbh "SELECT 1 FROM ocsigen_start.preregister WHERE email = $email"]) @@ -143,38 +141,38 @@ module User = struct let create ?password ?avatar ?language ?email ~firstname ~lastname () = if password = Some "" - then Lwt.fail_with "empty password" + then failwith "empty password" else full_transaction_block (fun dbh -> let password_o = Eliom_lib.Option.map (fun p -> fst !pwd_crypt_ref p) password in - let* userid = - Lwt.bind + let userid = + match [%pgsql dbh "INSERT INTO ocsigen_start.users\n\ (firstname, lastname, main_email, password, avatar, language)\n\ VALUES ($firstname, $lastname, $?email,\n\ $?password_o, $?avatar, $?language)\n\ RETURNING userid"] - (function - | [userid] -> Lwt.return userid - | _ -> assert false) + with + | [userid] -> userid + | _ -> assert false) in - let* () = - match email with - | Some email -> - let* () = - [%pgsql - dbh - "INSERT INTO ocsigen_start.emails (email, userid) - VALUES ($email, $userid)"] - in - remove_preregister0 dbh email - | None -> Lwt.return_unit + match email with + | Some email -> + match + [%pgsql + dbh + "INSERT INTO ocsigen_start.emails (email, userid) + VALUES ($email, $userid)"] + with + | _ -> () + remove_preregister0 dbh email + | None -> () in - Lwt.return userid) + userid) let update ?password ?avatar ?language ~firstname ~lastname userid = if password = Some "" - then Lwt.fail_with "empty password" + then failwith "empty password" else let password = match password with @@ -194,7 +192,7 @@ module User = struct let update_password ~userid ~password = if password = "" - then Lwt.fail_with "empty password" + then failwith "empty password" else let password = fst !pwd_crypt_ref password in without_transaction @@ fun dbh -> @@ -228,7 +226,7 @@ module User = struct let verify_password ~email ~password = if password = "" - then Lwt.fail Empty_password + then failwith "empty password" else one without_transaction (fun dbh -> @@ -246,15 +244,15 @@ module User = struct match password' with | Some password' when snd !pwd_crypt_ref userid password password' -> if validated - then Lwt.return userid - else Lwt.fail Account_not_activated - | Some _ -> Lwt.fail Wrong_password - | _ -> Lwt.fail Password_not_set) - ~fail:(Lwt.fail No_such_user) + then userid + else raise Account_not_activated + | Some _ -> raise Wrong_password + | _ -> raise Password_not_set) + ~fail:(raise No_such_user) let verify_password_phone ~number ~password = if password = "" - then Lwt.fail Empty_password + then failwith "empty password" else one without_transaction (fun dbh -> @@ -267,24 +265,23 @@ module User = struct ~success:(fun (userid, password') -> match password' with | Some password' when snd !pwd_crypt_ref userid password password' -> - Lwt.return userid - | Some _ -> Lwt.fail Wrong_password - | _ -> Lwt.fail Password_not_set) - ~fail:(Lwt.fail No_such_user) + userid + | Some _ -> raise Wrong_password + | _ -> raise Password_not_set) + ~fail:(fun () -> raise No_such_user) let user_of_userid userid = one without_transaction ~success: (fun (userid, firstname, lastname, avatar, has_password, language) -> - Lwt.return ( userid , firstname , lastname , avatar , has_password = Some true , language )) - ~fail:(Lwt.fail No_such_resource) + ~fail:(fun () -> raise No_such_resource) (fun dbh -> [%pgsql dbh @@ -296,7 +293,7 @@ module User = struct full_transaction_block (fun dbh -> one (fun q -> q dbh) - ~fail:(Lwt.fail No_such_resource) + ~fail:(fun () -> raise No_such_resource) (fun dbh -> [%pgsql dbh @@ -313,7 +310,7 @@ module User = struct | c -> `Custom c in let v = max 0L (Int64.pred validity) in - let* () = + let () = (* We provide a grace period of 20 seconds before expiring the key, in case the link is successively opened several times *) if v = 0L @@ -331,7 +328,6 @@ module User = struct "UPDATE ocsigen_start.activation SET validity = $v WHERE activationkey = $act_key"] in - Lwt.return Os_types.Action_link_key. {userid; email; validity; expiry; action; data; autoconnect})) @@ -348,8 +344,8 @@ module User = struct let email_of_userid userid = one without_transaction - ~success:(fun main_email -> Lwt.return main_email) - ~fail:(Lwt.fail No_such_resource) + ~success:(fun main_email -> main_email) + ~fail:(fun () -> raise No_such_resource) (fun dbh -> [%pgsql dbh @@ -357,8 +353,8 @@ module User = struct let is_main_email ~userid ~email = one without_transaction - ~success:(fun _ -> Lwt.return_true) - ~fail:Lwt.return_false + ~success:(fun _ -> true) + ~fail:(fun () -> false) (fun dbh -> [%pgsql dbh @@ -373,9 +369,9 @@ module User = struct VALUES ($email, $userid)"] let remove_email_from_user ~userid ~email = - let* b = is_main_email ~userid ~email in + let b = is_main_email ~userid ~email in if b - then Lwt.fail Main_email_removal_attempt + then raise Main_email_removal_attempt else without_transaction @@ fun dbh -> [%pgsql @@ -385,14 +381,14 @@ module User = struct let get_language userid = one without_transaction - ~success:(fun language -> Lwt.return language) - ~fail:(Lwt.fail No_such_resource) + ~success:(fun language -> language) + ~fail:(fun () -> raise No_such_resource) (fun dbh -> [%pgsql dbh "SELECT language FROM ocsigen_start.users WHERE userid = $userid"]) let get_users ?pattern () = - let* l = + let l = without_transaction (fun dbh -> match pattern with | None -> @@ -411,16 +407,15 @@ module User = struct WHERE firstname <> '' -- avoids email addresses AND CONCAT_WS(' ', firstname, lastname) ~* $pattern"]) in - Lwt.return - (List.map - (fun (userid, firstname, lastname, avatar, has_password, language) -> - ( userid - , firstname - , lastname - , avatar - , has_password = Some true - , language )) - l) + List.map + (fun (userid, firstname, lastname, avatar, has_password, language) -> + ( userid + , firstname + , lastname + , avatar + , has_password = Some true + , language )) + l end module Groups = struct @@ -439,8 +434,8 @@ module Groups = struct "SELECT groupid, name, description FROM ocsigen_start.groups WHERE name = $name"]) >>= function - | [r] -> Lwt.return r - | _ -> Lwt.fail No_such_resource + | [r] -> r + | _ -> raise No_such_resource let add_user_in_group ~groupid ~userid = without_transaction @@ fun dbh -> @@ -461,8 +456,8 @@ module Groups = struct (match dbh with | None -> without_transaction | Some dbh -> fun f -> f dbh) - ~success:(fun _ -> Lwt.return_true) - ~fail:Lwt.return_false + ~success:(fun _ -> true) + ~fail:(fun () -> false) (fun dbh -> [%pgsql dbh @@ -477,7 +472,7 @@ end module Phone = struct let add userid number = without_transaction @@ fun dbh -> - let* l = + let l = [%pgsql dbh "INSERT INTO ocsigen_start.phones (number, userid) @@ -485,23 +480,21 @@ module Phone = struct ON CONFLICT DO NOTHING RETURNING 0"] in - Lwt.return (match l with [_] -> true | _ -> false) + (match l with [_] -> true | _ -> false) let exists number = - Lwt.bind - ( without_transaction @@ fun dbh -> - [%pgsql dbh "SELECT 1 FROM ocsigen_start.phones WHERE number = $number"] - ) - (function _ :: _ -> Lwt.return_true | [] -> Lwt.return_false) + ( without_transaction @@ fun dbh -> + [%pgsql dbh "SELECT 1 FROM ocsigen_start.phones WHERE number = $number"] + ) + >>= (function _ :: _ -> true | [] -> false) let userid number = - Lwt.bind - ( without_transaction @@ fun dbh -> - [%pgsql - dbh "SELECT userid FROM ocsigen_start.phones WHERE number = $number"] - ) - (function - | userid :: _ -> Lwt.return (Some userid) | [] -> Lwt.return None) + ( without_transaction @@ fun dbh -> + [%pgsql + dbh "SELECT userid FROM ocsigen_start.phones WHERE number = $number"] + ) + >>= (function + | userid :: _ -> Some userid | [] -> None) let delete userid number = without_transaction @@ fun dbh -> diff --git a/src/os_fcm_notif.eliom b/src/os_fcm_notif.eliom index 0599e8c1..8a1a4394 100644 --- a/src/os_fcm_notif.eliom +++ b/src/os_fcm_notif.eliom @@ -346,7 +346,11 @@ module Response = struct let t_of_http_response (r, b) = try let status = Cohttp.(Code.code_of_status (Response.status r)) in - let b = Cohttp_lwt.Body.to_string b in + let b = + let buf = Buffer.create 1024 in + Eio.Flow.copy b (Eio.Flow.buffer_sink buf); + Buffer.contents buf + in Yojson.Safe.from_string b |> Yojson.Safe.to_basic |> t_of_json status with (* Could be the case if the server key is wrong or if it's not @@ -367,13 +371,17 @@ let send server_key notification ?(data = Data.empty ()) options = and headers = Cohttp.Header.of_list ["Authorization", "key=" ^ server_key; "Content-Type", "application/json"] - (* Data is optional, so we use an option type and a pattern matching *) and body = `Assoc (("notification", Notification.to_json notification) :: ("data", Data.to_json data) :: Options.to_list options) - |> Yojson.Safe.to_string |> Cohttp_lwt.Body.of_string + |> Yojson.Safe.to_string |> Cohttp_eio.Body.of_string + in + let sw = Option.get (Eio.Fiber.get Ocsigen_lib.current_switch) in + let env = Stdlib.Option.get (Eio.Fiber.get Ocsigen_lib.env) in + let client = Cohttp_eio.Client.make ~https:None env#net in + let response = + Cohttp_eio.Client.call client ~headers ~body ~sw `POST gcm_url in - let response = Cohttp_lwt_unix.Client.call ~headers ~body `POST gcm_url in Response.t_of_http_response response diff --git a/src/os_group.mli b/src/os_group.mli index 1073db9e..06e4adb9 100644 --- a/src/os_group.mli +++ b/src/os_group.mli @@ -81,7 +81,7 @@ val remove_user_in_group : [group]. *) val in_group : - ?dbh:Os_db.PGOCaml.pa_pg_data Os_db.PGOCaml.t + ?dbh:PGOCaml.pa_pg_data PGOCaml.t -> group:Os_types.Group.t -> userid:Os_types.User.id -> unit diff --git a/src/os_handlers.eliom b/src/os_handlers.eliom index 90356f4e..82e24d0d 100644 --- a/src/os_handlers.eliom +++ b/src/os_handlers.eliom @@ -377,25 +377,22 @@ let%client add_email_handler () = add_email_rpc let%shared _ = Os_comet.__link (* to make sure os_comet is linked *) let%client input_popup ?(button_label = "OK") f = - let w, u = Lwt.wait () in + let w, u = Eio.Promise.create () in let content close = let open Eliom_content.Html in let button = D.button ~a:[D.a_class ["button"]] [D.txt button_label] in let inp = - let f code = - let* () = close () in - Lwt.wakeup u (); f code - in + let f code = close (); Eio.Promise.resolve u (); f code in Os_lib.lwt_bound_input_enter ~button f in - Lwt.return (D.div [button; inp]) + D.div [button; inp] in - let* _ = Ot_popup.popup ~close_button:[Os_icons.F.close ()] content in - w + let _ = Ot_popup.popup ~close_button:[Os_icons.F.close ()] content in + Eio.Promise.await w let%client confirm_code_popup ~dest f = input_popup @@ fun code -> - let* b = f code in + let b = f code in if b then let service = @@ -405,10 +402,8 @@ let%client confirm_code_popup ~dest f = in match service with | Some service -> Eliom_client.change_page ~service () () - | None -> Lwt.fail_with "confirm_popup: settings service unknown" - else ( - Os_msg.msg ~level:`Err ~duration:2. "Wrong SMS activation code"; - Lwt.return_unit) + | None -> failwith "confirm_popup: settings service unknown" + else Os_msg.msg ~level:`Err ~duration:2. "Wrong SMS activation code" (* We only need confirm_code_*_service to implement the activation UI. Assuming normal user behavior, we will only ever call them via @@ -424,14 +419,11 @@ let%server confirm_code_extra_handler = confirm_code_handler let%server confirm_code_recovery_handler = confirm_code_handler let%client request_activation_code_wrapper number f = - Lwt.bind (Os_connect_phone.request_code number) (function - | Ok () -> f () - | Error `Ownership -> - Os_msg.msg ~level:`Err ~duration:2. "Phone taken"; - Lwt.return_unit - | Error (`Unknown | `Send | `Limit | `Invalid_number) -> - Os_msg.msg ~level:`Err ~duration:2. "SMS error"; - Lwt.return_unit) + match Os_connect_phone.request_code number with + | Ok () -> f () + | Error `Ownership -> Os_msg.msg ~level:`Err ~duration:2. "Phone taken" + | Error (`Unknown | `Send | `Limit | `Invalid_number) -> + Os_msg.msg ~level:`Err ~duration:2. "SMS error" let%client confirm_code_signup_handler () (first_name, (last_name, (password, number))) @@ -445,10 +437,9 @@ let%client confirm_code_extra_handler () number = confirm_code_popup ~dest:`Settings Os_connect_phone.confirm_code_extra let%client confirm_code_recovery_handler () number = - Lwt.bind (Os_connect_phone.request_recovery_code number) (function - | Ok () -> - confirm_code_popup ~dest:`Settings - Os_connect_phone.confirm_code_recovery - | Error (`Unknown | `Send | `Limit | _) -> - Os_msg.msg ~level:`Err ~duration:2. "SMS error"; - Lwt.return ()) + match Os_connect_phone.request_recovery_code number with + | Ok () -> + confirm_code_popup ~dest:`Settings + Os_connect_phone.confirm_code_recovery + | Error (`Unknown | `Send | `Limit | _) -> + Os_msg.msg ~level:`Err ~duration:2. "SMS error" diff --git a/src/os_handlers.eliomi b/src/os_handlers.eliomi index 51844c44..0a8cf0f7 100644 --- a/src/os_handlers.eliomi +++ b/src/os_handlers.eliomi @@ -145,7 +145,7 @@ val set_personal_data_handler : [%%client.start] -val set_password_rpc : string * string -> unit Lwt.t +val set_password_rpc : string * string -> unit (** [set_password_rpc (password, confirmation_password)] is a RPC to [set_password]. *) diff --git a/src/os_lib.eliom b/src/os_lib.eliom index 2da6cf70..30269fda 100644 --- a/src/os_lib.eliom +++ b/src/os_lib.eliom @@ -19,7 +19,7 @@ *) open%client Js_of_ocaml -open%client Js_of_ocaml_lwt +open%client Js_of_ocaml_eio let%client reload () = Eliom_client.change_page ~replace:true @@ -131,9 +131,9 @@ module Email_or_phone = struct end let%client on_enter ~f inp = - Lwt.async @@ fun () -> - Lwt_js_events.keydowns inp @@ fun ev _ -> - if ev##.keyCode = 13 then f (Js.to_string inp##.value) else Lwt.return_unit + Eio_js.start @@ fun () -> + Eio_js_events.keydowns inp (fun ev -> + if ev##.keyCode = 13 then f (Js.to_string inp##.value)) (* TODO: Build a nice Ot_form module with such functions *) let%shared @@ -164,9 +164,9 @@ let%shared option) with | Some button -> - Lwt.async @@ fun () -> - Lwt_js_events.clicks (Eliom_content.Html.To_dom.of_element button) - @@ fun _ _ -> f (Js.to_string e##.value) + Eio_js.start @@ fun () -> + Eio_js_events.clicks (Eliom_content.Html.To_dom.of_element button) + (fun _ -> f (Js.to_string e##.value)) | None -> () : unit)] diff --git a/src/os_lib.eliomi b/src/os_lib.eliomi index 9b52d174..8d46ff76 100644 --- a/src/os_lib.eliomi +++ b/src/os_lib.eliomi @@ -23,7 +23,7 @@ [%%client.start] -val reload : unit -> unit Lwt.t +val reload : unit -> unit (** [reload ()] reloads the current page. *) [%%shared.start] diff --git a/src/os_msg.eliom b/src/os_msg.eliom index 3524fab0..ba6ff32e 100644 --- a/src/os_msg.eliom +++ b/src/os_msg.eliom @@ -18,7 +18,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open%client Lwt.Syntax +open%client Js_of_ocaml_eio open%client Eliom_content.Html open%client Eliom_content.Html.F open%client Js_of_ocaml @@ -45,16 +45,15 @@ let%shared [%client (let c = if ~%level = `Msg then [] else ["os-err"] in let message_dom = To_dom.of_p (D.p ~a:[a_class c] [txt ~%message]) in - Lwt.async (fun () -> - let* () = - if ~%onload then Eliom_client.lwt_onload () else Lwt.return_unit - in + Eio_js.start (fun () -> + (if ~%onload then + (* Wait for onload event if requested *) + ignore (Eio_js_events.onload ())); let msgbox = msgbox () in Logs.info (fun fmt -> fmt "%s" ~%message); Dom.appendChild msgbox message_dom; - let* () = Js_of_ocaml_lwt.Lwt_js.sleep ~%duration in - Dom.removeChild msgbox message_dom; - Lwt.return_unit) + Eio_js.sleep ~%duration; + Dom.removeChild msgbox message_dom) : unit)] let action_link_key_created = diff --git a/src/os_session.eliomi b/src/os_session.eliomi index ad4b701c..24e5c1bc 100644 --- a/src/os_session.eliomi +++ b/src/os_session.eliomi @@ -109,7 +109,7 @@ val disconnect_all : [%%client.start] -val disconnect_all : ?user_indep:bool -> unit -> unit Lwt.t +val disconnect_all : ?user_indep:bool -> unit -> unit (** Close all sessions of current user. If [?user_indep] is [true] (default), will also affect [user_indep_session_scope]. diff --git a/src/os_tips.eliom b/src/os_tips.eliom index 6a37a057..058fe0cd 100644 --- a/src/os_tips.eliom +++ b/src/os_tips.eliom @@ -21,7 +21,7 @@ open%shared Eliom_content.Html open%shared Eliom_content.Html.F open%client Js_of_ocaml -open%client Js_of_ocaml_lwt +open%client Js_of_ocaml_eio module%shared Stringset = Set.Make (String) (* tips_seen is a group persistent reference recording which tips have @@ -64,7 +64,7 @@ let%server get_tips_seen () = Eliom_reference.Volatile.get seen_by_user tabs at a time which means that the user may see the same tip several times in that case. *) let%client tips_seen_client_ref = ref Stringset.empty -let%client get_tips_seen () = Lwt.return !tips_seen_client_ref +let%client get_tips_seen () = !tips_seen_client_ref let%server () = Os_session.on_start_connected_process (fun _ -> @@ -128,7 +128,7 @@ let%shared block ?(a = []) ?(recipient = `All) - ?(onclose = [%client (fun () -> Lwt.return_unit : unit -> unit)]) + ?(onclose = [%client (fun () -> () : unit -> unit)]) ~name ~content () @@ -144,12 +144,10 @@ let%shared let close : (unit -> unit) Eliom_client_value.t = [%client fun () -> - let* () = ~%onclose () in - let () = - match !(~%box_ref) with - | Some x -> Manip.removeSelf x - | None -> () - in + ~%onclose (); + (match !(~%box_ref) with + | Some x -> Manip.removeSelf x + | None -> ()); set_tip_seen ~%name] in let c = content close in @@ -160,7 +158,7 @@ let%shared (Os_icons.D.close ~a: [ a_class ["os-tip-close"] - ; a_onclick [%client fun _ -> Lwt.async ~%close] ] + ; a_onclick [%client fun _ -> Eio_js.start ~%close] ] () :: c) in @@ -169,19 +167,21 @@ let%shared | _ -> None let%client onload_waiter () = - let* _ = Eliom_client.lwt_onload () in - Lwt.return_unit + let t, u = Eio.Promise.create () in + Eliom_client.onload (fun () -> Eio.Promise.resolve_ok u ()); + t, u -(* This thread is used to display only one tip at a time *) +(* This promise is used to display only one tip at a time *) let%client waiter = ref (onload_waiter ()) +exception%client Page_changed + let%client rec onchangepage_handler _ = - Lwt.cancel !waiter; + Eio.Promise.resolve_error (snd !waiter) (Eio.Cancel.Cancelled Page_changed); waiter := onload_waiter (); (* onchangepage handlers are one-off, register ourselves again for next time *) - Eliom_client.onchangepage onchangepage_handler; - Lwt.return_unit + Eliom_client.onchangepage onchangepage_handler let%client () = Eliom_client.onchangepage onchangepage_handler @@ -198,92 +198,92 @@ let%client ?width ?(parent_node : _ elt option) ?(delay = 0.0) - ?(onclose = fun () -> Lwt.return_unit) + ?(onclose = fun () -> ()) ~name ~content () = - let current_waiter = !waiter in - let new_waiter, new_wakener = Lwt.task () in - waiter := new_waiter; - let* () = current_waiter in - let bec = D.div ~a:[a_class ["os-tip-bec"]] [] in - let box_ref = ref None in - let close () = - let* () = onclose () in - let () = match !box_ref with Some x -> Manip.removeSelf x | None -> () in - Lwt.wakeup new_wakener (); - set_tip_seen (name : string) - in - let* c = content close in - let c = [div ~a:[a_class ["os-tip-content"]] c] in - let box = - D.div - ~a:(a_class ["os-tip"; "os-tip-bubble"] :: a) - (Os_icons.D.close - ~a:[a_class ["os-tip-close"]; a_onclick (fun _ -> Lwt.async close)] - () - :: (match arrow with None -> c | _ -> bec :: c)) - in - box_ref := Some box; - let parent_node = - match parent_node with - | None -> Dom_html.document##.body - | Some p -> To_dom.of_element p - in - let* () = Ot_nodeready.nodeready parent_node in - let* () = Lwt_js.sleep delay in - let box = To_dom.of_element box in - Dom.appendChild parent_node box; - box##.style##.opacity := Js.string "0"; - Eliom_lib.Option.iter - (fun v -> box##.style##.top := Js.string (Printf.sprintf "%ipx" v)) - top; - Eliom_lib.Option.iter - (fun v -> box##.style##.left := Js.string (Printf.sprintf "%ipx" v)) - left; - Eliom_lib.Option.iter - (fun v -> box##.style##.right := Js.string (Printf.sprintf "%ipx" v)) - right; - Eliom_lib.Option.iter - (fun v -> box##.style##.bottom := Js.string (Printf.sprintf "%ipx" v)) - bottom; - Eliom_lib.Option.iter - (fun v -> box##.style##.width := Js.string (Printf.sprintf "%ipx" v)) - width; - Eliom_lib.Option.iter - (fun v -> box##.style##.height := Js.string (Printf.sprintf "%ipx" v)) - height; - Eliom_lib.Option.iter - (fun a -> - let bec = To_dom.of_element bec in - let bec_size = bec##.offsetWidth in - let offset = Printf.sprintf "-%dpx" (bec_size / 2) in - match a with - | `top i -> - bec##.style##.top := Js.string offset; - bec##.style##.left := Js.string (Printf.sprintf "%ipx" i); - bec##.style##.borderBottom := Js.string "none"; - bec##.style##.borderRight := Js.string "none" - | `left i -> - bec##.style##.left := Js.string offset; - bec##.style##.top := Js.string (Printf.sprintf "%ipx" i); - bec##.style##.borderTop := Js.string "none"; - bec##.style##.borderRight := Js.string "none" - | `bottom i -> - bec##.style##.bottom := Js.string offset; - bec##.style##.left := Js.string (Printf.sprintf "%ipx" i); - bec##.style##.borderTop := Js.string "none"; - bec##.style##.borderLeft := Js.string "none" - | `right i -> - bec##.style##.right := Js.string offset; - bec##.style##.top := Js.string (Printf.sprintf "%ipx" i); - bec##.style##.borderBottom := Js.string "none"; - bec##.style##.borderLeft := Js.string "none") - arrow; - let* () = Lwt_js_events.request_animation_frame () in - box##.style##.opacity := Js.string "1"; - Lwt.return_unit + Eio_js.start (fun () -> + let current_waiter = fst !waiter in + waiter := Eio.Promise.create (); + let _new_promise, new_resolver = !waiter in + Eio.Promise.await_exn current_waiter; + let bec = D.div ~a:[a_class ["os-tip-bec"]] [] in + let box_ref = ref None in + let close () = + onclose (); + (match !box_ref with Some x -> Manip.removeSelf x | None -> ()); + Eio.Promise.resolve_ok new_resolver (); + set_tip_seen (name : string) + in + let c = content close in + let c = [div ~a:[a_class ["os-tip-content"]] c] in + let box = + D.div + ~a:(a_class ["os-tip"; "os-tip-bubble"] :: a) + (Os_icons.D.close + ~a:[a_class ["os-tip-close"]; a_onclick (fun _ -> Eio_js.start close)] + () + :: (match arrow with None -> c | _ -> bec :: c)) + in + box_ref := Some box; + let parent_node = + match parent_node with + | None -> Dom_html.document##.body + | Some p -> To_dom.of_element p + in + Ot_nodeready.nodeready parent_node; + Eio_js.sleep delay; + let box = To_dom.of_element box in + Dom.appendChild parent_node box; + box##.style##.opacity := Js.string "0"; + Eliom_lib.Option.iter + (fun v -> box##.style##.top := Js.string (Printf.sprintf "%ipx" v)) + top; + Eliom_lib.Option.iter + (fun v -> box##.style##.left := Js.string (Printf.sprintf "%ipx" v)) + left; + Eliom_lib.Option.iter + (fun v -> box##.style##.right := Js.string (Printf.sprintf "%ipx" v)) + right; + Eliom_lib.Option.iter + (fun v -> box##.style##.bottom := Js.string (Printf.sprintf "%ipx" v)) + bottom; + Eliom_lib.Option.iter + (fun v -> box##.style##.width := Js.string (Printf.sprintf "%ipx" v)) + width; + Eliom_lib.Option.iter + (fun v -> box##.style##.height := Js.string (Printf.sprintf "%ipx" v)) + height; + Eliom_lib.Option.iter + (fun a -> + let bec = To_dom.of_element bec in + let bec_size = bec##.offsetWidth in + let offset = Printf.sprintf "-%dpx" (bec_size / 2) in + match a with + | `top i -> + bec##.style##.top := Js.string offset; + bec##.style##.left := Js.string (Printf.sprintf "%ipx" i); + bec##.style##.borderBottom := Js.string "none"; + bec##.style##.borderRight := Js.string "none" + | `left i -> + bec##.style##.left := Js.string offset; + bec##.style##.top := Js.string (Printf.sprintf "%ipx" i); + bec##.style##.borderTop := Js.string "none"; + bec##.style##.borderRight := Js.string "none" + | `bottom i -> + bec##.style##.bottom := Js.string offset; + bec##.style##.left := Js.string (Printf.sprintf "%ipx" i); + bec##.style##.borderTop := Js.string "none"; + bec##.style##.borderLeft := Js.string "none" + | `right i -> + bec##.style##.right := Js.string offset; + bec##.style##.top := Js.string (Printf.sprintf "%ipx" i); + bec##.style##.borderBottom := Js.string "none"; + bec##.style##.borderLeft := Js.string "none") + arrow; + ignore (Eio_js_events.request_animation_frame ()); + box##.style##.opacity := Js.string "1") (* Function to be called on server to display a tip *) let%shared @@ -323,7 +323,7 @@ let%shared else let _ = [%client - (Lwt.async (fun () -> + (Eio_js.start (fun () -> display_bubble ?a:~%a ?arrow:~%arrow ?top:~%top ?left:~%left ?right:~%right ?bottom:~%bottom ?height:~%height ?width:~%width ?parent_node:~%parent_node ?delay:~%delay ?onclose:~%onclose diff --git a/src/os_uploader.eliom b/src/os_uploader.eliom index 566c2fcc..9457589f 100644 --- a/src/os_uploader.eliom +++ b/src/os_uploader.eliom @@ -23,41 +23,42 @@ exception Error_while_cropping of Unix.process_status exception Error_while_resizing of Unix.process_status] let%server resize_image ~src ?(dst = src) ~width ~height () = - let resize_unix_result = - Lwt_process.exec - ( "" - , [| "convert" - ; "+repage" - ; "-strip" - ; "-interlace" - ; "Plane" - ; "-auto-orient" - ; "-define" - ; Printf.sprintf "jpeg:size=%dx%d" (2 * width) (2 * height) - ; "-resize" - ; Printf.sprintf "%dx%d!" width height - ; "-quality" - ; "85" - ; (* In case of transparent image *) - "-background" - ; "white" - ; "-flatten" - ; src - ; "jpg:" ^ dst |] ) - in - match resize_unix_result with - | Unix.WEXITED status_code when status_code = 0 -> () - | unix_process_status -> raise (Error_while_resizing unix_process_status) + let env = Stdlib.Option.get (Eio.Fiber.get Ocsigen_lib.env) in + try + Eio.Process.run env#process_mgr + [ "convert" + ; "+repage" + ; "-strip" + ; "-interlace" + ; "Plane" + ; "-auto-orient" + ; "-define" + ; Printf.sprintf "jpeg:size=%dx%d" (2 * width) (2 * height) + ; "-resize" + ; Printf.sprintf "%dx%d!" width height + ; "-quality" + ; "85" + ; (* In case of transparent image *) + "-background" + ; "white" + ; "-flatten" + ; src + ; "jpg:" ^ dst ] + with _ -> raise (Error_while_resizing (Unix.WEXITED 1)) let%server get_image_width file = + let env = Stdlib.Option.get (Eio.Fiber.get Ocsigen_lib.env) in let width = - Lwt_process.pread ("", [|"convert"; file; "-print"; "%w"; "/dev/null"|]) + Eio.Process.parse_out env#process_mgr Eio.Buf_read.line + ["convert"; file; "-print"; "%w"; "/dev/null"] in int_of_string width let%server get_image_height file = + let env = Stdlib.Option.get (Eio.Fiber.get Ocsigen_lib.env) in let height = - Lwt_process.pread ("", [|"convert"; file; "-print"; "%h"; "/dev/null"|]) + Eio.Process.parse_out env#process_mgr Eio.Buf_read.line + ["convert"; file; "-print"; "%h"; "/dev/null"] in int_of_string height @@ -77,20 +78,17 @@ let%server crop_image ~src ?(dst = src) ?ratio ~top ~right ~bottom ~left () = | None -> height_src - top_px - pixel_of_percent bottom height_src | Some ratio -> truncate (float_of_int width_cropped /. ratio) in - let crop_unix_result = - Lwt_process.exec - ( "" - , [| "convert" - ; "-crop" - ; Printf.sprintf "%dx%d+%d+%d" width_cropped height_cropped left_px - top_px - ; src - ; dst |] ) - in - match crop_unix_result with - | Unix.WEXITED status_code when status_code = 0 -> - resize_image ~src:dst ~dst ~width:width_cropped ~height:height_cropped () - | unix_process_status -> raise (Error_while_cropping unix_process_status) + let env = Stdlib.Option.get (Eio.Fiber.get Ocsigen_lib.env) in + (try + Eio.Process.run env#process_mgr + [ "convert" + ; "-crop" + ; Printf.sprintf "%dx%d+%d+%d" width_cropped height_cropped left_px + top_px + ; src + ; dst ] + with _ -> raise (Error_while_cropping (Unix.WEXITED 1))); + resize_image ~src:dst ~dst ~width:width_cropped ~height:height_cropped () let%server record_image directory ?ratio ?cropping file = let make_file_saver cp () = @@ -108,7 +106,7 @@ let%server record_image directory ?ratio ?cropping file = match cropping with | Some (top, right, bottom, left) -> fun src dst -> crop_image ~src ~dst ?ratio ~top ~right ~bottom ~left () - | None -> Lwt_unix.link + | None -> fun src dst -> Unix.link src dst in let file_saver = make_file_saver cp () in file_saver file diff --git a/src/os_user_view.eliom b/src/os_user_view.eliom index 63a18d90..0b94b130 100644 --- a/src/os_user_view.eliom +++ b/src/os_user_view.eliom @@ -18,19 +18,18 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open%client Lwt.Syntax open%shared Eliom_content.Html open%shared Eliom_content.Html.F open%client Js_of_ocaml -open%client Js_of_ocaml_lwt +open%client Js_of_ocaml_eio let%shared enable_phone = ref false let%client check_password_confirmation ~password ~confirmation = let password_dom = To_dom.of_input password in let confirmation_dom = To_dom.of_input confirmation in - Lwt_js_events.async (fun () -> - Lwt_js_events.inputs confirmation_dom (fun _ _ -> + Eio_js_events.async (fun () -> + Eio_js_events.inputs confirmation_dom (fun _ -> ignore (if Js.to_string password_dom##.value @@ -38,8 +37,7 @@ let%client check_password_confirmation ~password ~confirmation = then (Js.Unsafe.coerce confirmation_dom)##(setCustomValidity "Passwords do not match") - else (Js.Unsafe.coerce confirmation_dom)##(setCustomValidity "")); - Lwt.return_unit)) + else (Js.Unsafe.coerce confirmation_dom)##(setCustomValidity "")))) let%shared generic_email_form @@ -67,30 +65,21 @@ let%shared let%client form_override_phone phone_input form = let phone_input = To_dom.of_input phone_input and form = To_dom.of_form form in - Lwt.async @@ fun () -> - Lwt_js_events.submits form @@ fun ev _ -> + Eio_js.start @@ fun () -> + Eio_js_events.submits form @@ fun ev -> let number = Js.to_string phone_input##.value in if number <> "" - then - Lwt.bind - (let password = (Js.Unsafe.coerce form)##.password##.value |> Js.to_string - and keepmeloggedin = - (Js.Unsafe.coerce form)##.keepmeloggedin##.checked |> Js.to_bool - in - Dom.preventDefault ev; - Os_connect_phone.connect ~keepmeloggedin ~password number) - (function - | `Login_ok -> Os_lib.reload () - | `Wrong_password -> - Os_msg.msg ~level:`Err "Wrong password"; - Lwt.return_unit - | `No_such_user -> - Os_msg.msg ~level:`Err "No such user"; - Lwt.return_unit - | `Password_not_set -> - Os_msg.msg ~level:`Err "User password not set"; - Lwt.return_unit) - else Lwt.return_unit + then ( + let password = (Js.Unsafe.coerce form)##.password##.value |> Js.to_string + and keepmeloggedin = + (Js.Unsafe.coerce form)##.keepmeloggedin##.checked |> Js.to_bool + in + Dom.preventDefault ev; + match Os_connect_phone.connect ~keepmeloggedin ~password number with + | `Login_ok -> Os_lib.reload () + | `Wrong_password -> Os_msg.msg ~level:`Err "Wrong password" + | `No_such_user -> Os_msg.msg ~level:`Err "No such user" + | `Password_not_set -> Os_msg.msg ~level:`Err "User password not set") let%shared connect_form @@ -302,29 +291,26 @@ let%shared (a_onclick [%client (fun _ -> - Lwt.async (fun () -> + Eio_js.start (fun () -> ~%onclick (); let upload_service ?progress ?cropping file = Ot_picture_uploader.ocaml_service_upload ?progress ?cropping ~service:~%service ~arg:() file in - Lwt.catch - (fun () -> - ignore - @@ Ot_popup.popup - ~close_button:[Os_icons.F.close ()] - ~onclose:(fun () -> - Eliom_client.change_page - ~service:Eliom_service.reload_action () ()) - (fun close -> - Ot_picture_uploader.mk_form ~crop:~%crop - ~input:~%input ~submit:~%submit - ~after_submit:close upload_service); - Lwt.return_unit) - (fun exn -> - Os_msg.msg ~level:`Err "Error while uploading the picture"; - Logs.info (fun fmt -> fmt "→ %s" (Printexc.to_string exn)); - Lwt.return_unit)) + try + ignore + @@ Ot_popup.popup + ~close_button:[Os_icons.F.close ()] + ~onclose:(fun () -> + Eliom_client.change_page + ~service:Eliom_service.reload_action () ()) + (fun close -> + Ot_picture_uploader.mk_form ~crop:~%crop + ~input:~%input ~submit:~%submit + ~after_submit:close upload_service) + with exn -> + Os_msg.msg ~level:`Err "Error while uploading the picture"; + Logs.info (fun fmt -> fmt "→ %s" (Printexc.to_string exn))) : _)] :: a) content @@ -339,12 +325,11 @@ let%shared let l = D.Raw.a [txt text_link] in ignore [%client - (Lwt_js_events.( + (Eio_js_events.( async (fun () -> - clicks (To_dom.of_element ~%l) (fun _ _ -> + clicks (To_dom.of_element ~%l) (fun _ -> ~%close (); - Eliom_client.exit_to ~service:Os_tips.reset_tips_service () (); - Lwt.return_unit))) + Eliom_client.exit_to ~service:Os_tips.reset_tips_service () ()))) : unit)]; l @@ -352,9 +337,9 @@ let%shared disconnect_all_link ?(text_link = "Logout on all my devices") () = let l = D.Raw.a [txt text_link] in ignore [%client - (Lwt_js_events.( + (Eio_js_events.( async (fun () -> - clicks (To_dom.of_element ~%l) (fun _ _ -> + clicks (To_dom.of_element ~%l) (fun _ -> Os_session.disconnect_all ()))) : unit)]; l @@ -370,15 +355,15 @@ let%shared = ignore [%client - (Lwt.async (fun () -> - Lwt_js_events.clicks (Eliom_content.Html.To_dom.of_element ~%button) - (fun _ _ -> - let* _ = + (Eio_js.start (fun () -> + Eio_js_events.clicks (Eliom_content.Html.To_dom.of_element ~%button) + (fun _ -> + let _ = Ot_popup.popup ?a:~%a ~close_button:[Os_icons.F.close ()] ~%popup_content in - Lwt.return_unit)) + ())) : _)] let%client @@ -392,7 +377,7 @@ let%client = let popup_content _ = let h = h2 [txt content_popup] in - Lwt.return @@ div + div @@ if !enable_phone then @@ -427,8 +412,7 @@ let%shared let popup_content = [%client fun close -> - Lwt.return - @@ div + div [ h2 [txt ~%text_button] ; connect_form ~a_placeholder_email:~%a_placeholder_email ~a_placeholder_phone:~%a_placeholder_phone @@ -438,7 +422,7 @@ let%shared ; forgotpwd_button ~content_popup:~%content_popup_forgotpwd ~text_button:~%text_button_forgotpwd ~text_send_button:~%text_send_button - ~close:(fun () -> Lwt.async close) + ~close:(fun () -> Eio_js.start close) () ]] in let button_name = text_button in @@ -464,7 +448,7 @@ let%shared ; sign_up_form ~a_placeholder_email:~%a_placeholder_email ~text:~%text_send_button () ] in - Lwt.return @@ div + div @@ if !enable_phone then @@ -485,7 +469,7 @@ let%shared disconnect_link ?(text_logout = "Logout") ?(a = []) () = (a_onclick [%client fun _ -> - Lwt.async (fun () -> + Eio_js.start (fun () -> Eliom_client.change_page ~service:Os_services.disconnect_service () ())] :: a) From 09c96c364eee75071bcca7b76e4eaf756aba229c Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Tue, 20 Jan 2026 15:19:44 +0100 Subject: [PATCH 3/5] Switch to Eio: Manual changes, step 2 --- src/os_comet.eliom | 24 +++++++++++++++++------- src/os_core_db.ml | 11 ++++++++++- src/os_db.ml | 26 +++++++++++++------------- src/os_msg.eliom | 4 ++-- src/os_notif.eliom | 2 +- src/os_session.eliom | 2 ++ src/os_tips.eliom | 36 +++++++++++++++++++++++++++++------- src/os_user.eliom | 5 ++++- src/os_user_view.eliom | 2 +- 9 files changed, 79 insertions(+), 33 deletions(-) diff --git a/src/os_comet.eliom b/src/os_comet.eliom index 21ad9559..9c8a2c68 100644 --- a/src/os_comet.eliom +++ b/src/os_comet.eliom @@ -17,11 +17,12 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open%client Js_of_ocaml -open%client Js_of_ocaml_eio 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"; @@ -49,7 +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 ()) + 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. @@ -83,11 +89,12 @@ 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 ()) + (Printexc.to_string exn)) + (* TODO: re-enable restart_process () after fixing comet channel issues *) + ) let%client set_error_handler f = handle_error := f @@ -112,9 +119,12 @@ 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 - (Eio_js.start (fun () -> + (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)]); diff --git a/src/os_core_db.ml b/src/os_core_db.ml index a46c572b..3976ceb8 100644 --- a/src/os_core_db.ml +++ b/src/os_core_db.ml @@ -85,9 +85,15 @@ let connection_wrapper = ref {f = (fun _ f -> f ())} let set_connection_wrapper f = connection_wrapper := f let use_pool f = + Logs.warn ~src:section (fun fmt -> fmt "[use_pool] acquiring connection"); Eio.Pool.use !pool @@ fun db -> + Logs.warn ~src:section (fun fmt -> fmt "[use_pool] got connection"); !connection_wrapper.f db @@ fun () -> - try f db with + try + let r = f db in + Logs.warn ~src:section (fun fmt -> fmt "[use_pool] f done, releasing connection"); + r + with | PGOCaml.Error msg as e -> Logs.err ~src:section (fun fmt -> fmt "postgresql protocol error: %s" msg); let () = PGOCaml.close db in @@ -105,8 +111,11 @@ let use_pool f = let transaction_block db f = try PGOCaml.begin_work db >>= fun _ -> + Logs.warn ~src:section (fun fmt -> fmt "[transaction_block] begin_work done"); let r = f () in + Logs.warn ~src:section (fun fmt -> fmt "[transaction_block] f() done, about to commit"); let () = PGOCaml.commit db in + Logs.warn ~src:section (fun fmt -> fmt "[transaction_block] commit done"); r with | (PGOCaml.Error _ | Eio.Cancel.Cancelled _ | Unix.Unix_error _ | End_of_file) as e -> diff --git a/src/os_db.ml b/src/os_db.ml index fbdeba08..c90733dc 100644 --- a/src/os_db.ml +++ b/src/os_db.ml @@ -10,7 +10,7 @@ exception Main_email_removal_attempt exception Account_not_activated let ( >>= ) = fun x1 x2 -> x2 x1 -let one f ~success ~fail q = f q >>= function r :: _ -> success r | _ -> fail +let one f ~success ~fail q = f q >>= function r :: _ -> success r | _ -> fail () let pwd_crypt_ref = ref @@ -24,7 +24,7 @@ module Email = struct let available email = one without_transaction ~success:(fun _ -> false) - ~fail:true + ~fail:(fun () -> true) (fun dbh -> PGOCaml.bind (let dbh = dbh in @@ -115,7 +115,7 @@ module User = struct let userid_of_email email = one without_transaction ~success:(fun userid -> userid) - ~fail:(raise No_such_resource) + ~fail:(fun () -> raise No_such_resource) (fun dbh -> PGOCaml.bind (let dbh = dbh in @@ -210,7 +210,7 @@ module User = struct let is_email_validated userid email = one without_transaction ~success:(fun _ -> true) - ~fail:false + ~fail:(fun () -> false) (fun dbh -> PGOCaml.bind (let dbh = dbh in @@ -602,7 +602,7 @@ module User = struct let is_preregistered email = one without_transaction ~success:(fun _ -> true) - ~fail:false + ~fail:(fun () -> false) (fun dbh -> PGOCaml.bind (let dbh = dbh in @@ -1432,7 +1432,7 @@ module User = struct if validated then userid else raise Account_not_activated | Some _ -> raise Wrong_password | _ -> raise Password_not_set) - ~fail:(raise No_such_user) + ~fail:(fun () -> raise No_such_user) let verify_password_phone ~number ~password = if password = "" @@ -1533,7 +1533,7 @@ module User = struct userid | Some _ -> raise Wrong_password | _ -> raise Password_not_set) - ~fail:(raise No_such_user) + ~fail:(fun () -> raise No_such_user) let user_of_userid userid = one without_transaction @@ -1541,7 +1541,7 @@ module User = struct (fun (userid, firstname, lastname, avatar, has_password, language) -> userid, firstname, lastname, avatar, has_password = Some true, language) - ~fail:(raise No_such_resource) + ~fail:(fun () -> raise No_such_resource) (fun dbh -> PGOCaml.bind (let dbh = dbh in @@ -1655,7 +1655,7 @@ module User = struct full_transaction_block (fun dbh -> one (fun q -> q dbh) - ~fail:(raise No_such_resource) + ~fail:(fun () -> raise No_such_resource) (fun dbh -> PGOCaml.bind (let dbh = dbh in @@ -2096,7 +2096,7 @@ module User = struct let email_of_userid userid = one without_transaction ~success:(fun main_email -> main_email) - ~fail:(raise No_such_resource) + ~fail:(fun () -> raise No_such_resource) (fun dbh -> PGOCaml.bind (let dbh = dbh in @@ -2183,7 +2183,7 @@ module User = struct let is_main_email ~userid ~email = one without_transaction ~success:(fun _ -> true) - ~fail:false + ~fail:(fun () -> false) (fun dbh -> PGOCaml.bind (let dbh = dbh in @@ -2408,7 +2408,7 @@ module User = struct let get_language userid = one without_transaction ~success:(fun language -> language) - ~fail:(raise No_such_resource) + ~fail:(fun () -> raise No_such_resource) (fun dbh -> PGOCaml.bind (let dbh = dbh in @@ -3014,7 +3014,7 @@ module Groups = struct | None -> without_transaction | Some dbh -> fun f -> f dbh) ~success:(fun _ -> true) - ~fail:false + ~fail:(fun () -> false) (fun dbh -> PGOCaml.bind (let dbh = dbh in diff --git a/src/os_msg.eliom b/src/os_msg.eliom index ba6ff32e..c1244824 100644 --- a/src/os_msg.eliom +++ b/src/os_msg.eliom @@ -47,8 +47,8 @@ let%shared let message_dom = To_dom.of_p (D.p ~a:[a_class c] [txt ~%message]) in Eio_js.start (fun () -> (if ~%onload then - (* Wait for onload event if requested *) - ignore (Eio_js_events.onload ())); + (* Wait for Eliom's onload event (not browser's load event) *) + Eio.Promise.await (Eliom_client.onload_promise ())); let msgbox = msgbox () in Logs.info (fun fmt -> fmt "%s" ~%message); Dom.appendChild msgbox message_dom; diff --git a/src/os_notif.eliom b/src/os_notif.eliom index c0926dba..a5d49b2b 100644 --- a/src/os_notif.eliom +++ b/src/os_notif.eliom @@ -1,4 +1,4 @@ -open Eio.Std +open%server Eio.Std (* Ocsigen-start * http://www.ocsigen.org/ocsigen-start diff --git a/src/os_session.eliom b/src/os_session.eliom index f05003e4..5b4e3e29 100644 --- a/src/os_session.eliom +++ b/src/os_session.eliom @@ -314,11 +314,13 @@ let%server let new_process = (not force_unconnected) && Eliom_reference.Volatile.get new_process_eref in + Printf.printf "[Os_session] gen_wrapper: new_process=%b\n%!" new_process; let uid = if force_unconnected then None else get_session () in let () = request_action uid in let () = if new_process then ( + Printf.printf "[Os_session] gen_wrapper: calling start_process_action\n%!"; Eliom_reference.Volatile.set new_process_eref false; start_process_action uid) else () diff --git a/src/os_tips.eliom b/src/os_tips.eliom index 058fe0cd..6b9e1ec8 100644 --- a/src/os_tips.eliom +++ b/src/os_tips.eliom @@ -166,19 +166,39 @@ let%shared Some box | _ -> None +(* Create a promise that will be resolved when onload fires. + Must be called inside an Eio fiber. *) let%client onload_waiter () = let t, u = Eio.Promise.create () in - Eliom_client.onload (fun () -> Eio.Promise.resolve_ok u ()); + Eliom_client.onload (fun () -> + Eio_js.start (fun () -> Eio.Promise.resolve_ok u ())); t, u (* This promise is used to display only one tip at a time *) -let%client waiter = ref (onload_waiter ()) +(* Initialized lazily to avoid calling Eio.Promise.create at toplevel *) +(* We use a lazy value that is forced only inside an Eio fiber *) +let%client waiter = ref None +let%client get_waiter () = + match !waiter with + | Some w -> Lazy.force w + | None -> + let w = lazy (onload_waiter ()) in + waiter := Some w; + Lazy.force w exception%client Page_changed +(* Called by onchangepage - invalidates the current waiter so a new one + will be created on next get_waiter call *) let%client rec onchangepage_handler _ = - Eio.Promise.resolve_error (snd !waiter) (Eio.Cancel.Cancelled Page_changed); - waiter := onload_waiter (); + (match !waiter with + | Some w when Lazy.is_val w -> + (* Only resolve if the lazy was forced (promise was created) *) + Eio_js.start (fun () -> + Eio.Promise.resolve_error (snd (Lazy.force w)) (Eio.Cancel.Cancelled Page_changed)) + | _ -> ()); + (* Create a new lazy for the next waiter - it will be forced inside an Eio fiber *) + waiter := Some (lazy (onload_waiter ())); (* onchangepage handlers are one-off, register ourselves again for next time *) Eliom_client.onchangepage onchangepage_handler @@ -204,9 +224,11 @@ let%client () = Eio_js.start (fun () -> - let current_waiter = fst !waiter in - waiter := Eio.Promise.create (); - let _new_promise, new_resolver = !waiter in + let current_waiter = fst (get_waiter ()) in + (* Create the new waiter inside the Eio fiber, wrapped in lazy (already forced) *) + let new_w = Eio.Promise.create () in + waiter := Some (lazy new_w); + let _new_promise, new_resolver = Lazy.force (Option.get !waiter) in Eio.Promise.await_exn current_waiter; let bec = D.div ~a:[a_class ["os-tip-bec"]] [] in let box_ref = ref None in diff --git a/src/os_user.eliom b/src/os_user.eliom index 80c4cde9..bc2a54dc 100644 --- a/src/os_user.eliom +++ b/src/os_user.eliom @@ -129,7 +129,10 @@ let create ?password ?avatar ?language ?email ~firstname ~lastname () = Os_db.User.create ~firstname ~lastname ?password ?avatar ?language ?email () in - user_of_userid userid + Logs.warn (fun fmt -> fmt "[Os_user.create] Created user with id %Ld, now calling user_of_userid" userid); + let u = user_of_userid userid in + Logs.warn (fun fmt -> fmt "[Os_user.create] user_of_userid succeeded"); + u in match email with | Some email -> ( diff --git a/src/os_user_view.eliom b/src/os_user_view.eliom index 0b94b130..ab15d52d 100644 --- a/src/os_user_view.eliom +++ b/src/os_user_view.eliom @@ -355,7 +355,7 @@ let%shared = ignore [%client - (Eio_js.start (fun () -> + (Eio_js_events.async (fun () -> Eio_js_events.clicks (Eliom_content.Html.To_dom.of_element ~%button) (fun _ -> let _ = From cd5377c3ca6f97f30abd98b62662247aa2e17dae Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Mon, 26 Jan 2026 13:50:11 +0100 Subject: [PATCH 4/5] Add missing dependency to ressource-pooling --- opam | 1 + 1 file changed, 1 insertion(+) diff --git a/opam b/opam index c74ea7d3..9e3b1341 100644 --- a/opam +++ b/opam @@ -31,6 +31,7 @@ depends: [ "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"} From 451b9005151c69ef35334319ae1df862742dab73 Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Mon, 26 Jan 2026 13:20:29 +0100 Subject: [PATCH 5/5] Eio version of template --- template.distillery/Makefile.mobile | 2 +- template.distillery/PROJECT_NAME.conf.in | 4 +- template.distillery/PROJECT_NAME.eliom | 55 +++--- template.distillery/PROJECT_NAME.opam | 2 +- .../PROJECT_NAME_container.eliom | 78 ++++----- .../PROJECT_NAME_container.eliomi | 15 +- template.distillery/PROJECT_NAME_drawer.eliom | 2 +- .../PROJECT_NAME_handlers.eliom | 159 +++++++++--------- .../PROJECT_NAME_handlers.eliomi | 27 ++- template.distillery/PROJECT_NAME_icons.eliom | 6 +- .../PROJECT_NAME_language.eliom | 43 +++-- .../PROJECT_NAME_language.eliomi | 2 +- template.distillery/PROJECT_NAME_mobile.eliom | 83 +++++---- template.distillery/PROJECT_NAME_page.eliom | 4 +- template.distillery/PROJECT_NAME_page.eliomi | 34 ++-- .../PROJECT_NAME_phone_connect.eliom | 2 +- .../PROJECT_NAME_settings.eliom | 113 ++++++------- .../PROJECT_NAME_static_config.eliom.in | 6 +- template.distillery/demo.eliom | 2 +- template.distillery/demo_cache.eliom | 27 ++- template.distillery/demo_calendar.eliom | 31 ++-- template.distillery/demo_carousel1.eliom | 61 ++++--- template.distillery/demo_carousel2.eliom | 30 ++-- template.distillery/demo_carousel3.eliom | 31 ++-- template.distillery/demo_i18n.eliom | 34 ++-- template.distillery/demo_links.eliom | 90 +++++----- template.distillery/demo_notif.eliom | 78 +++++---- template.distillery/demo_pagetransition.eliom | 37 ++-- template.distillery/demo_pgocaml.eliom | 48 +++--- template.distillery/demo_pgocaml_db.ml | 2 +- template.distillery/demo_popup.eliom | 32 ++-- template.distillery/demo_pulltorefresh.eliom | 14 +- template.distillery/demo_react.eliom | 46 +++-- template.distillery/demo_ref.eliom | 37 ++-- template.distillery/demo_rpc.eliom | 41 ++--- template.distillery/demo_services.eliom | 12 +- template.distillery/demo_spinner.eliom | 37 ++-- template.distillery/demo_timepicker.eliom | 38 ++--- template.distillery/demo_tips.eliom | 36 ++-- template.distillery/demo_tongue.eliom | 14 +- template.distillery/demo_tools.eliom | 5 +- template.distillery/demo_users.eliom | 35 ++-- template.distillery/dune | 18 +- template.distillery/mobile!eliom_loader.ml | 45 +++-- template.distillery/tools!dune | 2 +- 45 files changed, 708 insertions(+), 812 deletions(-) diff --git a/template.distillery/Makefile.mobile b/template.distillery/Makefile.mobile index 780bfe54..7f8bb28e 100644 --- a/template.distillery/Makefile.mobile +++ b/template.distillery/Makefile.mobile @@ -239,7 +239,7 @@ $(CORDOVAPATH)/www/eliom.html: $(CORDOVAPATH) \ # Eliom loader is used in the index.html to retrieve update from the server. mobile/eliom_loader.byte: mobile/eliom_loader.ml ocamlfind ocamlc \ - -package js_of_ocaml,js_of_ocaml-ppx,js_of_ocaml-lwt \ + -package js_of_ocaml,js_of_ocaml-ppx,js_of_ocaml-lwt,lwt_ppx \ -linkpkg -o mobile/eliom_loader.byte \ $< diff --git a/template.distillery/PROJECT_NAME.conf.in b/template.distillery/PROJECT_NAME.conf.in index 7ceaffc4..8525e286 100644 --- a/template.distillery/PROJECT_NAME.conf.in +++ b/template.distillery/PROJECT_NAME.conf.in @@ -27,11 +27,10 @@ --> - + diff --git a/template.distillery/PROJECT_NAME.eliom b/template.distillery/PROJECT_NAME.eliom index 999b00a5..d0696aa1 100644 --- a/template.distillery/PROJECT_NAME.eliom +++ b/template.distillery/PROJECT_NAME.eliom @@ -1,5 +1,3 @@ -open%shared Lwt.Syntax - (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) @@ -32,8 +30,8 @@ let%shared () = (Os_session.Opt.connected_fun %%%MODULE_NAME%%%_handlers.action_link_handler); Eliom_registration.Action.register ~service:Os_services.add_email_service (fun () email -> - let* () = Os_handlers.add_email_handler () email in - add_email_notif (); Lwt.return_unit); + let () = Os_handlers.add_email_handler () email in + add_email_notif ()); Eliom_registration.Action.register ~service:Os_services.update_language_service %%%MODULE_NAME%%%_handlers.update_language_handler; @@ -50,24 +48,29 @@ let%server () = ~service:%%%MODULE_NAME%%%_services.upload_user_avatar_service (Os_session.connected_fun %%%MODULE_NAME%%%_handlers.upload_user_avatar_handler) -(* Print more debugging information when is in config file - (DEBUG = yes in Makefile.options). - Example of use: - let section = Logs.Src.create "%%%MODULE_NAME%%%:sectionname" - ... - Logs.info ~src:section (fun fmt -> "This is an information %i " 1); - (or Logs.debug, Logs.err etc.) +(* Print more debugging information when is in config file (DEBUG = + yes in Makefile.options). Example of use: let src = Logs.Src.create + "%%%MODULE_NAME%%%.sectionname" module Log = (val Logs.src_log src : Logs.LOG) ... + Log.info (fun m -> m "This is an information"); (or Log.debug, Log.warn, + Log.err etc.) *) +let%client () = + Js_of_ocaml.Console.console##log (Js_of_ocaml.Js.string "=== CLIENT MODULE INIT ===") + let%server _ = if Eliom_config.get_debugmode () then ( ignore [%client - ((* Eliom_config.debug_timings := true; *) - Logs.set_level (Some Logs.Debug) + (print_endline "hello"; + (* Eliom_config.debug_timings := true; *) + (* Logs.Src.set_level (Logs.Src.create "eliom.client") (Some Logs.Debug); *) + (* Logs.Src.set_level (Logs.Src.create "os") (Some Logs.Debug); *) + Logs.Src.set_level (Logs.Src.create "%%%MODULE_NAME%%%") (Some Logs.Debug) + (* Logs.set_level (Some Logs.Debug) *) : unit)]; - Logs.set_level (Some Logs.Debug)) - + (* Logs.set_level (Some Logs.Debug) *) + Logs.Src.set_level (Logs.Src.create "%%%MODULE_NAME%%%") (Some Logs.Debug)) (* The modules below are all the modules that needs to be explicitely linked-in. *) @@ -75,26 +78,26 @@ let%server _ = [%%shared.start] module Demo = Demo +module Demo_rpc = Demo_rpc +module Demo_ref = Demo_ref +module Demo_popu = Demo_popup +module Demo_spinner = Demo_spinner +module Demo_pgocaml = Demo_pgocaml +module Demo_users = Demo_users +module Demo_links = Demo_links +module Demo_i18n = Demo_i18n module Demo_cache = Demo_cache module Demo_calendar = Demo_calendar module Demo_carousel1 = Demo_carousel1 module Demo_carousel2 = Demo_carousel2 module Demo_carousel3 = Demo_carousel3 -module Demo_i18n = Demo_i18n -module Demo_links = Demo_links +module Demo_timepicker = Demo_timepicker +module Demo_tongue = Demo_tongue module Demo_notif = Demo_notif -module Demo_pagetransition = Demo_pagetransition -module Demo_pgocaml = Demo_pgocaml -module Demo_popup = Demo_popup module Demo_pulltorefresh = Demo_pulltorefresh module Demo_react = Demo_react -module Demo_ref = Demo_ref -module Demo_rpc = Demo_rpc -module Demo_spinner = Demo_spinner -module Demo_timepicker = Demo_timepicker +module Demo_pagetransition = Demo_pagetransition module Demo_tips = Demo_tips -module Demo_tongue = Demo_tongue -module Demo_users = Demo_users module %%%MODULE_NAME%%%_config = %%%MODULE_NAME%%%_config [%%client.start] diff --git a/template.distillery/PROJECT_NAME.opam b/template.distillery/PROJECT_NAME.opam index 707c0315..e27d7317 100644 --- a/template.distillery/PROJECT_NAME.opam +++ b/template.distillery/PROJECT_NAME.opam @@ -5,6 +5,6 @@ synopsis: "%%%PROJECT_NAME%%%" depends: [ "eliom" {>= "11.0.0" & < "12.0.0"} - "ocsipersist-pgsql-config" {>= "2.0" & < "3.0"} + "ocsipersist-sqlite-config" {>= "2.0" & < "3.0"} "ocsigen-start" {>= "7.0.0" & < "8.0.0"} ] diff --git a/template.distillery/PROJECT_NAME_container.eliom b/template.distillery/PROJECT_NAME_container.eliom index ac29e152..0cbf8d2b 100644 --- a/template.distillery/PROJECT_NAME_container.eliom +++ b/template.distillery/PROJECT_NAME_container.eliom @@ -1,11 +1,9 @@ -open%shared Lwt.Syntax - (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) let%shared os_header ?user () = let open Eliom_content.Html.F in - let* user_box = + let user_box = Os_user_view.user_box ~a_placeholder_email:[%i18n S.your_email] ~a_placeholder_pwd:[%i18n S.your_password] ~text_keep_me_logged_in:[%i18n S.keep_logged_in] @@ -15,15 +13,14 @@ let%shared os_header ?user () = ~text_sign_up:[%i18n S.sign_up ~capitalize:true] ~text_send_button:[%i18n S.send ~capitalize:true] ?user () in - Lwt.return - (header - ~a:[a_class ["os-page-header"]] - [ a - ~a:[a_class ["os-page-header-app-name"]] - ~service:Os_services.main_service - [txt %%%MODULE_NAME%%%_base.displayed_app_name] - () - ; user_box ]) + header + ~a:[a_class ["os-page-header"]] + [ a + ~a:[a_class ["os-page-header-app-name"]] + ~service:Os_services.main_service + [txt %%%MODULE_NAME%%%_base.displayed_app_name] + () + ; user_box ] let%shared os_footer () = let open Eliom_content.Html.F in @@ -38,14 +35,12 @@ let%shared os_footer () = ; a ~service:%%%MODULE_NAME%%%_services.ocsigen_service [txt " Ocsigen "] () ; txt [%i18n S.footer_technology] ] ] -let%rpc get_wrong_pdata () : - ((string * string) * (string * string)) option Lwt.t - = - Lwt.return @@ Eliom_reference.Volatile.get Os_msg.wrong_pdata +let%rpc get_wrong_pdata () : ((string * string) * (string * string)) option = + Eliom_reference.Volatile.get Os_msg.wrong_pdata let%shared connected_welcome_box () = let open Eliom_content.Html.F in - let* wrong_pdata = get_wrong_pdata () in + let wrong_pdata = get_wrong_pdata () in let info, ((fn, ln), (p1, p2)) = match wrong_pdata with | None -> @@ -56,37 +51,34 @@ let%shared connected_welcome_box () = , (("", ""), ("", "")) ) | Some wpd -> p [txt [%i18n S.wrong_data_fix]], wpd in - Lwt.return - @@ div - ~a:[a_class ["os-welcome-box"]] - [ div [h2 [%i18n welcome ~capitalize:true]; info] - ; Os_user_view.information_form - ~a_placeholder_password:[%i18n S.password] - ~a_placeholder_retype_password:[%i18n S.retype_password] - ~a_placeholder_firstname:[%i18n S.your_first_name] - ~a_placeholder_lastname:[%i18n S.your_last_name] - ~text_submit:[%i18n S.submit] ~firstname:fn ~lastname:ln - ~password1:p1 ~password2:p2 () ] + div + ~a:[a_class ["os-welcome-box"]] + [ div [h2 [%i18n welcome ~capitalize:true]; info] + ; Os_user_view.information_form ~a_placeholder_password:[%i18n S.password] + ~a_placeholder_retype_password:[%i18n S.retype_password] + ~a_placeholder_firstname:[%i18n S.your_first_name] + ~a_placeholder_lastname:[%i18n S.your_last_name] + ~text_submit:[%i18n S.submit] ~firstname:fn ~lastname:ln ~password1:p1 + ~password2:p2 () ] let%shared get_user_data = function - | None -> Lwt.return_none + | None -> None | Some myid -> - let* u = Os_user_proxy.get_data myid in - Lwt.return_some u + let u = Os_user_proxy.get_data myid in + Some u let%shared page ?html_a ?a ?title ?head myid_o content = - let* me = get_user_data myid_o in - let* content = + let me = get_user_data myid_o in + let content = match me with | Some me when not (Os_user.is_complete me) -> - let* cwb = connected_welcome_box () in - Lwt.return @@ (cwb :: content) - | _ -> Lwt.return @@ content + let cwb = connected_welcome_box () in + cwb :: content + | _ -> content in - let* h = os_header ?user:me () in - Lwt.return - (Os_page.content ?html_a ?a ?title ?head - [ h - ; Eliom_content.Html.F.(div ~a:[a_class ["os-body"]] content) - ; os_footer () - ; %%%MODULE_NAME%%%_drawer.make ?user:me () ]) + let h = os_header ?user:me () in + Os_page.content ?html_a ?a ?title ?head + [ h + ; Eliom_content.Html.F.(div ~a:[a_class ["os-body"]] content) + ; os_footer () + ; %%%MODULE_NAME%%%_drawer.make ?user:me () ] diff --git a/template.distillery/PROJECT_NAME_container.eliomi b/template.distillery/PROJECT_NAME_container.eliomi index 5997040c..22b5aed8 100644 --- a/template.distillery/PROJECT_NAME_container.eliomi +++ b/template.distillery/PROJECT_NAME_container.eliomi @@ -8,18 +8,15 @@ val os_header : ?user:Os_types.User.t -> unit - -> [> `Header] Eliom_content.Html.F.elt Lwt.t + -> [> `Header] Eliom_content.Html.F.elt (** [os_header ?user ()] defines the header for all pages. In this template, it's a userbox and the user name is displayed. *) val os_footer : unit -> [> `Footer] Eliom_content.Html.F.elt (** [os_footer ()] defines a footer for the page. *) -val connected_welcome_box : - unit - -> [> Html_types.div] Eliom_content.Html.F.elt Lwt.t - -val get_user_data : Os_types.User.id option -> Os_types.User.t option Lwt.t +val connected_welcome_box : unit -> [> Html_types.div] Eliom_content.Html.F.elt +val get_user_data : Os_types.User.id option -> Os_types.User.t option val page : ?html_a:Html_types.html_attrib Eliom_content.Html.attrib list @@ -29,7 +26,7 @@ val page : -> Os_types.User.id option -> [< Html_types.div_content_fun > `Div] Eliom_content.Html.F.elt Eliom_content.Html.F.list_wrap - -> Os_page.content Lwt.t + -> Os_page.content (** [page userid_o content] returns a page personalized for the user with id [myid_o] and with the content [content]. It adds a header, a footer, and a drawer menu. If the user profile is not @@ -37,6 +34,4 @@ val page : [%%shared.start] -val get_wrong_pdata : - unit - -> ((string * string) * (string * string)) option Lwt.t +val get_wrong_pdata : unit -> ((string * string) * (string * string)) option diff --git a/template.distillery/PROJECT_NAME_drawer.eliom b/template.distillery/PROJECT_NAME_drawer.eliom index 4c480f09..52a18fef 100644 --- a/template.distillery/PROJECT_NAME_drawer.eliom +++ b/template.distillery/PROJECT_NAME_drawer.eliom @@ -1,7 +1,7 @@ (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) -[%%shared open Eliom_content.Html.F] +open%shared Eliom_content.Html.F (** This module defines the drawer menu *) diff --git a/template.distillery/PROJECT_NAME_handlers.eliom b/template.distillery/PROJECT_NAME_handlers.eliom index 1b64986f..e162b54b 100644 --- a/template.distillery/PROJECT_NAME_handlers.eliom +++ b/template.distillery/PROJECT_NAME_handlers.eliom @@ -1,9 +1,7 @@ -open%shared Lwt.Syntax - (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) -[%%shared open Eliom_content.Html.F] +open%shared Eliom_content.Html.F (* Upload user avatar *) let upload_user_avatar_handler myid () ((), (cropping, photo)) = @@ -12,13 +10,16 @@ let upload_user_avatar_handler myid () ((), (cropping, photo)) = (List.hd !%%%MODULE_NAME%%%_config.avatar_dir) (List.tl !%%%MODULE_NAME%%%_config.avatar_dir) in - let* avatar = Os_uploader.record_image avatar_dir ~ratio:1. ?cropping photo in - let* user = Os_user.user_of_userid myid in + let avatar = Os_uploader.record_image avatar_dir ~ratio:1. ?cropping photo in + let user = Os_user.user_of_userid myid in let old_avatar = Os_user.avatar_of_user user in - let* () = Os_user.update_avatar ~userid:myid ~avatar in + let () = Os_user.update_avatar ~userid:myid ~avatar in match old_avatar with - | None -> Lwt.return_unit - | Some old_avatar -> Lwt_unix.unlink (Filename.concat avatar_dir old_avatar) + | None -> () + | Some old_avatar -> + let env = Stdlib.Option.get (Eio.Fiber.get Ocsigen_lib.env) in + let fs = Eio.Stdenv.fs env in + Eio.Path.unlink Eio.Path.(fs / Filename.concat avatar_dir old_avatar) (* Set personal data *) @@ -26,7 +27,7 @@ let%server set_personal_data_handler = Os_session.connected_fun Os_handlers.set_personal_data_handler let%rpc set_personal_data_rpc (data : (string * string) * (string * string)) : - unit Lwt.t + unit = set_personal_data_handler () data @@ -37,7 +38,7 @@ let%client set_personal_data_handler () = set_personal_data_rpc let%server forgot_password_handler = Os_handlers.forgot_password_handler %%%MODULE_NAME%%%_services.settings_service -let%rpc forgot_password_rpc (email : string) : unit Lwt.t = +let%rpc forgot_password_rpc (email : string) : unit = forgot_password_handler () email let%client forgot_password_handler () = forgot_password_rpc @@ -47,38 +48,37 @@ let%client forgot_password_handler () = forgot_password_rpc password. You can create your own action links and define their behavior here. *) let%shared action_link_handler myid_o akey () = - Lwt.catch - (fun () -> - (* We try first the default actions (activation link, reset + try + (* We try first the default actions (activation link, reset password) *) - Os_handlers.action_link_handler myid_o akey ()) - (function - | Os_handlers.No_such_resource | Os_handlers.Invalid_action_key _ -> - Os_msg.msg ~level:`Err ~onload:true [%i18n S.invalid_action_key]; - Eliom_registration.(appl_self_redirect Action.send) () - | e -> - let* email, phantom_user = - match e with - | Os_handlers.Account_already_activated_unconnected - { Os_types.Action_link_key.userid = _ - ; email - ; validity = _ - ; action = _ - ; data = _ - ; autoconnect = _ } -> - Lwt.return (email, false) - | Os_handlers.Custom_action_link - ( { Os_types.Action_link_key.userid = _ - ; email - ; validity = _ - ; action = _ - ; data = _ - ; autoconnect = _ } - , phantom_user ) -> - Lwt.return (email, phantom_user) - | _ -> Lwt.fail e - in - (* Define here your custom action links. If phantom_user is true, + Os_handlers.action_link_handler myid_o akey () + with + | Os_handlers.No_such_resource | Os_handlers.Invalid_action_key _ -> + Os_msg.msg ~level:`Err ~onload:true [%i18n S.invalid_action_key]; + Eliom_registration.(appl_self_redirect Action.send) () + | e -> + let email, phantom_user = + match e with + | Os_handlers.Account_already_activated_unconnected + { Os_types.Action_link_key.userid = _ + ; email + ; validity = _ + ; action = _ + ; data = _ + ; autoconnect = _ } -> + email, false + | Os_handlers.Custom_action_link + ( { Os_types.Action_link_key.userid = _ + ; email + ; validity = _ + ; action = _ + ; data = _ + ; autoconnect = _ } + , phantom_user ) -> + email, phantom_user + | _ -> raise e + in + (* Define here your custom action links. If phantom_user is true, it means the link has been created for an email that does not correspond to an existing user. By default, we just display a sign up form or phantom users, a login form for others. You @@ -87,57 +87,54 @@ let%shared action_link_handler myid_o akey () = Perhaps personalise the intended behavior for when you meet [Account_already_activated_unconnected]. *) - if myid_o = None (* Not currently connected, and no autoconnect *) - then - if phantom_user - then - let page = - [ div - ~a:[a_class ["login-signup-box"]] - [ Os_user_view.sign_up_form - ~a_placeholder_email:[%i18n S.your_email] - ~text:[%i18n S.sign_up] ~email () ] ] - in - %%%MODULE_NAME%%%_base.App.send - (%%%MODULE_NAME%%%_page.make_page (Os_page.content page)) - else - let page = - [ div - ~a:[a_class ["login-signup-box"]] - [ Os_user_view.connect_form - ~a_placeholder_email:[%i18n S.your_email] - ~a_placeholder_pwd:[%i18n S.your_password] - ~text_keep_me_logged_in:[%i18n S.keep_logged_in] - ~text_sign_in:[%i18n S.sign_in] ~email () ] ] - in - %%%MODULE_NAME%%%_base.App.send - (%%%MODULE_NAME%%%_page.make_page (Os_page.content page)) - else - (*VVV In that case we must do something more complex. Check + if myid_o = None (* Not currently connected, and no autoconnect *) + then + if phantom_user + then + let page = + [ div + ~a:[a_class ["login-signup-box"]] + [ Os_user_view.sign_up_form + ~a_placeholder_email:[%i18n S.your_email] + ~text:[%i18n S.sign_up] ~email () ] ] + in + %%%MODULE_NAME%%%_base.App.send + (%%%MODULE_NAME%%%_page.make_page (Os_page.content page)) + else + let page = + [ div + ~a:[a_class ["login-signup-box"]] + [ Os_user_view.connect_form + ~a_placeholder_email:[%i18n S.your_email] + ~a_placeholder_pwd:[%i18n S.your_password] + ~text_keep_me_logged_in:[%i18n S.keep_logged_in] + ~text_sign_in:[%i18n S.sign_in] ~email () ] ] + in + %%%MODULE_NAME%%%_base.App.send + (%%%MODULE_NAME%%%_page.make_page (Os_page.content page)) + else + (*VVV In that case we must do something more complex. Check whether myid = userid and ask the user what he wants to do. *) - let open Eliom_registration in - appl_self_redirect Redirection.send - (Redirection Eliom_service.reload_action)) + let open Eliom_registration in + appl_self_redirect Redirection.send + (Redirection Eliom_service.reload_action) (* Set password *) let%server set_password_handler = Os_session.connected_fun (fun myid () (pwd, pwd2) -> - let* () = Os_handlers.set_password_handler myid () (pwd, pwd2) in - Lwt.return (Eliom_registration.Redirection Eliom_service.reload_action)) + let () = Os_handlers.set_password_handler myid () (pwd, pwd2) in + Eliom_registration.Redirection Eliom_service.reload_action) let%client set_password_handler () (pwd, pwd2) = - let* () = Os_handlers.set_password_rpc (pwd, pwd2) in - Lwt.return (Eliom_registration.Redirection Eliom_service.reload_action) + let () = Os_handlers.set_password_rpc (pwd, pwd2) in + Eliom_registration.Redirection Eliom_service.reload_action (* Preregister *) let%server preregister_handler = Os_handlers.preregister_handler - -let%rpc preregister_rpc (email : string) : unit Lwt.t = - preregister_handler () email - +let%rpc preregister_rpc (email : string) : unit = preregister_handler () email let%client preregister_handler () = preregister_rpc let%shared main_service_handler myid_o () () = @@ -167,10 +164,10 @@ let%shared about_handler myid_o () () = ; p [%i18n about_handler_license] ] ] let%shared settings_handler myid_o () () = - let* content = + let content = match myid_o with | Some _ -> %%%MODULE_NAME%%%_settings.settings_content () - | None -> Lwt.return [p [%i18n log_in_to_see_page ~capitalize:true]] + | None -> [p [%i18n log_in_to_see_page ~capitalize:true]] in %%%MODULE_NAME%%%_container.page myid_o content diff --git a/template.distillery/PROJECT_NAME_handlers.eliomi b/template.distillery/PROJECT_NAME_handlers.eliomi index 010709e9..12ea501b 100644 --- a/template.distillery/PROJECT_NAME_handlers.eliomi +++ b/template.distillery/PROJECT_NAME_handlers.eliomi @@ -14,7 +14,7 @@ val upload_user_avatar_handler : -> unit -> unit * ((float * float * float * float) option * Ocsigen_extensions.file_info) - -> unit Lwt.t + -> unit (** Update new user avatar with cropping option. The new avatar is saved and the old one is removed. *) @@ -23,12 +23,12 @@ val upload_user_avatar_handler : val set_personal_data_handler : unit -> (string * string) * (string * string) - -> unit Lwt.t + -> unit (** Update personal data. It uses the default OS handler {!Os_handlers.set_personal_data_handler} and gets the user information with {!Os_session.connected_fun}. *) -val forgot_password_handler : unit -> string -> unit Lwt.t +val forgot_password_handler : unit -> string -> unit (** Reset forgotten password. It uses the default OS handler {!Os_handlers.forgot_password_handler} with the main service. *) @@ -36,17 +36,17 @@ val action_link_handler : Os_types.User.id option -> string -> unit - -> %%%MODULE_NAME%%%_base.App.result Lwt.t + -> %%%MODULE_NAME%%%_base.App.result val set_password_handler : unit -> string * string - -> Eliom_service.non_ocaml Eliom_registration.redirection Lwt.t + -> Eliom_service.non_ocaml Eliom_registration.redirection (** Set a new password. It uses the default OS handler {!Os_handlers.set_password_handler} and gets the user information with {!Os_session.connected_fun}. *) -val preregister_handler : unit -> string -> unit Lwt.t +val preregister_handler : unit -> string -> unit (** The following functions are the handlers for the three main pages. They are created with {!%%%MODULE_NAME%%%_container.page} which @@ -60,26 +60,19 @@ val main_service_handler : Os_types.User.id option -> unit -> unit - -> Os_page.content Lwt.t + -> Os_page.content (** The first page of the application *) -val about_handler : - Os_types.User.id option - -> unit - -> unit - -> Os_page.content Lwt.t +val about_handler : Os_types.User.id option -> unit -> unit -> Os_page.content (** About page *) val settings_handler : Os_types.User.id option -> unit -> unit - -> Os_page.content Lwt.t + -> Os_page.content (** Settings page. If the user is connected (see {!%%%MODULE_NAME%%%_container.get_user_data}), a settings container will be created. *) -val update_language_handler : - unit - -> string - -> Eliom_registration.Action.page Lwt.t +val update_language_handler : unit -> string -> Eliom_registration.Action.page diff --git a/template.distillery/PROJECT_NAME_icons.eliom b/template.distillery/PROJECT_NAME_icons.eliom index 4d390862..2ec64bd1 100644 --- a/template.distillery/PROJECT_NAME_icons.eliom +++ b/template.distillery/PROJECT_NAME_icons.eliom @@ -15,8 +15,10 @@ module Make (A : module type of Eliom_content.Html.F) = struct "i" is used because it is the de facto standard for icons. The optional parameter ~a is at the end to be able to add other CSS classes with predefined icons. *) - let icon classes - ?(a = ([] : Html_types.i_attrib Eliom_content.Html.attrib list)) () + let icon + classes + ?(a = ([] : Html_types.i_attrib Eliom_content.Html.attrib list)) + () = A.i ~a:(A.a_class ("fa" :: classes) :: a) [] diff --git a/template.distillery/PROJECT_NAME_language.eliom b/template.distillery/PROJECT_NAME_language.eliom index 1dfc11a8..e4f3ff65 100644 --- a/template.distillery/PROJECT_NAME_language.eliom +++ b/template.distillery/PROJECT_NAME_language.eliom @@ -1,5 +1,3 @@ -open%server Lwt.Syntax - (* This file was generated by Ocsigen-start. Feel free to use it, modify it, and redistribute it as you wish. *) @@ -12,8 +10,6 @@ let%server best_matched_language () = in (* Increasingly sort based on the quality *) let lang = List.sort (fun (_, q1) (_, q2) -> compare q2 q1) lang in - Lwt.return - @@ (* The first language of the list is returned. If the list is empty, the default language is returned. *) let rec aux = function @@ -32,28 +28,31 @@ let%server update_language lang = ignore [%client (%%%MODULE_NAME%%%_i18n.set_language ~%lang : unit)]; (* Update in the database if a user is connected *) match myid_o with - | None -> Lwt.return_unit + | None -> () | Some userid -> Os_user.update_language ~userid ~language let%server _ = Os_session.on_start_process (fun _ -> - let* (* Guess a default language. *) - lang = best_matched_language () in - ignore (update_language lang); - Lwt.return_unit); + let + (* Guess a default language. *) + lang + = + best_matched_language () + in + ignore (update_language lang)); Os_session.on_start_connected_process (fun userid -> - let* (* Set language according to user preferences. *) - language = - Lwt.bind (Os_user.get_language userid) (function - | Some lang -> - Lwt.return (%%%MODULE_NAME%%%_i18n.guess_language_of_string lang) - | None -> - let* best_language = best_matched_language () in - ignore - (Os_user.update_language ~userid - ~language:(%%%MODULE_NAME%%%_i18n.string_of_language best_language)); - Lwt.return best_language) + let + (* Set language according to user preferences. *) + language + = + match Os_user.get_language userid with + | Some lang -> %%%MODULE_NAME%%%_i18n.guess_language_of_string lang + | None -> + let best_language = best_matched_language () in + ignore + (Os_user.update_language ~userid + ~language:(%%%MODULE_NAME%%%_i18n.string_of_language best_language)); + best_language in %%%MODULE_NAME%%%_i18n.set_language language; - ignore [%client (%%%MODULE_NAME%%%_i18n.set_language ~%language : unit)]; - Lwt.return_unit) + ignore [%client (%%%MODULE_NAME%%%_i18n.set_language ~%language : unit)]) diff --git a/template.distillery/PROJECT_NAME_language.eliomi b/template.distillery/PROJECT_NAME_language.eliomi index f0847b42..91b6e842 100644 --- a/template.distillery/PROJECT_NAME_language.eliomi +++ b/template.distillery/PROJECT_NAME_language.eliomi @@ -8,7 +8,7 @@ i18n-update] uses this module to create the i18n file for translations (see [Makefile.options]). *) -val update_language : %%%MODULE_NAME%%%_i18n.t -> unit Lwt.t +val update_language : %%%MODULE_NAME%%%_i18n.t -> unit (** [update_language language] updates the language (client and server side) for the current user with the value [language]. It also updates the value in the database if an user is connected. *) diff --git a/template.distillery/PROJECT_NAME_mobile.eliom b/template.distillery/PROJECT_NAME_mobile.eliom index e40f1cbe..8e1adea0 100644 --- a/template.distillery/PROJECT_NAME_mobile.eliom +++ b/template.distillery/PROJECT_NAME_mobile.eliom @@ -2,9 +2,9 @@ Feel free to use it, modify it, and redistribute it as you wish. *) [%%client.start] -[%%client open Lwt.Syntax] -[%%client open Js_of_ocaml] -[%%client open Js_of_ocaml_lwt] + +open%client Js_of_ocaml +open%client Js_of_ocaml_eio (* This RPC is called when client application is initialized. This way, the server sends necessary cookies to the client (the mobile @@ -14,28 +14,34 @@ The RPC only initializes Os_date by default, but you can add your own actions to be performed server side on first client request, if necessary. *) -let%rpc init_request myid_o (tz : string) : unit Lwt.t = - ignore myid_o; Os_date.initialize tz; Lwt.return_unit - -let to_lwt f = - let wait, wakeup = Lwt.wait () in - f (Lwt.wakeup wakeup); - wait - -let ondeviceready = - to_lwt (fun cont -> - ignore - @@ Js_of_ocaml.Dom.addEventListener Js_of_ocaml.Dom_html.document - (Js_of_ocaml.Dom_html.Event.make "deviceready") - (Js_of_ocaml.Dom_html.handler (fun _ -> cont (); Js_of_ocaml.Js._true)) - Js_of_ocaml.Js._false) +let%rpc init_request myid_o (tz : string) : unit = + ignore myid_o; Os_date.initialize tz + +(* Wait for an event using Eio. Must be called inside an Eio fiber. *) +let await_event target event_name = + Eio_js_backend.await + ~setup:(fun ~resolve ~reject:_ -> + let handler = Js_of_ocaml.Dom_html.handler (fun _ -> + resolve (); + Js_of_ocaml.Js._true) + in + (* addEventListener returns an event_listener_id that can be used to remove it *) + Js_of_ocaml.Dom.addEventListener target + (Js_of_ocaml.Dom_html.Event.make event_name) + handler + Js_of_ocaml.Js._false) + ~cancel:(fun listener_id -> + Js_of_ocaml.Dom.removeEventListener listener_id) + +let ondeviceready () = + await_event Js_of_ocaml.Dom_html.document "deviceready" let app_started = ref false let initial_change_page = ref None let change_page_gen action = if !app_started - then Lwt.async action + then Eio_js.start action else if !initial_change_page = None then initial_change_page := Some action @@ -44,8 +50,8 @@ let change_page_uri uri = let handle_initial_url () = let tz = Os_date.user_tz () in - let* () = init_request tz in - let* () = ondeviceready in + let () = init_request tz in + let () = ondeviceready () in app_started := true; match !initial_change_page with | None -> @@ -54,15 +60,15 @@ let handle_initial_url () = | Some action -> action () let () = - Lwt.async @@ fun () -> - if Eliom_client.is_client_app () - then ( - (* Initialize the application server-side; there should be a + Eio_js.start (fun () -> + if Eliom_client.is_client_app () + then ( + (* Initialize the application server-side; there should be a single initial request for that. *) - Os_date.disable_auto_init (); - let* _ = Lwt_js_events.onload () in - handle_initial_url ()) - else Lwt.return_unit + Os_date.disable_auto_init (); + let _ = Js_of_ocaml_eio.Eio_js_events.onload () in + handle_initial_url ()) + else ()) (* Reactivate comet on resume and online events *) @@ -110,9 +116,11 @@ type event = Js_of_ocaml.Js.js_string Js_of_ocaml.Js.t Js_of_ocaml.Js.readonly_prop ; params : 'a. 'a Js_of_ocaml.Js.t Js_of_ocaml.Js.readonly_prop > +(* Returns the universal links API if available. Must be called inside an Eio fiber + since it waits for deviceready. *) let universal_links () = - let* () = ondeviceready in - Lwt.return @@ Js_of_ocaml.Js.Optdef.to_option + let () = ondeviceready () in + Js_of_ocaml.Js.Optdef.to_option @@ (Js_of_ocaml.Js.Unsafe.global##.universalLinks : < subscribe : Js_of_ocaml.Js.js_string Js_of_ocaml.Js.opt @@ -124,8 +132,9 @@ let universal_links () = Js_of_ocaml.Js.t Js_of_ocaml.Js.Optdef.t) -let _ = - Lwt.bind (universal_links ()) (function +let () = + Eio_js.start (fun () -> + match universal_links () with | Some universal_links -> Js_of_ocaml.Console.console##log (Js_of_ocaml.Js.string "Universal links: registering"); @@ -136,9 +145,8 @@ let _ = ev##.url; change_page_uri (Js_of_ocaml.Js.to_string ev##.url))); Js_of_ocaml.Console.console##log - (Js_of_ocaml.Js.string "Universal links: registered"); - Lwt.return_unit - | None -> Lwt.return_unit) + (Js_of_ocaml.Js.string "Universal links: registered") + | None -> ()) (* Debugging *) @@ -148,4 +156,5 @@ let _ = debugger console, you can do so by uncommenting the following lines. *) (* let () = Eliom_config.debug_timings := true *) -(* let () = Logs.set_level (Some Logs.Debug) *) +(* let () = Logs.Src.set_level (Logs.Src.create "eliom.client") (Some Logs.Debug) *) +(* let () = Logs.Src.set_level (Logs.Src.create "os") (Some Logs.Debug) *) diff --git a/template.distillery/PROJECT_NAME_page.eliom b/template.distillery/PROJECT_NAME_page.eliom index 698f9da1..b6df12d0 100644 --- a/template.distillery/PROJECT_NAME_page.eliom +++ b/template.distillery/PROJECT_NAME_page.eliom @@ -45,8 +45,8 @@ module Page_config = struct :: css_name_script @ app_js - let default_predicate _ _ = Lwt.return_true - let default_connected_predicate _ _ _ = Lwt.return_true + let default_predicate _ _ = true + let default_connected_predicate _ _ _ = true let default_error_page _ _ exn = %%%MODULE_NAME%%%_container.page None diff --git a/template.distillery/PROJECT_NAME_page.eliomi b/template.distillery/PROJECT_NAME_page.eliomi index 3ee5d3cd..35982927 100644 --- a/template.distillery/PROJECT_NAME_page.eliomi +++ b/template.distillery/PROJECT_NAME_page.eliomi @@ -16,48 +16,46 @@ module Page_config : sig val local_js : 'a list val local_css : string list list val other_head : [> Html_types.head_content] Eliom_content.Html.F.elt list - val default_predicate : 'a -> 'b -> bool Lwt.t - val default_connected_predicate : 'a -> 'b -> 'c -> bool Lwt.t - val default_error_page : 'a -> 'b -> exn -> Os_page.content Lwt.t + val default_predicate : 'a -> 'b -> bool + val default_connected_predicate : 'a -> 'b -> 'c -> bool + val default_error_page : 'a -> 'b -> exn -> Os_page.content val default_connected_error_page : Os_types.User.id option -> 'a -> 'b -> exn - -> Os_page.content Lwt.t + -> Os_page.content end val make_page : Os_page.content -> [> Html_types.html] Eliom_content.Html.elt val page : - ?predicate:('a -> 'b -> bool Lwt.t) - -> ?fallback:('a -> 'b -> exn -> Os_page.content Lwt.t) - -> ('a -> 'b -> Os_page.content Lwt.t) + ?predicate:('a -> 'b -> bool) + -> ?fallback:('a -> 'b -> exn -> Os_page.content) + -> ('a -> 'b -> Os_page.content) -> 'a -> 'b - -> Html_types.html Eliom_content.Html.elt Lwt.t + -> Html_types.html Eliom_content.Html.elt module Opt : sig val connected_page : ?allow:Os_types.Group.t list -> ?deny:Os_types.Group.t list - -> ?predicate:(Os_types.User.id option -> 'a -> 'b -> bool Lwt.t) - -> ?fallback: - (Os_types.User.id option -> 'a -> 'b -> exn -> Os_page.content Lwt.t) - -> (Os_types.User.id option -> 'a -> 'b -> Os_page.content Lwt.t) + -> ?predicate:(Os_types.User.id option -> 'a -> 'b -> bool) + -> ?fallback:(Os_types.User.id option -> 'a -> 'b -> exn -> Os_page.content) + -> (Os_types.User.id option -> 'a -> 'b -> Os_page.content) -> 'a -> 'b - -> Html_types.html Eliom_content.Html.elt Lwt.t + -> Html_types.html Eliom_content.Html.elt end val connected_page : ?allow:Os_types.Group.t list -> ?deny:Os_types.Group.t list - -> ?predicate:(Os_types.User.id option -> 'a -> 'b -> bool Lwt.t) - -> ?fallback: - (Os_types.User.id option -> 'a -> 'b -> exn -> Os_page.content Lwt.t) - -> (Os_types.User.id -> 'a -> 'b -> Os_page.content Lwt.t) + -> ?predicate:(Os_types.User.id option -> 'a -> 'b -> bool) + -> ?fallback:(Os_types.User.id option -> 'a -> 'b -> exn -> Os_page.content) + -> (Os_types.User.id -> 'a -> 'b -> Os_page.content) -> 'a -> 'b - -> Html_types.html Eliom_content.Html.elt Lwt.t + -> Html_types.html Eliom_content.Html.elt diff --git a/template.distillery/PROJECT_NAME_phone_connect.eliom b/template.distillery/PROJECT_NAME_phone_connect.eliom index 5859727e..003d67d8 100644 --- a/template.distillery/PROJECT_NAME_phone_connect.eliom +++ b/template.distillery/PROJECT_NAME_phone_connect.eliom @@ -19,7 +19,7 @@ let%server () = then Os_connect_phone.set_send_sms_handler (fun ~number message -> Printf.printf "Send SMS %s to %s\n%!" message number; - Lwt.return (Ok ())) + Ok ()) let () = if enable diff --git a/template.distillery/PROJECT_NAME_settings.eliom b/template.distillery/PROJECT_NAME_settings.eliom index c5ed9cda..34199ee5 100644 --- a/template.distillery/PROJECT_NAME_settings.eliom +++ b/template.distillery/PROJECT_NAME_settings.eliom @@ -1,9 +1,7 @@ -open%shared Lwt.Syntax - -[%%client (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) -open Js_of_ocaml_lwt] + +open%client Js_of_ocaml_eio let%shared update_main_email_button email = let open Eliom_content.Html in @@ -14,12 +12,12 @@ let%shared update_main_email_button email = in ignore [%client - (Lwt.async (fun () -> - Lwt_js_events.clicks (Eliom_content.Html.To_dom.of_element ~%button) - (fun _ _ -> - let* () = Os_current_user.update_main_email ~%email in - Eliom_client.change_page - ~service:%%%MODULE_NAME%%%_services.settings_service () ())) + (Eio_js.start (fun () -> + Js_of_ocaml_eio.Eio_js_events.clicks + (Eliom_content.Html.To_dom.of_element ~%button) (fun _ -> + let () = Os_current_user.update_main_email ~%email in + Eliom_client.change_page + ~service:%%%MODULE_NAME%%%_services.settings_service () ())) : unit)]; button @@ -33,12 +31,12 @@ let%shared delete_email_button email = in ignore [%client - (Lwt.async (fun () -> - Lwt_js_events.clicks (Eliom_content.Html.To_dom.of_element ~%button) - (fun _ _ -> - let* () = Os_current_user.remove_email_from_user ~%email in - Eliom_client.change_page - ~service:%%%MODULE_NAME%%%_services.settings_service () ())) + (Eio_js.start (fun () -> + Js_of_ocaml_eio.Eio_js_events.clicks + (Eliom_content.Html.To_dom.of_element ~%button) (fun _ -> + let () = Os_current_user.remove_email_from_user ~%email in + Eliom_client.change_page + ~service:%%%MODULE_NAME%%%_services.settings_service () ())) : unit)]; button @@ -81,25 +79,25 @@ let%shared li_of_email main_email (email, is_validated) = let labels = labels_of_email is_main_email is_validated and buttons = buttons_of_email is_main_email is_validated email and email = span ~a:[a_class ["os-settings-email"]] [txt email] in - Lwt.return (li ((email :: labels) @ buttons)) + li ((email :: labels) @ buttons) let%shared ul_of_emails (main_email, emails) = let li_of_email = li_of_email main_email in - let* li_list = Lwt_list.map_s li_of_email emails in - Lwt.return Eliom_content.Html.D.(div ~a:[a_class ["os-emails"]] [ul li_list]) + let li_list = List.map li_of_email emails in + Eliom_content.Html.D.(div ~a:[a_class ["os-emails"]] [ul li_list]) (* List with information about emails *) -let%rpc get_emails myid () : (string option * (string * bool) list) Lwt.t = - let* main_email = Os_db.User.email_of_userid myid in - let* emails = Os_db.User.emails_of_userid myid in - let* emails = - Lwt_list.map_s +let%rpc get_emails myid () : string option * (string * bool) list = + let main_email = Os_db.User.email_of_userid myid in + let emails = Os_db.User.emails_of_userid myid in + let emails = + List.map (fun email -> - let* v = Os_current_user.is_email_validated email in - Lwt.return (email, v)) + let v = Os_current_user.is_email_validated email in + email, v) emails in - Lwt.return (main_email, emails) + main_email, emails let%shared select_language_form select_language_name = let open Eliom_content.Html in @@ -125,34 +123,33 @@ let%shared select_language_form select_language_name = D.Form.string ] let%shared settings_content () = - let* emails = get_emails () in - let* emails = ul_of_emails emails in - Lwt.return - @@ Eliom_content.Html.D. - [ div - ~a:[a_class ["os-settings"]] - [ p [%i18n change_password ~capitalize:true] - ; Os_user_view.password_form ~a_placeholder_pwd:[%i18n S.password] - ~a_placeholder_confirmation:[%i18n S.retype_password] - ~text_send_button:[%i18n S.send] - ~service:Os_services.set_password_service () - ; br () - ; Os_user_view.upload_pic_link - ~submit:([a_class ["button"]], [txt "Submit"]) - ~content:[%i18n change_profile_picture] - %%%MODULE_NAME%%%_services.upload_user_avatar_service - ; br () - ; Os_user_view.reset_tips_link - ~text_link:[%i18n S.see_help_again_from_beginning] () - ; br () - ; Os_user_view.disconnect_all_link - ~text_link:[%i18n S.disconnect_all] () - ; br () - ; p [%i18n link_new_email] - ; Os_user_view.generic_email_form - ~a_placeholder_email:[%i18n S.email_address] ~text:[%i18n S.send] - ~service:Os_services.add_email_service () - ; p [%i18n currently_registered_emails] - ; div ~a:[a_class ["os-emails"]] [emails] - ; Form.post_form ~service:Os_services.update_language_service - select_language_form () ] ] + let emails = get_emails () in + let emails = ul_of_emails emails in + Eliom_content.Html.D. + [ div + ~a:[a_class ["os-settings"]] + [ p [%i18n change_password ~capitalize:true] + ; Os_user_view.password_form ~a_placeholder_pwd:[%i18n S.password] + ~a_placeholder_confirmation:[%i18n S.retype_password] + ~text_send_button:[%i18n S.send] + ~service:Os_services.set_password_service () + ; br () + ; Os_user_view.upload_pic_link + ~submit:([a_class ["button"]], [txt "Submit"]) + ~content:[%i18n change_profile_picture] + %%%MODULE_NAME%%%_services.upload_user_avatar_service + ; br () + ; Os_user_view.reset_tips_link + ~text_link:[%i18n S.see_help_again_from_beginning] () + ; br () + ; Os_user_view.disconnect_all_link ~text_link:[%i18n S.disconnect_all] + () + ; br () + ; p [%i18n link_new_email] + ; Os_user_view.generic_email_form + ~a_placeholder_email:[%i18n S.email_address] ~text:[%i18n S.send] + ~service:Os_services.add_email_service () + ; p [%i18n currently_registered_emails] + ; div ~a:[a_class ["os-emails"]] [emails] + ; Form.post_form ~service:Os_services.update_language_service + select_language_form () ] ] diff --git a/template.distillery/PROJECT_NAME_static_config.eliom.in b/template.distillery/PROJECT_NAME_static_config.eliom.in index 206cc258..bb58b025 100644 --- a/template.distillery/PROJECT_NAME_static_config.eliom.in +++ b/template.distillery/PROJECT_NAME_static_config.eliom.in @@ -13,10 +13,8 @@ let%server set_static_config () = Ocsigen_config.set_usedefaulthostname true; Ocsigen_config.set_command_pipe "local/var/run/%%%PROJECT_NAME%%%-cmd"; Ocsigen_config.set_default_charset (Some "utf-8"); - Ocsipersist_settings.set_host "%%PGHOST%%"; - Ocsipersist_settings.set_port %%PGPORT%%; - Ocsipersist_settings.set_database "ocsipersist_%%%PROJECT_NAME%%%"; - Ocsipersist.init (); + Ocsipersist_settings.set_db_file "local/var/data/ocsipersist-sqlite"; + Ocsipersist.init ~env:(Option.get (Eio.Fiber.get Ocsigen_lib.env)); %%%MODULE_NAME%%%_config.os_db_database := Some "%%PGDATABASE%%"; %%%MODULE_NAME%%%_config.os_db_host := Some "%%PGHOST%%"; %%%MODULE_NAME%%%_config.os_db_user := diff --git a/template.distillery/demo.eliom b/template.distillery/demo.eliom index 771dd124..6ca63ec3 100644 --- a/template.distillery/demo.eliom +++ b/template.distillery/demo.eliom @@ -1,7 +1,7 @@ (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) -[%%shared open Eliom_content.Html.D] +open%shared Eliom_content.Html.D (* drawer / demo welcome page ***********************************************) diff --git a/template.distillery/demo_cache.eliom b/template.distillery/demo_cache.eliom index 85789677..751d251c 100644 --- a/template.distillery/demo_cache.eliom +++ b/template.distillery/demo_cache.eliom @@ -1,22 +1,18 @@ -open%shared Lwt.Syntax - -[%%shared (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) (* Eliom_cscache demo *) -open Eliom_content.Html.F] +open%shared Eliom_content.Html.F (* Page for this demo *) let%shared page () = - Lwt.return - [ h1 [%i18n Demo.cache_1] - ; p - [%i18n - Demo.cache_2 - ~eliom_cscache:[code [txt "Eliom_cscache"]] - ~os_user_proxy:[code [txt "Os_user_proxy"]]] - ; p [%i18n Demo.cache_3 ~eliom_cscache:[code [txt "Eliom_cscache"]]] - ; p [%i18n Demo.cache_4 ~eliom_cscache:[code [txt "Eliom_cscache"]]] ] + [ h1 [%i18n Demo.cache_1] + ; p + [%i18n + Demo.cache_2 + ~eliom_cscache:[code [txt "Eliom_cscache"]] + ~os_user_proxy:[code [txt "Os_user_proxy"]]] + ; p [%i18n Demo.cache_3 ~eliom_cscache:[code [txt "Eliom_cscache"]]] + ; p [%i18n Demo.cache_4 ~eliom_cscache:[code [txt "Eliom_cscache"]]] ] (* Service registration is done on both sides (shared section), so that pages can be generated from the server @@ -25,5 +21,6 @@ let%shared page () = let%shared () = %%%MODULE_NAME%%%_base.App.register ~service:Demo_services.demo_cache ( %%%MODULE_NAME%%%_page.Opt.connected_page @@ fun myid_o () () -> - let* p = page () in - %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-cache"]] myid_o p ) + let p = page () in + %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-cache"]] myid_o p + ) diff --git a/template.distillery/demo_calendar.eliom b/template.distillery/demo_calendar.eliom index d62a4c73..ff832712 100644 --- a/template.distillery/demo_calendar.eliom +++ b/template.distillery/demo_calendar.eliom @@ -1,10 +1,7 @@ -open%shared Lwt.Syntax - -[%%shared (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) (* Calendar demo *) -open Eliom_content.Html.D] +open%shared Eliom_content.Html.D (* A reactive value containing the currently selected date *) (* NOTE: in this example, we define a shared signal on the server side. Its @@ -21,10 +18,7 @@ open Eliom_content.Html.D] signals can't be inferred (it remains unknown at the end of the typing pass) since it's never used throughout the program. *) let%server s, f = Eliom_shared.React.S.create None - -let%client action y m d = - ~%f (Some (y, m, d)); - Lwt.return_unit +let%client action y m d = ~%f (Some (y, m, d)) let%shared string_of_date = function | Some (y, m, d) -> @@ -36,20 +30,18 @@ let%shared string_of_date = function let%server date_as_string () : string Eliom_shared.React.S.t = Eliom_shared.React.S.map [%shared string_of_date] s -let%rpc date_reactive () : string Eliom_shared.React.S.t Lwt.t = - Lwt.return @@ date_as_string () +let%rpc date_reactive () : string Eliom_shared.React.S.t = date_as_string () (* Page for this demo *) let%shared page () = let calendar = Ot_calendar.make ~click_non_highlighted:true ~action:[%client action] () in - let* dr = date_reactive () in - Lwt.return - [ h1 [%i18n Demo.calendar] - ; p [%i18n Demo.this_page_show_calendar] - ; div ~a:[a_class ["os-calendar"]] [calendar] - ; p [Eliom_content.Html.R.txt dr] ] + let dr = date_reactive () in + [ h1 [%i18n Demo.calendar] + ; p [%i18n Demo.this_page_show_calendar] + ; div ~a:[a_class ["os-calendar"]] [calendar] + ; p [Eliom_content.Html.R.txt dr] ] (* Service registration is done on both sides (shared section), so that pages can be generated from the server @@ -58,6 +50,7 @@ let%shared page () = let%shared () = %%%MODULE_NAME%%%_base.App.register ~service:Demo_services.demo_calendar ( %%%MODULE_NAME%%%_page.Opt.connected_page @@ fun myid_o () () -> - let* p = page () in - %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-calendar"]] myid_o p - ) + let p = page () in + %%%MODULE_NAME%%%_container.page + ~a:[a_class ["os-page-demo-calendar"]] + myid_o p ) diff --git a/template.distillery/demo_carousel1.eliom b/template.distillery/demo_carousel1.eliom index 349ed8f0..a7847b58 100644 --- a/template.distillery/demo_carousel1.eliom +++ b/template.distillery/demo_carousel1.eliom @@ -1,34 +1,32 @@ -open%shared Lwt.Syntax - -[%%client (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) (* Carousel demo *) -open Eliom_content.Html] - -[%%shared open Eliom_content.Html.F] +open%client Eliom_content.Html +open%client Js_of_ocaml_eio +open%shared Eliom_content.Html.F (* Bind arrow keys *) -let%shared bind_keys - (change : ([`Goto of int | `Next | `Prev] -> unit) Eliom_client_value.t) - (carousel : [`Div] Eliom_content.Html.elt) +let%shared + bind_keys + (change : ([`Goto of int | `Next | `Prev] -> unit) Eliom_client_value.t) + (carousel : [`Div] Eliom_content.Html.elt) = ignore [%client - (let arrow_thread = - let* - (* Wait for the carousel to be in the page + (Eio_js.start (fun () -> + Eio.Switch.run (fun sw -> + let + (* Wait for the carousel to be in the page (in the case the page is generated client side): *) - () - = - Ot_nodeready.nodeready (To_dom.of_element ~%carousel) - in - Ot_carousel.bind_arrow_keys ~change:~%change - Js_of_ocaml.Dom_html.document##.body - in - (* Do not forget to cancel the thread when we remove the carousel + () + = + Ot_nodeready.nodeready (To_dom.of_element ~%carousel) + in + Ot_carousel.bind_arrow_keys ~change:~%change + Js_of_ocaml.Dom_html.document##.body; + (* Do not forget to cancel the thread when we remove the carousel (here, when we go to another page): *) - Eliom_client.onunload (fun () -> Lwt.cancel arrow_thread) + Eliom_client.onunload (fun () -> Eio.Switch.fail sw Exit))) : unit)] (* Page for this demo *) @@ -60,16 +58,15 @@ let%shared page () = let prev = Ot_carousel.previous ~change ~pos [] in let next = Ot_carousel.next ~change ~pos ~vis_elts ~length [] in bind_keys change carousel; - Lwt.return - [ h1 [%i18n Demo.carousel_1] - ; p [%i18n Demo.ot_carousel_first_example_1] - ; p [%i18n Demo.ot_carousel_first_example_2] - ; p [%i18n Demo.ot_carousel_first_example_3] - ; p [%i18n Demo.ot_carousel_first_example_4] - ; div - ~a:[a_class ["demo-carousel1"]] - [div ~a:[a_class ["demo-carousel1-box"]] [carousel; prev; next; bullets]] - ] + [ h1 [%i18n Demo.carousel_1] + ; p [%i18n Demo.ot_carousel_first_example_1] + ; p [%i18n Demo.ot_carousel_first_example_2] + ; p [%i18n Demo.ot_carousel_first_example_3] + ; p [%i18n Demo.ot_carousel_first_example_4] + ; div + ~a:[a_class ["demo-carousel1"]] + [div ~a:[a_class ["demo-carousel1-box"]] [carousel; prev; next; bullets]] + ] (* Service registration is done on both sides (shared section), so that pages can be generated from the server @@ -78,7 +75,7 @@ let%shared page () = let%shared () = %%%MODULE_NAME%%%_base.App.register ~service:Demo_services.demo_carousel1 ( %%%MODULE_NAME%%%_page.Opt.connected_page @@ fun myid_o () () -> - let* p = page () in + let p = page () in %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-carousel1"]] myid_o p ) diff --git a/template.distillery/demo_carousel2.eliom b/template.distillery/demo_carousel2.eliom index e50872ed..aa39b443 100644 --- a/template.distillery/demo_carousel2.eliom +++ b/template.distillery/demo_carousel2.eliom @@ -1,12 +1,9 @@ -open%shared Lwt.Syntax - -[%%shared (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) (* Page with several tabs *) -open Eliom_content.Html] - -[%%shared open Eliom_content.Html.F] +open%shared Eliom_content.Html +open%client Js_of_ocaml_eio +open%shared Eliom_content.Html.F let%shared lorem_ipsum = [ p @@ -69,18 +66,17 @@ let%shared page () = *) ignore [%client - (Lwt.async (fun () -> - Lwt.map ignore + (Eio_js.start (fun () -> + ignore (Ot_sticky.make_sticky ~ios_html_scroll_hack:true ~dir:`Top ~%tabs)) : unit)]; - Lwt.return - [ h1 [%i18n Demo.carousel_2] - ; p [%i18n Demo.ot_carousel_second_example_1] - ; p [%i18n Demo.ot_carousel_second_example_2] - ; p [%i18n Demo.ot_carousel_second_example_3] - ; div - ~a:[a_class ["demo-carousel2"]] - [div ~a:[a_class ["demo-carousel2-box"]] [tabs; carousel]] ] + [ h1 [%i18n Demo.carousel_2] + ; p [%i18n Demo.ot_carousel_second_example_1] + ; p [%i18n Demo.ot_carousel_second_example_2] + ; p [%i18n Demo.ot_carousel_second_example_3] + ; div + ~a:[a_class ["demo-carousel2"]] + [div ~a:[a_class ["demo-carousel2-box"]] [tabs; carousel]] ] (* Service registration is done on both sides (shared section), so that pages can be generated from the server @@ -89,7 +85,7 @@ let%shared page () = let%shared () = %%%MODULE_NAME%%%_base.App.register ~service:Demo_services.demo_carousel2 ( %%%MODULE_NAME%%%_page.Opt.connected_page @@ fun myid_o () () -> - let* p = page () in + let p = page () in %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-carousel2"]] myid_o p ) diff --git a/template.distillery/demo_carousel3.eliom b/template.distillery/demo_carousel3.eliom index 92221463..1482f8bf 100644 --- a/template.distillery/demo_carousel3.eliom +++ b/template.distillery/demo_carousel3.eliom @@ -1,12 +1,8 @@ -open%shared Lwt.Syntax - -[%%shared (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) (* Wheel demo *) -open Eliom_content.Html] - -[%%shared open Eliom_content.Html.F] +open%shared Eliom_content.Html +open%shared Eliom_content.Html.F (* Page for this demo *) let%shared page () = @@ -63,17 +59,16 @@ let%shared page () = ~update ~vertical:true ~inertia:1. ~position:10 ~transition_duration:3. ~face_size:25 carousel_content in - Lwt.return - [ h1 [%i18n Demo.carousel_wheel] - ; p [%i18n Demo.carousel_third_example_1] - ; carousel - ; div - [ Ot_carousel.previous ~a:[a_class ["demo-prev"]] ~change ~pos [] - ; Ot_carousel.next - ~a:[a_class ["demo-next"]] - ~change ~pos - ~vis_elts:(Eliom_shared.React.S.const 1) - ~length [] ] ] + [ h1 [%i18n Demo.carousel_wheel] + ; p [%i18n Demo.carousel_third_example_1] + ; carousel + ; div + [ Ot_carousel.previous ~a:[a_class ["demo-prev"]] ~change ~pos [] + ; Ot_carousel.next + ~a:[a_class ["demo-next"]] + ~change ~pos + ~vis_elts:(Eliom_shared.React.S.const 1) + ~length [] ] ] (* Service registration is done on both sides (shared section), so that pages can be generated from the server @@ -82,7 +77,7 @@ let%shared page () = let%shared () = %%%MODULE_NAME%%%_base.App.register ~service:Demo_services.demo_carousel3 ( %%%MODULE_NAME%%%_page.Opt.connected_page @@ fun myid_o () () -> - let* p = page () in + let p = page () in %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-carousel3"]] myid_o p ) diff --git a/template.distillery/demo_i18n.eliom b/template.distillery/demo_i18n.eliom index 92a3c0d7..544c506a 100644 --- a/template.distillery/demo_i18n.eliom +++ b/template.distillery/demo_i18n.eliom @@ -1,10 +1,7 @@ -open%shared Lwt.Syntax - -[%%shared (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) (* Ocsigen_i18n demo *) -open Eliom_content.Html.F] +open%shared Eliom_content.Html.F (* Page for this demo *) let%shared page () = @@ -17,20 +14,19 @@ let%shared page () = assets/%%%PROJECT_NAME%%%_Demo_i18n.tsv to see how to write the corresponding translations. *) - Lwt.return - [ h1 [%i18n Demo.internationalization ~capitalize:true] - ; p [%i18n Demo.internationalization_1] - ; p - [%i18n - Demo.internationalization_2 - ~f1:[code [txt "assets/%%%PROJECT_NAME%%%_i18n.tsv"]] - ~f2:[code [txt "%%%PROJECT_NAME%%%_i18n.eliom"]]] - ; p [txt [%i18n Demo.S.internationalization_3]] - ; p - [%i18n - Demo.internationalization_4 - ~f:[code [txt "assets/%%%PROJECT_NAME%%%_Demo_i18n.tsv"]] - ~demo_prefix:[code [txt "demo_"]]] ] + [ h1 [%i18n Demo.internationalization ~capitalize:true] + ; p [%i18n Demo.internationalization_1] + ; p + [%i18n + Demo.internationalization_2 + ~f1:[code [txt "assets/%%%PROJECT_NAME%%%_i18n.tsv"]] + ~f2:[code [txt "%%%PROJECT_NAME%%%_i18n.eliom"]]] + ; p [txt [%i18n Demo.S.internationalization_3]] + ; p + [%i18n + Demo.internationalization_4 + ~f:[code [txt "assets/%%%PROJECT_NAME%%%_Demo_i18n.tsv"]] + ~demo_prefix:[code [txt "demo_"]]] ] (* Service registration is done on both sides (shared section), so that pages can be generated from the server @@ -39,5 +35,5 @@ let%shared page () = let%shared () = %%%MODULE_NAME%%%_base.App.register ~service:Demo_services.demo_i18n ( %%%MODULE_NAME%%%_page.Opt.connected_page @@ fun myid_o () () -> - let* p = page () in + let p = page () in %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-i18n"]] myid_o p ) diff --git a/template.distillery/demo_links.eliom b/template.distillery/demo_links.eliom index 91860c4d..92610c80 100644 --- a/template.distillery/demo_links.eliom +++ b/template.distillery/demo_links.eliom @@ -1,10 +1,7 @@ -open%shared Lwt.Syntax - -[%%shared (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) (* Static files demo *) -open Eliom_content.Html.F] +open%shared Eliom_content.Html.F (* An example of external service: *) let%server ocsigen_service = @@ -16,48 +13,46 @@ let%client ocsigen_service = ~%ocsigen_service (* Page for this demo *) let%shared page () = - Lwt.return - [ h1 [%i18n Demo.links_and_static_files] - ; h2 [%i18n Demo.services] - ; p - [%i18n - Demo.services_1 - ~f1:[code [txt "%%%PROJECT_NAME%%%_services.eliom"]] - ~f2:[code [txt "%%%PROJECT_NAME%%%_handlers.eliom"]] - ~f3:[code [txt "%%%PROJECT_NAME%%%.eliom"]]] - ; h2 [%i18n Demo.links_and_forms] - ; p - [%i18n - Demo.links_and_forms_1 - ~t1: - [a ~service:Os_services.main_service [%i18n Demo.internal_link] ()] - ~t2:[a ~service:ocsigen_service [%i18n Demo.external_service] ()]] - ; h2 [%i18n Demo.static_files] - ; p - [%i18n - Demo.static_files_1 - ~static:[code [txt "static"]] - ~static_dir:[code [txt "static_dir"]]] - ; img - ~a:[a_class ["demo-static-img"]] - ~alt:"local_img" - ~src: - (Eliom_content.Html.F.make_uri - ~absolute:false (* We want local file on mobile app *) - ~service:(Eliom_service.static_dir ()) - ["images"; "ocsigen.png"]) - () - ; p [%i18n Demo.static_files_2] - ; img - ~a:[a_class ["demo-static-img"]] - ~alt:"distant_img" - ~src: - (Eliom_content.Html.F.make_uri - (* We want a distant file: + [ h1 [%i18n Demo.links_and_static_files] + ; h2 [%i18n Demo.services] + ; p + [%i18n + Demo.services_1 + ~f1:[code [txt "%%%PROJECT_NAME%%%_services.eliom"]] + ~f2:[code [txt "%%%PROJECT_NAME%%%_handlers.eliom"]] + ~f3:[code [txt "%%%PROJECT_NAME%%%.eliom"]]] + ; h2 [%i18n Demo.links_and_forms] + ; p + [%i18n + Demo.links_and_forms_1 + ~t1:[a ~service:Os_services.main_service [%i18n Demo.internal_link] ()] + ~t2:[a ~service:ocsigen_service [%i18n Demo.external_service] ()]] + ; h2 [%i18n Demo.static_files] + ; p + [%i18n + Demo.static_files_1 + ~static:[code [txt "static"]] + ~static_dir:[code [txt "static_dir"]]] + ; img + ~a:[a_class ["demo-static-img"]] + ~alt:"local_img" + ~src: + (Eliom_content.Html.F.make_uri + ~absolute:false (* We want local file on mobile app *) + ~service:(Eliom_service.static_dir ()) + ["images"; "ocsigen.png"]) + () + ; p [%i18n Demo.static_files_2] + ; img + ~a:[a_class ["demo-static-img"]] + ~alt:"distant_img" + ~src: + (Eliom_content.Html.F.make_uri + (* We want a distant file: keep the default value of ~absolute *) - ~service:(Eliom_service.static_dir ()) - ["images"; "ocsigen.png"]) - () ] + ~service:(Eliom_service.static_dir ()) + ["images"; "ocsigen.png"]) + () ] (* Service registration is done on both sides (shared section), so that pages can be generated from the server @@ -66,5 +61,6 @@ let%shared page () = let%shared () = %%%MODULE_NAME%%%_base.App.register ~service:Demo_services.demo_links ( %%%MODULE_NAME%%%_page.Opt.connected_page @@ fun myid_o () () -> - let* p = page () in - %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-links"]] myid_o p ) + let p = page () in + %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-links"]] myid_o p + ) diff --git a/template.distillery/demo_notif.eliom b/template.distillery/demo_notif.eliom index 8f9d6afa..ef816ab8 100644 --- a/template.distillery/demo_notif.eliom +++ b/template.distillery/demo_notif.eliom @@ -1,13 +1,10 @@ -open%shared Lwt.Syntax - -[%%client (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) (* Notification demo *) -open Js_of_ocaml_lwt] -[%%shared open Eliom_content] -[%%shared open Html.D] +open%shared Eliom_content +open%shared Html.D +open%client Js_of_ocaml_eio (* Instantiate function Os_notif.Simple for each kind of notification you need. @@ -15,7 +12,7 @@ open Js_of_ocaml_lwt] messaging application, it can be the chatroom ID (for example type key = int64). *) -module Notif = Os_notif.Make_Simple (struct +module%server Notif = Os_notif.Make_Simple (struct type key = unit (* The resources identifiers. @@ -25,18 +22,17 @@ module Notif = Os_notif.Make_Simple (struct end) (* Broadcast message [v] *) -let%rpc notify (v : string) : unit Lwt.t = +let%rpc notify (v : string) : unit = (* Notify all client processes listening on this resource (identified by its key, given as first parameter) by sending them message v. *) - Notif.notify (* ~notfor:`Me *) (() : Notif.key) v; - (* Use ~notfor:`Me to avoid receiving the message in this tab, + Notif.notify (* ~notfor:`Me *) (() : Notif.key) v +(* Use ~notfor:`Me to avoid receiving the message in this tab, or ~notfor:(`User myid) to avoid sending to the current user. (Where myid is Os_current_user.get_current_userid ()) *) - Lwt.return_unit -let%rpc listen () : unit Lwt.t = Notif.listen (); Lwt.return_unit +let%rpc listen () : unit = Notif.listen () (* Display a message every time the React event [e = Notif.client_ev ()] happens. *) @@ -52,8 +48,7 @@ let%server () = (* Eliom_lib.alert "%s" msg *) Os_msg.msg ~level:`Msg (Printf.sprintf "%s" msg)) ~%e) - : unit)]; - Lwt.return_unit) + : unit)]) (* Make a text input field that calls [f s] for each [s] submitted *) let%shared make_form msg f = @@ -63,41 +58,43 @@ let%shared make_form msg f = in ignore [%client - (Lwt.async @@ fun () -> - let btn = Eliom_content.Html.To_dom.of_element ~%btn - and inp = Eliom_content.Html.To_dom.of_input ~%inp in - Lwt_js_events.clicks btn @@ fun _ _ -> - let v = Js_of_ocaml.Js.to_string inp##.value in - let* () = ~%f v in - inp##.value := Js_of_ocaml.Js.string ""; - Lwt.return_unit + (Eio_js.start (fun () -> + let btn = Eliom_content.Html.To_dom.of_element ~%btn + and inp = Eliom_content.Html.To_dom.of_input ~%inp in + Js_of_ocaml_eio.Eio_js_events.clicks btn (fun _ -> + let v = Js_of_ocaml.Js.to_string inp##.value in + let () = ~%f v in + inp##.value := Js_of_ocaml.Js.string "")) : unit)]; Eliom_content.Html.D.div [inp; btn] -let%rpc unlisten () : unit Lwt.t = Notif.unlisten (); Lwt.return_unit +let%rpc unlisten () : unit = Notif.unlisten () (* Page for this demo *) let%shared page () = - let* (* Subscribe to notifications when entering this page: *) - () = + let + (* Subscribe to notifications when entering this page: *) + () + = listen () in (* Unsubscribe from notifications when user leaves this page *) let (_ : unit Eliom_client_value.t) = - [%client Eliom_client.Page_status.ondead (fun () -> Lwt.async unlisten)] + [%client + Eliom_client.Page_status.ondead (fun () -> + Eio_js.start (fun () -> unlisten ()))] in - Lwt.return - Eliom_content.Html.F. - [ h1 [%i18n Demo.notification] - ; p - ([%i18n - Demo.exchange_msg_between_users ~os_notif:[code [txt "Os_notif"]]] - @ [ br () - ; txt [%i18n Demo.S.open_multiple_tabs_browsers] - ; br () - ; txt [%i18n Demo.S.fill_input_form_send_message] ]) - ; make_form [%i18n Demo.S.send_message] - [%client (notify : string -> unit Lwt.t)] ] + Eliom_content.Html.F. + [ h1 [%i18n Demo.notification] + ; p + ([%i18n + Demo.exchange_msg_between_users ~os_notif:[code [txt "Os_notif"]]] + @ [ br () + ; txt [%i18n Demo.S.open_multiple_tabs_browsers] + ; br () + ; txt [%i18n Demo.S.fill_input_form_send_message] ]) + ; make_form [%i18n Demo.S.send_message] [%client (notify : string -> unit)] + ] (* Service registration is done on both sides (shared section), so that pages can be generated from the server @@ -106,5 +103,6 @@ let%shared page () = let%shared () = %%%MODULE_NAME%%%_base.App.register ~service:Demo_services.demo_notif ( %%%MODULE_NAME%%%_page.Opt.connected_page @@ fun myid_o () () -> - let* p = page () in - %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-notif"]] myid_o p ) + let p = page () in + %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-notif"]] myid_o p + ) diff --git a/template.distillery/demo_pagetransition.eliom b/template.distillery/demo_pagetransition.eliom index 6df9c3a0..00bb63c1 100644 --- a/template.distillery/demo_pagetransition.eliom +++ b/template.distillery/demo_pagetransition.eliom @@ -1,6 +1,3 @@ -open%shared Lwt.Syntax - -[%%shared (* This demo illustrates Eliom's DOM caching feature. By running [Eliom_client.onload Eliom_client.push_history_dom] one @@ -9,11 +6,10 @@ open%shared Lwt.Syntax cache instead of being charged from the server or regenerated by the client. Also the scroll position is restored that the page had at the end of the last visit. *) -open Eliom_content] - -[%%shared open Html] -[%%shared open Html.D] -[%%client open Js_of_ocaml_lwt] +open%shared Eliom_content +open%shared Html +open%shared Html.D +open%client Js_of_ocaml_eio let%shared create_item index = let open F in @@ -50,15 +46,13 @@ let%shared page () = r := !r + 1; !r in - Lwt_js_events.clicks (To_dom.of_element ~%add_button) (fun _ _ -> - Html.Manip.appendChild ~%l (create_item (counter ())); - Lwt.return_unit) - : unit Lwt.t)]; - Lwt.return - [ h1 [%i18n Demo.pagetransition_list_page] - ; p [%i18n Demo.pagetransition_intro] - ; l - ; add_button ] + Js_of_ocaml_eio.Eio_js_events.clicks (To_dom.of_element ~%add_button) + (fun _ -> Html.Manip.appendChild ~%l (create_item (counter ()))) + : unit)]; + [ h1 [%i18n Demo.pagetransition_list_page] + ; p [%i18n Demo.pagetransition_intro] + ; l + ; add_button ] let%shared make_detail_page page () = let back_button = @@ -66,10 +60,9 @@ let%shared make_detail_page page () = in ignore [%client - (Lwt.async (fun () -> - Lwt_js_events.clicks (To_dom.of_element ~%back_button) (fun _ _ -> - Js_of_ocaml.Dom_html.window##.history##back; - Lwt.return_unit)) + (Eio_js.start (fun () -> + Js_of_ocaml_eio.Eio_js_events.clicks (To_dom.of_element ~%back_button) + (fun _ -> Js_of_ocaml.Dom_html.window##.history##back)) : unit)]; [ h1 ([%i18n Demo.pagetransition_detail_page] @@ -83,7 +76,7 @@ let%shared make_detail_page page () = let%shared () = %%%MODULE_NAME%%%_base.App.register ~service:Demo_services.demo_pagetransition ( %%%MODULE_NAME%%%_page.Opt.connected_page @@ fun myid_o () () -> - let* p = page () in + let p = page () in %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-pagetransition"]] myid_o p ) diff --git a/template.distillery/demo_pgocaml.eliom b/template.distillery/demo_pgocaml.eliom index cad1effa..ba2fd99a 100644 --- a/template.distillery/demo_pgocaml.eliom +++ b/template.distillery/demo_pgocaml.eliom @@ -1,41 +1,37 @@ -open%shared Lwt.Syntax - -[%%shared (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) (* PGOcaml demo *) -open Eliom_content.Html.F] +open%shared Eliom_content.Html.F (* Fetch users in database *) -let%rpc get_users () : string list Lwt.t = - let* +let%rpc get_users () : string list = + let (* For this demo, we add a delay to simulate a network or db latency: *) - () + () = - Lwt_unix.sleep 2. + Eio_unix.sleep 2. in Demo_pgocaml_db.get () (* Generate page for this demo *) let%shared page () = - let* user_block = - Ot_spinner.with_spinner - (let* users = get_users () in - let users = - List.map - (fun u -> if u = "" then li [em [txt "new user"]] else li [txt u]) - users - in - if users = [] - then Lwt.return [p [em [%i18n Demo.no_user_create_accounts]]] - else Lwt.return [p [%i18n Demo.pgocaml_users]; ul users]) + let user_block = + Ot_spinner.with_spinner (fun () -> + let users = get_users () in + let users = + List.map + (fun u -> if u = "" then li [em [txt "new user"]] else li [txt u]) + users + in + if users = [] + then [p [em [%i18n Demo.no_user_create_accounts]]] + else [p [%i18n Demo.pgocaml_users]; ul users]) in - Lwt.return - [ h1 [%i18n Demo.pgocaml] - ; p [%i18n Demo.pgocaml_description_1] - ; p [%i18n Demo.pgocaml_description_2] - ; p [%i18n Demo.pgocaml_description_3] - ; user_block ] + [ h1 [%i18n Demo.pgocaml] + ; p [%i18n Demo.pgocaml_description_1] + ; p [%i18n Demo.pgocaml_description_2] + ; p [%i18n Demo.pgocaml_description_3] + ; user_block ] (* Service registration is done on both sides (shared section), so that pages can be generated from the server @@ -44,6 +40,6 @@ let%shared page () = let%shared () = %%%MODULE_NAME%%%_base.App.register ~service:Demo_services.demo_pgocaml ( %%%MODULE_NAME%%%_page.Opt.connected_page @@ fun myid_o () () -> - let* p = page () in + let p = page () in %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-pgocaml"]] myid_o p ) diff --git a/template.distillery/demo_pgocaml_db.ml b/template.distillery/demo_pgocaml_db.ml index 4d0b396a..33ff265c 100644 --- a/template.distillery/demo_pgocaml_db.ml +++ b/template.distillery/demo_pgocaml_db.ml @@ -10,4 +10,4 @@ open Os_db let get () = full_transaction_block (fun dbh -> - [%pgsql dbh "SELECT lastname FROM ocsigen_start.users"]) + [%pgsql dbh "SELECT lastname FROM ocsigen_start.users"]) diff --git a/template.distillery/demo_popup.eliom b/template.distillery/demo_popup.eliom index 9d80915b..1076ce0c 100644 --- a/template.distillery/demo_popup.eliom +++ b/template.distillery/demo_popup.eliom @@ -1,5 +1,3 @@ -open%shared Lwt.Syntax - [%%shared (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) @@ -7,7 +5,7 @@ open%shared Lwt.Syntax open Eliom_content.Html] [%%shared open Eliom_content.Html.F] -[%%client open Js_of_ocaml_lwt] +[%%client open Js_of_ocaml_eio] (* Name for demo menu. This value is defined both server and client-side. *) let%shared name () = [%i18n Demo.S.popup] @@ -28,11 +26,8 @@ let%shared page () = in (* Every time this page is generated, we want to execute the following piece of client-side code. - Lwt_js_events.clicks means "For each click on ... do ...". - It creates an Lwt thread that never returns. - We run it asynchronously using Lwt.async. - Lwt_js_events.clicks is expecting a DOM node - (i.e. an actual part of the current page). + Eio_js_events.clicks means "For each click on ... do ...". + It runs a callback for each click event. To_dom.of_element will return the DOM node corresponding to the OCaml value ~%button. ~%button refers to the value button, defined outside [%client ] section @@ -41,23 +36,18 @@ let%shared page () = ignore [%client (* This client section will be executed after the page is - displayed by the browser. *) - (Lwt.async (fun () -> - (* Lwt_js_events.clicks returns a Lwt thread, which never terminates. - We run it asynchronously. *) - Lwt_js_events.clicks (To_dom.of_element ~%button) (fun _ _ -> - let* _ = - Ot_popup.popup - ~close_button:[Os_icons.F.close ()] - (fun _ -> Lwt.return @@ p [%i18n Demo.popup_message]) - in - Lwt.return_unit)) + displayed by the browser. *) + (Eio_js.start (fun () -> + Eio_js_events.clicks (To_dom.of_element ~%button) (fun _ -> + ignore (Ot_popup.popup + ~close_button:[Os_icons.F.close ()] + (fun _ -> p [%i18n Demo.popup_message])))) : unit)]; (* Page elements, using module Eliom_content.Html.F (as we don't want to add a unique identifier). See internationalization demo for i18n syntax. *) - Lwt.return [h1 [%i18n Demo.popup]; p [%i18n Demo.popup_content]; p [button]] + [h1 [%i18n Demo.popup]; p [%i18n Demo.popup_content]; p [button]] (* Service registration is done on both sides (shared section), so that pages can be generated from the server @@ -66,5 +56,5 @@ let%shared page () = let%shared () = %%%MODULE_NAME%%%_base.App.register ~service:Demo_services.demo_popup ( %%%MODULE_NAME%%%_page.Opt.connected_page @@ fun myid_o () () -> - let* p = page () in + let p = page () in %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-popup"]] myid_o p ) diff --git a/template.distillery/demo_pulltorefresh.eliom b/template.distillery/demo_pulltorefresh.eliom index f4dfb218..a021111b 100644 --- a/template.distillery/demo_pulltorefresh.eliom +++ b/template.distillery/demo_pulltorefresh.eliom @@ -1,22 +1,20 @@ -open%shared Lwt.Syntax - (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) (** Demo for refreshable content *) -[%%shared open Eliom_content.Html] -[%%shared open Eliom_content.Html.D] +open%shared Eliom_content.Html +open%shared Eliom_content.Html.D let%shared page () = let counter_sig, set_counter = Eliom_shared.React.S.create 0 in let reload = [%client fun () -> - let* _ = Js_of_ocaml_lwt.Lwt_js.sleep 1. in + let _ = Js_of_ocaml_eio.Eio_js.sleep 1. in let n = Eliom_shared.React.S.value ~%counter_sig in ~%set_counter (n + 1); - Lwt.return_true] + true] in let counter_node_sig = Eliom_shared.React.S.map @@ -34,7 +32,7 @@ let%shared page () = ; F.p [%i18n Demo.pull_to_refresh_2] ; R.node counter_node_sig ] in - Lwt.return @@ [Ot_pulltorefresh.make ~dragThreshold:15. ~content reload] + [Ot_pulltorefresh.make ~dragThreshold:15. ~content reload] (* Service registration is done on both sides (shared section), so that pages can be generated from the server @@ -43,7 +41,7 @@ let%shared page () = let%shared () = %%%MODULE_NAME%%%_base.App.register ~service:Demo_services.demo_pulltorefresh ( %%%MODULE_NAME%%%_page.Opt.connected_page @@ fun myid_o () () -> - let* p = page () in + let p = page () in %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-pulltorefresh"]] myid_o p ) diff --git a/template.distillery/demo_react.eliom b/template.distillery/demo_react.eliom index 6980fb23..0e3a400b 100644 --- a/template.distillery/demo_react.eliom +++ b/template.distillery/demo_react.eliom @@ -1,13 +1,11 @@ -open%shared Lwt.Syntax - (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) (** Demo for shared reactive content *) -[%%client open Js_of_ocaml_lwt] -[%%shared open Eliom_content] -[%%shared open Html.D] +open%shared Eliom_content +open%shared Html.D +open%client Js_of_ocaml_eio (* Make a text input field that calls [f s] for each [s] submitted *) let%shared make_form msg f = @@ -17,14 +15,13 @@ let%shared make_form msg f = in ignore [%client - (Lwt.async @@ fun () -> - let btn = Eliom_content.Html.To_dom.of_element ~%btn - and inp = Eliom_content.Html.To_dom.of_input ~%inp in - Lwt_js_events.clicks btn @@ fun _ _ -> - let v = Js_of_ocaml.Js.to_string inp##.value in - let* () = ~%f v in - inp##.value := Js_of_ocaml.Js.string ""; - Lwt.return_unit + (Eio_js.start (fun () -> + let btn = Eliom_content.Html.To_dom.of_element ~%btn + and inp = Eliom_content.Html.To_dom.of_input ~%inp in + Js_of_ocaml_eio.Eio_js_events.clicks btn (fun _ -> + let v = Js_of_ocaml.Js.to_string inp##.value in + let () = ~%f v in + inp##.value := Js_of_ocaml.Js.string "")) : unit)]; Eliom_content.Html.D.div [inp; btn] @@ -41,8 +38,7 @@ let%shared page () = (* Form that performs a cons (client-side). *) make_form [%i18n Demo.S.reactive_programming_button] [%client - (fun v -> Lwt.return (Eliom_shared.ReactiveData.RList.cons v ~%h) - : string -> unit Lwt.t)] + (fun v -> Eliom_shared.ReactiveData.RList.cons v ~%h : string -> unit)] and l = (* Produce
  • items from l contents. The shared function will first be called once server or client-side @@ -53,14 +49,13 @@ let%shared page () = [%shared (fun s -> Eliom_content.Html.(D.li [D.txt s]) : _ -> _)] l in - Lwt.return - Eliom_content.Html. - [ F.h1 [%i18n Demo.reactive_programming] - ; F.p [F.txt [%i18n Demo.S.reactive_programming_1]] - ; F.p [F.txt [%i18n Demo.S.reactive_programming_2]] - ; F.p [F.txt [%i18n Demo.S.reactive_programming_3]] - ; inp - ; F.div [R.ul l] ] + Eliom_content.Html. + [ F.h1 [%i18n Demo.reactive_programming] + ; F.p [F.txt [%i18n Demo.S.reactive_programming_1]] + ; F.p [F.txt [%i18n Demo.S.reactive_programming_2]] + ; F.p [F.txt [%i18n Demo.S.reactive_programming_3]] + ; inp + ; F.div [R.ul l] ] (* Service registration is done on both sides (shared section), so that pages can be generated from the server @@ -69,5 +64,6 @@ let%shared page () = let%shared () = %%%MODULE_NAME%%%_base.App.register ~service:Demo_services.demo_react ( %%%MODULE_NAME%%%_page.Opt.connected_page @@ fun myid_o () () -> - let* p = page () in - %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-react"]] myid_o p ) + let p = page () in + %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-react"]] myid_o p + ) diff --git a/template.distillery/demo_ref.eliom b/template.distillery/demo_ref.eliom index d93ee200..4444075e 100644 --- a/template.distillery/demo_ref.eliom +++ b/template.distillery/demo_ref.eliom @@ -1,10 +1,7 @@ -open%shared Lwt.Syntax - -[%%shared (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) (* Demo for Eliom references and Os_date *) -open Eliom_content.Html.F] +open%shared Eliom_content.Html.F (* An Eliom reference storing the last time the user visited the current page. It has scope Eliom_common.default_group_scope, which means that @@ -17,30 +14,28 @@ let%server last_visit = ~scope:Eliom_common.default_group_scope None (* Read & reset last_visit *) -let%rpc get_reset_last_visit () : Os_date.local_calendar option Lwt.t = - let* v = Eliom_reference.get last_visit in - let* () = Eliom_reference.set last_visit (Some (Os_date.now ())) in - Lwt.return v +let%rpc get_reset_last_visit () : Os_date.local_calendar option = + let v = Eliom_reference.get last_visit in + let () = Eliom_reference.set last_visit (Some (Os_date.now ())) in + v (* Call get_reset_last_visit and produce pretty message *) let%shared get_reset_last_visit_message () = - let* last_visit = get_reset_last_visit () in + let last_visit = get_reset_last_visit () in match last_visit with - | None -> Lwt.return [%i18n Demo.eliom_ref_first_visit] + | None -> [%i18n Demo.eliom_ref_first_visit] | Some last_visit -> - Lwt.return - ([%i18n Demo.eliom_ref_last_visit] - @ [txt " "; txt (Os_date.smart_time last_visit)]) + [%i18n Demo.eliom_ref_last_visit] + @ [txt " "; txt (Os_date.smart_time last_visit)] (* Generate page for this demo *) let%shared page () = - let* last_visit_message = get_reset_last_visit_message () in - Lwt.return - [ h1 [%i18n Demo.eliom_ref] - ; p [txt [%i18n Demo.S.eliom_ref_1]] - ; p [txt [%i18n Demo.S.eliom_ref_2]] - ; p last_visit_message - ; p [txt [%i18n Demo.S.eliom_ref_3]] ] + let last_visit_message = get_reset_last_visit_message () in + [ h1 [%i18n Demo.eliom_ref] + ; p [txt [%i18n Demo.S.eliom_ref_1]] + ; p [txt [%i18n Demo.S.eliom_ref_2]] + ; p last_visit_message + ; p [txt [%i18n Demo.S.eliom_ref_3]] ] (* Service registration is done on both sides (shared section), so that pages can be generated from the server @@ -49,5 +44,5 @@ let%shared page () = let%shared () = %%%MODULE_NAME%%%_base.App.register ~service:Demo_services.demo_ref ( %%%MODULE_NAME%%%_page.Opt.connected_page @@ fun myid_o () () -> - let* p = page () in + let p = page () in %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-ref"]] myid_o p ) diff --git a/template.distillery/demo_rpc.eliom b/template.distillery/demo_rpc.eliom index d5a03f05..999bf2df 100644 --- a/template.distillery/demo_rpc.eliom +++ b/template.distillery/demo_rpc.eliom @@ -1,13 +1,10 @@ -open%shared Lwt.Syntax - -[%%client (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) (* RPC button demo *) -open Js_of_ocaml_lwt] -[%%shared open Eliom_content] -[%%shared open Html.D] +open%shared Eliom_content +open%shared Html.D +open%client Js_of_ocaml_eio (* A server-side reference that stores data for the current browser (scope = session). @@ -18,11 +15,11 @@ let%server my_ref = Eliom_reference.eref ~scope:Eliom_common.default_session_scope 0 (* Server-side function that increments my_ref and returns new val *) -let%rpc incr_my_ref () : int Lwt.t = - let* v = Eliom_reference.get my_ref in +let%rpc incr_my_ref () : int = + let v = Eliom_reference.get my_ref in let v = v + 1 in - let* () = Eliom_reference.set my_ref v in - Lwt.return v + let () = Eliom_reference.set my_ref v in + v let%shared button msg f = let btn = @@ -30,9 +27,9 @@ let%shared button msg f = in ignore [%client - (Lwt.async @@ fun () -> - Lwt_js_events.clicks (Eliom_content.Html.To_dom.of_element ~%btn) - (fun _ _ -> ~%f ()) + (Eio_js.start (fun () -> + Js_of_ocaml_eio.Eio_js_events.clicks + (Eliom_content.Html.To_dom.of_element ~%btn) (fun _ -> ~%f ())) : unit)]; btn @@ -42,16 +39,14 @@ let%shared page () = button [%i18n Demo.S.rpc_button_click_increase] [%client (fun () -> - let* v = incr_my_ref () in - Eliom_lib.alert "Update: %d" v; - Lwt.return_unit - : unit -> unit Lwt.t)] + let v = incr_my_ref () in + Eliom_lib.alert "Update: %d" v + : unit -> unit)] in - Lwt.return - Eliom_content.Html. - [ F.h1 [%i18n Demo.rpc_button] - ; F.p [F.txt [%i18n Demo.S.rpc_button_description]] - ; F.p [btn] ] + Eliom_content.Html. + [ F.h1 [%i18n Demo.rpc_button] + ; F.p [F.txt [%i18n Demo.S.rpc_button_description]] + ; F.p [btn] ] (* Service registration is done on both sides (shared section), so that pages can be generated from the server @@ -60,5 +55,5 @@ let%shared page () = let%shared () = %%%MODULE_NAME%%%_base.App.register ~service:Demo_services.demo_rpc ( %%%MODULE_NAME%%%_page.Opt.connected_page @@ fun myid_o () () -> - let* p = page () in + let p = page () in %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-rpc"]] myid_o p ) diff --git a/template.distillery/demo_services.eliom b/template.distillery/demo_services.eliom index 9f1826aa..67127386 100644 --- a/template.distillery/demo_services.eliom +++ b/template.distillery/demo_services.eliom @@ -16,12 +16,6 @@ let%server demo = let%client demo = ~%demo -let%server demo_popup = - Eliom_service.create ~path:(Eliom_service.Path ["demo-popup"]) - ~meth:(Eliom_service.Get Eliom_parameter.unit) () - -let%client demo_popup = ~%demo_popup - let%server demo_rpc = Eliom_service.create ~path:(Eliom_service.Path ["demo-rpc"]) ~meth:(Eliom_service.Get Eliom_parameter.unit) () @@ -64,6 +58,12 @@ let%server demo_i18n = let%client demo_i18n = ~%demo_i18n +let%server demo_popup = + Eliom_service.create ~path:(Eliom_service.Path ["demo-popup"]) + ~meth:(Eliom_service.Get Eliom_parameter.unit) () + +let%client demo_popup = ~%demo_popup + let%server demo_tips = Eliom_service.create ~path:(Eliom_service.Path ["demo-tips"]) ~meth:(Eliom_service.Get Eliom_parameter.unit) () diff --git a/template.distillery/demo_spinner.eliom b/template.distillery/demo_spinner.eliom index 804b9297..9bb56c42 100644 --- a/template.distillery/demo_spinner.eliom +++ b/template.distillery/demo_spinner.eliom @@ -1,38 +1,33 @@ -open%shared Lwt.Syntax - -[%%client (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) (* Spinner demo *) -open Js_of_ocaml_lwt] -[%%shared open Eliom_content] -[%%shared open Html.D] +open%shared Eliom_content +open%shared Html.D (* Build the spinner *) let%client make_spinner () = - (* [Ot_spinner.with_spinner_no_lwt] accepts an Lwt thread "slowly" + (* [Ot_spinner.with_spinner] accepts a thunk "slowly" producing HTML content *) - Ot_spinner.with_spinner_no_lwt + Ot_spinner.with_spinner (* sleep for 5 seconds to simulate a delay, then return content *) - (let* () = Lwt_js.sleep 5. in - Lwt.return + (fun () -> + let () = Js_of_ocaml_eio.Eio_js.sleep 5. in Eliom_content.Html.D. [ txt [%i18n Demo.S.spinner_content_ready] ; txt " " ; txt [%i18n Demo.S.spinner_message_replace_spinner] ]) (* Page for this demo *) -let%shared page () : Html_types.div_content Eliom_content.Html.elt list Lwt.t = - Lwt.return - Eliom_content.Html. - [ F.h1 [%i18n Demo.spinner] - ; F.p [F.txt [%i18n Demo.S.spinner_description_ot]] - ; F.p [F.txt [%i18n Demo.S.spinner_description_1]] - ; F.p [F.txt [%i18n Demo.S.spinner_description_2]] - ; F.p [F.txt [%i18n Demo.S.spinner_description_3]] - ; F.p [F.txt [%i18n Demo.S.spinner_generated_client_side]] - ; C.node [%client (make_spinner () : [> `Div] Eliom_content.Html.elt)] ] +let%shared page () : Html_types.div_content Eliom_content.Html.elt list = + Eliom_content.Html. + [ F.h1 [%i18n Demo.spinner] + ; F.p [F.txt [%i18n Demo.S.spinner_description_ot]] + ; F.p [F.txt [%i18n Demo.S.spinner_description_1]] + ; F.p [F.txt [%i18n Demo.S.spinner_description_2]] + ; F.p [F.txt [%i18n Demo.S.spinner_description_3]] + ; F.p [F.txt [%i18n Demo.S.spinner_generated_client_side]] + ; C.node [%client (make_spinner () : [> `Div] Eliom_content.Html.elt)] ] (* Service registration is done on both sides (shared section), so that pages can be generated from the server @@ -41,6 +36,6 @@ let%shared page () : Html_types.div_content Eliom_content.Html.elt list Lwt.t = let%shared () = %%%MODULE_NAME%%%_base.App.register ~service:Demo_services.demo_spinner ( %%%MODULE_NAME%%%_page.Opt.connected_page @@ fun myid_o () () -> - let* p = page () in + let p = page () in %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-spinner"]] myid_o p ) diff --git a/template.distillery/demo_timepicker.eliom b/template.distillery/demo_timepicker.eliom index 8428406c..a5d74d4d 100644 --- a/template.distillery/demo_timepicker.eliom +++ b/template.distillery/demo_timepicker.eliom @@ -1,19 +1,12 @@ -open%shared Lwt.Syntax - -[%%shared (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) -open Eliom_content.Html.D] - -[%%client open Js_of_ocaml_lwt] +open%shared Eliom_content.Html.D +open%client Js_of_ocaml_eio (* Timepicker demo *) let%server s, f = Eliom_shared.React.S.create None - -let%client action (h, m) = - ~%f (Some (h, m)); - Lwt.return_unit +let%client action (h, m) = ~%f (Some (h, m)) let%shared string_of_time = function | Some (h, m) -> @@ -23,8 +16,7 @@ let%shared string_of_time = function let%server time_as_string () : string Eliom_shared.React.S.t = Eliom_shared.React.S.map [%shared string_of_time] s -let%rpc time_reactive () : string Eliom_shared.React.S.t Lwt.t = - Lwt.return @@ time_as_string () +let%rpc time_reactive () : string Eliom_shared.React.S.t = time_as_string () (* Page for this demo *) let%shared page () = @@ -36,17 +28,17 @@ let%shared page () = in ignore [%client - (Lwt.async (fun () -> - Lwt_js_events.clicks (Eliom_content.Html.To_dom.of_element ~%button) - (fun _ _ -> ~%back_f (); Lwt.return_unit)) + (Eio_js.start (fun () -> + Js_of_ocaml_eio.Eio_js_events.clicks + (Eliom_content.Html.To_dom.of_element ~%button) (fun _ -> + ~%back_f ())) : _)]; - let* tr = time_reactive () in - Lwt.return - [ h1 [%i18n Demo.timepicker] - ; p [%i18n Demo.timepicker_description] - ; div [time_picker] - ; p [Eliom_content.Html.R.txt tr] - ; div [button] ] + let tr = time_reactive () in + [ h1 [%i18n Demo.timepicker] + ; p [%i18n Demo.timepicker_description] + ; div [time_picker] + ; p [Eliom_content.Html.R.txt tr] + ; div [button] ] (* Service registration is done on both sides (shared section), so that pages can be generated from the server @@ -55,7 +47,7 @@ let%shared page () = let%shared () = %%%MODULE_NAME%%%_base.App.register ~service:Demo_services.demo_timepicker ( %%%MODULE_NAME%%%_page.Opt.connected_page @@ fun myid_o () () -> - let* p = page () in + let p = page () in %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-timepicker"]] myid_o p ) diff --git a/template.distillery/demo_tips.eliom b/template.distillery/demo_tips.eliom index 9c3866e4..4817e089 100644 --- a/template.distillery/demo_tips.eliom +++ b/template.distillery/demo_tips.eliom @@ -1,10 +1,7 @@ -open%shared Lwt.Syntax - -[%%shared (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) (* Os_tips demo *) -open Eliom_content.Html.F] +open%shared Eliom_content.Html.F (* Here is an example of tip. Call this function while generating the widget concerned by the explanation it contains. *) @@ -16,27 +13,26 @@ let%shared example_tip () = ~content: [%client fun _ -> - Lwt.return - Eliom_content.Html.F. - [p [%i18n Demo.example_tip]; p [%i18n Demo.look_module_tip]]] + Eliom_content.Html.F. + [p [%i18n Demo.example_tip]; p [%i18n Demo.look_module_tip]]] (* Page for this demo *) let%shared page () = - let* (* Call the function defining the tip from the server or the client: *) - () + let + (* Call the function defining the tip from the server or the client: *) + () = example_tip () in - Lwt.return - [ h1 [%i18n Demo.tips1] - ; p [%i18n Demo.tips2 ~os_tips:[code [txt "Os_tips"]]] - ; p [%i18n Demo.tips3] - ; p - [%i18n - Demo.tips4 - ~set_page: - [ a ~service:%%%MODULE_NAME%%%_services.settings_service - [%i18n Demo.tips5] () ]] ] + [ h1 [%i18n Demo.tips1] + ; p [%i18n Demo.tips2 ~os_tips:[code [txt "Os_tips"]]] + ; p [%i18n Demo.tips3] + ; p + [%i18n + Demo.tips4 + ~set_page: + [ a ~service:%%%MODULE_NAME%%%_services.settings_service + [%i18n Demo.tips5] () ]] ] (* Service registration is done on both sides (shared section), so that pages can be generated from the server @@ -45,5 +41,5 @@ let%shared page () = let%shared () = %%%MODULE_NAME%%%_base.App.register ~service:Demo_services.demo_tips ( %%%MODULE_NAME%%%_page.Opt.connected_page @@ fun myid_o () () -> - let* p = page () in + let p = page () in %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-tips"]] myid_o p ) diff --git a/template.distillery/demo_tongue.eliom b/template.distillery/demo_tongue.eliom index ebae0af2..eeddb5e9 100644 --- a/template.distillery/demo_tongue.eliom +++ b/template.distillery/demo_tongue.eliom @@ -1,10 +1,7 @@ -open%shared Lwt.Syntax - -[%%shared (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) (* Tongue demo *) -open Eliom_content.Html.F] +open%shared Eliom_content.Html.F (* Page for this demo *) let%shared page () = @@ -21,10 +18,9 @@ let%shared page () = ~stops:[`Px 70; `Interval (`Percent 100, `Full_content)] ~init:(`Px 70) content in - Lwt.return - [ h1 [%i18n Demo.tongue_1] - ; p [%i18n Demo.ot_tongue_1] - ; div ~a:[a_class ["demo-tongue"]] [tongue.Ot_tongue.elt] ] + [ h1 [%i18n Demo.tongue_1] + ; p [%i18n Demo.ot_tongue_1] + ; div ~a:[a_class ["demo-tongue"]] [tongue.Ot_tongue.elt] ] (* Service registration is done on both sides (shared section), so that pages can be generated from the server @@ -33,6 +29,6 @@ let%shared page () = let%shared () = %%%MODULE_NAME%%%_base.App.register ~service:Demo_services.demo_tongue ( %%%MODULE_NAME%%%_page.Opt.connected_page @@ fun myid_o () () -> - let* p = page () in + let p = page () in %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-tongue"]] myid_o p ) diff --git a/template.distillery/demo_tools.eliom b/template.distillery/demo_tools.eliom index db81dc32..7cff5b3e 100644 --- a/template.distillery/demo_tools.eliom +++ b/template.distillery/demo_tools.eliom @@ -4,15 +4,16 @@ [%%shared.start] let demos = - [ (fun () -> [%i18n Demo.S.rpc_button]), Demo_services.demo_rpc + [ (fun () -> [%i18n Demo.S.tips]), Demo_services.demo_tips + ; (fun () -> [%i18n Demo.S.rpc_button]), Demo_services.demo_rpc ; (fun () -> [%i18n Demo.S.eliom_ref]), Demo_services.demo_ref ; (fun () -> [%i18n Demo.S.spinner]), Demo_services.demo_spinner + ; (fun () -> [%i18n Demo.S.popup]), Demo_services.demo_popup ; (fun () -> [%i18n Demo.S.pgocaml]), Demo_services.demo_pgocaml ; (fun () -> [%i18n Demo.S.users]), Demo_services.demo_users ; (fun () -> [%i18n Demo.S.links_and_static_files]), Demo_services.demo_links ; ( (fun () -> [%i18n Demo.S.internationalization ~capitalize:true]) , Demo_services.demo_i18n ) - ; (fun () -> [%i18n Demo.S.tips]), Demo_services.demo_tips ; (fun () -> [%i18n Demo.S.carousel_1]), Demo_services.demo_carousel1 ; (fun () -> [%i18n Demo.S.carousel_2]), Demo_services.demo_carousel2 ; (fun () -> [%i18n Demo.S.carousel_wheel]), Demo_services.demo_carousel3 diff --git a/template.distillery/demo_users.eliom b/template.distillery/demo_users.eliom index 7ed0d23f..78f62a0a 100644 --- a/template.distillery/demo_users.eliom +++ b/template.distillery/demo_users.eliom @@ -1,10 +1,7 @@ -open%shared Lwt.Syntax - -[%%shared (* This file was generated by Ocsigen Start. Feel free to use it, modify it, and redistribute it as you wish. *) (* Os_current_user demo *) -open Eliom_content.Html.F] +open%shared Eliom_content.Html.F let%shared display_user_name = function | None -> p [%i18n Demo.you_are_not_connected] @@ -30,19 +27,18 @@ let%shared page () = *) let myid_o = Os_current_user.Opt.get_current_userid () in let me_o = Os_current_user.Opt.get_current_user () in - Lwt.return - [ h1 [%i18n Demo.users] - ; p - [ txt [%i18n Demo.S.the_module] - ; code [txt " Os_current_user "] - ; txt [%i18n Demo.S.allows_get_information_currently_connected_user] ] - ; display_user_name me_o - ; display_user_id myid_o - ; p [txt [%i18n Demo.S.these_functions_called_server_or_client_side]] - ; p - [ txt [%i18n Demo.S.always_get_current_user_using_module] - ; code [txt " Os_current_user. "] - ; txt [%i18n Demo.S.never_trust_client_pending_user_id] ] ] + [ h1 [%i18n Demo.users] + ; p + [ txt [%i18n Demo.S.the_module] + ; code [txt " Os_current_user "] + ; txt [%i18n Demo.S.allows_get_information_currently_connected_user] ] + ; display_user_name me_o + ; display_user_id myid_o + ; p [txt [%i18n Demo.S.these_functions_called_server_or_client_side]] + ; p + [ txt [%i18n Demo.S.always_get_current_user_using_module] + ; code [txt " Os_current_user. "] + ; txt [%i18n Demo.S.never_trust_client_pending_user_id] ] ] (* Service registration is done on both sides (shared section), so that pages can be generated from the server @@ -51,5 +47,6 @@ let%shared page () = let%shared () = %%%MODULE_NAME%%%_base.App.register ~service:Demo_services.demo_users ( %%%MODULE_NAME%%%_page.Opt.connected_page @@ fun myid_o () () -> - let* p = page () in - %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-users"]] myid_o p ) + let p = page () in + %%%MODULE_NAME%%%_container.page ~a:[a_class ["os-page-demo-users"]] myid_o p + ) diff --git a/template.distillery/dune b/template.distillery/dune index 79103112..ac16b7c8 100644 --- a/template.distillery/dune +++ b/template.distillery/dune @@ -6,13 +6,17 @@ (name %%%PROJECT_NAME%%%) (modules (:standard \ %%%MODULE_NAME%%%_main)) - (libraries eliom.server ocsigen-start.server ocsipersist-pgsql ocsipersist-pgsql.settings) + (libraries + eliom.server + ocsigen-start.server + ocsipersist-sqlite + ocsipersist-sqlite.settings) (library_flags (:standard -linkall)) (wrapped false) (preprocess (pps - pgocaml_ppx + pgocaml_ppx js_of_ocaml-ppx_deriving_json ocsigen-i18n ocsigen-ppx-rpc @@ -34,13 +38,13 @@ (libraries eliom.server ocsigen-start.server - ocsipersist-pgsql + ocsipersist-sqlite ocsigenserver.ext.staticmod %%%PROJECT_NAME%%%) (modules %%%MODULE_NAME%%%_main) (preprocess (pps - pgocaml_ppx + pgocaml_ppx js_of_ocaml-ppx_deriving_json ocsigen-i18n ocsigen-ppx-rpc @@ -130,7 +134,7 @@ (preprocess (pps js_of_ocaml-ppx - ocsigen-i18n + ocsigen-i18n -- --prefix %%%MODULE_NAME%%%_ @@ -139,13 +143,15 @@ --default-module %%%MODULE_NAME%%%_i18n)) (js_of_ocaml - (build_runtime_flags :standard --enable use-js-string) + (build_runtime_flags :standard --enable use-js-string --enable effects) (flags :standard --enable with-js-error --enable use-js-string + --enable + effects --no-source-map)) ; source maps are slow... (libraries eliom.client ocsigen-start.client)) diff --git a/template.distillery/mobile!eliom_loader.ml b/template.distillery/mobile!eliom_loader.ml index 4870322e..767d61a1 100644 --- a/template.distillery/mobile!eliom_loader.ml +++ b/template.distillery/mobile!eliom_loader.ml @@ -2,18 +2,18 @@ Feel free to use it, modify it, and redistribute it as you wish. *) (* Load Eliom client-side program after storing global data in - localStorage. Compile as follos: + localStorage. Compile as follows: ocamlfind ocamlc \ - -package js_of_ocaml,js_of_ocaml.ppx \ + -package js_of_ocaml,js_of_ocaml-ppx,js_of_ocaml-eio \ -linkpkg -o eliom_loader.byte \ eliom_loader.ml - js_of_ocaml eliom_loader.byte + js_of_ocaml --effects=cps eliom_loader.byte *) -open Lwt.Syntax -module XmlHttpRequest = Js_of_ocaml_lwt.XmlHttpRequest +module XmlHttpRequest = Js_of_ocaml_eio.XmlHttpRequest +module Eio_js_events = Js_of_ocaml_eio.Eio_js_events (* Debug mode. Set to true if you want to use the debug mode. Used by "log". *) @@ -24,14 +24,14 @@ let debug = false *) let log = if debug then (fun s -> - Js_of_ocaml.Firebug.console##log (Js_of_ocaml.Js.string s); + Js_of_ocaml.Console.console##log (Js_of_ocaml.Js.string s); let p = Js_of_ocaml.Dom_html.createP Js_of_ocaml.Dom_html.document in p##.style##.color := Js_of_ocaml.Js.string "#64b5f6"; Js_of_ocaml.Dom.appendChild p (Js_of_ocaml.Dom_html.document##createTextNode (Js_of_ocaml.Js.string s)); let container = Js_of_ocaml.Dom_html.getElementById "app-container" in Js_of_ocaml.Dom.appendChild container p) - else fun s -> () + else fun _ -> () (* Reference used by the binding to fetchUpdate to know if update has been done * or if it failed. @@ -80,28 +80,27 @@ let rec add_retry_button wake msg = ignore Js_of_ocaml.Js.Unsafe.global##.chcp##fetchUpdate); if !data_upload_failed then ( data_upload_failed := false; - Lwt.async (fun () -> get_data wake)); + Eio_js_events.async (fun () -> get_data wake)); Js_of_ocaml.Js._false); btn##.id := Js_of_ocaml.Js.string "retry-button"; Js_of_ocaml.Dom.appendChild p btn; Js_of_ocaml.Dom.appendChild container p and get_data wake = - let* { XmlHttpRequest.content; code } = XmlHttpRequest.get url in + let { XmlHttpRequest.content; code; _ } = XmlHttpRequest.get url in if code = 200 then ( log "Got global data"; (storage ())##setItem (Js_of_ocaml.Js.string "__global_data") (Js_of_ocaml.Js.string content); - Lwt.wakeup wake ()) + Eio.Promise.resolve wake ()) else ( log "Could not get global data"; if not (!update_failed || !data_upload_failed) then ( data_upload_failed := true; add_retry_button wake "Cannot connect to the server. Please make sure that this app has \ - access to a data connection.")); - Lwt.return_unit + access to a data connection.")) (* Get the URL saved in the JavaScript variables "___eliom_html_url_" defined in * index.html and go this location. @@ -120,9 +119,9 @@ let _ = ignore Js_of_ocaml.Js.Unsafe.global##.chcp##fetchUpdate; Js_of_ocaml.Js._true)) Js_of_ocaml.Js._false; - (* Create two threads for success callbacks and error callbacks. *) - let wait_success, wake_success = Lwt.wait () in - let wait_error, wake_error = Lwt.wait () in + (* Create two promises for success callbacks and error callbacks. *) + let wait_success, wake_success = Eio.Promise.create () in + let wait_error, wake_error = Eio.Promise.create () in (* Callback when success. * [callback ev] will print the event if debug mode is activated. * Calls by the event chcp_nothingToUpdate. @@ -131,7 +130,7 @@ let _ = Js_of_ocaml.Dom.handler (fun _ -> log ev; update_failed := false; - Lwt.wakeup wake_success (); + Eio.Promise.resolve wake_success (); Js_of_ocaml.Js._true) in (* Callback when errors. @@ -151,7 +150,7 @@ let _ = in (* Callback to print a message *) let status_callback name = - Js_of_ocaml.Dom.handler (fun ev -> + Js_of_ocaml.Dom.handler (fun _ -> log name; Js_of_ocaml.Js.bool true) in @@ -194,9 +193,9 @@ let _ = "chcp_beforeAssetsInstalledOnExternalStorage"; "chcp_assetsInstalledOnExternalStorage"; ]; - Lwt.async @@ fun () -> - let* _ = Js_of_ocaml_lwt.Lwt_js_events.onload () in - let* _ = get_data wake_error in - let* _ = wait_error in - let* _ = wait_success in - Lwt.return (redirect ()) + Js_of_ocaml_eio.Eio_js.start @@ fun () -> + let _ = Eio_js_events.onload () in + get_data wake_error; + let _ = Eio.Promise.await wait_error in + let _ = Eio.Promise.await wait_success in + redirect () diff --git a/template.distillery/tools!dune b/template.distillery/tools!dune index dce4adbe..b666c362 100644 --- a/template.distillery/tools!dune +++ b/template.distillery/tools!dune @@ -2,7 +2,7 @@ (name eliom_ppx_client) (modes native) (modules eliom_ppx_client) - (libraries ocsigen-ppx-rpc eliom.ppx.client)) + (libraries ocsigen-ppx-rpc eliom.ppx.client)) (rule (action (with-stdout-to eliom_ppx_client.ml