1 open Js_of_ocaml 2 open Lwt.Infix 3 4 let workout_selector = "[data-hito-workout-content]" 5 let app_selector = "[data-hito-app-shell]" 6 let document = Dom_html.document 7 let request_number = ref 0 8 9 let query_one root selector = 10 match Js.Opt.to_option (root##querySelector (Js.string selector)) with 11 | None -> None 12 | Some node -> Js.Opt.to_option (Dom_html.CoerceTo.element node) 13 14 let closest selector element = 15 match Js.Opt.to_option (element##closest (Js.string selector)) with 16 | None -> None 17 | Some node -> Js.Opt.to_option (Dom_html.CoerceTo.element node) 18 19 let set_busy busy = 20 match query_one document app_selector with 21 | Some shell -> 22 shell##setAttribute (Js.string "aria-busy") 23 (Js.string (if busy then "true" else "false")) 24 | None -> () 25 26 let fallback url = Dom_html.window##.location##assign (Js.string url) 27 28 let announce message = 29 match query_one document "[data-hito-workout-status]" with 30 | Some status -> status##.textContent := Js.some (Js.string message) 31 | None -> () 32 33 (* The early-workout toast. The server renders it visible so a no-JS visitor 34 still reads it. With script it is a transient notice: mark it shown, then 35 remove it after three seconds (WCAG 2.2.1 gives users time to read a brief 36 status). Idempotent: a toast already dismissed carries [data-hito-toast-done] 37 and is left alone, so a content swap never re-arms the same notice. *) 38 let dismiss_toast () = 39 match query_one document "[data-hito-toast]" with 40 | None -> () 41 | Some toast -> ( 42 match 43 Js.Opt.to_option 44 (toast##getAttribute (Js.string "data-hito-toast-done")) 45 with 46 | Some _ -> () 47 | None -> 48 toast##setAttribute (Js.string "data-hito-toast-done") (Js.string ""); 49 ignore 50 (Dom_html.window##setTimeout 51 (Js.wrap_callback (fun () -> 52 match Js.Opt.to_option toast##.parentNode with 53 | Some parent -> Dom.removeChild parent toast 54 | None -> ())) 55 (Js.number_of_float 3000.))) 56 57 (* The workout timer. The sticky bar carries the workout's start time as an 58 epoch in [data-started]. The elapsed time is computed from it, so a content 59 swap that re-renders the bar never resets the count. A single interval runs 60 at a time: [start_timer] clears the previous one before it reads the bar the 61 latest render produced. When no bar is present, the timer stops. *) 62 let timer_interval = ref None 63 64 let format_elapsed seconds = 65 let seconds = if seconds < 0 then 0 else seconds in 66 let minutes = seconds / 60 in 67 let secs = seconds mod 60 in 68 Printf.sprintf "%d:%02d" minutes secs 69 70 let tick () = 71 match query_one document "[data-hito-workout-timer]" with 72 | None -> () 73 | Some bar -> ( 74 match Js.Opt.to_option (bar##getAttribute (Js.string "data-started")) with 75 | None -> () 76 | Some started -> ( 77 (* Epoch seconds exceed js_of_ocaml's 31-bit [int] range, so the 78 start and the current time are kept as floats. Only the small 79 elapsed difference is narrowed to an [int]. Doing the subtraction 80 in [int] would overflow and yield a wrong count. *) 81 let started = 82 try float_of_string (String.trim (Js.to_string started)) 83 with _ -> 0. 84 in 85 let now = Js.to_float (new%js Js.date_now)##getTime /. 1000. in 86 let elapsed = int_of_float (now -. started) in 87 match query_one document "[data-hito-workout-timer-value]" with 88 | None -> () 89 | Some value -> 90 value##.textContent := 91 Js.some (Js.string (format_elapsed elapsed)))) 92 93 let start_timer () = 94 (match !timer_interval with 95 | Some id -> 96 Dom_html.window##clearInterval id; 97 timer_interval := None 98 | None -> ()); 99 match query_one document "[data-hito-workout-timer]" with 100 | None -> () 101 | Some _ -> 102 tick (); 103 let id = 104 Dom_html.window##setInterval 105 (Js.wrap_callback (fun () -> tick ())) 106 (Js.number_of_float 1000.) 107 in 108 timer_interval := Some id 109 110 let feedback_modal () = query_one document "[data-hito-feedback-modal]" 111 112 let open_feedback_modal () = 113 match feedback_modal () with 114 | None -> () 115 | Some modal -> 116 modal##removeAttribute (Js.string "open"); 117 ignore (Js.Unsafe.meth_call modal "showModal" [||]) 118 119 let close_feedback_modal () = 120 match feedback_modal () with 121 | None -> () 122 | Some modal -> ignore (Js.Unsafe.meth_call modal "close" [||]) 123 124 (* A generic modal keyed by id: [data-hito-dialog-open="id"] opens the dialog 125 with that id, and [data-hito-dialog-close] closes its nearest dialog. Used by 126 the profile page so username and password edits open in a modal, while a 127 no-script client still shows the same server-rendered form. *) 128 let open_dialog id = 129 match query_one document (Printf.sprintf "dialog#%s" id) with 130 | None -> () 131 | Some modal -> 132 modal##removeAttribute (Js.string "open"); 133 ignore (Js.Unsafe.meth_call modal "showModal" [||]) 134 135 let dialog_click event = 136 let target = Dom_html.eventTarget event in 137 match closest "[data-hito-dialog-open]" target with 138 | Some trigger -> ( 139 match 140 Js.Opt.to_option 141 (trigger##getAttribute (Js.string "data-hito-dialog-open")) 142 with 143 | None -> Js._true 144 | Some id -> 145 Dom.preventDefault event; 146 open_dialog (Js.to_string id); 147 Js._false) 148 | None -> ( 149 match closest "[data-hito-dialog-close]" target with 150 | None -> Js._true 151 | Some close -> ( 152 match closest "dialog" close with 153 | None -> Js._true 154 | Some modal -> 155 Dom.preventDefault event; 156 ignore (Js.Unsafe.meth_call modal "close" [||]); 157 Js._false)) 158 159 let open_marked_feedback_modal () = 160 match feedback_modal () with 161 | Some modal when Js.to_bool (modal##hasAttribute (Js.string "open")) -> 162 open_feedback_modal () 163 | _ -> () 164 165 let replace selector html = 166 let next = Dom_html.createDiv document in 167 next##.innerHTML := Js.string html; 168 match (query_one document selector, query_one next selector) with 169 | Some current, Some replacement -> 170 let parent = Js.Opt.get current##.parentNode (fun () -> assert false) in 171 Dom.replaceChild parent replacement current; 172 (match 173 Js.Opt.to_option 174 (replacement##getAttribute (Js.string "data-hito-page-title")) 175 with 176 | Some title -> document##.title := title 177 | None -> ()); 178 (match query_one document (selector ^ " h1, " ^ selector ^ " h2") with 179 | Some heading -> 180 heading##setAttribute (Js.string "tabindex") (Js.string "-1"); 181 heading##focus 182 | None -> ()); 183 (* No "Page updated" announcement: moving focus to the swapped-in heading 184 already tells assistive tech the content changed, so a status message 185 would be redundant noise. Transient "Loading"/"Saving" still clear when 186 the swap lands, because the fresh status node starts empty. *) 187 start_timer (); 188 dismiss_toast (); 189 open_marked_feedback_modal (); 190 true 191 | _ -> false 192 193 let replace_app = replace app_selector 194 let replace_workout = replace workout_selector 195 196 let push_url url = 197 Dom_html.window##.history##pushState 198 Js.null (Js.string "") 199 (Js.some (Js.string url)) 200 201 let get ?(push = false) ?(workout = false) url = 202 incr request_number; 203 let request = !request_number in 204 set_busy true; 205 announce "Loading"; 206 Js_of_ocaml_lwt.XmlHttpRequest.perform_raw_url ~with_credentials:true url 207 >>= fun response -> 208 let replace = if workout then replace_workout else replace_app in 209 if request <> !request_number then Lwt.return_unit 210 else ( 211 set_busy false; 212 if response.code >= 200 && response.code < 300 && replace response.content 213 then ( 214 if push then push_url url; 215 Lwt.return_unit) 216 else ( 217 fallback url; 218 Lwt.return_unit)) 219 220 let modified event = 221 Js.to_bool event##.metaKey 222 || Js.to_bool event##.ctrlKey 223 || Js.to_bool event##.shiftKey 224 || Js.to_bool event##.altKey 225 226 let href link = 227 Js.Opt.to_option (link##getAttribute (Js.string "href")) 228 |> Option.map Js.to_string 229 230 let link_click event = 231 if event##.button <> 0 || modified event then Js._true 232 else 233 match 234 closest "a[data-hito-app-link], a[data-hito-workout-link]" 235 (Dom_html.eventTarget event) 236 with 237 | None -> Js._true 238 | Some link -> ( 239 match href link with 240 | None -> Js._true 241 | Some url -> 242 Dom.preventDefault event; 243 let workout = 244 Js.to_bool 245 (link##hasAttribute (Js.string "data-hito-workout-link")) 246 in 247 Lwt.async (fun () -> get ~push:true ~workout url); 248 Js._false) 249 250 let slot_from_action action = 251 match List.rev (String.split_on_char '/' action) with 252 | "edit" :: slot :: _ | slot :: _ -> slot 253 | [] -> "" 254 255 let form_submit event = 256 match 257 closest "form[data-hito-app-form], form[data-hito-workout-form]" 258 (Dom_html.eventTarget event) 259 with 260 | None -> Js._true 261 | Some element -> ( 262 match Js.Opt.to_option (Dom_html.CoerceTo.form element) with 263 | None -> Js._true 264 | Some form when not (Js.to_bool form##checkValidity) -> Js._true 265 | Some form -> 266 let action = 267 match 268 Js.Opt.to_option (form##getAttribute (Js.string "action")) 269 with 270 | Some action -> Js.to_string action 271 | None -> "/" 272 in 273 incr request_number; 274 let request = !request_number in 275 let workout = 276 Js.to_bool (form##hasAttribute (Js.string "data-hito-workout-form")) 277 in 278 let feedback = 279 Js.to_bool 280 (form##hasAttribute (Js.string "data-hito-feedback-form")) 281 in 282 let submit = 283 match 284 Js.Opt.to_option 285 (form##querySelector (Js.string "input[type=submit]")) 286 with 287 | None -> None 288 | Some input -> Js.Opt.to_option (Dom_html.CoerceTo.input input) 289 in 290 Dom.preventDefault event; 291 Option.iter (fun input -> input##.disabled := Js._true) submit; 292 set_busy true; 293 announce "Saving"; 294 (* Dream.form accepts URL-encoded forms. FormData produces a 295 multipart request, which requires Dream.multipart instead. Keep 296 this shared client path URL-encoded because all app forms use 297 ordinary fields, including textareas. *) 298 let contents = 299 Form.get_form_contents form 300 |> List.map (fun (name, value) -> (name, `String (Js.string value))) 301 in 302 Lwt.async (fun () -> 303 Js_of_ocaml_lwt.XmlHttpRequest.perform_raw_url 304 ~with_credentials:true ~override_method:`POST 305 ~contents:(`POST_form contents) action 306 >>= fun response -> 307 if request <> !request_number then Lwt.return_unit 308 else ( 309 set_busy false; 310 Option.iter (fun input -> input##.disabled := Js._false) submit; 311 let replace = 312 if workout then replace_workout else replace_app 313 in 314 if response.code = 400 && replace response.content then 315 Lwt.return_unit 316 else if workout && response.code >= 200 && response.code < 300 317 then 318 get ~workout:true ("/workout?slot=" ^ slot_from_action action) 319 else if response.code < 500 && replace response.content then ( 320 if response.code >= 200 && response.code < 300 then 321 push_url response.url; 322 Lwt.return_unit) 323 else ( 324 fallback (if feedback then "/logbook" else action); 325 Lwt.return_unit))); 326 Js._false) 327 328 let popstate _ = 329 Lwt.async (fun () -> get (Js.to_string Dom_html.window##.location##.href)); 330 Js._true 331 332 (* The cancel confirmation modal. The cancel form submits directly without 333 script. With script, its submit is intercepted only to open a native dialog. 334 "Cancel workout" submits the native form as a full document POST. "Keep 335 logging" and Escape close the dialog. The dialog and the pending form are 336 found fresh on each click, so a content swap never leaves a stale 337 reference. *) 338 let confirm_modal () = query_one document "[data-hito-confirm-modal]" 339 340 let close_modal () = 341 match confirm_modal () with 342 | None -> () 343 | Some modal -> ignore (Js.Unsafe.meth_call modal "close" [||]) 344 345 let open_modal () = 346 match confirm_modal () with 347 | None -> () 348 | Some modal -> ignore (Js.Unsafe.meth_call modal "showModal" [||]) 349 350 let pending_confirm_form () = 351 match query_one document "[data-hito-confirm-form]" with 352 | None -> None 353 | Some element -> Js.Opt.to_option (Dom_html.CoerceTo.form element) 354 355 let confirm_click event = 356 let target = Dom_html.eventTarget event in 357 match closest "[data-hito-confirm-cancel]" target with 358 | Some _ -> 359 (* Opening the modal replaces immediate cancellation. *) 360 Dom.preventDefault event; 361 open_modal (); 362 Js._false 363 | None -> ( 364 match closest "[data-hito-confirm-dismiss]" target with 365 | Some _ -> 366 Dom.preventDefault event; 367 close_modal (); 368 Js._false 369 | None -> ( 370 match closest "[data-hito-confirm-accept]" target with 371 | Some _ -> ( 372 Dom.preventDefault event; 373 close_modal (); 374 match pending_confirm_form () with 375 | Some form -> 376 ignore (Js.Unsafe.meth_call form "requestSubmit" [||]); 377 Js._false 378 | None -> Js._false) 379 | None -> Js._true)) 380 381 (* The feedback flow uses the same native dialog behavior as workout 382 cancellation. The trigger remains a normal link, so no-script clients open 383 the server-rendered modal page instead. *) 384 let feedback_click event = 385 let target = Dom_html.eventTarget event in 386 match closest "[data-hito-feedback-open]" target with 387 | Some _ -> 388 Dom.preventDefault event; 389 open_feedback_modal (); 390 Js._false 391 | None -> ( 392 match closest "[data-hito-feedback-dismiss]" target with 393 | Some _ -> 394 Dom.preventDefault event; 395 close_feedback_modal (); 396 Js._false 397 | None -> ( 398 match closest "[data-hito-feedback-action]" target with 399 | None -> Js._true 400 | Some action -> ( 401 match closest "form" action with 402 | None -> Js._true 403 | Some form -> ( 404 match 405 Js.Opt.to_option 406 (form##getAttribute 407 (Js.string "data-hito-feedback-pending")) 408 with 409 | Some _ -> 410 Dom.preventDefault event; 411 Js._false 412 | None -> ( 413 match 414 Js.Opt.to_option 415 (action##getAttribute (Js.string "value")) 416 with 417 | None -> Js._true 418 | Some value -> ( 419 match 420 query_one form "[data-hito-feedback-action-value]" 421 with 422 | None -> Js._true 423 | Some hidden -> 424 form##setAttribute 425 (Js.string "data-hito-feedback-pending") 426 (Js.string ""); 427 hidden##setAttribute (Js.string "value") value; 428 Js._true)))))) 429 430 (* Selecting a score advances to the next factor without a separate Next 431 action. Handle click rather than change so selecting the current score again 432 follows the same path. Defer the submit by one event-loop tick so the browser 433 applies the radio value before form data is collected. *) 434 let feedback_choice event = 435 match closest "[data-hito-feedback-choice]" (Dom_html.eventTarget event) with 436 | None -> Js._true 437 | Some choice -> ( 438 match closest "form" choice with 439 | None -> Js._true 440 | Some form -> ( 441 match 442 Js.Opt.to_option 443 (form##getAttribute (Js.string "data-hito-feedback-pending")) 444 with 445 | Some _ -> Js._false 446 | None -> ( 447 match query_one form "[data-hito-feedback-action-value]" with 448 | None -> Js._true 449 | Some hidden -> 450 form##setAttribute 451 (Js.string "data-hito-feedback-pending") 452 (Js.string ""); 453 ignore 454 (Dom_html.window##setTimeout 455 (Js.wrap_callback (fun () -> 456 hidden##setAttribute (Js.string "value") 457 (Js.string "next"); 458 ignore 459 (Js.Unsafe.meth_call form "requestSubmit" [||]))) 460 (Js.number_of_float 0.)); 461 Js._true))) 462 463 (* The exercise dropdown navigates the moment its selection changes. It lives in 464 a GET form ([data-hito-exercise-form]) that submits to the workout path. The 465 client turns a change into a workout-scoped content swap to [?slot=N], so no 466 submit click is needed. Without script the form's submit button still works. *) 467 let exercise_change event = 468 match closest "[data-hito-exercise-form]" (Dom_html.eventTarget event) with 469 | None -> Js._true 470 | Some form -> ( 471 let action = 472 match Js.Opt.to_option (form##getAttribute (Js.string "action")) with 473 | Some action -> Js.to_string action 474 | None -> "/workout" 475 in 476 match query_one form "[data-hito-exercise-select]" with 477 | None -> Js._true 478 | Some node -> ( 479 match Js.Opt.to_option (Dom_html.CoerceTo.select node) with 480 | None -> Js._true 481 | Some select -> 482 let slot = Js.to_string select##.value in 483 Dom.preventDefault event; 484 Lwt.async (fun () -> get ~workout:true (action ^ "?slot=" ^ slot)); 485 Js._false)) 486 487 let () = 488 Dom_html.addEventListener document Dom_html.Event.click 489 (Dom_html.handler link_click) 490 Js._false 491 |> ignore; 492 Dom_html.addEventListener document Dom_html.Event.submit 493 (Dom_html.handler form_submit) 494 Js._false 495 |> ignore; 496 Dom_html.addEventListener document Dom_html.Event.click 497 (Dom_html.handler feedback_click) 498 Js._false 499 |> ignore; 500 Dom_html.addEventListener document Dom_html.Event.click 501 (Dom_html.handler dialog_click) 502 Js._false 503 |> ignore; 504 Dom_html.addEventListener document Dom_html.Event.click 505 (Dom_html.handler feedback_choice) 506 Js._false 507 |> ignore; 508 Dom_html.addEventListener document Dom_html.Event.change 509 (Dom_html.handler exercise_change) 510 Js._false 511 |> ignore; 512 Dom_html.addEventListener document Dom_html.Event.click 513 (Dom_html.handler confirm_click) 514 Js._false 515 |> ignore; 516 Dom_html.addEventListener Dom_html.window Dom_html.Event.popstate 517 (Dom_html.handler popstate) 518 Js._false 519 |> ignore; 520 (* Background tabs throttle [setInterval], so the elapsed count can lag while 521 the tab is hidden. Tick once the moment the tab is shown again, so the 522 timer catches up at once rather than after the next throttled interval. *) 523 Dom_html.addEventListener document 524 (Dom_html.Event.make "visibilitychange") 525 (Dom_html.handler (fun _ -> 526 tick (); 527 Js._true)) 528 Js._false 529 |> ignore; 530 (* Mark the document as script-enhanced so CSS can hide no-JS fallbacks such 531 as the exercise-selector submit button. Set only once the client runs, so 532 a no-JS visitor keeps every fallback. *) 533 document##.documentElement##setAttribute 534 (Js.string "data-hito-js") (Js.string "on"); 535 (* Retry startup after the document is ready. This is idempotent because 536 [start_timer] clears any prior interval before it reads the current timer. *) 537 Dom_html.addEventListener document Dom_html.Event.domContentLoaded 538 (Dom_html.handler (fun _ -> 539 start_timer (); 540 Js._true)) 541 Js._false 542 |> ignore; 543 start_timer (); 544 dismiss_toast () 545