big squish

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