geochan/src/image.ml

open Db
open Syntax

type t =
  { name : string
  ; alt : string
  ; content : string
  ; thumbnail : string
  }

module Q = struct
  open Caqti_request.Infix

  let create_info_table =
    (Caqti_type.unit ->. Caqti_type.unit)
      "CREATE TABLE IF NOT EXISTS image_info (post_id TEXT, image_name TEXT, \
       image_alt TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON \
       DELETE CASCADE);"

  let create_content_table =
    (Caqti_type.unit ->. Caqti_type.unit)
      "CREATE TABLE IF NOT EXISTS image_content (post_id TEXT, content TEXT, \
       FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE CASCADE);"

  let create_thumbnail_table =
    (Caqti_type.unit ->. Caqti_type.unit)
      "CREATE TABLE IF NOT EXISTS image_thumbnail (post_id TEXT, content TEXT, \
       FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE CASCADE);"

  let upload_info =
    (Caqti_type.(tup3 string string string) ->. Caqti_type.unit)
      "INSERT INTO image_info VALUES (?,?,?);"

  let upload_content =
    (Caqti_type.(tup2 string string) ->. Caqti_type.unit)
      "INSERT INTO image_content VALUES (?,?);"

  let upload_thumbnail =
    (Caqti_type.(tup2 string string) ->. Caqti_type.unit)
      "INSERT INTO image_thumbnail VALUES (?,?);"

  let get_post_content =
    (Caqti_type.string ->? Caqti_type.string)
      "SELECT content FROM image_content WHERE post_id=?;"

  let get_post_thumbnail =
    (Caqti_type.string ->? Caqti_type.string)
      "SELECT content FROM image_thumbnail WHERE post_id=?;"

  let get_post_info =
    (Caqti_type.string ->? Caqti_type.(tup2 string string))
      "SELECT image_name,image_alt FROM image_info WHERE post_id=?;"

  (*avatars*)
  let create_user_content_table =
    (Caqti_type.unit ->. Caqti_type.unit)
      "CREATE TABLE IF NOT EXISTS user_image_content (user_id TEXT, content \
       TEXT, FOREIGN KEY(user_id) REFERENCES user(user_id) ON DELETE CASCADE);"

  let create_user_thumbnail_table =
    (Caqti_type.unit ->. Caqti_type.unit)
      "CREATE TABLE IF NOT EXISTS user_image_thumbnail (user_id TEXT, content \
       TEXT, FOREIGN KEY(user_id) REFERENCES user(user_id) ON DELETE CASCADE);"

  let upload_user_content =
    (Caqti_type.(tup2 string string) ->. Caqti_type.unit)
      "INSERT INTO user_image_content VALUES (?,?);"

  let upload_user_thumbnail =
    (Caqti_type.(tup2 string string) ->. Caqti_type.unit)
      "INSERT INTO user_image_thumbnail VALUES (?,?);"

  let get_user_content =
    (Caqti_type.string ->? Caqti_type.string)
      "SELECT content FROM user_image_content WHERE user_id=?;"

  let get_user_thumbnail =
    (Caqti_type.string ->? Caqti_type.string)
      "SELECT content FROM user_image_thumbnail WHERE user_id=?;"

  let delete_user_content =
    (Caqti_type.string ->. Caqti_type.unit)
      "DELETE FROM user_image_content WHERE user_id=?;"

  let delete_user_thumbnail =
    (Caqti_type.string ->. Caqti_type.unit)
      "DELETE FROM user_image_thumbnail WHERE user_id=?;"
end

let () =
  let tables =
    [| Q.create_info_table
     ; Q.create_content_table
     ; Q.create_thumbnail_table
     ; Q.create_user_content_table
     ; Q.create_user_thumbnail_table
    |]
  in
  if
    Array.exists Result.is_error
      (Array.map (fun query -> Db.exec query ()) tables)
  then Dream.error (fun log -> log "can't create images tables")

let upload image id =
  let^ () = Db.exec Q.upload_info (id, image.name, image.alt) in
  let^ () = Db.exec Q.upload_content (id, image.content) in
  let^ () = Db.exec Q.upload_thumbnail (id, image.thumbnail) in
  Ok ()

let get_content id =
  let^ content = Db.find_opt Q.get_post_content id in
  Ok content

let get_thumbnail id =
  let^ thumbnail = Db.find_opt Q.get_post_thumbnail id in
  Ok thumbnail

let get_info id =
  let^ info = Db.find_opt Q.get_post_info id in
  Ok info

let upload_avatar image id =
  let^ () = Db.exec Q.delete_user_content id in
  let^ () = Db.exec Q.delete_user_thumbnail id in
  let^ () = Db.exec Q.upload_user_content (id, image.content) in
  let^ () = Db.exec Q.upload_user_thumbnail (id, image.thumbnail) in
  Ok ()

let get_user_content id =
  let^ content = Db.find_opt Q.get_user_content id in
  Ok content

let get_user_thumbnail id =
  let^ thumbnail = Db.find_opt Q.get_user_thumbnail id in
  Ok thumbnail

let make_thumbnail content =
  let open Bos in
  (* jpp *)
  let ( let* ) o f =
    Result.fold ~ok:f ~error:(function `Msg s -> Result.error s) o
  in

  let* image_file = OS.File.tmp "%s" in
  let* thumb_file = OS.File.tmp "%s_thumb" in
  let* () = OS.File.write image_file content in
  let cmd =
    Cmd.(
      v "convert" % "-define" % "jpeg:size=700x700" % p image_file
      % "-auto-orient" % "-thumbnail" % "300x300>" % "-unsharp" % "0x.5"
      % "-format" % "jpg" % p thumb_file)
  in
  let* () = OS.Cmd.run cmd in
  let* thumbnail = OS.File.read thumb_file in
  let* () = OS.File.delete image_file in
  let* () = OS.File.delete thumb_file in
  Ok thumbnail

let mime =
  let database = Conan.Process.database ~tree:Conan_light.tree in
  fun content ->
    match Conan_string.run ~database content with
    | Ok m -> Conan.Metadata.mime m
    | Error _ -> None

let make_image image =
  let max_name = 1000 in
  let max_alt = 3000 in
  let max_content = 4200000 in

  let name, alt, content = image in
  let name =
    match name with
    | Some name -> Dream.html_escape name
    | None ->
      (* make up random name if no name was given *)
      Uuidm.to_string (Uuidm.v4_gen App.random_state ())
  in
  let alt = if String.trim alt = "" then name else alt in
  if String.length name > max_name then
    Error (Format.sprintf "Image name too long: More than %dB" max_name)
  else if String.length alt > max_alt then
    Error (Format.sprintf "Image description too long: More than %dB" max_alt)
  else if String.length content > max_content then
    Error (Format.sprintf "Image size too big: More than %dB" max_content)
  else
    match mime content with
    | None -> Error "invalid image type"
    | Some mime -> (
      match mime with
      | "image/jpeg" | "image/png" | "image/webp" -> (
        match make_thumbnail content with
        | Error e -> Error e
        | Ok thumbnail -> Ok { name; alt; content; thumbnail } )
      | _unsupported_mime_type ->
        Error (Format.sprintf "unsupported image type: %s" mime) )