wip:babillard
This commit is contained in:
parent
c13b231b9c
commit
0ad247c4be
12 changed files with 984 additions and 54 deletions
|
|
@ -15,3 +15,4 @@ let f nick request =
|
|||
<button type="submit" class="btn btn-primary">Add Plant</button>
|
||||
</div>
|
||||
</form>
|
||||
<script type="text/javascript" src="/assets/js/js_plant_map.js" defer="defer"></script>
|
||||
|
|
|
|||
558
src/babillard.ml
Normal file
558
src/babillard.ml
Normal file
|
|
@ -0,0 +1,558 @@
|
|||
open Db
|
||||
|
||||
module Q = struct
|
||||
let create_post_user_table =
|
||||
Caqti_request.exec Caqti_type.unit
|
||||
"CREATE TABLE IF NOT EXISTS post_user (post_id TEXT, nick TEXT, PRIMARY \
|
||||
KEY(post_id), FOREIGN KEY(nick) REFERENCES user(nick));"
|
||||
|
||||
(* post_id -> OP's post_id *)
|
||||
let create_post_parent_table =
|
||||
Caqti_request.exec Caqti_type.unit
|
||||
"CREATE TABLE IF NOT EXISTS post_parent (post_id TEXT, parent_id TEXT, \
|
||||
FOREIGN KEY(post_id) REFERENCES post_user(post_id),\n\
|
||||
\ FOREIGN KEY(parent_id) REFERENCES post_user(post_id));"
|
||||
|
||||
let create_thread_table =
|
||||
Caqti_request.exec Caqti_type.unit
|
||||
"CREATE TABLE IF NOT EXISTS threads (thread_id TEXT, post_id TEXT,\n\
|
||||
\ FOREIGN KEY(thread_id) REFERENCES post_user(post_id),\n\
|
||||
\ FOREIGN KEY(post_id) REFERENCES post_user(post_id));"
|
||||
|
||||
let create_post_replies_table =
|
||||
Caqti_request.exec Caqti_type.unit
|
||||
"CREATE TABLE IF NOT EXISTS post_replies (post_id TEXT, reply_id TEXT, \
|
||||
FOREIGN KEY(post_id) REFERENCES post_user(post_id),\n\
|
||||
\ FOREIGN KEY(reply_id) REFERENCES post_user(post_id));"
|
||||
|
||||
let create_post_citations_table =
|
||||
Caqti_request.exec Caqti_type.unit
|
||||
"CREATE TABLE IF NOT EXISTS post_citations (post_id TEXT, cited_id TEXT, \
|
||||
FOREIGN KEY(post_id) REFERENCES post_user(post_id),\n\
|
||||
\ FOREIGN KEY(cited_id) REFERENCES post_user(post_id));"
|
||||
|
||||
let create_post_date_table =
|
||||
Caqti_request.exec Caqti_type.unit
|
||||
"CREATE TABLE IF NOT EXISTS post_date (post_id TEXT, date INT, FOREIGN \
|
||||
KEY(post_id) REFERENCES post_user(post_id));"
|
||||
|
||||
let create_post_comment_table =
|
||||
Caqti_request.exec Caqti_type.unit
|
||||
"CREATE TABLE IF NOT EXISTS post_comment (post_id TEXT, comment TEXT, \
|
||||
FOREIGN KEY(post_id) REFERENCES post_user(post_id));"
|
||||
|
||||
let create_post_image_table =
|
||||
Caqti_request.exec Caqti_type.unit
|
||||
"CREATE TABLE IF NOT EXISTS post_image (post_id TEXT, image_name TEXT, \
|
||||
image_content, FOREIGN KEY(post_id) REFERENCES post_user(post_id));"
|
||||
|
||||
let create_post_gps_table =
|
||||
Caqti_request.exec Caqti_type.unit
|
||||
"CREATE TABLE IF NOT EXISTS post_gps (post_id TEXT, lat FLOAT, lng FLOAT ,\n\
|
||||
\ FOREIGN KEY(post_id) REFERENCES post_user(post_id));"
|
||||
|
||||
let create_post_subject_table =
|
||||
Caqti_request.exec Caqti_type.unit
|
||||
"CREATE TABLE IF NOT EXISTS post_subject (post_id TEXT, subject TEXT, \
|
||||
FOREIGN KEY(post_id) REFERENCES post_user(post_id));"
|
||||
|
||||
let create_post_tags_table =
|
||||
Caqti_request.exec Caqti_type.unit
|
||||
"CREATE TABLE IF NOT EXISTS post_tags (post_id TEXT, tag TEXT, FOREIGN \
|
||||
KEY(post_id) REFERENCES post_user(post_id));"
|
||||
|
||||
let upload_post_id =
|
||||
Caqti_request.exec
|
||||
Caqti_type.(tup2 string string)
|
||||
"INSERT INTO post_user VALUES (?,?);"
|
||||
|
||||
let upload_post_gps =
|
||||
Caqti_request.exec
|
||||
Caqti_type.(tup3 string float float)
|
||||
"INSERT INTO post_gps VALUES (?,?,?);"
|
||||
|
||||
let upload_post_image =
|
||||
Caqti_request.exec
|
||||
Caqti_type.(tup3 string string string)
|
||||
"INSERT INTO post_image VALUES (?,?,?);"
|
||||
|
||||
let upload_post_reply =
|
||||
Caqti_request.exec
|
||||
Caqti_type.(tup2 string string)
|
||||
"INSERT INTO post_replies VALUES (?,?);"
|
||||
|
||||
let upload_post_comment =
|
||||
Caqti_request.exec
|
||||
Caqti_type.(tup2 string string)
|
||||
"INSERT INTO post_comment VALUES (?,?);"
|
||||
|
||||
let upload_post_subject =
|
||||
Caqti_request.exec
|
||||
Caqti_type.(tup2 string string)
|
||||
"INSERT INTO post_subject VALUES (?,?);"
|
||||
|
||||
let upload_post_tag =
|
||||
Caqti_request.exec
|
||||
Caqti_type.(tup2 string string)
|
||||
"INSERT INTO post_tags VALUES (?,?);"
|
||||
|
||||
let upload_post_date =
|
||||
Caqti_request.exec
|
||||
Caqti_type.(tup2 string int)
|
||||
"INSERT INTO post_date VALUES (?,?);"
|
||||
|
||||
let upload_to_thread =
|
||||
Caqti_request.exec
|
||||
Caqti_type.(tup2 string string)
|
||||
"INSERT INTO threads VALUES (?,?);"
|
||||
|
||||
let upload_post_parent =
|
||||
Caqti_request.exec
|
||||
Caqti_type.(tup2 string string)
|
||||
"INSERT INTO post_parent VALUES (?,?);"
|
||||
|
||||
let get_post_nick =
|
||||
Caqti_request.find Caqti_type.string Caqti_type.string
|
||||
"SELECT nick FROM post_user WHERE post_id=?;"
|
||||
|
||||
let get_post_comment =
|
||||
Caqti_request.find Caqti_type.string Caqti_type.string
|
||||
"SELECT comment FROM post_comment WHERE post_id=?;"
|
||||
|
||||
let get_post_image_content =
|
||||
Caqti_request.find_opt Caqti_type.string Caqti_type.string
|
||||
"SELECT image_content FROM post_image WHERE post_id=?;"
|
||||
|
||||
let get_post_image_name =
|
||||
Caqti_request.find_opt Caqti_type.string Caqti_type.string
|
||||
"SELECT image_name FROM post_image WHERE post_id=?;"
|
||||
|
||||
let get_post_tags =
|
||||
Caqti_request.collect Caqti_type.string Caqti_type.string
|
||||
"SELECT tag FROM post_tags WHERE post_id=?;"
|
||||
|
||||
let get_post_date =
|
||||
Caqti_request.find Caqti_type.string Caqti_type.int
|
||||
"SELECT date FROM post_date WHERE post_id=?;"
|
||||
|
||||
let get_post_citations =
|
||||
Caqti_request.collect Caqti_type.string Caqti_type.string
|
||||
"SELECT post_id FROM post_citations WHERE reply_id=?;"
|
||||
|
||||
let get_post_replies =
|
||||
Caqti_request.collect Caqti_type.string Caqti_type.string
|
||||
"SELECT reply_id FROM post_replies WHERE post_id=?;"
|
||||
|
||||
let get_thread_posts =
|
||||
Caqti_request.collect Caqti_type.string Caqti_type.string
|
||||
"SELECT 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_post_subject =
|
||||
Caqti_request.find_opt Caqti_type.string Caqti_type.string
|
||||
"SELECT subject FROM post_subject WHERE post_id=?;"
|
||||
|
||||
let get_post_gps =
|
||||
Caqti_request.find_opt Caqti_type.string
|
||||
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;"
|
||||
end
|
||||
|
||||
let () =
|
||||
let tables =
|
||||
[ Q.create_post_user_table
|
||||
; Q.create_post_parent_table
|
||||
; Q.create_thread_table
|
||||
; Q.create_post_replies_table
|
||||
; Q.create_post_citations_table
|
||||
; Q.create_post_date_table
|
||||
; Q.create_post_comment_table
|
||||
; Q.create_post_image_table
|
||||
; Q.create_post_gps_table
|
||||
; Q.create_post_subject_table
|
||||
; Q.create_post_tags_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")
|
||||
|
||||
(* TODO should I escape html or smthing ?*)
|
||||
let parse_comment comment =
|
||||
let words = String.split_on_char ' ' comment in
|
||||
let cited_posts, words =
|
||||
List.fold_left
|
||||
(fun (acc_cited, acc_posts) w ->
|
||||
match String.starts_with ~prefix:">>" w with
|
||||
| false -> (acc_cited, acc_posts @ [ w ])
|
||||
| true -> (
|
||||
let sub_w = String.sub w 2 (String.length w - 2) in
|
||||
match Uuidm.of_string sub_w with
|
||||
| None -> (acc_cited, acc_posts @ [ w ])
|
||||
| Some _ ->
|
||||
let new_w = Format.sprintf {|<a href="#%s">%s</a>|} sub_w w in
|
||||
(acc_cited @ [ sub_w ], acc_posts @ [ new_w ]) ) )
|
||||
([], []) words
|
||||
in
|
||||
let comment = String.concat (String.make 1 ' ') words in
|
||||
(* remove duplicate *)
|
||||
let cited_posts = List.sort_uniq (fun _ _ -> 0) cited_posts in
|
||||
(comment, cited_posts)
|
||||
|
||||
let view_post post_id =
|
||||
let res_nick = Db.find Q.get_post_nick post_id in
|
||||
let res_comment = Db.find Q.get_post_comment post_id in
|
||||
let res_date = Db.find Q.get_post_date post_id in
|
||||
let res_image_name = Db.find_opt Q.get_post_image_name post_id in
|
||||
|
||||
let res_tags =
|
||||
Db.fold Q.get_post_tags (fun tag acc -> tag :: acc) post_id []
|
||||
in
|
||||
let res_replies =
|
||||
Db.fold Q.get_post_replies (fun reply_id acc -> reply_id :: acc) post_id []
|
||||
in
|
||||
|
||||
(* get more stuff for OP *)
|
||||
let res_subject = Db.find_opt Q.get_post_subject post_id in
|
||||
let res_latlng = Db.find_opt Q.get_post_gps post_id in
|
||||
|
||||
(* TODO clean taht idk urghh.. *)
|
||||
let res0 =
|
||||
match List.find_opt Result.is_error [ res_nick; res_comment ] with
|
||||
| Some (Error e) -> Error e
|
||||
| Some (Ok _) -> assert false
|
||||
| None -> Ok ()
|
||||
in
|
||||
let res1 =
|
||||
match List.find_opt Result.is_error [ res_image_name; res_subject ] with
|
||||
| Some (Error e) -> Error e
|
||||
| Some (Ok _) -> assert false
|
||||
| None -> Ok ()
|
||||
in
|
||||
let res2 =
|
||||
match res_latlng with
|
||||
| Ok _ -> Ok ()
|
||||
| Error e -> Error e
|
||||
in
|
||||
let res3 =
|
||||
match List.find_opt Result.is_error [ res_tags; res_replies ] with
|
||||
| Some (Error e) -> Error e
|
||||
| Some (Ok _) -> assert false
|
||||
| None -> Ok ()
|
||||
in
|
||||
let res4jpp =
|
||||
match res_date with
|
||||
| Ok _ -> Ok ()
|
||||
| Error e -> Error e
|
||||
in
|
||||
match List.find_opt Result.is_error [ res0; res1; res2; res3; res4jpp ] with
|
||||
| Some (Error e) -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
|
||||
| None -> (
|
||||
match
|
||||
( res_nick
|
||||
, res_comment
|
||||
, res_image_name
|
||||
, res_date
|
||||
, res_subject
|
||||
, res_latlng
|
||||
, res_tags
|
||||
, res_replies )
|
||||
with
|
||||
| ( Ok nick
|
||||
, Ok comment
|
||||
, Ok image_name
|
||||
, Ok date
|
||||
, Ok _subject
|
||||
, Ok _latlng
|
||||
, Ok _tags
|
||||
, Ok replies ) ->
|
||||
let image_view =
|
||||
match image_name with
|
||||
| Some image_name ->
|
||||
(*TODO thumbnails *)
|
||||
Format.sprintf
|
||||
{|
|
||||
<div class="file">
|
||||
<a title="%s" href="/post_pic/%s">
|
||||
<img src="/post_pic/%s" style="width:100" loading="lazy">
|
||||
</a>
|
||||
</div>
|
||||
|}
|
||||
image_name post_id post_id
|
||||
| None -> ""
|
||||
in
|
||||
let replies_view =
|
||||
{|<div class="repliesLink">|}
|
||||
^ String.concat ""
|
||||
(List.map
|
||||
(fun reply_id ->
|
||||
Format.sprintf {|<a class="replyLink" href="#%s">>>%s</a>|}
|
||||
reply_id reply_id )
|
||||
replies )
|
||||
^ {|</div> |}
|
||||
in
|
||||
(* TODO how to display date, I should probably render everything on the client*)
|
||||
let post_info_view =
|
||||
Format.sprintf
|
||||
{|
|
||||
<div class="postInfo"
|
||||
<span class=nick>%s</span>
|
||||
<span class=date unix-time="%d"></span>
|
||||
<span class=postNo>
|
||||
<a href="#%s" title="Link to this post">No.</a>
|
||||
<a href="javascript:insert_quote('%s')" "class=quoteLink title="Reply to this post">%s</a>
|
||||
</span>
|
||||
%s
|
||||
</div>|}
|
||||
nick date post_id post_id post_id replies_view
|
||||
in
|
||||
|
||||
Ok
|
||||
(Format.sprintf
|
||||
{|
|
||||
<div class="post" id="%s">
|
||||
%s
|
||||
%s
|
||||
<blockquote class="comment">%s</blockquote>
|
||||
</div>
|
||||
|}
|
||||
post_id post_info_view image_view comment )
|
||||
| _ -> assert false )
|
||||
| _ -> assert false
|
||||
|
||||
let view_thread thread_id =
|
||||
let res = Db.find_opt Q.is_thread thread_id in
|
||||
match res with
|
||||
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
|
||||
| Ok None -> Error "Not a thread"
|
||||
| Ok (Some _) -> (
|
||||
let thread_posts =
|
||||
Db.fold Q.get_thread_posts
|
||||
(fun post_id acc -> post_id :: acc)
|
||||
thread_id []
|
||||
in
|
||||
match thread_posts with
|
||||
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
|
||||
| Ok thread_posts -> (
|
||||
(*order by date *)
|
||||
(*TODO do this more clean *)
|
||||
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
|
||||
(function
|
||||
| Ok date -> date
|
||||
| Error _ -> assert false )
|
||||
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, _ = List.split sorted_posts_dates in
|
||||
let view_posts = List.map view_post posts in
|
||||
let view_posts =
|
||||
List.map
|
||||
(function
|
||||
| Ok view -> view
|
||||
| Error _ -> assert false )
|
||||
(List.filter Result.is_ok view_posts)
|
||||
in
|
||||
Ok (String.concat "\n\r" view_posts) ) )
|
||||
|
||||
let make_post ~comment ?file ~tags ?parent_id nick =
|
||||
let is_valid_comment =
|
||||
String.length comment < 10000
|
||||
(*&& String.escaped comment = comment*)
|
||||
in
|
||||
let is_valid_file =
|
||||
match file with
|
||||
| Some (_, image_content) -> is_valid_image image_content
|
||||
| None -> true
|
||||
in
|
||||
(* TODO latlng validation? *)
|
||||
let is_valid_tags = String.length tags < 1000 in
|
||||
let tag_list = Str.split (Str.regexp " +") tags in
|
||||
match (is_valid_comment, is_valid_file, is_valid_tags) with
|
||||
| false, _, _ -> Error "invalid comment"
|
||||
| _, false, _ -> Error "invalid file"
|
||||
| _, _, false -> Error "invalid tags"
|
||||
| true, true, true -> (
|
||||
(*TODO make post_id a int *)
|
||||
let post_id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
|
||||
(* add to plant_id <-> user*)
|
||||
let res_post_id = Db.exec Q.upload_post_id (post_id, nick) in
|
||||
let comment, cited_posts = parse_comment comment in
|
||||
|
||||
let res_comment = Db.exec Q.upload_post_comment (post_id, comment) in
|
||||
let res_image =
|
||||
match file with
|
||||
| Some (image_name, image_content) ->
|
||||
let image_name =
|
||||
match image_name with
|
||||
| Some image_name -> image_name
|
||||
| None ->
|
||||
(* make up random name if no name was given *)
|
||||
Uuidm.to_string (Uuidm.v4_gen random_state ())
|
||||
in
|
||||
Db.exec Q.upload_post_image (post_id, image_name, image_content)
|
||||
| None -> Ok ()
|
||||
in
|
||||
let res_tags =
|
||||
match
|
||||
List.find_opt Result.is_error
|
||||
(List.map
|
||||
(fun tag -> Db.exec Q.upload_post_tag (post_id, tag))
|
||||
tag_list )
|
||||
with
|
||||
| Some (Error e) -> Error e
|
||||
| Some _ -> assert false
|
||||
| None -> Ok ()
|
||||
in
|
||||
(* TODO unix time *)
|
||||
let date = int_of_float (Unix.time ()) in
|
||||
let res_date = Db.exec Q.upload_post_date (post_id, date) in
|
||||
let parent_id =
|
||||
match parent_id with
|
||||
| Some id -> id
|
||||
| None -> post_id
|
||||
in
|
||||
let res_parent = Db.exec Q.upload_post_parent (post_id, parent_id) in
|
||||
let res_citations =
|
||||
match
|
||||
List.find_opt Result.is_error
|
||||
(List.map
|
||||
(fun cited_id -> Db.exec Q.upload_post_reply (cited_id, post_id))
|
||||
cited_posts )
|
||||
with
|
||||
| Some (Error e) -> Error e
|
||||
| Some _ -> assert false
|
||||
| None -> Ok ()
|
||||
in
|
||||
let res_thread = Db.exec Q.upload_to_thread (parent_id, post_id) in
|
||||
let res =
|
||||
List.find_opt Result.is_error
|
||||
[ res_post_id
|
||||
; res_comment
|
||||
; res_image
|
||||
; res_tags
|
||||
; res_date
|
||||
; res_parent
|
||||
; res_citations
|
||||
; res_thread
|
||||
]
|
||||
in
|
||||
match res with
|
||||
| Some (Error e) ->
|
||||
(* TODO try to remove post_id from post_user to clean db*)
|
||||
Error (Format.sprintf "db error: %s" (Caqti_error.show e))
|
||||
| Some _ -> assert false
|
||||
| None -> Ok post_id )
|
||||
|
||||
let make_thread comment file (lat, lng) subject tags nick =
|
||||
(* TODO latlng validation? *)
|
||||
let is_valid_latlng = true in
|
||||
let is_valid_subject =
|
||||
String.length subject < 500 && String.escaped subject = subject
|
||||
in
|
||||
(* OP must have tags (?) *)
|
||||
let is_valid_tags = String.length tags < 1000 && String.length tags > 0 in
|
||||
match (is_valid_latlng, is_valid_subject, is_valid_tags) with
|
||||
| false, _, _ -> Error "invalid coordinate"
|
||||
| _, false, _ -> Error "invalid subject"
|
||||
| _, _, false -> Error "invalid or empty tags"
|
||||
| true, true, true -> (
|
||||
let res_post = make_post ~comment ~file ~tags nick in
|
||||
match res_post with
|
||||
| Error e -> Error e
|
||||
| Ok post_id -> (
|
||||
(* add fields specific to OP *)
|
||||
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
|
||||
let res = List.find_opt Result.is_error [ res_gps; res_subject ] in
|
||||
match res with
|
||||
| Some (Error e) ->
|
||||
(* TODO try to remove post_id from post_user *)
|
||||
Error (Format.sprintf "db error: %s" (Caqti_error.show e))
|
||||
| Some _ -> assert false
|
||||
| None -> Ok post_id ) )
|
||||
|
||||
(* TODO make this return geojson directly *)
|
||||
let marker_list () =
|
||||
let thread_id_list =
|
||||
Db.fold Q.list_thread_ids (fun thread_id acc -> thread_id :: acc) () []
|
||||
in
|
||||
match thread_id_list with
|
||||
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
|
||||
| Ok thread_id_list ->
|
||||
let markers_res =
|
||||
List.map
|
||||
(fun thread_id ->
|
||||
match Db.find_opt Q.get_post_gps thread_id with
|
||||
| Ok (Some (lat, lng)) ->
|
||||
let content =
|
||||
match view_post thread_id with
|
||||
| Ok s -> s
|
||||
| Error e -> e
|
||||
in
|
||||
Ok (lat, lng, content, thread_id)
|
||||
| Ok None -> Error "latlng not found"
|
||||
| Error e ->
|
||||
Error (Format.sprintf "db error: %s" (Caqti_error.show e)) )
|
||||
thread_id_list
|
||||
in
|
||||
let markers =
|
||||
List.map
|
||||
(function
|
||||
| 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, thread_id ->
|
||||
Format.sprintf
|
||||
{|
|
||||
{
|
||||
"type": "Feature",
|
||||
"geometry": {
|
||||
"type": "Point",
|
||||
"coordinates": [%s,%s]
|
||||
},
|
||||
"properties": {
|
||||
"content": "%s",
|
||||
"thread_id": "%s"
|
||||
}
|
||||
}
|
||||
|}
|
||||
(* geojson use lng lat, and not lat lng*)
|
||||
(Float.to_string lng)
|
||||
(Float.to_string lat) (String.escaped content) thread_id
|
||||
|
||||
let get_post_image post_id =
|
||||
let res = Db.find_opt Q.get_post_image_content post_id in
|
||||
match res with
|
||||
| Ok content -> (
|
||||
match content with
|
||||
| Some content -> Ok (Some content)
|
||||
| None -> Error "Image not found" )
|
||||
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
|
||||
29
src/babillard_page.eml.html
Normal file
29
src/babillard_page.eml.html
Normal file
|
|
@ -0,0 +1,29 @@
|
|||
let f request =
|
||||
<script type="text/javascript" src="/assets/js/js_thread_map.js" defer="defer"></script>
|
||||
<%s Format.sprintf "Babillard is love" %>
|
||||
<div class="mb-3">
|
||||
% begin match Dream.session "nick" request with
|
||||
% | None ->
|
||||
|
||||
% | Some _nick ->
|
||||
<%s! Dream.form_tag ~action:"/babillard" ~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="subject" id="subjectLabel" class="form-label">Subject</label>
|
||||
<input name="subject" type="text" class="form-control" id="subject" aria-labelledby="subjectLabel"></input>
|
||||
|
||||
<label for="threadComment" id="threadCommentLabel" class="form-label">Comment</label>
|
||||
<textarea name="threadComment" type="text" class="form-control" id="threadComment" aria-labelledby="threadCommentLabel"></textarea>
|
||||
|
||||
<label for="tags" id="tagsLabel" class="form-label">Tags</label>
|
||||
<input name="tags" type="text" class="form-control" id="tags" aria-labelledby="tagsLabel"></input>
|
||||
|
||||
<input id="file" name="file" aria-describedby="fileHelp" type="file">
|
||||
<div id="fileHelp" class="form-text">Add a picture for your thread</div>
|
||||
<button type="submit" class="btn btn-primary">Make Thread</button>
|
||||
</form>
|
||||
%end;
|
||||
<div id="map"></div>
|
||||
<div id="thread_div"></div>
|
||||
</div>
|
||||
|
|
@ -1,8 +1,17 @@
|
|||
(rule
|
||||
(target map.js)
|
||||
(target js_plant_map.js)
|
||||
(deps
|
||||
(file ../../../map.bc.js))
|
||||
(file ../../../js_plant_map.bc.js))
|
||||
(action
|
||||
(with-stdout-to
|
||||
%{target}
|
||||
(cat ../../../map.bc.js))))
|
||||
(cat ../../../js_plant_map.bc.js))))
|
||||
|
||||
(rule
|
||||
(target js_thread_map.js)
|
||||
(deps
|
||||
(file ../../../js_thread_map.bc.js))
|
||||
(action
|
||||
(with-stdout-to
|
||||
%{target}
|
||||
(cat ../../../js_thread_map.bc.js))))
|
||||
|
|
|
|||
32
src/dune
32
src/dune
|
|
@ -1,6 +1,9 @@
|
|||
(executable
|
||||
(public_name permap)
|
||||
(modules
|
||||
thread_page
|
||||
babillard
|
||||
babillard_page
|
||||
plant
|
||||
db
|
||||
app
|
||||
|
|
@ -29,8 +32,18 @@
|
|||
(pps lwt_ppx)))
|
||||
|
||||
(executable
|
||||
(name map)
|
||||
(modules map)
|
||||
(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_thread_map)
|
||||
(modules js_thread_map)
|
||||
(libraries js_of_ocaml brr)
|
||||
(modes js)
|
||||
(js_of_ocaml
|
||||
|
|
@ -56,6 +69,18 @@
|
|||
(action
|
||||
(run dream_eml %{deps} --workspace %{workspace_root})))
|
||||
|
||||
(rule
|
||||
(targets babillard_page.ml)
|
||||
(deps babillard_page.eml.html)
|
||||
(action
|
||||
(run dream_eml %{deps} --workspace %{workspace_root})))
|
||||
|
||||
(rule
|
||||
(targets thread_page.ml)
|
||||
(deps thread_page.eml.html)
|
||||
(action
|
||||
(run dream_eml %{deps} --workspace %{workspace_root})))
|
||||
|
||||
(rule
|
||||
(targets add_plant.ml)
|
||||
(deps add_plant.eml.html)
|
||||
|
|
@ -72,7 +97,8 @@
|
|||
(target content.ml)
|
||||
(deps
|
||||
(source_tree content)
|
||||
(file content/assets/js/map.js))
|
||||
(file content/assets/js/js_plant_map.js)
|
||||
(file content/assets/js/js_thread_map.js))
|
||||
(action
|
||||
(with-stdout-to
|
||||
%{null}
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
(* TODO only run this on /add_plant and /map *)
|
||||
(*TODO clean up this shit *)
|
||||
(*TODO use Jv.find everywhere (do we care?)*)
|
||||
let log = Format.printf
|
||||
|
||||
|
|
@ -56,7 +57,6 @@ 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
|
||||
|
|
@ -64,6 +64,10 @@ 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 on_click callback to map*)
|
||||
ignore @@ Jv.call map "on" [| Jv.of_string "click"; Jv.repr on_click |]
|
||||
|
||||
module Marker = struct
|
||||
let on_each_feature feature layer =
|
||||
log "on_each_feature@.";
|
||||
|
|
@ -78,7 +82,7 @@ module Marker = struct
|
|||
(* TODO add onEachFeature *)
|
||||
let dict = Jv.obj [| ("onEachFeature", Jv.repr on_each_feature) |] in
|
||||
let layer = Jv.call leaflet "geoJSON" [| geojson; dict |] in
|
||||
ignore @@ Jv.call layer "addTo" [| map |];
|
||||
let _marker_layer = Jv.call layer "addTo" [| map |] in
|
||||
()
|
||||
|
||||
let handle_response response =
|
||||
|
|
@ -88,14 +92,11 @@ module Marker = struct
|
|||
()
|
||||
|
||||
let () =
|
||||
(* TODO only on /map *)
|
||||
log "fetch geojson@.";
|
||||
log "fetch plant geojson@.";
|
||||
let window = Jv.get Jv.global "window" in
|
||||
let fetchfutur = Jv.call window "fetch" [| Jv.of_string "/markers" |] in
|
||||
let fetchfutur =
|
||||
Jv.call window "fetch" [| Jv.of_string "/plant_markers" |]
|
||||
in
|
||||
ignore @@ Jv.call fetchfutur "then" [| Jv.repr handle_response |];
|
||||
()
|
||||
end
|
||||
|
||||
let () =
|
||||
(*add on_click callback to map*)
|
||||
ignore @@ Jv.call map "on" [| Jv.of_string "click"; Jv.repr on_click |]
|
||||
147
src/js_thread_map.ml
Normal file
147
src/js_thread_map.ml
Normal file
|
|
@ -0,0 +1,147 @@
|
|||
(*TODO clean up this shit *)
|
||||
let log = Format.printf
|
||||
|
||||
(* 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
|
||||
{|© <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 |]
|
||||
|
||||
let () =
|
||||
(*add on_click callback to map*)
|
||||
ignore @@ Jv.call map "on" [| Jv.of_string "click"; Jv.repr on_click |]
|
||||
|
||||
module Marker = struct
|
||||
(* manipulate DOM to show thread in a div *)
|
||||
let handle_thread_view thread_view =
|
||||
log "handle_thread_view@.";
|
||||
let thread_div = Jv.get Jv.global "thread_div" in
|
||||
ignore @@ Jv.set thread_div "innerHTML" thread_view;
|
||||
()
|
||||
|
||||
let handle_response response =
|
||||
log "handle_response@.";
|
||||
let thread_view_futur = Jv.call response "text" [||] in
|
||||
ignore @@ Jv.call thread_view_futur "then" [| Jv.repr handle_thread_view |];
|
||||
()
|
||||
|
||||
(*fuck you js*)
|
||||
let marker_on_click thread_id _e =
|
||||
log "marker_on_click@.";
|
||||
let thread_id = Jv.to_string thread_id in
|
||||
let window = Jv.get Jv.global "window" in
|
||||
log "3@.";
|
||||
let fetchfutur =
|
||||
Jv.call window "fetch" [| Jv.of_string ("/thread_view/" ^ thread_id) |]
|
||||
in
|
||||
log "4@.";
|
||||
ignore @@ Jv.call fetchfutur "then" [| Jv.repr handle_response |];
|
||||
()
|
||||
|
||||
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
|
||||
let thread_id = Jv.get feature_properties "thread_id" in
|
||||
let layer = Jv.call layer "bindPopup" [| feature_properties_content |] in
|
||||
ignore
|
||||
@@ Jv.call layer "on"
|
||||
[| Jv.of_string "click"; Jv.repr (marker_on_click thread_id) |];
|
||||
()
|
||||
|
||||
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 "geoJSON" [| geojson; dict |] in
|
||||
let _marker_layer = Jv.call layer "addTo" [| map |] in
|
||||
|
||||
()
|
||||
|
||||
let markers_handle_response response =
|
||||
log "markers_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 thread geojson@.";
|
||||
let window = Jv.get Jv.global "window" in
|
||||
let fetchfutur =
|
||||
Jv.call window "fetch" [| Jv.of_string "/thread_markers" |]
|
||||
in
|
||||
ignore @@ Jv.call fetchfutur "then" [| Jv.repr markers_handle_response |];
|
||||
()
|
||||
end
|
||||
|
||||
(* called by clicking post_id to reply *)
|
||||
(* insert id into reply form *)
|
||||
let insert_quote post_id =
|
||||
log "quote@.";
|
||||
match Jv.(find global "replyComment") with
|
||||
| None -> Jv.undefined
|
||||
| Some comment_textarea ->
|
||||
let content = Jv.get comment_textarea "value" in
|
||||
let new_content =
|
||||
Jv.call content "concat"
|
||||
[| Jv.of_string ">>"; post_id; Jv.of_string " " |]
|
||||
in
|
||||
ignore @@ Jv.set comment_textarea "value" new_content;
|
||||
Jv.undefined
|
||||
|
||||
let () = Jv.set Jv.global "insert_quote" (Jv.repr insert_quote)
|
||||
162
src/permap.ml
162
src/permap.ml
|
|
@ -102,9 +102,9 @@ let profile_post request =
|
|||
| `Expired _
|
||||
| `Wrong_content_type -> (
|
||||
match%lwt Dream.multipart request with
|
||||
| `Ok [ ("files", files) ] ->
|
||||
| `Ok [ ("file", file) ] ->
|
||||
let res =
|
||||
match User.upload_avatar files nick with
|
||||
match User.upload_avatar file nick with
|
||||
| Ok () -> "Avatar was uploaded!"
|
||||
| Error e -> e
|
||||
in
|
||||
|
|
@ -142,6 +142,17 @@ let plant_image request =
|
|||
| 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
|
||||
match image with
|
||||
| Ok (Some image) ->
|
||||
Dream.respond ~headers:[ ("Content-Type", "image") ] image
|
||||
| Ok None
|
||||
| Error _ ->
|
||||
Dream.empty `Not_Found
|
||||
|
||||
(* TODO fix *)
|
||||
let map request = page "map" request
|
||||
|
||||
let add_plant_get request =
|
||||
|
|
@ -156,21 +167,15 @@ let add_plant_post request =
|
|||
match%lwt Dream.multipart request with
|
||||
| `Ok
|
||||
[ ("files", files)
|
||||
; ("lat_input", lat)
|
||||
; ("lng_input", lng)
|
||||
; ("tags", tags)
|
||||
; ("lat_input", [ (_, lat) ])
|
||||
; ("lng_input", [ (_, lng) ])
|
||||
; ("tags", [ (_, tags) ])
|
||||
]
|
||||
| `Ok
|
||||
(("files", files)
|
||||
:: ("lat_input", lat) :: ("lng_input", lng) :: ("tags", tags) :: _ :: _
|
||||
:: ("lat_input", [ (_, lat) ])
|
||||
:: ("lng_input", [ (_, lng) ]) :: ("tags", [ (_, tags) ]) :: _ :: _
|
||||
) -> (
|
||||
match tags with
|
||||
| [] -> render_unsafe "Field tag is empty" request
|
||||
| [ (_, tags) ] -> (
|
||||
match (lat, lng) with
|
||||
| [], _ -> render_unsafe "Field tag is empty" request
|
||||
| _, [] -> render_unsafe "Field tag is empty" request
|
||||
| [ (_, lat) ], [ (_, lng) ] -> (
|
||||
match (Float.of_string_opt lat, Float.of_string_opt lng) with
|
||||
| None, _ -> render_unsafe "Invalide coordinate" request
|
||||
| _, None -> render_unsafe "Invalide coordinate" request
|
||||
|
|
@ -181,8 +186,6 @@ let add_plant_post request =
|
|||
| Error e -> e
|
||||
in
|
||||
render_unsafe res request )
|
||||
| _lat_lng -> Dream.empty `Bad_Request )
|
||||
| _tags -> Dream.empty `Bad_Request )
|
||||
| `Ok _ -> Dream.empty `Bad_Request
|
||||
| `Expired _
|
||||
| `Many_tokens _
|
||||
|
|
@ -192,7 +195,8 @@ let add_plant_post request =
|
|||
| `Wrong_content_type ->
|
||||
Dream.empty `Bad_Request )
|
||||
|
||||
let markers request =
|
||||
let plant_markers request =
|
||||
(*TODO should be in plant *)
|
||||
let marker_list = Plant.marker_list () in
|
||||
match marker_list with
|
||||
| Ok marker_list ->
|
||||
|
|
@ -204,6 +208,123 @@ let markers request =
|
|||
Dream.respond ~headers:[ ("Content-Type", "application/json") ] json
|
||||
| Error e -> render_unsafe e request
|
||||
|
||||
let thread_markers request =
|
||||
(*TODO should be in babillard*)
|
||||
let marker_list = Babillard.marker_list () in
|
||||
match marker_list with
|
||||
| Ok marker_list ->
|
||||
let json =
|
||||
{| [ |}
|
||||
^ String.concat "," (List.map Babillard.marker_to_geojson marker_list)
|
||||
^ "]"
|
||||
in
|
||||
Dream.respond ~headers:[ ("Content-Type", "application/json") ] json
|
||||
| Error e -> render_unsafe e request
|
||||
|
||||
let babillard_get request = render_unsafe (Babillard_page.f request) request
|
||||
|
||||
let babillard_post request =
|
||||
match Dream.session "nick" request with
|
||||
| None -> render_unsafe "Not logged in" request
|
||||
| Some nick -> (
|
||||
match%lwt Dream.multipart request with
|
||||
(*TODO jpp du duplicat la *)
|
||||
| `Ok
|
||||
[ ("file", file)
|
||||
; ("lat_input", [ (_, lat) ])
|
||||
; ("lng_input", [ (_, lng) ])
|
||||
; ("subject", [ (_, subject) ])
|
||||
; ("tags", [ (_, tags) ])
|
||||
; ("threadComment", [ (_, comment) ])
|
||||
]
|
||||
| `Ok
|
||||
(("file", file)
|
||||
:: ("lat_input", [ (_, lat) ])
|
||||
:: ("lng_input", [ (_, lng) ])
|
||||
:: ("subject", [ (_, subject) ])
|
||||
:: ("tags", [ (_, tags) ])
|
||||
:: ("threadComment", [ (_, comment) ]) :: _ :: _ ) -> (
|
||||
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 -> (
|
||||
match file with
|
||||
| [] -> render_unsafe "No image" request
|
||||
| _ :: _ :: _ -> render_unsafe "More than one image" request
|
||||
| [ file ] ->
|
||||
let res =
|
||||
match
|
||||
Babillard.make_thread comment file (lat, lng) subject tags nick
|
||||
with
|
||||
| Ok _post_id -> "Your thread was posted on the babillard!"
|
||||
| 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 thread_get request =
|
||||
let thread_id = Dream.param "thread_id" request in
|
||||
let thread_view = Babillard.view_thread thread_id in
|
||||
match thread_view with
|
||||
| Error e -> render_unsafe e request
|
||||
| Ok thread_view ->
|
||||
render_unsafe (Thread_page.f thread_view thread_id request) request
|
||||
|
||||
(* get thread view but not wrapped in template, so we can display it on /babillard*)
|
||||
let thread_view request =
|
||||
let thread_id = Dream.param "thread_id" request in
|
||||
let thread_view = Babillard.view_thread thread_id in
|
||||
match thread_view with
|
||||
| Error e -> render_unsafe e request
|
||||
| Ok thread_view ->
|
||||
Dream.respond
|
||||
~headers:[ ("Content-Type", "html") ]
|
||||
(Thread_page.f thread_view thread_id request)
|
||||
|
||||
(*form to reply to a thread *)
|
||||
let thread_post request =
|
||||
match Dream.session "nick" request with
|
||||
| None -> render_unsafe "Not logged in" request
|
||||
| Some nick -> (
|
||||
match%lwt Dream.multipart request with
|
||||
| `Ok
|
||||
[ ("file", file)
|
||||
; ("replyComment", [ (_, comment) ])
|
||||
; ("tags", [ (_, tags) ])
|
||||
]
|
||||
| `Ok
|
||||
(("file", file)
|
||||
:: ("tags", [ (_, tags) ])
|
||||
:: ("replyComment", [ (_, comment) ]) :: _ :: _ ) ->
|
||||
let parent_id = Dream.param "thread_id" request in
|
||||
let res =
|
||||
match file with
|
||||
| [] -> Babillard.make_post ~comment ~tags ~parent_id nick
|
||||
| [ file ] -> Babillard.make_post ~comment ~file ~tags ~parent_id nick
|
||||
| _ :: _ :: _ -> Error "More than one image"
|
||||
in
|
||||
let msg =
|
||||
match res with
|
||||
| Ok _post_id -> "Your reply was posted"
|
||||
| Error e -> e
|
||||
in
|
||||
render_unsafe msg request
|
||||
| `Ok _ -> Dream.empty `Bad_Request
|
||||
| `Expired _
|
||||
| `Many_tokens _
|
||||
| `Missing_token _
|
||||
| `Invalid_token _
|
||||
| `Wrong_session _
|
||||
| `Wrong_content_type ->
|
||||
Dream.empty `Bad_Request )
|
||||
|
||||
let () =
|
||||
Dream.run @@ Dream.logger @@ Dream.memory_sessions
|
||||
@@ Dream.router
|
||||
|
|
@ -223,6 +344,13 @@ 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.get "/plant_markers" plant_markers
|
||||
; Dream.get "/thread_markers" thread_markers
|
||||
; Dream.get "/thread_view/:thread_id" thread_view
|
||||
; Dream.get "/babillard" babillard_get
|
||||
; Dream.post "/babillard" babillard_post
|
||||
; Dream.get "/babillard/:thread_id" thread_get (*todo, bad names ^^*)
|
||||
; Dream.post "/babillard/:thread_id" thread_post
|
||||
; Dream.get "/post_pic/:post_id" post_image
|
||||
]
|
||||
@@ Dream.not_found
|
||||
|
|
|
|||
24
src/plant.ml
24
src/plant.ml
|
|
@ -83,6 +83,7 @@ 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
|
||||
|
|
@ -186,18 +187,19 @@ let get_plant_image plant_id nb =
|
|||
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
|
||||
|
||||
let add_plant (lat, lng) tags files nick =
|
||||
let tags_len = String.length tags in
|
||||
if tags_len > 1000 then
|
||||
if String.length tags > 1000 then
|
||||
Error "tags too long"
|
||||
else
|
||||
let tag_list = Str.split (Str.regexp " +") tags in
|
||||
(* id for plant*)
|
||||
let ok_list = List.map (fun (_, content) -> is_valid_image content) files in
|
||||
let valid_files = List.for_all (fun valid -> valid) ok_list in
|
||||
if not valid_files then
|
||||
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
|
||||
|
|
@ -216,9 +218,11 @@ let add_plant (lat, lng) tags files nick =
|
|||
(fun tag -> Db.exec Q.upload_plant_tag (plant_id, tag))
|
||||
tag_list
|
||||
in
|
||||
if List.exists Result.is_error res_tags then
|
||||
Error (Format.sprintf "db error")
|
||||
else
|
||||
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
|
||||
|
|
@ -231,4 +235,4 @@ let add_plant (lat, lng) tags files nick =
|
|||
| Some (Error e) ->
|
||||
Error (Format.sprintf "db error: %s" (Caqti_error.show e))
|
||||
| Some (Ok _) -> assert false
|
||||
| None -> Ok () ) )
|
||||
| None -> Ok () ) ) )
|
||||
|
|
|
|||
|
|
@ -43,6 +43,9 @@ let render_unsafe ~title ~content request =
|
|||
<li class="nav-item">
|
||||
<a class="nav-link" href="/map">Map</a>
|
||||
</li>
|
||||
<li class="nav-item">
|
||||
<a class="nav-link" href="/babillard">Babillard</a>
|
||||
</li>
|
||||
<li class="nav-item">
|
||||
<a class="nav-link" href="/user">Users</a>
|
||||
</li>
|
||||
|
|
@ -67,6 +70,5 @@ let render_unsafe ~title ~content request =
|
|||
</footer>
|
||||
</main>
|
||||
<script src="/assets/js/bootstrap.bundle.min.js"></script>
|
||||
<script type="text/javascript" src="/assets/js/map.js" defer="defer"></script>
|
||||
</body>
|
||||
</html>
|
||||
|
|
|
|||
25
src/thread_page.eml.html
Normal file
25
src/thread_page.eml.html
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
let f thread_view thread_id request =
|
||||
<script type="text/javascript" src="/assets/js/js_thread_map.js" defer="defer"></script>
|
||||
<%s Format.sprintf "[Reply]" %>
|
||||
<%s! thread_view %>
|
||||
|
||||
% begin match Dream.session "nick" request with
|
||||
% | None ->
|
||||
|
||||
% | Some _ ->
|
||||
<div class="mb-3">
|
||||
<%s! Dream.form_tag ~action:( Format.sprintf "/babillard/%s" thread_id)
|
||||
~enctype:`Multipart_form_data request %>
|
||||
|
||||
<label for="replyComment" id="replyCommentLabel" class="form-label">Comment</label>
|
||||
<textarea name="replyComment" type="text" class="form-control" id="replyComment" aria-labelledby="replyCommentLabel"></textarea>
|
||||
|
||||
<label for="tags" id="tagsLabel" class="form-label">Tags</label>
|
||||
<input name="tags" type="text" class="form-control" id="tags" aria-labelledby="tagsLabel"></input>
|
||||
|
||||
<input id="file" name="file" aria-describedby="fileHelp" type="file">
|
||||
<div id="fileHelp" class="form-text">Add a picture to your post</div>
|
||||
<button type="submit" class="btn btn-primary">Reply</button>
|
||||
</div>
|
||||
</form>
|
||||
% end;
|
||||
|
|
@ -11,7 +11,7 @@ let f nick bio request =
|
|||
|
||||
<img src="/user/<%s nick %>/avatar" class="img-thumbnail" alt="Your avatar picture">
|
||||
<%s! Dream.form_tag ~action:"/profile" ~enctype:`Multipart_form_data request %>
|
||||
<input name="files" type="file" multiple>
|
||||
<input name="file" type="file">
|
||||
<button>Submit!</button>
|
||||
</form>
|
||||
<%s! Plant.view_user_plant_list nick %>
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue