add categories

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"

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

src/babillard_page.eml.html

@@ -39,6 +39,7 @@ let f request =
           <textarea name="thread-comment" type="text" class="form-control" id="thread-comment" aria-labelledby="thread-comment-label"></textarea>
           <br />
           <label for="tags" id="tags-label" class="form-label">Tags</label>
+          <%s! Pp_babillard.pp_checkboxes () %>
           <input name="tags" type="text" class="form-control" id="tags" aria-labelledby="tags-label"></input>
           <br />
           <label for="file" id="file-label" class="form-label">Picture:</label>

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;
 }

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

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 {|<span class="category tag">%s</span>|} category
+  in
   let pp_print_tag fmt tag =
     Format.fprintf fmt {|<span class="tag">%s</span>|} tag
   in
   let pp_print_tags fmt tags =
-    Format.fprintf fmt {|<div class="tags">%a</div>|}
+    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 {|<div class="tags">%a%a</div>|}
+      (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
+      {|
+<div class="form-check col">
+    <input name="category" id="category-%s" type="checkbox" class"form-check-input" value="%s">
+    <label class="form-check-label" for="category-%s">%s</label>
+</div>
+|}
+      category category category category
+  in
+  Format.asprintf
+    {| 
+<div class="row">
+   %a
+</div>|}
+    (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