add depends

src/json_data.ml

@@ -0,0 +1,364 @@
+open Data_encoding
+open Types
+
+type nonrec 'a result = ('a, string) result
+
+let internal_err =
+  let open Err in
+  union
+    [ (let title = "No_msg" in
+       case ~title (Tag 0)
+         (obj1 (req title unit))
+         (function No_msg -> Some () | _ -> None)
+         (fun () -> No_msg) )
+    ; (let title = "Db" in
+       case ~title (Tag 1)
+         (obj1 (req title string))
+         (function Db s -> Some s | _ -> None)
+         (fun s -> Db s) )
+    ; (let title = "Db_not_found" in
+       case ~title (Tag 2)
+         (obj1 (req title string))
+         (function Db_not_found s -> Some s | _ -> None)
+         (fun s -> Db_not_found s) )
+    ; (let title = "Bos" in
+       case ~title (Tag 3)
+         (obj1 (req title string))
+         (function Bos s -> Some s | _ -> None)
+         (fun s -> Bos s) )
+    ; (let title = "Conan" in
+       case ~title (Tag 4)
+         (obj1 (req title string))
+         (function Conan s -> Some s | _ -> None)
+         (fun s -> Conan s) )
+    ]
+
+let err =
+  let open Err in
+  union
+    [ (let title = "Internal" in
+       case ~title (Tag 0) internal_err
+         (function Internal o -> Some o | _ -> None)
+         (fun o -> Internal o) )
+    ; (let title = "Bad_form" in
+       case ~title (Tag 1)
+         (obj1 (req title unit))
+         (function Bad_form -> Some () | _ -> None)
+         (fun () -> Bad_form) )
+    ; (let title = "Bad_form_suspicious" in
+       case ~title (Tag 2)
+         (obj1 (req title unit))
+         (function Bad_form_suspicious -> Some () | _ -> None)
+         (fun () -> Bad_form_suspicious) )
+    ; (let title = "Unauthorized" in
+       case ~title (Tag 3)
+         (obj1 (req title unit))
+         (function Unauthorized -> Some () | _ -> None)
+         (fun () -> Unauthorized) )
+    ; (let title = "Unauthorized_login" in
+       case ~title (Tag 4)
+         (obj1 (req title string))
+         (function Unauthorized_login s -> Some s | _ -> None)
+         (fun s -> Unauthorized_login s) )
+    ; (let title = "Forbidden" in
+       case ~title (Tag 5)
+         (obj1 (req title unit))
+         (function Forbidden -> Some () | _ -> None)
+         (fun () -> Forbidden) )
+    ; (let title = "Not_found" in
+       case ~title (Tag 6)
+         (obj1 (req title unit))
+         (function Not_found -> Some () | _ -> None)
+         (fun () -> Not_found) )
+    ; (let title = "Not_found_thread" in
+       case ~title (Tag 7)
+         (obj1 (req title int31))
+         (function Not_found_thread s -> Some s | _ -> None)
+         (fun s -> Not_found_thread s) )
+    ; (let title = "Not_found_post" in
+       case ~title (Tag 8)
+         (obj1 (req title int31))
+         (function Not_found_post s -> Some s | _ -> None)
+         (fun s -> Not_found_post s) )
+    ; (let title = "Not_found_user" in
+       case ~title (Tag 9)
+         (obj1 (req title string))
+         (function Not_found_user s -> Some s | _ -> None)
+         (fun s -> Not_found_user s) )
+    ; (let title = "Not_found_image" in
+       case ~title (Tag 10)
+         (obj1 (req title int31))
+         (function Not_found_image s -> Some s | _ -> None)
+         (fun s -> Not_found_image s) )
+    ; (let title = "Unprocessable" in
+       case ~title (Tag 11)
+         (obj1 (req title string))
+         (function Unprocessable s -> Some s | _ -> None)
+         (fun s -> Unprocessable s) )
+    ]
+
+let img_info =
+  conv
+    (fun { md5; mime; w; h; thumb_w; thumb_h; name; alt } ->
+      (md5, mime, w, h, thumb_w, thumb_h, name, alt) )
+    (fun (md5, mime, w, h, thumb_w, thumb_h, name, alt) ->
+      { md5; mime; w; h; thumb_w; thumb_h; name; alt } )
+    (obj8 (req "md5" string) (req "mime" string) (req "w" int31) (req "h" int31)
+       (req "thumb_w" int31) (req "thumb_h" int31) (req "name" string)
+       (req "alt" string) )
+
+let post =
+  conv_with_guard
+    (fun { id
+         ; parent_t_id
+         ; date
+         ; poster_id
+         ; poster_nick
+         ; comment
+         ; image_info
+         ; backlinks
+         } ->
+      ( id
+      , parent_t_id
+      , date
+      , poster_id
+      , poster_nick
+      , Comment.to_string comment
+      , image_info
+      , backlinks ) )
+    (fun ( id
+         , parent_t_id
+         , date
+         , poster_id
+         , poster_nick
+         , comment_str
+         , image_info
+         , backlinks ) ->
+      let open Syntax in
+      let+ comment = Comment.of_string comment_str in
+      { id
+      ; parent_t_id
+      ; date
+      ; poster_id
+      ; poster_nick
+      ; comment
+      ; image_info
+      ; backlinks
+      } )
+    (obj8 (req "id" int31) (req "parent_t_id" int31) (req "date" float)
+       (req "poster_id" string) (req "poster_nick" string)
+       (req "comment" string)
+       (req "image_info" (option img_info))
+       (req "replies" (list int31)) )
+
+let bump_status =
+  union
+    [ case ~title:"Dead" (Tag 0)
+        (obj1 (req "dead" empty))
+        (function Dead -> Some () | _ -> None)
+        (fun () -> Dead)
+    ; case ~title:"Locked" (Tag 1)
+        (obj1 (req "locked" int31))
+        (function Locked c -> Some c | _ -> None)
+        (fun c -> Locked c)
+    ; case ~title:"Alive" (Tag 2)
+        (obj1 (req "alive" int31))
+        (function Alive c -> Some c | _ -> None)
+        (fun c -> Alive c)
+    ]
+
+let thread =
+  conv
+    (fun { op; subject; lat; lng; bump_status; reply_count } ->
+      (op, subject, lat, lng, bump_status, reply_count) )
+    (fun (op, subject, lat, lng, bump_status, reply_count) ->
+      { op; subject; lat; lng; bump_status; reply_count } )
+    (obj6 (req "op" post) (req "subject" string) (req "lat" float)
+       (req "lng" float)
+       (req "bump_status" bump_status)
+       (req "reply_count" int31) )
+
+let thread_w_reply =
+  let open Thread_w_reply in
+  conv
+    (fun { op; subject; lat; lng; bump_status; reply_count; reply_l } ->
+      (op, subject, lat, lng, bump_status, reply_count, reply_l) )
+    (fun (op, subject, lat, lng, bump_status, reply_count, reply_l) ->
+      { op; subject; lat; lng; bump_status; reply_count; reply_l } )
+    (obj7 (req "op" post) (req "subject" string) (req "lat" float)
+       (req "lng" float)
+       (req "bump_status" bump_status)
+       (req "reply_count" int31)
+       (req "reply_l" (list post)) )
+
+let catalog : thread list encoding =
+  conv (fun l -> l) (fun l -> l) (obj1 (req "catalog" (list thread)))
+
+let report =
+  conv
+    (fun { report_id
+         ; report_date
+         ; reported_post
+         ; reporter_user_id
+         ; reporter_nick
+         ; reason
+         } ->
+      ( report_id
+      , report_date
+      , reported_post
+      , reporter_user_id
+      , reporter_nick
+      , reason ) )
+    (fun ( report_id
+         , report_date
+         , reported_post
+         , reporter_user_id
+         , reporter_nick
+         , reason ) ->
+      { report_id
+      ; report_date
+      ; reported_post
+      ; reporter_user_id
+      ; reporter_nick
+      ; reason
+      } )
+    (obj6 (req "report_id" string) (req "report_date" float)
+       (req "reported_post" post)
+       (req "reporter_user_id" string)
+       (req "reporter_nick" string)
+       (req "reason" string) )
+
+let reports : report list encoding =
+  conv (fun o -> o) (fun o -> o) (obj1 (req "reports" (list report)))
+
+let user =
+  conv
+    (fun { user_id; user_nick; user_is_admin; bio; avatar_info } ->
+      (user_id, user_nick, user_is_admin, bio, avatar_info) )
+    (fun (user_id, user_nick, user_is_admin, bio, avatar_info) ->
+      { user_id; user_nick; user_is_admin; bio; avatar_info } )
+    (obj5 (req "user_id" string) (req "user_nick" string)
+       (req "user_is_admin" bool) (req "bio" string)
+       (req "avatar_info" (option img_info)) )
+
+let user_private =
+  let open User_private in
+  conv
+    (fun { user_id; user_nick; user_is_admin; bio; avatar_info; email } ->
+      (user_id, user_nick, user_is_admin, bio, avatar_info, email) )
+    (fun (user_id, user_nick, user_is_admin, bio, avatar_info, email) ->
+      { user_id; user_nick; user_is_admin; bio; avatar_info; email } )
+    (obj6 (req "user_id" string) (req "user_nick" string)
+       (req "user_is_admin" bool) (req "bio" string)
+       (req "avatar_info" (option img_info))
+       (req "email" string) )
+
+let geojson_marker : (float * float * post_id) encoding =
+  let geometry =
+    conv
+      (* !! geojson coordinates are lng first then lat *)
+      (fun (lat, lng) -> ((), [ lng; lat ]) )
+      (fun ((), coordinates) ->
+        match coordinates with [ lng; lat ] -> (lat, lng) | _ -> assert false )
+      (obj2
+         (req "type" (constant "Point"))
+         (req "coordinates" (Fixed.list 2 float)) )
+  in
+  let properties = conv (fun id -> id) (fun id -> id) (obj1 (req "id" int31)) in
+  conv
+    (fun (lat, lng, id) -> ((), (lat, lng), id))
+    (fun ((), (lat, lng), id) -> (lat, lng, id))
+    (obj3
+       (req "type" (constant "Feature"))
+       (req "geometry" geometry)
+       (req "properties" properties) )
+
+let geojson_markers : (float * float * post_id) list encoding =
+  conv
+    (fun l -> ((), l))
+    (fun ((), l) -> l)
+    (obj2
+       (req "type" (constant "FeatureCollection"))
+       (req "features" (list geojson_marker)) )
+
+let session : session encoding =
+  conv
+    (fun { user_private; csrf_token; csrf_time_limit } ->
+      (user_private, csrf_token, csrf_time_limit) )
+    (fun (user_private, csrf_token, csrf_time_limit) ->
+      { user_private; csrf_token; csrf_time_limit } )
+    (obj3
+       (req "user_private" (option user_private))
+       (req "csrf_token" string)
+       (req "csrf_time_limit" float) )
+
+let unit : unit encoding =
+  conv (fun o -> o) (fun o -> o) (obj1 (req "unit" unit))
+
+let to_string enc =
+  let json = Data_encoding.Json.construct enc in
+  fun v -> Data_encoding.Json.to_string (json v)
+
+let of_string enc =
+  let destruct = Data_encoding.Json.destruct enc in
+  fun s -> Data_encoding.Json.from_string s |> Result.map destruct
+
+module Read = struct
+  let err = of_string err
+
+  let session = of_string session
+
+  let img_info = of_string img_info
+
+  let post = of_string post
+
+  let bump_status = of_string bump_status
+
+  let thread = of_string thread
+
+  let thread_w_reply = of_string thread_w_reply
+
+  let catalog = of_string catalog
+
+  let reports = of_string reports
+
+  let user = of_string user
+
+  let user_private = of_string user_private
+
+  let geojson_marker = of_string geojson_marker
+
+  let geojson_markers = of_string geojson_markers
+
+  let unit = of_string unit
+end
+
+module Write = struct
+  let err = to_string err
+
+  let session = to_string session
+
+  let img_info = to_string img_info
+
+  let post = to_string post
+
+  let bump_status = to_string bump_status
+
+  let thread = to_string thread
+
+  let thread_w_reply = to_string thread_w_reply
+
+  let catalog = to_string catalog
+
+  let reports = to_string reports
+
+  let user = to_string user
+
+  let user_private = to_string user_private
+
+  let geojson_marker = to_string geojson_marker
+
+  let geojson_markers = to_string geojson_markers
+
+  let unit = to_string unit
+end