geochan/src/db_image.ml

(* TODO
   - delete: error if does not exists
   - better upload (insert/update)
   - use join *)
open Syntax
open Err
open Types
open Caqti_request.Infix
open Caqti_type
open Caqti_db

let post_tbl_prefix, post_key_reference = ("post_", "post(id)")

let avatar_tbl_prefix, avatar_key_reference = ("user_", "user(user_id)")

let () =
  let mk_tables id_kind prefix reference_tbl =
    [| Fmt.kstr (unit ->. unit)
         "CREATE TABLE IF NOT EXISTS %simage_info (id %s, md5 TEXT, mime TEXT, \
          w INTEGER, h INTEGER, thumb_w INTEGER, thumb_h INTEGER, name TEXT, \
          alt TEXT, FOREIGN KEY(id) REFERENCES %s ON DELETE CASCADE)"
         prefix id_kind reference_tbl
     ; Fmt.kstr (unit ->. unit)
         "CREATE TABLE IF NOT EXISTS %simage_content (id %s, content TEXT, \
          FOREIGN KEY(id) REFERENCES %s ON DELETE CASCADE)"
         prefix id_kind reference_tbl
     ; Fmt.kstr (unit ->. unit)
         "CREATE TABLE IF NOT EXISTS %simage_thumbnail (id %s, content TEXT, \
          FOREIGN KEY(id) REFERENCES %s ON DELETE CASCADE)"
         prefix id_kind reference_tbl
    |]
  in
  let tables =
    Array.concat
      [ mk_tables "INTEGER" post_tbl_prefix post_key_reference
      ; mk_tables "TEXT" avatar_tbl_prefix avatar_key_reference
      ]
  in
  Array.iter (fun query -> Db.exec_unsafe query ()) tables

module type T = sig
  type t

  val info : t -> img_info option result

  val data : t -> string option result

  val thumbnail_data : t -> string option result

  val delete : t -> unit result

  val upload : t -> img -> unit result
end

module type A = sig
  type t

  val caqti_t : t Caqti_type.t

  val prefix : string

  val replace_image : bool
end

(* Make(A) => T *)
module Make (M : A) = struct
  include M

  let upload_info =
    Db.exec
    @@ Fmt.kstr
         (t9 caqti_t string string int int int int string string ->. unit)
         "INSERT INTO  %simage_info VALUES (?,?,?,?,?,?,?,?,?)" prefix

  let upload_data =
    Db.exec
    @@ Fmt.kstr
         (t2 caqti_t string ->. unit)
         "INSERT INTO %simage_content VALUES (?,?)" prefix

  let upload_thumbnail_data =
    Db.exec
    @@ Fmt.kstr
         (t2 caqti_t string ->. unit)
         "INSERT INTO %simage_thumbnail VALUES (?,?)" prefix

  let info =
    let f =
      Db.find_opt
        (Fmt.kstr
           (caqti_t ->? t9 caqti_t string string int int int int string string)
           "SELECT * FROM %simage_info WHERE id=?" prefix )
    in
    fun id ->
      let+ opt = f id in
      Option.map
        (fun (_id, md5, mime, w, h, thumb_w, thumb_h, name, alt) ->
          { md5; mime; w; h; thumb_w; thumb_h; name; alt } )
        opt

  let data =
    Db.find_opt
    @@ Fmt.kstr (caqti_t ->? string)
         "SELECT content FROM %simage_content WHERE id=?" prefix

  let thumbnail_data =
    Db.find_opt
    @@ Fmt.kstr (caqti_t ->? string)
         "SELECT content FROM %simage_thumbnail WHERE id=?" prefix

  let delete_info =
    Db.exec
    @@ Fmt.kstr (caqti_t ->. unit) "DELETE FROM %simage_info WHERE id=?" prefix

  let delete_content =
    Db.exec
    @@ Fmt.kstr (caqti_t ->. unit) "DELETE FROM %simage_content WHERE id=?"
         prefix

  let delete_thumbnail =
    Db.exec
    @@ Fmt.kstr (caqti_t ->. unit) "DELETE FROM %simage_thumbnail WHERE id=?"
         prefix

  (* TODO error if does not exists *)
  let delete id =
    let* () = delete_info id in
    let* () = delete_content id in
    delete_thumbnail id

  let upload id image =
    (* TODO do something like
       https://stackoverflow.com/questions/418898/upsert-not-insert-or-replace/4330694#4330694
       instead of deleting then re-inserting to update(or insert on first time).. *)
    let* () = if replace_image then delete id else Ok () in
    (* -- *)
    let { info; data; thumbnail_data } = image in
    let { md5; mime; w; h; thumb_w; thumb_h; name; alt } = info in
    let* () = upload_info (id, md5, mime, w, h, thumb_w, thumb_h, name, alt) in
    let* () = upload_data (id, data) in
    upload_thumbnail_data (id, thumbnail_data)
end

module P = Make (struct
  type t = int

  let caqti_t = Caqti_type.int

  let prefix = post_tbl_prefix

  let replace_image = false
end)

module U = Make (struct
  type t = string

  let caqti_t = Caqti_type.string

  let prefix = avatar_tbl_prefix

  let replace_image = true
end)