diff --git a/src/os_comet.eliom b/src/os_comet.eliom index ba4c61f6..10651a31 100644 --- a/src/os_comet.eliom +++ b/src/os_comet.eliom @@ -86,8 +86,10 @@ let already_send_ref = let%client handle_error = ref (fun exn -> - Eliom_lib.Lwt_log.ign_info_f ~exn - "Exception received on Os_comet's monitor channel: "; + Logs.info (fun fmt -> + fmt + ("Exception received on Os_comet's monitor channel: " ^^ "@\n%s") + (Printexc.to_string exn)); restart_process (); Lwt.return_unit) @@ -96,7 +98,7 @@ let%client set_error_handler f = handle_error := f let%client handle_message = function | Error exn -> !handle_error exn | Ok Heartbeat -> - Eliom_lib.Lwt_log.ign_info_f "poum"; + Logs.info (fun fmt -> fmt "poum"); Lwt.return_unit | Ok Connection_changed -> Os_msg.msg ~level:`Err @@ -121,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: *) @@ -136,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 ce840714..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 = Lwt_log.Section.make "os:db" -let ( >>= ) = Lwt.bind +let section = Logs.Src.create "os:db" +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,49 +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 -> - Lwt_log.ign_error_f ~section "postgresql protocol error: %s" msg; - let* () = Lwt_PGOCaml.close db in - Lwt.fail e - | (Unix.Unix_error _ | End_of_file) as e -> - Lwt_log.ign_error_f ~section ~exn:e "unix error"; - let* () = Lwt_PGOCaml.close db in - Lwt.fail e - | Lwt.Canceled as e -> - Lwt_log.ign_error ~section "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. *) - Lwt_log.ign_error ~section "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_msg.eliom b/src/os_msg.eliom index d14c3dca..3524fab0 100644 --- a/src/os_msg.eliom +++ b/src/os_msg.eliom @@ -50,7 +50,7 @@ let%shared if ~%onload then Eliom_client.lwt_onload () else Lwt.return_unit in let msgbox = msgbox () in - Eliom_lib.Lwt_log.ign_info_f "%s" ~%message; + 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; 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 4edabba7..f05003e4 100644 --- a/src/os_session.eliom +++ b/src/os_session.eliom @@ -18,9 +18,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Lwt.Syntax - -let log_section = Lwt_log.Section.make "os:session" +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 let user_indep_session_scope = `Session user_indep_state_hierarchy @@ -33,15 +31,16 @@ 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 -> - Lwt_log.ign_debug ~section:log_section ("handling actions: " ^ name); + Logs.debug ~src:log_section (fun fmt -> + fmt "%s" ("handling actions: " ^ name)); !r arg ) let on_connected_request, connected_request_action = @@ -64,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 @@ -85,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 @@ -110,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 @@ -126,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 -> ( @@ -137,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. *) @@ -150,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 @@ -174,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. @@ -266,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. @@ -314,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 @@ -323,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) @@ -370,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 959d7f46..63a18d90 100644 --- a/src/os_user_view.eliom +++ b/src/os_user_view.eliom @@ -323,7 +323,7 @@ let%shared Lwt.return_unit) (fun exn -> Os_msg.msg ~level:`Err "Error while uploading the picture"; - Eliom_lib.Lwt_log.ign_info_f "%s" ~exn "→ "; + Logs.info (fun fmt -> fmt "→ %s" (Printexc.to_string exn)); Lwt.return_unit)) : _)] :: a) @@ -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}. *) diff --git a/template.distillery/.ocamlformat b/template.distillery/.ocamlformat index ee092cc1..78fc5bfb 100644 --- a/template.distillery/.ocamlformat +++ b/template.distillery/.ocamlformat @@ -1,3 +1,5 @@ +version=0.28.1 +parse-docstrings = false break-cases = fit break-collection-expressions = fit-or-vertical break-fun-decl = wrap diff --git a/template.distillery/PROJECT_NAME.eliom b/template.distillery/PROJECT_NAME.eliom index 7d9371a0..2fb620bb 100644 --- a/template.distillery/PROJECT_NAME.eliom +++ b/template.distillery/PROJECT_NAME.eliom @@ -53,24 +53,19 @@ let%server () = (* Print more debugging information when is in config file (DEBUG = yes in Makefile.options). Example of use: - let section = Lwt_log.Section.make "%%%MODULE_NAME%%%:sectionname" + let section = Logs.Src.create "%%%MODULE_NAME%%%:sectionname" ... - Lwt_log.ign_info ~section "This is an information"; - (or ign_debug, ign_warning, ign_error etc.) + Logs.info ~src:section (fun fmt -> "This is an information %i " 1); + (or Logs.debug, Logs.err etc.) *) let%server _ = if Eliom_config.get_debugmode () then ( - ignore +(* ignore [%client - ((* Eliom_config.debug_timings := true; *) - (* Lwt_log_core.add_rule "eliom:client*" Lwt_log_js.Debug; *) - (* Lwt_log_core.add_rule "os*" Lwt_log_js.Debug; *) - Lwt_log_core.add_rule "%%%MODULE_NAME%%%*" Lwt_log_js.Debug - (* Lwt_log_core.add_rule "*" Lwt_log_js.Debug *) - : unit)]; - (* Lwt_log_core.add_rule "*" Lwt_log.Debug *) - Lwt_log_core.add_rule "%%%MODULE_NAME%%%*" Lwt_log.Debug) + (Eliom_config.debug_timings := true + : unit)]; *) + Logs.set_level (Some Logs.Debug)) (* The modules below are all the modules that needs to be explicitely linked-in. *) diff --git a/template.distillery/PROJECT_NAME_mobile.eliom b/template.distillery/PROJECT_NAME_mobile.eliom index e22ecb86..e40f1cbe 100644 --- a/template.distillery/PROJECT_NAME_mobile.eliom +++ b/template.distillery/PROJECT_NAME_mobile.eliom @@ -148,5 +148,4 @@ let _ = debugger console, you can do so by uncommenting the following lines. *) (* let () = Eliom_config.debug_timings := true *) -(* let () = Lwt_log_core.add_rule "eliom:client*" Lwt_log_js.Debug *) -(* let () = Lwt_log_core.add_rule "os*" Lwt_log_js.Debug *) +(* let () = Logs.set_level (Some Logs.Debug) *)