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_visibility `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