geochan/src/babillard.ml

open Syntax
open Caqti_request.Infix
open Caqti_type

type moderation_action =
  | Ignore
  | Delete
  | Banish

let moderation_action_to_string = function
  | Ignore -> "ignore"
  | Delete -> "delete"
  | Banish -> "banish"

let moderation_action_from_string = function
  | "ignore" -> Some Ignore
  | "delete" -> Some Delete
  | "banish" -> Some Banish
  | _ -> None

type thread_data =
  { subject : string
  ; lng : float
  ; lat : float
  }

type post =
  { id : string
  ; emojid : string
  ; parent_id : string
  ; date : float
  ; user_id : string
  ; nick : string
  ; comment : string
  ; image_info : (string * string) option
  ; tags : string list
  ; replies : string list
  ; citations : string list
  }

type t =
  | Op of thread_data * post
  | Post of post

let () =
  let tables =
    [| (unit ->. unit)
         "CREATE TABLE IF NOT EXISTS post_user (post_id TEXT, user_id TEXT, \
          PRIMARY KEY(post_id), FOREIGN KEY(user_id) REFERENCES user(user_id) \
          ON DELETE CASCADE)"
     ; (* one row for each thread, with thread's data *)
       (unit ->. unit)
         "CREATE TABLE IF NOT EXISTS thread_info (thread_id TEXT, subject \
          TEXT, lat FLOAT, lng FLOAT, FOREIGN KEY(thread_id) REFERENCES \
          post_user(post_id) ON DELETE CASCADE)"
     ; (* map thread and reply to the thread *)
       (unit ->. unit)
         "CREATE TABLE IF NOT EXISTS thread_post (thread_id TEXT, post_id \
          TEXT, FOREIGN KEY(thread_id) REFERENCES post_user(post_id) ON DELETE \
          CASCADE, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON \
          DELETE CASCADE)"
     ; (unit ->. unit)
         "CREATE TABLE IF NOT EXISTS post_replies (post_id TEXT, reply_id \
          TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
          CASCADE, FOREIGN KEY(reply_id) REFERENCES post_user(post_id) ON \
          DELETE CASCADE)"
     ; (unit ->. unit)
         "CREATE TABLE IF NOT EXISTS post_citations (post_id TEXT, cited_id \
          TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
          CASCADE, FOREIGN KEY(cited_id) REFERENCES post_user(post_id) ON \
          DELETE CASCADE)"
     ; (unit ->. unit)
         "CREATE TABLE IF NOT EXISTS post_date (post_id TEXT, date FLOAT, \
          FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
          CASCADE)"
     ; (unit ->. unit)
         "CREATE TABLE IF NOT EXISTS post_comment (post_id TEXT, comment TEXT, \
          FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
          CASCADE)"
     ; (unit ->. unit)
         "CREATE TABLE IF NOT EXISTS post_tags (post_id TEXT, tag TEXT, \
          FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
          CASCADE)"
     ; (unit ->. unit)
         "CREATE TABLE IF NOT EXISTS report (user_id TEXT, reason TEXT, date \
          FLOAT,post_id TEXT, FOREIGN KEY(post_id) REFERENCES \
          post_user(post_id) ON DELETE CASCADE, FOREIGN KEY(user_id) \
          REFERENCES user(user_id) ON DELETE CASCADE)"
    |]
  in
  if
    Array.exists Result.is_error
      (Array.map (fun query -> Db.exec query ()) tables)
  then Dream.error (fun log -> log "can't create babillard's tables")

module Q = struct
  let upload_report =
    Db.exec
    @@ (tup4 string string float string ->. unit)
         "INSERT INTO report VALUES (?,?,?,?)"

  let get_reports =
    Db.collect_list
    @@ (unit ->* tup4 string string float string) "SELECT * FROM report"

  let upload_post_id =
    Db.exec
    @@ (tup2 string string ->. unit) "INSERT INTO post_user VALUES (?,?)"

  let upload_thread_info =
    Db.exec
    @@ (tup4 string string float float ->. unit)
         "INSERT INTO thread_info VALUES (?,?,?,?)"

  let upload_thread_post =
    Db.exec
    @@ (tup2 string string ->. unit) "INSERT INTO thread_post VALUES (?,?)"

  let upload_post_reply =
    Db.exec
    @@ (tup2 string string ->. unit) "INSERT INTO post_replies VALUES (?,?)"

  let upload_post_comment =
    Db.exec
    @@ (tup2 string string ->. unit) "INSERT INTO post_comment VALUES (?,?)"

  let upload_post_tag =
    Db.exec
    @@ (tup2 string string ->. unit) "INSERT INTO post_tags VALUES (?,?)"

  let upload_post_date =
    Db.exec @@ (tup2 string float ->. unit) "INSERT INTO post_date VALUES (?,?)"

  let get_post_user_id =
    Db.find
    @@ (string ->! string) "SELECT user_id FROM post_user WHERE post_id=?"

  let get_post_comment =
    Db.find
    @@ (string ->! string) "SELECT comment FROM post_comment WHERE post_id=?"

  let get_post_tags =
    Db.collect_list
    @@ (string ->* string) "SELECT tag FROM post_tags WHERE post_id=?"

  let get_post_date =
    Db.find @@ (string ->! float) "SELECT date FROM post_date WHERE post_id=?"

  let get_post_citations =
    Db.collect_list
    @@ (string ->* string) "SELECT post_id FROM post_citations WHERE post_id=?"

  let get_post_replies =
    Db.collect_list
    @@ (string ->* string) "SELECT reply_id FROM post_replies WHERE post_id=?"

  let get_thread_posts =
    Db.collect_list
    @@ (string ->* string) "SELECT post_id FROM thread_post WHERE thread_id=?"

  let count_thread_posts =
    Db.find
    @@ (string ->! int)
         "SELECT COUNT(post_id) FROM thread_post WHERE thread_id=?"

  let get_is_post =
    Db.find
    @@ (string ->! string)
         "SELECT post_id FROM post_user WHERE post_id=? LIMIT 1"

  let get_post_thread =
    Db.find
    @@ (string ->! string)
         "SELECT thread_id FROM thread_post WHERE post_id=? LIMIT 1"

  let get_thread_info =
    Db.find
    @@ (string ->! tup3 string float float)
         "SELECT subject,lat,lng FROM thread_info WHERE thread_id=?"

  let get_threads =
    Db.collect_list @@ (unit ->* string) "SELECT thread_id FROM thread_info"

  let delete_post =
    Db.exec @@ (string ->. unit) "DELETE FROM post_user WHERE post_id=?"
end

let ignore_report =
  Db.exec @@ (string ->. unit) "DELETE FROM report WHERE post_id=?"

(*TODO switch to markdown !*)
(* insert html into the comment, and keep tracks of citations :
       -wraps lines starting with ">" with a <span class="quote">
       -make raw posts uuid into links
   (*TODO fix bad link if post is in other thread*)
       -keeps tracks of every post cited in this comment
      - add <br> at each line *)
let parse_comment comment =
  let citations = ref [] in

  let pp_word fmt w =
    let trim_w = String.trim w in
    (* '>' is '&gt;' after html_escape *)
    if String.length trim_w >= 8 then
      let sub_w = String.sub trim_w 8 (String.length trim_w - 8) in
      if
        String.starts_with ~prefix:{|&gt;&gt;|} trim_w
        && Option.is_some (Uuidm.of_string sub_w)
      then begin
        citations := sub_w :: !citations;
        Format.fprintf fmt {|<a href="#%s">%s</a>|} sub_w w
      end
      else Format.pp_print_string fmt w
    else Format.pp_print_string fmt w
  in
  let pp_line fmt l =
    let trim_w = String.trim l in
    (*insert quote*)
    let words = String.split_on_char ' ' l in
    if
      String.starts_with ~prefix:{|&gt;|} trim_w
      && not (String.starts_with ~prefix:{|&gt;&gt;|} trim_w)
    then
      Format.fprintf fmt {|<span class="quote">%a</span>|}
        (Format.pp_print_list ~pp_sep:Format.pp_print_space pp_word)
        words
    else Format.pp_print_list ~pp_sep:Format.pp_print_space pp_word fmt words
  in

  let comment = String.trim comment in
  let lines = String.split_on_char '\n' comment in
  (*insert <br>*)
  let comment =
    Format.asprintf "%a"
      (Format.pp_print_list
         ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n<br>")
         pp_line )
      lines
  in
  (* remove duplicate cited_id *)
  let citations = List.sort_uniq String.compare !citations in
  (comment, citations)

let upload_post ~image post =
  let thread_data, reply =
    match post with
    | Op (thread_data, reply) -> (Some thread_data, reply)
    | Post reply -> (None, reply)
  in
  let { id; parent_id; date; user_id; comment; tags; citations; _ } = reply in

  let* () = Q.upload_post_id (id, user_id) in
  let* () = Q.upload_post_comment (id, comment) in
  let* () = Q.upload_post_date (id, date) in
  let* () = Q.upload_thread_post (parent_id, id) in
  let* () =
    match image with None -> Ok () | Some image -> Image.upload image id
  in
  match unwrap_list (fun tag -> Q.upload_post_tag (id, tag)) tags with
  | Error _e as e -> e
  | Ok _ -> (
    match
      unwrap_list (fun cited_id -> Q.upload_post_reply (cited_id, id)) citations
    with
    | Error _e as e -> e
    | Ok _ ->
      let* () =
        match thread_data with
        | None -> Ok ()
        | Some { subject; lng; lat } ->
          Q.upload_thread_info (id, subject, lat, lng)
      in
      Ok id )

let build_reply ~comment ~image_info ~tag_list ?parent_id user_id =
  let comment = Dream.html_escape comment in
  let id = Uuidm.to_string (Uuidm.v4_gen App.random_state ()) in
  (* parent_id is None if this reply is supposed to be a new thread *)
  let parent_id = Option.value parent_id ~default:id in
  if Option.is_none (Uuidm.of_string parent_id) then Error "invalid thread id"
  else if String.length comment > 10000 then Error "invalid comment"
  else if List.length tag_list > 30 then Error "too much tags"
  else if List.exists (fun tag -> String.length tag > 100) tag_list then
    Error "tag too long"
  else if Option.is_none image_info && String.length (String.trim comment) = 0
  then Error "Your post must contain an image or a comment"
  else
    let tag_list =
      List.map String.lowercase_ascii
      @@ List.sort_uniq String.compare
      @@ List.filter (( <> ) "")
      @@ List.map String.trim
      @@ List.map Dream.html_escape tag_list
    in
    let date = Unix.time () in
    let comment, citations = parse_comment comment in
    let* nick = User.get_nick user_id in
    let* emojid = Emojid.make id in
    let reply =
      { id
      ; emojid
      ; parent_id
      ; date
      ; user_id
      ; nick
      ; comment
      ; image_info
      ; tags = tag_list
      ; replies = []
      ; citations
      }
    in
    Ok reply

let build_op ~comment ~image_info ~tag_list ~categories ~subject ~lat ~lng
    user_id =
  let subject = Dream.html_escape subject in
  if List.exists (fun s -> not (List.mem s App.categories)) categories then
    Error "Invalid category"
  else
    let tag_list = categories @ tag_list in
    (* TODO latlng validation? *)
    let is_valid_latlng = true in
    if not is_valid_latlng then Error "Invalid coordinate"
    else if String.length subject > 600 then Error "Invalid subject"
    else
      let* reply = build_reply ~comment ~image_info ~tag_list user_id in
      Ok ({ subject; lng; lat }, reply)

let make_post ~comment ?image_input ~tags ~op_or_reply_data user_id =
  let tag_list = String.split_on_char ',' tags in
  let* image, image_info =
    match image_input with
    | None -> Ok (None, None)
    | Some image_input ->
      let* image = Image.make_image image_input in
      Ok (Some image, Some (image.name, image.alt))
  in
  let* post =
    match op_or_reply_data with
    | `Reply_data parent_id ->
      let* reply =
        build_reply ~comment ~image_info ~tag_list ~parent_id user_id
      in
      Ok (Post reply)
    | `Op_data (categories, subject, lat, lng) ->
      let* thread_data, reply =
        build_op ~comment ~image_info ~tag_list ~categories ~subject ~lat ~lng
          user_id
      in
      Ok (Op (thread_data, reply))
  in
  upload_post ~image post

(* true if post is an op too *)
let post_exist id = Result.is_ok (Q.get_is_post id)

let get_post id =
  let* emojid = Emojid.get id in
  let* parent_id = Q.get_post_thread id in
  let* user_id = Q.get_post_user_id id in
  let* nick = User.get_nick user_id in
  let* comment = Q.get_post_comment id in
  let* date = Q.get_post_date id in
  let* image_info = Image.get_info id in

  let* tags = Q.get_post_tags id in
  let* replies = Q.get_post_replies id in
  let* citations = Q.get_post_citations id in
  let reply =
    { id
    ; emojid
    ; parent_id
    ; date
    ; user_id
    ; nick
    ; comment
    ; image_info
    ; tags
    ; replies
    ; citations
    }
  in
  Ok reply

let get_thread_data id =
  let* subject, lat, lng = Q.get_thread_info id in
  Ok { subject; lat; lng }

let get_op id =
  let* thread_data = get_thread_data id in
  let* post = get_post id in
  Ok (thread_data, post)

let get_posts ids = unwrap_list get_post ids

let get_ops ids = unwrap_list get_op ids

let try_delete_post ~user_id id =
  let* post = get_post id in
  if post.user_id = user_id || User.is_admin user_id then Q.delete_post id
  else Error "You can only delete your posts"

let report ~user_id ~reason id =
  if not (post_exist id) then Error "This post exists not"
  else if String.length reason > 2000 then Error "Your reason is too long.."
  else
    let reason = Dream.html_escape reason in
    let date = Unix.time () in
    Q.upload_report (user_id, reason, date, id)

let get_reports () =
  let* reports = Q.get_reports () in
  let* posts =
    unwrap_list (fun (_reporter_id, _reason, _date, id) -> get_post id) reports
  in
  (* add reporter_nick to reports so we can display it *)
  let* reports =
    unwrap_list
      (fun (reporter_id, reason, date, id) ->
        let* reporter_nick = User.get_nick reporter_id in
        Ok (reporter_id, reporter_nick, reason, date, id) )
      reports
  in
  Ok (posts, reports)