fix

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 \
+       FLOAT,post_id TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) \
-       DELETE CASCADE, FOREIGN KEY(nick) REFERENCES user(nick) ON DELETE \
+       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 ()

src/babillard_page.eml.html

@@ -22,7 +22,7 @@ let f request =
     <div class="thread-preview on" id="thread-preview"></div>
 
     <div class="new-thread off" id="new-thread">
-      <h1>New thread</h1>
+      <h2>New thread</h2>
       <span id="new-thread-info">
           Click the map and make a new thread:
       </span>

src/content/assets/css/style.css

@@ -129,9 +129,6 @@ a.preview-link {
   padding: 2px;
 }
 
-.on {
-}
-
 .off {
   display: none;
 }

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 () =
+  let new_thread_div = Jv.get Jv.global "new-thread"
-    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 set visible el =
+  let thread_preview_div = Jv.get Jv.global "thread-preview"
-    log "set (un)visible@\n";
+
+  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
-      ignore
+    @@ Jv.call class_list "replace" [| Jv.of_string "off"; Jv.of_string "on" |]
-      @@ 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" |]
 
-  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
+    is_in_new_thread_mode := true;
-    let thread_preview_div = Jv.get Jv.global "thread-preview" in
+    set_visible new_thread_div;
-    let new_thread_button = Jv.get Jv.global "new-thread-button" in
+    set_visible return_button;
-    let return_button = Jv.get Jv.global "return-button" in
+    set_invisible thread_preview_div;
-    let () = set form_visibility new_thread_div in
+    Option.iter set_invisible new_thread_button;
-    let () = set form_visibility return_button in
+    ignore @@ Jv.call Leaflet.map "closePopup" [||]
-    let () = set (not form_visibility) thread_preview_div in
+
-    let () = set (not form_visibility) new_thread_button in
+  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.of_string "click"; Jv.repr to_babillard_mode |];
-          ; Jv.repr (change_page_mode ~form_visibility:false)
+    Option.iter
-         |];
+      (fun button ->
-    (* new-thread-button is new-thread-button-redirect if not logged in *)
+        ignore
-    let opt = Jv.find Jv.global "new-thread-button" in
+        @@ Jv.call button "addEventListener"
-    if Option.is_some opt then
+             [| Jv.of_string "click"; Jv.repr to_new_thread_mode |] )
-      let new_thread_button = Option.get opt in
+      new_thread_button
-      ignore
-      @@ Jv.call new_thread_button "addEventListener"
-           [| Jv.of_string "click"
-            ; Jv.repr (change_page_mode ~form_visibility:true)
-           |]
 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 (
+    if not !Visibility.is_in_new_thread_mode then
-      let thread_preview_div = Jv.get Jv.global "thread-preview" in
       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*)

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_float
-      (Jv.to_int
+      (Jv.call date_span "getAttribute" [| Jv.of_string "data-time" |])
-         (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

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

src/pp_babillard.ml

@@ -80,7 +80,7 @@ let pp_post fmt t =
       {|
     <div class="post-info">
         <span class="nick">%s</span>
-        <span class="date" data-time="%d"></span>
+        <span class="date" data-time="%f"></span>
         <div class="dropend post-menu-div">
           <a class="dropdown-toggle post-menu-link" href="#" role="button" id="dropdownMenuLink" data-bs-toggle="dropdown" aria-expanded="false">
           </a>
@@ -116,8 +116,8 @@ let pp_post fmt t =
     if Option.is_some thread_data_opt then
       Format.fprintf fmt
         {|<a class="stretched-link preview-link" href="/thread/%s"></a>|} id
-    else Format.fprintf fmt ""
   in
+
   Format.fprintf fmt
     {|
     <div class="position-relative post" id="%s">
@@ -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
-      (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun fmt post ->
+      (fun fmt post -> pp_post fmt (Post post))
-           pp_post fmt (Post post) ) )
+      fmt posts
-      posts
   in
   Format.fprintf fmt
     {|

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 _unit_lwt = Dream.invalidate_session request in
-        let%lwt () = Dream.invalidate_session request in
+      let _unit_lwt = Dream.put_session "nick" nick request in
-        Dream.put_session "nick" nick request
-      in
       Ok ()
     else Error "wrong password"
   else Error "wrong user name"