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 {|