<commit_before>(* Copyright <NAME> *)

let (>>=) = Lwt.bind

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

let connect () = Lwt_PGOCaml.connect ~database:"eba" ()

let validate db =
  try_lwt
    lwt () = Lwt_PGOCaml.ping db in
    Lwt.return true
  with _ ->
    Lwt.return false

let pool : (string, bool) Hashtbl.t Lwt_PGOCaml.t Lwt_pool.t =
  Lwt_pool.create 16 ~validate connect

let transaction_block db f =
  Lwt_PGOCaml.begin_work db >>= fun _ ->
  try_lwt
     lwt r = f () in
     lwt () = Lwt_PGOCaml.commit db in
     Lwt.return r
  with e ->
     lwt () = Lwt_PGOCaml.rollback db in
     Lwt.fail e

let full_transaction_block f =
  Lwt_pool.use pool (fun db -> transaction_block db (fun () -> f db))


(********* Tables *********)
let users_table_id_seq = <:sequence< bigserial "users_userid_seq" >>

let users_table = <:table< users (
       userid bigint NOT NULL DEFAULT(nextval $users_table_id_seq$),
       pwd text,
       firstname text NOT NULL,
       lastname text NOT NULL,
       (* 0 = user, 1 = beta testeur, 2 = admin *)
       (* there is not default value because it doesn't work with macaque *)
       pic text
) >>

let emails_table = <:table< emails (
       email text NOT NULL,
       userid bigint NOT NULL
) >>

let activation_table = <:table< activation (
       activationkey text NOT NULL,
       email text NOT NULL,
       creationdate timestamp NOT NULL DEFAULT(current_timestamp)
) >>

let contacts_table = <:table< contacts (
       userid bigint NOT NULL,
       contactid bigint NOT NULL
) >>

let preregister_table = <:table< preregister (
       email text NOT NULL
) >>

let groups_table_id_seq = <:sequence< bigserial "groups_groupid_seq" >>

let groups_table = <:table< groups (
       groupid bigint NOT NULL DEFAULT(nextval $groups_table_id_seq$),
       name text NOT NULL,
       description text
) >>

let user_groups_table = <:table< user_groups (
       userid bigint NOT NULL,
       groupid bigint NOT NULL
) >>

(********* Queries *********)
let get_group name =
  full_transaction_block
    (fun dbh ->
       Lwt_Query.view_one dbh
         <:view< g | g in $groups_table$;
                     g.name = $string:name$ >>)

let q_group_exists dbh name =
  try_lwt
    lwt g = Lwt_Query.view_one dbh
    <:view< g | g in $groups_table$;
                g.name = $string:name$ >>;
    in
    Lwt.return (Some g)
  with _ -> Lwt.return None

let group_exists name =
  full_transaction_block
    (fun dbh ->
       q_group_exists dbh name)

let new_group ?description name =
  full_transaction_block
    (fun dbh ->
       lwt () =
         match description with
           | None ->
               Lwt_Query.query dbh
                 <:insert<
                 $groups_table$ := { groupid = groups_table?groupid;
                                     name = $string:name$;
                                     description = $Sql.Op.null$ }
                 >>
           | Some d ->
               Lwt_Query.query dbh
                 <:insert<
                 $groups_table$ := { groupid = groups_table?groupid;
                                     name = $string:name$;
                                     description = $string:d$ }
                 >>
       in Lwt.return ())

(* CHARLY: better to user label because we're going to user same
 * type for both and we don't want to make some mistakes :) *)
let is_user_in_group ~userid ~groupid =
  full_transaction_block
    (fun dbh ->
       try_lwt
         lwt _ = Lwt_Query.view_one dbh
           <:view< ug | ug in $user_groups_table$;
                        ug.userid = $int64:userid$;
                        ug.groupid = $int64:groupid$;
           >>
         in Lwt.return true
       with _ -> Lwt.return false)

(* CHARLY: same here *)
let add_user_in_group ~userid ~groupid =
  full_transaction_block
    (fun dbh ->
       lwt b = is_user_in_group ~userid ~groupid in
       (* true -> in the group, false -> not in the group *)
       if b
       (* we don't need to add user to the groups because he already belongs to it *)
       then Lwt.return ()
       (* here, ew add the user to a group *)
       else
         Lwt_Query.query dbh
           <:insert<
           $user_groups_table$ := { userid = $int64:userid$;
                                    groupid = $int64:groupid$ }
           >>)

(* CHARLY: same here *)
let remove_user_in_group ~userid ~groupid =
  full_transaction_block
    (fun dbh ->
       Lwt_Query.query dbh
         <:delete< ug in $user_groups_table$
                   | ug.userid = $int64:userid$;
                     ug.groupid = $int64:groupid$;
         >>)

let get_groups () =
  full_transaction_block
    (fun dbh ->
       Lwt_Query.query dbh
         <:select< g | g in $groups_table$ >>)

let new_preregister_email m =
  full_transaction_block
    (fun dbh ->
       Lwt_Query.query dbh
         <:insert<
            $preregister_table$ := { email = $string:m$; }
         >>)

let q_is_registered dbh m =
  try_lwt
    lwt _ = Lwt_Query.view_one dbh
    <:view< e | e in $emails_table$;
                e.email = $string:m$ >>;
    in
    Lwt.return true
  with _ -> Lwt.return false

let q_is_preregistered dbh m =
  try_lwt
    lwt _ = Lwt_Query.view_one dbh
    <:view< p | p in $preregister_table$;
                p.email = $string:m$ >>;
    in
    Lwt.return true
  with _ -> Lwt.return false

let is_registered m =
  full_transaction_block
    (fun dbh ->
       (* this will return a Lwt.t *)
       q_is_registered dbh m)

let is_preregistered m =
  full_transaction_block
    (fun dbh ->
       (* this will return a Lwt.t *)
       q_is_preregistered dbh m)

let is_registered_or_preregistered m =
  full_transaction_block
    (fun dbh ->
       lwt b1 = q_is_preregistered dbh m in
       lwt b2 = q_is_registered dbh m in
       Lwt.return (b1 || b2))

let all_preregistered () =
  full_transaction_block
    (fun dbh ->
       lwt l = (Lwt_Query.query dbh
                  <:select< p | p in $preregister_table$; >>)
       in
       Lwt.return (List.map (fun r -> r#!email) l))



let password_view =
  <:view< {email = e.email; pwd = <PASSWORD>; userid=u.userid} |
      u in $users_table$;
      e in $emails_table$;
      u.userid = e.userid >>

let check_pwd login pwd =
  full_transaction_block
  (fun dbh ->
    lwt l = Lwt_Query.query dbh
    <:select< r | r in $password_view$;
                  r.email = $string:login$ >>
                  (* r.pwd = $string:pwd$ >> *)
    in
    (match l with
      | [] -> Lwt.fail Not_found
      | [r] -> (match Sql.getn r#pwd with
          | None -> Lwt.fail Not_found
          | Some h -> if Bcrypt.verify pwd (Bcrypt.hash_of_string h)
            then Lwt.return (r#!userid)
            else Lwt.fail Not_found)
      | r::_ -> Ocsigen_messages.warning "Db.check_pwd: should not occure. Check!";
        Lwt.return (r#!userid)
    ))


(** Returns the informations about one user from one uid.
    The results are cached in an Eliom reference with scope request. *)
let get_user, reset_user =
  let module M = Map.Make(struct type t = int64 let compare = compare end) in
  let cache = Eliom_reference.Volatile.eref
    ~scope:Eliom_common.request_scope M.empty
  in
  ((fun ?(default_avatar=Eba_common0.default_user_avatar) uid ->
    let table = Eliom_reference.Volatile.get cache in
    try Lwt.return (M.find uid table) with
      | Not_found ->
        full_transaction_block
          (fun dbh ->
            try_lwt
              lwt u =
                Lwt_Query.view_one dbh
                <:view< r | r in $users_table$;
                            r.userid = $int64:uid$ >>
              in
              let user =
                Eba_common0.create_user_from_db_info ~default_avatar u in
              let () = Eliom_reference.Volatile.set
                cache (M.add uid user table) in
              Lwt.return user
            with _ -> Lwt.fail Eba_common0.No_such_user)),
   (fun uid ->
     let table = Eliom_reference.Volatile.get cache in
     Eliom_reference.Volatile.set cache (M.remove uid table)))

(** Get the list of users corresponding to one name. *)
let get_users_from_name (fn, ln) =
  full_transaction_block
    (fun dbh ->
      Lwt_Query.view dbh
        <:view< r |<commit_msg>use eba_cache instead of old cache system<commit_after>(* Copyright <NAME> *)

let (>>=) = Lwt.bind

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

let connect () = Lwt_PGOCaml.connect ~database:"eba" ()

let validate db =
  try_lwt
    lwt () = Lwt_PGOCaml.ping db in
    Lwt.return true
  with _ ->
    Lwt.return false

let pool : (string, bool) Hashtbl.t Lwt_PGOCaml.t Lwt_pool.t =
  Lwt_pool.create 16 ~validate connect

let transaction_block db f =
  Lwt_PGOCaml.begin_work db >>= fun _ ->
  try_lwt
     lwt r = f () in
     lwt () = Lwt_PGOCaml.commit db in
     Lwt.return r
  with e ->
     lwt () = Lwt_PGOCaml.rollback db in
     Lwt.fail e

let full_transaction_block f =
  Lwt_pool.use pool (fun db -> transaction_block db (fun () -> f db))


(********* Tables *********)
let users_table_id_seq = <:sequence< bigserial "users_userid_seq" >>

let users_table = <:table< users (
       userid bigint NOT NULL DEFAULT(nextval $users_table_id_seq$),
       pwd text,
       firstname text NOT NULL,
       lastname text NOT NULL,
       (* 0 = user, 1 = beta testeur, 2 = admin *)
       (* there is not default value because it doesn't work with macaque *)
       pic text
) >>

let emails_table = <:table< emails (
       email text NOT NULL,
       userid bigint NOT NULL
) >>

let activation_table = <:table< activation (
       activationkey text NOT NULL,
       email text NOT NULL,
       creationdate timestamp NOT NULL DEFAULT(current_timestamp)
) >>

let contacts_table = <:table< contacts (
       userid bigint NOT NULL,
       contactid bigint NOT NULL
) >>

let preregister_table = <:table< preregister (
       email text NOT NULL
) >>

let groups_table_id_seq = <:sequence< bigserial "groups_groupid_seq" >>

let groups_table = <:table< groups (
       groupid bigint NOT NULL DEFAULT(nextval $groups_table_id_seq$),
       name text NOT NULL,
       description text
) >>

let user_groups_table = <:table< user_groups (
       userid bigint NOT NULL,
       groupid bigint NOT NULL
) >>

(********* Queries *********)
let get_group name =
  full_transaction_block
    (fun dbh ->
       Lwt_Query.view_one dbh
         <:view< g | g in $groups_table$;
                     g.name = $string:name$ >>)

let q_group_exists dbh name =
  try_lwt
    lwt g = Lwt_Query.view_one dbh
    <:view< g | g in $groups_table$;
                g.name = $string:name$ >>;
    in
    Lwt.return (Some g)
  with _ -> Lwt.return None

let group_exists name =
  full_transaction_block
    (fun dbh ->
       q_group_exists dbh name)

let new_group ?description name =
  full_transaction_block
    (fun dbh ->
       lwt () =
         match description with
           | None ->
               Lwt_Query.query dbh
                 <:insert<
                 $groups_table$ := { groupid = groups_table?groupid;
                                     name = $string:name$;
                                     description = $Sql.Op.null$ }
                 >>
           | Some d ->
               Lwt_Query.query dbh
                 <:insert<
                 $groups_table$ := { groupid = groups_table?groupid;
                                     name = $string:name$;
                                     description = $string:d$ }
                 >>
       in Lwt.return ())

(* CHARLY: better to user label because we're going to user same
 * type for both and we don't want to make some mistakes :) *)
let is_user_in_group ~userid ~groupid =
  full_transaction_block
    (fun dbh ->
       try_lwt
         lwt _ = Lwt_Query.view_one dbh
           <:view< ug | ug in $user_groups_table$;
                        ug.userid = $int64:userid$;
                        ug.groupid = $int64:groupid$;
           >>
         in Lwt.return true
       with _ -> Lwt.return false)

(* CHARLY: same here *)
let add_user_in_group ~userid ~groupid =
  full_transaction_block
    (fun dbh ->
       lwt b = is_user_in_group ~userid ~groupid in
       (* true -> in the group, false -> not in the group *)
       if b
       (* we don't need to add user to the groups because he already belongs to it *)
       then Lwt.return ()
       (* here, ew add the user to a group *)
       else
         Lwt_Query.query dbh
           <:insert<
           $user_groups_table$ := { userid = $int64:userid$;
                                    groupid = $int64:groupid$ }
           >>)

(* CHARLY: same here *)
let remove_user_in_group ~userid ~groupid =
  full_transaction_block
    (fun dbh ->
       Lwt_Query.query dbh
         <:delete< ug in $user_groups_table$
                   | ug.userid = $int64:userid$;
                     ug.groupid = $int64:groupid$;
         >>)

let get_groups () =
  full_transaction_block
    (fun dbh ->
       Lwt_Query.query dbh
         <:select< g | g in $groups_table$ >>)

let new_preregister_email m =
  full_transaction_block
    (fun dbh ->
       Lwt_Query.query dbh
         <:insert<
            $preregister_table$ := { email = $string:m$; }
         >>)

let q_is_registered dbh m =
  try_lwt
    lwt _ = Lwt_Query.view_one dbh
    <:view< e | e in $emails_table$;
                e.email = $string:m$ >>;
    in
    Lwt.return true
  with _ -> Lwt.return false

let q_is_preregistered dbh m =
  try_lwt
    lwt _ = Lwt_Query.view_one dbh
    <:view< p | p in $preregister_table$;
                p.email = $string:m$ >>;
    in
    Lwt.return true
  with _ -> Lwt.return false

let is_registered m =
  full_transaction_block
    (fun dbh ->
       (* this will return a Lwt.t *)
       q_is_registered dbh m)

let is_preregistered m =
  full_transaction_block
    (fun dbh ->
       (* this will return a Lwt.t *)
       q_is_preregistered dbh m)

let is_registered_or_preregistered m =
  full_transaction_block
    (fun dbh ->
       lwt b1 = q_is_preregistered dbh m in
       lwt b2 = q_is_registered dbh m in
       Lwt.return (b1 || b2))

let all_preregistered () =
  full_transaction_block
    (fun dbh ->
       lwt l = (Lwt_Query.query dbh
                  <:select< p | p in $preregister_table$; >>)
       in
       Lwt.return (List.map (fun r -> r#!email) l))



let password_view =
  <:view< {email = e.email; pwd = <PASSWORD>; userid=u.userid} |
      u in $users_table$;
      e in $emails_table$;
      u.userid = e.userid >>

module MCache_in = struct
  type key_t = int64
  type value_t = Eba_common0.user

  let compare = compare
  let get key =
    full_transaction_block
      (fun dbh ->
         try_lwt
           lwt u =
             Lwt_Query.view_one dbh
               <:view< r | r in $users_table$;
                           r.userid = $int64:key$
               >>
           in
           let user =
             Eba_common0.create_user_from_db_info u
           in
           Lwt.return user
         with
           | _ -> Lwt.fail Eba_common0.No_such_user)
end
module MCache = Eba_cache.Make(MCache_in)

let get_user (uid : int64) =
  (MCache.get uid :> Eba_common0.user Lwt.t)

let reset_user (uid : int64) : unit =
  MCache.reset uid

let check_pwd login pwd =
  full_transaction_block
  (fun dbh ->
    lwt l = Lwt_Query.query dbh
    <:select< r | r in $password_view$;
                  r.email = $string:login$ >>
                  (* r.pwd = $string:pwd$ >> *)
    in
    (match l with
      | [] -> Lwt.fail Not_found
      | [r] -> (match Sql.getn r#pwd with
          | None -> Lwt.fail Not_found
          | Some h -> if Bcrypt.verify pwd (Bcrypt.hash_of_string h)
            then Lwt.return (r#!userid)
            else Lwt.fail Not_found)
      | r::_ -> Ocsigen_messages.warning "Db.check_pwd: should not occure. Check!";
        Lwt.return (r#!userid)
    ))


(** Get the list of users corresponding to one name. *)
let get_users_from_name (fn, ln) =
  full_transaction_block
    (fun dbh ->
      Lwt_Query.view dbh
        <:view< r |
{'fraction_non_alphanumeric': 0.10360905898025917, 'fraction_numerical': 0.0036938355334867386, 'mean_word_length': 2.0136861313868613, 'pattern_counts': {'":': 0, '<': 107, '<?xml version=': 0, '>': 189, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 15, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3124601', 'n_tokens_mistral': 5605, 'n_tokens_neox': 5425, 'n_words': 1487}