geochan/src/client/network.ml

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