geochan/src/client/page.ml

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