From 56e0e02a7bd4756810728c06aff08100951fa1ce Mon Sep 17 00:00:00 2001 From: Swrup Date: Tue, 18 Jan 2022 00:12:03 +0100 Subject: [PATCH] remove plants :( --- src/babillard.ml | 7 +- src/babillard_page.eml.html | 8 +- src/content/assets/js/dune | 9 -- src/dune | 18 --- src/js_plant_map.ml | 100 -------------- src/newthread_page.eml.html | 5 +- src/permap.ml | 13 +- src/plant.ml | 255 ------------------------------------ src/plants_page.eml.html | 20 --- src/template.eml.html | 3 - 10 files changed, 12 insertions(+), 426 deletions(-) delete mode 100644 src/js_plant_map.ml delete mode 100644 src/plant.ml delete mode 100644 src/plants_page.eml.html diff --git a/src/babillard.ml b/src/babillard.ml index acb9bc1..cea63bd 100644 --- a/src/babillard.ml +++ b/src/babillard.ml @@ -2,20 +2,15 @@ open Db exception Invalid_post of string -type board = - | Plants - | Babillard +type board = Babillard let int_of_board = function - | Plants -> 0 | Babillard -> 1 let pp_board fmt = function - | Plants -> Format.fprintf fmt "plants" | Babillard -> Format.fprintf fmt "babillard" let board_of_int = function - | 0 -> Plants | 1 -> Babillard | _ -> raise (Invalid_argument "board_of_int") diff --git a/src/babillard_page.eml.html b/src/babillard_page.eml.html index 01c2d90..4f587f1 100644 --- a/src/babillard_page.eml.html +++ b/src/babillard_page.eml.html @@ -1,6 +1,7 @@ -let f request = +let f ~board request = +%let board = Format.asprintf "%a" Babillard.pp_board board in -
+
> <%s Format.sprintf "Babillard is love" %>
@@ -9,7 +10,8 @@ let f request = % | None -> % | Some _nick -> -[New Thread] +%let url = Format.sprintf "/%s/new_thread" board in +>[New Thread] % end;
diff --git a/src/content/assets/js/dune b/src/content/assets/js/dune index 96effaf..a71da68 100644 --- a/src/content/assets/js/dune +++ b/src/content/assets/js/dune @@ -1,12 +1,3 @@ -(rule - (target js_plant_map.js) - (deps - (file ../../../js_plant_map.bc.js)) - (action - (with-stdout-to - %{target} - (cat ../../../js_plant_map.bc.js)))) - (rule (target js_babillard.js) (deps diff --git a/src/dune b/src/dune index 8862041..4e3f6da 100644 --- a/src/dune +++ b/src/dune @@ -5,7 +5,6 @@ thread_page babillard babillard_page - plants_page db app content @@ -30,16 +29,6 @@ (preprocess (pps lwt_ppx))) -(executable - (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_babillard) (modules js_babillard) @@ -106,12 +95,6 @@ (action (run dream_eml %{deps} --workspace %{workspace_root}))) -(rule - (targets plants_page.ml) - (deps plants_page.eml.html) - (action - (run dream_eml %{deps} --workspace %{workspace_root}))) - (rule (targets user_profile.ml) (deps user_profile.eml.html) @@ -122,7 +105,6 @@ (target content.ml) (deps (source_tree content) - (file content/assets/js/js_plant_map.js) (file content/assets/js/js_babillard.js) (file content/assets/js/js_newthread.js) (file content/assets/js/js_thread.js)) diff --git a/src/js_plant_map.ml b/src/js_plant_map.ml deleted file mode 100644 index 9799c29..0000000 --- a/src/js_plant_map.ml +++ /dev/null @@ -1,100 +0,0 @@ -let log = Format.printf - -module Leaflet = struct - (* 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 |] - - (*add on_click callback to map*) - let () = - ignore @@ Jv.call map "on" [| Jv.of_string "click"; Jv.repr on_click |] -end - -module Marker = struct - 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 - ignore @@ Jv.call layer "bindPopup" [| feature_properties_content |]; - () - - 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.leaflet "geoJSON" [| geojson; dict |] in - let _marker_layer = Jv.call layer "addTo" [| Leaflet.map |] in - () - - let handle_response response = - log "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 plant geojson@."; - let window = Jv.get Jv.global "window" in - let fetchfutur = - Jv.call window "fetch" [| Jv.of_string "/plant_markers" |] - in - ignore @@ Jv.call fetchfutur "then" [| Jv.repr handle_response |]; - () -end diff --git a/src/newthread_page.eml.html b/src/newthread_page.eml.html index 304148d..3a7c199 100644 --- a/src/newthread_page.eml.html +++ b/src/newthread_page.eml.html @@ -1,11 +1,12 @@ let f ~board request = -%let url = Format.asprintf "/%a/new_thread" Babillard.pp_board board in +%let board = Format.asprintf "%a" Babillard.pp_board board in +%let url = Format.sprintf "/%s/new_thread" board in % begin match Dream.session "nick" request with % | None -> Login to make a new thread. % | Some _nick -> -
Click the map to make a new thread:
+
>Click the map to make a new thread:
diff --git a/src/permap.ml b/src/permap.ml index 1c6a8d0..4080177 100644 --- a/src/permap.ml +++ b/src/permap.ml @@ -148,8 +148,6 @@ let post_image request = | Ok image -> Dream.respond ~headers:[ ("Content-Type", "image") ] image | Error _ -> Dream.empty `Not_Found -let plants_get request = render_unsafe (Plants_page.f request) request - let markers ~board request = let markers = Babillard.get_markers board in match markers with @@ -157,7 +155,8 @@ let markers ~board request = Dream.respond ~headers:[ ("Content-Type", "application/json") ] markers | Error e -> render_unsafe e request -let babillard_get request = render_unsafe (Babillard_page.f request) request +let babillard_get ~board request = + render_unsafe (Babillard_page.f ~board request) request let newthread_get ~board request = render_unsafe (Newthread_page.f ~board request) request @@ -283,15 +282,9 @@ let () = ; Dream.get "/profile" profile_get ; Dream.post "/profile" profile_post ; Dream.get "/thread_view/:thread_id" thread_view - ; Dream.get "/plants/markers" (markers ~board:Plants) ; Dream.get "/babillard/markers" (markers ~board:Babillard) - ; Dream.get "/plants" plants_get - ; Dream.get "/plants/new_thread" (newthread_get ~board:Plants) - ; Dream.post "/plants/new_thread" (newthread_post ~board:Plants) - ; Dream.get "/plants/:thread_id" thread_get (*todo, bad names ^^*) - ; Dream.post "/plants/:thread_id" reply_post ; Dream.get "/post_pic/:post_id" post_image - ; Dream.get "/babillard" babillard_get + ; Dream.get "/babillard" (babillard_get ~board:Babillard) ; Dream.get "/babillard/new_thread" (newthread_get ~board:Babillard) ; Dream.post "/babillard/new_thread" (newthread_post ~board:Babillard) ; Dream.get "/babillard/:thread_id" thread_get diff --git a/src/plant.ml b/src/plant.ml deleted file mode 100644 index 86b6f2c..0000000 --- a/src/plant.ml +++ /dev/null @@ -1,255 +0,0 @@ -(*TODO implement plants as special posts? *) -open Db - -type t = - { id : string - ; date : int - ; nick : string (*TODO ? ; comment : string *) - ; images : (string * string) list - ; tags : string list - ; longitude : float - ; latitude : float - ; replies : string list - ; citations : string list - } - -(* ('a option, string) result *) -let ( let** ) o f = - match o with - | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) - | Ok None -> Error (Format.sprintf "db error: value not found") - | Ok (Some x) -> f x - -(* ('a, string) result *) -let ( let* ) o f = - match o with - | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) - | Ok x -> f x - -module Q = struct - let create_plant_user_table = - Caqti_request.exec Caqti_type.unit - "CREATE TABLE IF NOT EXISTS plant_user (plant_id TEXT, nick TEXT, \ - PRIMARY KEY(plant_id), FOREIGN KEY(nick) REFERENCES user(nick));" - - let create_plant_image_table = - Caqti_request.exec Caqti_type.unit - "CREATE TABLE IF NOT EXISTS plant_image ( plant_id TEXT, image TEXT,id \ - INTEGER, FOREIGN KEY(plant_id) REFERENCES plant_user(plant_id));" - - let create_plant_tag_table = - Caqti_request.exec Caqti_type.unit - "CREATE TABLE IF NOT EXISTS plant_tag (plant_id TEXT, tag TEXT, FOREIGN \ - KEY(plant_id) REFERENCES plant_user(plant_id));" - - let create_plant_gps_table = - Caqti_request.exec Caqti_type.unit - "CREATE TABLE IF NOT EXISTS plant_gps (plant_id TEXT, lat FLOAT,lng \ - FLOAT, FOREIGN KEY(plant_id) REFERENCES plant_user(plant_id));" - - let upload_plant_id = - Caqti_request.exec - Caqti_type.(tup2 string string) - "INSERT INTO plant_user VALUES (?,?);" - - let upload_plant_tag = - Caqti_request.exec - Caqti_type.(tup2 string string) - "INSERT INTO plant_tag VALUES (?,?);" - - let upload_plant_gps = - Caqti_request.exec - Caqti_type.(tup3 string float float) - "INSERT INTO plant_gps VALUES (?,?,?);" - - let upload_plant_image = - Caqti_request.exec - Caqti_type.(tup3 string string int) - "INSERT INTO plant_image VALUES (?,?,?);" - - let get_user_plants = - Caqti_request.collect Caqti_type.string Caqti_type.string - "SELECT plant_id FROM plant_user WHERE nick=?;" - - let list_plant_ids = - Caqti_request.collect Caqti_type.unit Caqti_type.string - "SELECT plant_id FROM plant_user;" - - let count_plant_image = - Caqti_request.find_opt Caqti_type.string Caqti_type.int - "SELECT COUNT(*) FROM plant_image WHERE plant_id=?;" - - let get_plant_image = - Caqti_request.find_opt - Caqti_type.(tup2 string int) - Caqti_type.string - "SELECT image FROM plant_image WHERE plant_id=? AND id=?;" - - let get_plant_tags = - Caqti_request.collect Caqti_type.string Caqti_type.string - "SELECT tag FROM plant_tag WHERE plant_id=?;" - - let get_plant_gps = - Caqti_request.find_opt Caqti_type.string - Caqti_type.(tup2 float float) - "SELECT lat, lng FROM plant_gps WHERE plant_id=?;" -end - -let () = - let tables = - [ Q.create_plant_user_table - ; Q.create_plant_image_table - ; Q.create_plant_tag_table - ; Q.create_plant_gps_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") - -let view_plant plant_id = - let** count = Db.find_opt Q.count_plant_image plant_id in - let gps = - match Db.find_opt Q.get_plant_gps plant_id with - | Ok (Some (lat, lng)) -> Float.to_string lat ^ " " ^ Float.to_string lng - | Ok None -> "" - | Error e -> Format.sprintf "db error: %s" (Caqti_error.show e) - in - let images = - String.concat "\n" - (List.map - (Format.sprintf - {|
    • |} - plant_id ) - (List.init count (fun i -> i)) ) - in - let tags = Db.fold Q.get_plant_tags (fun tag acc -> tag :: acc) plant_id [] in - match tags with - | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) - | Ok tags -> - let tags = String.concat " " tags in - (* TODO add link to gps/map too *) - Ok (images ^ tags ^ gps) - -let marker_list () = - let* plant_id_list = - Db.fold Q.list_plant_ids (fun plant_id acc -> plant_id :: acc) () [] - in - let markers_res = - List.map - (fun plant_id -> - match Db.find_opt Q.get_plant_gps plant_id with - | Ok (Some (lat, lng)) -> ( - let content = view_plant plant_id in - match content with - | Error e -> Error e - | Ok content -> Ok (lat, lng, content) ) - | Ok None -> Error "latlng not found" - | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) - ) - plant_id_list - in - let markers = - List.map - (fun res -> - match res with - | 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 -> - Format.sprintf - {| -{ - "type": "Feature", - "geometry": { - "type": "Point", - "coordinates": [%s,%s] - }, - "properties": { - "content": "%s" - } -} -|} - (* geojson use lng lat, and not lat lng*) - (Float.to_string lng) - (Float.to_string lat) (String.escaped content) - -let view_user_plant_list nick = - let plant_id_list = - Db.fold Q.get_user_plants (fun plant_id acc -> plant_id :: acc) nick [] - in - match plant_id_list with - | Error e -> Format.sprintf "db error: %s" (Caqti_error.show e) - | Ok plant_id_list -> - let plants = - List.map - (fun p -> - match view_plant p with - | Ok p -> p - | Error _ -> "" ) - plant_id_list - in - String.concat "\n" plants - -let get_plant_image plant_id nb = - let** content = Db.find_opt Q.get_plant_image (plant_id, nb) in - Ok content - -(*TODO split validation and uploading to db like for babillard *) -let add_plant (lat, lng) tags files nick = - if String.length tags > 1000 then - Error "tags too long" - else - let tag_list = Str.split (Str.regexp " +") tags in - 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 - match res_plant with - | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) - | Ok _ -> ( - (* add to plant_id <-> gps table*) - (*TODO check if valid latlng *) - let res_gps = Db.exec Q.upload_plant_gps (plant_id, lat, lng) in - match res_gps with - | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) - | Ok _ -> ( - (* add to plant_id <-> tag table*) - let res_tags = - List.map - (fun tag -> Db.exec Q.upload_plant_tag (plant_id, tag)) - tag_list - in - 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 - (List.mapi - (fun nb (_, content) -> - Db.exec Q.upload_plant_image (plant_id, content, nb) ) - files ) - in - match res_images with - | Some (Error e) -> - Error (Format.sprintf "db error: %s" (Caqti_error.show e)) - | Some (Ok _) -> assert false - | None -> Ok () ) ) ) diff --git a/src/plants_page.eml.html b/src/plants_page.eml.html deleted file mode 100644 index 4e2fb22..0000000 --- a/src/plants_page.eml.html +++ /dev/null @@ -1,20 +0,0 @@ -let f request = - -
    -<%s Format.sprintf "Plants is love" %> -
    -
    -
    -% begin match Dream.session "nick" request with -% | None -> - -% | Some _nick -> -[New Thread] -% end; -
    -
    -
    -
    - -
    -
    diff --git a/src/template.eml.html b/src/template.eml.html index 7daf5d4..4273bc5 100644 --- a/src/template.eml.html +++ b/src/template.eml.html @@ -37,9 +37,6 @@ let render_unsafe ~title ~content request = Logout % end; -
  • - Plants -
  • Babillard