geochan/src/image.ml

open Syntax
open Caqti_request.Infix
open Caqti_type

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

let () =
  let tables =
    [| (unit ->. 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)"
     ; (unit ->. 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)"
     ; (unit ->. 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)"
     ; (unit ->. 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)"
     ; (unit ->. 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)"
    |]
  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_info =
  Db.exec
  @@ (tup3 string string string ->. unit)
       "INSERT INTO image_info VALUES (?,?,?)"

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

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

let get_content =
  Db.find_opt
  @@ (string ->? string) "SELECT content FROM image_content WHERE post_id=?"

let get_thumbnail =
  Db.find_opt
  @@ (string ->? string) "SELECT content FROM image_thumbnail WHERE post_id=?"

let get_info =
  Db.find_opt
  @@ (string ->? tup2 string string)
       "SELECT image_name,image_alt FROM image_info WHERE post_id=?"

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

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

let get_user_content =
  Db.find_opt
  @@ (string ->? string)
       "SELECT content FROM user_image_content WHERE user_id=?"

let get_user_thumbnail =
  Db.find_opt
  @@ (string ->? string)
       "SELECT content FROM user_image_thumbnail WHERE user_id=?"

let delete_user_content =
  Db.exec @@ (string ->. unit) "DELETE FROM user_image_content WHERE user_id=?"

let delete_user_thumbnail =
  Db.exec
  @@ (string ->. unit) "DELETE FROM user_image_thumbnail WHERE user_id=?"

let upload image id =
  let* () = upload_info (id, image.name, image.alt) in
  let* () = upload_content (id, image.content) in
  upload_thumbnail (id, image.thumbnail)

let upload_avatar image id =
  let* () = delete_user_content id in
  let* () = delete_user_thumbnail id in
  let* () = upload_user_content (id, image.content) in
  upload_user_thumbnail (id, image.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" | "image/gif" -> (
        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) )