swrup/geochan
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

add alt text field

Browse source
This commit is contained in:
Swrup 2022-01-25 14:07:28 +01:00
parent 7272ede2ca
commit 44bacabfbd
7 changed files with 198 additions and 129 deletions
Download patch file Download diff file Expand all files Collapse all files

228
src/babillard.ml
View file

@ -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)
"INSERT INTO post_image VALUES (?,?,?);"
Caqti_type.(tup4 string string string string)
"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 =
Caqti_request.find_opt Caqti_type.string Caqti_type.string
"SELECT image_name FROM post_image 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 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
| Some image_name ->
match image_info with
| 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">
<img class= "postImage" src="/post_pic/%s" loading="lazy">
<a href="/post_pic/%s" target="_blank">
<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 =
List.map Result.get_ok (List.filter Result.is_ok view_posts)
in
let view_posts =
Format.asprintf "%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\r\n")
Format.pp_print_string )
view_posts
in
Ok view_posts
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
let view_posts =
Format.asprintf "%a"
(Format.pp_print_list
~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) ->
Db.exec Q.upload_post_image (post_id, image_name, image_content)
| Some (image_name, image_content, alt) ->
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 image with
| Some (Some image_name, image_content) ->
Some (Dream.html_escape image_name, image_content)
| 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? *)
let tag_list = Str.split (Str.regexp " +") tags in
let id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
let date = int_of_float (Unix.time ()) in
let comment, citations = parse_comment comment in
let reply =
Reply
{ id
; parent_id
; date
; nick
; comment
; image
; tags = tag_list
; replies = []
; citations
}
in
upload_post reply
match parse_image image with
| Error e -> Error e
| Ok image ->
if String.length tags > 1000 then
Error "invalid tags"
else
(* TODO latlng validation? *)
let tag_list = Str.split (Str.regexp " +") tags in
let id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
let date = int_of_float (Unix.time ()) in
let comment, citations = parse_comment comment in
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 image with
| Some image_name, image_content ->
(Dream.html_escape image_name, image_content)
| None, image_content ->
(* 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? *)
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"
match parse_image (Some image) with
| Error e -> Error e
| Ok None -> assert false
| Ok (Some image) ->
if String.length tags > 1000 then
Error "invalid tags"
else
let tag_list = Str.split (Str.regexp " +") tags in
let id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
let date = int_of_float (Unix.time ()) in
let comment, citations = parse_comment comment in
let op =
Op
{ id
; board
; date
; nick
; subject
; comment
; image
; tags = tag_list
; longitude = lng
; latitude = lat
; replies = []
; citations
}
in
upload_post op
(* 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
let id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
let date = int_of_float (Unix.time ()) in
let comment, citations = parse_comment comment in
let op =
Op
{ id
; board
; date
; nick
; subject
; comment
; image
; tags = tag_list
; longitude = lng
; latitude = lat
; replies = []
; citations
}
in
upload_post op
let get_markers board =
let* thread_id_list =

11
src/content/assets/css/style.css
View file

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

21
src/js_newthread.ml
View file

@ -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) |];
()

21
src/js_thread.ml
View file

@ -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) |];
()

5
src/newthread_page.eml.html
View file

@ -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>

38
src/permap.ml
View file

@ -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)
:: ("lat_input", [ (_, lat) ])
:: ("lng_input", [ (_, lng) ])
:: ("subject", [ (_, subject) ])
:: ("tags", [ (_, tags) ])
:: ("threadComment", [ (_, comment) ]) :: _ :: _ ) -> (
(("alt", [ (_, alt) ])
:: ("file", file)
:: ("lat_input", [ (_, lat) ])
:: ("lng_input", [ (_, lng) ])
:: ("subject", [ (_, subject) ])
:: ("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
~board nick
Babillard.make_op ~comment ~image ~lat ~lng ~subject ~tags ~board
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)
:: ("tags", [ (_, tags) ])
:: ("replyComment", [ (_, comment) ]) :: _ :: _ ) -> (
(("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 ] ->
Babillard.make_reply ~comment ~image:file ~tags ~parent_id nick
| [ (image_name, image_content) ] ->
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

3
src/thread_page.eml.html
View file

@ -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>