diff --git a/src/content/assets/img/layers-2x.png b/src/content/assets/img/layers-2x.png new file mode 100644 index 0000000..200c333 Binary files /dev/null and b/src/content/assets/img/layers-2x.png differ diff --git a/src/content/assets/img/layers.png b/src/content/assets/img/layers.png new file mode 100644 index 0000000..1a72e57 Binary files /dev/null and b/src/content/assets/img/layers.png differ diff --git a/src/content/assets/img/marker-icon-2x.png b/src/content/assets/img/marker-icon-2x.png new file mode 100644 index 0000000..88f9e50 Binary files /dev/null and b/src/content/assets/img/marker-icon-2x.png differ diff --git a/src/content/assets/img/marker-icon.png b/src/content/assets/img/marker-icon.png new file mode 100644 index 0000000..950edf2 Binary files /dev/null and b/src/content/assets/img/marker-icon.png differ diff --git a/src/content/assets/img/marker-shadow.png b/src/content/assets/img/marker-shadow.png new file mode 100644 index 0000000..9fd2979 Binary files /dev/null and b/src/content/assets/img/marker-shadow.png differ diff --git a/src/dune b/src/dune index dea9cf7..5e7f840 100644 --- a/src/dune +++ b/src/dune @@ -75,3 +75,13 @@ (with-stdout-to %{null} (run ocaml-crunch -m plain content -o %{target})))) + +(install + (section share) + (files + ./content/assets/css/leaflet.css + (./content/assets/img/layers-2x.png as images/layers-2x.png) + (./content/assets/img/layers.png as images/layers.png) + (./content/assets/img/marker-icon-2x.png as images/marker-icon-2x.png) + (./content/assets/img/marker-icon.png as images/marker-icon.png) + (./content/assets/img/marker-shadow.png as images/marker-shadow.png))) diff --git a/src/map.ml b/src/map.ml index 1f90c59..70f6214 100644 --- a/src/map.ml +++ b/src/map.ml @@ -56,6 +56,7 @@ 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 @@ -63,6 +64,41 @@ 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_marker lat lng content = + log "add_marker@."; + + let marker = + Jv.call leaflet "marker" [| Jv.of_array Jv.of_float [| lat; lng |] |] + in + ignore @@ Jv.call marker "bindPopup" [| Jv.of_string content |]; + ignore @@ Jv.call marker "addTo" [| map |] +*) + +let handle_geojson geojson = + log "handle_geojson@."; + log "feed geojson to leaflet@."; + let layer = Jv.call leaflet "geoJSON" [| geojson |] in + ignore @@ Jv.call layer "addTo" [| map |]; + (* TODO this doesnt work :^) *) + () + +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 () = + (* TODO only on /map *) + (* TODO add marker for plants on the map *) + (* TODO GET /markers -> geojson *) + (* TODO make popup *) + log "fetch geojson@."; + let window = Jv.get Jv.global "window" in + let fetchfutur = Jv.call window "fetch" [| Jv.of_string "/markers" |] in + ignore @@ Jv.call fetchfutur "then" [| Jv.repr handle_response |]; + () + let () = (*add on_click callback to map*) ignore @@ Jv.call map "on" [| Jv.of_string "click"; Jv.repr on_click |] diff --git a/src/permap.ml b/src/permap.ml index 3994542..cf59c60 100644 --- a/src/permap.ml +++ b/src/permap.ml @@ -170,13 +170,17 @@ let add_plant_post request = match (lat, lng) with | [], _ -> render_unsafe "Field tag is empty" request | _, [] -> render_unsafe "Field tag is empty" request - | [ (_, lat) ], [ (_, lng) ] -> - let res = - match User.add_plant (lat, lng) tags files nick with - | Ok () -> "Your plant was uploaded!" - | Error e -> e - in - render_unsafe res 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 User.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 ) | `Ok _ -> Dream.empty `Bad_Request @@ -188,6 +192,18 @@ let add_plant_post request = | `Wrong_content_type -> Dream.empty `Bad_Request ) +let markers request = + let marker_list = User.marker_list () in + match marker_list with + | Ok marker_list -> + let json = + {| [ |} + ^ String.concat "," (List.map User.marker_to_geojson marker_list) + ^ "]" + in + Dream.respond ~headers:[ ("Content-Type", "application/json") ] json + | Error e -> render_unsafe e request + let () = Dream.run @@ Dream.logger @@ Dream.memory_sessions @@ Dream.router @@ -207,5 +223,6 @@ 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.not_found diff --git a/src/template.eml.html b/src/template.eml.html index d305546..cfd145c 100644 --- a/src/template.eml.html +++ b/src/template.eml.html @@ -7,6 +7,7 @@ let render_unsafe ~title ~content request = +
diff --git a/src/user.ml b/src/user.ml index 9079c86..775e320 100644 --- a/src/user.ml +++ b/src/user.ml @@ -29,8 +29,8 @@ module Q = struct let create_plant_gps_table = Caqti_request.exec Caqti_type.unit - "CREATE TABLE IF NOT EXISTS plant_gps (plant_id TEXT, lat TEXT,lng TEXT, \ - FOREIGN KEY(plant_id) REFERENCES plant_user(plant_id));" + "CREATE TABLE IF NOT EXISTS plant_gps (plant_id TEXT, lat FLOAT,lng \ + FLOAT, FOREIGN KEY(plant_id) REFERENCES plant_user(plant_id));" let get_password = Caqti_request.find_opt Caqti_type.string Caqti_type.string @@ -86,7 +86,7 @@ module Q = struct let upload_plant_gps = Caqti_request.exec - Caqti_type.(tup3 string string string) + Caqti_type.(tup3 string float float) "INSERT INTO plant_gps VALUES (?,?,?);" let upload_plant_image = @@ -98,6 +98,10 @@ module Q = struct 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=?;" @@ -114,7 +118,7 @@ module Q = struct let get_plant_gps = Caqti_request.find_opt Caqti_type.string - Caqti_type.(tup2 string string) + Caqti_type.(tup2 float float) "SELECT lat, lng FROM plant_gps WHERE plant_id=?;" end @@ -208,7 +212,8 @@ let view_plant plant_id = | Some count -> ( let gps = match Db.find_opt Q.get_plant_gps plant_id with - | Ok (Some (lat, lng)) -> lat ^ " " ^ lng + | 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 @@ -230,6 +235,55 @@ let view_plant plant_id = | None -> "db error" ) | Error e -> Format.sprintf "db error: %s" (Caqti_error.show e) +let marker_list () = + let plant_id_list = + Db.fold Q.list_plant_ids (fun plant_id acc -> plant_id :: acc) () [] + in + match plant_id_list with + | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) + | Ok plant_id_list -> + 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 + 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" + } +} +|} + (*TODO escape in content ?? *) + (Float.to_string lat) + (Float.to_string lng) (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 []