diff --git a/src/add_plant.eml.html b/src/add_plant.eml.html deleted file mode 100644 index 97a41d9..0000000 --- a/src/add_plant.eml.html +++ /dev/null @@ -1,21 +0,0 @@ -let f nick request = - -<%s Format.sprintf "Add a plant to your Collection %s !" nick %> -
-
-
-
-
- <%s! Dream.form_tag ~action:"/add_plant" ~enctype:`Multipart_form_data request %> - - - - - -
Describe your plant with tags
- - -
Add a optional picture for your plant
- - -
diff --git a/src/babillard.ml b/src/babillard.ml index 426a682..7ae6fad 100644 --- a/src/babillard.ml +++ b/src/babillard.ml @@ -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 diff --git a/src/babillard_page.eml.html b/src/babillard_page.eml.html index f500eec..accae1c 100644 --- a/src/babillard_page.eml.html +++ b/src/babillard_page.eml.html @@ -1,6 +1,8 @@ let f request = +
<%s Format.sprintf "Babillard is love" %> +
% begin match Dream.session "nick" request with diff --git a/src/dune b/src/dune index fb7c253..7b1c56c 100644 --- a/src/dune +++ b/src/dune @@ -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}))) diff --git a/src/js_babillard.ml b/src/js_babillard.ml index 7c7350e..f3dcaa5 100644 --- a/src/js_babillard.ml +++ b/src/js_babillard.ml @@ -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 |]; () diff --git a/src/newthread_page.eml.html b/src/newthread_page.eml.html index e173c50..64d6a62 100644 --- a/src/newthread_page.eml.html +++ b/src/newthread_page.eml.html @@ -1,6 +1,6 @@ -let f request = +let f ~board request = - <%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 %> diff --git a/src/permap.ml b/src/permap.ml index 0504b97..97e0e0b 100644 --- a/src/permap.ml +++ b/src/permap.ml @@ -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 diff --git a/src/plant.ml b/src/plant.ml index 233e708..86b6f2c 100644 --- a/src/plant.ml +++ b/src/plant.ml @@ -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 - {|
    • |} - 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 + {|
    • |} + 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 = diff --git a/src/plants_page.eml.html b/src/plants_page.eml.html new file mode 100644 index 0000000..5902dd2 --- /dev/null +++ b/src/plants_page.eml.html @@ -0,0 +1,20 @@ +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 f384ffe..7daf5d4 100644 --- a/src/template.eml.html +++ b/src/template.eml.html @@ -33,13 +33,13 @@ let render_unsafe ~title ~content request =
  • <%s! nick %>
    • -
  • - Add Plant -
  • Logout
    • % end; +
  • + Plants +
  • Babillard
    • diff --git a/src/thread_page.eml.html b/src/thread_page.eml.html index d3524e3..d42ee25 100644 --- a/src/thread_page.eml.html +++ b/src/thread_page.eml.html @@ -6,7 +6,7 @@ let f thread_view thread_id request = % | Some _ ->
    - <%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 %> diff --git a/src/user.ml b/src/user.ml index 6ff0cd5..ebd2613 100644 --- a/src/user.ml +++ b/src/user.ml @@ -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'; 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) diff --git a/src/user_profile.eml.html b/src/user_profile.eml.html index eae520e..61f828c 100644 --- a/src/user_profile.eml.html +++ b/src/user_profile.eml.html @@ -14,4 +14,3 @@ let f nick bio request = - <%s! Plant.view_user_plant_list nick %>