add depends

src/client/client_types.ml

@@ -0,0 +1,207 @@
+open Types
+
+type ('a, 'b) wrap = ('a, 'b) Page.wrap
+
+module Fragment = struct
+  type t =
+    | Empty
+    | Top
+    | Bottom
+    | Id of (int, int) wrap
+
+  let unwrap_id = function Page.Loading v | Not_found v -> v | Ready v -> v
+
+  let to_string = function
+    | Empty -> ""
+    | Top -> "top"
+    | Bottom -> "bottom"
+    | Id v ->
+      let id = unwrap_id v in
+      string_of_int id
+
+  let of_string s =
+    match s with
+    | "" -> Ok Empty
+    | "top" -> Ok Top
+    | "bottom" -> Ok Bottom
+    | s -> (
+      match int_of_string_opt s with
+      | None -> Fmt.error "invalid fragment format `%s`" s
+      | Some id -> Ok (Id (Loading id)) )
+
+  let get_ready_value v =
+    match v with
+    | Empty | Top | Bottom -> Some (to_string v)
+    | Id (Loading _) | Id (Not_found _) -> None
+    | Id (Ready _) -> Some (to_string v)
+end
+
+module Post_form_data = struct
+  (* TODO (?) have a more genral thing for every form *)
+  (* store input data of reply and new thread form
+     both form share the same data:
+       text in comment on reply form will show up on new thread form too
+     wraped in module because record field conflict *)
+  type t =
+    { subject : string
+    ; comment : string
+    ; file : string option
+    ; alt : string option
+    ; is_open : bool
+    ; latlng : (float * float) option
+    }
+
+  let empty =
+    { subject = ""
+    ; comment = ""
+    ; file = None
+    ; alt = None
+    ; is_open = false
+    ; latlng = None
+    }
+end
+
+type meth =
+  | GET
+  | POST
+
+type response =
+  { meth : meth
+  ; url : string
+  ; status : int
+  ; status_text : string
+  ; body : string
+  }
+
+(* https://developer.mozilla.org/en-US/docs/Web/API/Window/fetch#exceptions *)
+(* https://developer.mozilla.org/en-US/docs/Web/API/Response/text#exceptions *)
+type network_error =
+  | Fetch_err of string
+  | Body_err of string
+  | Read_err of string * response
+
+(* error type for interactions with server *)
+type error =
+  | Network_err of network_error
+  | Err_response of Err.t
+
+type map_action =
+  | Move_end of (float * float * int)
+  | Zoom_end of (float * float * int)
+  | Click_latlng of (float * float)
+  | Click_marker of Types.post_id
+  | Geoloc_start
+  | Geoloc_pos of Brr_io.Geolocation.Pos.t
+  | Geoloc_err of Brr_io.Geolocation.Error.t
+
+type form_action =
+  | Form_open
+  | Form_close
+  | Form_insert_quote of post_id
+  | Form_comment of string
+  | Form_file of string option
+  | Form_alt of string option
+  | Form_subject of string
+  | Form_latlng of (float * float) option
+  | Form_reset
+
+(* post-quote's (x,y,w,h)
+   needed to compute quickview position *)
+type rect = float * float * float * float
+
+type action =
+  | Navigation_event of (Page.t option * Fragment.t)
+  | Post_form_change of form_action
+  | Map_input of map_action
+  | Submit_event of (Form_kind.wrapped * Brr.El.t)
+  | Quickview_change of (rect * post_id) option
+  | Image_click of post_id
+  | Clear_error
+
+type data_update =
+  | Post_update of post
+  | Thread_update of Thread_w_reply.t
+  | Catalog_update of thread list
+  | User_update of user
+  | Reports_update of report list
+  | Session_update of session
+
+(* printer/util *)
+
+let pp_meth fmt = function GET -> Fmt.pf fmt "GET" | POST -> Fmt.pf fmt "POST"
+
+let pp_response fmt r =
+  Fmt.pf fmt
+    {|{ meth: `%a`; url: `%s`; status code: `%d`; status text: `%s`; body:`%s`}@.|}
+    pp_meth r.meth r.url r.status r.status_text r.body
+
+let pp_network_error fmt err =
+  match err with
+  | Fetch_err s -> Fmt.pf fmt "network fetch error `%s`" s
+  | Body_err s -> Fmt.pf fmt "network read body error `%s`" s
+  | Read_err (s, r) ->
+    Fmt.pf fmt "network read error `%s` on response `%a`" s pp_response r
+
+let pp_error fmt err =
+  match err with
+  | Network_err e -> pp_network_error fmt e
+  | Err_response e -> Err.pp fmt e
+
+let pp_map_action fmt a =
+  Fmt.pf fmt "map ";
+  match a with
+  | Move_end (lat, lng, zoom) ->
+    Fmt.pf fmt "move end `(%f, %f, %d)`" lat lng zoom
+  | Zoom_end (lat, lng, zoom) ->
+    Fmt.pf fmt "zoom end `(%f, %f, %d)`" lat lng zoom
+  | Click_latlng (lat, lng) -> Fmt.pf fmt "click latlng `(%f, %f)`" lat lng
+  | Click_marker post_id -> Fmt.pf fmt "click marker `%d`" post_id
+  | Geoloc_start -> Fmt.pf fmt "geoloc start"
+  | Geoloc_pos pos ->
+    let open Brr_io.Geolocation.Pos in
+    Fmt.pf fmt "geoloc pos `(%f, %f)`" (latitude pos) (longitude pos)
+  | Geoloc_err err ->
+    let open Brr_io.Geolocation.Error in
+    Fmt.pf fmt "geoloc error, code `%d` message `%s`" (code err)
+      (message err |> Jstr.to_string)
+
+let pp_form_action fmt a =
+  Fmt.pf fmt "form ";
+  match a with
+  | Form_open -> Fmt.pf fmt "open"
+  | Form_close -> Fmt.pf fmt "close"
+  | Form_insert_quote post_id -> Fmt.pf fmt "insert quote `%d`" post_id
+  | Form_comment s -> Fmt.pf fmt "comment `%s`" s
+  | Form_file o -> Fmt.pf fmt "file `%s`" (Option.value ~default:"none" o)
+  | Form_alt o -> Fmt.pf fmt "alt `%s`" (Option.value ~default:"none" o)
+  | Form_subject s -> Fmt.pf fmt "subject `%s`" s
+  | Form_latlng o -> (
+    match o with
+    | None -> Fmt.pf fmt "latlng `none`"
+    | Some (lat, lng) -> Fmt.pf fmt "latlng `(%f, %f)`" lat lng )
+  | Form_reset -> Fmt.pf fmt "reset"
+
+let pp_action fmt = function
+  | Navigation_event (opt, frag) ->
+    let s =
+      match opt with
+      | None -> "none"
+      | Some p -> p |> Page.to_uri |> Brr.Uri.to_jstr |> Jstr.to_string
+    in
+    Fmt.pf fmt "navigation event `(%s, %s)`" s (Fragment.to_string frag)
+  | Post_form_change a -> Fmt.pf fmt "post form change `%a`" pp_form_action a
+  | Map_input a -> Fmt.pf fmt "map input `%a`" pp_map_action a
+  | Submit_event (W kind, _el) ->
+    Fmt.pf fmt "submit event `%s`" (Form_kind.name kind)
+  | Quickview_change _opt -> Fmt.pf fmt "quickview change"
+  | Image_click post_id -> Fmt.pf fmt "image click `%d`" post_id
+  | Clear_error -> Fmt.pf fmt "clear error"
+
+let pp_data_update fmt a =
+  match a with
+  | Post_update v -> Fmt.pf fmt "post update `%d`" v.id
+  | Thread_update v -> Fmt.pf fmt "thread update `%d`" v.op.id
+  | Catalog_update _l -> Fmt.pf fmt "catalog update"
+  | User_update u -> Fmt.pf fmt "user update `%s`" u.user_id
+  | Reports_update _l -> Fmt.pf fmt "report update"
+  | Session_update _session -> Fmt.pf fmt "session update"

src/client/db.ml

@@ -0,0 +1,129 @@
+open Types
+
+let session : session option ref = ref None
+
+let update_session (v : session) =
+  session := Some v;
+  ()
+
+let get_session () =
+  match !session with
+  | None -> Fmt.failwith "called get_session with uninitialized session"
+  | Some v -> v
+
+let post_db : (post_id, post) Hashtbl.t = Hashtbl.create 0x1000
+
+let add_post (v : post) =
+  Hashtbl.replace post_db v.id v;
+  ()
+
+let find_post id =
+  match Hashtbl.find_opt post_db id with None -> None | Some v -> Some v
+
+let post_db_404 : (post_id, unit) Hashtbl.t = Hashtbl.create 0x100
+
+let post_is_404 id = Hashtbl.mem post_db_404 id
+
+let thread_is_404 id = Hashtbl.mem post_db_404 id
+
+let user_db_404 : (user_id, unit) Hashtbl.t = Hashtbl.create 0x100
+
+let user_is_404 id = Hashtbl.mem user_db_404 id
+
+let catalog : thread list ref = ref []
+
+let update_catalog (v : thread list) =
+  catalog := v;
+  ()
+
+let get_catalog () = !catalog
+
+let thread_w_reply : Thread_w_reply.t option ref = ref None
+
+let update_thread_w_reply (o : Thread_w_reply.t option) =
+  Hashtbl.clear post_db;
+  thread_w_reply := o;
+  Option.iter (fun v -> List.iter add_post v.Thread_w_reply.reply_l) o;
+  ()
+
+let find_thread_w_reply id =
+  match !thread_w_reply with
+  | None -> None
+  | Some v -> ( match v.op.id = id with false -> None | true -> Some v )
+
+let reports : report list ref = ref []
+
+let update_reports (v : report list) =
+  reports := v;
+  ()
+
+let get_reports () = !reports
+
+let user : user option ref = ref None
+
+let update_user (v : user option) =
+  user := v;
+  ()
+
+let find_user id =
+  match !user with
+  | None -> None
+  | Some v -> (
+    match String.equal v.user_id id with false -> None | true -> Some v )
+
+let clear () =
+  session := None;
+  update_catalog [];
+  update_thread_w_reply None;
+  update_reports [];
+  Hashtbl.clear post_db;
+  Hashtbl.clear post_db_404;
+  update_user None;
+  ()
+
+let add_post_404 id =
+  (* in case post is a thread we have to remove id + potential reply_l *)
+  let to_delete_l =
+    match find_thread_w_reply id with
+    | Some v -> List.map (fun p -> p.id) v.reply_l
+    | None -> [ id ]
+  in
+  let filter get_id l =
+    (* O(n^2) ~~ *)
+    List.filter (fun v -> not @@ List.mem (get_id v) to_delete_l) l
+  in
+
+  update_catalog (get_catalog () |> filter (fun v -> v.op.id));
+
+  update_thread_w_reply
+    ( match find_thread_w_reply id with
+    | Some _ -> None
+    | None -> (
+      match !thread_w_reply with
+      | None -> None
+      | Some v ->
+        let v = { v with reply_l = filter (fun v -> v.id) v.reply_l } in
+        Some v ) );
+
+  update_reports (!reports |> filter (fun r -> r.reported_post.id));
+
+  Hashtbl.remove post_db id;
+  Hashtbl.add post_db_404 id ();
+  ()
+
+let add_thread_404 = add_post_404
+
+let add_user_404 id =
+  let session = get_session () in
+  let session =
+    match session.user_private with
+    | Some u when String.equal u.user_id id ->
+      (* dead session here *)
+      { session with user_private = None }
+    | _ -> session
+  in
+  update_session session;
+  begin
+    match find_user id with Some _ -> update_user None | None -> ()
+  end;
+  ()

src/client/dune

@@ -0,0 +1,17 @@
+(executable
+ (name main)
+ (modules :standard)
+ (libraries
+  config_impl ; virtual
+  shared
+  comment
+  leaflet
+  note
+  note.brr
+  brr
+  fmt
+  unix
+  prelude)
+ (modes js)
+ (flags
+  (:standard -open Prelude)))

src/client/events.ml

@@ -0,0 +1,8 @@
+open Note
+open Client_types
+
+let (actions : action event), send_action = E.create ()
+
+let (data_updates : data_update event), send_data_update = E.create ()
+
+let (errors : error event), send_error = E.create ()

src/client/form_kind.ml

@@ -0,0 +1,50 @@
+(* TODO server/client shared routes and types *)
+open Types
+
+type _ t =
+  | Home : Thread_w_reply.t t
+  | Register : session t
+  | Login : session t
+  | Logout : session t
+  | Profile : session t
+  | Account : session t
+  | Thread : post_id -> Thread_w_reply.t t
+  | Delete : post_id -> post t
+  | Report :
+      post_id
+      -> report list t (* only reports made by user, or all if user is admin *)
+  | Admin_ignore : post_id -> report list t
+  | Admin_delete : post_id -> post t
+  | Admin_banish : user_id -> user t
+
+type wrapped = W : 'a t -> wrapped [@@unboxed]
+
+let name : type a. a t -> string = function
+  | Home -> "new-thread"
+  | Register -> "register"
+  | Login -> "login"
+  | Logout -> "logout"
+  | Profile -> "profile"
+  | Account -> "account"
+  | Thread _ -> "post"
+  | Delete _ -> "delete-post"
+  | Report _ -> "report-post"
+  | Admin_ignore _ -> "admin-ignore"
+  | Admin_delete _ -> "admin-delete"
+  | Admin_banish _ -> "admin-banish"
+
+let action : type a. a t -> string = function
+  | Home -> "/"
+  | Register -> "/register"
+  | Login -> "/login"
+  | Logout -> "/logout"
+  | Profile -> "/profile"
+  | Account -> "/account"
+  | Thread id -> Fmt.str "/thread/%d" id
+  | Delete id -> Fmt.str "/delete/%d" id
+  | Report id -> Fmt.str "/report/%d" id
+  | Admin_ignore id -> Fmt.str "/admin/ignore/%d" id
+  | Admin_delete id -> Fmt.str "/admin/delete/%d" id
+  | Admin_banish id -> Fmt.str "/admin/banish/%s" id
+
+let action k = Fmt.str "/api%s" (action k)

src/client/html.ml

@@ -0,0 +1,366 @@
+open Brr
+open Note
+open Note_brr
+open Types
+open Client_types
+open Page
+open Model
+open Util
+open Html_util
+
+module Header = struct
+  let mk t_s =
+    let left = El.div ~at:[ class' "nav-left" ] [ mk_page_link Home ] in
+    let right session =
+      let dropmenu user =
+        let class_prefix = "settings" in
+        let label = user.user_nick in
+        let at_title = "Settings" in
+        let mk_content () =
+          [ mk_page_link Profile
+          ; mk_page_link Account
+          ; Html_form.mk_logout ()
+          ; mk_page_link About
+          ]
+        in
+        mk_dropdown_menu ~class_prefix ~label ~at_title ~placeholder:true
+          mk_content
+      in
+      let l =
+        match Option.map user_private_to_public session.user_private with
+        | None -> List.map mk_page_link [ About; Register; Login ]
+        | Some u when u.user_is_admin ->
+          [ mk_page_link (Admin (Loading ())); dropmenu u ]
+        | Some u -> [ dropmenu u ]
+      in
+      El.div ~at:[ class' "nav-right" ] l
+    in
+    let children = S.map (fun t -> [ left; right t.session ]) t_s in
+    let el = El.nav ~at:[ id "top" ] [] in
+    Elr.def_children el children;
+    el
+
+  let f t_s =
+    let header = El.header [ mk t_s ] in
+    header
+end
+
+module Home = struct
+  let left t_s =
+    let new_thread_view =
+      (* TODO try to find better class names *)
+      let new_thread_form_div =
+        El.div
+          ~at:[ class' "new-thread-form-div" ]
+          [ Html_form.new_thread_el t_s ]
+      in
+      El.div
+        ~at:[ class' "new-thread-view" ]
+        [ h2 "New thread"
+        ; El.span
+            ~at:[ class' "new-thread-info" ]
+            [ el_txt "Click the map and make a new thread:" ]
+        ; new_thread_form_div
+        ]
+    in
+    let thread_view = Html_thread.f t_s in
+    let new_thread_link = Html_thread.new_thread_link_el t_s in
+    let return_link = El.a ~at:[ href (to_path Home) ] [ el_txt "Return" ] in
+    let navigation_div =
+      El.div
+        ~at:[ class' "home-left-navigation-div" ]
+        [ new_thread_link; return_link ]
+    in
+    let mode k = S.map (is_page_kind k) t_s in
+    def_on (mode New_thread) new_thread_view;
+    def_off (mode Thread) navigation_div;
+    def_on (mode Thread) thread_view;
+    def_off (mode New_thread) new_thread_link;
+    def_on (mode New_thread) return_link;
+    let el =
+      El.div
+        ~at:[ class' "home-left" ]
+        [ navigation_div; new_thread_view; thread_view ]
+    in
+    el
+
+  let f t_s =
+    let left_el = left t_s in
+    let right_el = Leaflet_map.f t_s in
+    let el = El.div ~at:[ class' "home-page" ] [ left_el; right_el ] in
+    def_on
+      (S.map
+         (fun t ->
+           is_page_kind Home t || is_page_kind New_thread t
+           || is_page_kind Thread t )
+         t_s )
+      el;
+    el
+end
+
+module About = struct
+  let f t_s =
+    let l = [ h1 "TODO about page" ] in
+    let el = mk_page About t_s l in
+    el
+end
+
+module Register = struct
+  let f t_s =
+    let l = [ h1 "Register"; Html_form.mk_register () ] in
+    let el = mk_page Register t_s l in
+    el
+end
+
+module Login = struct
+  let f t_s =
+    let l = [ h1 "Login"; Html_form.mk_login () ] in
+    let el = mk_page Login t_s l in
+    el
+end
+
+module Admin = struct
+  let mk t_s t =
+    match get_user_admin t with
+    | None -> []
+    | Some _user -> (
+      match t.page with
+      | Home | New_thread | Thread _ | About | Register | Login | Profile
+      | Account | Delete _ | Report _ | User _ ->
+        []
+      | Admin (Loading ()) -> loading_el
+      | Admin (Not_found ()) -> not_found_el
+      | Admin (Ready reports) ->
+        let forms =
+          match reports with
+          | [] ->
+            [ el_txt "Report list is empty!~"
+            ; El.br ()
+            ; el_txt "good job! ( ๑>ᴗ<๑ )"
+            ]
+          | reports ->
+            (* TODO add reported_post_parent_t_id to report type? *)
+            List.map
+              (fun report ->
+                let post = report.reported_post in
+                let post_view = Html_post.post_view t_s post in
+                let span_info_on_report =
+                  let s =
+                    Fmt.str "From: %s, Reason: %s" report.reporter_nick
+                      report.reason
+                  in
+                  El.span [ el_txt s ]
+                in
+                let forms =
+                  El.div
+                    Html_form.
+                      [ admin_ignore post.id
+                      ; admin_delete post.id
+                      ; admin_banish post.poster_id
+                      ]
+                in
+                El.div
+                  ~at:[ class' "report" ]
+                  [ post_view; span_info_on_report; forms ] )
+              reports
+        in
+        let reports_div = El.div ~at:[ class' "reports-div" ] forms in
+        [ h1 "Administration board"; reports_div ] )
+
+  let f t_s =
+    let el = mk_page Admin t_s [] in
+    Elr.def_children el (S.map (mk t_s) t_s);
+    el
+end
+
+module Profile = struct
+  let mk t =
+    match get_user t with
+    | None -> []
+    | Some user ->
+      let public_profile_link =
+        El.p
+          [ el_txt "Check your "
+          ; mk_page_link ~label:"public profile" (User (Loading user.user_id))
+          ]
+      in
+      let forms = Html_form.profile user in
+      [ h1 "Profile settings"; public_profile_link ] @ forms
+
+  let f t_s =
+    let el = mk_page Profile t_s [] in
+    Elr.def_children el (S.map mk t_s);
+    el
+end
+
+module Account = struct
+  let mk t =
+    match get_user_private t with
+    | None -> []
+    | Some user_private ->
+      let forms = Html_form.account user_private in
+      h1 "Account settings" :: forms
+
+  let f t_s =
+    let el = mk_page Account t_s [] in
+    Elr.def_children el (S.map mk t_s);
+    el
+end
+
+module User = struct
+  let mk t =
+    match t.page with
+    | Home | New_thread | Thread _ | About | Register | Login | Admin _
+    | Profile | Account | Delete _ | Report _ ->
+      []
+    | User (Loading _user_id) -> loading_el
+    | User (Not_found _user_id) -> not_found_el
+    | User (Ready user) ->
+      let bio = El.div [ El.blockquote (Html_util.insert_br user.bio) ] in
+      let img =
+        match user.avatar_info with
+        | None -> []
+        | Some info ->
+          let alt_at =
+            if String.equal "" info.alt then []
+            else [ alt info.alt; name info.name; title info.alt ]
+          in
+          let at =
+            [ Fmt.kstr src "/user/%s/avatar" user.user_id
+            ; class' "img-thumbnail"
+            ]
+            @ alt_at
+          in
+          [ El.img ~at () ]
+      in
+      h1 user.user_nick :: bio :: img
+
+  let f t_s =
+    let el = mk_page User t_s [] in
+    Elr.def_children el (S.map mk t_s);
+    el
+end
+
+module Delete = struct
+  let mk t_s t =
+    match get_user t with
+    | None -> []
+    | Some user -> (
+      match t.page with
+      | Home | New_thread | Thread _ | About | Register | Login | Admin _
+      | Profile | Account | Report _ | User _ ->
+        []
+      | Delete (Loading _id) -> loading_el
+      | Delete (Not_found _id) -> not_found_el
+      | Delete (Ready post) -> (
+        match String.equal post.poster_id user.user_id with
+        | false -> (* TODO error can not delete other's posts *) []
+        | true ->
+          let post_view = Html_post.post_view t_s post in
+          let form = Html_form.delete post in
+          [ post_view; form ] ) )
+
+  let f t_s =
+    let el = mk_page Delete t_s [] in
+    Elr.def_children el (S.map (mk t_s) t_s);
+    el
+end
+
+module Report = struct
+  let mk t_s t =
+    match get_user t with
+    | None -> []
+    | Some _user -> (
+      match t.page with
+      | Home | New_thread | Thread _ | About | Register | Login | Admin _
+      | Profile | Account | Delete _ | User _ ->
+        []
+      | Report (Loading _id) -> loading_el
+      | Report (Not_found _id) -> not_found_el
+      | Report (Ready post) ->
+        let post_view = Html_post.post_view t_s post in
+        let form = Html_form.report post in
+        [ post_view; form ] )
+
+  let f t_s =
+    let el = mk_page Report t_s [] in
+    Elr.def_children el (S.map (mk t_s) t_s);
+    el
+end
+
+module Error_popup = struct
+  let mk container_el opt =
+    match opt with
+    | None -> []
+    | Some error ->
+      let dragzone =
+        let close_btn =
+          El.button ~at:[ class' "close-error-popup-btn" ] [ el_txt "X" ]
+        in
+        hold_on close_btn Ev.click (fun _ev -> Events.send_action Clear_error);
+        El.div ~at:[ class' "error-popup-dragzone" ] [ close_btn ]
+      in
+      Html_form.Dragzone.f ~dragzone container_el;
+      let content =
+        El.div
+          ~at:[ class' "error-popup-content" ]
+          [ El.span [ el_txt (Fmt.str "%a" Client_types.pp_error error) ] ]
+      in
+      [ dragzone; content ]
+
+  let f t_s =
+    let el = El.div ~at:[ class' "error-popup" ] [] in
+    Elr.def_children el (S.map (fun t -> mk el t.error) t_s);
+    def_off (S.map (fun t -> Option.is_none t.error) t_s) el;
+    el
+end
+
+module Main = struct
+  let f t_s =
+    let l =
+      List.map
+        (fun f -> f t_s)
+        [ Home.f
+        ; About.f
+        ; Register.f
+        ; Login.f
+        ; Admin.f
+        ; Profile.f
+        ; Account.f
+        ; User.f
+        ; Delete.f
+        ; Report.f
+        ; Error_popup.f
+        ]
+    in
+    let main = El.v (str "main") l in
+    main
+end
+
+let def_page_title t_s =
+  let set_title page =
+    let s =
+      match page with
+      | Thread (Loading _) | User (Loading _) -> "loading"
+      | Thread (Not_found _) | User (Not_found _) -> "not found"
+      | Thread (Ready v) -> v.subject
+      | User (Ready u) -> u.user_nick
+      | page -> (
+        match to_kind page with
+        | New_thread -> "new thread"
+        | kind -> Kind.to_string kind )
+    in
+    Fmt.str "%s | Geochan" s |> String.capitalize_ascii |> Jstr.v
+    |> Document.set_title G.document
+  in
+  S.map (fun t -> t.page) t_s |> S.changes |> hold_endless set_title;
+  (* init *)
+  let k = (S.value t_s).page in
+  set_title k;
+  ()
+
+let f t_s =
+  let header_el = Header.f t_s in
+  let main_el = Main.f t_s in
+  def_page_title t_s;
+  [ header_el; main_el ]

src/client/html_form.ml

@@ -0,0 +1,391 @@
+open Brr
+open Note
+open Note_brr
+open Types
+open Client_types
+open Util
+
+let handle_submit kind form ev =
+  Fmt.pr "catched form submit event@.";
+  Ev.prevent_default ev;
+  Events.send_action (Submit_event (W kind, form));
+  ()
+
+let mk kind ~btn l =
+  let class_prefix = Form_kind.name kind in
+  let action = Form_kind.action kind in
+  let at =
+    [ Fmt.kstr class' "%s-form " class_prefix
+    ; At.action (str action)
+    ; At.method' (str "POST")
+    ; mk_at "enctype" "multipart/form-data"
+    ]
+  in
+  let content = l @ [ El.div [ btn ] ] in
+  let form = El.form ~at content in
+  hold_on form Brr_io.Form.Ev.submit (fun ev -> handle_submit kind form ev);
+  form
+
+(* -- TODO clean up this mess -- *)
+
+let mk_field_unwraped kind ~name ~label ~at =
+  let type' =
+    type'
+    @@
+    match kind with
+    | `Text | `Textarea _ -> "text"
+    | `Password -> "password"
+    | `File -> "file"
+  in
+  let label =
+    El.label
+      ~at:
+        [ At.for' (str name); Fmt.kstr id "%s-label" name; class' "form-label" ]
+      [ el_txt label ]
+  in
+  let at =
+    [ type'
+    ; id name
+    ; At.name (str name)
+    ; class' "form-label"
+    ; Fmt.kstr (mk_at "aria-labelledby") "%s-label" name
+    ]
+    @ at
+  in
+  let item =
+    match kind with
+    | `Text | `File | `Password -> El.input ~at ()
+    | `Textarea content -> El.textarea ~at [ el_txt content ]
+  in
+  (label, item)
+
+let mk_field kind ~name ~label ~at =
+  let label, item = mk_field_unwraped kind ~name ~label ~at in
+  El.div [ label; item ]
+
+let mk_btn ?(at = []) s =
+  let at = [ type' "submit"; class' "submit-btn" ] @ at in
+  El.button ~at [ el_txt s ]
+
+let mk_btn_save () = mk_btn "Save"
+
+let mk_btn_submit () = mk_btn "Submit"
+
+let mk_logout () =
+  let btn =
+    let label = "❌ Logout" in
+    let btn_class = "logount-btn" in
+    El.button ~at:[ class' btn_class ] [ el_txt label ]
+  in
+  mk Logout ~btn []
+
+let mk_register () =
+  let nick = mk_field `Text ~name:"nick" ~label:"Nickname" ~at:[] in
+  let email = mk_field `Text ~name:"email" ~label:"Email" ~at:[] in
+  let password = mk_field `Password ~name:"password" ~label:"Password" ~at:[] in
+  let btn = mk_btn_submit () in
+  mk Register ~btn [ nick; email; password ]
+
+let mk_login () =
+  let nick = mk_field `Text ~name:"login" ~label:"Nickname or email" ~at:[] in
+  let password = mk_field `Password ~name:"password" ~label:"Password" ~at:[] in
+  let btn = mk_btn_submit () in
+  mk Login ~btn [ nick; password ]
+
+let mk_subject_field_unwraped () =
+  mk_field_unwraped `Text ~name:"subject" ~label:"Subject" ~at:[]
+
+let mk_comment_field_unwraped s =
+  mk_field_unwraped (`Textarea s) ~name:"comment" ~label:"Comment" ~at:[]
+
+let mk_image_field_unwraped () =
+  let file_label, file =
+    mk_field_unwraped `File ~name:"file" ~label:"Add picture"
+      ~at:
+        [ mk_at "accept"
+            (String.concat "," (Array.to_list Config.supported_mime_type))
+        ]
+  in
+  let alt =
+    El.div
+      ~at:[ class' "alt-image-input-div" ]
+      [ mk_field (`Textarea "") ~name:"alt" ~label:"Image desciption" ~at:[] ]
+  in
+  ((file_label, file), alt)
+
+let mk_image_field () =
+  let (file_label, file), alt = mk_image_field_unwraped () in
+  let file_div = El.div [ file_label; file ] in
+  El.div ~at:[ class' "image-input-div" ] [ file_div; alt ]
+
+(* -------- *)
+
+let sync_field input ~on form_action =
+  hold_on input Ev.input (fun _ev ->
+      let s = El.prop El.Prop.value input |> Jstr.to_string in
+      Events.send_action (Post_form_change (form_action s)) );
+  Elr.set_prop El.Prop.value ~on input;
+  ()
+
+let mk_comment_div t_s =
+  let open Model in
+  let label, textarea = mk_comment_field_unwraped "" in
+  let () =
+    let on = S.map (fun t -> t.post_form.comment |> Jstr.v) t_s |> S.changes in
+    let send s = Client_types.Form_comment s in
+    sync_field textarea ~on send
+  in
+  let focus_e =
+    S.map
+      (fun t ->
+        (* take reply_form here and not reply_form.is_open
+             so focus turn on when textarea content changes (quote insertion) *)
+        t.post_form )
+      t_s
+    |> S.changes
+    |> E.filter_map (fun rf ->
+           match rf.Post_form_data.is_open with
+           | false -> None
+           | true -> Some true )
+  in
+  Elr.set_has_focus ~on:focus_e textarea;
+  El.div ~at:[ class' "comment-input-div" ] [ label; textarea ]
+
+let mk_image_div t_s =
+  let open Model in
+  let (file_label, file), alt = mk_image_field_unwraped () in
+  let () =
+    let has_file = S.map (fun t -> Option.is_some t.post_form.file) t_s in
+    Util.def_on has_file alt;
+    let on =
+      S.map (fun t -> t.post_form.alt) t_s
+      |> S.changes |> E.filter_map Fun.id |> E.map Jstr.v
+    in
+    let send s =
+      let opt = if String.equal s "" then None else Some s in
+      Client_types.Form_alt opt
+    in
+    sync_field alt ~on send
+  in
+  hold_on file Ev.change (fun _ev ->
+      let opt =
+        match El.Input.files file with
+        | [] -> None
+        | file :: _l ->
+          let s = File.name file |> Jstr.to_string in
+          Some s
+      in
+      Events.send_action (Post_form_change (Form_file opt)) );
+  (* clear image file name if needed *)
+  let on =
+    S.map
+      (fun t ->
+        match t.post_form.file with
+        | None -> Some (Jv.to_jstr Jv.null)
+        | Some _s -> None )
+      t_s
+    |> S.changes |> E.filter_map Fun.id
+  in
+  Elr.set_prop El.Prop.value ~on file;
+  let file_div = El.div [ file_label; file ] in
+  El.div ~at:[ class' "image-input-div" ] [ file_div; alt ]
+
+let new_thread_el t_s =
+  let open Model in
+  let subject =
+    let label, input = mk_subject_field_unwraped () in
+    let () =
+      let on =
+        S.map (fun t -> t.post_form.subject |> Jstr.v) t_s |> S.changes
+      in
+      let send s = Client_types.Form_subject s in
+      sync_field input ~on send
+    in
+    El.div ~at:[ class' "subject-input-div" ] [ label; input ]
+  in
+  let comment = mk_comment_div t_s in
+  let image = mk_image_div t_s in
+  let lat =
+    El.input ~at:[ type' "hidden"; id "lat-input"; name "lat-input" ] ()
+  in
+  let lng =
+    El.input ~at:[ type' "hidden"; id "lng-input"; name "lng-input" ] ()
+  in
+  let latlng_s = S.map (fun t -> t.post_form.latlng) t_s in
+  Elr.def_at At.Name.value
+    (latlng_s |> S.map (Option.map fst) |> S.map (Option.map Jstr.of_float))
+    lat;
+  Elr.def_at At.Name.value
+    (latlng_s |> S.map (Option.map snd) |> S.map (Option.map Jstr.of_float))
+    lng;
+  let btn =
+    let at = [ class' "submit-post-btn" ] in
+    mk_btn ~at "Post"
+  in
+  Util.def_disabled (S.map Option.is_none latlng_s) btn;
+  mk Home ~btn [ subject; comment; image; lat; lng ]
+
+let profile user =
+  let mk = mk Profile in
+  let nickname =
+    let nick =
+      mk_field `Text ~name:"nick" ~label:"Change nickname"
+        ~at:[ value user.user_nick ]
+    in
+    let btn = mk_btn_save () in
+    let form = mk ~btn [ nick ] in
+    [ h2 "Nickname"; form ]
+  in
+  let bio =
+    let bio =
+      mk_field (`Textarea user.bio) ~name:"bio" ~label:"Change your biography"
+        ~at:[]
+    in
+    let btn = mk_btn_save () in
+    let form = mk ~btn [ bio ] in
+    [ h2 "Biography"; form ]
+  in
+  let avatar =
+    (* TODO
+       - small preview off current avatar on the left of delete avatar button
+       - preview of image to be uploaded
+       - add image preview in new-thread/reply form too*)
+    let delete =
+      user.avatar_info
+      |> Option.map (fun _ ->
+             let input_el =
+               El.input
+                 ~at:[ type' "hidden"; name "delete-avatar"; value "" ]
+                 ()
+             in
+             let btn = mk_btn "delete current avatar" in
+             mk ~btn [ input_el ] )
+      |> Option.to_list
+    in
+    let upload =
+      let file_el =
+        mk_field `File ~name:"file" ~label:"Change your avatar"
+          ~at:
+            [ mk_at "accept"
+                (String.concat "," (Array.to_list Config.supported_mime_type))
+            ]
+      in
+      (* TODO disable alt field if no image; do the same for post form *)
+      let alt_el =
+        let content =
+          Option.fold ~none:"" ~some:(fun img -> img.alt) user.avatar_info
+        in
+        mk_field (`Textarea content) ~name:"alt" ~label:"Image desciption"
+          ~at:[]
+      in
+      let btn = mk_btn_save () in
+      [ mk ~btn [ file_el; alt_el ] ]
+    in
+    (h2 "Avatar" :: delete) @ upload
+  in
+  nickname @ bio @ avatar
+
+let account user_private =
+  let mk = mk Account in
+  let email =
+    let email =
+      mk_field `Text ~name:"email" ~label:"Email"
+        ~at:[ value user_private.User_private.email ]
+    in
+    let btn = mk_btn_save () in
+    let form = mk ~btn [ email ] in
+    [ h2 "Change email"; form ]
+  in
+  let password =
+    let pw1 =
+      mk_field `Password ~name:"new-password" ~label:"New password" ~at:[]
+    in
+    let pw2 =
+      mk_field `Password ~name:"confirm-new-password"
+        ~label:"Confirm new password" ~at:[]
+    in
+    let btn = mk_btn_save () in
+    let form = mk ~btn [ pw1; pw2 ] in
+    [ h2 "Change password"; form ]
+  in
+  let big_delete =
+    let btn = mk_btn ~at:[ class' "delete-account-btn" ] "DELETE ACCOUNT" in
+    let form =
+      mk ~btn
+        [ El.input ~at:[ type' "hidden"; name "delete-account"; value "" ] () ]
+    in
+    [ h2 "Delete account"; form ]
+  in
+  email @ password @ big_delete
+
+let delete post =
+  let btn = mk_btn "DELETE" in
+  mk (Delete post.id) ~btn []
+
+let report post =
+  let btn = mk_btn "Report" in
+  let reason = mk_field `Text ~name:"reason" ~label:"Reason" ~at:[] in
+  mk (Report post.id) ~btn [ reason ]
+
+let admin_ignore post_id =
+  let btn = mk_btn "ignore" in
+  mk (Admin_ignore post_id) ~btn []
+
+let admin_delete post_id =
+  let btn = mk_btn "DELETE" in
+  mk (Admin_delete post_id) ~btn []
+
+let admin_banish user_id =
+  let btn = mk_btn "BANISH" in
+  mk (Admin_banish user_id) ~btn []
+
+module Dragzone = struct
+  (* TODO
+     - send drag_state to model on dragend (mouseup)
+       need to differentiate which popup we are dragging for this *)
+  let drag_state = ref None
+
+  let on_mousedown dragzone container ev =
+    match !drag_state with
+    | Some _ -> Fmt.failwith "Dragzone state error: double mousedown?"
+    | None ->
+      let evt = Ev.as_type ev in
+      let offset_x = El.bound_x container -. Ev.Mouse.client_x evt in
+      let offset_y = El.bound_y container -. Ev.Mouse.client_y evt in
+      drag_state := Some (dragzone, container, offset_x, offset_y);
+      (* css so nothing get highlighted *)
+      El.set_inline_style (Jstr.v "user-select") (Jstr.v "none") body;
+      El.set_inline_style (Jstr.v "pointer-events") (Jstr.v "none") body;
+      El.set_inline_style (Jstr.v "pointer-events") (Jstr.v "auto") dragzone
+
+  let on_mousemove ev =
+    match !drag_state with
+    | None -> ()
+    | Some (_dragzone, container, offset_x, offset_y) ->
+      let evt = Ev.as_type ev in
+      let x = Ev.Mouse.client_x evt +. offset_x in
+      let y = Ev.Mouse.client_y evt +. offset_y in
+      let x = clamp ~min:0. ~max:(window_width () -. El.bound_w container) x in
+      let y = clamp ~min:0. ~max:(window_height () -. El.bound_h container) y in
+      El.set_inline_style El.Style.position (Jstr.v "fixed") container;
+      El.set_inline_style El.Style.left (Fmt.kstr Jstr.v "%fpx" x) container;
+      El.set_inline_style El.Style.top (Fmt.kstr Jstr.v "%fpx" y) container
+
+  let on_mouseup _ev =
+    match !drag_state with
+    | None -> ()
+    | Some (dragzone, _container, _, _) ->
+      El.set_inline_style (Jstr.v "user-select") (Jstr.v "") body;
+      El.set_inline_style (Jstr.v "pointer-events") (Jstr.v "") body;
+      El.set_inline_style (Jstr.v "pointer-events") (Jstr.v "") dragzone;
+      drag_state := None
+
+  let () =
+    hold_endless_on_window Ev.mousemove on_mousemove;
+    hold_endless_on_window Ev.mouseup on_mouseup;
+    ()
+
+  let f ~dragzone container =
+    hold_on dragzone Ev.mousedown (fun ev -> on_mousedown dragzone container ev);
+    ()
+end

src/client/html_post.ml

@@ -0,0 +1,335 @@
+open Brr
+open Note
+open Note_brr
+open Types
+open Client_types
+open Util
+
+let nick post =
+  El.a
+    ~at:
+      [ class' "user-link"
+      ; class' "post-author-nick"
+      ; mk_at "data-user-id" post.poster_id
+      ; Fmt.kstr href "/user/%s" post.poster_id
+      ]
+    [ el_txt post.poster_nick ]
+
+let date post =
+  let print_date t =
+    let t = Unix.localtime t in
+    Fmt.str "%02d-%02d-%02d %02d:%02d" (1900 + t.tm_year) (1 + t.tm_mon)
+      t.tm_mday t.tm_hour t.tm_min
+  in
+  El.span
+    ~at:[ class' "post-date"; mk_at "data-time" (string_of_float post.date) ]
+    [ el_txt (print_date post.date) ]
+
+(* TODO rm this since we can click the post_id? *)
+let link_to_post ?(is_vignette = false) post =
+  let url =
+    if is_vignette then Fmt.str "/thread/%d#%d" post.parent_t_id post.id
+    else Fmt.str "#%d" post.id
+  in
+  El.a
+    ~at:[ href url; title "Link to this post"; class' "post-link-to-self" ]
+    [ el_txt "#" ]
+
+let post_id post =
+  let el =
+    let at =
+      [ class' "post-id"
+      ; title "Reply to this post"
+      ; mk_at "data-id" (string_of_int post.id)
+      ; Fmt.kstr href "#%d" post.id
+      ]
+    in
+    El.a ~at [ el_txt (Fmt.str ">>%d" post.id) ]
+  in
+  hold_on el Ev.click (fun _ev ->
+      Events.send_action (Post_form_change Form_open);
+      Events.send_action (Post_form_change (Form_insert_quote post.id)) );
+  el
+
+let post_id_quote =
+  let is_local_link t_s id =
+    (* list of post currently on the page
+       (consider thread page case only) *)
+    let post_l =
+      match (S.value t_s).Model.page with
+      | Thread (Ready v) -> v.reply_l
+      | _ -> []
+    in
+    List.find_opt (fun p -> p.id = id) post_l |> Option.is_some
+  in
+  let hold_highlight_event el id =
+    let mouseenter = Evr.on_el Ev.mouseenter Evr.unit el in
+    let mouseleave = Evr.on_el Ev.mouseleave Evr.unit el in
+    let focus = Evr.on_el Ev.focus Evr.unit el in
+    let blur = Evr.on_el Ev.blur Evr.unit el in
+    let off = E.select [ mouseleave; blur ] |> E.map (fun () -> None) in
+    let on =
+      E.select [ mouseenter; focus ]
+      |> E.map (fun () -> Some (get_bounds el, id))
+    in
+    let event = E.select [ off; on ] in
+    hold_event_on el event (fun opt ->
+        Events.send_action (Quickview_change opt) );
+    ()
+  in
+  fun t_s id ->
+    let at = [ class' "post-id-quote"; mk_at "data-id" (string_of_int id) ] in
+    let txt = el_txt (Fmt.str ">>%d" id) in
+    match is_local_link t_s id with
+    | true ->
+      (* simple #%d link *)
+      let at = [ Fmt.kstr href "#%d" id ] @ at in
+      let el = El.a ~at [ txt ] in
+      hold_highlight_event el id;
+      el
+    | false ->
+      (* remote link *)
+      let at = [ class' "remote" ] @ at in
+      let container = El.span [] in
+      hold_highlight_event container id;
+      let children =
+        let open Page in
+        S.map (fun t -> t.Model.quickview) t_s
+        |> S.changes |> E.filter_map Fun.id
+        |> E.map (fun (rect, v) ->
+               let quickview_id = unwrap_post_id v in
+               fun last_value ->
+                 match quickview_id = id with
+                 | true -> Some (rect, v)
+                 | false -> last_value )
+        |> S.accum None
+        |> S.map (function
+             | None -> [ El.button ~at [ txt ] ]
+             | Some (_rect, v) -> (
+               match v with
+               | Loading _ ->
+                 let at = [ class' "loading" ] @ at in
+                 [ El.button ~at [ txt ] ]
+               | Not_found _ ->
+                 let at = [ class' "not-found" ] @ at in
+                 [ El.button ~at [ txt ] ]
+               | Ready p ->
+                 let at =
+                   [ class' "ready"
+                   ; Fmt.kstr href "/thread/%d#%d" p.parent_t_id p.id
+                   ]
+                   @ at
+                 in
+                 [ El.a ~at [ txt ] ] ) )
+      in
+      Elr.def_children container children;
+      container
+
+let post_menu t_s post =
+  let mk s =
+    El.a
+      ~at:
+        [ Fmt.kstr href "/%s/%d" s post.id
+        ; Fmt.kstr class' "%s-link" s
+        ; mk_at "data-post-id" (string_of_int post.id)
+        ]
+      [ el_txt (String.capitalize_ascii s) ]
+  in
+  let mk_content () =
+    let delete = mk "delete" in
+    let report = mk "report" in
+    let own_post =
+      S.map Model.get_user t_s
+      |> S.map (function
+           | None -> false
+           | Some u -> String.equal u.user_id post.poster_id )
+    in
+    def_on own_post delete;
+    [ delete; report ]
+  in
+  Html_util.mk_dropdown_menu ~class_prefix:"post-info" ~label:""
+    ~at_title:"Post menu" ~placeholder:false mk_content
+
+let backlinks t_s post =
+  let l = List.map (post_id_quote t_s) post.backlinks in
+  El.div ~at:[ class' "post-replies" ] l
+
+let image t_s ?(is_vignette = false) post =
+  match post.image_info with
+  | None -> None
+  | Some image -> (
+    (* TODO show image dimension/name *)
+    let mk is_small =
+      let class_small =
+        if is_small then [ class' "post-image-small" ] else []
+      in
+      let sizes =
+        [ mk_at "width"
+            (string_of_int (if is_small then image.thumb_w else image.w))
+        ; mk_at "height"
+            (string_of_int (if is_small then image.thumb_h else image.h))
+        ]
+      in
+      let url =
+        src
+        @@
+        if is_small then Fmt.str "/img/s/%d" post.id
+        else Fmt.str "/img/%d" post.id
+      in
+      let at =
+        class_small @ sizes
+        @ url
+          :: [ class' "post-image"
+             ; alt image.alt
+             ; title image.alt
+             ; mk_at "data-id" (string_of_int post.id)
+             ; mk_at "loading" "lazy"
+             ]
+      in
+      El.img ~at ()
+    in
+    let img_small, img_big = (mk true, mk false) in
+    let el = El.div ~at:[ class' "post-image-div" ] [ img_small ] in
+    match is_vignette with
+    | true -> Some el
+    | false ->
+      (* swap img_(small/big) on click *)
+      hold_on el Ev.click (fun _ev -> Events.send_action (Image_click post.id));
+      let img_s =
+        S.map (fun t -> t.Model.opened_image) t_s
+        |> S.map (function
+             | Some id when Int.equal id post.id -> [ img_big ]
+             | Some _ | None -> [ img_small ] )
+      in
+      Elr.def_children el img_s;
+      Some el )
+
+let comment =
+  let open Comment in
+  let insert_br_between_lines l =
+    match l with
+    | [] -> []
+    | hd :: tl ->
+      List.rev
+      @@ List.fold_left (fun acc x -> x :: [ El.br () ] :: acc) [ hd ] tl
+  in
+  let item t_s = function Txt s -> el_txt s | Id i -> post_id_quote t_s i in
+  let items t_s l = List.map (item t_s) l in
+  let line t_s = function
+    | Line l -> items t_s l
+    | Line_quote l ->
+      [ El.span ~at:[ class' "line-quote" ] (el_txt ">" :: items t_s l) ]
+  in
+  fun t_s comment ->
+    let content =
+      List.map (line t_s) comment |> insert_br_between_lines |> List.flatten
+    in
+    El.div ~at:[ class' "post-comment" ] content
+
+let info t_s post =
+  El.div
+    ~at:[ class' "post-info" ]
+    [ nick post
+    ; date post
+    ; post_id post
+    ; link_to_post post
+    ; post_menu t_s post
+    ; backlinks t_s post
+    ]
+
+let post_view t_s post =
+  let info = info t_s post in
+  let content =
+    let comment = comment t_s post.comment in
+    let l =
+      match image t_s post with
+      | None -> [ comment ]
+      | Some image -> [ image; comment ]
+    in
+    El.div ~at:[ class' "post-content" ] l
+  in
+  let at = [ class' "post"; id (string_of_int post.id) ] in
+  let el = El.div ~at [ info; content ] in
+  let is_selected =
+    S.map
+      (fun t ->
+        match t.Model.fragment with
+        | Id v ->
+          let id = Fragment.unwrap_id v in
+          post.id = id
+        | Empty | Top | Bottom -> false )
+      t_s
+  in
+  Elr.def_class (Jstr.v "selected") is_selected el;
+  let is_highlighted =
+    S.map (fun t -> t.Model.quickview) t_s
+    |> S.map (function
+         | None -> false
+         | Some (_rect, v) -> Int.equal post.id (Page.unwrap_post_id v) )
+  in
+  Elr.def_class (Jstr.v "highlighted") is_highlighted el;
+  el
+
+module Quickview = struct
+  open Model
+
+  let quickview_class = "quickview-div"
+
+  let to_px_jstr x = x |> int_of_float |> Fmt.str "%dpx" |> Jstr.of_string
+
+  let is_in_viewport post =
+    (* find highlighted post DOM element *)
+    let id = string_of_int post.id in
+    match find_html_el_by_id id with
+    | None -> false
+    | Some el ->
+      (* check bounds *)
+      let x, y, w, h = get_bounds el in
+      let ( <= ) x y = Float.compare x y <= 0 in
+      0. <= x && 0. <= y
+      && x +. w <= window_width ()
+      && y +. h <= window_height ()
+
+  let f t_s =
+    let container = El.div ~at:[ class' quickview_class ] [] in
+    let mk (id_x, id_y, id_w, id_h) post =
+      if is_in_viewport post then []
+      else
+        let quickview = post_view t_s post in
+        (* ensure we don't have duplicate html id attribute *)
+        El.set_at At.Name.id (Some (Jstr.v "quickview")) quickview;
+        (* hack: insert hidden quickview into DOM so we can compute it's bounds
+           we don't use the viewed post's already in DOM element for this
+             - it might actually not be in DOM
+             - it might have it's image opened and size changed *)
+        El.set_inline_style El.Style.visibility (Jstr.v "hidden") quickview;
+        El.set_children container [ quickview ];
+        (* compute quickview position *)
+        let quickview_x = id_x +. id_w in
+        let quickview_h = El.bound_h quickview in
+        let quickview_y = id_y +. (0.5 *. id_h) -. (0.5 *. quickview_h) in
+        let quickview_y =
+          clamp ~min:0. ~max:(window_height () -. quickview_h) quickview_y
+        in
+        (* undo quickview DOM insertion *)
+        El.set_inline_style El.Style.visibility (Jstr.v "visible") quickview;
+        El.remove quickview;
+        (* set quickview style *)
+        El.set_inline_style El.Style.position (Jstr.v "fixed") quickview;
+        El.set_inline_style El.Style.z_index (Jstr.v "99999") quickview;
+        El.set_inline_style El.Style.left (to_px_jstr quickview_x) quickview;
+        El.set_inline_style El.Style.top (to_px_jstr quickview_y) quickview;
+        [ quickview ]
+    in
+    let children =
+      S.map (fun t -> t.quickview) t_s
+      |> S.map (function
+           | None -> []
+           | Some (rect, v) -> (
+             match v with
+             | Page.Loading _ | Not_found _ -> []
+             | Ready post -> mk rect post ) )
+    in
+    Elr.def_children container children;
+    container
+end

src/client/html_thread.ml

@@ -0,0 +1,156 @@
+open Brr
+open Note
+open Note_brr
+open Types
+open Page
+open Model
+open Util
+open Html_util
+
+let thread_el_aux t_s w =
+  match w with
+  | Loading _id -> loading_el
+  | Not_found _id -> not_found_el
+  | Ready (v : Thread_w_reply.t) ->
+    let subject =
+      El.div ~at:[ class' "thread-subject" ] [ El.strong [ el_txt v.subject ] ]
+    in
+    let reply_l =
+      let l =
+        List.sort (fun a b -> Float.compare a.date b.date) v.reply_l
+        |> List.map (fun p -> Html_post.post_view t_s p)
+      in
+      El.div ~at:[ class' "thread-replies" ] l
+    in
+    [ subject; reply_l ]
+
+let thread_el t_s w =
+  let id = Jstr.of_int (unwrap_thread_id w) in
+  let el =
+    El.div
+      ~at:[ class' "thread"; At.v (str "data-id") id ]
+      (thread_el_aux t_s w)
+  in
+  el
+
+let reply_popup_el t_s w =
+  let dragzone =
+    let close_btn =
+      El.button ~at:[ class' "close-reply-popup-btn" ] [ el_txt "X" ]
+    in
+    hold_on close_btn Ev.click (fun _ev ->
+        Events.send_action (Post_form_change Form_close) );
+    El.div ~at:[ class' "reply-popup-dragzone" ] [ close_btn ]
+  in
+  let content =
+    let open Html_form in
+    let comment = mk_comment_div t_s in
+    let image = mk_image_div t_s in
+    let btn = mk_btn "Post" in
+    let form = mk (Thread (unwrap_thread_id w)) ~btn [ comment; image ] in
+    let el = El.div ~at:[ class' "reply-popup-content" ] [ form ] in
+    el
+  in
+  let el = El.div ~at:[ class' "reply-popup" ] [ dragzone; content ] in
+  Html_form.Dragzone.f ~dragzone el;
+  let is_visible_s = S.map (fun t -> t.post_form.is_open) t_s in
+  def_on is_visible_s el;
+  el
+
+let new_thread_link_el t_s =
+  let mk user =
+    match user with
+    | None ->
+      (* TODO redirect *)
+      mk_page_link ~label:"Login to post a thread!" Login
+    | Some _user ->
+      El.a ~at:[ href (Page.to_path New_thread) ] [ el_txt "New thread" ]
+  in
+  let el = El.div ~at:[ class' "new-thread-link-div" ] [] in
+  let children = S.map get_user t_s |> S.map (fun u -> [ mk u ]) in
+  Elr.def_children el children;
+  el
+
+let bump_status_el v =
+  el_txt
+  @@
+  match v with
+  | Types.Dead -> "Dead thread"
+  | Locked c ->
+    Fmt.str "bump order: [%d/%d]\nLocked thread, You cannot reply anymore." c
+      Config.thread_alive_max_count
+  | Alive c -> Fmt.str "bump order: [%d/%d]" c Config.thread_alive_max_count
+
+let reply_btn_el t_s w =
+  let mk user =
+    match w with
+    | Loading _ | Not_found _ -> []
+    | Ready (v : Thread_w_reply.t) ->
+      let el =
+        match user with
+        | None ->
+          (* TODO redirect *)
+          mk_page_link ~label:"Login to reply!" Login
+        | Some _user -> (
+          match v.bump_status with
+          | Dead | Locked _ -> bump_status_el v.bump_status
+          | Alive _bump_order ->
+            let btn =
+              let at = [ class' "open-reply-popup-btn" ] in
+              El.button ~at [ el_txt "Post a reply" ]
+            in
+            let is_hidden = S.map (fun t -> t.post_form.is_open) t_s in
+            Elr.def_class (Jstr.v "hidden") is_hidden btn;
+            hold_on btn Ev.click (fun _ev ->
+                Events.send_action (Post_form_change Form_open) );
+            btn )
+      in
+      [ el ]
+  in
+  let el = El.div ~at:[ class' "reply-popup-btn-div" ] [] in
+  let children = S.map get_user t_s |> S.map mk in
+  Elr.def_children el children;
+  el
+
+(* need t_s for user + reply form open/close state *)
+let nav_el kind t_s w =
+  let str = match kind with `Top -> "top" | `Bottom -> "bottom" in
+  let str_inv = match kind with `Top -> "bottom" | `Bottom -> "top" in
+  let update_el =
+    El.a ~at:[ href (Page.to_path (Thread w)) ] [ el_txt "Update" ]
+  in
+  let at =
+    match kind with
+    | `Top ->
+      (* id="top" is set on nav bar instead *)
+      [ class' "sub-nav" ]
+    | `Bottom -> [ class' "sub-nav"; id str ]
+  in
+  let el =
+    El.div ~at
+      [ new_thread_link_el t_s
+      ; reply_btn_el t_s w
+      ; update_el
+      ; El.a
+          ~at:[ Fmt.kstr href "#%s" str_inv ]
+          [ Fmt.kstr el_txt "Go to %s" str_inv ]
+      ]
+  in
+  el
+
+let mk t_s w =
+  [ nav_el `Top t_s w
+  ; thread_el t_s w
+  ; reply_popup_el t_s w
+  ; Html_post.Quickview.f t_s
+  ; nav_el `Bottom t_s w
+  ]
+
+let f t_s =
+  let el = El.div ~at:[ class' "thread-view" ] [] in
+  let children_s =
+    S.map get_thread_w_reply t_s
+    |> S.map (function None -> [] | Some w -> mk t_s w)
+  in
+  Elr.def_children el children_s;
+  el

src/client/html_util.ml

@@ -0,0 +1,80 @@
+open Brr
+open Note
+open Model
+open Util
+
+let loading_el = [ el_txt "ฅ^•ﻌ•^ฅ loading" ]
+
+let not_found_el = [ el_txt "ฅ^•ﻌ•^ฅ not found" ]
+
+let mk_page_link ?label p =
+  let open Page in
+  let href = href (to_path p) in
+  let k = to_kind p in
+  let s = Kind.to_string k in
+  let label =
+    match label with
+    | Some label -> label
+    | None -> (
+      match Kind.to_emoji k with
+      | None -> s
+      | Some emoji -> Fmt.str "%s %s" emoji s )
+  in
+  El.a ~at:[ Fmt.kstr class' "%s-link" s; href ] [ el_txt label ]
+
+let is_page_kind k t = Page.(Kind.equal k (to_kind t.page))
+
+let mk_page kind t_s l =
+  let el =
+    let at = [ Fmt.kstr class' "%s-page" (Page.Kind.to_string kind) ] in
+    El.div ~at l
+  in
+  let is_on = S.map (is_page_kind kind) t_s in
+  def_on is_on el;
+  el
+
+let insert_br s =
+  match String.split_on_char '\n' s with
+  | [] -> []
+  | hd :: tl ->
+    List.rev
+    @@ List.fold_left
+         (fun acc x -> el_txt x :: El.br () :: acc)
+         [ el_txt hd ]
+         tl
+
+(* glorious CSS dropdown menu
+   - need to take mk_content and not just content because El.t are only added one time in DOM
+     -> or clone content
+   - need placeholder for correct style *)
+let mk_dropdown_menu ~class_prefix ~label ~at_title ~placeholder mk_content =
+  let mk_btn suffix =
+    let at =
+      [ Fmt.kstr class' "%s-dropdown%s" class_prefix suffix
+      ; Fmt.kstr class' "dropdown%s" suffix
+      ]
+    in
+    let arrow = El.span ~at:[ class' "dropdown-arrow" ] [ el_txt "▶" ] in
+    El.button ~at [ arrow; el_txt label ]
+  in
+  let mk_dropdown_content suffix =
+    let at =
+      [ Fmt.kstr class' "%s-dropdown-content%s" class_prefix suffix
+      ; Fmt.kstr class' "dropdown-content%s" suffix
+      ]
+    in
+    let l = mk_content () |> List.map (fun o -> El.li [ o ]) in
+    El.ul ~at l
+  in
+  let at =
+    [ Fmt.kstr class' "%s-dropdown" class_prefix
+    ; class' "dropdown"
+    ; At.title (str at_title)
+    ]
+  in
+  let l =
+    mk_btn "-open-btn"
+    :: (if placeholder then [ mk_dropdown_content "-placeholder" ] else [])
+    @ [ mk_dropdown_content ""; mk_btn "-close-btn" ]
+  in
+  El.div ~at l

src/client/leaflet_map.ml

@@ -0,0 +1,199 @@
+open Brr
+open Note
+open Leaflet
+open Util
+
+let geoloc_btn =
+  let s = "geolocalize-btn" in
+  El.button ~at:[ class' s; id s ] [ el_txt "Geolocalize me" ]
+
+let buttons =
+  let new_thread_link =
+    El.a ~at:[ href (Page.to_path New_thread) ] [ el_txt "New thread" ]
+  in
+  El.div ~at:[ class' "map-btn-div" ] [ new_thread_link; geoloc_btn ]
+
+let map_el = El.div ~at:[ id "map" ] []
+
+let map = Map.create_from_div map_el
+
+let set_view (lat, lng, zoom) =
+  let latlng = Latlng.create ~lat ~lng in
+  let zoom = Some zoom in
+  Map.set_view latlng ~zoom map;
+  ()
+
+let get_view () =
+  let latlng = Map.get_center map in
+  let lat = Latlng.lat latlng in
+  let lng = Latlng.lng latlng in
+  let zoom = Map.get_zoom map in
+  let wrapped_latlng = Map.wrap_latlng latlng map in
+  let is_wrapped = not @@ Latlng.equals latlng wrapped_latlng in
+  if is_wrapped then (
+    (* wrap coordinates so we don't drift into a parralel universe
+     and lose track of markers *)
+    let w_lat = Latlng.lat wrapped_latlng in
+    let w_lng = Latlng.lng wrapped_latlng in
+    set_view (w_lat, w_lng, zoom);
+    (w_lat, w_lng, zoom) )
+  else (lat, lng, zoom)
+
+(* todo better leaflet interface for open/close_popup? *)
+let open_popup content latlng =
+  let popup = Popup.create ~content:(Some content) ~latlng:(Some latlng) [||] in
+  Map.open_popup popup map
+
+let close_popup () = Map.close_popup None map
+
+let on_move_end f = Map.on Event.Move_end f map
+
+let on_zoom_end f = Map.on Event.Zoom_end f map
+
+let on_click f = Map.on Event.Click f map
+
+(* init map, setup events *)
+let () =
+  Note_brr.Elr.on_add
+    (fun () ->
+      Fmt.pr "leaflet map init@.";
+      let osm_layer = Layer.create_tile_osm [||] in
+      Layer.add_to map osm_layer;
+      set_view (Storage.init_map_view ()) )
+    map_el;
+  on_move_end (fun _ev ->
+      let o = get_view () in
+      Events.send_action (Map_input (Move_end o)) );
+  on_zoom_end (fun _ev ->
+      let o = get_view () in
+      Events.send_action (Map_input (Zoom_end o)) );
+  on_click (fun ev ->
+      let latlng =
+        (* TODO wrap/check it server side too *)
+        (* wrap it to avoid creating thread on wrong earth *)
+        let latlng = Event.latlng ev in
+        Map.wrap_latlng latlng map
+      in
+      let lat = Latlng.lat latlng in
+      let lng = Latlng.lng latlng in
+      Events.send_action (Map_input (Click_latlng (lat, lng))) );
+  (* TODO:
+     - show a loading animation until we get the geolocation
+     - show something in case of error
+     - add special marker on map *)
+  let geolocalize _ev =
+    let open Brr_io.Geolocation in
+    let l = of_navigator G.navigator in
+    let opts = opts ~high_accuracy:true () in
+    Events.send_action (Map_input Geoloc_start);
+    (* only get first Geoloc_pos for now
+       let _ : watch_id =
+         watch l ~opts (fun pos_res ->
+    *)
+    let _fut : unit Fut.t =
+      get l ~opts
+      |> Fut.map (fun pos_res ->
+             match pos_res with
+             | Error err -> Events.send_action (Map_input (Geoloc_err err))
+             | Ok pos ->
+               Events.send_action (Map_input (Geoloc_pos pos));
+               let lat = Pos.latitude pos in
+               let lng = Pos.longitude pos in
+               let zoom = 17 in
+               set_view (lat, lng, zoom);
+               Storage.set_map_view (lat, lng, zoom);
+               () )
+    in
+    ()
+  in
+  hold_on geoloc_btn Ev.click geolocalize;
+  ()
+
+let toggle_latlng_popup latlng_opt =
+  match latlng_opt with
+  | None -> close_popup ()
+  | Some (lat, lng) ->
+    (* TODO add a marker with special icon here *)
+    open_popup "create thread here" (Latlng.create ~lat ~lng)
+
+module Markers = struct
+  let icon mode =
+    (* TODO define in App *)
+    let default_url = "/assets/img/marker-icon.png" in
+    let default_icon = Icon.create default_url [||] in
+    let selected_icon = Icon.create default_url [||] in
+    match mode with `Selected -> selected_icon | `Normal -> default_icon
+
+  let selected_id = ref None
+
+  let select id_opt = selected_id := id_opt
+
+  let is_selected id =
+    match !selected_id with
+    | None -> false
+    | Some selected_id -> Int.equal selected_id id
+
+  let refresh =
+    let set_layer =
+      (* replace previous geojson layer: avoid stacking layers and handle thread deletion *)
+      let layer_ref = ref None in
+      fun layer ->
+        Option.iter (Layer.remove_from map) !layer_ref;
+        layer_ref := Some layer;
+        Layer.add_to map layer
+    in
+    let on_marker_click id =
+      Events.send_action (Map_input (Click_marker id));
+      Navigation.load (Thread (Loading id))
+    in
+    let spawn_marker geojsonpoint_feature latlng =
+      let id =
+        let feature_properties = Jv.get geojsonpoint_feature "properties" in
+        Jv.get feature_properties "id" |> Jv.to_int
+      in
+      let icon =
+        match is_selected id with
+        | false -> icon `Normal
+        | true -> icon `Selected
+      in
+      let marker = Marker.create latlng [| Icon icon |] in
+      Layer.on Event.Click (fun _ev -> on_marker_click id) marker;
+      marker
+    in
+    fun catalog ->
+      let geojson_res =
+        let open Types in
+        catalog
+        |> List.map (fun v -> (v.lat, v.lng, v.op.id))
+        |> Json_data.Write.geojson_markers |> Jstr.of_string |> Brr.Json.decode
+      in
+      match geojson_res with
+      | Error e ->
+        Fmt.failwith "Markers.refresh failure: geojson serialization error `%s`"
+          (Util.str_of_error e)
+      | Ok geojson ->
+        let layer =
+          Layer.create_geojson geojson [| Point_to_layer spawn_marker |]
+        in
+        set_layer layer
+end
+
+let f t_s =
+  let open Model in
+  S.map (fun t -> t.post_form.latlng) t_s
+  |> S.changes
+  |> hold_endless toggle_latlng_popup;
+  S.map (fun t -> t.page) t_s
+  |> S.changes
+  |> E.map (fun _ -> None)
+  |> hold_endless toggle_latlng_popup;
+  (* todo: refresh on selection change may be too much because we clear and re-add all markers *)
+  S.map (fun t -> t.catalog) t_s |> S.changes |> hold_endless Markers.refresh;
+  S.map get_thread_w_reply t_s
+  |> S.map (Option.map Page.unwrap_thread_id)
+  |> S.changes
+  |> hold_endless (fun id_opt ->
+         Markers.select id_opt;
+         Markers.refresh (S.value t_s).catalog );
+  let el = El.div ~at:[ class' "home-right" ] [ map_el; buttons ] in
+  el

src/client/main.ml

@@ -0,0 +1,24 @@
+open Brr
+open Note
+open Model
+
+let ui : t -> t signal * El.t list =
+ fun t ->
+  let def t_s =
+    let els = Html.f t_s in
+    let do_stuff =
+      let do_actions = E.map do_action Events.actions in
+      let do_data_updates = E.map do_data_update Events.data_updates in
+      let do_error_popup_updates = E.map do_error Events.errors in
+      E.select [ do_actions; do_data_updates; do_error_popup_updates ]
+    in
+    let t_s' = S.accum (S.value t_s) do_stuff in
+    (t_s', (t_s', els))
+  in
+  S.fix t def
+
+let () =
+  let t_s, els = ui (init ()) in
+  (* don't forget to hold model signal! *)
+  Logr.(hold @@ S.log t_s (fun (_ : Model.t) -> ()));
+  El.set_children Util.body els

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

src/client/navigation.ml

@@ -0,0 +1,98 @@
+(* TODO
+     - use navigation API when ready(?)
+       https://developer.mozilla.org/en-US/docs/Web/API/Navigation_API *)
+open Brr
+open Util
+
+let of_uri uri =
+  let page, frag = Page.of_uri uri in
+  let frag =
+    let open Client_types.Fragment in
+    match of_string frag with
+    | Error e ->
+      Fmt.epr "%s@." e;
+      Empty
+    | Ok v -> v
+  in
+  (page, frag)
+
+let go_to ~just_change_hash uri =
+  let open Window in
+  let history = history window in
+  History.push_state ~uri history;
+  let page, frag = of_uri uri in
+  let opt = match just_change_hash with true -> None | false -> Some page in
+  Events.send_action (Navigation_event (opt, frag));
+  ()
+
+let load p =
+  let uri = Page.to_uri p in
+  go_to ~just_change_hash:false uri;
+  ()
+
+let update_to_current_location () =
+  let uri = Window.location window in
+  let page, frag = of_uri uri in
+  Events.send_action (Navigation_event (Some page, frag));
+  ()
+
+let on_load () =
+  (* todo hold
+     only observe once; destroy logger after first event *)
+  hold_endless_on_window Ev.load (fun _ev -> update_to_current_location ());
+  ()
+
+let on_link_click () =
+  let handle_link href =
+    let open Window in
+    let is_local = String.starts_with ~prefix:"/" href in
+    let is_hash = String.starts_with ~prefix:"#" href in
+    if is_local || is_hash then
+      (* how to build uri correctly from just href..? *)
+      let href_jstr = Jstr.v href in
+      let uri =
+        let with_uri =
+          match is_local with
+          | true ->
+            let e = Jstr.v "" in
+            fun uri -> Uri.with_uri ~path:e ~query:e ~fragment:e uri
+          | false -> fun uri -> Uri.with_uri ~fragment:href_jstr uri
+        in
+        let base =
+          match with_uri (location window) with
+          | Error e ->
+            Fmt.failwith "on_link_click: with_uri error `%s`"
+              (Util.str_of_error e)
+          | Ok v -> Uri.to_jstr v
+        in
+        Uri.v ~base href_jstr
+      in
+      go_to ~just_change_hash:is_hash uri
+  in
+  let navigation_handler ev =
+    (* TODO rm magick if possible *)
+    let el : El.t = Obj.magic (Ev.target ev) in
+    begin
+      if Jstr.equal (El.tag_name el) (Jstr.v "a") then
+        match El.at (Jstr.v "href") el with
+        | None -> Fmt.failwith "<a> element with no href"
+        | Some href -> begin
+          Ev.prevent_default ev;
+          handle_link (Jstr.to_string href)
+        end
+    end
+  in
+  hold_on body Ev.click navigation_handler
+
+let on_pop_state () =
+  let open Window in
+  hold_endless_on_window History.Ev.popstate (fun _ev ->
+      update_to_current_location () );
+  ()
+
+(* setup navigation listeners *)
+let () =
+  on_load ();
+  on_link_click ();
+  on_pop_state ();
+  ()

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

src/client/page.ml

@@ -0,0 +1,193 @@
+open Types
+
+module Kind = struct
+  type t =
+    | Home
+    | New_thread
+    | Thread
+    | About
+    | Register
+    | Login
+    | Admin
+    | Profile
+    | Account
+    | User
+    | Delete
+    | Report
+
+  let equal : t -> t -> bool = fun a b -> Obj.magic a = Obj.magic b
+
+  let to_string = function
+    | Home -> "home"
+    | New_thread -> "new-thread"
+    | Thread -> "thread"
+    | About -> "about"
+    | Register -> "register"
+    | Login -> "login"
+    | Admin -> "administration"
+    | Profile -> "profile"
+    | Account -> "account"
+    | User -> "user"
+    | Delete -> "delete"
+    | Report -> "report"
+
+  let of_string s =
+    match s with
+    | "" | "home" -> Some Home
+    | "new-thread" -> Some New_thread
+    | "thread" -> Some Thread
+    | "about" -> Some About
+    | "register" -> Some Register
+    | "login" -> Some Login
+    | "administration" -> Some Admin
+    | "profile" -> Some Profile
+    | "account" -> Some Account
+    | "user" -> Some User
+    | "delete" -> Some Delete
+    | "report" -> Some Report
+    | _ -> None
+
+  let to_emoji = function
+    | Home -> Some "🗺️"
+    | About -> Some "🛸"
+    | Register -> Some "🍎"
+    | Login -> Some "🚪"
+    | Admin -> Some "🪄"
+    | Profile -> Some "🦩"
+    | Account -> Some "⚙"
+    | New_thread | Thread | User | Delete | Report -> None
+end
+
+type ('a, 'b) wrap =
+  | Loading of 'a
+  | Not_found of 'a
+  | Ready of 'b
+
+type t =
+  | Home
+  | New_thread
+  | Thread of (int, Thread_w_reply.t) wrap
+  | About
+  | Register
+  | Login
+  | Admin of (unit, report list) wrap
+  | Profile
+  | Account
+  | User of (user_id, user) wrap
+  | Delete of (post_id, post) wrap
+  | Report of (post_id, post) wrap
+
+let is_ready = function
+  | Home | New_thread | About | Register | Login | Profile | Account -> true
+  | Thread (Ready _)
+  | Admin (Ready _)
+  | User (Ready _)
+  | Delete (Ready _)
+  | Report (Ready _) ->
+    true
+  | _ -> false
+
+let unwrap_thread_id = function
+  | Loading v | Not_found v -> v
+  | Ready v -> v.Thread_w_reply.op.id
+
+let unwrap_post_id = function Loading v | Not_found v -> v | Ready v -> v.id
+
+let unwrap_user_id = function
+  | Loading v | Not_found v -> v
+  | Ready v -> v.user_id
+
+let to_kind = function
+  | Home -> Kind.Home
+  | New_thread -> New_thread
+  | Thread _ -> Thread
+  | About -> About
+  | Register -> Register
+  | Login -> Login
+  | Admin _ -> Admin
+  | Profile -> Profile
+  | Account -> Account
+  | User _ -> User
+  | Delete _ -> Delete
+  | Report _ -> Report
+
+(* TODO handle failure *)
+let of_uri =
+  let admin () = Admin (Loading ()) in
+  let user id = User (Loading id) in
+  let thread id = Thread (Loading id) in
+  let delete id = Delete (Loading id) in
+  let report id = Report (Loading id) in
+  let bind_int opt f = Option.bind opt int_of_string_opt |> Option.map f in
+  let of_kind ~item_id k =
+    match k with
+    | Kind.Home -> Some Home
+    | New_thread -> Some New_thread
+    | About -> Some About
+    | Register -> Some Register
+    | Login -> Some Login
+    | Profile -> Some Profile
+    | Account -> Some Account
+    | Admin -> Some (admin ())
+    | User -> item_id |> Option.map user
+    | Thread -> bind_int item_id thread
+    | Delete -> bind_int item_id delete
+    | Report -> bind_int item_id report
+  in
+  fun uri ->
+    let open Brr in
+    let segment_1, segment_2 =
+      let segments =
+        match Uri.path_segments uri with
+        | Error e ->
+          Fmt.failwith "Page.of_uri failure: path_segments error `%s`"
+            (Util.str_of_error e)
+        | Ok l -> List.map Jstr.to_string l
+      in
+      match segments with
+      | [] -> ("home", None)
+      | x :: [] -> (x, None)
+      | [ x; y ] -> (x, Some y)
+      | _ -> Fmt.failwith "Page.of_uri failure: invalid path segments"
+    in
+    match
+      Option.bind (Kind.of_string segment_1) (of_kind ~item_id:segment_2)
+    with
+    | None -> Fmt.failwith "Page.of_uri failure: invalid path format"
+    | Some page ->
+      let fragment_opt = uri |> Uri.fragment |> Jstr.to_string in
+      (page, fragment_opt)
+
+let to_path o =
+  let page_name = to_kind o |> Kind.to_string in
+  let param =
+    match o with
+    | Home | New_thread | About | Register | Login | Profile | Account -> None
+    | Admin _ -> None
+    | User v ->
+      let id = unwrap_user_id v in
+      Some id
+    | Thread v ->
+      let id = unwrap_thread_id v in
+      Some (string_of_int id)
+    | Delete v | Report v ->
+      let id = unwrap_post_id v in
+      Some (string_of_int id)
+  in
+  match param with
+  | None -> Fmt.str "/%s" page_name
+  | Some s -> Fmt.str "/%s/%s" page_name s
+
+let to_uri o =
+  let open Brr in
+  let uri =
+    (* clear query and fragment of the current uri *)
+    let empty_params = Uri.Params.of_jstr (Jstr.v "") in
+    let uri = Window.location G.window in
+    let uri = Uri.with_query_params uri empty_params in
+    Uri.with_fragment_params uri empty_params
+  in
+  let path = Jstr.v (to_path o) in
+  match Uri.with_uri ~path uri with
+  | Error e -> Fmt.failwith "%s" (Jv.of_error e |> Jv.to_string)
+  | Ok uri -> uri

src/client/storage.ml

@@ -0,0 +1,43 @@
+module Local = struct
+  open Brr
+  open Brr_io
+
+  let local = Storage.local G.window
+
+  let set k v =
+    match Storage.set_item local (Jstr.v k) (Jstr.v v) with
+    | (exception Jv.Error e) | Error e ->
+      Fmt.failwith "local storage failure `%s`" (Util.str_of_error e)
+    | Ok () -> ()
+
+  let get k = Storage.get_item local (Jstr.v k) |> Option.map Jstr.to_string
+
+  let clear () = Storage.clear local
+end
+
+let init_map_view () =
+  let default_map_view = (51.505, -0.09, 13) in
+  let lat = Local.get "lat" in
+  let lng = Local.get "lng" in
+  let zoom = Local.get "zoom" in
+  match (lat, lng, zoom) with
+  | Some lat, Some lng, Some zoom ->
+    let lat = lat |> Jstr.v |> Jstr.to_float in
+    let lng = lng |> Jstr.v |> Jstr.to_float in
+    let zoom =
+      match int_of_string_opt zoom with
+      | None -> Fmt.failwith "init_map_view: int_of_string failure on zoom"
+      | Some zoom -> zoom
+    in
+    (lat, lng, zoom)
+  | _ -> default_map_view
+
+let set_map_view (lat, lng, zoom) =
+  Local.set "lat" (string_of_float lat);
+  Local.set "lng" (string_of_float lng);
+  Local.set "zoom" (string_of_int zoom);
+  ()
+
+let clear () =
+  Local.clear ();
+  ()

src/client/util.ml

@@ -0,0 +1,89 @@
+open Brr
+
+let str = Jstr.v
+
+let str_of_error e = Jv.of_error e |> Jv.to_string
+
+(* redefine At module? *)
+let class' j = At.class' (str j)
+
+let id j = At.id (str j)
+
+let href j = At.href (str j)
+
+let src j = At.src (str j)
+
+let alt j = At.v (str "alt") (str j)
+
+let title j = At.title (str j)
+
+let type' j = At.type' (str j)
+
+let name j = At.name (str j)
+
+let value j = At.value (str j)
+
+let mk_at k v = At.v (str k) (str v)
+
+let el_txt s = El.txt (str s)
+
+let h1 s = El.h1 [ el_txt s ]
+
+let h2 s = El.h2 [ el_txt s ]
+
+let window = G.window
+
+let window_as_target = Window.as_target window
+
+let window_jv = Jv.get Jv.global "window"
+
+let window_width () = Jv.get window_jv "innerWidth" |> Jv.to_float
+
+let window_height () = Jv.get window_jv "innerHeight" |> Jv.to_float
+
+let document = G.document
+
+let document_as_target = Document.as_target document
+
+let body = Document.body document
+
+let find_html_el_by_id id =
+  Document.find_el_by_id G.document (Jstr.of_string id)
+
+let get_bounds el =
+  let x = El.bound_x el in
+  let y = El.bound_y el in
+  let w = El.bound_w el in
+  let h = El.bound_h el in
+  (x, y, w, h)
+
+let clamp ~min ~max x = Float.max (Float.min max x) min
+
+(* -- Note util -- *)
+open Note
+open Note_brr
+
+let def_off b_s el = Elr.def_class (str "off") b_s el
+
+let def_on b_s el = Elr.def_class (str "off") (S.map not b_s) el
+
+let def_disabled b_s el =
+  Elr.def_at At.Name.disabled
+    (S.map (function true -> Some (Jstr.v "") | false -> None) b_s)
+    el
+
+let hold_on el ev_type f =
+  let event = Evr.on_el ev_type Fun.id el in
+  Elr.may_hold_logr el (E.log event f);
+  ()
+
+let hold_event_on el event f =
+  Elr.may_hold_logr el (E.log event f);
+  ()
+
+let hold_endless f e = Logr.may_hold (E.log e f)
+
+let hold_endless_on_window ev_type f =
+  let event = Evr.on_target ev_type Fun.id window_as_target in
+  hold_endless f event;
+  ()