[@@@ocaml.warning "-26-27"] open Melange_json.Primitives open React module Aria = ReactAria let cimd_suffix_len = String.length "/oauth-client-metadata.json" type actor = AccountSwitcher.actor = {did: string; handle: string; avatar_data_uri: string option [@default None]} [@@deriving json] type permission_set_display = { nsid: string ; title: string option [@default None] ; detail: string option [@default None] ; expanded_scopes: string list } [@@deriving json] type props = { client_url: string * string (* (host, path) *) ; client_name: string option [@default None] ; logo_uri: string option [@default None] ; current_user: actor ; logged_in_users: actor list ; scopes: string list ; permission_sets: permission_set_display list [@default []] ; code: string ; request_uri: string ; csrf_token: string } [@@deriving json] module ScopesTable = struct type repo_action = Create | Update | Delete type parsed_repo_scope = {collections: string list; actions: repo_action list} type parsed_rpc_scope = {lxm: string; aud: string} type parsed_scope = | Email of [`Read | `Manage] | Identity of [`Handle | `Full] | Repo of parsed_repo_scope | Rpc of parsed_rpc_scope | Blob of string list (* mimetypes *) | Bluesky (* transition:generic or app.bsky.* *) | Chat (* transition:chat.bsky or chat.bsky.* *) | Atproto | PermissionSet of { nsid: string ; title: string option ; detail: string option ; expanded_scopes: string list (* raw scope strings for display *) } | Unknown of string let parse_scope scope = if scope = "atproto" then Atproto else if scope = "transition:generic" then Bluesky else if scope = "transition:chat.bsky" then Chat else if scope = "transition:email" then Email `Read else if String.starts_with ~prefix:"account:" scope || String.starts_with ~prefix:"account?" scope then let has_positional = String.starts_with ~prefix:"account:" scope in let rest = String.sub scope 8 (String.length scope - 8) in let parts = String.split_on_char '?' rest in let positional_attr = if has_positional then match parts with a :: _ when a <> "" -> Some a | _ -> None else None in let query_str = if has_positional then if List.length parts > 1 then Some (List.nth parts 1) else None else if rest <> "" then Some rest else None in let parse_query_params qs = String.split_on_char '&' qs |> List.filter_map (fun pair -> match String.split_on_char '=' pair with | [k; v] -> Some (k, v) | _ -> None ) in let params = Option.map parse_query_params query_str |> Option.value ~default:[] in let attr = match positional_attr with | Some a -> a | None -> List.find_map (fun (k, v) -> if k = "attr" then Some v else None) params |> Option.value ~default:"" in let action = List.find_map (fun (k, v) -> if k = "action" then Some v else None) params |> Option.value ~default:"read" in if attr = "email" then if action = "manage" then Email `Manage else Email `Read else Unknown scope (* repo and other attrs not displayed specially *) else if String.starts_with ~prefix:"identity:" scope || String.starts_with ~prefix:"identity?" scope then (* attrs are "handle" or "*" *) let has_positional = String.starts_with ~prefix:"identity:" scope in let rest = String.sub scope 9 (String.length scope - 9) in let parts = String.split_on_char '?' rest in let positional_attr = if has_positional then match parts with a :: _ when a <> "" -> Some a | _ -> None else None in let attr = match positional_attr with | Some a -> a | None -> let params = if has_positional then if List.length parts > 1 then List.nth parts 1 else "" else rest in String.split_on_char '&' params |> List.find_map (fun pair -> match String.split_on_char '=' pair with | [k; v] when k = "attr" -> Some v | _ -> None ) |> Option.value ~default:"handle" in if attr = "*" then Identity `Full else Identity `Handle else if String.starts_with ~prefix:"repo:" scope || String.starts_with ~prefix:"repo?" scope then let has_positional = String.starts_with ~prefix:"repo:" scope in let rest = String.sub scope 5 (String.length scope - 5) in let parts = String.split_on_char '?' rest in let positional_coll = if has_positional then match parts with coll :: _ when coll <> "" -> Some coll | _ -> None else None in let query_str = if has_positional then if List.length parts > 1 then Some (List.nth parts 1) else None else if (* for repo?... format, rest starts with the query string *) rest <> "" then Some rest else None in let parse_query_params qs = String.split_on_char '&' qs |> List.filter_map (fun pair -> match String.split_on_char '=' pair with | [k; v] -> Some (k, v) | _ -> None ) in let params = Option.map parse_query_params query_str |> Option.value ~default:[] in let collection = match positional_coll with | Some c -> [c] | None -> ( List.filter_map (fun (k, v) -> if k = "collection" then Some v else None) params |> function [] -> ["*"] | cols -> cols ) in let actions = let action_strs = List.filter_map (fun (k, v) -> if k = "action" then Some v else None) params |> List.concat_map (String.split_on_char ',') in if action_strs = [] then [Create; Update; Delete] else List.filter_map (fun a -> match a with | "create" -> Some Create | "update" -> Some Update | "delete" -> Some Delete | _ -> None ) action_strs |> function [] -> [Create; Update; Delete] | l -> l in if List.exists (fun c -> String.starts_with ~prefix:"app.bsky." c || String.starts_with ~prefix:"chat.bsky." c ) collection then if List.exists (fun c -> String.starts_with ~prefix:"chat.bsky." c) collection then Chat else Bluesky else Repo {collections= collection; actions} else if String.starts_with ~prefix:"rpc:" scope || String.starts_with ~prefix:"rpc?" scope then let has_positional = String.starts_with ~prefix:"rpc:" scope in let rest = String.sub scope 4 (String.length scope - 4) in let parts = String.split_on_char '?' rest in let positional_lxm = if has_positional then match parts with l :: _ when l <> "" -> Some l | _ -> None else None in let query_str = if has_positional then if List.length parts > 1 then Some (List.nth parts 1) else None else if rest <> "" then Some rest else None in let parse_query_params qs = String.split_on_char '&' qs |> List.filter_map (fun pair -> match String.split_on_char '=' pair with | [k; v] -> Some (k, v) | _ -> None ) in let params = Option.map parse_query_params query_str |> Option.value ~default:[] in let lxm = match positional_lxm with | Some l -> l | None -> List.find_map (fun (k, v) -> if k = "lxm" then Some v else None) params |> Option.value ~default:"*" in let aud = List.find_map (fun (k, v) -> if k = "aud" then Some v else None) params |> Option.value ~default:"*" in if String.starts_with ~prefix:"app.bsky." lxm then Bluesky else if String.starts_with ~prefix:"chat.bsky." lxm then Chat else Rpc {lxm; aud} else if String.starts_with ~prefix:"blob:" scope || String.starts_with ~prefix:"blob?" scope then let has_positional = String.starts_with ~prefix:"blob:" scope in let rest = String.sub scope 5 (String.length scope - 5) in let mimetypes = if has_positional then [rest] else String.split_on_char '&' rest |> List.filter_map (fun pair -> match String.split_on_char '=' pair with | [k; v] when k = "accept" -> Some v | _ -> None ) in Blob (if mimetypes = [] then ["*/*"] else mimetypes) else Unknown scope (* parse repo scope string without converting app.bsky/chat.bsky to Bluesky/Chat *) let parse_repo_scope_raw scope = if String.starts_with ~prefix:"repo:" scope || String.starts_with ~prefix:"repo?" scope then let has_positional = String.starts_with ~prefix:"repo:" scope in let rest = String.sub scope 5 (String.length scope - 5) in let parts = String.split_on_char '?' rest in let positional_coll = if has_positional then match parts with coll :: _ when coll <> "" -> Some coll | _ -> None else None in let query_str = if has_positional then if List.length parts > 1 then Some (List.nth parts 1) else None else if rest <> "" then Some rest else None in let parse_query_params qs = String.split_on_char '&' qs |> List.filter_map (fun pair -> match String.split_on_char '=' pair with | [k; v] -> Some (k, v) | _ -> None ) in let params = Option.map parse_query_params query_str |> Option.value ~default:[] in let collection = match positional_coll with | Some c -> [c] | None -> ( List.filter_map (fun (k, v) -> if k = "collection" then Some v else None) params |> function [] -> ["*"] | cols -> cols ) in let actions = let action_strs = List.filter_map (fun (k, v) -> if k = "action" then Some v else None) params |> List.concat_map (String.split_on_char ',') in if action_strs = [] then [Create; Update; Delete] else List.filter_map (fun a -> match a with | "create" -> Some Create | "update" -> Some Update | "delete" -> Some Delete | _ -> None ) action_strs |> function [] -> [Create; Update; Delete] | l -> l in Some {collections= collection; actions} else None type collection_actions = {create: bool; update: bool; delete: bool} module StringMap = Map.Make (String) let build_collection_actions_map repos = List.fold_left (fun acc r -> List.fold_left (fun acc coll -> let existing = StringMap.find_opt coll acc |> Option.value ~default:{create= false; update= false; delete= false} in let updated = { create= existing.create || List.mem Create r.actions ; update= existing.update || List.mem Update r.actions ; delete= existing.delete || List.mem Delete r.actions } in StringMap.add coll updated acc ) acc r.collections ) StringMap.empty repos let build_aud_lxms_map rpcs = List.fold_left (fun acc r -> let existing = StringMap.find_opt r.aud acc |> Option.value ~default:[] in let lxms = if List.mem r.lxm existing then existing else r.lxm :: existing in StringMap.add r.aud lxms acc ) StringMap.empty rpcs let merge_parsed_scopes scopes = let email = ref None in let identity = ref None in let repos = ref [] in let rpcs = ref [] in let blobs = ref [] in let has_bluesky = ref false in let has_chat = ref false in let unknowns = ref [] in List.iter (fun scope -> match parse_scope scope with | Email `Manage -> email := Some `Manage | Email `Read -> if !email = None then email := Some `Read | Identity `Full -> identity := Some `Full | Identity `Handle -> if !identity = None then identity := Some `Handle | Repo r -> repos := r :: !repos | Rpc r -> rpcs := r :: !rpcs | Blob mimes -> blobs := mimes @ !blobs | Bluesky -> has_bluesky := true | Chat -> has_chat := true | Atproto -> () | PermissionSet _ -> () | Unknown s -> unknowns := s :: !unknowns ) scopes ; ( !email , !identity , !repos , !rpcs , !blobs , !has_bluesky , !has_chat , !unknowns ) let[@react.component] make ~scopes ?(permission_sets = []) () = let email, identity, repos, rpcs, blobs, has_bluesky, has_chat, unknowns = merge_parsed_scopes scopes in let ps_displays = List.map (fun (ps : permission_set_display) -> PermissionSet { nsid= ps.nsid ; title= ps.title ; detail= ps.detail ; expanded_scopes= ps.expanded_scopes } ) permission_sets in
( match email with | Some level ->
(string "email")
(string ( if level = `Manage then "Read and update your account's email address" else "Read your account's email address" ) )
| None -> null ) ( match identity with | Some level ->
(string "identity")
(string ( if level = `Full then "Manage your full identity including your @handle, with \ the ability to move your account to another PDS or \ permanently lock you out of your account." else "Change your @handle" ) )
| None -> null ) ( if has_bluesky then
(string "bluesky")
(string "Manage your profile, posts, likes and follows")
else null ) ( if has_chat then
(string "chat")
(string "Read and send messages")
else null ) ( if List.length repos > 0 then let coll_actions_map = build_collection_actions_map repos in let coll_actions_list = StringMap.bindings coll_actions_map |> List.sort (fun (a, _) (b, _) -> String.compare a b) in let star_actions = StringMap.find_opt "*" coll_actions_map in let has_full_access = match star_actions with | Some a -> a.create && a.update && a.delete | None -> false in
(string "repository")
(string ( if has_full_access then "Create, update, and delete any public record" else "Publish changes to your repository" ) )
( if not has_full_access then ( coll_actions_list |> List.map (fun (coll, actions) -> let star_create = Option.map (fun a -> a.create) star_actions |> Option.value ~default:false in let star_update = Option.map (fun a -> a.update) star_actions |> Option.value ~default:false in let star_delete = Option.map (fun a -> a.delete) star_actions |> Option.value ~default:false in ) |> Array.of_list |> array )
(string "Collection") (string "Create") (string "Update") (string "Delete")
(string ( if coll = "*" then "Any collection" else coll ) ) ( if star_create || actions.create then (string {js|✓|js}) else null ) ( if star_update || actions.update then (string {js|✓|js}) else null ) ( if star_delete || actions.delete then (string {js|✓|js}) else null )
else null )
else null ) ( if List.length rpcs > 0 then let aud_lxms_map = build_aud_lxms_map rpcs in let aud_lxms_list = StringMap.bindings aud_lxms_map |> List.map (fun (aud, lxms) -> let sorted_lxms = if List.mem "*" lxms then ["*"] else List.sort String.compare lxms in (aud, sorted_lxms) ) |> List.sort (fun (a, _) (b, _) -> String.compare a b) in let has_full_access = List.exists (fun (aud, lxms) -> aud = "*" && List.mem "*" lxms) aud_lxms_list in
(string "authenticate")
(string ( if has_full_access then "Act on your behalf towards any service" else "Perform actions on your behalf" ) )
( if not has_full_access then ( aud_lxms_list |> List.concat_map (fun (aud, lxms) -> let render_aud () = if aud = "*" then (string "Any service") else if String.starts_with ~prefix:"did:web:api.bsky.app#" aud then (string "Bluesky services") else if String.starts_with ~prefix:"did:web:api.bsky.chat#" aud then (string "Bluesky chat services") else if String.starts_with ~prefix:"did:web:" aud && String.contains aud '#' then let domain = String.sub aud 8 (String.index aud '#' - 8) in (string ("Service by " ^ domain)) else (string aud) in List.map (fun lxm -> ) lxms ) |> Array.of_list |> array )
(string "Method") (string "Service")
(string (if lxm = "*" then "Any method" else lxm) ) (render_aud ())
else null )
else null ) ( if List.length blobs > 0 then
(string "file upload")
(string ( if List.mem "*/*" blobs then "Upload any files" else "Upload files to your repository" ) )
else null ) ( if List.length unknowns > 0 then
(string "other permissions")
( unknowns |> List.map (fun s -> (string s) ) |> Array.of_list |> array )
else null ) (* permission sets *) ( List.map (fun ps -> match ps with | PermissionSet {nsid; title; detail; expanded_scopes} -> let repos = List.filter_map parse_repo_scope_raw expanded_scopes in let coll_actions_map = build_collection_actions_map repos in let coll_actions_list = StringMap.bindings coll_actions_map |> List.sort (fun (a, _) (b, _) -> String.compare a b) in
(string (Option.value title ~default:nsid))
( match detail with | Some d ->
(string d)
| None -> null ) ( if List.length coll_actions_list > 0 then ( coll_actions_list |> List.map (fun (coll, actions) -> ) |> Array.of_list |> array )
(string "Collection") (string "Create") (string "Update") (string "Delete")
(string ( if coll = "*" then "Any collection" else coll ) ) ( if actions.create then (string {js|✓|js}) else null ) ( if actions.update then (string {js|✓|js}) else null ) ( if actions.delete then (string {js|✓|js}) else null )
else null )
| _ -> null ) ps_displays |> Array.of_list |> React.array )
end let[@react.component] make ~props: ({ client_url ; client_name ; logo_uri ; current_user ; logged_in_users ; scopes ; permission_sets ; code ; request_uri ; csrf_token } : props ) () = let host, path = client_url in let rendered_name = match client_name with | Some client_name -> (string client_name) (string (" (" ^ host ^ ")")) | None when String.length path = 0 -> (string host) | None -> (string host) (string path) in let query_string = match%platform Runtime.platform with | Server -> "" | Client -> Webapi.Dom.Location.search Webapi.Dom.location in let add_account_url = "/account/login" ^ query_string in let favicon_url, set_favicon_url = useState (fun () -> Option.value logo_uri ~default:("https://" ^ host ^ "/favicon.ico") ) in

(string ("authorizing " ^ host))

(string "You're signing into ") ( if favicon_url <> "" then set_favicon_url (fun _ -> "")) /> else null ) rendered_name (string " as ") (string " and granting it the following permissions:")