change post type

src/babillard.ml

@@ -14,19 +14,11 @@ let board_of_int = function
   | 1 -> Babillard
   | _ -> raise (Invalid_argument "board_of_int")
 
-type op =
+type thread_data =
-  { id : string
+  { board : board
-  ; board : board
-  ; date : int
-  ; nick : string
   ; subject : string
-  ; comment : string
+  ; lng : float
-  ; image : string * string * string
+  ; lat : float
-  ; tags : string list
-  ; longitude : float
-  ; latitude : float
-  ; replies : string list
-  ; citations : string list
   }
 
 type reply =
@@ -42,22 +34,25 @@ type reply =
   }
 
 type post =
-  | Op of op
+  | Op of thread_data * reply
   | Reply of reply
 
-(* ('a option, string) result *)
 let ( let** ) o f =
   match o with
   | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
   | Ok None -> Error "db error"
   | Ok (Some x) -> f x
 
-(* ('a, string) result *)
 let ( let* ) o f =
   match o with
   | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
   | Ok x -> f x
 
+let ( let+ ) o f =
+  match o with
+  | Error e -> Error (Format.sprintf "%s" e)
+  | Ok x -> f x
+
 module Q = struct
   let create_post_user_table =
     Caqti_request.exec Caqti_type.unit
@@ -492,37 +487,26 @@ let view_thread thread_id =
       Ok view_posts )
 
 let upload_post post =
-  let post_id, parent_id, date, nick, comment, image, tags, citations, op_data =
+  let thread_data, reply =
     match post with
-    | Op
+    | Op (thread_data, reply) -> (Some thread_data, reply)
-        { id
+    | Reply reply -> (None, reply)
-        ; board
-        ; date
-        ; nick
-        ; subject
-        ; comment
-        ; image
-        ; tags
-        ; longitude
-        ; latitude
-        ; replies = _replies
-        ; citations
-        } ->
-      let op_data = Some (board, subject, longitude, latitude) in
-      (id, id, date, nick, comment, Some image, tags, citations, op_data)
-    | Reply
-        { id
-        ; parent_id
-        ; date
-        ; nick
-        ; comment
-        ; image
-        ; tags
-        ; replies = _replies
-        ; citations
-        } ->
-      (id, parent_id, date, nick, comment, image, tags, citations, None)
   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)
+  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
@@ -554,19 +538,28 @@ let upload_post post =
     | Some _ -> assert false
     | None -> Ok ()
   in
-  match op_data with
+  match thread_data with
   | None -> Ok post_id
-  | Some (board, subject, lng, lat) ->
+  | Some thread_data -> (
-    let* _res_board =
+    match thread_data with
-      Db.exec Q.upload_thread_board (post_id, int_of_board board)
+    | { board; subject; lng; lat } ->
-    in
+      let* _res_board =
-    let* _res_gps = Db.exec Q.upload_post_gps (post_id, lat, lng) in
+        Db.exec Q.upload_thread_board (post_id, int_of_board board)
-    let* _res_subject = Db.exec Q.upload_post_subject (post_id, subject) in
+      in
-    Ok post_id
+      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 )
 
-let make_reply ~comment ?image ~tags ~parent_id nick =
+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
   if Option.is_none (Uuidm.of_string parent_id) then
     Error "invalid thread id"
   else if String.length comment > 10000 then
@@ -580,66 +573,48 @@ let make_reply ~comment ?image ~tags ~parent_id nick =
       else
         (* TODO latlng validation? *)
         let tag_list = Str.split (Str.regexp " +") tags in
-        let id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
         let date = int_of_float (Unix.time ()) in
         let comment, citations = parse_comment comment in
         let reply =
-          Reply
+          { id
-            { id
+          ; parent_id
-            ; parent_id
+          ; date
-            ; date
+          ; nick
-            ; nick
+          ; comment
-            ; comment
+          ; image
-            ; image
+          ; tags = tag_list
-            ; tags = tag_list
+          ; replies = []
-            ; replies = []
+          ; citations
-            ; citations
+          }
-            }
         in
-        upload_post reply
+        Ok reply
 
-let make_op ~comment ~image ~tags ~subject ~lat ~lng ~board nick =
+let build_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick =
-  let comment = Dream.html_escape comment in
-  let tags = Dream.html_escape tags in
   let subject = Dream.html_escape subject in
-  if String.length comment > 10000 then
+  (* TODO latlng validation? *)
-    Error "invalid comment"
+  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
-    match parse_image (Some image) with
+    let thread_data = { board; subject; lng; lat } in
-    | Error e -> Error e
+    let+ reply =
-    | Ok None -> assert false
+      match image with
-    | Ok (Some image) ->
+      | Some image -> build_reply ~comment ~image ~tags nick
-      if String.length tags > 1000 then
+      | None -> build_reply ~comment ~tags nick
-        Error "invalid tags"
+    in
-      else
+    let op = Op (thread_data, reply) in
-        (* TODO latlng validation? *)
+    Ok op
-        let is_valid_latlng = true in
+
-        if not is_valid_latlng then
+let make_reply ~comment ?image ~tags ~parent_id nick =
-          Error "Invalid coordinate"
+  let+ reply = build_reply ~comment ?image ~tags ~parent_id nick in
-        else if String.length subject > 600 then
+  let post = Reply reply in
-          Error "Invalid subject"
+  upload_post post
-        else
+
-          let tag_list = Str.split (Str.regexp " +") tags in
+let make_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick =
-          let id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
+  let+ op = build_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick in
-          let date = int_of_float (Unix.time ()) in
+  upload_post op
-          let comment, citations = parse_comment comment in
-          let op =
-            Op
-              { id
-              ; board
-              ; date
-              ; nick
-              ; subject
-              ; comment
-              ; image
-              ; tags = tag_list
-              ; longitude = lng
-              ; latitude = lat
-              ; replies = []
-              ; citations
-              }
-          in
-          upload_post op
 
 let get_markers board =
   let* thread_id_list =
@@ -681,6 +656,6 @@ let get_markers board =
   in
   Ok markers
 
-let get_post_image post_id =
+let get_post_image_content post_id =
   let** content = Db.find_opt Q.get_post_image_content post_id in
   Ok content

src/permap.ml

@@ -143,7 +143,7 @@ let avatar_image request =
 
 let post_image request =
   let post_id = Dream.param "post_id" request in
-  let image = Babillard.get_post_image post_id in
+  let image = Babillard.get_post_image_content post_id in
   match image with
   | Ok image -> Dream.respond ~headers:[ ("Content-Type", "image") ] image
   | Error _ -> Dream.empty `Not_Found