clean babillard, remove option for multiple boards

This commit is contained in:
Swrup 2022-02-17 03:59:23 +01:00
parent 8c594648c9
commit be599322da
8 changed files with 104 additions and 166 deletions

View file

@ -1,23 +1,8 @@
open Db
include Bindings
exception Invalid_post of string
type board = Babillard
let int_of_board = function
| Babillard -> 1
let pp_board fmt = function
| Babillard -> Format.fprintf fmt "babillard"
let board_of_int = function
| 1 -> Babillard
| _ -> raise (Invalid_argument "board_of_int")
type thread_data =
{ board : board
; subject : string
{ subject : string
; lng : float
; lat : float
}
@ -51,12 +36,6 @@ 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,11 +130,6 @@ 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)
@ -202,14 +176,9 @@ module Q = struct
Caqti_request.find Caqti_type.string Caqti_type.int
"SELECT COUNT(post_id) FROM threads WHERE thread_id=?;"
(* TODO return bool *)
let is_thread =
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;"
Caqti_request.find Caqti_type.string Caqti_type.bool
"IF EXISTS (SELECT thread_id FROM threads WHERE thread_id=? LIMIT 1);"
let get_post_subject =
Caqti_request.find_opt Caqti_type.string Caqti_type.string
@ -220,9 +189,9 @@ module Q = struct
Caqti_type.(tup2 float float)
"SELECT lat, lng FROM post_gps WHERE post_id=?;"
let list_threads =
Caqti_request.collect Caqti_type.int Caqti_type.string
"SELECT thread_id FROM thread_board WHERE board=?;"
let get_threads =
Caqti_request.collect Caqti_type.unit Caqti_type.string
"SELECT thread_id FROM threads;"
end
let () =
@ -230,7 +199,6 @@ 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
@ -269,21 +237,26 @@ let parse_image image =
else
Ok (Some image) )
(* TODO: Is this safe? *)
(*TODO fix bad link if post in other thread*)
(*TODO switch to markdown !*)
(* insert html into the comment, and keep tracks of citations :
-wraps lines starting with ">" with a <span class="quote">
-make raw posts uuid into links
(*TODO fix bad link if post is in other thread*)
-keeps tracks of every post cited in this comment
- add <br> at each line *)
let parse_comment comment =
let handle_word w =
let trim_w = String.trim w in
(* '>' is '&gt;' after html_escape *)
match String.starts_with ~prefix:{|&gt;&gt;|} trim_w with
| false -> (w, None)
| true -> (
if String.starts_with ~prefix:{|&gt;&gt;|} trim_w then
let sub_w = String.sub trim_w 8 (String.length trim_w - 8) in
match Uuidm.of_string sub_w with
| None -> (w, None)
| Some _ ->
let new_w = Format.sprintf {|<a href="#%s">%s</a>|} sub_w w in
(new_w, Some sub_w) )
(new_w, Some sub_w)
else
(w, None)
in
let handle_line l =
let trim_w = String.trim l in
@ -344,46 +317,36 @@ let upload_post post =
| Op (thread_data, reply) -> (Some thread_data, reply)
| Reply reply -> (None, reply)
in
let post_id, parent_id, date, nick, comment, image, tags, citations =
match reply with
| { id
; parent_id
; date
; nick
; comment
; image
; tags
; replies = _replies
; citations
} ->
(id, parent_id, date, nick, comment, image, tags, citations)
let { id; parent_id; date; nick; comment; image; tags; citations; _ } =
reply
in
let^ _res_post_id = Db.exec Q.upload_post_id (post_id, nick) in
let^ _res_comment = Db.exec Q.upload_post_comment (post_id, comment) in
let^ _res_date = Db.exec Q.upload_post_date (post_id, date) in
let^ _res_thread = Db.exec Q.upload_to_thread (parent_id, post_id) in
let^ _res_image =
let^ () = Db.exec Q.upload_post_id (id, nick) in
let^ () = Db.exec Q.upload_post_comment (id, comment) in
let^ () = Db.exec Q.upload_post_date (id, date) in
let^ () = Db.exec Q.upload_to_thread (parent_id, id) in
let^ () =
match image with
| None -> Ok ()
| Some (image_name, image_content, alt) ->
Db.exec Q.upload_post_image (post_id, image_name, image_content, alt)
Db.exec Q.upload_post_image (id, image_name, image_content, alt)
in
let^ _res_parent = Db.exec Q.upload_post_parent (post_id, parent_id) in
let^ _res_tags =
(* what is parent and why do i need it again? TODO TODO *)
let^ () = Db.exec Q.upload_post_parent (id, parent_id) in
let^ () =
match
List.find_opt Result.is_error
(List.map (fun tag -> Db.exec Q.upload_post_tag (post_id, tag)) tags)
(List.map (fun tag -> Db.exec Q.upload_post_tag (id, tag)) tags)
with
| Some (Error e) -> Error e
| Some _ -> assert false
| None -> Ok ()
in
let^ _res_citations =
let^ () =
match
List.find_opt Result.is_error
(List.map
(fun cited_id -> Db.exec Q.upload_post_reply (cited_id, post_id))
(fun cited_id -> Db.exec Q.upload_post_reply (cited_id, id))
citations )
with
| Some (Error e) -> Error e
@ -391,27 +354,18 @@ let upload_post post =
| None -> Ok ()
in
match thread_data with
| None -> Ok post_id
| Some thread_data -> (
match thread_data with
| { 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 )
| None -> Ok id
| Some { subject; lng; lat } ->
let^ () = Db.exec Q.upload_post_gps (id, lat, lng) in
let^ () = Db.exec Q.upload_post_subject (id, subject) in
Ok id
let build_reply ~comment ?image ~tags ?parent_id nick =
let comment = Dream.html_escape comment in
let tags = Dream.html_escape tags in
let id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
(* parent_id is None if this reply is supposed to be a new thread *)
let parent_id =
match parent_id with
| Some parent_id -> parent_id
| None -> id
in
let parent_id = Option.value parent_id ~default:id in
if Option.is_none (Uuidm.of_string parent_id) then
Error "invalid thread id"
else if String.length comment > 10000 then
@ -441,7 +395,7 @@ let build_reply ~comment ?image ~tags ?parent_id nick =
in
Ok reply
let build_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick =
let build_op ~comment ?image ~tags ~subject ~lat ~lng nick =
let subject = Dream.html_escape subject in
(* TODO latlng validation? *)
let is_valid_latlng = true in
@ -450,7 +404,7 @@ let build_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick =
else if String.length subject > 600 then
Error "Invalid subject"
else
let thread_data = { board; subject; lng; lat } in
let thread_data = { subject; lng; lat } in
let* reply =
match image with
| Some image -> build_reply ~comment ~image ~tags nick
@ -464,8 +418,8 @@ let make_reply ~comment ?image ~tags ~parent_id nick =
let post = Reply reply in
upload_post post
let make_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick =
let* op = build_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick in
let make_op ~comment ?image ~tags ~subject ~lat ~lng nick =
let* op = build_op ~comment ?image ~tags ~subject ~lat ~lng nick in
upload_post op
let get_post_image_content post_id =

View file

@ -1,17 +1,13 @@
let f ~board request =
%let board = Format.asprintf "%a" Babillard.pp_board board in
let f request =
<script type="text/javascript" src="/assets/js/js_babillard.js" defer="defer"></script>
<div id="board" data-board=<%s board %> >
<%s Format.sprintf "Babillard is love" %>
</div>
<div class="row mb-3">
<div class="col-md-6">
% begin match Dream.session "nick" request with
% | None ->
% | Some _nick ->
%let url = Format.sprintf "/%s/new_thread" board in
<a href=<%s url %>>[New Thread]</a>
<a href="/babillard/new_thread" >[New Thread]</a>
% end;
<div id="map"></div>
<button onclick="geolocalize()">Geolocalize me</button>

View file

@ -13,5 +13,5 @@ let ( let^ ) o f =
let ( let* ) o f =
match o with
| Error e -> Error (Format.sprintf "%s" e)
| Error e -> Error e
| Ok x -> f x

View file

@ -32,7 +32,7 @@ blockquote.blockquote {
margin: 5px 5px 5px 5px;
border: 2px solid #FFB300;
padding: 2px;
display:table;
display: table;
}
.postInfo {
@ -74,7 +74,7 @@ blockquote.blockquote {
margin: 5px 5px 5px 5px;
border: 2px solid #FFB300;
padding: 2px;
display:table;
display: table;
width: 500px;
}

View file

@ -119,11 +119,6 @@ module Geolocalize = struct
end
module Marker = struct
let board =
let board_div = Jv.get Jv.global "board" in
Jv.to_string
(Jv.call board_div "getAttribute" [| Jv.of_string "data-board" |])
(*todo do this in js_babillard*)
let marker_on_click thread_preview thread_id _e =
log "marker_on_click@.";
@ -131,7 +126,7 @@ 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 = Format.sprintf "/%s/%s" board thread_id in
let link = Format.sprintf "/babillard/%s" thread_id in
ignore @@ Jv.set thread_link "href" (Jv.of_string link);
ignore @@ Jv.set thread_link "innerText" (Jv.of_string "[View Thread]");
let _ = Js_pretty_post.make_pretty () in
@ -173,7 +168,7 @@ module Marker = struct
let () =
log "fetch thread geojson@.";
let window = Jv.get Jv.global "window" in
let link = Jv.of_string (Format.sprintf "/%s/markers" board) in
let link = Jv.of_string "/babillard/markers" in
let fetchfutur = Jv.call window "fetch" [| link |] in
ignore @@ Jv.call fetchfutur "then" [| Jv.repr markers_handle_response |];
()

View file

@ -1,13 +1,10 @@
let f ~board request =
%let board = Format.asprintf "%a" Babillard.pp_board board in
%let url = Format.sprintf "/%s/new_thread" board in
let f request =
% 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="newthread">Click the map to make a new thread:</div>
<div id="board" data-board=<%s board %> ></div>
<div class="row mb-3">
<div class="col-md-6">
<div id="map"></div>
@ -16,7 +13,7 @@ Login to make a new thread.
<div class="col-md-6" id="newthread-form">
<div class="postForm">
<%s! Dream.form_tag ~action:url ~enctype:`Multipart_form_data request %>
<%s! Dream.form_tag ~action:"/babillard/new_thread" ~enctype:`Multipart_form_data request %>
<input type="hidden" id="lat_input" name="lat_input">
<input type="hidden" id="lng_input" name="lng_input">

View file

@ -148,20 +148,18 @@ let post_image request =
| Ok image -> Dream.respond ~headers:[ ("Content-Type", "image") ] image
| Error _ -> Dream.empty `Not_Found
let markers ~board request =
let markers = Pp_babillard.get_markers board in
let markers request =
let markers = Pp_babillard.get_markers () in
match markers with
| Ok markers ->
Dream.respond ~headers:[ ("Content-Type", "application/json") ] markers
| Error e -> render_unsafe e request
let babillard_get ~board request =
render_unsafe (Babillard_page.f ~board request) request
let babillard_get request = render_unsafe (Babillard_page.f request) request
let newthread_get ~board request =
render_unsafe (Newthread_page.f ~board request) request
let newthread_get request = render_unsafe (Newthread_page.f request) request
let newthread_post ~board request =
let newthread_post request =
match Dream.session "nick" request with
| None -> render_unsafe "Not logged in" request
| Some nick -> (
@ -181,19 +179,15 @@ let newthread_post ~board request =
| Some lat, Some lng -> (
let res =
match file with
| [] ->
Babillard.make_op ~comment ~lat ~lng ~subject ~tags ~board nick
| [] -> Babillard.make_op ~comment ~lat ~lng ~subject ~tags nick
| _ :: _ :: _ -> Error "More than one image"
| [ (image_name, image_content) ] ->
let image = (image_name, image_content, alt) in
Babillard.make_op ~comment ~image ~lat ~lng ~subject ~tags ~board
nick
Babillard.make_op ~comment ~image ~lat ~lng ~subject ~tags nick
in
match res with
| Ok thread_id ->
let adress =
Format.asprintf "/%a/%s" Babillard.pp_board board thread_id
in
let adress = Format.asprintf "/babillard/%s" thread_id in
Dream.respond ~status:`See_Other
~headers:[ ("Location", adress) ]
"Your thread was posted!"
@ -282,11 +276,11 @@ let () =
; Dream.get "/profile" profile_get
; Dream.post "/profile" profile_post
; Dream.get "/thread_view/:thread_id" thread_view
; Dream.get "/babillard/markers" (markers ~board:Babillard)
; Dream.get "/babillard/markers" markers
; Dream.get "/post_pic/:post_id" post_image
; 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" babillard_get
; Dream.get "/babillard/new_thread" newthread_get
; Dream.post "/babillard/new_thread" newthread_post
; Dream.get "/babillard/:thread_id" thread_get
; Dream.post "/reply/:thread_id" reply_post
; Dream.get "/post_pic/:post_id" post_image

View file

@ -126,42 +126,46 @@ let preview_thread thread_id =
Ok thread_preview
let view_thread thread_id =
let^? _ = Db.find_opt Q.is_thread thread_id in
let^? subject = Db.find_opt Q.get_post_subject thread_id in
let^ thread_posts = Db.fold Q.get_thread_posts List.cons thread_id [] in
(*order by date *)
let dates =
List.map (fun post_id -> Db.find Q.get_post_date post_id) thread_posts
in
match List.find_opt Result.is_error dates with
| Some (Error e) -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
| Some (Ok _) -> assert false
| None -> (
let dates = List.map Result.get_ok dates in
let posts_dates = List.combine thread_posts dates in
let sorted_posts_dates =
List.sort (fun (_, a) (_, b) -> compare a b) posts_dates
let^ is_thread = Db.find Q.is_thread thread_id in
if not is_thread then
Error "This thread doesn't exists"
else
let^? subject = Db.find_opt Q.get_post_subject thread_id in
let^ thread_posts = Db.fold Q.get_thread_posts List.cons thread_id [] in
(*order by date *)
let dates =
List.map (fun post_id -> Db.find Q.get_post_date post_id) thread_posts
in
let posts, _ = List.split sorted_posts_dates in
let view_posts = List.map view_post posts in
match List.find_opt Result.is_error view_posts with
| Some (Error e) -> Error e
match List.find_opt Result.is_error dates with
| Some (Error e) ->
Error (Format.sprintf "db error: %s" (Caqti_error.show e))
| Some (Ok _) -> assert false
| None ->
let posts =
List.map Result.get_ok (List.filter Result.is_ok view_posts)
| None -> (
let dates = List.map Result.get_ok dates in
let posts_dates = List.combine thread_posts dates in
let sorted_posts_dates =
List.sort (fun (_, a) (_, b) -> compare a b) posts_dates
in
let posts =
Format.asprintf "%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\r\n")
Format.pp_print_string )
posts
in
let thread_view =
Format.sprintf
{|
let posts, _ = List.split sorted_posts_dates in
let view_posts = List.map view_post posts in
match List.find_opt Result.is_error view_posts with
| Some (Error e) -> Error e
| Some (Ok _) -> assert false
| None ->
let posts =
List.map Result.get_ok (List.filter Result.is_ok view_posts)
in
let posts =
Format.asprintf "%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\r\n")
Format.pp_print_string )
posts
in
let thread_view =
Format.sprintf
{|
<div class="thread">
<div class="threadSubject">
%s
@ -171,14 +175,12 @@ let view_thread thread_id =
</div>
</div>
|}
subject posts
in
Ok thread_view )
subject posts
in
Ok thread_view )
let get_markers board =
let^ thread_id_list =
Db.fold Q.list_threads List.cons (int_of_board board) []
in
let get_markers () =
let^ thread_id_list = Db.fold Q.get_threads List.cons () [] in
let markers_res =
List.map
(fun thread_id ->