add thumbnail

src/babillard.ml

@@ -40,6 +40,7 @@ type image =
   { name : string
   ; alt : string
   ; content : string
+  ; thumbnail : string
   }
 
 type t =
@@ -97,9 +98,13 @@ module Q = struct
 
   let create_image_content_table =
     Caqti_request.exec Caqti_type.unit
-      "CREATE TABLE IF NOT EXISTS image_content (post_id TEXT,image_content \
-       TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
-       CASCADE);"
+      "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
@@ -151,6 +156,11 @@ module Q = struct
       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)
@@ -181,7 +191,11 @@ module Q = struct
 
   let get_post_image_content =
     Caqti_request.find_opt Caqti_type.string Caqti_type.string
-      "SELECT image_content FROM image_content WHERE post_id=?;"
+      "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
@@ -249,6 +263,7 @@ let () =
      ; 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
     |]
@@ -271,6 +286,41 @@ let clean_image image =
   else if String.length alt > 1000 then Error "Image description too long"
   else Ok (name, alt, content)
 
+let make_thumbnail content =
+  try
+    let filename =
+      Filename.concat "/tmp" (Uuidm.to_string (Uuidm.v4_gen random_state ()))
+    in
+    let thumb_filename = filename ^ "_small" in
+    let oc = open_out filename in
+    let fmt = Format.formatter_of_out_channel oc in
+    Format.fprintf fmt "%s" content;
+    close_out oc;
+    let command =
+      Format.sprintf
+        "convert -define jpeg:size=700x700 %s -auto-orient -thumbnail \
+         '300x300>' -unsharp 0x.5 -format jpg %s"
+        filename thumb_filename
+    in
+    let resize_exit_code = Sys.command command in
+    if resize_exit_code <> 0 then
+      Error
+        (Format.sprintf "thumbnail: resize command failed with exit code: %d"
+           resize_exit_code )
+    else
+      let ic = open_in thumb_filename in
+      let thumbnail = really_input_string ic (in_channel_length ic) in
+      close_in ic;
+
+      let delete = Format.sprintf "rm %s; rm %s" filename thumb_filename in
+      let delete_exit_code = Sys.command delete in
+      if delete_exit_code <> 0 then
+        Error
+          (Format.sprintf "thumbnail: delete command failed with exit code: %d"
+             delete_exit_code )
+      else Ok thumbnail
+  with Sys_error e -> Error e
+
 (*TODO switch to markdown !*)
 (* insert html into the comment, and keep tracks of citations :
        -wraps lines starting with ">" with a <span class="quote">
@@ -346,6 +396,7 @@ let upload_post ~image post =
       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 ()
   in
   let^ _unit_list =
@@ -417,7 +468,8 @@ let build_op ~comment ~image_info ~tag_list ~categories ~subject ~lat ~lng
 
 let build_image image_input =
   let* name, alt, content = clean_image image_input in
-  let image = { name; alt; content } in
+  let* thumbnail = make_thumbnail content in
+  let image = { name; alt; content; thumbnail } in
   Ok image
 
 let make_post ~comment ?image_input ~tags ~op_or_reply_data user_id =
@@ -449,6 +501,10 @@ 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 *)

src/content/assets/css/style.css

@@ -56,12 +56,12 @@ blockquote.blockquote {
 }
 
 .post-image {
-  max-width: 250px;
-  height: auto;
+  max-width: 300px;
+  max-height: 300px;
 }
 
 .post-image-big {
-  max-width: 750px;
+  max-width: 1200px;
   height: auto;
 }
 

src/js/js_pretty_post.ml

@@ -21,13 +21,24 @@ let image_click post_image event =
   in
   let new_class =
     match of_string current_class with
-    | Some image_size ->
-      to_string (match image_size with Big -> Small | Small -> Big)
+    | Some image_size -> ( match image_size with Big -> Small | Small -> Big )
     | None -> failwith "invalid image class name"
   in
   ignore
   @@ Jv.call post_image "setAttribute"
-       [| Jv.of_string "class"; Jv.of_string new_class |];
+       [| Jv.of_string "class"; Jv.of_string (to_string new_class) |];
+  let id =
+    Jv.to_string
+    @@ Jv.call post_image "getAttribute" [| Jv.of_string "data-id" |]
+  in
+  let src =
+    match new_class with
+    | Small -> Format.sprintf "/img/s/%s" id
+    | Big -> Format.sprintf "/img/%s" id
+  in
+  ignore
+  @@ Jv.call post_image "setAttribute"
+       [| Jv.of_string "src"; Jv.of_string src |];
   (*prevent redirect to /img/:img*)
   ignore @@ Jv.call event "preventDefault" [||];
   ignore @@ Jv.call event "stopPropagation" [||]

src/permap.ml

@@ -328,10 +328,13 @@ let avatar_image request =
       | Some avatar ->
         Dream.respond ~headers:[ ("Content-Type", "image") ] avatar ) )
 
-let post_image request =
+let get_post_image ~thumbnail request =
   let post_id = Dream.param request "post_id" in
   if Babillard.post_exist post_id then
-    let image = Babillard.get_post_image_content post_id in
+    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
@@ -481,12 +484,12 @@ let routes =
   ; get_ "/catalog" catalog
   ; get_ "/delete/:post_id" delete_get
   ; post "/delete/:post_id" delete_post
-  ; get_ "/img/:post_id" post_image
+  ; get_ "/img/:post_id" (get_post_image ~thumbnail:false)
+  ; get_ "/img/s/:post_id" (get_post_image ~thumbnail:true)
   ; get_ "/login" login_get
   ; post "/login" login_post
   ; get_ "/logout" logout
   ; get_ "/markers" markers
-  ; get_ "/post_pic/:post_id" post_image
   ; get_ "/profile" profile_get
   ; post "/profile" profile_post
   ; get_ "/report/:post_id" report_get

src/pp_babillard.ml

@@ -29,11 +29,11 @@ let pp_post fmt t =
         {|
     <div class="post-image-container">
         <a href="/img/%s">
-        <img class="post-image" src="/img/%s" alt="%s" title="%s" loading="lazy">
+        <img class="post-image" src="/img/s/%s" alt="%s" title="%s" data-id="%s" loading="lazy">
         </a>
     </div> 
 |}
-        id id image_alt image_alt
+        id id image_alt image_alt id
     | None -> Format.fprintf fmt ""
   in