swrup/geochan
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

remove plants :(

Browse source
This commit is contained in:
Swrup 2022-01-18 00:12:03 +01:00
parent f754126567
commit 70b34515f8
10 changed files with 12 additions and 426 deletions
Download patch file Download diff file Expand all files Collapse all files

7
src/babillard.ml
View file

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

8
src/babillard_page.eml.html
View file

@ -1,6 +1,7 @@
let f request =
let f ~board request =
%let board = Format.asprintf "%a" Babillard.pp_board board in
<script type="text/javascript" src="/assets/js/js_babillard.js" defer="defer"></script>
<div id="board" data-board="babillard">
<div id="board" data-board=<%s board %> >
<%s Format.sprintf "Babillard is love" %>
</div>
<div class="row mb-3">
@ -9,7 +10,8 @@ let f request =
% | None ->
% | Some _nick ->
<a href="/babillard/new_thread">[New Thread]</a>
%let url = Format.sprintf "/%s/new_thread" board in
<a href=<%s url %>>[New Thread]</a>
% end;
<div id="map"></div>
</div>

9
src/content/assets/js/dune
View file

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

18
src/dune
View file

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

100
src/js_plant_map.ml
View file

@ -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
{|&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 |]
(*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

5
src/newthread_page.eml.html
View file

@ -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 ->
<script type="text/javascript" src="/assets/js/js_newthread.js" defer="defer"></script>
<div id="board" data-board="babillard">Click the map to make a new thread:</div>
<div id="board" data-board=<%s board %> >Click the map to make a new thread:</div>
<div class="row mb-3">
<div class="col-md-6">
<div id="map"></div>

13
src/permap.ml
View file

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

255
src/plant.ml
View file

@ -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
{|<li><img src="/plant_pic/%s/%i" class="img-thumbnail"></li>|}
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 () ) ) )

20
src/plants_page.eml.html
View file

@ -1,20 +0,0 @@
let f request =
<script type="text/javascript" src="/assets/js/js_babillard.js" defer="defer"></script>
<div id="board" data-board="plants">
<%s Format.sprintf "Plants is love" %>
</div>
<div class="row mb-3">
<div class="col-md-6">
% begin match Dream.session "nick" request with
% | None ->
% | Some _nick ->
<a href="/plants/new_thread">[New Thread]</a>
% end;
<div id="map"></div>
</div>
<div class="col-md-6">
<div id="thread_preview_div"></div>
<a id="thread_link"></a>
</div>
</div>

3
src/template.eml.html
View file

@ -37,9 +37,6 @@ let render_unsafe ~title ~content request =
<a class="nav-link" href="/logout">Logout</a>
</li>
% end;
<li class="nav-item">
<a class="nav-link" href="/plants">Plants</a>
</li>
<li class="nav-item">
<a class="nav-link" href="/babillard">Babillard</a>
</li>