wip:babillard

src/add_plant.eml.html

@@ -15,3 +15,4 @@ let f nick request =
       <button type="submit" class="btn btn-primary">Add Plant</button>
       </div>
     </form>
+<script type="text/javascript" src="/assets/js/js_plant_map.js" defer="defer"></script>

src/babillard.ml

@@ -0,0 +1,558 @@
+open Db
+
+module Q = struct
+  let create_post_user_table =
+    Caqti_request.exec Caqti_type.unit
+      "CREATE TABLE IF NOT EXISTS post_user (post_id TEXT, nick TEXT, PRIMARY \
+       KEY(post_id), FOREIGN KEY(nick) REFERENCES user(nick));"
+
+  (* post_id -> OP's post_id *)
+  let create_post_parent_table =
+    Caqti_request.exec Caqti_type.unit
+      "CREATE TABLE IF NOT EXISTS post_parent (post_id TEXT, parent_id TEXT, \
+       FOREIGN KEY(post_id) REFERENCES post_user(post_id),\n\
+      \       FOREIGN KEY(parent_id) REFERENCES post_user(post_id));"
+
+  let create_thread_table =
+    Caqti_request.exec Caqti_type.unit
+      "CREATE TABLE IF NOT EXISTS threads (thread_id TEXT, post_id TEXT,\n\
+      \         FOREIGN KEY(thread_id) REFERENCES post_user(post_id),\n\
+      \         FOREIGN KEY(post_id) REFERENCES post_user(post_id));"
+
+  let create_post_replies_table =
+    Caqti_request.exec Caqti_type.unit
+      "CREATE TABLE IF NOT EXISTS post_replies (post_id TEXT, reply_id TEXT, \
+       FOREIGN KEY(post_id) REFERENCES post_user(post_id),\n\
+      \       FOREIGN KEY(reply_id) REFERENCES post_user(post_id));"
+
+  let create_post_citations_table =
+    Caqti_request.exec Caqti_type.unit
+      "CREATE TABLE IF NOT EXISTS post_citations (post_id TEXT, cited_id TEXT, \
+       FOREIGN KEY(post_id) REFERENCES post_user(post_id),\n\
+      \       FOREIGN KEY(cited_id) REFERENCES post_user(post_id));"
+
+  let create_post_date_table =
+    Caqti_request.exec Caqti_type.unit
+      "CREATE TABLE IF NOT EXISTS post_date (post_id TEXT, date INT, FOREIGN \
+       KEY(post_id) REFERENCES post_user(post_id));"
+
+  let create_post_comment_table =
+    Caqti_request.exec Caqti_type.unit
+      "CREATE TABLE IF NOT EXISTS post_comment (post_id TEXT, comment TEXT, \
+       FOREIGN KEY(post_id) REFERENCES post_user(post_id));"
+
+  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));"
+
+  let create_post_gps_table =
+    Caqti_request.exec Caqti_type.unit
+      "CREATE TABLE IF NOT EXISTS post_gps (post_id TEXT, lat FLOAT, lng FLOAT ,\n\
+      \       FOREIGN KEY(post_id) REFERENCES post_user(post_id));"
+
+  let create_post_subject_table =
+    Caqti_request.exec Caqti_type.unit
+      "CREATE TABLE IF NOT EXISTS post_subject (post_id TEXT, subject TEXT, \
+       FOREIGN KEY(post_id) REFERENCES post_user(post_id));"
+
+  let create_post_tags_table =
+    Caqti_request.exec Caqti_type.unit
+      "CREATE TABLE IF NOT EXISTS post_tags (post_id TEXT, tag TEXT, FOREIGN \
+       KEY(post_id) REFERENCES post_user(post_id));"
+
+  let upload_post_id =
+    Caqti_request.exec
+      Caqti_type.(tup2 string string)
+      "INSERT INTO post_user VALUES (?,?);"
+
+  let upload_post_gps =
+    Caqti_request.exec
+      Caqti_type.(tup3 string float float)
+      "INSERT INTO post_gps VALUES (?,?,?);"
+
+  let upload_post_image =
+    Caqti_request.exec
+      Caqti_type.(tup3 string string string)
+      "INSERT INTO post_image VALUES (?,?,?);"
+
+  let upload_post_reply =
+    Caqti_request.exec
+      Caqti_type.(tup2 string string)
+      "INSERT INTO post_replies VALUES (?,?);"
+
+  let upload_post_comment =
+    Caqti_request.exec
+      Caqti_type.(tup2 string string)
+      "INSERT INTO post_comment VALUES (?,?);"
+
+  let upload_post_subject =
+    Caqti_request.exec
+      Caqti_type.(tup2 string string)
+      "INSERT INTO post_subject VALUES (?,?);"
+
+  let upload_post_tag =
+    Caqti_request.exec
+      Caqti_type.(tup2 string string)
+      "INSERT INTO post_tags VALUES (?,?);"
+
+  let upload_post_date =
+    Caqti_request.exec
+      Caqti_type.(tup2 string int)
+      "INSERT INTO post_date VALUES (?,?);"
+
+  let upload_to_thread =
+    Caqti_request.exec
+      Caqti_type.(tup2 string string)
+      "INSERT INTO threads VALUES (?,?);"
+
+  let upload_post_parent =
+    Caqti_request.exec
+      Caqti_type.(tup2 string string)
+      "INSERT INTO post_parent VALUES (?,?);"
+
+  let get_post_nick =
+    Caqti_request.find Caqti_type.string Caqti_type.string
+      "SELECT nick FROM post_user WHERE post_id=?;"
+
+  let get_post_comment =
+    Caqti_request.find Caqti_type.string Caqti_type.string
+      "SELECT comment FROM post_comment WHERE post_id=?;"
+
+  let get_post_image_content =
+    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_tags =
+    Caqti_request.collect Caqti_type.string Caqti_type.string
+      "SELECT tag FROM post_tags WHERE post_id=?;"
+
+  let get_post_date =
+    Caqti_request.find Caqti_type.string Caqti_type.int
+      "SELECT date FROM post_date WHERE post_id=?;"
+
+  let get_post_citations =
+    Caqti_request.collect Caqti_type.string Caqti_type.string
+      "SELECT post_id FROM post_citations WHERE reply_id=?;"
+
+  let get_post_replies =
+    Caqti_request.collect Caqti_type.string Caqti_type.string
+      "SELECT reply_id FROM post_replies WHERE post_id=?;"
+
+  let get_thread_posts =
+    Caqti_request.collect Caqti_type.string Caqti_type.string
+      "SELECT post_id FROM threads WHERE thread_id=?;"
+
+  (* TODO return bool *)
+  let is_thread =
+    Caqti_request.find_opt Caqti_type.string Caqti_type.string
+      "SELECT thread_id FROM threads WHERE thread_id=? LIMIT 1;"
+
+  let get_post_subject =
+    Caqti_request.find_opt Caqti_type.string Caqti_type.string
+      "SELECT subject FROM post_subject WHERE post_id=?;"
+
+  let get_post_gps =
+    Caqti_request.find_opt Caqti_type.string
+      Caqti_type.(tup2 float float)
+      "SELECT lat, lng FROM post_gps WHERE post_id=?;"
+
+  let list_thread_ids =
+    Caqti_request.collect Caqti_type.unit Caqti_type.string
+      "SELECT thread_id FROM threads;"
+end
+
+let () =
+  let tables =
+    [ Q.create_post_user_table
+    ; Q.create_post_parent_table
+    ; Q.create_thread_table
+    ; Q.create_post_replies_table
+    ; Q.create_post_citations_table
+    ; Q.create_post_date_table
+    ; Q.create_post_comment_table
+    ; Q.create_post_image_table
+    ; Q.create_post_gps_table
+    ; Q.create_post_subject_table
+    ; Q.create_post_tags_table
+    ]
+  in
+  if
+    List.exists Result.is_error
+      (List.map (fun query -> Db.exec query ()) tables)
+  then
+    Dream.warning (fun log -> log "can't create table")
+
+(* TODO should I escape html or smthing ?*)
+let parse_comment comment =
+  let words = String.split_on_char ' ' comment in
+  let cited_posts, words =
+    List.fold_left
+      (fun (acc_cited, acc_posts) w ->
+        match String.starts_with ~prefix:">>" w with
+        | false -> (acc_cited, acc_posts @ [ w ])
+        | true -> (
+          let sub_w = String.sub w 2 (String.length w - 2) in
+          match Uuidm.of_string sub_w with
+          | None -> (acc_cited, acc_posts @ [ w ])
+          | Some _ ->
+            let new_w = Format.sprintf {|<a href="#%s">%s</a>|} sub_w w in
+            (acc_cited @ [ sub_w ], acc_posts @ [ new_w ]) ) )
+      ([], []) words
+  in
+  let comment = String.concat (String.make 1 ' ') words in
+  (* remove duplicate *)
+  let cited_posts = List.sort_uniq (fun _ _ -> 0) cited_posts in
+  (comment, cited_posts)
+
+let view_post post_id =
+  let res_nick = Db.find Q.get_post_nick post_id in
+  let res_comment = Db.find Q.get_post_comment post_id in
+  let res_date = Db.find Q.get_post_date post_id in
+  let res_image_name = Db.find_opt Q.get_post_image_name post_id in
+
+  let res_tags =
+    Db.fold Q.get_post_tags (fun tag acc -> tag :: acc) post_id []
+  in
+  let res_replies =
+    Db.fold Q.get_post_replies (fun reply_id acc -> reply_id :: acc) post_id []
+  in
+
+  (* get more stuff for OP *)
+  let res_subject = Db.find_opt Q.get_post_subject post_id in
+  let res_latlng = Db.find_opt Q.get_post_gps post_id in
+
+  (* TODO clean taht idk urghh.. *)
+  let res0 =
+    match List.find_opt Result.is_error [ res_nick; res_comment ] with
+    | Some (Error e) -> Error e
+    | Some (Ok _) -> assert false
+    | None -> Ok ()
+  in
+  let res1 =
+    match List.find_opt Result.is_error [ res_image_name; res_subject ] with
+    | Some (Error e) -> Error e
+    | Some (Ok _) -> assert false
+    | None -> Ok ()
+  in
+  let res2 =
+    match res_latlng with
+    | Ok _ -> Ok ()
+    | Error e -> Error e
+  in
+  let res3 =
+    match List.find_opt Result.is_error [ res_tags; res_replies ] with
+    | Some (Error e) -> Error e
+    | Some (Ok _) -> assert false
+    | None -> Ok ()
+  in
+  let res4jpp =
+    match res_date with
+    | Ok _ -> Ok ()
+    | Error e -> Error e
+  in
+  match List.find_opt Result.is_error [ res0; res1; res2; res3; res4jpp ] with
+  | Some (Error e) -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
+  | None -> (
+    match
+      ( res_nick
+      , res_comment
+      , res_image_name
+      , res_date
+      , res_subject
+      , res_latlng
+      , res_tags
+      , res_replies )
+    with
+    | ( Ok nick
+      , Ok comment
+      , Ok image_name
+      , Ok date
+      , Ok _subject
+      , Ok _latlng
+      , Ok _tags
+      , Ok replies ) ->
+      let image_view =
+        match image_name with
+        | Some image_name ->
+          (*TODO thumbnails *)
+          Format.sprintf
+            {|
+    <div class="file">
+        <a title="%s" href="/post_pic/%s">
+        <img src="/post_pic/%s" style="width:100" loading="lazy">
+        </a>
+    </div> 
+|}
+            image_name post_id post_id
+        | None -> ""
+      in
+      let replies_view =
+        {|<div class="repliesLink">|}
+        ^ String.concat ""
+            (List.map
+               (fun reply_id ->
+                 Format.sprintf {|<a class="replyLink" href="#%s">>>%s</a>|}
+                   reply_id reply_id )
+               replies )
+        ^ {|</div> |}
+      in
+      (* TODO how to display date, I should probably render everything on the client*)
+      let post_info_view =
+        Format.sprintf
+          {|
+    <div class="postInfo"
+        <span class=nick>%s</span>
+        <span class=date unix-time="%d"></span>
+        <span class=postNo>
+            <a href="#%s" title="Link to this post">No.</a>
+            <a href="javascript:insert_quote('%s')" "class=quoteLink title="Reply to this post">%s</a>
+        </span>
+        %s
+    </div>|}
+          nick date post_id post_id post_id replies_view
+      in
+
+      Ok
+        (Format.sprintf
+           {|
+<div class="post" id="%s">
+    %s
+    %s
+    <blockquote class="comment">%s</blockquote> 
+</div> 
+|}
+           post_id post_info_view image_view comment )
+    | _ -> assert false )
+  | _ -> assert false
+
+let view_thread thread_id =
+  let res = Db.find_opt Q.is_thread thread_id in
+  match res with
+  | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
+  | Ok None -> Error "Not a thread"
+  | Ok (Some _) -> (
+    let thread_posts =
+      Db.fold Q.get_thread_posts
+        (fun post_id acc -> post_id :: acc)
+        thread_id []
+    in
+    match thread_posts with
+    | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
+    | Ok thread_posts -> (
+      (*order by date *)
+      (*TODO do this more clean *)
+      let dates =
+        List.map (fun post_id -> Db.find Q.get_post_date post_id) thread_posts
+      in
+      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 ->
+        let dates =
+          List.map
+            (function
+              | Ok date -> date
+              | Error _ -> assert false )
+            dates
+        in
+        let posts_dates = List.combine thread_posts dates in
+        let sorted_posts_dates =
+          List.sort (fun (_, a) (_, b) -> compare a b) posts_dates
+        in
+
+        let posts, _ = List.split sorted_posts_dates in
+        let view_posts = List.map view_post posts in
+        let view_posts =
+          List.map
+            (function
+              | Ok view -> view
+              | Error _ -> assert false )
+            (List.filter Result.is_ok view_posts)
+        in
+        Ok (String.concat "\n\r" view_posts) ) )
+
+let make_post ~comment ?file ~tags ?parent_id nick =
+  let is_valid_comment =
+    String.length comment < 10000
+    (*&& String.escaped comment = comment*)
+  in
+  let is_valid_file =
+    match file with
+    | Some (_, image_content) -> is_valid_image image_content
+    | None -> true
+  in
+  (* TODO latlng validation? *)
+  let is_valid_tags = String.length tags < 1000 in
+  let tag_list = Str.split (Str.regexp " +") tags in
+  match (is_valid_comment, is_valid_file, is_valid_tags) with
+  | false, _, _ -> Error "invalid comment"
+  | _, false, _ -> Error "invalid file"
+  | _, _, false -> Error "invalid tags"
+  | true, true, true -> (
+    (*TODO make post_id a int *)
+    let post_id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
+    (* add to plant_id <-> user*)
+    let res_post_id = Db.exec Q.upload_post_id (post_id, nick) in
+    let comment, cited_posts = parse_comment comment in
+
+    let res_comment = Db.exec Q.upload_post_comment (post_id, comment) in
+    let res_image =
+      match file with
+      | Some (image_name, image_content) ->
+        let image_name =
+          match image_name with
+          | Some image_name -> image_name
+          | None ->
+            (* make up random name if no name was given *)
+            Uuidm.to_string (Uuidm.v4_gen random_state ())
+        in
+        Db.exec Q.upload_post_image (post_id, image_name, image_content)
+      | None -> Ok ()
+    in
+    let res_tags =
+      match
+        List.find_opt Result.is_error
+          (List.map
+             (fun tag -> Db.exec Q.upload_post_tag (post_id, tag))
+             tag_list )
+      with
+      | Some (Error e) -> Error e
+      | Some _ -> assert false
+      | None -> Ok ()
+    in
+    (* TODO unix time *)
+    let date = int_of_float (Unix.time ()) in
+    let res_date = Db.exec Q.upload_post_date (post_id, date) in
+    let parent_id =
+      match parent_id with
+      | Some id -> id
+      | None -> post_id
+    in
+    let res_parent = Db.exec Q.upload_post_parent (post_id, parent_id) in
+    let res_citations =
+      match
+        List.find_opt Result.is_error
+          (List.map
+             (fun cited_id -> Db.exec Q.upload_post_reply (cited_id, post_id))
+             cited_posts )
+      with
+      | Some (Error e) -> Error e
+      | Some _ -> assert false
+      | None -> Ok ()
+    in
+    let res_thread = Db.exec Q.upload_to_thread (parent_id, post_id) in
+    let res =
+      List.find_opt Result.is_error
+        [ res_post_id
+        ; res_comment
+        ; res_image
+        ; res_tags
+        ; res_date
+        ; res_parent
+        ; res_citations
+        ; res_thread
+        ]
+    in
+    match res with
+    | Some (Error e) ->
+      (* TODO try to remove post_id from post_user to clean db*)
+      Error (Format.sprintf "db error: %s" (Caqti_error.show e))
+    | Some _ -> assert false
+    | None -> Ok post_id )
+
+let make_thread comment file (lat, lng) subject tags nick =
+  (* TODO latlng validation? *)
+  let is_valid_latlng = true in
+  let is_valid_subject =
+    String.length subject < 500 && String.escaped subject = subject
+  in
+  (* OP must have tags (?) *)
+  let is_valid_tags = String.length tags < 1000 && String.length tags > 0 in
+  match (is_valid_latlng, is_valid_subject, is_valid_tags) with
+  | false, _, _ -> Error "invalid coordinate"
+  | _, false, _ -> Error "invalid subject"
+  | _, _, false -> Error "invalid or empty tags"
+  | true, true, true -> (
+    let res_post = make_post ~comment ~file ~tags nick in
+    match res_post with
+    | Error e -> Error e
+    | Ok post_id -> (
+      (* add fields specific to OP *)
+      let res_gps = Db.exec Q.upload_post_gps (post_id, lat, lng) in
+      let res_subject = Db.exec Q.upload_post_subject (post_id, subject) in
+      let res = List.find_opt Result.is_error [ res_gps; res_subject ] in
+      match res with
+      | Some (Error e) ->
+        (* TODO try to remove post_id from post_user *)
+        Error (Format.sprintf "db error: %s" (Caqti_error.show e))
+      | Some _ -> assert false
+      | None -> Ok post_id ) )
+
+(* TODO make this return geojson directly *)
+let marker_list () =
+  let thread_id_list =
+    Db.fold Q.list_thread_ids (fun thread_id acc -> thread_id :: acc) () []
+  in
+  match thread_id_list with
+  | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
+  | Ok thread_id_list ->
+    let markers_res =
+      List.map
+        (fun thread_id ->
+          match Db.find_opt Q.get_post_gps thread_id with
+          | Ok (Some (lat, lng)) ->
+            let content =
+              match view_post thread_id with
+              | Ok s -> s
+              | Error e -> e
+            in
+            Ok (lat, lng, content, thread_id)
+          | Ok None -> Error "latlng not found"
+          | Error e ->
+            Error (Format.sprintf "db error: %s" (Caqti_error.show e)) )
+        thread_id_list
+    in
+    let markers =
+      List.map
+        (function
+          | Ok res -> res
+          | Error _ -> assert false )
+        (List.filter Result.is_ok markers_res)
+    in
+    Ok markers
+
+let marker_to_geojson marker =
+  match marker with
+  | lat, lng, content, thread_id ->
+    Format.sprintf
+      {|
+{
+  "type": "Feature",
+  "geometry": {
+    "type": "Point",
+    "coordinates": [%s,%s]
+  },
+  "properties": {
+    "content": "%s",
+    "thread_id": "%s"
+  }
+} 
+|}
+      (* geojson use lng lat, and not lat lng*)
+      (Float.to_string lng)
+      (Float.to_string lat) (String.escaped content) thread_id
+
+let get_post_image post_id =
+  let res = Db.find_opt Q.get_post_image_content post_id in
+  match res with
+  | Ok content -> (
+    match content with
+    | Some content -> Ok (Some content)
+    | None -> Error "Image not found" )
+  | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))

src/babillard_page.eml.html

@@ -0,0 +1,29 @@
+let f request =
+<script type="text/javascript" src="/assets/js/js_thread_map.js" defer="defer"></script>
+<%s  Format.sprintf "Babillard is love" %>
+      <div class="mb-3">
+%  begin match Dream.session "nick" request with
+%  | None ->
+
+%  | Some _nick ->
+        <%s! Dream.form_tag ~action:"/babillard" ~enctype:`Multipart_form_data request %>
+        <input type="hidden" id="lat_input" name="lat_input">
+        <input type="hidden" id="lng_input" name="lng_input">
+
+        <label for="subject" id="subjectLabel" class="form-label">Subject</label>
+        <input name="subject" type="text" class="form-control" id="subject" aria-labelledby="subjectLabel"></input>
+
+        <label for="threadComment" id="threadCommentLabel" class="form-label">Comment</label>
+        <textarea name="threadComment" type="text" class="form-control" id="threadComment" aria-labelledby="threadCommentLabel"></textarea>
+
+        <label for="tags" id="tagsLabel" class="form-label">Tags</label>
+        <input name="tags" type="text" class="form-control" id="tags" aria-labelledby="tagsLabel"></input>
+
+        <input id="file" name="file" aria-describedby="fileHelp" type="file">
+        <div id="fileHelp" class="form-text">Add a picture for your thread</div>
+      <button type="submit" class="btn btn-primary">Make Thread</button>
+    </form>
+%end;
+<div id="map"></div>
+<div id="thread_div"></div>
+      </div>

src/content/assets/js/dune

@@ -1,8 +1,17 @@
 (rule
- (target map.js)
+ (target js_plant_map.js)
  (deps
-  (file ../../../map.bc.js))
+  (file ../../../js_plant_map.bc.js))
  (action
   (with-stdout-to
    %{target}
-   (cat ../../../map.bc.js))))
+   (cat ../../../js_plant_map.bc.js))))
+
+(rule
+ (target js_thread_map.js)
+ (deps
+  (file ../../../js_thread_map.bc.js))
+ (action
+  (with-stdout-to
+   %{target}
+   (cat ../../../js_thread_map.bc.js))))

src/dune

@@ -1,6 +1,9 @@
 (executable
  (public_name permap)
  (modules
+  thread_page
+  babillard
+  babillard_page
   plant
   db
   app
@@ -29,8 +32,18 @@
   (pps lwt_ppx)))
 
 (executable
- (name map)
- (modules map)
+ (name js_plant_map)
+ (modules js_plant_map)
+ (libraries js_of_ocaml brr)
+ (modes js)
+ (js_of_ocaml
+  (javascript_files leaflet/leaflet.js))
+ (preprocess
+  (pps js_of_ocaml-ppx)))
+
+(executable
+ (name js_thread_map)
+ (modules js_thread_map)
  (libraries js_of_ocaml brr)
  (modes js)
  (js_of_ocaml
@@ -56,6 +69,18 @@
  (action
   (run dream_eml %{deps} --workspace %{workspace_root})))
 
+(rule
+ (targets babillard_page.ml)
+ (deps babillard_page.eml.html)
+ (action
+  (run dream_eml %{deps} --workspace %{workspace_root})))
+
+(rule
+ (targets thread_page.ml)
+ (deps thread_page.eml.html)
+ (action
+  (run dream_eml %{deps} --workspace %{workspace_root})))
+
 (rule
  (targets add_plant.ml)
  (deps add_plant.eml.html)
@@ -72,7 +97,8 @@
  (target content.ml)
  (deps
   (source_tree content)
-  (file content/assets/js/map.js))
+  (file content/assets/js/js_plant_map.js)
+  (file content/assets/js/js_thread_map.js))
  (action
   (with-stdout-to
    %{null}

src/js_plant_map.ml

@@ -1,4 +1,5 @@
 (* TODO only run this on /add_plant and /map *)
+(*TODO clean up this shit *)
 (*TODO use Jv.find everywhere (do we care?)*)
 let log = Format.printf
 
@@ -56,7 +57,6 @@ let on_click e =
   ignore @@ Jv.call popup "setContent" [| Jv.of_string "euujjj" |];
   ignore @@ Jv.call popup "openOn" [| map |];
 
-  (* TODO only on /add_plant *)
   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
@@ -64,6 +64,10 @@ let on_click e =
   ignore @@ Jv.call lat_input "setAttribute" [| Jv.of_string "value"; lat |];
   ignore @@ Jv.call lng_input "setAttribute" [| Jv.of_string "value"; lng |]
 
+let () =
+  (*add on_click callback to map*)
+  ignore @@ Jv.call map "on" [| Jv.of_string "click"; Jv.repr on_click |]
+
 module Marker = struct
   let on_each_feature feature layer =
     log "on_each_feature@.";
@@ -78,7 +82,7 @@ module Marker = struct
     (* TODO add onEachFeature *)
     let dict = Jv.obj [| ("onEachFeature", Jv.repr on_each_feature) |] in
     let layer = Jv.call leaflet "geoJSON" [| geojson; dict |] in
-    ignore @@ Jv.call layer "addTo" [| map |];
+    let _marker_layer = Jv.call layer "addTo" [| map |] in
     ()
 
   let handle_response response =
@@ -88,14 +92,11 @@ module Marker = struct
     ()
 
   let () =
-    (* TODO only on /map *)
-    log "fetch geojson@.";
+    log "fetch plant geojson@.";
     let window = Jv.get Jv.global "window" in
-    let fetchfutur = Jv.call window "fetch" [| Jv.of_string "/markers" |] in
+    let fetchfutur =
+      Jv.call window "fetch" [| Jv.of_string "/plant_markers" |]
+    in
     ignore @@ Jv.call fetchfutur "then" [| Jv.repr handle_response |];
     ()
 end
-
-let () =
-  (*add on_click callback to map*)
-  ignore @@ Jv.call map "on" [| Jv.of_string "click"; Jv.repr on_click |]

src/js_thread_map.ml

@@ -0,0 +1,147 @@
+(*TODO clean up this shit *)
+let log = Format.printf
+
+(* get the leaflet object *)
+let leaflet =
+  match Jv.(find global "L") with
+  | Some l -> l
+  | None -> failwith "can't load leaflet"
+
+(* get popup object *)
+let popup = Jv.call leaflet "popup" [||]
+
+(* create a map *)
+let map =
+  log "creating map@.";
+  let open Brr in
+  let _container = El.div ~at:At.[ id (Jstr.v "map") ] [] in
+  Jv.call leaflet "map" [| Jv.of_string "map" |]
+
+(* create map's pos *)
+let lat_lng =
+  log "making latlng@.";
+  Jv.call leaflet "latLng" [| Jv.of_float 51.505; Jv.of_float (-0.09) |]
+
+(* set map's pos *)
+let () =
+  log "setting view@.";
+  let _m : Jv.t = Jv.call map "setView" [| lat_lng; Jv.of_int 13 |] in
+  ()
+
+(* create map tile layer *)
+let tile_layer =
+  log "creating tile layer@.";
+  Jv.call leaflet "tileLayer"
+    [| Jv.of_string "https://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png"
+     ; Jv.obj
+         [| ( "attribution"
+            , Jv.of_string
+                {|&copy; <a href="https://.www.openstreetmap.org/copyright">OpenStreetMap</a> contributors|}
+            )
+         |]
+    |]
+
+(* add tile layer *)
+let () =
+  log "adding tile layer@.";
+  let _map : Jv.t = Jv.call tile_layer "addTo" [| map |] in
+  ()
+
+let on_click e =
+  log "on_click@.";
+
+  let lat_lng = Jv.get e "latlng" in
+  ignore @@ Jv.call popup "setLatLng" [| lat_lng |];
+  ignore @@ Jv.call popup "setContent" [| Jv.of_string "euujjj" |];
+  ignore @@ Jv.call popup "openOn" [| map |];
+
+  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 |]
+
+let () =
+  (*add on_click callback to map*)
+  ignore @@ Jv.call map "on" [| Jv.of_string "click"; Jv.repr on_click |]
+
+module Marker = struct
+  (* manipulate DOM to show thread in a div *)
+  let handle_thread_view thread_view =
+    log "handle_thread_view@.";
+    let thread_div = Jv.get Jv.global "thread_div" in
+    ignore @@ Jv.set thread_div "innerHTML" thread_view;
+    ()
+
+  let handle_response response =
+    log "handle_response@.";
+    let thread_view_futur = Jv.call response "text" [||] in
+    ignore @@ Jv.call thread_view_futur "then" [| Jv.repr handle_thread_view |];
+    ()
+
+  (*fuck you js*)
+  let marker_on_click thread_id _e =
+    log "marker_on_click@.";
+    let thread_id = Jv.to_string thread_id in
+    let window = Jv.get Jv.global "window" in
+    log "3@.";
+    let fetchfutur =
+      Jv.call window "fetch" [| Jv.of_string ("/thread_view/" ^ thread_id) |]
+    in
+    log "4@.";
+    ignore @@ Jv.call fetchfutur "then" [| Jv.repr handle_response |];
+    ()
+
+  let on_each_feature feature layer =
+    log "on_each_feature@.";
+    let feature_properties = Jv.get feature "properties" in
+    let feature_properties_content = Jv.get feature_properties "content" in
+    let thread_id = Jv.get feature_properties "thread_id" in
+    let layer = Jv.call layer "bindPopup" [| feature_properties_content |] in
+    ignore
+    @@ Jv.call layer "on"
+         [| Jv.of_string "click"; Jv.repr (marker_on_click thread_id) |];
+    ()
+
+  let handle_geojson geojson =
+    log "handle_geojson@.";
+    log "feed geojson to leaflet@.";
+    let dict = Jv.obj [| ("onEachFeature", Jv.repr on_each_feature) |] in
+    let layer = Jv.call leaflet "geoJSON" [| geojson; dict |] in
+    let _marker_layer = Jv.call layer "addTo" [| map |] in
+
+    ()
+
+  let markers_handle_response response =
+    log "markers_handle_response@.";
+    let geo_json_list_futur = Jv.call response "json" [||] in
+    ignore @@ Jv.call geo_json_list_futur "then" [| Jv.repr handle_geojson |];
+    ()
+
+  let () =
+    log "fetch thread geojson@.";
+    let window = Jv.get Jv.global "window" in
+    let fetchfutur =
+      Jv.call window "fetch" [| Jv.of_string "/thread_markers" |]
+    in
+    ignore @@ Jv.call fetchfutur "then" [| Jv.repr markers_handle_response |];
+    ()
+end
+
+(* called by clicking post_id to reply *)
+(* insert id into reply form *)
+let insert_quote post_id =
+  log "quote@.";
+  match Jv.(find global "replyComment") with
+  | None -> Jv.undefined
+  | Some comment_textarea ->
+    let content = Jv.get comment_textarea "value" in
+    let new_content =
+      Jv.call content "concat"
+        [| Jv.of_string ">>"; post_id; Jv.of_string " " |]
+    in
+    ignore @@ Jv.set comment_textarea "value" new_content;
+    Jv.undefined
+
+let () = Jv.set Jv.global "insert_quote" (Jv.repr insert_quote)

src/permap.ml

@@ -102,9 +102,9 @@ let profile_post request =
     | `Expired _
     | `Wrong_content_type -> (
       match%lwt Dream.multipart request with
-      | `Ok [ ("files", files) ] ->
+      | `Ok [ ("file", file) ] ->
         let res =
-          match User.upload_avatar files nick with
+          match User.upload_avatar file nick with
           | Ok () -> "Avatar was uploaded!"
           | Error e -> e
         in
@@ -142,6 +142,17 @@ let plant_image request =
   | Error _ ->
     Dream.empty `Not_Found
 
+let post_image request =
+  let post_id = Dream.param "post_id" request in
+  let image = Babillard.get_post_image post_id in
+  match image with
+  | Ok (Some image) ->
+    Dream.respond ~headers:[ ("Content-Type", "image") ] image
+  | Ok None
+  | Error _ ->
+    Dream.empty `Not_Found
+
+(* TODO fix *)
 let map request = page "map" request
 
 let add_plant_get request =
@@ -156,33 +167,25 @@ let add_plant_post request =
     match%lwt Dream.multipart request with
     | `Ok
         [ ("files", files)
-        ; ("lat_input", lat)
-        ; ("lng_input", lng)
-        ; ("tags", tags)
+        ; ("lat_input", [ (_, lat) ])
+        ; ("lng_input", [ (_, lng) ])
+        ; ("tags", [ (_, tags) ])
         ]
     | `Ok
         (("files", files)
-        :: ("lat_input", lat) :: ("lng_input", lng) :: ("tags", tags) :: _ :: _
+        :: ("lat_input", [ (_, lat) ])
+           :: ("lng_input", [ (_, lng) ]) :: ("tags", [ (_, tags) ]) :: _ :: _
         ) -> (
-      match tags with
-      | [] -> render_unsafe "Field tag is empty" request
-      | [ (_, tags) ] -> (
-        match (lat, lng) with
-        | [], _ -> render_unsafe "Field tag is empty" request
-        | _, [] -> render_unsafe "Field tag is empty" request
-        | [ (_, lat) ], [ (_, lng) ] -> (
-          match (Float.of_string_opt lat, Float.of_string_opt lng) with
-          | None, _ -> render_unsafe "Invalide coordinate" request
-          | _, None -> render_unsafe "Invalide coordinate" request
-          | Some lat, Some lng ->
-            let res =
-              match Plant.add_plant (lat, lng) tags files nick with
-              | Ok () -> "Your plant was uploaded!"
-              | Error e -> e
-            in
-            render_unsafe res request )
-        | _lat_lng -> Dream.empty `Bad_Request )
-      | _tags -> Dream.empty `Bad_Request )
+      match (Float.of_string_opt lat, Float.of_string_opt lng) with
+      | None, _ -> render_unsafe "Invalide coordinate" request
+      | _, None -> render_unsafe "Invalide coordinate" request
+      | Some lat, Some lng ->
+        let res =
+          match Plant.add_plant (lat, lng) tags files nick with
+          | Ok () -> "Your plant was uploaded!"
+          | Error e -> e
+        in
+        render_unsafe res request )
     | `Ok _ -> Dream.empty `Bad_Request
     | `Expired _
     | `Many_tokens _
@@ -192,7 +195,8 @@ let add_plant_post request =
     | `Wrong_content_type ->
       Dream.empty `Bad_Request )
 
-let markers request =
+let plant_markers request =
+  (*TODO should be in plant *)
   let marker_list = Plant.marker_list () in
   match marker_list with
   | Ok marker_list ->
@@ -204,6 +208,123 @@ let markers request =
     Dream.respond ~headers:[ ("Content-Type", "application/json") ] json
   | Error e -> render_unsafe e request
 
+let thread_markers request =
+  (*TODO should be in babillard*)
+  let marker_list = Babillard.marker_list () in
+  match marker_list with
+  | Ok marker_list ->
+    let json =
+      {| [ |}
+      ^ String.concat "," (List.map Babillard.marker_to_geojson marker_list)
+      ^ "]"
+    in
+    Dream.respond ~headers:[ ("Content-Type", "application/json") ] json
+  | Error e -> render_unsafe e request
+
+let babillard_get request = render_unsafe (Babillard_page.f request) request
+
+let babillard_post request =
+  match Dream.session "nick" request with
+  | None -> render_unsafe "Not logged in" request
+  | Some nick -> (
+    match%lwt Dream.multipart request with
+    (*TODO jpp du duplicat la *)
+    | `Ok
+        [ ("file", file)
+        ; ("lat_input", [ (_, lat) ])
+        ; ("lng_input", [ (_, lng) ])
+        ; ("subject", [ (_, subject) ])
+        ; ("tags", [ (_, tags) ])
+        ; ("threadComment", [ (_, comment) ])
+        ]
+    | `Ok
+        (("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
+      | Some lat, Some lng -> (
+        match file with
+        | [] -> render_unsafe "No image" request
+        | _ :: _ :: _ -> render_unsafe "More than one image" request
+        | [ file ] ->
+          let res =
+            match
+              Babillard.make_thread comment file (lat, lng) subject tags nick
+            with
+            | Ok _post_id -> "Your thread was posted on the babillard!"
+            | Error e -> e
+          in
+          render_unsafe res request ) )
+    | `Ok _ -> Dream.empty `Bad_Request
+    | `Expired _
+    | `Many_tokens _
+    | `Missing_token _
+    | `Invalid_token _
+    | `Wrong_session _
+    | `Wrong_content_type ->
+      Dream.empty `Bad_Request )
+
+let thread_get request =
+  let thread_id = Dream.param "thread_id" request in
+  let thread_view = Babillard.view_thread thread_id in
+  match thread_view with
+  | Error e -> render_unsafe e request
+  | Ok thread_view ->
+    render_unsafe (Thread_page.f thread_view thread_id request) request
+
+(* get thread view but not wrapped in template, so we can display it on /babillard*)
+let thread_view request =
+  let thread_id = Dream.param "thread_id" request in
+  let thread_view = Babillard.view_thread thread_id in
+  match thread_view with
+  | Error e -> render_unsafe e request
+  | Ok thread_view ->
+    Dream.respond
+      ~headers:[ ("Content-Type", "html") ]
+      (Thread_page.f thread_view thread_id request)
+
+(*form to reply to a thread *)
+let thread_post request =
+  match Dream.session "nick" request with
+  | None -> render_unsafe "Not logged in" request
+  | Some nick -> (
+    match%lwt Dream.multipart request with
+    | `Ok
+        [ ("file", file)
+        ; ("replyComment", [ (_, comment) ])
+        ; ("tags", [ (_, tags) ])
+        ]
+    | `Ok
+        (("file", file)
+        :: ("tags", [ (_, tags) ])
+           :: ("replyComment", [ (_, comment) ]) :: _ :: _ ) ->
+      let parent_id = Dream.param "thread_id" request in
+      let res =
+        match file with
+        | [] -> Babillard.make_post ~comment ~tags ~parent_id nick
+        | [ file ] -> Babillard.make_post ~comment ~file ~tags ~parent_id nick
+        | _ :: _ :: _ -> Error "More than one image"
+      in
+      let msg =
+        match res with
+        | Ok _post_id -> "Your reply was posted"
+        | Error e -> e
+      in
+      render_unsafe msg request
+    | `Ok _ -> Dream.empty `Bad_Request
+    | `Expired _
+    | `Many_tokens _
+    | `Missing_token _
+    | `Invalid_token _
+    | `Wrong_session _
+    | `Wrong_content_type ->
+      Dream.empty `Bad_Request )
+
 let () =
   Dream.run @@ Dream.logger @@ Dream.memory_sessions
   @@ Dream.router
@@ -223,6 +344,13 @@ let () =
        ; Dream.get "/add_plant" add_plant_get
        ; Dream.post "/add_plant" add_plant_post
        ; Dream.get "/plant_pic/:plant_id/:nb" plant_image
-       ; Dream.get "/markers" markers
+       ; Dream.get "/plant_markers" plant_markers
+       ; Dream.get "/thread_markers" thread_markers
+       ; Dream.get "/thread_view/:thread_id" thread_view
+       ; Dream.get "/babillard" babillard_get
+       ; Dream.post "/babillard" babillard_post
+       ; Dream.get "/babillard/:thread_id" thread_get (*todo, bad names ^^*)
+       ; Dream.post "/babillard/:thread_id" thread_post
+       ; Dream.get "/post_pic/:post_id" post_image
        ]
   @@ Dream.not_found

src/plant.ml

@@ -83,6 +83,7 @@ let () =
   then
     Dream.warning (fun log -> log "can't create table")
 
+(* TODO make it return a Result? *)
 let view_plant plant_id =
   let count = Db.find_opt Q.count_plant_image plant_id in
   match count with
@@ -186,18 +187,19 @@ let get_plant_image plant_id nb =
   | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
 
 let add_plant (lat, lng) tags files nick =
-  let tags_len = String.length tags in
-  if tags_len > 1000 then
+  if String.length tags > 1000 then
     Error "tags too long"
   else
     let tag_list = Str.split (Str.regexp " +") tags in
-    (* id for plant*)
-    let ok_list = List.map (fun (_, content) -> is_valid_image content) files in
-    let valid_files = List.for_all (fun valid -> valid) ok_list in
-    if not valid_files then
+    let is_valid_list =
+      List.map (fun (_, content) -> is_valid_image content) files
+    in
+    let is_valid_files = List.for_all (fun valid -> valid) is_valid_list in
+    if not is_valid_files then
       Error "Invalid image"
     else
       (* add plant to db *)
+      (* make id for plant*)
       let plant_id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
       (* add to plant_id <-> user*)
       let res_plant = Db.exec Q.upload_plant_id (plant_id, nick) in
@@ -216,9 +218,11 @@ let add_plant (lat, lng) tags files nick =
               (fun tag -> Db.exec Q.upload_plant_tag (plant_id, tag))
               tag_list
           in
-          if List.exists Result.is_error res_tags then
-            Error (Format.sprintf "db error")
-          else
+          match List.find_opt Result.is_error res_tags with
+          | Some (Error e) ->
+            Error (Format.sprintf "db error: %s" (Caqti_error.show e))
+          | Some _ -> assert false
+          | None -> (
             (* add to plant_id <-> image*)
             let res_images =
               List.find_opt Result.is_error
@@ -231,4 +235,4 @@ let add_plant (lat, lng) tags files nick =
             | Some (Error e) ->
               Error (Format.sprintf "db error: %s" (Caqti_error.show e))
             | Some (Ok _) -> assert false
-            | None -> Ok () ) )
+            | None -> Ok () ) ) )

src/template.eml.html

@@ -43,6 +43,9 @@ let render_unsafe ~title ~content request =
                           <li class="nav-item">
                               <a class="nav-link" href="/map">Map</a>
                           </li>
+                          <li class="nav-item">
+                              <a class="nav-link" href="/babillard">Babillard</a>
+                          </li>
                           <li class="nav-item">
                               <a class="nav-link" href="/user">Users</a>
                           </li>
@@ -67,6 +70,5 @@ let render_unsafe ~title ~content request =
         </footer>
       </main>
       <script src="/assets/js/bootstrap.bundle.min.js"></script>
-      <script type="text/javascript" src="/assets/js/map.js" defer="defer"></script>
     </body>
   </html>

src/thread_page.eml.html

@@ -0,0 +1,25 @@
+let f thread_view thread_id request =
+<script type="text/javascript" src="/assets/js/js_thread_map.js" defer="defer"></script>
+<%s  Format.sprintf "[Reply]" %>
+      <%s! thread_view %>
+
+% begin match Dream.session "nick" request with
+% | None ->
+
+% | Some _ ->
+      <div class="mb-3">
+        <%s! Dream.form_tag ~action:( Format.sprintf "/babillard/%s" thread_id)
+        ~enctype:`Multipart_form_data request %>
+
+        <label for="replyComment" id="replyCommentLabel" class="form-label">Comment</label>
+        <textarea name="replyComment" type="text" class="form-control" id="replyComment" aria-labelledby="replyCommentLabel"></textarea>
+
+        <label for="tags" id="tagsLabel" class="form-label">Tags</label>
+        <input name="tags" type="text" class="form-control" id="tags" aria-labelledby="tagsLabel"></input>
+
+        <input id="file" name="file" aria-describedby="fileHelp" type="file">
+        <div id="fileHelp" class="form-text">Add a picture to your post</div>
+      <button type="submit" class="btn btn-primary">Reply</button>
+      </div>
+    </form>
+% end;

src/user_profile.eml.html

@@ -11,7 +11,7 @@ let f nick bio request =
 
     <img src="/user/<%s nick %>/avatar" class="img-thumbnail" alt="Your avatar picture">
     <%s! Dream.form_tag ~action:"/profile" ~enctype:`Multipart_form_data request %>
-      <input name="files" type="file" multiple>
+      <input name="file" type="file">
       <button>Submit!</button>
     </form>
     <%s! Plant.view_user_plant_list nick %>