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,6 +459,10 @@ let view_thread thread_id =
 
     let posts, _ = List.split sorted_posts_dates in
     let view_posts = List.map view_post posts in
+    match List.find_opt Result.is_error view_posts with
+    | Some (Error e) -> Error e
+    | Some (Ok _) -> assert false
+    | None ->
       let view_posts =
         List.map Result.get_ok (List.filter Result.is_ok view_posts)
       in
@@ -444,7 +473,7 @@ let view_thread thread_id =
              Format.pp_print_string )
           view_posts
       in
-    Ok view_posts
+      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,24 +556,10 @@ 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) ->
-        (* make up random name if no name was given *)
-        let image_name = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
-        Some (image_name, image_content)
-      | None -> None
-    in
-    let is_valid =
-      match image with
-      | None -> true
-      | Some (_, 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? *)
@@ -574,22 +589,11 @@ 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 *)
-        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? *)

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,7 +177,8 @@ let newthread_post ~board request =
         ; ("threadComment", [ (_, comment) ])
         ]
     | `Ok
-        (("file", file)
+        (("alt", [ (_, alt) ])
+        :: ("file", file)
            :: ("lat_input", [ (_, lat) ])
               :: ("lng_input", [ (_, lng) ])
                  :: ("subject", [ (_, subject) ])
@@ -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) ])
+        :: ("file", file)
            :: ("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>