diff --git a/src/babillard.ml b/src/babillard.ml index dc4c71f..55d0d26 100644 --- a/src/babillard.ml +++ b/src/babillard.ml @@ -10,7 +10,7 @@ type thread_data = type post = { id : string ; parent_id : string - ; date : int + ; date : float ; nick : string ; comment : string ; image_info : (string * string) option @@ -66,7 +66,7 @@ module Q = struct let create_post_date_table = Caqti_request.exec Caqti_type.unit - "CREATE TABLE IF NOT EXISTS post_date (post_id TEXT, date INT, FOREIGN \ + "CREATE TABLE IF NOT EXISTS post_date (post_id TEXT, date FLOAT, FOREIGN \ KEY(post_id) REFERENCES post_user(post_id) ON DELETE CASCADE);" let create_post_comment_table = @@ -94,13 +94,13 @@ module Q = struct let create_report_table = Caqti_request.exec Caqti_type.unit "CREATE TABLE IF NOT EXISTS report (nick TEXT, reason TEXT, date \ - INT,post_id TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON \ - DELETE CASCADE, FOREIGN KEY(nick) REFERENCES user(nick) ON DELETE \ + FLOAT,post_id TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) \ + ON DELETE CASCADE, FOREIGN KEY(nick) REFERENCES user(nick) ON DELETE \ CASCADE);" let upload_report_post = Caqti_request.exec - Caqti_type.(tup4 string string int string) + Caqti_type.(tup4 string string float string) "INSERT INTO report VALUES (?,?,?,?);" let upload_post_id = @@ -145,7 +145,7 @@ module Q = struct let upload_post_date = Caqti_request.exec - Caqti_type.(tup2 string int) + Caqti_type.(tup2 string float) "INSERT INTO post_date VALUES (?,?);" let get_post_nick = @@ -170,7 +170,7 @@ module Q = struct "SELECT tag FROM post_tags WHERE post_id=?;" let get_post_date = - Caqti_request.find Caqti_type.string Caqti_type.int + Caqti_request.find Caqti_type.string Caqti_type.float "SELECT date FROM post_date WHERE post_id=?;" let get_post_citations = @@ -381,7 +381,7 @@ let build_reply ~comment ?image ~tags ?parent_id nick = | Some (image_info, _image_content) -> Some image_info in let tag_list = Str.split (Str.regexp " +") tags in - let date = int_of_float (Unix.time ()) in + let date = Unix.time () in let comment, citations = parse_comment comment in let reply = { id @@ -430,10 +430,10 @@ let get_post_image_content id = let^? content = Db.find_opt Q.get_post_image_content id in Ok content -let thread_exists id = Result.is_ok (Db.find Q.get_is_thread id) +let thread_exist id = Result.is_ok (Db.find Q.get_is_thread id) (* true if post is an op too *) -let post_exists id = Result.is_ok (Db.find Q.get_is_post id) +let post_exist id = Result.is_ok (Db.find Q.get_is_post id) let get_post id = let^ parent_id = Db.find Q.get_post_thread id in @@ -451,7 +451,7 @@ let get_post id = Ok reply let get_thread_data id = - if thread_exists id then + if thread_exist id then let^? subject, lat, lng = Db.find_opt Q.get_thread_info id in let thread_data = { subject; lat; lng } in Ok thread_data @@ -474,8 +474,10 @@ let try_delete_post ~nick id = else Error "You can only delete your posts" let report ~nick ~reason id = - if not (post_exists id) then Error "This post doesn't exists" + if not (post_exist id) then Error "This post doesn't exists" + else if String.length reason > 2000 then Error "Your reason is too long.." else - let date = int_of_float (Unix.time ()) in + let reason = Dream.html_escape reason in + let date = Unix.time () in let^ () = Db.exec Q.upload_report_post (nick, reason, date, id) in Ok () diff --git a/src/babillard_page.eml.html b/src/babillard_page.eml.html index 8121a37..7d1815d 100644 --- a/src/babillard_page.eml.html +++ b/src/babillard_page.eml.html @@ -22,7 +22,7 @@ let f request =
-

New thread

+

New thread

Click the map and make a new thread: diff --git a/src/content/assets/css/style.css b/src/content/assets/css/style.css index 031fb00..0d409db 100644 --- a/src/content/assets/css/style.css +++ b/src/content/assets/css/style.css @@ -129,9 +129,6 @@ a.preview-link { padding: 2px; } -.on { -} - .off { display: none; } diff --git a/src/js/js_babillard.ml b/src/js/js_babillard.ml index e2e6caa..f099977 100644 --- a/src/js/js_babillard.ml +++ b/src/js/js_babillard.ml @@ -2,63 +2,70 @@ open Js_map include Js_post_form module Visibility = struct - let is_in_new_thread_mode () = - log "is_in_new_thread_mode?@\n"; - let new_thread_div = Jv.get Jv.global "new-thread" in - let class_list = Jv.get new_thread_div "classList" in - Jv.to_bool @@ Jv.call class_list "contains" [| Jv.of_string "on" |] + let new_thread_div = Jv.get Jv.global "new-thread" - let set visible el = - log "set (un)visible@\n"; + let thread_preview_div = Jv.get Jv.global "thread-preview" + + let return_button = Jv.get Jv.global "return-button" + + (* new-thread-button is new-thread-button-redirect if not logged in *) + let new_thread_button = Jv.find Jv.global "new-thread-button" + + let is_in_new_thread_mode = ref false + + let set_visible el = + log "set_visible@\n"; let class_list = Jv.get el "classList" in - if visible then - ignore - @@ Jv.call class_list "replace" - [| Jv.of_string "off"; Jv.of_string "on" |] - else - ignore - @@ Jv.call class_list "replace" - [| Jv.of_string "on"; Jv.of_string "off" |] + ignore + @@ Jv.call class_list "replace" [| Jv.of_string "off"; Jv.of_string "on" |] - let change_page_mode ~form_visibility _event = + let set_invisible el = + log "set_invisible@\n"; + let class_list = Jv.get el "classList" in + ignore + @@ Jv.call class_list "replace" [| Jv.of_string "on"; Jv.of_string "off" |] + + let to_new_thread_mode _event = log "change_page_mode@\n"; - let new_thread_div = Jv.get Jv.global "new-thread" in - let thread_preview_div = Jv.get Jv.global "thread-preview" in - let new_thread_button = Jv.get Jv.global "new-thread-button" in - let return_button = Jv.get Jv.global "return-button" in - let () = set form_visibility new_thread_div in - let () = set form_visibility return_button in - let () = set (not form_visibility) thread_preview_div in - let () = set (not form_visibility) new_thread_button in + is_in_new_thread_mode := true; + set_visible new_thread_div; + set_visible return_button; + set_invisible thread_preview_div; + Option.iter set_invisible new_thread_button; + ignore @@ Jv.call Leaflet.map "closePopup" [||] + + let to_babillard_mode _event = + log "change_page_mode@\n"; + is_in_new_thread_mode := false; + set_invisible new_thread_div; + set_invisible return_button; + set_visible thread_preview_div; + Option.iter set_visible new_thread_button; ignore @@ Jv.call Leaflet.map "closePopup" [||] let () = log "add events on return/new thread button@\n"; - let return_button = Jv.get Jv.global "return-button" in ignore @@ Jv.call return_button "addEventListener" - [| Jv.of_string "click" - ; Jv.repr (change_page_mode ~form_visibility:false) - |]; - (* new-thread-button is new-thread-button-redirect if not logged in *) - let opt = Jv.find Jv.global "new-thread-button" in - if Option.is_some opt then - let new_thread_button = Option.get opt in - ignore - @@ Jv.call new_thread_button "addEventListener" - [| Jv.of_string "click" - ; Jv.repr (change_page_mode ~form_visibility:true) - |] + [| Jv.of_string "click"; Jv.repr to_babillard_mode |]; + Option.iter + (fun button -> + ignore + @@ Jv.call button "addEventListener" + [| Jv.of_string "click"; Jv.repr to_new_thread_mode |] ) + new_thread_button end module Marker = struct + let window = Jv.get Jv.global "window" + + let thread_preview_div = Jv.get Jv.global "thread-preview" + let marker_on_click thread_preview _e = log "marker_on_click@\n"; - if not (Visibility.is_in_new_thread_mode ()) then ( - let thread_preview_div = Jv.get Jv.global "thread-preview" in + if not !Visibility.is_in_new_thread_mode then ignore @@ Jv.set thread_preview_div "innerHTML" thread_preview; - let _ = Js_pretty_post.make_pretty () in - () ) + Js_pretty_post.make_pretty () let on_each_feature feature layer = log "on_each_feature@\n"; @@ -70,8 +77,6 @@ module Marker = struct let handle_geojson geojson = log "handle_geojson@\n"; - log "feed geojson to leaflet@\n"; - (* make markers unresponsive on*) let dict = Jv.obj [| ("onEachFeature", Jv.repr on_each_feature) |] in let layer = Jv.call Leaflet.leaflet "geoJSON" [| geojson; dict |] in let _marker_layer = Jv.call layer "addTo" [| Leaflet.map |] in @@ -84,16 +89,21 @@ module Marker = struct let () = log "fetch thread geojson@\n"; - let window = Jv.get Jv.global "window" in let link = Jv.of_string "/markers" in let fetchfutur = Jv.call window "fetch" [| link |] in ignore @@ Jv.call fetchfutur "then" [| Jv.repr markers_handle_response |] end +let lat_input = Jv.get Jv.global "lat-input" + +let lng_input = Jv.get Jv.global "lng-input" + +let button = Jv.get Jv.global "submit-new-thread-button" + (* set input lat/lng when clicked*) let on_click_set_latlng e = log "on_click_set_latlng@\n"; - if Visibility.is_in_new_thread_mode () then ( + if !Visibility.is_in_new_thread_mode then ( let lat_lng = Jv.get e "latlng" in ignore @@ Jv.call Leaflet.popup "setLatLng" [| lat_lng |]; ignore @@ -103,13 +113,9 @@ let on_click_set_latlng e = let lat = Jv.get lat_lng "lat" in let lng = Jv.get lat_lng "lng" in - let lat_input = Jv.get Jv.global "lat-input" in - let lng_input = Jv.get Jv.global "lng-input" in ignore @@ Jv.call lat_input "setAttribute" [| Jv.of_string "value"; lat |]; ignore @@ Jv.call lng_input "setAttribute" [| Jv.of_string "value"; lng |]; - log "on_click_set_latlng: disableb disabled@\n"; - let button = Jv.get Jv.global "submit-new-thread-button" in ignore @@ Jv.call button "removeAttribute" [| Jv.of_string "disabled" |] ) (*add on_click callback to map*) diff --git a/src/js/js_pretty_post.ml b/src/js/js_pretty_post.ml index 6a986b9..0539255 100644 --- a/src/js/js_pretty_post.ml +++ b/src/js/js_pretty_post.ml @@ -11,6 +11,8 @@ let of_string = function let to_string = function Small -> "post-image" | Big -> "post-image-big" +let document = Jv.get Jv.global "document" + (*change postImage class to make it bigger/smaller on click*) let image_click post_image event = log "image_click@\n"; @@ -33,9 +35,8 @@ let image_click post_image event = let render_time date_span = log "render time@\n"; let t = - float_of_int - (Jv.to_int - (Jv.call date_span "getAttribute" [| Jv.of_string "data-time" |]) ) + Jv.to_float + (Jv.call date_span "getAttribute" [| Jv.of_string "data-time" |]) in let t = Unix.localtime t in let date = @@ -46,7 +47,6 @@ let render_time date_span = let make_pretty _event = log "make pretty@\n"; - let document = Jv.get Jv.global "document" in let times = Jv.to_jv_list diff --git a/src/permap.ml b/src/permap.ml index 2992f18..ff1f9e9 100644 --- a/src/permap.ml +++ b/src/permap.ml @@ -124,7 +124,7 @@ let user request = let user_profile request = let nick = Dream.param request "user" in - if User.exists nick then + if User.exist nick then render_unsafe (Result.fold ~ok:Fun.id ~error:Fun.id (User.public_profile nick)) request @@ -171,7 +171,7 @@ let profile_post request = let avatar_image request = let nick = Dream.param request "user" in - if User.exists nick then + if User.exist nick then let avatar = User.get_avatar nick in match avatar with | Ok (Some avatar) -> @@ -185,7 +185,7 @@ let avatar_image request = let post_image request = let post_id = Dream.param request "post_id" in - if Babillard.post_exists post_id then + if Babillard.post_exist post_id then let image = Babillard.get_post_image_content post_id in match image with | Ok image -> Dream.respond ~headers:[ ("Content-Type", "image") ] image @@ -241,7 +241,7 @@ let babillard_post request = let thread_get request = let thread_id = Dream.param request "thread_id" in - if Babillard.thread_exists thread_id then + if Babillard.thread_exist thread_id then let thread_view = Pp_babillard.view_thread thread_id in let res = match thread_view with diff --git a/src/pp_babillard.ml b/src/pp_babillard.ml index 101562e..5a7d790 100644 --- a/src/pp_babillard.ml +++ b/src/pp_babillard.ml @@ -80,7 +80,7 @@ let pp_post fmt t = {|
%s - +
@@ -116,8 +116,8 @@ let pp_post fmt t = if Option.is_some thread_data_opt then Format.fprintf fmt {||} id - else Format.fprintf fmt "" in + Format.fprintf fmt {|
@@ -164,10 +164,9 @@ let pp_thread fmt op posts = (*order by date *) let posts = List.sort (fun a b -> compare a.date b.date) posts in let posts_view fmt () = - Format.fprintf fmt "%a" - (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun fmt post -> - pp_post fmt (Post post) ) ) - posts + Format.pp_print_list ~pp_sep:Format.pp_print_space + (fun fmt post -> pp_post fmt (Post post)) + fmt posts in Format.fprintf fmt {| diff --git a/src/user.ml b/src/user.ml index f7545b0..6ca7948 100644 --- a/src/user.ml +++ b/src/user.ml @@ -70,16 +70,14 @@ let () = (List.map (fun query -> Db.exec query ()) tables) then Dream.error (fun log -> log "can't create table") -let exists nick = Result.is_ok (Db.find Q.get_user nick) +let exist nick = Result.is_ok (Db.find Q.get_user nick) let login ~nick ~password request = - if exists nick then + if exist nick then let^? good_password = Db.find_opt Q.get_password nick in if Bcrypt.verify password (Bcrypt.hash_of_string good_password) then - let _ = - let%lwt () = Dream.invalidate_session request in - Dream.put_session "nick" nick request - in + let _unit_lwt = Dream.invalidate_session request in + let _unit_lwt = Dream.put_session "nick" nick request in Ok () else Error "wrong password" else Error "wrong user name"