diff --git a/src/add_plant.eml.html b/src/add_plant.eml.html index 9c567ad..d7ff24c 100644 --- a/src/add_plant.eml.html +++ b/src/add_plant.eml.html @@ -15,3 +15,4 @@ let f nick request = + diff --git a/src/babillard.ml b/src/babillard.ml new file mode 100644 index 0000000..ed32dbd --- /dev/null +++ b/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 {|%s|} 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 + {| +
+ + + +
+|} + image_name post_id post_id + | None -> "" + in + let replies_view = + {|
|} + ^ String.concat "" + (List.map + (fun reply_id -> + Format.sprintf {|>>%s|} + reply_id reply_id ) + replies ) + ^ {|
|} + in + (* TODO how to display date, I should probably render everything on the client*) + let post_info_view = + Format.sprintf + {| +
%s + + + No. + %s + + %s +
|} + nick date post_id post_id post_id replies_view + in + + Ok + (Format.sprintf + {| +
+ %s + %s +
%s
+
+|} + 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)) diff --git a/src/babillard_page.eml.html b/src/babillard_page.eml.html new file mode 100644 index 0000000..e8f1f32 --- /dev/null +++ b/src/babillard_page.eml.html @@ -0,0 +1,29 @@ +let f request = + +<%s Format.sprintf "Babillard is love" %> +
+% begin match Dream.session "nick" request with +% | None -> + +% | Some _nick -> + <%s! Dream.form_tag ~action:"/babillard" ~enctype:`Multipart_form_data request %> + + + + + + + + + + + + + +
Add a picture for your thread
+ + +%end; +
+
+
diff --git a/src/content/assets/js/dune b/src/content/assets/js/dune index 92ee040..2a624ae 100644 --- a/src/content/assets/js/dune +++ b/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)))) diff --git a/src/dune b/src/dune index bf32499..19aba30 100644 --- a/src/dune +++ b/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} diff --git a/src/map.ml b/src/js_plant_map.ml similarity index 93% rename from src/map.ml rename to src/js_plant_map.ml index d097410..b2b4b6d 100644 --- a/src/map.ml +++ b/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 |] diff --git a/src/js_thread_map.ml b/src/js_thread_map.ml new file mode 100644 index 0000000..199fa4e --- /dev/null +++ b/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 + {|© OpenStreetMap 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) diff --git a/src/permap.ml b/src/permap.ml index f25323a..9a7c9e8 100644 --- a/src/permap.ml +++ b/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 diff --git a/src/plant.ml b/src/plant.ml index 4652ff0..d5ac6ee 100644 --- a/src/plant.ml +++ b/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 () ) ) ) diff --git a/src/template.eml.html b/src/template.eml.html index d305546..a13c1f2 100644 --- a/src/template.eml.html +++ b/src/template.eml.html @@ -43,6 +43,9 @@ let render_unsafe ~title ~content request =
  • Map
    • +
  • + Babillard +
  • Users
    • @@ -67,6 +70,5 @@ let render_unsafe ~title ~content request = - diff --git a/src/thread_page.eml.html b/src/thread_page.eml.html new file mode 100644 index 0000000..c065a20 --- /dev/null +++ b/src/thread_page.eml.html @@ -0,0 +1,25 @@ +let f thread_view thread_id request = + +<%s Format.sprintf "[Reply]" %> + <%s! thread_view %> + +% begin match Dream.session "nick" request with +% | None -> + +% | Some _ -> +
    + <%s! Dream.form_tag ~action:( Format.sprintf "/babillard/%s" thread_id) + ~enctype:`Multipart_form_data request %> + + + + + + + + +
    Add a picture to your post
    + +
    + +% end; diff --git a/src/user_profile.eml.html b/src/user_profile.eml.html index 2e3f6bf..eae520e 100644 --- a/src/user_profile.eml.html +++ b/src/user_profile.eml.html @@ -11,7 +11,7 @@ let f nick bio request = Your avatar picture <%s! Dream.form_tag ~action:"/profile" ~enctype:`Multipart_form_data request %> - + <%s! Plant.view_user_plant_list nick %>