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 ; geolocation : geolocation_state ; (* todo: just remove rect from here *) quickview : (rect * (post_id, post) wrap) option ; opened_image : Img_info.t 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 () ; geolocation = Geo_off ; 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 } | Click_latlng latlng -> ( match t.page with New_thread -> set_latlng t (Some latlng) | _ -> t ) | Click_marker _thread_id -> set_latlng t None | Geolocation geolocation -> { t with geolocation } 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_change opened_image -> { t with opened_image } | 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