geochan/src/user.ml

type t =
  { nick : string
  ; password : string
  ; email : string
  ; bio : string
  ; avatar : string
  }

module Q = struct
  let create_user_table =
    Caqti_request.exec Caqti_type.unit
      "CREATE TABLE IF NOT EXISTS user (nick TEXT, password TEXT, email TEXT, \
       bio TEXT, avatar BLOB, PRIMARY KEY(nick));"

  let create_plant_user_table =
    Caqti_request.exec Caqti_type.unit
      "CREATE TABLE IF NOT EXISTS plant_user (plant_id TEXT, nick TEXT, \
       PRIMARY KEY(plant_id), FOREIGN KEY(nick) REFERENCES user(nick));"

  let create_plant_image_table =
    Caqti_request.exec Caqti_type.unit
      "CREATE TABLE IF NOT EXISTS plant_image ( plant_id TEXT, image TEXT,id \
       INTEGER, FOREIGN KEY(plant_id) REFERENCES plant_user(plant_id));"

  let create_plant_tag_table =
    Caqti_request.exec Caqti_type.unit
      "CREATE TABLE IF NOT EXISTS plant_tag (plant_id TEXT, tag TEXT, FOREIGN \
       KEY(plant_id) REFERENCES plant_user(plant_id));"

  let create_plant_gps_table =
    Caqti_request.exec Caqti_type.unit
      "CREATE TABLE IF NOT EXISTS plant_gps (plant_id TEXT, lat TEXT,lng TEXT, \
       FOREIGN KEY(plant_id) REFERENCES plant_user(plant_id));"

  let get_password =
    Caqti_request.find_opt Caqti_type.string Caqti_type.string
      "SELECT password FROM user WHERE nick=?;"

  let is_already_user =
    Caqti_request.find_opt
      Caqti_type.(tup2 string string)
      Caqti_type.int
      "SELECT EXISTS(SELECT 1 FROM user WHERE nick=? OR email=?);"

  let inser_new_user =
    Caqti_request.exec
      Caqti_type.(tup4 string string string Caqti_type.(tup2 string string))
      "INSERT INTO user VALUES (?, ?, ?, ?, ?);"

  let list_nicks =
    Caqti_request.collect Caqti_type.unit Caqti_type.string
      "SELECT nick FROM user;"

  let get_user =
    Caqti_request.find_opt Caqti_type.string
      Caqti_type.(tup4 string string string Caqti_type.(tup2 string string))
      "SELECT * FROM user WHERE nick=?;"

  let update_bio =
    Caqti_request.exec
      Caqti_type.(tup2 string string)
      "UPDATE user SET bio=? WHERE nick=?;"

  let get_bio =
    Caqti_request.find_opt Caqti_type.string Caqti_type.string
      "SELECT bio FROM user WHERE nick=?;"

  let get_avatar =
    Caqti_request.find_opt Caqti_type.string Caqti_type.string
      "SELECT avatar FROM user WHERE nick=?;"

  let upload_avatar =
    Caqti_request.exec
      Caqti_type.(tup2 string string)
      "UPDATE user SET avatar=? WHERE nick=?;"

  let upload_plant_id =
    Caqti_request.exec
      Caqti_type.(tup2 string string)
      "INSERT INTO plant_user VALUES (?,?);"

  let upload_plant_tag =
    Caqti_request.exec
      Caqti_type.(tup2 string string)
      "INSERT INTO plant_tag VALUES (?,?);"

  let upload_plant_gps =
    Caqti_request.exec
      Caqti_type.(tup3 string string string)
      "INSERT INTO plant_gps VALUES (?,?,?);"

  let upload_plant_image =
    Caqti_request.exec
      Caqti_type.(tup3 string string int)
      "INSERT INTO plant_image VALUES (?,?,?);"

  let get_user_plants =
    Caqti_request.collect Caqti_type.string Caqti_type.string
      "SELECT plant_id FROM plant_user WHERE nick=?;"

  let count_plant_image =
    Caqti_request.find_opt Caqti_type.string Caqti_type.int
      "SELECT COUNT(*) FROM plant_image WHERE plant_id=?;"

  let get_plant_image =
    Caqti_request.find_opt
      Caqti_type.(tup2 string int)
      Caqti_type.string
      "SELECT image FROM plant_image WHERE plant_id=? AND id=?;"

  let get_tags =
    Caqti_request.collect Caqti_type.string Caqti_type.string
      "SELECT tag FROM plant_tag WHERE plant_id=?;"

  let get_plant_gps =
    Caqti_request.find_opt Caqti_type.string
      Caqti_type.(tup2 string string)
      "SELECT lat, lng FROM plant_gps WHERE plant_id=?;"
end

module Db =
( val Caqti_blocking.connect (Uri.of_string (Filename.concat "sqlite3://" Db.db))
      |> Caqti_blocking.or_fail )

let random_state = Random.State.make_self_init ()

let () =
  let tables =
    [ Q.create_user_table
    ; Q.create_plant_user_table
    ; Q.create_plant_image_table
    ; Q.create_plant_tag_table
    ; Q.create_plant_gps_table
    ]
  in
  if
    List.exists Result.is_error
      (List.map (fun query -> Db.exec query ()) tables)
  then
    Dream.warning (fun log -> log "can't create table")

let login ~nick ~password request =
  let good_password = Db.find_opt Q.get_password nick in
  match good_password with
  | Ok foo -> (
    match foo with
    | Some good_password ->
      if Bcrypt.verify password (Bcrypt.hash_of_string good_password) then
        let _ =
          let%lwt () = Dream.invalidate_session request in
          Dream.put_session "nick" nick request
        in
        Ok ()
      else
        Error "wrong password"
    | None -> Error (Format.sprintf "user `%s` doesn't exist" nick) )
  | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))

let register ~email ~nick ~password =
  (* TODO: remove bad characters (e.g. delthas) *)
  let valid_nick =
    String.length nick < 64
    && String.length nick > 0
    && String.escaped nick = nick
  in

  let valid_email =
    match Emile.of_string email with
    | Ok _ -> true
    | Error _ -> false
  in

  let valid_password =
    String.length password < 128 && String.length password > 0
  in

  let valid = valid_nick && valid_email && valid_password in

  let password = Bcrypt.hash password in
  let password = Bcrypt.string_of_hash password in

  if not valid then
    Error "Something is wrong"
  else
    let unique = Db.find_opt Q.is_already_user (nick, email) in
    match unique with
    | Ok unique -> (
      match unique with
      | Some nb -> (
        match nb with
        | 0 -> (
          let res =
            Db.exec Q.inser_new_user (nick, password, email, ("", ""))
          in
          match res with
          | Ok res -> Ok res
          | Error e ->
            Error (Format.sprintf "db error: %s" (Caqti_error.show e)) )
        | _ -> Error "nick or email already exists" )
      | None -> Error "db error" )
    | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))

let view_plant plant_id =
  let count = Db.find_opt Q.count_plant_image plant_id in
  match count with
  | Ok count -> (
    match count with
    | Some count -> (
      let gps =
        match Db.find_opt Q.get_plant_gps plant_id with
        | Ok (Some (lat, lng)) -> lat ^ " " ^ lng
        | Ok None -> ""
        | Error e -> Format.sprintf "db error: %s" (Caqti_error.show e)
      in
      let images =
        String.concat "\n"
          (List.map
             (Format.sprintf
                {|<li><img src="/plant_pic/%s/%i" class="img-thumbnail"></li>|}
                plant_id )
             (List.init count (fun i -> i)) )
      in
      let tags = Db.fold Q.get_tags (fun tag acc -> tag :: acc) plant_id [] in
      match tags with
      | Error e -> Format.sprintf "db error: %s" (Caqti_error.show e)
      | Ok tags ->
        let tags = String.concat " " tags in
        (* TODO add link to gps/map too *)
        images ^ tags ^ gps )
    | None -> "db error" )
  | Error e -> Format.sprintf "db error: %s" (Caqti_error.show e)

let view_user_plant_list nick =
  let plant_id_list =
    Db.fold Q.get_user_plants (fun plant_id acc -> plant_id :: acc) nick []
  in
  match plant_id_list with
  | Error e -> Format.sprintf "db error: %s" (Caqti_error.show e)
  | Ok plant_id_list ->
    let plants = List.map view_plant plant_id_list in
    String.concat "\n" plants

let list () =
  let users = Db.fold Q.list_nicks (fun nick acc -> nick :: acc) () [] in
  match users with
  | Ok users ->
    Format.asprintf "<ul>%a</ul>"
      (Format.pp_print_list (fun fmt -> function
         | s -> Format.fprintf fmt {|<li><a href="/user/%s">%s</a></li>|} s s )
      )
      users
  | Error e -> Format.sprintf "db error: %s" (Caqti_error.show e)

let public_profile request =
  let nick = Dream.param "user" request in
  let user = Db.find_opt Q.get_user nick in
  match user with
  | Ok user -> (
    match user with
    | Some (nick, password, email, (bio, _)) ->
      let plants = view_user_plant_list nick in
      let user_info =
        Format.sprintf
          {|nick = `%s`; password = `%s`; email = `%s`; bio = '%s';
    <img src="/user/%s/avatar" class="img-thumbnail" alt="Your avatar picture">|}
          nick password email (Dream.html_escape bio) nick
      in
      user_info ^ plants
    | None -> "incoherent db answer" )
  | Error e -> Format.sprintf "db error: %s" (Caqti_error.show e)

let profile request =
  match Dream.session "nick" request with
  | None -> "not logged in"
  | Some nick -> Format.sprintf "Hello %s !" nick

let update_bio bio nick =
  let valid = true in
  (* TODO check bio len and FORBIDEN WORDS *)
  if not valid then
    Error "Not biologic"
  else
    let res = Db.exec Q.update_bio (bio, nick) in
    match res with
    | Ok _ -> Ok ()
    | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))

let get_bio nick =
  let res = Db.find_opt Q.get_bio nick in
  match res with
  | Ok bio -> (
    match bio with
    | Some bio -> Ok bio
    | None -> Error "incoherent db result" )
  | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))

let get_avatar nick =
  let res = Db.find_opt Q.get_avatar nick in
  match res with
  | Ok avatar -> (
    match avatar with
    | Some avatar ->
      if String.length avatar = 0 then
        Ok None
      else
        Ok (Some avatar)
    | None -> Error "db error:" )
  | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))

let get_plant_image plant_id nb =
  let res = Db.find_opt Q.get_plant_image (plant_id, nb) in
  match res with
  | Ok content -> (
    match content with
    | Some content -> Ok (Some content)
    | None -> Error "Image not found" )
  | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))

let upload_avatar files nick =
  match files with
  | [] -> Error "No file provided"
  | [ (_, content) ] -> (
    let valid = true in
    if not valid then
      Error "Invalid image"
    else
      let res = Db.exec Q.upload_avatar (content, nick) in
      match res with
      | Ok _ -> Ok ()
      | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) )
  | _files -> Error "More than one file provided"

(* TODO do image validation: length and MIME types with conan*)
(* TODO do the same for text input: check length, forbidden chars and have a forbidden words filter*)
let is_valid_image _content = true

let add_plant (lat, lng) tags files nick =
  let tags_len = String.length tags in
  if tags_len > 1000 then
    Error "tags too long"
  else
    let tag_list = Str.split (Str.regexp " +") tags in
    (* id for plant*)
    let ok_list = List.map (fun (_, content) -> is_valid_image content) files in
    let valid_files = List.for_all (fun valid -> valid) ok_list in
    if not valid_files then
      Error "Invalid image"
    else
      (* add plant to db *)
      let plant_id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
      (* add to plant_id <-> user*)
      let res_plant = Db.exec Q.upload_plant_id (plant_id, nick) in
      match res_plant with
      | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
      | Ok _ -> (
        (* add to plant_id <-> gps table*)
        (*TODO check if valid latlng *)
        let res_gps = Db.exec Q.upload_plant_gps (plant_id, lat, lng) in
        match res_gps with
        | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
        | Ok _ -> (
          (* add to plant_id <-> tag table*)
          let res_tags =
            List.map
              (fun tag -> Db.exec Q.upload_plant_tag (plant_id, tag))
              tag_list
          in
          if List.exists Result.is_error res_tags then
            Error (Format.sprintf "db error")
          else
            (* add to plant_id <-> image*)
            let res_images =
              List.find_opt Result.is_error
                (List.mapi
                   (fun nb (_, content) ->
                     Db.exec Q.upload_plant_image (plant_id, content, nb) )
                   files )
            in
            match res_images with
            | Some (Error e) ->
              Error (Format.sprintf "db error: %s" (Caqti_error.show e))
            | Some (Ok _) -> assert false
            | None -> Ok () ) )