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

remove /add_plant, add /plants, a board to replace it

Browse source
This commit is contained in:
Swrup 2022-01-12 19:34:55 +01:00
parent 0b7983ed6c
commit 8332a16209
13 changed files with 168 additions and 158 deletions
Download patch file Download diff file Expand all files Collapse all files

21
src/add_plant.eml.html
View file

@ -1,21 +0,0 @@
let f nick request =
<script type="text/javascript" src="/assets/js/js_plant_map.js" defer="defer"></script>
<%s Format.sprintf "Add a plant to your Collection %s !" nick %>
<div class="row mb-3">
<div class="col-md-6">
<div id="map"></div>
</div>
<div class="col-md-6">
<%s! Dream.form_tag ~action:"/add_plant" ~enctype:`Multipart_form_data request %>
<input type="hidden" id="lat_input" name="lat_input">
<input type="hidden" id="lng_input" name="lng_input">
<label for="tags" class="form-label">Tags</label>
<textarea name="tags" type="text" class="form-control" id="tags" aria-describedby="tagsHelp"></textarea>
<div id="tagsHelp" class="form-text">Describe your plant with tags</div>
<input id="files" name="files" aria-describedby="filesHelp" type="file" multiple>
<div id="filesHelp" class="form-text">Add a optional picture for your plant</div>
<button type="submit" class="btn btn-primary">Add Plant</button>
</form>
</div>

58
src/babillard.ml
View file

@ -2,8 +2,26 @@ open Db
exception Invalid_post of string
type board =
| Plants
| Babillard
let int_of_board = function
| Plants -> 0
| Babillard -> 1
let string_of_board = function
| Plants -> "plants"
| Babillard -> "babillard"
let board_of_int = function
| 0 -> Plants
| 1 -> Babillard
| _ -> assert false
type op =
{ id : string
; board : board
; date : int
; nick : string
; subject : string
@ -58,6 +76,12 @@ module Q = struct
FOREIGN KEY(post_id) REFERENCES post_user(post_id),\n\
\ FOREIGN KEY(parent_id) REFERENCES post_user(post_id));"
let create_thread_board_table =
Caqti_request.exec Caqti_type.unit
"CREATE TABLE IF NOT EXISTS thread_board (thread_id TEXT, board INT, \
FOREIGN KEY(thread_id) REFERENCES post_user(post_id));"
(* TODO useless? *)
let create_thread_table =
Caqti_request.exec Caqti_type.unit
"CREATE TABLE IF NOT EXISTS threads (thread_id TEXT, post_id TEXT,\n\
@ -151,6 +175,11 @@ module Q = struct
Caqti_type.(tup2 string string)
"INSERT INTO threads VALUES (?,?);"
let upload_thread_board =
Caqti_request.exec
Caqti_type.(tup2 string int)
"INSERT INTO thread_board VALUES (?,?);"
let upload_post_parent =
Caqti_request.exec
Caqti_type.(tup2 string string)
@ -197,6 +226,10 @@ module Q = struct
Caqti_request.find_opt Caqti_type.string Caqti_type.string
"SELECT thread_id FROM threads WHERE thread_id=? LIMIT 1;"
let get_thread_board =
Caqti_request.find Caqti_type.string Caqti_type.int
"SELECT board FROM thread_board 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=?;"
@ -206,9 +239,9 @@ module Q = struct
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;"
let list_threads =
Caqti_request.collect Caqti_type.int Caqti_type.string
"SELECT thread_id FROM thread_board WHERE board=?;"
end
let () =
@ -216,6 +249,7 @@ let () =
[ Q.create_post_user_table
; Q.create_post_parent_table
; Q.create_thread_table
; Q.create_thread_board_table
; Q.create_post_replies_table
; Q.create_post_citations_table
; Q.create_post_date_table
@ -233,6 +267,7 @@ let () =
Dream.warning (fun log -> log "can't create table")
(* TODO should I escape html or smthing ?*)
(*TODO fix bad link if post in other thread*)
let parse_comment comment =
let words = String.split_on_char ' ' comment in
let cited_posts, words =
@ -366,6 +401,7 @@ let upload_post post =
match post with
| Op
{ id
; board
; date
; nick
; subject
@ -377,7 +413,7 @@ let upload_post post =
; replies = _replies
; citations
} ->
let op_data = Some (subject, longitude, latitude) in
let op_data = Some (board, subject, longitude, latitude) in
(id, id, date, nick, comment, Some image, tags, citations, op_data)
| Reply
{ id
@ -425,7 +461,10 @@ let upload_post post =
in
match op_data with
| None -> Ok post_id
| Some (subject, lng, lat) ->
| Some (board, subject, lng, lat) ->
let* _res_board =
Db.exec Q.upload_thread_board (post_id, int_of_board board)
in
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
Ok post_id
@ -473,7 +512,7 @@ let make_reply ~comment ?image ~tags ~parent_id nick =
in
upload_post reply
let make_op ~comment ~image ~tags ~subject ~lat ~lng nick =
let make_op ~comment ~image ~tags ~subject ~lat ~lng ~board nick =
if String.length comment > 10000 then
Error "invalid comment"
else
@ -508,6 +547,7 @@ let make_op ~comment ~image ~tags ~subject ~lat ~lng nick =
let op =
Op
{ id
; board
; date
; nick
; subject
@ -523,9 +563,11 @@ let make_op ~comment ~image ~tags ~subject ~lat ~lng nick =
upload_post op
(* TODO make this return geojson directly *)
let marker_list () =
let marker_list board =
let* thread_id_list =
Db.fold Q.list_thread_ids (fun thread_id acc -> thread_id :: acc) () []
Db.fold Q.list_threads
(fun thread_id acc -> thread_id :: acc)
(int_of_board board) []
in
let markers_res =
List.map

2
src/babillard_page.eml.html
View file

@ -1,6 +1,8 @@
let f request =
<script type="text/javascript" src="/assets/js/js_babillard.js" defer="defer"></script>
<div id="board" boardvalue="babillard">
<%s Format.sprintf "Babillard is love" %>
</div>
<div class="row mb-3">
<div class="col-md-6">
% begin match Dream.session "nick" request with

9
src/dune
View file

@ -5,7 +5,7 @@
thread_page
babillard
babillard_page
plant
plants_page
db
app
content
@ -15,8 +15,7 @@
register
template
user
user_profile
add_plant)
user_profile)
(libraries
uuidm
caqti.blocking
@ -99,8 +98,8 @@
(run dream_eml %{deps} --workspace %{workspace_root})))
(rule
(targets add_plant.ml)
(deps add_plant.eml.html)
(targets plants_page.ml)
(deps plants_page.eml.html)
(action
(run dream_eml %{deps} --workspace %{workspace_root})))

14
src/js_babillard.ml
View file

@ -74,7 +74,12 @@ module Marker = struct
let thread_preview_div = Jv.get Jv.global "thread_preview_div" in
ignore @@ Jv.set thread_preview_div "innerHTML" thread_preview;
let thread_link = Jv.get Jv.global "thread_link" in
let link = "/babillard/" ^ thread_id in
let board_div = Jv.get Jv.global "board" in
let board =
Jv.to_string
(Jv.call board_div "getAttribute" [| Jv.of_string "boardvalue" |])
in
let link = "/" ^ board ^ "/" ^ thread_id in
ignore @@ Jv.set thread_link "href" (Jv.of_string link);
ignore @@ Jv.set thread_link "innerText" (Jv.of_string "[View Thread]");
()
@ -107,9 +112,14 @@ module Marker = struct
let () =
log "fetch thread geojson@.";
let board_div = Jv.get Jv.global "board" in
let board =
Jv.to_string
(Jv.call board_div "getAttribute" [| Jv.of_string "boardvalue" |])
in
let window = Jv.get Jv.global "window" in
let fetchfutur =
Jv.call window "fetch" [| Jv.of_string "/thread_markers" |]
Jv.call window "fetch" [| Jv.of_string ("/" ^ board ^ "/markers") |]
in
ignore @@ Jv.call fetchfutur "then" [| Jv.repr markers_handle_response |];
()

4
src/newthread_page.eml.html
View file

@ -1,6 +1,6 @@
let f request =
let f ~board request =
<script type="text/javascript" src="/assets/js/js_babillard.js" defer="defer"></script>
<%s! Dream.form_tag ~action:"/babillard/new_thread" ~enctype:`Multipart_form_data request %>
<%s! Dream.form_tag ~action:(Format.sprintf "/%s/new_thread" (Babillard.string_of_board board)) ~enctype:`Multipart_form_data request %>
<input type="hidden" id="lat_input" name="lat_input">
<input type="hidden" id="lng_input" name="lng_input">

102
src/permap.ml
View file

@ -131,14 +131,6 @@ let avatar_image request =
| Some avatar -> Dream.respond ~headers:[ ("Content-Type", "image") ] avatar
)
let plant_image request =
let plant_id = Dream.param "plant_id" request in
let nb = int_of_string (Dream.param "nb" request) in
let image = Plant.get_plant_image plant_id nb in
match image with
| Ok image -> Dream.respond ~headers:[ ("Content-Type", "image") ] image
| 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
@ -146,62 +138,11 @@ let post_image request =
| Ok image -> Dream.respond ~headers:[ ("Content-Type", "image") ] image
| Error _ -> Dream.empty `Not_Found
let add_plant_get request =
match Dream.session "nick" request with
| None -> render_unsafe "Not logged in" request
| Some nick -> render_unsafe (Add_plant.f nick request) request
let plants_get request = render_unsafe (Plants_page.f request) request
let add_plant_post request =
match Dream.session "nick" request with
| None -> render_unsafe "Not logged in" request
| Some nick -> (
match%lwt Dream.multipart request with
| `Ok
[ ("files", files)
; ("lat_input", [ (_, lat) ])
; ("lng_input", [ (_, lng) ])
; ("tags", [ (_, tags) ])
]
| `Ok
(("files", files)
:: ("lat_input", [ (_, lat) ])
:: ("lng_input", [ (_, lng) ]) :: ("tags", [ (_, tags) ]) :: _ :: _
) -> (
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 _
| `Missing_token _
| `Invalid_token _
| `Wrong_session _
| `Wrong_content_type ->
Dream.empty `Bad_Request )
let plant_markers request =
(*TODO should be in plant *)
let marker_list = Plant.marker_list () in
match marker_list with
| Ok marker_list ->
let json =
{| [ |}
^ String.concat "," (List.map Plant.marker_to_geojson marker_list)
^ "]"
in
Dream.respond ~headers:[ ("Content-Type", "application/json") ] json
| Error e -> render_unsafe e request
let thread_markers request =
let markers ~board request =
(*TODO should be in babillard*)
let marker_list = Babillard.marker_list () in
let marker_list = Babillard.marker_list board in
match marker_list with
| Ok marker_list ->
let json =
@ -214,9 +155,10 @@ let thread_markers request =
let babillard_get request = render_unsafe (Babillard_page.f request) request
let newthread_get request = render_unsafe (Newthread_page.f request) request
let newthread_get ~board request =
render_unsafe (Newthread_page.f ~board request) request
let newthread_post request =
let newthread_post ~board request =
match Dream.session "nick" request with
| None -> render_unsafe "Not logged in" request
| Some nick -> (
@ -246,10 +188,15 @@ let newthread_post request =
| _ :: _ :: _ -> render_unsafe "More than one image" request
| [ file ] -> (
match
Babillard.make_op ~comment ~image:file ~lat ~lng ~subject ~tags nick
Babillard.make_op ~comment ~image:file ~lat ~lng ~subject ~tags
~board nick
with
| Ok thread_id ->
let adress = Format.sprintf "/babillard/%s" thread_id in
let adress =
Format.sprintf "/%s/%s"
(Babillard.string_of_board board)
thread_id
in
Dream.respond ~status:`See_Other ~headers:[ ("Location", adress) ]
"Your thread was posted on the babillard!"
| Error e -> render_unsafe e request ) ) )
@ -279,7 +226,7 @@ let thread_view request =
| Ok thread_view -> Dream.html (Thread_page.f thread_view thread_id request)
(*form to reply to a thread *)
let thread_post request =
let reply_post request =
match Dream.session "nick" request with
| None -> render_unsafe "Not logged in" request
| Some nick -> (
@ -331,17 +278,20 @@ let () =
; Dream.get "/logout" logout
; Dream.get "/profile" profile_get
; Dream.post "/profile" profile_post
; 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 "/plant_markers" plant_markers
; Dream.get "/thread_markers" thread_markers
; 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/new_thread" newthread_get
; Dream.post "/babillard/new_thread" newthread_post
; Dream.get "/babillard/:thread_id" thread_get (*todo, bad names ^^*)
; Dream.post "/babillard/:thread_id" thread_post
; 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
; Dream.post "/reply/:thread_id" reply_post
; Dream.get "/post_pic/:post_id" post_image
]
@@ Dream.not_found

84
src/plant.ml
View file

@ -1,5 +1,18 @@
(*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
@ -96,39 +109,29 @@ 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
| Ok count -> (
match count with
| Some count -> (
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 -> Format.sprintf "db error: %s" (Caqti_error.show e)
| Ok tags ->
let tags = String.concat " " tags in
(* TODO add link to gps/map too *)
images ^ tags ^ gps )
| None -> "db error" )
| Error e -> Format.sprintf "db error: %s" (Caqti_error.show e)
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 =
@ -138,9 +141,11 @@ let marker_list () =
List.map
(fun plant_id ->
match Db.find_opt Q.get_plant_gps plant_id with
| Ok (Some (lat, lng)) ->
| Ok (Some (lat, lng)) -> (
let content = view_plant plant_id in
Ok (lat, lng, content)
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))
)
@ -172,12 +177,10 @@ let marker_to_geojson marker =
}
}
|}
(*TODO escape in content ?? *)
(* geojson use lng lat, and not lat lng*)
(Float.to_string lng)
(Float.to_string lat) (String.escaped content)
(* TODO return result *)
let view_user_plant_list nick =
let plant_id_list =
Db.fold Q.get_user_plants (fun plant_id acc -> plant_id :: acc) nick []
@ -185,7 +188,14 @@ let view_user_plant_list nick =
match plant_id_list with
| Error e -> Format.sprintf "db error: %s" (Caqti_error.show e)
| Ok plant_id_list ->
let plants = List.map view_plant plant_id_list in
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 =

20
src/plants_page.eml.html Normal file
View file

@ -0,0 +1,20 @@
let f request =
<script type="text/javascript" src="/assets/js/js_babillard.js" defer="defer"></script>
<div id="board" boardvalue="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>

6
src/template.eml.html
View file

@ -33,13 +33,13 @@ let render_unsafe ~title ~content request =
<li class="nav-item">
<a class="nav-link" href="/profile"><%s! nick %></a>
</li>
<li class="nav-item">
<a class="nav-link" href="/add_plant">Add Plant</a>
</li>
<li class="nav-item">
<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>

2
src/thread_page.eml.html
View file

@ -6,7 +6,7 @@ let f thread_view thread_id request =
% | Some _ ->
<div class="mb-3">
<%s! Dream.form_tag ~action:( Format.sprintf "/babillard/%s" thread_id)
<%s! Dream.form_tag ~action:( Format.sprintf "/reply/%s" thread_id)
~enctype:`Multipart_form_data request %>
<label for="replyComment" id="replyCommentLabel" class="form-label">Comment</label>

3
src/user.ml
View file

@ -149,14 +149,13 @@ let public_profile request =
| Ok user -> (
match user with
| Some (nick, password, email, (bio, _)) ->
let plants = Plant.view_user_plant_list nick in
let user_info =
Format.sprintf
{|nick = `%s`; password = `%s`; email = `%s`; bio = '%s';
<img src="/user/%s/avatar" class="img-thumbnail" alt="Your avatar picture">|}
nick password email (Dream.html_escape bio) nick
in
user_info ^ plants
user_info
| None -> "incoherent db answer" )
| Error e -> Format.sprintf "db error: %s" (Caqti_error.show e)

1
src/user_profile.eml.html
View file

@ -14,4 +14,3 @@ let f nick bio request =
<input name="file" type="file">
<button>Submit!</button>
</form>
<%s! Plant.view_user_plant_list nick %>