From 9ca17a8840ab9d1f28d7b9d25acefa2063d9fd94 Mon Sep 17 00:00:00 2001 From: Swrup Date: Mon, 4 Apr 2022 14:39:25 +0200 Subject: [PATCH] put all image stuff in image.ml, make thumbnail for avatars --- src/app.ml | 2 + src/babillard.ml | 106 ++----------------------- src/db.ml | 38 --------- src/dune | 1 + src/image.ml | 200 +++++++++++++++++++++++++++++++++++++++++++++++ src/permap.ml | 39 ++++----- src/user.ml | 40 +++------- 7 files changed, 240 insertions(+), 186 deletions(-) create mode 100644 src/image.ml diff --git a/src/app.ml b/src/app.ml index afc1afe..ed1b3c7 100644 --- a/src/app.ml +++ b/src/app.ml @@ -88,3 +88,5 @@ let get_dirs name = let admins = get_dirs "admin" let categories = List.sort_uniq compare (get_dirs "category") + +let random_state = Random.State.make_self_init () diff --git a/src/babillard.ml b/src/babillard.ml index 8526db4..301e965 100644 --- a/src/babillard.ml +++ b/src/babillard.ml @@ -36,13 +36,6 @@ type post = ; citations : string list } -type image = - { name : string - ; alt : string - ; content : string - ; thumbnail : string - } - type t = | Op of thread_data * post | Post of post @@ -90,22 +83,6 @@ module Q = struct "CREATE TABLE IF NOT EXISTS post_comment (post_id TEXT, comment TEXT, \ FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE CASCADE);" - let create_image_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_image_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_image_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 create_post_tags_table = Caqti_request.exec Caqti_type.unit "CREATE TABLE IF NOT EXISTS post_tags (post_id TEXT, tag TEXT, FOREIGN \ @@ -146,21 +123,6 @@ module Q = struct Caqti_type.(tup2 string string) "INSERT INTO thread_post VALUES (?,?);" - let upload_image_info = - Caqti_request.exec - Caqti_type.(tup3 string string string) - "INSERT INTO image_info VALUES (?,?,?);" - - let upload_image_content = - Caqti_request.exec - Caqti_type.(tup2 string string) - "INSERT INTO image_content VALUES (?,?);" - - let upload_image_thumbnail = - Caqti_request.exec - Caqti_type.(tup2 string string) - "INSERT INTO image_thumbnail VALUES (?,?);" - let upload_post_reply = Caqti_request.exec Caqti_type.(tup2 string string) @@ -189,19 +151,6 @@ module Q = struct Caqti_request.find Caqti_type.string Caqti_type.string "SELECT comment FROM post_comment WHERE post_id=?;" - let get_post_image_content = - Caqti_request.find_opt Caqti_type.string Caqti_type.string - "SELECT content FROM image_content WHERE post_id=?;" - - let get_post_image_thumbnail = - Caqti_request.find_opt Caqti_type.string Caqti_type.string - "SELECT content FROM image_thumbnail WHERE post_id=?;" - - let get_post_image_info = - Caqti_request.find_opt Caqti_type.string - Caqti_type.(tup2 string string) - "SELECT image_name,image_alt FROM image_info WHERE post_id=?;" - let get_post_tags = Caqti_request.collect Caqti_type.string Caqti_type.string "SELECT tag FROM post_tags WHERE post_id=?;" @@ -261,9 +210,6 @@ let () = ; Q.create_post_citations_table ; Q.create_post_date_table ; Q.create_post_comment_table - ; Q.create_image_info_table - ; Q.create_image_content_table - ; Q.create_image_thumbnail_table ; Q.create_post_tags_table ; Q.create_report_table |] @@ -273,28 +219,6 @@ let () = (Array.map (fun query -> Db.exec query ()) tables) then Dream.error (fun log -> log "can't create babillard's tables") -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 - (*TODO switch to markdown !*) (* insert html into the comment, and keep tracks of citations : -wraps lines starting with ">" with a @@ -354,24 +278,14 @@ let upload_post ~image post = | Op (thread_data, reply) -> (Some thread_data, reply) | Post reply -> (None, reply) in - let { id; parent_id; date; user_id; comment; image_info; tags; citations; _ } - = - reply - in + let { id; parent_id; date; user_id; comment; tags; citations; _ } = reply in let^ () = Db.exec Q.upload_post_id (id, user_id) in let^ () = Db.exec Q.upload_post_comment (id, comment) in let^ () = Db.exec Q.upload_post_date (id, date) in let^ () = Db.exec Q.upload_thread_post (parent_id, id) in let* () = - match image with - | None -> Ok () - | Some image -> - assert (Option.is_some image_info); - let^ () = Db.exec Q.upload_image_info (id, image.name, image.alt) in - let^ () = Db.exec Q.upload_image_content (id, image.content) in - let^ () = Db.exec Q.upload_image_thumbnail (id, image.thumbnail) in - Ok () + match image with None -> Ok () | Some image -> Image.upload image id in let^ _unit_list = unwrap_list (fun tag -> Db.exec Q.upload_post_tag (id, tag)) tags @@ -389,7 +303,7 @@ let upload_post ~image post = 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 random_state ()) 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" @@ -443,9 +357,7 @@ let build_op ~comment ~image_info ~tag_list ~categories ~subject ~lat ~lng Ok op let build_image image_input = - let* name, alt, content = clean_image image_input in - let* thumbnail = make_thumbnail content in - let image = { name; alt; content; thumbnail } in + let* image = Image.make_image image_input in Ok image let make_post ~comment ?image_input ~tags ~op_or_reply_data user_id = @@ -473,14 +385,6 @@ let make_post ~comment ?image_input ~tags ~op_or_reply_data user_id = in upload_post ~image post -let get_post_image_content id = - let^? content = Db.find_opt Q.get_post_image_content id in - Ok content - -let get_post_image_thumbnail id = - let^? content = Db.find_opt Q.get_post_image_thumbnail id in - Ok content - let thread_exist id = Result.is_ok (Db.find Q.get_is_thread id) (* true if post is an op too *) @@ -492,7 +396,7 @@ let get_post id = let* nick = User.get_nick user_id in let^ comment = Db.find Q.get_post_comment id in let^ date = Db.find Q.get_post_date id in - let^ image_info = Db.find_opt Q.get_post_image_info id in + let* image_info = Image.get_info id in let^ tags = Db.collect_list Q.get_post_tags id in let^ replies = Db.collect_list Q.get_post_replies id in diff --git a/src/db.ml b/src/db.ml index 5ac6e47..3c78bd9 100644 --- a/src/db.ml +++ b/src/db.ml @@ -11,8 +11,6 @@ let db = Filename.concat db_root "permap.db" let db_uri = Format.sprintf "sqlite3://%s" db -let random_state = Random.State.make_self_init () - module Db = (val Caqti_blocking.connect (Uri.of_string db_uri) |> Caqti_blocking.or_fail) @@ -34,39 +32,3 @@ let () = | Error _e -> Format.eprintf "db error@\n"; exit 1 - -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 clean_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 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" -> Ok (name, alt, content) - | _unsupported_mime_type -> - Error (Format.sprintf "unsupported image type: %s" mime) ) diff --git a/src/dune b/src/dune index 600b3fb..bff5792 100644 --- a/src/dune +++ b/src/dune @@ -9,6 +9,7 @@ db delete_page discuss + image login permap pp_babillard diff --git a/src/image.ml b/src/image.ml new file mode 100644 index 0000000..532def0 --- /dev/null +++ b/src/image.ml @@ -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) ) diff --git a/src/permap.ml b/src/permap.ml index 8aed574..a806edb 100644 --- a/src/permap.ml +++ b/src/permap.ml @@ -293,32 +293,33 @@ let profile_post request = | `Wrong_session _ | `Wrong_content_type -> Dream.empty `Bad_Request ) ) -let avatar_image request = +let get_post_image ~thumbnail request = + let id = Dream.param request "id" in + let image = + if thumbnail then Image.get_thumbnail id else Image.get_content id + in + match image with + | Error e -> render_unsafe e request + | Ok image_opt -> ( + match image_opt with + | None -> Dream.respond ~status:`Not_Found "Image does not exists" + | Some image -> Dream.respond ~headers:[ ("Content-Type", "image") ] image ) + +let get_avatar_image request = let nick = Dream.param request "user" in match User.get_user_id_from_nick nick with | Error _e -> Dream.respond ~status:`Not_Found "User does not exists" | Ok user_id -> ( - let avatar = User.get_avatar user_id in + let avatar = Image.get_user_content user_id in match avatar with | Ok (Some avatar) -> Dream.respond ~headers:[ ("Content-Type", "image") ] avatar - | Ok None | Error _ -> ( + | Ok None -> ( match Content.read "/assets/img/default_avatar.png" with | None -> failwith "can't find default avatar" | Some avatar -> - Dream.respond ~headers:[ ("Content-Type", "image") ] avatar ) ) - -let get_post_image ~thumbnail request = - let post_id = Dream.param request "post_id" in - if Babillard.post_exist post_id then - let image = - if thumbnail then Babillard.get_post_image_thumbnail post_id - else Babillard.get_post_image_content post_id - in - match image with - | Ok image -> Dream.respond ~headers:[ ("Content-Type", "image") ] image - | Error _ -> Dream.empty `Not_Found - else Dream.respond ~status:`Not_Found "Image does not exists" + Dream.respond ~headers:[ ("Content-Type", "image") ] avatar ) + | Error e -> render_unsafe e request ) let markers request = let markers = Pp_babillard.get_markers () in @@ -467,8 +468,8 @@ let routes = ; get_ "/discuss" Discuss.render ; get_ "/discuss/:comrade_id" Discuss.render_one ; post "/discuss/:comrade_id" Discuss.post - ; get_ "/img/:post_id" (get_post_image ~thumbnail:false) - ; get_ "/img/s/:post_id" (get_post_image ~thumbnail:true) + ; get_ "/img/:id" (get_post_image ~thumbnail:false) + ; get_ "/img/s/:id" (get_post_image ~thumbnail:true) ; get_ "/login" login_get ; post "/login" login_post ; get_ "/logout" logout @@ -482,7 +483,7 @@ let routes = ; get_ "/thread/:thread_id/feed" thread_feed_get ; get_ "/user" user ; get_ "/user/:user" user_profile - ; get_ "/user/:user/avatar" avatar_image + ; get_ "/user/:user/avatar" get_avatar_image ] @ if App.open_registration then diff --git a/src/user.ml b/src/user.ml index 83fabbc..96ae5bb 100644 --- a/src/user.ml +++ b/src/user.ml @@ -7,7 +7,6 @@ type t = ; password : string ; email : string ; bio : string - ; avatar : string ; metadata : (string * string) list } @@ -15,7 +14,7 @@ module Q = struct let create_user_table = Caqti_request.exec Caqti_type.unit "CREATE TABLE IF NOT EXISTS user (user_id TEXT, nick TEXT, password \ - TEXT, email TEXT, bio TEXT, avatar BLOB, PRIMARY KEY(user_id));" + TEXT, email TEXT, bio TEXT, PRIMARY KEY(user_id));" let create_banished_table = Caqti_request.exec Caqti_type.unit @@ -59,9 +58,8 @@ module Q = struct let upload_user = Caqti_request.exec - Caqti_type.( - tup4 string string string Caqti_type.(tup3 string string string)) - "INSERT INTO user VALUES (?, ?, ?, ?, ?, ?);" + Caqti_type.(tup4 string string string Caqti_type.(tup2 string string)) + "INSERT INTO user VALUES (?, ?, ?, ?, ?);" let list_nicks = Caqti_request.collect Caqti_type.unit Caqti_type.string @@ -70,8 +68,7 @@ module Q = struct let get_user = Caqti_request.find Caqti_type.string (* there is no "tup6" *) - Caqti_type.( - tup4 string string string Caqti_type.(tup3 string string string)) + Caqti_type.(tup4 string string string Caqti_type.(tup2 string string)) "SELECT * FROM user WHERE user_id=?;" let update_bio = @@ -106,15 +103,6 @@ module Q = struct Caqti_request.find Caqti_type.string Caqti_type.string "SELECT email FROM user WHERE user_id=?;" - let get_avatar = - Caqti_request.find Caqti_type.string Caqti_type.string - "SELECT avatar FROM user WHERE user_id=?;" - - let upload_avatar = - Caqti_request.exec - Caqti_type.(tup2 string string) - "UPDATE user SET avatar=? WHERE user_id=?;" - let delete_user = Caqti_request.exec Caqti_type.string "DELETE FROM user WHERE user_id=?;" @@ -139,6 +127,8 @@ let () = (Array.map (fun query -> Db.exec query ()) tables) then Dream.error (fun log -> log "can't create user tables") +let exist id = Result.is_ok (Db.find Q.get_user id) + let exist_nick nick = Result.is_ok (Db.find Q.get_user_id_from_nick nick) let exist_email email = Result.is_ok (Db.find Q.get_user_id_from_email email) @@ -153,11 +143,11 @@ let get_user_id_from_nick nick = Ok user_id let get_user user_id = - let^? user_id, nick, password, (email, bio, avatar) = + let^? user_id, nick, password, (email, bio) = Db.find_opt Q.get_user user_id in let* metadata = get_metadata user_id in - Ok { user_id; nick; password; email; bio; avatar; metadata } + Ok { user_id; nick; password; email; bio; metadata } let is_banished login = Result.is_ok (Db.find Q.get_banished (login, login)) @@ -210,10 +200,8 @@ let register ~email ~nick ~password = else let^ nb = Db.find Q.is_already_user (nick, email) in if nb = 0 then - let user_id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in - let^ () = - Db.exec Q.upload_user (user_id, nick, password, (email, "", "")) - in + let user_id = Uuidm.to_string (Uuidm.v4_gen App.random_state ()) in + let^ () = Db.exec Q.upload_user (user_id, nick, password, (email, "")) in let^ () = Db.exec Q.upload_metadata (user_id, Marshal.to_string [] []) in Ok () else Error "nick or email already exists" @@ -248,16 +236,12 @@ let get_email user_id = let^ email = Db.find Q.get_email user_id in Ok email -let get_avatar user_id = - let^ avatar = Db.find Q.get_avatar user_id in - if String.length avatar = 0 then Ok None else Ok (Some avatar) - let upload_avatar files user_id = match files with | [] -> Error "No file provided" | [ (name_opt, content) ] -> - let* _name, _alt, content = clean_image (name_opt, "avatar", content) in - let^ () = Db.exec Q.upload_avatar (content, user_id) in + let* image = Image.make_image (name_opt, "avatar", content) in + let* () = Image.upload_avatar image user_id in Ok () | _files -> Error "More than one file provided"