From 18bbeba3c97fbabd78c84bbb3d4a01c7eacef417 Mon Sep 17 00:00:00 2001 From: Swrup Date: Wed, 9 Mar 2022 14:36:19 +0100 Subject: [PATCH] add categories --- src/app.ml | 8 ++++-- src/babillard.ml | 49 +++++++++++++++++++------------- src/babillard_page.eml.html | 1 + src/content/assets/css/style.css | 8 ++++++ src/permap.ml | 13 +++++++-- src/pp_babillard.ml | 31 +++++++++++++++++++- 6 files changed, 85 insertions(+), 25 deletions(-) diff --git a/src/app.ml b/src/app.ml index 3fd5865..ec84d50 100644 --- a/src/app.ml +++ b/src/app.ml @@ -78,9 +78,13 @@ let log = let () = Dream.log "log: %b" log -let admins = - let dirs = Scfg.Query.get_dirs "admin" config in +let get_dirs name = + let dirs = Scfg.Query.get_dirs name config in List.map (fun dir -> Result.fold ~error:failwith ~ok:Fun.id (Scfg.Query.get_param 0 dir) ) dirs + +let admins = get_dirs "admin" + +let categories = get_dirs "category" diff --git a/src/babillard.ml b/src/babillard.ml index 34a48e7..0f7ea01 100644 --- a/src/babillard.ml +++ b/src/babillard.ml @@ -343,9 +343,8 @@ let upload_post ?image_content post = let^ () = Db.exec Q.upload_thread_info (id, subject, lat, lng) in Ok id -let build_reply ~comment ?image ~tags ?parent_id user_id = +let build_reply ~comment ?image ~tag_list ?parent_id user_id = 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 = Option.value parent_id ~default:id in @@ -355,7 +354,9 @@ let build_reply ~comment ?image ~tags ?parent_id user_id = match parse_image image with | Error e -> Error e | Ok image -> - if String.length tags > 1000 then Error "invalid tags" + if List.length tag_list > 30 then Error "too much tags" + else if List.exists (fun tag -> String.length tag > 100) tag_list then + Error "tag too long" else let image_info = match image with @@ -367,7 +368,7 @@ let build_reply ~comment ?image ~tags ?parent_id user_id = @@ List.sort_uniq String.compare @@ List.filter (( <> ) "") @@ List.map String.trim - @@ Str.split (Str.regexp ",+") tags + @@ List.map Dream.html_escape tag_list in let date = Unix.time () in let comment, citations = parse_comment comment in @@ -387,31 +388,39 @@ let build_reply ~comment ?image ~tags ?parent_id user_id = in Ok reply -let build_op ~comment ?image ~tags ~subject ~lat ~lng user_id = +let build_op ~comment ?image ~tag_list ~categories ~subject ~lat ~lng user_id = let subject = Dream.html_escape subject in - (* TODO latlng validation? *) - let is_valid_latlng = true in - if not is_valid_latlng then Error "Invalid coordinate" - else if String.length subject > 600 then Error "Invalid subject" + if List.exists (fun s -> not (List.mem s App.categories)) categories then + Error "Invalid category" else - let thread_data = { subject; lng; lat } in - let* reply = - match image with - | Some image -> build_reply ~comment ~image ~tags user_id - | None -> build_reply ~comment ~tags user_id - in - let op = Op (thread_data, reply) in - Ok op + let tag_list = categories @ tag_list in + (* TODO latlng validation? *) + let is_valid_latlng = true in + if not is_valid_latlng then Error "Invalid coordinate" + else if String.length subject > 600 then Error "Invalid subject" + else + let thread_data = { subject; lng; lat } in + let* reply = + match image with + | Some image -> build_reply ~comment ~image ~tag_list user_id + | None -> build_reply ~comment ~tag_list user_id + in + let op = Op (thread_data, reply) in + Ok op let make_reply ~comment ?image ~tags ~parent_id user_id = - let* reply = build_reply ~comment ?image ~tags ~parent_id user_id in + let tag_list = Str.split (Str.regexp ",+") tags in + let* reply = build_reply ~comment ?image ~tag_list ~parent_id user_id in let post = Post reply in match image with | None -> upload_post post | Some (_image_info, image_content) -> upload_post ~image_content post -let make_op ~comment ?image ~tags ~subject ~lat ~lng user_id = - let* op = build_op ~comment ?image ~tags ~subject ~lat ~lng user_id in +let make_op ~comment ?image ~tags ~categories ~subject ~lat ~lng user_id = + let tag_list = Str.split (Str.regexp ",+") tags in + let* op = + build_op ~comment ?image ~tag_list ~categories ~subject ~lat ~lng user_id + in match image with | None -> upload_post op | Some (_image_info, image_content) -> upload_post ~image_content op diff --git a/src/babillard_page.eml.html b/src/babillard_page.eml.html index 501c30f..4b5ca1c 100644 --- a/src/babillard_page.eml.html +++ b/src/babillard_page.eml.html @@ -39,6 +39,7 @@ let f request =
+ <%s! Pp_babillard.pp_checkboxes () %>
diff --git a/src/content/assets/css/style.css b/src/content/assets/css/style.css index 87a9198..51b8e9f 100644 --- a/src/content/assets/css/style.css +++ b/src/content/assets/css/style.css @@ -129,6 +129,14 @@ a.preview-link { padding: 2px; } +.category { + background-color: #FFB300; + border-radius: 4px; + padding: 2px; + font-weight: bold; + font-size: 20px; +} + .off { display: none; } diff --git a/src/permap.ml b/src/permap.ml index 79e7e03..0f340c9 100644 --- a/src/permap.ml +++ b/src/permap.ml @@ -1,3 +1,5 @@ +include Bindings + let get_title content = let open Soup in try @@ -341,6 +343,7 @@ let babillard_post request = match%lwt Dream.multipart request with | `Ok [ ("alt", [ (_, alt) ]) + ; ("category", categories) ; ("file", file) ; ("lat-input", [ (_, lat) ]) ; ("lng-input", [ (_, lng) ]) @@ -348,17 +351,23 @@ let babillard_post request = ; ("tags", [ (_, tags) ]) ; ("thread-comment", [ (_, comment) ]) ] -> ( + let categories = + List.map (fun (_name, category) -> category) categories + in 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 file with - | [] -> Babillard.make_op ~comment ~lat ~lng ~subject ~tags user_id + | [] -> + Babillard.make_op ~comment ~lat ~lng ~subject ~tags ~categories + user_id | _ :: _ :: _ -> Error "More than one image" | [ (image_name, image_content) ] -> let image = ((image_name, alt), image_content) in - Babillard.make_op ~comment ~image ~lat ~lng ~subject ~tags user_id + Babillard.make_op ~comment ~image ~lat ~lng ~subject ~tags + ~categories user_id in match res with | Ok thread_id -> diff --git a/src/pp_babillard.ml b/src/pp_babillard.ml index d8cb650..fa07f03 100644 --- a/src/pp_babillard.ml +++ b/src/pp_babillard.ml @@ -96,11 +96,21 @@ let pp_post fmt t = user_id nick date id id id post_links_view () in + let pp_print_category fmt category = + Format.fprintf fmt {|%s|} category + in let pp_print_tag fmt tag = Format.fprintf fmt {|%s|} tag in let pp_print_tags fmt tags = - Format.fprintf fmt {|
%a
|} + let categories, tags = + List.partition (fun tag -> List.mem tag App.categories) tags + in + let categories = List.sort String.compare categories in + let tags = List.sort String.compare tags in + Format.fprintf fmt {|
%a%a
|} + (Format.pp_print_list ~pp_sep:Format.pp_print_space pp_print_category) + categories (Format.pp_print_list ~pp_sep:Format.pp_print_space pp_print_tag) tags in @@ -274,6 +284,25 @@ let get_markers () = in Ok markers +let pp_checkboxes () = + let pp_checkbox fmt category = + Format.fprintf fmt + {| +
+ + +
+|} + category category category category + in + Format.asprintf + {| +
+ %a +
|} + (Format.pp_print_list ~pp_sep:Format.pp_print_space pp_checkbox) + App.categories + (* RFC-3339 date-time *) let pp_date fmt date = let date = Unix.gmtime date in