add alt text field

src/babillard.ml

@@ -21,7 +21,7 @@ type op =
   ; nick : string
   ; subject : string
   ; comment : string
-  ; image : string * string
+  ; image : string * string * string
   ; tags : string list
   ; longitude : float
   ; latitude : float
@@ -35,7 +35,7 @@ type reply =
   ; date : int
   ; nick : string
   ; comment : string
-  ; image : (string * string) option
+  ; image : (string * string * string) option
   ; tags : string list
   ; replies : string list
   ; citations : string list
@@ -108,7 +108,8 @@ module Q = struct
   let create_post_image_table =
     Caqti_request.exec Caqti_type.unit
       "CREATE TABLE IF NOT EXISTS post_image (post_id TEXT, image_name TEXT, \
-       image_content, FOREIGN KEY(post_id) REFERENCES post_user(post_id));"
+       image_content TEXT, image_alt TEXT, FOREIGN KEY(post_id) REFERENCES \
+       post_user(post_id));"
 
   let create_post_gps_table =
     Caqti_request.exec Caqti_type.unit
@@ -137,8 +138,8 @@ module Q = struct
 
   let upload_post_image =
     Caqti_request.exec
-      Caqti_type.(tup3 string string string)
+      Caqti_type.(tup4 string string string string)
-      "INSERT INTO post_image VALUES (?,?,?);"
+      "INSERT INTO post_image VALUES (?,?,?,?);"
 
   let upload_post_reply =
     Caqti_request.exec
@@ -192,9 +193,10 @@ module Q = struct
     Caqti_request.find_opt Caqti_type.string Caqti_type.string
       "SELECT image_content FROM post_image WHERE post_id=?;"
 
-  let get_post_image_name =
+  let get_post_image_info =
-    Caqti_request.find_opt Caqti_type.string Caqti_type.string
+    Caqti_request.find_opt Caqti_type.string
-      "SELECT image_name FROM post_image WHERE post_id=?;"
+      Caqti_type.(tup2 string string)
+      "SELECT image_name,image_alt FROM post_image WHERE post_id=?;"
 
   let get_post_tags =
     Caqti_request.collect Caqti_type.string Caqti_type.string
@@ -265,6 +267,28 @@ let () =
   then
     Dream.warning (fun log -> log "can't create table")
 
+let parse_image image =
+  match image with
+  | None -> Ok None
+  | Some image -> (
+    let image =
+      match image with
+      | Some image_name, image_content, alt ->
+        (Dream.html_escape image_name, image_content, Dream.html_escape alt)
+      | None, image_content, alt ->
+        (* make up random name if no name was given *)
+        let image_name = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
+        (image_name, image_content, Dream.html_escape alt)
+    in
+    match image with
+    | _, image_content, alt ->
+      if not (is_valid_image image_content) then
+        Error "invalid image"
+      else if String.length alt > 1000 then
+        Error "Image description too long"
+      else
+        Ok (Some image) )
+
 (* TODO: Is this safe? *)
 (*TODO fix bad link if post in other thread*)
 let parse_comment comment =
@@ -338,7 +362,7 @@ let view_post ?is_thread_preview post_id =
   let* nick = Db.find Q.get_post_nick post_id in
   let* comment = Db.find Q.get_post_comment post_id in
   let* date = Db.find Q.get_post_date post_id in
-  let* image_name = Db.find_opt Q.get_post_image_name post_id in
+  let* image_info = Db.find_opt Q.get_post_image_info post_id in
 
   let* _tags = Db.fold Q.get_post_tags (fun tag acc -> tag :: acc) post_id [] in
   let* replies =
@@ -350,18 +374,19 @@ let view_post ?is_thread_preview post_id =
      let* _latlng = Db.find_opt Q.get_post_gps post_id in
   *)
   let image_view =
-    match image_name with
+    match image_info with
-    | Some image_name ->
+    | Some (_image_name, image_alt) ->
       (*TODO thumbnails *)
+      (*TODO image info like file name and size on top of image*)
       Format.sprintf
         {|
     <div class="postImageContainer">
-        <a title="%s" href="/post_pic/%s" target="_blank">
+        <a href="/post_pic/%s" target="_blank">
-        <img class= "postImage" src="/post_pic/%s" loading="lazy">
+        <img class="postImage" src="/post_pic/%s" alt="%s" title="%s" loading="lazy">
         </a>
     </div> 
 |}
-        image_name post_id post_id
+        post_id post_id image_alt image_alt
     | None -> ""
   in
 
@@ -425,7 +450,7 @@ let view_thread thread_id =
   match List.find_opt Result.is_error dates with
   | Some (Error e) -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
   | Some (Ok _) -> assert false
-  | None ->
+  | None -> (
     let dates = List.map Result.get_ok dates in
     let posts_dates = List.combine thread_posts dates in
     let sorted_posts_dates =
@@ -434,17 +459,21 @@ let view_thread thread_id =
 
     let posts, _ = List.split sorted_posts_dates in
     let view_posts = List.map view_post posts in
-    let view_posts =
+    match List.find_opt Result.is_error view_posts with
-      List.map Result.get_ok (List.filter Result.is_ok view_posts)
+    | Some (Error e) -> Error e
-    in
+    | Some (Ok _) -> assert false
-    let view_posts =
+    | None ->
-      Format.asprintf "%a"
+      let view_posts =
-        (Format.pp_print_list
+        List.map Result.get_ok (List.filter Result.is_ok view_posts)
-           ~pp_sep:(fun fmt () -> Format.fprintf fmt "\r\n")
+      in
-           Format.pp_print_string )
+      let view_posts =
-        view_posts
+        Format.asprintf "%a"
-    in
+          (Format.pp_print_list
-    Ok view_posts
+             ~pp_sep:(fun fmt () -> Format.fprintf fmt "\r\n")
+             Format.pp_print_string )
+          view_posts
+      in
+      Ok view_posts )
 
 let upload_post post =
   let post_id, parent_id, date, nick, comment, image, tags, citations, op_data =
@@ -485,8 +514,8 @@ let upload_post post =
   let* _res_image =
     match image with
     | None -> Ok ()
-    | Some (image_name, image_content) ->
+    | Some (image_name, image_content, alt) ->
-      Db.exec Q.upload_post_image (post_id, image_name, image_content)
+      Db.exec Q.upload_post_image (post_id, image_name, image_content, alt)
   in
   let* _res_parent = Db.exec Q.upload_post_parent (post_id, parent_id) in
   let* _res_tags =
@@ -527,45 +556,31 @@ let make_reply ~comment ?image ~tags ~parent_id nick =
   else if String.length comment > 10000 then
     Error "invalid comment"
   else
-    let image =
+    match parse_image image with
-      match image with
+    | Error e -> Error e
-      | Some (Some image_name, image_content) ->
+    | Ok image ->
-        Some (Dream.html_escape image_name, image_content)
+      if String.length tags > 1000 then
-      | Some (None, image_content) ->
+        Error "invalid tags"
-        (* make up random name if no name was given *)
+      else
-        let image_name = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
+        (* TODO latlng validation? *)
-        Some (image_name, image_content)
+        let tag_list = Str.split (Str.regexp " +") tags in
-      | None -> None
+        let id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
-    in
+        let date = int_of_float (Unix.time ()) in
-    let is_valid =
+        let comment, citations = parse_comment comment in
-      match image with
+        let reply =
-      | None -> true
+          Reply
-      | Some (_, image_content) -> is_valid_image image_content
+            { id
-    in
+            ; parent_id
-    if not is_valid then
+            ; date
-      Error "invalid image"
+            ; nick
-    else if String.length tags > 1000 then
+            ; comment
-      Error "invalid tags"
+            ; image
-    else
+            ; tags = tag_list
-      (* TODO latlng validation? *)
+            ; replies = []
-      let tag_list = Str.split (Str.regexp " +") tags in
+            ; citations
-      let id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
+            }
-      let date = int_of_float (Unix.time ()) in
+        in
-      let comment, citations = parse_comment comment in
+        upload_post reply
-      let reply =
-        Reply
-          { id
-          ; parent_id
-          ; date
-          ; nick
-          ; comment
-          ; image
-          ; tags = tag_list
-          ; replies = []
-          ; citations
-          }
-      in
-      upload_post reply
 
 let make_op ~comment ~image ~tags ~subject ~lat ~lng ~board nick =
   let comment = Dream.html_escape comment in
@@ -574,52 +589,41 @@ let make_op ~comment ~image ~tags ~subject ~lat ~lng ~board nick =
   if String.length comment > 10000 then
     Error "invalid comment"
   else
-    let image =
+    match parse_image (Some image) with
-      match image with
+    | Error e -> Error e
-      | Some image_name, image_content ->
+    | Ok None -> assert false
-        (Dream.html_escape image_name, image_content)
+    | Ok (Some image) ->
-      | None, image_content ->
+      if String.length tags > 1000 then
-        (* make up random name if no name was given *)
+        Error "invalid tags"
-        let image_name = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
-        (image_name, image_content)
-    in
-    let is_valid =
-      match image with
-      | _, image_content -> is_valid_image image_content
-    in
-    if not is_valid then
-      Error "invalid image"
-    else if String.length tags > 1000 then
-      Error "invalid tags"
-    else
-      (* TODO latlng validation? *)
-      let is_valid_latlng = true in
-      if not is_valid_latlng then
-        Error "Invalid coordinate"
-      else if String.length subject > 600 then
-        Error "Invalid subject"
       else
-        let tag_list = Str.split (Str.regexp " +") tags in
+        (* TODO latlng validation? *)
-        let id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
+        let is_valid_latlng = true in
-        let date = int_of_float (Unix.time ()) in
+        if not is_valid_latlng then
-        let comment, citations = parse_comment comment in
+          Error "Invalid coordinate"
-        let op =
+        else if String.length subject > 600 then
-          Op
+          Error "Invalid subject"
-            { id
+        else
-            ; board
+          let tag_list = Str.split (Str.regexp " +") tags in
-            ; date
+          let id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
-            ; nick
+          let date = int_of_float (Unix.time ()) in
-            ; subject
+          let comment, citations = parse_comment comment in
-            ; comment
+          let op =
-            ; image
+            Op
-            ; tags = tag_list
+              { id
-            ; longitude = lng
+              ; board
-            ; latitude = lat
+              ; date
-            ; replies = []
+              ; nick
-            ; citations
+              ; subject
-            }
+              ; comment
-        in
+              ; image
-        upload_post op
+              ; tags = tag_list
+              ; longitude = lng
+              ; latitude = lat
+              ; replies = []
+              ; citations
+              }
+          in
+          upload_post op
 
 let get_markers board =
   let* thread_id_list =

src/content/assets/css/style.css

@@ -71,3 +71,14 @@ blockquote.blockquote {
   display:table;
   width: 500px;
 }
+
+#newthread-form {
+    visibility: hidden;
+}
+
+#altLabel {
+    display:none;
+}
+#alt {
+    display:none;
+}

src/js_newthread.ml

@@ -105,3 +105,24 @@ let on_click e =
 let () =
   ignore
   @@ Jv.call Leaflet.map "on" [| Jv.of_string "click"; Jv.repr on_click |]
+
+(*!Duplicate*)
+(* make image description field visible when a file is selected*)
+let make_visible alt_input alt_label _event =
+  let alt_style = Jv.get alt_input "style" in
+  let alt_label_style = Jv.get alt_label "style" in
+  ignore @@ Jv.set alt_style "display" (Jv.of_string "block");
+  ignore @@ Jv.set alt_label_style "display" (Jv.of_string "block");
+  ()
+
+let () =
+  let file_input = Jv.find Jv.global "file" in
+  match file_input with
+  | None -> () (*not post form on the page, not logged in*)
+  | Some file_input ->
+    let alt_input = Jv.get Jv.global "alt" in
+    let alt_label = Jv.get Jv.global "altLabel" in
+    ignore
+    @@ Jv.call file_input "addEventListener"
+         [| Jv.of_string "change"; Jv.repr (make_visible alt_input alt_label) |];
+    ()

src/js_thread.ml

@@ -50,3 +50,24 @@ let () =
   in
   List.iter add_click post_images;
   ()
+
+(*!Duplicate*)
+(* make image description field visible when a file is selected*)
+let make_visible alt_input alt_label _event =
+  let alt_style = Jv.get alt_input "style" in
+  let alt_label_style = Jv.get alt_label "style" in
+  ignore @@ Jv.set alt_style "display" (Jv.of_string "block");
+  ignore @@ Jv.set alt_label_style "display" (Jv.of_string "block");
+  ()
+
+let () =
+  let file_input = Jv.find Jv.global "file" in
+  match file_input with
+  | None -> () (*not post form on the page, not logged in*)
+  | Some file_input ->
+    let alt_input = Jv.get Jv.global "alt" in
+    let alt_label = Jv.get Jv.global "altLabel" in
+    ignore
+    @@ Jv.call file_input "addEventListener"
+         [| Jv.of_string "change"; Jv.repr (make_visible alt_input alt_label) |];
+    ()

src/newthread_page.eml.html

@@ -12,7 +12,7 @@ Login to make a new thread.
         <div id="map"></div>
     </div>
 
-    <div class="col-md-6" id="newthread-form" style="visibility:hidden">
+    <div class="col-md-6" id="newthread-form">
     <div class="postForm">
 <%s! Dream.form_tag ~action:url ~enctype:`Multipart_form_data request %>
         <input type="hidden" id="lat_input" name="lat_input">
@@ -29,6 +29,9 @@ Login to make a new thread.
 
         <label for="file" id="fileLabel" class="form-label">Picture:</label>
         <input id="file" name="file" aria-describedby="fileLabel" type="file" accept="image/*">
+
+        <label for="alt" id="altLabel" class="form-label">Image description:</label>
+        <input name="alt" type="text" class="form-control" id="alt" aria-labelledby="altLabel"></input>
       <button type="submit" class="btn btn-primary">Make Thread</button>
 </form>
     </div>

src/permap.ml

@@ -168,7 +168,8 @@ let newthread_post ~board request =
     match%lwt Dream.multipart request with
     (*TODO jpp du duplicat la *)
     | `Ok
-        [ ("file", file)
+        [ ("alt", [ (_, alt) ])
+        ; ("file", file)
         ; ("lat_input", [ (_, lat) ])
         ; ("lng_input", [ (_, lng) ])
         ; ("subject", [ (_, subject) ])
@@ -176,12 +177,13 @@ let newthread_post ~board request =
         ; ("threadComment", [ (_, comment) ])
         ]
     | `Ok
-        (("file", file)
+        (("alt", [ (_, alt) ])
-        :: ("lat_input", [ (_, lat) ])
+        :: ("file", file)
-           :: ("lng_input", [ (_, lng) ])
+           :: ("lat_input", [ (_, lat) ])
-              :: ("subject", [ (_, subject) ])
+              :: ("lng_input", [ (_, lng) ])
-                 :: ("tags", [ (_, tags) ])
+                 :: ("subject", [ (_, subject) ])
-                    :: ("threadComment", [ (_, comment) ]) :: _ :: _ ) -> (
+                    :: ("tags", [ (_, tags) ])
+                       :: ("threadComment", [ (_, comment) ]) :: _ :: _ ) -> (
       match (Float.of_string_opt lat, Float.of_string_opt lng) with
       | None, _ -> render_unsafe "Invalide coordinate" request
       | _, None -> render_unsafe "Invalide coordinate" request
@@ -189,10 +191,11 @@ let newthread_post ~board request =
         match file with
         | [] -> render_unsafe "No image" request
         | _ :: _ :: _ -> render_unsafe "More than one image" request
-        | [ file ] -> (
+        | [ (image_name, image_content) ] -> (
+          let image = (image_name, image_content, alt) in
           match
-            Babillard.make_op ~comment ~image:file ~lat ~lng ~subject ~tags
+            Babillard.make_op ~comment ~image ~lat ~lng ~subject ~tags ~board
-              ~board nick
+              nick
           with
           | Ok thread_id ->
             let adress =
@@ -234,20 +237,23 @@ let reply_post request =
   | Some nick -> (
     match%lwt Dream.multipart request with
     | `Ok
-        [ ("file", file)
+        [ ("alt", [ (_, alt) ])
+        ; ("file", file)
         ; ("replyComment", [ (_, comment) ])
         ; ("tags", [ (_, tags) ])
         ]
     | `Ok
-        (("file", file)
+        (("alt", [ (_, alt) ])
-        :: ("tags", [ (_, tags) ])
+        :: ("file", file)
-           :: ("replyComment", [ (_, comment) ]) :: _ :: _ ) -> (
+           :: ("tags", [ (_, tags) ])
+              :: ("replyComment", [ (_, comment) ]) :: _ :: _ ) -> (
       let parent_id = Dream.param "thread_id" request in
       let res =
         match file with
         | [] -> Babillard.make_reply ~comment ~tags ~parent_id nick
-        | [ file ] ->
+        | [ (image_name, image_content) ] ->
-          Babillard.make_reply ~comment ~image:file ~tags ~parent_id nick
+          let image = (image_name, image_content, alt) in
+          Babillard.make_reply ~comment ~image ~tags ~parent_id nick
         | _ :: _ :: _ -> Error "More than one image"
       in
       match res with

src/thread_page.eml.html

@@ -17,6 +17,9 @@ let f thread_view thread_id request =
 
         <label for="file" id="fileLabel" class="form-label">Picture:</label>
         <input id="file" name="file" aria-describedby="fileLabel" type="file" accept="image/*">
+
+        <label for="alt" id="altLabel" class="form-label">Image description:</label>
+        <input name="alt" type="text" class="form-control" id="alt" aria-labelledby="altLabel"></input>
       <button type="submit" class="btn btn-primary">Reply</button>
       </div>
     </form>