wip: marker for plants on the map

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)))

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 |]

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) ] ->
+        | [ (_, lat) ], [ (_, lng) ] -> (
-          let res =
+          match (Float.of_string_opt lat, Float.of_string_opt lng) with
-            match User.add_plant (lat, lng) tags files nick with
+          | None, _ -> render_unsafe "Invalide coordinate" request
-            | Ok () -> "Your plant was uploaded!"
+          | _, None -> render_unsafe "Invalide coordinate" request
-            | Error e -> e
+          | Some lat, Some lng ->
-          in
+            let res =
-          render_unsafe res request
+              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

src/template.eml.html

@@ -7,6 +7,7 @@ let render_unsafe ~title ~content request =
       <link href="/assets/css/bootstrap.min.css" rel="stylesheet"/>
       <link href="/assets/css/leaflet.css" rel="stylesheet">
       <link href="/assets/css/style.css" rel="stylesheet">
+      <link href="/assets/img/marker-icon.png" rel="marker-icon">
     </head>
     <body>
       <header>

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, \
+      "CREATE TABLE IF NOT EXISTS plant_gps (plant_id TEXT, lat FLOAT,lng \
-       FOREIGN KEY(plant_id) REFERENCES plant_user(plant_id));"
+       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 []