add depends

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