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