add depends

src/client/model.ml

@@ -0,0 +1,303 @@
+open Types
+open Client_types
+open Page
+
+type t =
+  { (* navigation state *)
+    session : session
+  ; fragment : Fragment.t
+  ; (* ui state *)
+    catalog : thread list
+  ; page : Page.t
+  ; post_form : Post_form_data.t
+  ; map_view : float * float * int
+  ; (* todo: just remove rect from here *)
+    quickview : (rect * (post_id, post) wrap) option
+  ; opened_image : post_id option
+  ; error : Client_types.error option
+  }
+
+(* TODO better session initialization/no dummy *)
+(* initialize session with dummy data and launch a GET.session request
+   catalog will be fetched on home and thread page navigation *)
+let init () =
+  Fmt.pr "model init@.";
+  let dummy_session =
+    { user_private = None; csrf_token = "dummy"; csrf_time_limit = 0.0 }
+  in
+  Network.GET.session ();
+  { session = dummy_session
+  ; fragment = Empty
+  ; catalog = Db.get_catalog ()
+  ; page = Home
+  ; post_form = Post_form_data.empty
+  ; map_view = Storage.init_map_view ()
+  ; quickview = None
+  ; opened_image = None
+  ; error = None
+  }
+
+(* TODO mv to ../util.ml *)
+let user_private_to_public u =
+  let User_private.
+        { user_id; user_nick; user_is_admin; bio; avatar_info; email = _ } =
+    u
+  in
+  { user_id; user_nick; user_is_admin; bio; avatar_info }
+
+let get_user t = Option.map user_private_to_public t.session.user_private
+
+let get_user_private t = t.session.user_private
+
+let get_user_admin t =
+  match get_user t with
+  | None -> None
+  | Some u -> ( match u.user_is_admin with false -> None | true -> Some u )
+
+let get_thread_w_reply t = match t.page with Thread t -> Some t | _ -> None
+
+(* TODO
+   - use CSS `scroll-margin-top` property *)
+(* History.push_state does not fire hashchange + scroll, so we have to do it
+   manually this relies on html `id` attribute:
+   - id attribute must exists and be unique
+     be careful to have posts only once in the html
+   - if html is invalid and multiple element have the same id.
+       it scroll to the first, which can be in a hidden page
+   This must be called after a fragment change when page is ready.
+   The DOM need to be re-rendered before we scroll_into_view.
+   So the scoll is delayed to the next JavaScript event loop cycle
+   with [Futr.to_event] *)
+let schedule_scroll_into_view =
+  let f opt =
+    match opt with
+    | None -> ()
+    | Some "" -> ()
+    | Some id -> (
+      match Util.find_html_el_by_id id with
+      | None ->
+        Fmt.failwith "scroll_into_view: html element with id `%s` not found@."
+          id
+      | Some el ->
+        Fmt.pr "scroll_into_view `%s`@." id;
+        Brr.El.scroll_into_view el )
+  in
+  fun s ->
+    let open Note in
+    (* TODO hold; need a hold_once? *)
+    let _ : Logr.t =
+      Fut.return s |> Note_brr.Futr.to_event |> E.obs
+      |> Logr.(app (const f))
+      |> Logr.create ~now:false
+    in
+    ()
+
+let load_aux find is_404 id =
+  match find id with
+  | Some v -> Ready v
+  | None -> (
+    match is_404 id with true -> Not_found id | false -> Loading id )
+
+let load_thread v =
+  let id = unwrap_thread_id v in
+  load_aux Db.find_thread_w_reply Db.thread_is_404 id
+
+let load_post v =
+  let id = unwrap_post_id v in
+  load_aux Db.find_post Db.post_is_404 id
+
+let load_user v =
+  let id = unwrap_user_id v in
+  load_aux Db.find_user Db.user_is_404 id
+
+let load_fragment page fragment =
+  let open Fragment in
+  match fragment with
+  | Empty | Top | Bottom -> fragment
+  | Id v ->
+    let id = unwrap_id v in
+    (* only consider fragment on thread pages *)
+    let v =
+      match page with
+      | Thread v -> (
+        match v with
+        | Loading _ -> Loading id
+        | Not_found _ -> Not_found id
+        | Ready v -> (
+          match List.exists (fun p -> p.id = id) v.reply_l with
+          | false -> Not_found id
+          | true -> Ready id ) )
+      | _ -> Not_found id
+    in
+    Id v
+
+let load_page = function
+  | Home -> Home
+  | New_thread -> New_thread
+  | About -> About
+  | Register -> Register
+  | Login -> Login
+  | Profile -> Profile
+  | Account -> Account
+  | Admin _ -> Admin (Ready (Db.get_reports ()))
+  | Thread id -> Thread (load_thread id)
+  | User id -> User (load_user id)
+  | Delete id -> Delete (load_post id)
+  | Report id -> Report (load_post id)
+
+let load_quickview opt =
+  opt
+  |> Option.map (fun (rect, v) ->
+         ( rect
+         , match v with Ready _ | Not_found _ -> v | Loading _ -> load_post v ) )
+
+let load_model t =
+  let session = Db.get_session () in
+  let catalog = Db.get_catalog () in
+  let page = load_page t.page in
+  let fragment = load_fragment page t.fragment in
+  let () =
+    match
+      (Fragment.get_ready_value t.fragment, Fragment.get_ready_value fragment)
+    with
+    | _, None | Some _, Some _ -> ()
+    | None, Some s -> schedule_scroll_into_view s
+  in
+  let quickview = load_quickview t.quickview in
+  { t with session; catalog; page; fragment; quickview }
+
+let do_post_form_action form_action post_form =
+  let open Post_form_data in
+  match form_action with
+  | Form_open -> { post_form with is_open = true }
+  | Form_close -> { post_form with is_open = false }
+  | Form_insert_quote id ->
+    let comment =
+      let s = post_form.comment in
+      (* insert quote on newline *)
+      match String.ends_with ~suffix:"\n" s || String.length s = 0 with
+      | true -> Fmt.str "%s>>%d " s id
+      | false -> Fmt.str "%s@\n>>%d " s id
+    in
+    { post_form with comment }
+  | Form_comment comment -> { post_form with comment }
+  | Form_file file -> { post_form with file }
+  | Form_alt alt -> { post_form with alt }
+  | Form_subject subject -> { post_form with subject }
+  | Form_latlng latlng -> { post_form with latlng }
+  | Form_reset -> Post_form_data.empty
+
+let do_map_action a t =
+  let set_latlng t opt =
+    let post_form = do_post_form_action (Form_latlng opt) t.post_form in
+    { t with post_form }
+  in
+  match a with
+  | Move_end map_view | Zoom_end map_view ->
+    Storage.set_map_view map_view;
+    { t with map_view }
+  | Geoloc_start -> t
+  | Geoloc_pos (_pos : Brr_io.Geolocation.Pos.t) -> t
+  | Geoloc_err (_err : Brr_io.Geolocation.Error.t) -> t
+  | Click_latlng latlng -> (
+    match t.page with New_thread -> set_latlng t (Some latlng) | _ -> t )
+  | Click_marker _thread_id -> set_latlng t None
+
+let do_action : Client_types.action -> t -> t =
+ fun action t ->
+  Fmt.pr {|do action: "%a"@.|} pp_action action;
+  match action with
+  | Navigation_event (page_opt, frag) ->
+    let page =
+      match page_opt with
+      | None -> t.page
+      | Some loading_page ->
+        Network.GET.f loading_page;
+        load_page loading_page
+    in
+    let fragment = load_fragment page frag in
+    let () =
+      match Fragment.get_ready_value fragment with
+      | None -> ()
+      | Some s -> schedule_scroll_into_view s
+    in
+    (* when we click the id to go to post blur event is not triggered,
+       so we clear quick view on hashchange too *)
+    let quickview = None in
+    let post_form =
+      match page_opt with
+      | None -> t.post_form
+      | Some _ -> { t.post_form with is_open = false; latlng = None }
+    in
+    { t with page; fragment; quickview; post_form }
+  | Post_form_change form_action -> (
+    (* TODO error message/feedback; use Validate_str *)
+    (* ignore reply form action if not logged in *)
+    match get_user t with
+    | None -> t
+    | Some _ ->
+      let post_form = do_post_form_action form_action t.post_form in
+      { t with post_form } )
+  | Map_input map_action -> do_map_action map_action t
+  | Submit_event (Form_kind.W kind, form) ->
+    let session = Db.get_session () in
+    Network.POST.f kind form session.csrf_token;
+    let t =
+      match kind with
+      | Logout ->
+        (* todo reload window? Brr.Window.reload Brr.G.window; *)
+        (* clear all state on logout
+           we do it here so we can logout even if offline *)
+        Db.clear ();
+        Storage.clear ();
+        init ()
+      | _ -> t
+    in
+    t
+  | Quickview_change opt ->
+    let quickview =
+      opt |> Option.map (fun (rect, v) -> (rect, Loading v)) |> load_quickview
+    in
+    begin
+      match quickview with
+      | Some (_, Loading post_id) -> Network.GET.post post_id
+      | _ -> ()
+    end;
+    { t with quickview }
+  | Image_click id -> (
+    match t.opened_image with
+    | Some current_image_id when Int.equal current_image_id id ->
+      { t with opened_image = None }
+    | Some _ | None -> { t with opened_image = Some id } )
+  | Clear_error -> { t with error = None }
+
+let do_data_update : Client_types.data_update -> t -> t =
+ fun action t ->
+  Fmt.pr {|do data update: "%a"@.|} pp_data_update action;
+  begin
+    match action with
+    | Post_update v -> Db.add_post v
+    | Thread_update thread_w_reply ->
+      Db.update_thread_w_reply (Some thread_w_reply)
+    | Catalog_update l -> Db.update_catalog l
+    | User_update u -> Db.update_user (Some u)
+    | Reports_update reports -> Db.update_reports reports
+    | Session_update session -> Db.update_session session
+  end;
+  load_model t
+
+let do_error : Client_types.error -> t -> t =
+ fun e t ->
+  Fmt.pr {|do error: "%a"@.|} pp_error e;
+  let t = { t with error = Some e } in
+  let () =
+    match e with
+    | Network_err _ -> ()
+    | Err_response e -> (
+      match e with
+      | Not_found_post id -> Db.add_post_404 id
+      | Not_found_thread id -> Db.add_thread_404 id
+      | Not_found_user user_id -> Db.add_user_404 user_id
+      | _ -> () )
+  in
+  load_model t