add depends

src/client/network.ml

@@ -0,0 +1,214 @@
+open Types
+open Client_types
+open Util
+
+(* TODO handle no network connection/unreachable server *)
+let handle_response meth fetch read_ok on_ok =
+  let open Brr_io.Fetch in
+  let read_body response res =
+    match res with
+    | Error e -> Error (Body_err (str_of_error e))
+    | Ok jstr -> (
+      let url = Jstr.to_string (Response.url response) in
+      let status = Response.status response in
+      let status_text = Jstr.to_string (Response.status_text response) in
+      let body = Jstr.to_string jstr in
+      let r = { meth; url; status; status_text; body } in
+      match Response.ok response with
+      | true -> (
+        match read_ok r.body with
+        | Error e -> Error (Read_err (e, r))
+        | Ok v -> Ok (Either.Left v) )
+      | false -> (
+        match Json_data.Read.err r.body with
+        | Error e -> Error (Read_err (e, r))
+        | Ok v -> Ok (Either.Right v) ) )
+  in
+  let read_response res =
+    match res with
+    | Error e -> Fut.return @@ Error (Fetch_err (str_of_error e))
+    | Ok response ->
+      let body = Response.as_body response in
+      Body.text body |> Fut.map (read_body response)
+  in
+  let f res =
+    read_response res
+    |> Fut.map (function
+         | Error e ->
+           Events.send_error (Network_err e);
+           ()
+         | Ok (Either.Left v) ->
+           on_ok v;
+           ()
+         | Ok (Either.Right err) ->
+           Events.send_error (Err_response err);
+           () )
+  in
+  Fut.bind (fetch ()) f
+
+module GET = struct
+  type _ t =
+    | Catalog : thread list t
+    | Thread : int -> Thread_w_reply.t t
+    | Post : int -> post t
+    | Admin : report list t
+    | User : string -> user t
+    | Session : session t
+
+  let reader : type a. a t -> string -> (a, string) result =
+   fun t ->
+    let open Json_data.Read in
+    match t with
+    | Catalog -> catalog
+    | Thread _id -> thread_w_reply
+    | Post _id -> post
+    | Admin -> reports
+    | User _id -> user
+    | Session -> session
+
+  let url : type a. a t -> string =
+   fun t ->
+    Fmt.str "/api%s"
+      ( match t with
+      | Catalog -> "/catalog"
+      | Thread id -> Fmt.str "/thread/%d" id
+      | Post id -> Fmt.str "/post/%d" id
+      | Admin -> "/admin"
+      | User id -> Fmt.str "/user/%s" id
+      | Session -> "/session" )
+
+  let on_ok : type a. a t -> a -> unit =
+   fun req v ->
+    let open Client_types in
+    let open Events in
+    begin
+      match req with
+      | Catalog -> send_data_update (Catalog_update v)
+      | Thread _id -> send_data_update (Thread_update v)
+      | Post _id -> send_data_update (Post_update v)
+      | Admin -> send_data_update (Reports_update v)
+      | User _id -> send_data_update (User_update v)
+      | Session -> send_data_update (Session_update v)
+    end;
+    ()
+
+  let fetch t =
+    let s = url t in
+    Fmt.pr "fetch `%s`@." s;
+    let fetch () = Brr_io.Fetch.url (Jstr.v s) in
+    let _fut = handle_response GET fetch (reader t) (on_ok t) in
+    ()
+
+  let catalog () = fetch Catalog
+
+  let thread id = fetch (Thread id)
+
+  let post id = fetch (Post id)
+
+  let admin () = fetch Admin
+
+  let user id = fetch (User id)
+
+  let session () = fetch Session
+
+  let f page =
+    let open Page in
+    match page with
+    | About | Register | Login -> ()
+    | Account | Profile -> session ()
+    | Home | New_thread -> catalog ()
+    | Admin _ -> admin ()
+    | Thread v ->
+      let id = unwrap_thread_id v in
+      thread id;
+      catalog ()
+    | Delete v | Report v ->
+      let id = unwrap_post_id v in
+      post id
+    | User v ->
+      let id = unwrap_user_id v in
+      user id
+end
+
+module POST = struct
+  open Form_kind
+
+  let reader : type a. a t -> string -> (a, string) result =
+   fun t ->
+    let open Json_data.Read in
+    match t with
+    | Home -> thread_w_reply
+    | Register -> session
+    | Login -> session
+    | Logout -> session
+    | Profile -> session
+    | Account -> session
+    | Thread _ -> thread_w_reply
+    | Delete _ -> post
+    | Report _ -> reports
+    | Admin_ignore _ -> reports
+    | Admin_delete _ -> post
+    | Admin_banish _ -> user
+
+  (* TODO implement redirection mechanism *)
+  let on_ok : type a. a t -> a -> unit =
+   fun o v ->
+    let open Client_types in
+    let open Events in
+    begin
+      match o with
+      | Home ->
+        send_data_update (Thread_update v);
+        send_action (Post_form_change Form_reset);
+        let id = v.op.id in
+        Navigation.load (Thread (Loading id))
+      | Thread _ ->
+        (* server respond to successful POST with full thread *)
+        send_data_update (Thread_update v);
+        send_action (Post_form_change Form_reset);
+        let id = v.op.id in
+        Navigation.load (Thread (Loading id))
+      | Register ->
+        send_data_update (Session_update v);
+        Navigation.load Profile
+      | Login ->
+        send_data_update (Session_update v);
+        Navigation.load Home
+      | Logout -> send_data_update (Session_update v)
+      | Delete _ -> (
+        let is_op = Int.equal v.id v.parent_t_id in
+        match is_op with
+        | true -> Navigation.load Home
+        | false -> Navigation.load (Thread (Loading v.parent_t_id)) )
+      | Report _ ->
+        send_data_update (Reports_update v);
+        (* TODO need redirection to page before report here *)
+        Navigation.load Home
+      | Admin_ignore _ -> send_data_update (Reports_update v)
+      | Admin_delete _ -> ()
+      | Admin_banish _ -> ()
+      | Profile -> send_data_update (Session_update v)
+      | Account -> send_data_update (Session_update v)
+    end;
+    ()
+
+  let fetch t request =
+    let fetch () = Brr_io.Fetch.request request in
+    handle_response POST fetch (reader t) (on_ok t)
+
+  let f kind form_el csrf_token =
+    let open Brr_io in
+    let method' = Jstr.v "POST" in
+    let form = Form.of_el form_el in
+    let action = Form_kind.action kind |> Jstr.v in
+    let form_data = Form.Data.of_form form in
+    Form.Data.set form_data (Jstr.v "dream.csrf") (Jstr.v csrf_token);
+    let body = Fetch.Body.of_form_data form_data in
+    let init = Fetch.Request.init ~method' ~body () in
+    let request = Fetch.Request.v ~init action in
+    let fut = fetch kind request in
+    let _fut : unit Fut.t =
+      Fut.map (fun () -> Fmt.pr "`%s` xhr done@." (Form_kind.name kind)) fut
+    in
+    ()
+end