From 29566d9d99ae609f728864ccba1f1845bcd6933d Mon Sep 17 00:00:00 2001 From: Vincent Balat Date: Fri, 14 Nov 2025 16:21:20 +0100 Subject: [PATCH] ocamlformat --- .ocamlformat | 3 +- src/os_comet.eliom | 5 +- src/os_connect_phone.eliom | 26 +- src/os_core_db.ml | 36 +- src/os_date.eliom | 7 +- src/os_db.ml | 6427 +++++++++++++++++++----------------- src/os_db.ppx.ml | 238 +- src/os_fcm_notif.eliom | 10 +- src/os_group.ml | 32 +- src/os_handlers.eliom | 143 +- src/os_lib.eliom | 21 +- src/os_msg.eliom | 8 +- src/os_page.eliom | 40 +- src/os_session.eliom | 79 +- src/os_tips.eliom | 76 +- src/os_user.eliom | 6 +- src/os_user_view.eliom | 218 +- 17 files changed, 4022 insertions(+), 3353 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index a8e76621..78fc5bfb 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,5 @@ -version=0.26.1 +version=0.28.1 +parse-docstrings = false break-cases = fit break-collection-expressions = fit-or-vertical break-fun-decl = wrap diff --git a/src/os_comet.eliom b/src/os_comet.eliom index 8e6ed39d..ba4c61f6 100644 --- a/src/os_comet.eliom +++ b/src/os_comet.eliom @@ -41,12 +41,13 @@ let%client restart_process () = Eliom_client.exit_to ~absolute:false ~service:(Eliom_service.static_dir ()) ["index.html"] () - else if (* If cookies do not work, + else if + (* If cookies do not work, the failed comet is probably due to missing cookies. In that case we do not restart. This happens for example if cookies are deactivated of if the app is running in an iframe and the browser forbids third party cookies. *) - cookies_enabled () + cookies_enabled () then Eliom_client.exit_to ~service:Eliom_service.reload_action () () let%client _ = diff --git a/src/os_connect_phone.eliom b/src/os_connect_phone.eliom index 644e3028..ff854358 100644 --- a/src/os_connect_phone.eliom +++ b/src/os_connect_phone.eliom @@ -19,6 +19,7 @@ *) open%server Lwt.Syntax + type%shared sms_error_core = [`Unknown | `Send | `Limit | `Invalid_number] type%shared sms_error = [`Ownership | sms_error_core] @@ -100,8 +101,8 @@ let%server confirm_code myid code = let%rpc confirm_code_extra myid (code : string) : bool Lwt.t = confirm_code myid code -let%server confirm_code_signup_no_connect ~first_name ~last_name ~code ~password - () +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' -> @@ -114,8 +115,13 @@ let%server confirm_code_signup_no_connect ~first_name ~last_name ~code ~password Lwt.return_some userid | _ -> Lwt.return_none) -let%rpc confirm_code_signup ~(first_name : string) ~(last_name : string) - ~(code : string) ~(password : string) () : bool Lwt.t +let%rpc + confirm_code_signup + ~(first_name : string) + ~(last_name : string) + ~(code : string) + ~(password : string) + () : bool Lwt.t = Lwt.bind (confirm_code_signup_no_connect ~first_name ~last_name ~code ~password ()) @@ -136,7 +142,7 @@ let%rpc confirm_code_recovery (code : string) : bool Lwt.t = | _ -> Lwt.return_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.t = Lwt.catch (fun () -> @@ -144,8 +150,8 @@ let%rpc connect ~(keepmeloggedin : bool) ~(password : string) (number : string) 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) + | 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) diff --git a/src/os_core_db.ml b/src/os_core_db.ml index d65e3771..ce840714 100644 --- a/src/os_core_db.ml +++ b/src/os_core_db.ml @@ -67,8 +67,8 @@ let connect () = Lwt.catch (fun () -> init h) (fun exn -> - let* () = dispose h in - Lwt.fail exn) + let* () = dispose h in + Lwt.fail exn) in Lwt.return h | None -> Lwt.return h @@ -76,8 +76,8 @@ let connect () = let validate db = Lwt.catch (fun () -> - let* () = Lwt_PGOCaml.ping db in - Lwt.return_true) + let* () = Lwt_PGOCaml.ping db in + Lwt.return_true) (fun _ -> Lwt.return_false) let pool : (string, bool) Hashtbl.t Lwt_PGOCaml.t Resource_pool.t ref = @@ -85,8 +85,17 @@ let pool : (string, bool) Hashtbl.t Lwt_PGOCaml.t Resource_pool.t ref = let set_pool_size n = pool := Resource_pool.create n ~validate ~dispose connect -let init ?host ?port ?user ?password ?database ?unix_domain_socket_dir - ?pool_size ?init () = +let init + ?host + ?port + ?user + ?password + ?database + ?unix_domain_socket_dir + ?pool_size + ?init + () + = host_r := host; port_r := port; user_r := user; @@ -98,11 +107,10 @@ let init ?host ?port ?user ?password ?database ?unix_domain_socket_dir 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 Lwt.t) -> 'a Lwt.t} -let connection_wrapper = ref { f = (fun _ f -> f ()) } +let connection_wrapper = ref {f = (fun _ f -> f ())} let set_connection_wrapper f = connection_wrapper := f let use_pool f = @@ -128,10 +136,10 @@ let use_pool f = 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) + 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 -> diff --git a/src/os_date.eliom b/src/os_date.eliom index 6b0cc23a..dcd8f091 100644 --- a/src/os_date.eliom +++ b/src/os_date.eliom @@ -31,10 +31,11 @@ let%client timezone = (* Use Intl API if available. Revert to using the time zone offset otherwise. *) match - if Js.Opt.test Js.Unsafe.global ##. Intl - && Js.Opt.test Js.Unsafe.global ##. Intl ##. DateTimeFormat + if + Js.Opt.test Js.Unsafe.global##.Intl + && Js.Opt.test Js.Unsafe.global##.Intl##.DateTimeFormat then - let f = Js.Unsafe.global ##. Intl ## DateTimeFormat in + let f = Js.Unsafe.global##.Intl##DateTimeFormat in if Js.Opt.test f##.resolvedOptions then let o = f##resolvedOptions in diff --git a/src/os_db.ml b/src/os_db.ml index 339c1901..42c1e8b6 100644 --- a/src/os_db.ml +++ b/src/os_db.ml @@ -1,880 +1,1849 @@ (* GENERATED CODE, DO NOT EDIT! *) open Lwt.Syntax include Os_core_db -exception No_such_resource -exception Wrong_password -exception Password_not_set -exception No_such_user -exception Empty_password -exception Main_email_removal_attempt -exception Account_not_activated -let (>>=) = Lwt.bind -let one f ~success ~fail q = - (f q) >>= (function | r::_ -> success r | _ -> fail) + +exception No_such_resource +exception Wrong_password +exception Password_not_set +exception No_such_user +exception Empty_password +exception Main_email_removal_attempt +exception Account_not_activated + +let ( >>= ) = Lwt.bind +let one f ~success ~fail q = f q >>= function r :: _ -> success r | _ -> fail + let pwd_crypt_ref = ref - ((fun password -> Bcrypt.string_of_hash (Bcrypt.hash password)), - (fun _ -> - fun password1 -> - fun password2 -> - Bcrypt.verify password1 (Bcrypt.hash_of_string password2))) -module Email = - struct - let available email = - one without_transaction ~success:(fun _ -> Lwt.return_false) - ~fail:Lwt.return_true + ( (fun password -> Bcrypt.string_of_hash (Bcrypt.hash password)) + , fun _ -> + fun password1 -> + fun password2 -> + Bcrypt.verify password1 (Bcrypt.hash_of_string password2) ) + +module Email = struct + let available email = + one without_transaction + ~success:(fun _ -> Lwt.return_false) + ~fail:Lwt.return_true + (fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_string) + email) ] ] + in + let split = + [ `Text + "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 + 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\n FROM ocsigen_start.emails\n JOIN ocsigen_start.users USING (userid)\n WHERE email = $email" + 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))) +end + +module User = struct + exception Invalid_action_link_key of Os_types.User.id + + let userid_of_email email = + one without_transaction + ~success:(fun userid -> Lwt.return userid) + ~fail:(Lwt.fail No_such_resource) + (fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_string) + email) ] ] + in + let split = + [ `Text + "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 + 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\n FROM ocsigen_start.users JOIN ocsigen_start.emails USING (userid)\n WHERE email = $email" + 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))) + + 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) + + let is_email_validated userid email = + one without_transaction + ~success:(fun _ -> Lwt.return_true) + ~fail:Lwt.return_false + (fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] + ; [ Some + ((let open PGOCaml in + string_of_string) + email) ] ] + in + let split = + [ `Text + "SELECT 1 FROM ocsigen_start.emails\n WHERE userid = " + ; `Var ("userid", false, false) + ; `Text " AND email = " + ; `Var ("email", false, false) + ; `Text " AND validated" ] + 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.emails\n WHERE userid = $userid AND email = $email AND validated" + 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))) + + let set_email_validated userid email = + without_transaction @@ fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] + ; [ Some + ((let open PGOCaml in + string_of_string) + email) ] ] + in + let split = + [ `Text + "UPDATE ocsigen_start.emails SET validated = true\n WHERE userid = " + ; `Var ("userid", false, false) + ; `Text " AND email = " + ; `Var ("email", 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 add_actionlinkkey + ?(autoconnect = false) + ?(action = `AccountActivation) + ?(data = "") + ?(validity = 1L) + ?expiry + ~act_key + ~userid + ~email + () + = + let action = + match action with + | `AccountActivation -> "activation" + | `PasswordReset -> "passwordreset" + | `Custom s -> s + in + without_transaction @@ fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] + ; [ Some + ((let open PGOCaml in + string_of_string) + email) ] + ; [ Some + ((let open PGOCaml in + string_of_string) + action) ] + ; [ Some + ((let open PGOCaml in + string_of_bool) + autoconnect) ] + ; [ Some + ((let open PGOCaml in + string_of_string) + data) ] + ; [ Some + ((let open PGOCaml in + string_of_int64) + validity) ] + ; [ Some + ((let open PGOCaml in + string_of_string) + act_key) ] + ; [ PGOCaml_aux.Option.map + (let open PGOCaml in + string_of_timestamp) + expiry ] ] + in + let split = + [ `Text + "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) + ; `Text ", " + ; `Var ("action", false, false) + ; `Text ", " + ; `Var ("autoconnect", false, false) + ; `Text ", " + ; `Var ("data", false, false) + ; `Text ",\n " + ; `Var ("validity", false, false) + ; `Text ", " + ; `Var ("act_key", false, false) + ; `Text ", " + ; `Var ("expiry", false, true) + ; `Text ")" ] + 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 add_preregister email = + without_transaction @@ fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_string) + email) ] ] + in + let split = + [ `Text "INSERT INTO ocsigen_start.preregister (email) VALUES (" + ; `Var ("email", false, false) + ; `Text ")" ] + 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 remove_preregister0 dbh email = + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_string) + email) ] ] + in + let split = + [ `Text "DELETE FROM ocsigen_start.preregister WHERE email = " + ; `Var ("email", 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 remove_preregister email = + without_transaction @@ fun dbh -> remove_preregister0 dbh email + + let is_preregistered email = + one without_transaction + ~success:(fun _ -> Lwt.return_true) + ~fail:Lwt.return_false + (fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_string) + email) ] ] + in + let split = + [ `Text "SELECT 1 FROM ocsigen_start.preregister WHERE email = " + ; `Var ("email", 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.preregister WHERE email = $email" + 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))) + + let all ?(limit = 10L) () = + without_transaction @@ fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_int64) + limit) ] ] + in + let split = + [ `Text "SELECT email FROM ocsigen_start.preregister LIMIT " + ; `Var ("limit", 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 email FROM ocsigen_start.preregister LIMIT $limit" + in + List.rev_map + (fun row -> + match row with + | c0 :: [] -> + (let open PGOCaml in + string_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)) + + let create ?password ?avatar ?language ?email ~firstname ~lastname () = + if password = Some "" + then Lwt.fail_with "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 + 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))) + (function userid :: [] -> Lwt.return userid | _ -> assert false) + in + let* () = + match email with + | Some email -> + let* () = + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_string) + email) ] + ; [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] ] + in + let split = + [ `Text + "INSERT INTO ocsigen_start.emails (email, userid)\n VALUES (" + ; `Var ("email", false, false) + ; `Text ", " + ; `Var ("userid", false, false) + ; `Text ")" ] + 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 ()) + in + remove_preregister0 dbh email + | None -> Lwt.return_unit + in + Lwt.return userid) + + let update ?password ?avatar ?language ~firstname ~lastname userid = + if password = Some "" + then Lwt.fail_with "empty password" + else + let password = + match password with + | Some password -> Some (fst !pwd_crypt_ref password) + | None -> None + in + without_transaction @@ fun dbh -> + 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) + password ] + ; [ PGOCaml_aux.Option.map + (let open PGOCaml in + string_of_string) + avatar ] + ; [ PGOCaml_aux.Option.map + (let open PGOCaml in + string_of_string) + language ] + ; [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] ] + in + let split = + [ `Text "UPDATE ocsigen_start.users\n SET firstname = " + ; `Var ("firstname", false, false) + ; `Text ",\n lastname = " + ; `Var ("lastname", false, false) + ; `Text ",\n password = COALESCE(" + ; `Var ("password", false, true) + ; `Text ", password),\n avatar = COALESCE(" + ; `Var ("avatar", false, true) + ; `Text ", avatar),\n language = COALESCE(" + ; `Var ("language", false, true) + ; `Text ", language)\n WHERE userid = " + ; `Var ("userid", 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 update_password ~userid ~password = + if password = "" + then Lwt.fail_with "empty password" + else + let password = fst !pwd_crypt_ref password in + without_transaction @@ fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_string) + password) ] + ; [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] ] + in + let split = + [ `Text "UPDATE ocsigen_start.users SET password = " + ; `Var ("password", false, false) + ; `Text "\n WHERE userid = " + ; `Var ("userid", 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 update_avatar ~userid ~avatar = + without_transaction @@ fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_string) + avatar) ] + ; [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] ] + in + let split = + [ `Text "UPDATE ocsigen_start.users SET avatar = " + ; `Var ("avatar", false, false) + ; `Text "\n WHERE userid = " + ; `Var ("userid", 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 update_main_email ~userid ~email = + without_transaction @@ fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_string) + email) ] + ; [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] ] + in + let split = + [ `Text + "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) + ; `Text "\n AND e.userid = u.userid AND e.validated" ] + 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 update_language ~userid ~language = + without_transaction @@ fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_string) + language) ] + ; [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] ] + in + let split = + [ `Text "UPDATE ocsigen_start.users SET language = " + ; `Var ("language", false, false) + ; `Text "\n WHERE userid = " + ; `Var ("userid", 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 verify_password ~email ~password = + if password = "" + then Lwt.fail Empty_password + else + one without_transaction (fun dbh -> PGOCaml.bind (let dbh = dbh in let params : string option list list = - [[Some (((let open PGOCaml in string_of_string)) email)]] in + [ [ Some + ((let open PGOCaml in + string_of_string) + email) ] ] + in let split = - [`Text - "SELECT 1\n FROM ocsigen_start.emails\n JOIN ocsigen_start.users USING (userid)\n WHERE email = "; - `Var ("email", false, false)] in + [ `Text + "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 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 + | `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 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 + 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 ()) + 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\n FROM ocsigen_start.emails\n JOIN ocsigen_start.users USING (userid)\n WHERE email = $email" in + "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 -> match row with - | c0::[] -> - PGOCaml_aux.Option.map - (let open PGOCaml in int32_of_string) c0 + | [c0; c1; c2] -> + ( (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\"") + , PGOCaml_aux.Option.map + (let open PGOCaml in + string_of_string) + c1 + , (let open PGOCaml in + bool_of_string) + (try PGOCaml_aux.Option.get c2 + 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))) - end -module User = - struct - exception Invalid_action_link_key of Os_types.User.id - let userid_of_email email = - one without_transaction ~success:(fun userid -> Lwt.return userid) - ~fail:(Lwt.fail No_such_resource) + "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))) + ~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) + + let verify_password_phone ~number ~password = + if password = "" + then Lwt.fail Empty_password + else + one without_transaction (fun dbh -> PGOCaml.bind (let dbh = dbh in let params : string option list list = - [[Some (((let open PGOCaml in string_of_string)) email)]] in + [ [ Some + ((let open PGOCaml in + string_of_string) + number) ] ] + in let split = - [`Text - "SELECT userid\n FROM ocsigen_start.users JOIN ocsigen_start.emails USING (userid)\n WHERE email = "; - `Var ("email", false, false)] in + [ `Text + "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 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 + | `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 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 + 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 ()) + 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\n FROM ocsigen_start.users JOIN ocsigen_start.emails USING (userid)\n WHERE email = $email" in + "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 -> match row with - | c0::[] -> - (let open PGOCaml in int64_of_string) - (try PGOCaml_aux.Option.get c0 - with - | _ -> + | [c0; c1] -> + ( (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\"") + , PGOCaml_aux.Option.map + (let open PGOCaml in + string_of_string) + c1 ) | _ -> 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))) - 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) - let is_email_validated userid email = - one without_transaction ~success:(fun _ -> Lwt.return_true) - ~fail:Lwt.return_false + "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))) + ~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) + + 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) + (fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] ] + in + let split = + [ `Text + "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 + 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, firstname, lastname, avatar,\n password IS NOT NULL, language\n FROM ocsigen_start.users WHERE userid = $userid" + in + List.rev_map + (fun row -> + match row with + | [c0; c1; c2; c3; c4; c5] -> + ( (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 open PGOCaml in + string_of_string) + (try PGOCaml_aux.Option.get c1 + with _ -> + failwith + "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"") + , (let open PGOCaml in + string_of_string) + (try PGOCaml_aux.Option.get c2 + with _ -> + failwith + "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"") + , PGOCaml_aux.Option.map + (let open PGOCaml in + string_of_string) + c3 + , PGOCaml_aux.Option.map + (let open PGOCaml in + bool_of_string) + c4 + , PGOCaml_aux.Option.map + (let open PGOCaml in + string_of_string) + c5 ) + | _ -> + 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))) + + let get_actionlinkkey_info act_key = + full_transaction_block (fun dbh -> + one + (fun q -> q dbh) + ~fail:(Lwt.fail No_such_resource) (fun dbh -> PGOCaml.bind (let dbh = dbh in let params : string option list list = - [[Some (((let open PGOCaml in string_of_int64)) userid)]; - [Some (((let open PGOCaml in string_of_string)) email)]] in + [ [ Some + ((let open PGOCaml in + string_of_string) + act_key) ] ] + in let split = - [`Text - "SELECT 1 FROM ocsigen_start.emails\n WHERE userid = "; - `Var ("userid", false, false); - `Text " AND email = "; - `Var ("email", false, false); - `Text " AND validated"] in + [ `Text + "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 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 + | `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 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 + 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 ()) + 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.emails\n WHERE userid = $userid AND email = $email AND validated" in + "SELECT userid, email, validity, expiry, autoconnect, action, data\n FROM ocsigen_start.activation\n WHERE activationkey = $act_key" + in List.rev_map (fun row -> match row with - | c0::[] -> - PGOCaml_aux.Option.map - (let open PGOCaml in int32_of_string) c0 + | [c0; c1; c2; c3; c4; c5; c6] -> + ( (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 open PGOCaml in + string_of_string) + (try PGOCaml_aux.Option.get c1 + with _ -> + failwith + "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"") + , (let open PGOCaml in + int64_of_string) + (try PGOCaml_aux.Option.get c2 + with _ -> + failwith + "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"") + , PGOCaml_aux.Option.map + (let open PGOCaml in + timestamp_of_string) + c3 + , (let open PGOCaml in + bool_of_string) + (try PGOCaml_aux.Option.get c4 + with _ -> + failwith + "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"") + , (let open PGOCaml in + string_of_string) + (try PGOCaml_aux.Option.get c5 + with _ -> + failwith + "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"") + , (let open PGOCaml in + string_of_string) + (try PGOCaml_aux.Option.get c6 + 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))) - let set_email_validated userid email = - without_transaction @@ - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_int64)) userid)]; - [Some (((let open PGOCaml in string_of_string)) email)]] in - let split = - [`Text - "UPDATE ocsigen_start.emails SET validated = true\n WHERE userid = "; - `Var ("userid", false, false); - `Text " AND email = "; - `Var ("email", 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 add_actionlinkkey ?(autoconnect= false) ?(action= - `AccountActivation) ?(data= "") ?(validity= 1L) ?expiry ~act_key - ~userid ~email () = - let action = - match action with - | `AccountActivation -> "activation" - | `PasswordReset -> "passwordreset" - | `Custom s -> s in - without_transaction @@ - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_int64)) userid)]; - [Some (((let open PGOCaml in string_of_string)) email)]; - [Some (((let open PGOCaml in string_of_string)) action)]; - [Some (((let open PGOCaml in string_of_bool)) autoconnect)]; - [Some (((let open PGOCaml in string_of_string)) data)]; - [Some (((let open PGOCaml in string_of_int64)) validity)]; - [Some (((let open PGOCaml in string_of_string)) act_key)]; - [PGOCaml_aux.Option.map - (let open PGOCaml in string_of_timestamp) expiry]] in - let split = - [`Text - "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); - `Text ", "; - `Var ("action", false, false); - `Text ", "; - `Var ("autoconnect", false, false); - `Text ", "; - `Var ("data", false, false); - `Text ",\n "; - `Var ("validity", false, false); - `Text ", "; - `Var ("act_key", false, false); - `Text ", "; - `Var ("expiry", false, true); - `Text ")"] 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 add_preregister email = - without_transaction @@ - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_string)) email)]] in - let split = - [`Text - "INSERT INTO ocsigen_start.preregister (email) VALUES ("; - `Var ("email", false, false); - `Text ")"] 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 remove_preregister0 dbh email = - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_string)) email)]] in - let split = - [`Text "DELETE FROM ocsigen_start.preregister WHERE email = "; - `Var ("email", 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 + "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))) + ~success: + (fun + (userid, email, validity, expiry, autoconnect, action, data) -> + let action = + match action with + | "activation" -> `AccountActivation + | "passwordreset" -> `PasswordReset + | c -> `Custom c + in + let v = max 0L (Int64.pred validity) in + let* () = + if v = 0L 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 remove_preregister email = - without_transaction @@ (fun dbh -> remove_preregister0 dbh email) - let is_preregistered email = - one without_transaction ~success:(fun _ -> Lwt.return_true) - ~fail:Lwt.return_false - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_string)) email)]] in - let split = - [`Text - "SELECT 1 FROM ocsigen_start.preregister WHERE email = "; - `Var ("email", 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.preregister WHERE email = $email" 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))) - let all ?(limit= 10L) () = - without_transaction @@ - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_int64)) limit)]] in - let split = - [`Text "SELECT email FROM ocsigen_start.preregister LIMIT "; - `Var ("limit", 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 email FROM ocsigen_start.preregister LIMIT $limit" in - List.rev_map - (fun row -> - match row with - | c0::[] -> - (let open PGOCaml in string_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))) - let create ?password ?avatar ?language ?email ~firstname ~lastname - () = - if password = (Some "") - then Lwt.fail_with "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 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))) - (function - | userid::[] -> Lwt.return userid - | _ -> assert false) - in - let* () = - match email with - | Some email -> - let* () = - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some - (((let open PGOCaml in string_of_string)) email)]; - [Some - (((let open PGOCaml in string_of_int64)) userid)]] in - let split = - [`Text - "INSERT INTO ocsigen_start.emails (email, userid)\n VALUES ("; - `Var ("email", false, false); - `Text ", "; - `Var ("userid", false, false); - `Text ")"] 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 ()) - in remove_preregister0 dbh email - | None -> Lwt.return_unit - in Lwt.return userid) - let update ?password ?avatar ?language ~firstname ~lastname userid = - if password = (Some "") - then Lwt.fail_with "empty password" - else - (let password = - match password with - | Some password -> Some (fst (!pwd_crypt_ref) password) - | None -> None in - without_transaction @@ - (fun dbh -> 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) password]; - [PGOCaml_aux.Option.map - (let open PGOCaml in string_of_string) avatar]; - [PGOCaml_aux.Option.map - (let open PGOCaml in string_of_string) language]; - [Some (((let open PGOCaml in string_of_int64)) userid)]] in + [ [ Some + ((let open PGOCaml in + string_of_string) + act_key) ] ] + in let split = - [`Text - "UPDATE ocsigen_start.users\n SET firstname = "; - `Var ("firstname", false, false); - `Text ",\n lastname = "; - `Var ("lastname", false, false); - `Text ",\n password = COALESCE("; - `Var ("password", false, true); - `Text ", password),\n avatar = COALESCE("; - `Var ("avatar", false, true); - `Text ", avatar),\n language = COALESCE("; - `Var ("language", false, true); - `Text ", language)\n WHERE userid = "; - `Var ("userid", false, false)] in + [ `Text + "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 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 + | `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 + "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 + 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 @@ -884,55 +1853,62 @@ module User = Hashtbl.add hash name true; PGOCaml.return ()) else PGOCaml.return ()) (fun () -> PGOCaml.execute_rev dbh ~name ~params ())) - (fun _rows -> PGOCaml.return ()))) - let update_password ~userid ~password = - if password = "" - then Lwt.fail_with "empty password" - else - (let password = fst (!pwd_crypt_ref) password in - without_transaction @@ - (fun dbh -> + (fun _rows -> PGOCaml.return ()) + else PGOCaml.bind (let dbh = dbh in let params : string option list list = - [[Some (((let open PGOCaml in string_of_string)) password)]; - [Some (((let open PGOCaml in string_of_int64)) userid)]] in + [ [ Some + ((let open PGOCaml in + string_of_int64) + v) ] + ; [ Some + ((let open PGOCaml in + string_of_string) + act_key) ] ] + in let split = - [`Text "UPDATE ocsigen_start.users SET password = "; - `Var ("password", false, false); - `Text "\n WHERE userid = "; - `Var ("userid", false, false)] in + [ `Text + "UPDATE ocsigen_start.activation\n SET validity = " + ; `Var ("v", false, false) + ; `Text " WHERE activationkey = " + ; `Var ("act_key", 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 + | `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 + "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 + 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 @@ -942,2194 +1918,1711 @@ module User = Hashtbl.add hash name true; PGOCaml.return ()) else PGOCaml.return ()) (fun () -> PGOCaml.execute_rev dbh ~name ~params ())) - (fun _rows -> PGOCaml.return ()))) - let update_avatar ~userid ~avatar = - without_transaction @@ - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_string)) avatar)]; - [Some (((let open PGOCaml in string_of_int64)) userid)]] in - let split = - [`Text "UPDATE ocsigen_start.users SET avatar = "; - `Var ("avatar", false, false); - `Text "\n WHERE userid = "; - `Var ("userid", 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 "," + (fun _rows -> PGOCaml.return ()) + in + Lwt.return + (let open Os_types.Action_link_key in + {userid; email; validity; expiry; action; data; autoconnect}))) + + let emails_of_userid userid = + without_transaction @@ fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] ] + in + let split = + [ `Text "SELECT email FROM ocsigen_start.emails WHERE userid = " + ; `Var ("userid", 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 email FROM ocsigen_start.emails WHERE userid = $userid" + in + List.rev_map + (fun row -> + match row with + | c0 :: [] -> + (let open PGOCaml in + string_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)) + + let emails_of_userid_with_status userid = + without_transaction @@ fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] ] + in + let split = + [ `Text + "SELECT email, validated\n FROM ocsigen_start.emails WHERE userid = " + ; `Var ("userid", 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 email, validated\n FROM ocsigen_start.emails WHERE userid = $userid" + in + List.rev_map + (fun row -> + match row with + | [c0; c1] -> + ( (let open PGOCaml in + string_of_string) + (try PGOCaml_aux.Option.get c0 + with _ -> + failwith + "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"") + , (let open PGOCaml in + bool_of_string) + (try PGOCaml_aux.Option.get c1 + 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)) + + let email_of_userid userid = + one without_transaction + ~success:(fun main_email -> Lwt.return main_email) + ~fail:(Lwt.fail No_such_resource) + (fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] ] + in + let split = + [ `Text + "SELECT main_email FROM ocsigen_start.users WHERE userid = " + ; `Var ("userid", 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 main_email FROM ocsigen_start.users WHERE userid = $userid" + in + List.rev_map + (fun row -> + match row with + | c0 :: [] -> + PGOCaml_aux.Option.map + (let open PGOCaml in + string_of_string) + c0 + | _ -> + let msg = + "ppx_pgsql: internal error: " + ^ "Incorrect number of columns returned from query: " + ^ original_query ^ ". Columns are: " + ^ 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 update_main_email ~userid ~email = - without_transaction @@ - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_string)) email)]; - [Some (((let open PGOCaml in string_of_int64)) userid)]] in - let split = - [`Text - "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); - `Text "\n AND e.userid = u.userid AND e.validated"] 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 "," + (function + | Some str -> Printf.sprintf "%S" str + | None -> "NULL") + row) + in + raise (PGOCaml.Error msg)) + _rows))) + + let is_main_email ~userid ~email = + one without_transaction + ~success:(fun _ -> Lwt.return_true) + ~fail:Lwt.return_false + (fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] + ; [ Some + ((let open PGOCaml in + string_of_string) + email) ] ] + in + let split = + [ `Text + "SELECT 1 FROM ocsigen_start.users\n WHERE userid = " + ; `Var ("userid", false, false) + ; `Text " AND main_email = " + ; `Var ("email", 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.users\n WHERE userid = $userid AND main_email = $email" + 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 - (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 update_language ~userid ~language = - without_transaction @@ - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_string)) language)]; - [Some (((let open PGOCaml in string_of_int64)) userid)]] in - let split = - [`Text "UPDATE ocsigen_start.users SET language = "; - `Var ("language", false, false); - `Text "\n WHERE userid = "; - `Var ("userid", 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 "," + (function + | Some str -> Printf.sprintf "%S" str + | None -> "NULL") + row) + in + raise (PGOCaml.Error msg)) + _rows))) + + let add_email_to_user ~userid ~email = + without_transaction @@ fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_string) + email) ] + ; [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] ] + in + let split = + [ `Text + "INSERT INTO ocsigen_start.emails (email, userid)\n VALUES (" + ; `Var ("email", false, false) + ; `Text ", " + ; `Var ("userid", false, false) + ; `Text ")" ] + 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 remove_email_from_user ~userid ~email = + let* b = is_main_email ~userid ~email in + if b + then Lwt.fail Main_email_removal_attempt + else + without_transaction @@ fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] + ; [ Some + ((let open PGOCaml in + string_of_string) + email) ] ] + in + let split = + [ `Text "DELETE FROM ocsigen_start.emails\n WHERE userid = " + ; `Var ("userid", false, false) + ; `Text " AND email = " + ; `Var ("email", 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 get_language userid = + one without_transaction + ~success:(fun language -> Lwt.return language) + ~fail:(Lwt.fail No_such_resource) + (fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] ] + in + let split = + [ `Text "SELECT language FROM ocsigen_start.users WHERE userid = " + ; `Var ("userid", 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 language FROM ocsigen_start.users WHERE userid = $userid" + in + List.rev_map + (fun row -> + match row with + | c0 :: [] -> + PGOCaml_aux.Option.map + (let open PGOCaml in + string_of_string) + c0 + | _ -> + let msg = + "ppx_pgsql: internal error: " + ^ "Incorrect number of columns returned from query: " + ^ original_query ^ ". Columns are: " + ^ 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 verify_password ~email ~password = - if password = "" - then Lwt.fail Empty_password - else - one without_transaction - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_string)) email)]] in - let split = - [`Text - "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 - let j = ref 0 in - let query = - String.concat "" - (List.map - (function + (function + | Some str -> Printf.sprintf "%S" str + | None -> "NULL") + row) + in + raise (PGOCaml.Error msg)) + _rows))) + + let get_users ?pattern () = + let* l = + without_transaction (fun dbh -> + match pattern with + | None -> + PGOCaml.bind + (let dbh = dbh in + 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" + ] + 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) + "$" ^ 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, password, validated\n FROM ocsigen_start.users\n JOIN ocsigen_start.emails USING (userid)\n WHERE email = $email" in - List.rev_map - (fun row -> - match row with - | c0::c1::c2::[] -> - (((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\"")), - (PGOCaml_aux.Option.map - (let open PGOCaml in string_of_string) c1), - ((let open PGOCaml in bool_of_string) - (try PGOCaml_aux.Option.get c2 - 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))) - ~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) - let verify_password_phone ~number ~password = - if password = "" - then Lwt.fail Empty_password - else - one 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, 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 - let j = ref 0 in - let query = - String.concat "" - (List.map - (function + "(" + ^ 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, firstname, lastname, avatar,\n password IS NOT NULL, language\n FROM ocsigen_start.users" + in + List.rev_map + (fun row -> + match row with + | [c0; c1; c2; c3; c4; c5] -> + ( (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 open PGOCaml in + string_of_string) + (try PGOCaml_aux.Option.get c1 + with _ -> + failwith + "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"") + , (let open PGOCaml in + string_of_string) + (try PGOCaml_aux.Option.get c2 + with _ -> + failwith + "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"") + , PGOCaml_aux.Option.map + (let open PGOCaml in + string_of_string) + c3 + , PGOCaml_aux.Option.map + (let open PGOCaml in + bool_of_string) + c4 + , PGOCaml_aux.Option.map + (let open PGOCaml in + string_of_string) + c5 ) + | _ -> + 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)) + | Some pattern -> + let pattern = "(^" ^ pattern ^ ")|(.* " ^ pattern ^ ")" in + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_string) + pattern) ] ] + 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) ~* " + ; `Var ("pattern", 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) + "$" ^ 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, password\n FROM ocsigen_start.users\n JOIN ocsigen_start.phones USING (userid)\n WHERE number = $number" in - List.rev_map - (fun row -> - match row with - | c0::c1::[] -> - (((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\"")), - (PGOCaml_aux.Option.map - (let open PGOCaml in string_of_string) c1)) - | _ -> - 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))) - ~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) - 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) - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_int64)) userid)]] in - let split = - [`Text - "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 - 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 "," + "(" + ^ 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, firstname, lastname, avatar,\n password IS NOT NULL, language\n FROM ocsigen_start.users WHERE userid = $userid" in - List.rev_map - (fun row -> - match row with - | c0::c1::c2::c3::c4::c5::[] -> - (((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 open PGOCaml in string_of_string) + "$" ^ 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, 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 -> + match row with + | [c0; c1; c2; c3; c4; c5] -> + ( (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 open PGOCaml in + string_of_string) (try PGOCaml_aux.Option.get c1 - with - | _ -> - failwith - "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"")), - ((let open PGOCaml in string_of_string) + with _ -> + failwith + "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"") + , (let open PGOCaml in + string_of_string) (try PGOCaml_aux.Option.get c2 - with - | _ -> - failwith - "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"")), - (PGOCaml_aux.Option.map - (let open PGOCaml in string_of_string) c3), - (PGOCaml_aux.Option.map - (let open PGOCaml in bool_of_string) c4), - (PGOCaml_aux.Option.map - (let open PGOCaml in string_of_string) c5)) - | _ -> - 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))) - let get_actionlinkkey_info act_key = - full_transaction_block - (fun dbh -> - one (fun q -> q dbh) ~fail:(Lwt.fail No_such_resource) - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some - (((let open PGOCaml in string_of_string)) act_key)]] in - let split = - [`Text - "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 - 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, email, validity, expiry, autoconnect, action, data\n FROM ocsigen_start.activation\n WHERE activationkey = $act_key" in - List.rev_map - (fun row -> - match row with - | c0::c1::c2::c3::c4::c5::c6::[] -> - (((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 open PGOCaml in string_of_string) - (try PGOCaml_aux.Option.get c1 - with - | _ -> - failwith - "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"")), - ((let open PGOCaml in int64_of_string) - (try PGOCaml_aux.Option.get c2 - with - | _ -> - failwith - "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"")), - (PGOCaml_aux.Option.map - (let open PGOCaml in - timestamp_of_string) c3), - ((let open PGOCaml in bool_of_string) - (try PGOCaml_aux.Option.get c4 - with - | _ -> - failwith - "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"")), - ((let open PGOCaml in string_of_string) - (try PGOCaml_aux.Option.get c5 - with - | _ -> - failwith - "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"")), - ((let open PGOCaml in string_of_string) - (try PGOCaml_aux.Option.get c6 - 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))) - ~success:(fun - (userid, email, validity, expiry, autoconnect, - action, data) - -> - let action = - match action with - | "activation" -> `AccountActivation - | "passwordreset" -> `PasswordReset - | c -> `Custom c in - let v = max 0L (Int64.pred validity) in - let* () = - if v = 0L - then - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some - (((let open PGOCaml in string_of_string)) - act_key)]] 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 = "; - `Var ("act_key", 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 ()) - else - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some - (((let open PGOCaml in string_of_int64)) - v)]; - [Some - (((let open PGOCaml in string_of_string)) - act_key)]] in - let split = - [`Text - "UPDATE ocsigen_start.activation\n SET validity = "; - `Var ("v", false, false); - `Text " WHERE activationkey = "; - `Var ("act_key", 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 ()) - in - Lwt.return - (let open Os_types.Action_link_key in - { - userid; - email; - validity; - expiry; - action; - data; - autoconnect - }))) - let emails_of_userid userid = - without_transaction @@ - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_int64)) userid)]] in - let split = - [`Text - "SELECT email FROM ocsigen_start.emails WHERE userid = "; - `Var ("userid", 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 email FROM ocsigen_start.emails WHERE userid = $userid" in - List.rev_map - (fun row -> - match row with - | c0::[] -> - (let open PGOCaml in string_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))) - let emails_of_userid_with_status userid = - without_transaction @@ - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_int64)) userid)]] in - let split = - [`Text - "SELECT email, validated\n FROM ocsigen_start.emails WHERE userid = "; - `Var ("userid", 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 email, validated\n FROM ocsigen_start.emails WHERE userid = $userid" in - List.rev_map - (fun row -> - match row with - | c0::c1::[] -> - (((let open PGOCaml in string_of_string) - (try PGOCaml_aux.Option.get c0 - with - | _ -> - failwith - "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"")), - ((let open PGOCaml in bool_of_string) - (try PGOCaml_aux.Option.get c1 - 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))) - let email_of_userid userid = - one without_transaction - ~success:(fun main_email -> Lwt.return main_email) - ~fail:(Lwt.fail No_such_resource) - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_int64)) userid)]] in - let split = - [`Text - "SELECT main_email FROM ocsigen_start.users WHERE userid = "; - `Var ("userid", 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 main_email FROM ocsigen_start.users WHERE userid = $userid" in - List.rev_map - (fun row -> - match row with - | c0::[] -> - PGOCaml_aux.Option.map - (let open PGOCaml in string_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))) - let is_main_email ~userid ~email = - one without_transaction ~success:(fun _ -> Lwt.return_true) - ~fail:Lwt.return_false - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_int64)) userid)]; - [Some (((let open PGOCaml in string_of_string)) email)]] in - let split = - [`Text - "SELECT 1 FROM ocsigen_start.users\n WHERE userid = "; - `Var ("userid", false, false); - `Text " AND main_email = "; - `Var ("email", 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.users\n WHERE userid = $userid AND main_email = $email" 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))) - let add_email_to_user ~userid ~email = - without_transaction @@ - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_string)) email)]; - [Some (((let open PGOCaml in string_of_int64)) userid)]] in - let split = - [`Text - "INSERT INTO ocsigen_start.emails (email, userid)\n VALUES ("; - `Var ("email", false, false); - `Text ", "; - `Var ("userid", false, false); - `Text ")"] 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 remove_email_from_user ~userid ~email = - let* b = is_main_email ~userid ~email - in - if b - then Lwt.fail Main_email_removal_attempt - else - without_transaction @@ - ((fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_int64)) userid)]; - [Some (((let open PGOCaml in string_of_string)) email)]] in - let split = - [`Text - "DELETE FROM ocsigen_start.emails\n WHERE userid = "; - `Var ("userid", false, false); - `Text " AND email = "; - `Var ("email", 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 "," + with _ -> + failwith + "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"") + , PGOCaml_aux.Option.map + (let open PGOCaml in + string_of_string) + c3 + , PGOCaml_aux.Option.map + (let open PGOCaml in + bool_of_string) + c4 + , PGOCaml_aux.Option.map + (let open PGOCaml in + string_of_string) + c5 ) + | _ -> + let msg = + "ppx_pgsql: internal error: " + ^ "Incorrect number of columns returned from query: " + ^ original_query ^ ". Columns are: " + ^ 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 get_language userid = - one without_transaction ~success:(fun language -> Lwt.return language) - ~fail:(Lwt.fail No_such_resource) - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_int64)) userid)]] in - let split = - [`Text - "SELECT language FROM ocsigen_start.users WHERE userid = "; - `Var ("userid", 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 language FROM ocsigen_start.users WHERE userid = $userid" in - List.rev_map - (fun row -> - match row with - | c0::[] -> - PGOCaml_aux.Option.map - (let open PGOCaml in string_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))) - let get_users ?pattern () = - let* l = - without_transaction - (fun dbh -> - match pattern with - | None -> - PGOCaml.bind - (let dbh = dbh in - 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"] in - let i = ref 0 in - let j = ref 0 in - let query = - String.concat "" + (function + | Some str -> Printf.sprintf "%S" str + | None -> "NULL") + row) + in + 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) +end + +module Groups = struct + let create ?description name = + without_transaction @@ fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ PGOCaml_aux.Option.map + (let open PGOCaml in + string_of_string) + description ] + ; [ Some + ((let open PGOCaml in + string_of_string) + name) ] ] + in + let split = + [ `Text + "INSERT INTO ocsigen_start.groups (description, name)\n VALUES (" + ; `Var ("description", false, true) + ; `Text ", " + ; `Var ("name", false, false) + ; `Text ")\n ON CONFLICT DO NOTHING" ] + 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 - (function - | `Text text -> text - | `Var (_varname, false, _) -> - let () = incr i in + (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 group_of_name name = + without_transaction (fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_string) + name) ] ] + in + let split = + [ `Text + "SELECT groupid, name, description\n FROM ocsigen_start.groups WHERE name = " + ; `Var ("name", 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) - | `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, firstname, lastname, avatar,\n password IS NOT NULL, language\n FROM ocsigen_start.users" in - List.rev_map - (fun row -> - match row with - | c0::c1::c2::c3::c4::c5::[] -> - (((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 open PGOCaml in string_of_string) - (try PGOCaml_aux.Option.get c1 - with - | _ -> - failwith - "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"")), - ((let open PGOCaml in string_of_string) - (try PGOCaml_aux.Option.get c2 - with - | _ -> - failwith - "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"")), - (PGOCaml_aux.Option.map - (let open PGOCaml in string_of_string) - c3), - (PGOCaml_aux.Option.map - (let open PGOCaml in bool_of_string) - c4), - (PGOCaml_aux.Option.map - (let open PGOCaml in string_of_string) - c5)) - | _ -> - 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)) - | Some pattern -> - let pattern = - "(^" ^ (pattern ^ (")|(.* " ^ (pattern ^ ")"))) in - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some - (((let open PGOCaml in string_of_string)) pattern)]] 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) ~* "; - `Var ("pattern", false, false)] in - let i = ref 0 in - let j = ref 0 in - let query = - String.concat "" + "$" ^ 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 groupid, name, description\n FROM ocsigen_start.groups WHERE name = $name" + in + List.rev_map + (fun row -> + match row with + | [c0; c1; c2] -> + ( (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 open PGOCaml in + string_of_string) + (try PGOCaml_aux.Option.get c1 + with _ -> + failwith + "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"") + , PGOCaml_aux.Option.map + (let open PGOCaml in + string_of_string) + c2 ) + | _ -> + 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 + | r :: [] -> Lwt.return r + | _ -> Lwt.fail No_such_resource + + let add_user_in_group ~groupid ~userid = + without_transaction @@ fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] + ; [ Some + ((let open PGOCaml in + string_of_int64) + groupid) ] ] + in + let split = + [ `Text + "INSERT INTO ocsigen_start.user_groups (userid, groupid)\n VALUES (" + ; `Var ("userid", false, false) + ; `Text ", " + ; `Var ("groupid", false, false) + ; `Text ")" ] + 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 - (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, 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 -> - match row with - | c0::c1::c2::c3::c4::c5::[] -> - (((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 open PGOCaml in string_of_string) - (try PGOCaml_aux.Option.get c1 - with - | _ -> - failwith - "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"")), - ((let open PGOCaml in string_of_string) - (try PGOCaml_aux.Option.get c2 - with - | _ -> - failwith - "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"")), - (PGOCaml_aux.Option.map - (let open PGOCaml in string_of_string) - c3), - (PGOCaml_aux.Option.map - (let open PGOCaml in bool_of_string) - c4), - (PGOCaml_aux.Option.map - (let open PGOCaml in string_of_string) - c5)) - | _ -> - 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))) - in - Lwt.return - (List.map - (fun (userid, firstname, lastname, avatar, has_password, language) - -> - (userid, firstname, lastname, avatar, - (has_password = (Some true)), language)) l) - end -module Groups = - struct - let create ?description name = - without_transaction @@ - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[PGOCaml_aux.Option.map - (let open PGOCaml in string_of_string) description]; - [Some (((let open PGOCaml in string_of_string)) name)]] in - let split = - [`Text - "INSERT INTO ocsigen_start.groups (description, name)\n VALUES ("; - `Var ("description", false, true); - `Text ", "; - `Var ("name", false, false); - `Text ")\n ON CONFLICT DO NOTHING"] 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 group_of_name name = - (without_transaction - (fun dbh -> + (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 remove_user_in_group ~groupid ~userid = + without_transaction @@ fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_int64) + groupid) ] + ; [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] ] + in + let split = + [ `Text + "DELETE FROM ocsigen_start.user_groups\n WHERE groupid = " + ; `Var ("groupid", false, false) + ; `Text " AND userid = " + ; `Var ("userid", 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 in_group ?dbh ~groupid ~userid () = + one + (match dbh with + | None -> without_transaction + | Some dbh -> fun f -> f dbh) + ~success:(fun _ -> Lwt.return_true) + ~fail:Lwt.return_false + (fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_int64) + groupid) ] + ; [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] ] + in + let split = + [ `Text + "SELECT 1 FROM ocsigen_start.user_groups\n WHERE groupid = " + ; `Var ("groupid", false, false) + ; `Text " AND userid = " + ; `Var ("userid", 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 - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_string)) name)]] in - let split = - [`Text - "SELECT groupid, name, description\n FROM ocsigen_start.groups WHERE name = "; - `Var ("name", 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 groupid, name, description\n FROM ocsigen_start.groups WHERE name = $name" in - List.rev_map - (fun row -> - match row with - | c0::c1::c2::[] -> - (((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 open PGOCaml in string_of_string) - (try PGOCaml_aux.Option.get c1 - with - | _ -> - failwith - "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"")), - (PGOCaml_aux.Option.map - (let open PGOCaml in string_of_string) c2)) - | _ -> - 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 | r::[] -> Lwt.return r | _ -> Lwt.fail No_such_resource) - let add_user_in_group ~groupid ~userid = - without_transaction @@ - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_int64)) userid)]; - [Some (((let open PGOCaml in string_of_int64)) groupid)]] in - let split = - [`Text - "INSERT INTO ocsigen_start.user_groups (userid, groupid)\n VALUES ("; - `Var ("userid", false, false); - `Text ", "; - `Var ("groupid", false, false); - `Text ")"] 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 remove_user_in_group ~groupid ~userid = - without_transaction @@ - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_int64)) groupid)]; - [Some (((let open PGOCaml in string_of_int64)) userid)]] in - let split = - [`Text - "DELETE FROM ocsigen_start.user_groups\n WHERE groupid = "; - `Var ("groupid", false, false); - `Text " AND userid = "; - `Var ("userid", 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 in_group ?dbh ~groupid ~userid () = - one - (match dbh with - | None -> without_transaction - | Some dbh -> (fun f -> f dbh)) ~success:(fun _ -> Lwt.return_true) - ~fail:Lwt.return_false - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_int64)) groupid)]; - [Some (((let open PGOCaml in string_of_int64)) userid)]] in - let split = - [`Text - "SELECT 1 FROM ocsigen_start.user_groups\n WHERE groupid = "; - `Var ("groupid", false, false); - `Text " AND userid = "; - `Var ("userid", 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.user_groups\n WHERE groupid = $groupid AND userid = $userid" 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))) - let all () = - without_transaction @@ - (fun dbh -> - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = [] in - let split = - [`Text - "SELECT groupid, name, description FROM ocsigen_start.groups"] 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 "," + (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.user_groups\n WHERE groupid = $groupid AND userid = $userid" + 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 - (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 groupid, name, description FROM ocsigen_start.groups" in - List.rev_map - (fun row -> - match row with - | c0::c1::c2::[] -> - (((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 open PGOCaml in string_of_string) - (try PGOCaml_aux.Option.get c1 - with - | _ -> - failwith - "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"")), - (PGOCaml_aux.Option.map - (let open PGOCaml in string_of_string) c2)) - | _ -> - 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))) - end -module Phone = - struct - let add userid number = - without_transaction @@ - (fun dbh -> - let* l = - PGOCaml.bind - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_string)) number)]; - [Some (((let open PGOCaml in string_of_int64)) userid)]] in - let split = - [`Text - "INSERT INTO ocsigen_start.phones (number, userid)\n VALUES ("; - `Var ("number", false, false); - `Text ", "; - `Var ("userid", false, false); - `Text - ")\n ON CONFLICT DO NOTHING\n RETURNING 0"] 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.phones (number, userid)\n VALUES ($number, $userid)\n ON CONFLICT DO NOTHING\n RETURNING 0" 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)) - in Lwt.return (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) - 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) - let delete userid number = - without_transaction @@ - (fun dbh -> + (function + | Some str -> Printf.sprintf "%S" str + | None -> "NULL") + row) + in + raise (PGOCaml.Error msg)) + _rows))) + + let all () = + without_transaction @@ fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = [] in + let split = + [`Text "SELECT groupid, name, description FROM ocsigen_start.groups"] + 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 groupid, name, description FROM ocsigen_start.groups" + in + List.rev_map + (fun row -> + match row with + | [c0; c1; c2] -> + ( (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 open PGOCaml in + string_of_string) + (try PGOCaml_aux.Option.get c1 + with _ -> + failwith + "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"") + , PGOCaml_aux.Option.map + (let open PGOCaml in + string_of_string) + c2 ) + | _ -> + 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)) +end + +module Phone = struct + let add userid number = + without_transaction @@ fun dbh -> + let* l = + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_string) + number) ] + ; [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] ] + in + let split = + [ `Text + "INSERT INTO ocsigen_start.phones (number, userid)\n VALUES (" + ; `Var ("number", false, false) + ; `Text ", " + ; `Var ("userid", false, false) + ; `Text + ")\n ON CONFLICT DO NOTHING\n RETURNING 0" ] + 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.phones (number, userid)\n VALUES ($number, $userid)\n ON CONFLICT DO NOTHING\n RETURNING 0" + 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)) + in + Lwt.return (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 - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_int64)) userid)]; - [Some (((let open PGOCaml in string_of_string)) number)]] in - let split = - [`Text - "DELETE FROM ocsigen_start.phones\n WHERE userid = "; - `Var ("userid", false, false); - `Text " AND 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 get_list userid = - without_transaction @@ - (fun dbh -> + (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) + + 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 - (let dbh = dbh in - let params : string option list list = - [[Some (((let open PGOCaml in string_of_int64)) userid)]] in - let split = - [`Text - "SELECT number FROM ocsigen_start.phones WHERE userid = "; - `Var ("userid", 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 number FROM ocsigen_start.phones WHERE userid = $userid" in - List.rev_map - (fun row -> - match row with - | c0::[] -> - (let open PGOCaml in string_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))) - end + (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) + + let delete userid number = + without_transaction @@ fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] + ; [ Some + ((let open PGOCaml in + string_of_string) + number) ] ] + in + let split = + [ `Text "DELETE FROM ocsigen_start.phones\n WHERE userid = " + ; `Var ("userid", false, false) + ; `Text " AND 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 get_list userid = + without_transaction @@ fun dbh -> + PGOCaml.bind + (let dbh = dbh in + let params : string option list list = + [ [ Some + ((let open PGOCaml in + string_of_int64) + userid) ] ] + in + let split = + [ `Text "SELECT number FROM ocsigen_start.phones WHERE userid = " + ; `Var ("userid", 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 number FROM ocsigen_start.phones WHERE userid = $userid" + in + List.rev_map + (fun row -> + match row with + | c0 :: [] -> + (let open PGOCaml in + string_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)) +end diff --git a/src/os_db.ppx.ml b/src/os_db.ppx.ml index 5bc26cce..e61c5233 100644 --- a/src/os_db.ppx.ml +++ b/src/os_db.ppx.ml @@ -47,9 +47,9 @@ module Email = struct ~success:(fun _ -> Lwt.return_false) ~fail:Lwt.return_true (fun dbh -> - [%pgsql - dbh - "SELECT 1 + [%pgsql + dbh + "SELECT 1 FROM ocsigen_start.emails JOIN ocsigen_start.users USING (userid) WHERE email = $email"]) @@ -63,17 +63,17 @@ module User = struct ~success:(fun userid -> Lwt.return userid) ~fail:(Lwt.fail No_such_resource) (fun dbh -> - [%pgsql - dbh - "SELECT userid + [%pgsql + dbh + "SELECT userid FROM ocsigen_start.users JOIN ocsigen_start.emails USING (userid) WHERE email = $email"]) let is_registered email = Lwt.catch (fun () -> - let* _ = userid_of_email email in - Lwt.return_true) + let* _ = userid_of_email email in + Lwt.return_true) (function No_such_resource -> Lwt.return_false | exc -> Lwt.reraise exc) let is_email_validated userid email = @@ -81,9 +81,9 @@ module User = struct ~success:(fun _ -> Lwt.return_true) ~fail:Lwt.return_false (fun dbh -> - [%pgsql - dbh - "SELECT 1 FROM ocsigen_start.emails + [%pgsql + dbh + "SELECT 1 FROM ocsigen_start.emails WHERE userid = $userid AND email = $email AND validated"]) let set_email_validated userid email = @@ -93,8 +93,17 @@ module User = struct "UPDATE ocsigen_start.emails SET validated = true WHERE userid = $userid AND email = $email"] - let add_actionlinkkey ?(autoconnect = false) ?(action = `AccountActivation) - ?(data = "") ?(validity = 1L) ?expiry ~act_key ~userid ~email () = + let add_actionlinkkey + ?(autoconnect = false) + ?(action = `AccountActivation) + ?(data = "") + ?(validity = 1L) + ?expiry + ~act_key + ~userid + ~email + () + = let action = match action with | `AccountActivation -> "activation" @@ -125,49 +134,47 @@ module User = struct ~success:(fun _ -> Lwt.return_true) ~fail:Lwt.return_false (fun dbh -> - [%pgsql - dbh "SELECT 1 FROM ocsigen_start.preregister WHERE email = $email"]) + [%pgsql + dbh "SELECT 1 FROM ocsigen_start.preregister WHERE email = $email"]) let all ?(limit = 10L) () = without_transaction @@ fun dbh -> [%pgsql dbh "SELECT email FROM ocsigen_start.preregister LIMIT $limit"] let create ?password ?avatar ?language ?email ~firstname ~lastname () = - if password = Some "" then Lwt.fail_with "empty password" + if password = Some "" + then Lwt.fail_with "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 - [%pgsql - dbh - "INSERT INTO ocsigen_start.users\n\ - \ (firstname, lastname, main_email, \ - password, avatar, language)\n\ - \ VALUES ($firstname, $lastname, $?email,\n\ - \ $?password_o, $?avatar, $?language)\n\ - \ RETURNING userid"] (function - | [ userid ] -> Lwt.return userid - | _ -> assert false) - in - let* () = - match email with - | Some email -> - let* () = - [%pgsql - dbh - "INSERT INTO ocsigen_start.emails (email, userid) + let password_o = + Eliom_lib.Option.map (fun p -> fst !pwd_crypt_ref p) password + in + let* userid = + Lwt.bind + [%pgsql + dbh + "INSERT INTO ocsigen_start.users\n\ (firstname, lastname, main_email, password, avatar, language)\n\ VALUES ($firstname, $lastname, $?email,\n\ $?password_o, $?avatar, $?language)\n\ RETURNING userid"] + (function + | [userid] -> Lwt.return userid + | _ -> assert false) + in + let* () = + match email with + | Some email -> + let* () = + [%pgsql + dbh + "INSERT INTO ocsigen_start.emails (email, userid) VALUES ($email, $userid)"] - in - remove_preregister0 dbh email - | None -> Lwt.return_unit - in - Lwt.return userid) + in + remove_preregister0 dbh email + | None -> Lwt.return_unit + in + Lwt.return userid) let update ?password ?avatar ?language ~firstname ~lastname userid = - if password = Some "" then Lwt.fail_with "empty password" + if password = Some "" + then Lwt.fail_with "empty password" else let password = match password with @@ -225,9 +232,9 @@ module User = struct else one without_transaction (fun dbh -> - [%pgsql - dbh - "SELECT userid, password, validated + [%pgsql + dbh + "SELECT userid, password, validated FROM ocsigen_start.users JOIN ocsigen_start.emails USING (userid) WHERE email = $email"]) @@ -238,20 +245,22 @@ module User = struct a password field. *) match password' with | Some password' when snd !pwd_crypt_ref userid password password' -> - if validated then Lwt.return userid + 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) let verify_password_phone ~number ~password = - if password = "" then Lwt.fail Empty_password + if password = "" + then Lwt.fail Empty_password else one without_transaction (fun dbh -> - [%pgsql - dbh - "SELECT userid, password + [%pgsql + dbh + "SELECT userid, password FROM ocsigen_start.users JOIN ocsigen_start.phones USING (userid) WHERE number = $number"]) @@ -277,52 +286,54 @@ module User = struct , language )) ~fail:(Lwt.fail No_such_resource) (fun dbh -> - [%pgsql - dbh - "SELECT userid, firstname, lastname, avatar, + [%pgsql + dbh + "SELECT userid, firstname, lastname, avatar, password IS NOT NULL, language FROM ocsigen_start.users WHERE userid = $userid"]) let get_actionlinkkey_info act_key = full_transaction_block (fun dbh -> - one - (fun q -> q dbh) - ~fail:(Lwt.fail No_such_resource) - (fun dbh -> - [%pgsql - dbh - "SELECT userid, email, validity, expiry, autoconnect, action, data + one + (fun q -> q dbh) + ~fail:(Lwt.fail No_such_resource) + (fun dbh -> + [%pgsql + dbh + "SELECT userid, email, validity, expiry, autoconnect, action, data FROM ocsigen_start.activation WHERE activationkey = $act_key"]) - ~success: - (fun (userid, email, validity, expiry, autoconnect, action, data) -> - let action = - match action with - | "activation" -> `AccountActivation - | "passwordreset" -> `PasswordReset - | c -> `Custom c - in - let v = max 0L (Int64.pred validity) in - let* () = - (* We provide a grace period of 20 seconds before expiring the + ~success: + (fun + (userid, email, validity, expiry, autoconnect, action, data) -> + let action = + match action with + | "activation" -> `AccountActivation + | "passwordreset" -> `PasswordReset + | c -> `Custom c + in + let v = max 0L (Int64.pred validity) in + let* () = + (* We provide a grace period of 20 seconds before expiring the key, in case the link is successively opened several times *) - if v = 0L then - [%pgsql - dbh - "UPDATE ocsigen_start.activation + if v = 0L + then + [%pgsql + dbh + "UPDATE ocsigen_start.activation SET expiry = LEAST(NOW() AT TIME ZONE 'utc' + INTERVAL '20 seconds', expiry) WHERE activationkey = $act_key"] - else - [%pgsql - dbh - "UPDATE ocsigen_start.activation + else + [%pgsql + dbh + "UPDATE ocsigen_start.activation SET validity = $v WHERE activationkey = $act_key"] - in - Lwt.return - Os_types.Action_link_key. - { userid; email; validity; expiry; action; data; autoconnect })) + in + Lwt.return + Os_types.Action_link_key. + {userid; email; validity; expiry; action; data; autoconnect})) let emails_of_userid userid = without_transaction @@ fun dbh -> @@ -340,18 +351,18 @@ module User = struct ~success:(fun main_email -> Lwt.return main_email) ~fail:(Lwt.fail No_such_resource) (fun dbh -> - [%pgsql - dbh - "SELECT main_email FROM ocsigen_start.users WHERE userid = $userid"]) + [%pgsql + dbh + "SELECT main_email FROM ocsigen_start.users WHERE userid = $userid"]) let is_main_email ~userid ~email = one without_transaction ~success:(fun _ -> Lwt.return_true) ~fail:Lwt.return_false (fun dbh -> - [%pgsql - dbh - "SELECT 1 FROM ocsigen_start.users + [%pgsql + dbh + "SELECT 1 FROM ocsigen_start.users WHERE userid = $userid AND main_email = $email"]) let add_email_to_user ~userid ~email = @@ -363,7 +374,8 @@ module User = struct let remove_email_from_user ~userid ~email = let* b = is_main_email ~userid ~email in - if b then Lwt.fail Main_email_removal_attempt + if b + then Lwt.fail Main_email_removal_attempt else without_transaction @@ fun dbh -> [%pgsql @@ -376,24 +388,24 @@ module User = struct ~success:(fun language -> Lwt.return language) ~fail:(Lwt.fail No_such_resource) (fun dbh -> - [%pgsql - dbh "SELECT language FROM ocsigen_start.users WHERE userid = $userid"]) + [%pgsql + dbh "SELECT language FROM ocsigen_start.users WHERE userid = $userid"]) let get_users ?pattern () = let* l = without_transaction (fun dbh -> - match pattern with - | None -> - [%pgsql - dbh - "SELECT userid, firstname, lastname, avatar, + match pattern with + | None -> + [%pgsql + dbh + "SELECT userid, firstname, lastname, avatar, password IS NOT NULL, language FROM ocsigen_start.users"] - | Some pattern -> - let pattern = "(^" ^ pattern ^ ")|(.* " ^ pattern ^ ")" in - [%pgsql - dbh - "SELECT userid, firstname, lastname, avatar, + | Some pattern -> + let pattern = "(^" ^ pattern ^ ")|(.* " ^ pattern ^ ")" in + [%pgsql + dbh + "SELECT userid, firstname, lastname, avatar, password IS NOT NULL, language FROM ocsigen_start.users WHERE firstname <> '' -- avoids email addresses @@ -422,12 +434,12 @@ module Groups = struct let group_of_name name = without_transaction (fun dbh -> - [%pgsql - dbh - "SELECT groupid, name, description + [%pgsql + dbh + "SELECT groupid, name, description FROM ocsigen_start.groups WHERE name = $name"]) >>= function - | [ r ] -> Lwt.return r + | [r] -> Lwt.return r | _ -> Lwt.fail No_such_resource let add_user_in_group ~groupid ~userid = @@ -452,9 +464,9 @@ module Groups = struct ~success:(fun _ -> Lwt.return_true) ~fail:Lwt.return_false (fun dbh -> - [%pgsql - dbh - "SELECT 1 FROM ocsigen_start.user_groups + [%pgsql + dbh + "SELECT 1 FROM ocsigen_start.user_groups WHERE groupid = $groupid AND userid = $userid"]) let all () = @@ -473,7 +485,7 @@ module Phone = struct ON CONFLICT DO NOTHING RETURNING 0"] in - Lwt.return (match l with [ _ ] -> true | _ -> false) + Lwt.return (match l with [_] -> true | _ -> false) let exists number = Lwt.bind diff --git a/src/os_fcm_notif.eliom b/src/os_fcm_notif.eliom index 4d7f54b0..2820601a 100644 --- a/src/os_fcm_notif.eliom +++ b/src/os_fcm_notif.eliom @@ -353,13 +353,13 @@ module Response = struct 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 + (* 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 _ -> + Lwt.fail + (FCM_no_json_response "It could come from your server key.") + | exc -> Lwt.reraise exc) let multicast_id_of_t response = response.multicast_id let success_of_t response = response.success diff --git a/src/os_group.ml b/src/os_group.ml index b212d254..b44da362 100644 --- a/src/os_group.ml +++ b/src/os_group.ml @@ -24,12 +24,12 @@ exception No_such_group type id = Os_types.Group.id [@@deriving json] -type t = Os_types.Group.t = { id : id; name : string; desc : string option } +type t = Os_types.Group.t = {id : id; name : string; desc : string option} [@@deriving json] (** Create a group of type [Os_types.Group.t] using db information. *) let create_group_from_db (groupid, name, description) : Os_types.Group.t = - { id = groupid; name; desc = description } + {id = groupid; name; desc = description} let id_of_group (g : Os_types.Group.t) = g.id let name_of_group (g : Os_types.Group.t) = g.name @@ -38,20 +38,20 @@ let desc_of_group (g : Os_types.Group.t) = g.desc (* Using cache tools to prevent multiple same database queries during the request. *) module MCache = Os_request_cache.Make (struct - type key = string - type value = Os_types.Group.t + type key = string + type value = Os_types.Group.t - let compare = compare + 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) -end) + 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) + end) (** Helper function which creates a new group and return it as * a record of type [Os_types.Group.t]. *) @@ -67,8 +67,8 @@ let create ?description name = let* () = Os_db.Groups.create ?description name in Lwt.catch (fun () -> - let* g = group_of_name name in - Lwt.return g) + 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) diff --git a/src/os_handlers.eliom b/src/os_handlers.eliom index 62d5bd13..cdcde01b 100644 --- a/src/os_handlers.eliom +++ b/src/os_handlers.eliom @@ -31,8 +31,11 @@ let%client storage () = (fun v -> v) (* Set personal data *) -let%server set_personal_data_handler myid () - (((firstname, lastname), (pwd, pwd2)) as pd) +let%server + set_personal_data_handler + myid + () + (((firstname, lastname), (pwd, pwd2)) as pd) = if firstname = "" || lastname = "" || pwd <> pwd2 then ( @@ -58,9 +61,13 @@ let%server set_password_handler myid () (pwd, pwd2) = let%rpc set_password_rpc myid (p : string * string) : unit Lwt.t = set_password_handler myid () p -let%server generate_action_link_key - ?(act_key = Ocsigen_lib.make_cryptographic_safe_string ()) - ?(send_email = true) ~service ~text email +let%server + generate_action_link_key + ?(act_key = Ocsigen_lib.make_cryptographic_safe_string ()) + ?(send_email = true) + ~service + ~text + email = let service = Eliom_service.attach ~fallback:service @@ -84,8 +91,16 @@ let%server generate_action_link_key act_key (** For default value of [autoconnect], cf. [Os_user.add_actionlinkkey]. *) -let%server send_action_link ?autoconnect ?action ?validity ?expiry msg service - email userid +let%server + send_action_link + ?autoconnect + ?action + ?validity + ?expiry + msg + service + email + userid = let act_key = generate_action_link_key ~service ~text:msg email in Eliom_reference.Volatile.set Os_msg.action_link_key_created true; @@ -113,21 +128,21 @@ let%server sign_up_handler () email = "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, + | 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) + 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 @@ -146,11 +161,11 @@ let%server forgot_password_handler service () email = ~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) + | 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) let%client restart ?url () = (* Restart the client. @@ -184,7 +199,7 @@ let%client restart ?url () = let disconnect_handler ?(main_page = false) () () = let* (* SECURITY: no check here because we disconnect the session cookie owner. *) - () + () = Os_session.disconnect () in @@ -211,26 +226,28 @@ let%client disconnect_handler ?(main_page = false) () () = let connect_handler () ((login, pwd), keepmeloggedin) = Lwt.catch (fun () -> - let* (* SECURITY: no check here. *) - userid = + 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) + | 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 = connect_handler () v @@ -254,13 +271,13 @@ exception%shared Invalid_action_key of Os_types.Action_link_key.info exception%shared No_such_resource let%rpc action_link_handler_common myid_o (akey : string) : - [ `Account_already_activated_unconnected of Os_types.Action_link_key.info - | `Custom_action_link of Os_types.Action_link_key.info * bool - | `Invalid_action_key of Os_types.Action_link_key.info - | `No_such_resource - | `Reload - | `Restart_if_app ] - Lwt.t + [ `Account_already_activated_unconnected of Os_types.Action_link_key.info + | `Custom_action_link of Os_types.Action_link_key.info * bool + | `Invalid_action_key of Os_types.Action_link_key.info + | `No_such_resource + | `Reload + | `Restart_if_app ] + Lwt.t = Lwt.catch (fun () -> @@ -307,20 +324,20 @@ let%rpc action_link_handler_common myid_o (akey : string) : 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. + | 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. If the user wasn't already logged in, let the exception pass to the next exception handler. *) - Lwt.return `Reload - | exc -> Lwt.reraise exc) + Lwt.return `Reload + | exc -> Lwt.reraise exc) let%client restart_if_client_side () = restart @@ -443,8 +460,8 @@ let%client request_activation_code_wrapper number f = Os_msg.msg ~level:`Err ~duration:2. "SMS error"; Lwt.return_unit) -let%client confirm_code_signup_handler () - (first_name, (last_name, (password, number))) +let%client + confirm_code_signup_handler () (first_name, (last_name, (password, number))) = request_activation_code_wrapper number @@ fun () -> confirm_code_popup ~dest:`Main @@ fun code -> diff --git a/src/os_lib.eliom b/src/os_lib.eliom index 3ec88051..7a89e72c 100644 --- a/src/os_lib.eliom +++ b/src/os_lib.eliom @@ -108,13 +108,14 @@ module Email_or_phone = struct in if String.sub s 0 3 = "+33" then - if (* Be a bit more precise for France. We should have +33 + if + (* Be a bit more precise for France. We should have +33 followed by 9 digits, i.e., 12 characters in total. For cellphones, the 4-th character is either 6 or 7. *) - String.length s = 12 - && - let s3 = String.get s 3 in - s3 = '6' || s3 = '7' + String.length s = 12 + && + let s3 = String.get s 3 in + s3 = '6' || s3 = '7' then s, `Phone else s, `Almost_phone else s, `Phone @@ -136,10 +137,12 @@ let%client on_enter ~f inp = if ev##.keyCode = 13 then f (Js.to_string inp##.value) else Lwt.return_unit (* TODO: Build a nice Ot_form module with such functions *) -let%shared lwt_bind_input_enter - ?(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) +let%shared + lwt_bind_input_enter + ?(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) = ignore [%client diff --git a/src/os_msg.eliom b/src/os_msg.eliom index 69023ebd..d14c3dca 100644 --- a/src/os_msg.eliom +++ b/src/os_msg.eliom @@ -34,8 +34,12 @@ let%client msgbox () = let%server default_duration = ref 4. let%server set_default_duration d = default_duration := d -let%shared msg ?(level = `Err) ?(duration = ~%(!default_duration)) - ?(onload = false) (message : string) +let%shared + msg + ?(level = `Err) + ?(duration = ~%(!default_duration)) + ?(onload = false) + (message : string) = ignore [%client diff --git a/src/os_page.eliom b/src/os_page.eliom index 52440e51..1b6e6dea 100644 --- a/src/os_page.eliom +++ b/src/os_page.eliom @@ -150,8 +150,12 @@ module Make (C : PAGE) = struct ~a:(platform_attr :: connected_attr :: content.body_attrs) content.body) - let page ?(predicate = C.default_predicate) ?(fallback = C.default_error_page) - f gp pp + let page + ?(predicate = C.default_predicate) + ?(fallback = C.default_error_page) + f + gp + pp = let* content = Lwt.catch @@ -164,8 +168,14 @@ module Make (C : PAGE) = struct in Lwt.return (make_page content) - let connected_page ?allow ?deny ?(predicate = C.default_connected_predicate) - ?(fallback = C.default_connected_error_page) f gp pp + let connected_page + ?allow + ?deny + ?(predicate = C.default_connected_predicate) + ?(fallback = C.default_connected_error_page) + f + gp + pp = let f_wrapped myid gp pp = Lwt.catch @@ -178,8 +188,8 @@ module Make (C : PAGE) = struct (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))) + | 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 @@ -189,14 +199,20 @@ module Make (C : PAGE) = struct 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) + | Os_session.Not_connected as exc -> fallback None gp pp exc + | exc -> Lwt.reraise exc) in Lwt.return (make_page content) module Opt = struct - let connected_page ?allow ?deny ?(predicate = C.default_connected_predicate) - ?(fallback = C.default_connected_error_page) f gp pp + let connected_page + ?allow + ?deny + ?(predicate = C.default_connected_predicate) + ?(fallback = C.default_connected_error_page) + f + gp + pp = let f_wrapped (myid_o : Os_types.User.id option) gp pp = Lwt.catch @@ -209,8 +225,8 @@ module Make (C : PAGE) = struct (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))) + | Predicate_failed _ as exc -> fallback myid_o gp pp exc + | exc -> fallback myid_o gp pp (Predicate_failed (Some exc))) in let* content = Os_session.Opt.connected_fun ?allow ?deny diff --git a/src/os_session.eliom b/src/os_session.eliom index 29b4055e..4edabba7 100644 --- a/src/os_session.eliom +++ b/src/os_session.eliom @@ -118,8 +118,12 @@ let set_warn_connection_change, warn_connection_changed = let r = ref (fun _ -> ()) in (fun f -> r := f), fun state -> !r state; Lwt.return_unit -let disconnect_all ?sitedata ?userid ?(user_indep = true) ?(with_restart = true) - () +let disconnect_all + ?sitedata + ?userid + ?(user_indep = true) + ?(with_restart = true) + () = let close_my_sessions = userid = None in let* () = @@ -158,10 +162,10 @@ let disconnect_all ?sitedata ?userid ?(user_indep = true) ?(with_restart = true) option Eliom_reference.eref)) (function - | None -> acc - | Some s -> - let* acc = acc in - Lwt.return (s :: acc))) + | None -> acc + | Some s -> + let* acc = acc in + Lwt.return (s :: acc))) Lwt.return_nil (Eliom_state.Ext.fold_volatile_sub_states ?sitedata ~state: @@ -170,8 +174,10 @@ let disconnect_all ?sitedata ?userid ?(user_indep = true) ?(with_restart = true) (fun acc s -> s :: acc) []) in - let* (* Closing all sessions: *) - () = + let* + (* Closing all sessions: *) + () + = Lwt_list.iter_s (fun state -> Eliom_state.Ext.iter_sub_states ?sitedata ~state @@ fun state -> @@ -183,16 +189,20 @@ let disconnect_all ?sitedata ?userid ?(user_indep = true) ?(with_restart = true) then post_close_session_action () else Lwt.return_unit in - let* (* Warn every client process that the session is closed: *) - () = + let* + (* Warn every client process that the session is closed: *) + () + = Lwt_list.iter_s (fun state -> Eliom_state.Ext.iter_sub_states ?sitedata ~state warn_connection_changed) ui_states in - let* (* Closing user_indep states, if requested: *) - () = + let* + (* Closing user_indep states, if requested: *) + () + = if user_indep then Lwt_list.iter_s @@ -252,7 +262,7 @@ let get_session () = relaunched. We restart the volatile session silently (comme si de rien n'était, pom pom pom). *) - () + () = connect_volatile (Int64.to_string uid) in @@ -269,15 +279,15 @@ let get_session () = 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) + | 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) (** The connection wrapper checks whether the user is connected, and calls the page generator accordingly. @@ -299,9 +309,16 @@ let get_session () = or not to these groups, and call function [deny_fun] otherwise. By default, it raises [Permission_denied]. *) -let%server gen_wrapper ~allow ~deny ?(force_unconnected = false) - ?(deny_fun = fun _ -> Lwt.fail Permission_denied) connected not_connected gp - pp +let%server + gen_wrapper + ~allow + ~deny + ?(force_unconnected = false) + ?(deny_fun = fun _ -> Lwt.fail Permission_denied) + connected + not_connected + gp + pp = let new_process = (not force_unconnected) && Eliom_reference.Volatile.get new_process_eref @@ -336,8 +353,16 @@ let%client get_current_userid_o = ref (fun () -> assert false) (* On client-side, we do no security check. They are done by the server. *) -let%client gen_wrapper ~allow:_ ~deny:_ ?(force_unconnected = false) ?deny_fun:_ - connected not_connected gp pp +let%client + gen_wrapper + ~allow:_ + ~deny:_ + ?(force_unconnected = false) + ?deny_fun:_ + connected + not_connected + gp + pp = let myid_o = if force_unconnected then None else !get_current_userid_o () in match myid_o with diff --git a/src/os_tips.eliom b/src/os_tips.eliom index 730314ee..12937646 100644 --- a/src/os_tips.eliom +++ b/src/os_tips.eliom @@ -126,9 +126,14 @@ let%client reset_tips () = (* Returns a block containing a tip, if it has not already been seen by the user. *) -let%shared block ?(a = []) ?(recipient = `All) - ?(onclose = [%client (fun () -> Lwt.return_unit : unit -> unit Lwt.t)]) - ~name ~content () +let%shared + block + ?(a = []) + ?(recipient = `All) + ?(onclose = [%client (fun () -> Lwt.return_unit : unit -> unit Lwt.t)]) + ~name + ~content + () = let myid_o = Os_current_user.Opt.get_current_userid () in match recipient, myid_o with @@ -183,9 +188,22 @@ let%client rec onchangepage_handler _ = let%client () = Eliom_client.onchangepage onchangepage_handler (* Display a tip bubble *) -let%client display_bubble ?(a = []) ?arrow ?top ?left ?right ?bottom ?height - ?width ?(parent_node : _ elt option) ?(delay = 0.0) - ?(onclose = fun () -> Lwt.return_unit) ~name ~content () +let%client + display_bubble + ?(a = []) + ?arrow + ?top + ?left + ?right + ?bottom + ?height + ?width + ?(parent_node : _ elt option) + ?(delay = 0.0) + ?(onclose = fun () -> Lwt.return_unit) + ~name + ~content + () = let current_waiter = !waiter in let new_waiter, new_wakener = Lwt.task () in @@ -270,26 +288,32 @@ let%client display_bubble ?(a = []) ?arrow ?top ?left ?right ?bottom ?height Lwt.return_unit (* Function to be called on server to display a tip *) -let%shared bubble - ?(a : - [< Html_types.div_attrib > `Class] Eliom_content.Html.D.attrib list - option) ?(recipient = `All) - ?(arrow : - [< `left of int | `right of int | `top of int | `bottom of int] - Eliom_client_value.t - option) ?(top : int Eliom_client_value.t option) - ?(left : int Eliom_client_value.t option) - ?(right : int Eliom_client_value.t option) - ?(bottom : int Eliom_client_value.t option) - ?(height : int Eliom_client_value.t option) - ?(width : int Eliom_client_value.t option) - ?(parent_node : - [< `Body | Html_types.body_content] Eliom_content.Html.elt option) ?delay - ?onclose ~(name : string) - ~(content : - ((unit -> unit Lwt.t) - -> Html_types.div_content Eliom_content.Html.elt list Lwt.t) - Eliom_client_value.t) () +let%shared + bubble + ?(a : + [< Html_types.div_attrib > `Class] Eliom_content.Html.D.attrib list + option) + ?(recipient = `All) + ?(arrow : + [< `left of int | `right of int | `top of int | `bottom of int] + Eliom_client_value.t + option) + ?(top : int Eliom_client_value.t option) + ?(left : int Eliom_client_value.t option) + ?(right : int Eliom_client_value.t option) + ?(bottom : int Eliom_client_value.t option) + ?(height : int Eliom_client_value.t option) + ?(width : int Eliom_client_value.t option) + ?(parent_node : + [< `Body | Html_types.body_content] Eliom_content.Html.elt option) + ?delay + ?onclose + ~(name : string) + ~(content : + ((unit -> unit Lwt.t) + -> Html_types.div_content Eliom_content.Html.elt list Lwt.t) + Eliom_client_value.t) + () = let delay : float option = delay in let onclose : (unit -> unit Lwt.t) Eliom_client_value.t option = onclose in diff --git a/src/os_user.eliom b/src/os_user.eliom index ce42650f..372619b2 100644 --- a/src/os_user.eliom +++ b/src/os_user.eliom @@ -105,8 +105,8 @@ module MCache = Os_request_cache.Make (struct 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) + | Os_db.No_such_resource -> Lwt.fail No_such_user + | exc -> Lwt.reraise exc) end) (* Overwrite the function [user_of_userid] of [Os_db.User] and use @@ -143,7 +143,7 @@ let create ?password ?avatar ?language ?email ~firstname ~lastname () = 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) + | Os_db.No_such_resource -> really_create () | exc -> Lwt.reraise exc) | None -> really_create () (* Overwrites the function [update] of [Os_db.User] diff --git a/src/os_user_view.eliom b/src/os_user_view.eliom index 60f10a4d..959d7f46 100644 --- a/src/os_user_view.eliom +++ b/src/os_user_view.eliom @@ -32,17 +32,24 @@ let%client check_password_confirmation ~password ~confirmation = Lwt_js_events.async (fun () -> Lwt_js_events.inputs confirmation_dom (fun _ _ -> ignore - (if Js.to_string password_dom##.value - <> Js.to_string confirmation_dom##.value + (if + Js.to_string password_dom##.value + <> Js.to_string confirmation_dom##.value then - (Js.Unsafe.coerce confirmation_dom) - ## (setCustomValidity "Passwords do not match") - else (Js.Unsafe.coerce confirmation_dom) ## (setCustomValidity "")); + (Js.Unsafe.coerce confirmation_dom)##(setCustomValidity + "Passwords do not match") + else (Js.Unsafe.coerce confirmation_dom)##(setCustomValidity "")); Lwt.return_unit)) -let%shared generic_email_form ?a ?label - ?(a_placeholder_email = "e-mail address") ?(text = "Send") ?(email = "") - ~service () +let%shared + generic_email_form + ?a + ?label + ?(a_placeholder_email = "e-mail address") + ?(text = "Send") + ?(email = "") + ~service + () = D.Form.post_form ?a ~service (fun name -> @@ -73,23 +80,28 @@ let%client form_override_phone phone_input form = Dom.preventDefault ev; Os_connect_phone.connect ~keepmeloggedin ~password number) (function - | `Login_ok -> Os_lib.reload () - | `Wrong_password -> - Os_msg.msg ~level:`Err "Wrong password"; - Lwt.return_unit - | `No_such_user -> - Os_msg.msg ~level:`Err "No such user"; - Lwt.return_unit - | `Password_not_set -> - Os_msg.msg ~level:`Err "User password not set"; - Lwt.return_unit) + | `Login_ok -> Os_lib.reload () + | `Wrong_password -> + Os_msg.msg ~level:`Err "Wrong password"; + Lwt.return_unit + | `No_such_user -> + Os_msg.msg ~level:`Err "No such user"; + Lwt.return_unit + | `Password_not_set -> + Os_msg.msg ~level:`Err "User password not set"; + Lwt.return_unit) else Lwt.return_unit -let%shared connect_form ?(a_placeholder_email = "Your email") - ?(a_placeholder_phone = "Or your phone") - ?(a_placeholder_pwd = "Your password") - ?(text_keep_me_logged_in = "keep me logged in") ?(text_sign_in = "Sign in") - ?a ?(email = "") () +let%shared + connect_form + ?(a_placeholder_email = "Your email") + ?(a_placeholder_phone = "Or your phone") + ?(a_placeholder_pwd = "Your password") + ?(text_keep_me_logged_in = "keep me logged in") + ?(text_sign_in = "Sign in") + ?a + ?(email = "") + () = let phone_input = if !enable_phone @@ -164,11 +176,19 @@ let%client forgot_password_phone_input ~placeholder label = (Eliom_client.change_page ~service:Os_services.confirm_code_remind_service ()) -let%shared information_form ?a ?(a_placeholder_password = "Your password") - ?(a_placeholder_retype_password = "Retype password") - ?(a_placeholder_firstname = "Your first name") - ?(a_placeholder_lastname = "Your last name") ?(text_submit = "Submit") - ?(firstname = "") ?(lastname = "") ?(password1 = "") ?(password2 = "") () +let%shared + information_form + ?a + ?(a_placeholder_password = "Your password") + ?(a_placeholder_retype_password = "Retype password") + ?(a_placeholder_firstname = "Your first name") + ?(a_placeholder_lastname = "Your last name") + ?(text_submit = "Submit") + ?(firstname = "") + ?(lastname = "") + ?(password1 = "") + ?(password2 = "") + () = D.Form.post_form ?a ~service:Os_services.set_personal_data_service (fun ((fname, lname), (passwordn1, passwordn2)) -> @@ -222,9 +242,14 @@ let%shared username user = in div ~a:[a_class ["os_username"]] n -let%shared password_form ?(a_placeholder_pwd = "password") - ?(a_placeholder_confirmation = "retype your password") - ?(text_send_button = "Send") ?a ~service () +let%shared + password_form + ?(a_placeholder_pwd = "password") + ?(a_placeholder_confirmation = "retype your password") + ?(text_send_button = "Send") + ?a + ~service + () = D.Form.post_form ?a ~service (fun (pwdn, pwd2n) -> @@ -255,19 +280,22 @@ let%shared password_form ?(a_placeholder_pwd = "password") ~value:text_send_button D.Form.string ]) () -let%shared upload_pic_link ?(a = []) ?(content = [txt "Change profile picture"]) - ?(crop = Some 1.) - ?(input : - Html_types.label_attrib Eliom_content.Html.D.Raw.attrib list - * Html_types.label_content_fun Eliom_content.Html.D.Raw.elt list = - [], []) - ?(submit : - Html_types.button_attrib Eliom_content.Html.D.Raw.attrib list - * Html_types.button_content_fun Eliom_content.Html.D.Raw.elt list = - [], [txt "Submit"]) - ?(onclick : (unit -> unit) Eliom_client_value.t = - [%client (fun () -> () : unit -> unit)]) - (service : (unit, unit) Ot_picture_uploader.service) +let%shared + upload_pic_link + ?(a = []) + ?(content = [txt "Change profile picture"]) + ?(crop = Some 1.) + ?(input : + Html_types.label_attrib Eliom_content.Html.D.Raw.attrib list + * Html_types.label_content_fun Eliom_content.Html.D.Raw.elt list = + [], []) + ?(submit : + Html_types.button_attrib Eliom_content.Html.D.Raw.attrib list + * Html_types.button_content_fun Eliom_content.Html.D.Raw.elt list = + [], [txt "Submit"]) + ?(onclick : (unit -> unit) Eliom_client_value.t = + [%client (fun () -> () : unit -> unit)]) + (service : (unit, unit) Ot_picture_uploader.service) = D.Raw.a ~a: @@ -301,9 +329,12 @@ let%shared upload_pic_link ?(a = []) ?(content = [txt "Change profile picture"]) :: a) content -let%shared reset_tips_link ?(text_link = "See help again from beginning") - ?(close : (unit -> unit) Eliom_client_value.t = - [%client (fun () -> () : unit -> unit)]) () +let%shared + reset_tips_link + ?(text_link = "See help again from beginning") + ?(close : (unit -> unit) Eliom_client_value.t = + [%client (fun () -> () : unit -> unit)]) + () = let l = D.Raw.a [txt text_link] in ignore @@ -328,11 +359,15 @@ let%shared disconnect_all_link ?(text_link = "Logout on all my devices") () = : unit)]; l -let%shared bind_popup_button ?a ~button - ~(popup_content : - ((unit -> unit Lwt.t) - -> [< Html_types.div_content] Eliom_content.Html.elt Lwt.t) - Eliom_client_value.t) () +let%shared + bind_popup_button + ?a + ~button + ~(popup_content : + ((unit -> unit Lwt.t) + -> [< Html_types.div_content] Eliom_content.Html.elt Lwt.t) + Eliom_client_value.t) + () = ignore [%client @@ -347,10 +382,14 @@ let%shared bind_popup_button ?a ~button Lwt.return_unit)) : _)] -let%client forgotpwd_button ?(content_popup = "Recover password") - ?(text_button = "Forgot your password?") - ?(phone_placeholder = "Or your phone") ?(text_send_button = "Send") - ?(close = (fun () -> () : unit -> unit)) () +let%client + forgotpwd_button + ?(content_popup = "Recover password") + ?(text_button = "Forgot your password?") + ?(phone_placeholder = "Or your phone") + ?(text_send_button = "Send") + ?(close = (fun () -> () : unit -> unit)) + () = let popup_content _ = let h = h2 [txt content_popup] in @@ -373,13 +412,18 @@ let%client forgotpwd_button ?(content_popup = "Recover password") bind_popup_button ~a:[a_class ["os-forgot-pwd"]] ~button ~popup_content (); button -let%shared sign_in_button ?(a_placeholder_email = "Your email") - ?(a_placeholder_phone = "Or your phone") - ?(a_placeholder_pwd = "Your password") - ?(text_keep_me_logged_in = "keep me logged in") ?(text_sign_in = "Sign in") - ?(content_popup_forgotpwd = "Recover password") - ?(text_button_forgotpwd = "Forgot your password?") - ?(text_button = "Sign in") ?(text_send_button = "Send") () +let%shared + sign_in_button + ?(a_placeholder_email = "Your email") + ?(a_placeholder_phone = "Or your phone") + ?(a_placeholder_pwd = "Your password") + ?(text_keep_me_logged_in = "keep me logged in") + ?(text_sign_in = "Sign in") + ?(content_popup_forgotpwd = "Recover password") + ?(text_button_forgotpwd = "Forgot your password?") + ?(text_button = "Sign in") + ?(text_send_button = "Send") + () = let popup_content = [%client @@ -405,9 +449,13 @@ let%shared sign_in_button ?(a_placeholder_email = "Your email") bind_popup_button ~a:[a_class ["os-sign-in"]] ~button ~popup_content (); button -let%shared sign_up_button ?(a_placeholder_email = "Your email") - ?(a_placeholder_phone = "or your phone") ?(text_button = "Sign up") - ?(text_send_button = "Send") () +let%shared + sign_up_button + ?(a_placeholder_email = "Your email") + ?(a_placeholder_phone = "or your phone") + ?(text_button = "Sign up") + ?(text_send_button = "Send") + () = let popup_content = [%client @@ -448,13 +496,18 @@ let%shared connected_user_box ~user = let username = username user in D.div ~a:[a_class ["connected-user-box"]] [avatar user; div [username]] -let%shared connection_box ?(a_placeholder_email = "Your email") - ?(a_placeholder_phone = "Your phone") ?(a_placeholder_pwd = "Your password") - ?(text_keep_me_logged_in = "keep me logged in") - ?(content_popup_forgotpwd = "Recover password") - ?(text_button_forgotpwd = "Forgot your password?") - ?(text_sign_in = "Sign in") ?(text_sign_up = "Sign up") - ?(text_send_button = "Send") () +let%shared + connection_box + ?(a_placeholder_email = "Your email") + ?(a_placeholder_phone = "Your phone") + ?(a_placeholder_pwd = "Your password") + ?(text_keep_me_logged_in = "keep me logged in") + ?(content_popup_forgotpwd = "Recover password") + ?(text_button_forgotpwd = "Forgot your password?") + ?(text_sign_in = "Sign in") + ?(text_sign_up = "Sign up") + ?(text_send_button = "Send") + () = let sign_in = sign_in_button ~a_placeholder_email ~a_placeholder_phone ~a_placeholder_pwd @@ -467,13 +520,18 @@ let%shared connection_box ?(a_placeholder_email = "Your email") in Lwt.return @@ div ~a:[a_class ["os-connection-box"]] [sign_in; sign_up] -let%shared user_box ?(a_placeholder_email = "Your email") - ?(a_placeholder_pwd = "Your password") - ?(text_keep_me_logged_in = "keep me logged in") - ?(content_popup_forgotpwd = "Recover password") - ?(text_button_forgotpwd = "Forgot your password?") - ?(text_sign_in = "Sign in") ?(text_sign_up = "Sign up") - ?(text_send_button = "Send") ?user () +let%shared + user_box + ?(a_placeholder_email = "Your email") + ?(a_placeholder_pwd = "Your password") + ?(text_keep_me_logged_in = "keep me logged in") + ?(content_popup_forgotpwd = "Recover password") + ?(text_button_forgotpwd = "Forgot your password?") + ?(text_sign_in = "Sign in") + ?(text_sign_up = "Sign up") + ?(text_send_button = "Send") + ?user + () = match user with | None ->