put all image stuff in image.ml, make thumbnail for avatars
This commit is contained in:
parent
dbc2139511
commit
9ca17a8840
7 changed files with 240 additions and 186 deletions
200
src/image.ml
Normal file
200
src/image.ml
Normal file
|
|
@ -0,0 +1,200 @@
|
|||
open Syntax
|
||||
open Db
|
||||
|
||||
type t =
|
||||
{ name : string
|
||||
; alt : string
|
||||
; content : string
|
||||
; thumbnail : string
|
||||
}
|
||||
|
||||
module Q = struct
|
||||
let create_info_table =
|
||||
Caqti_request.exec 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_request.exec 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_request.exec 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_request.exec
|
||||
Caqti_type.(tup3 string string string)
|
||||
"INSERT INTO image_info VALUES (?,?,?);"
|
||||
|
||||
let upload_content =
|
||||
Caqti_request.exec
|
||||
Caqti_type.(tup2 string string)
|
||||
"INSERT INTO image_content VALUES (?,?);"
|
||||
|
||||
let upload_thumbnail =
|
||||
Caqti_request.exec
|
||||
Caqti_type.(tup2 string string)
|
||||
"INSERT INTO image_thumbnail VALUES (?,?);"
|
||||
|
||||
let get_post_content =
|
||||
Caqti_request.find_opt Caqti_type.string Caqti_type.string
|
||||
"SELECT content FROM image_content WHERE post_id=?;"
|
||||
|
||||
let get_post_thumbnail =
|
||||
Caqti_request.find_opt Caqti_type.string Caqti_type.string
|
||||
"SELECT content FROM image_thumbnail WHERE post_id=?;"
|
||||
|
||||
let get_post_info =
|
||||
Caqti_request.find_opt 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_request.exec 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_request.exec 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_request.exec
|
||||
Caqti_type.(tup2 string string)
|
||||
"INSERT INTO user_image_content VALUES (?,?);"
|
||||
|
||||
let upload_user_thumbnail =
|
||||
Caqti_request.exec
|
||||
Caqti_type.(tup2 string string)
|
||||
"INSERT INTO user_image_thumbnail VALUES (?,?);"
|
||||
|
||||
let get_user_content =
|
||||
Caqti_request.find_opt Caqti_type.string Caqti_type.string
|
||||
"SELECT content FROM user_image_content WHERE user_id=?;"
|
||||
|
||||
let get_user_thumbnail =
|
||||
Caqti_request.find_opt Caqti_type.string Caqti_type.string
|
||||
"SELECT content FROM user_image_thumbnail WHERE user_id=?;"
|
||||
|
||||
let delete_user_content =
|
||||
Caqti_request.exec Caqti_type.string
|
||||
"DELETE FROM user_image_content WHERE user_id=?;"
|
||||
|
||||
let delete_user_thumbnail =
|
||||
Caqti_request.exec Caqti_type.string
|
||||
"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) )
|
||||
Loading…
Add table
Add a link
Reference in a new issue