···706 remove p json
707 in
708 Jsont.map Jsont.json ~dec ~enc:(fun j -> j)
0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
···706 remove p json
707 in
708 Jsont.map Jsont.json ~dec ~enc:(fun j -> j)
709+710+(* JMAP Extended Pointers - RFC 8620 Section 3.7 *)
711+module Jmap = struct
712+ (* Extended segment type: regular tokens or wildcard *)
713+ type segment =
714+ | Token of string (* Unescaped reference token *)
715+ | Wildcard (* The * token for array mapping *)
716+717+ type t = segment list
718+719+ let parse_segments s =
720+ if s = "" then []
721+ else if s.[0] <> '/' then
722+ Jsont.Error.msgf Jsont.Meta.none
723+ "Invalid JMAP Pointer: must be empty or start with '/': %s" s
724+ else
725+ let rest = String.sub s 1 (String.length s - 1) in
726+ let tokens = String.split_on_char '/' rest in
727+ List.map (fun tok ->
728+ if tok = "*" then Wildcard
729+ else if tok = "-" then
730+ Jsont.Error.msgf Jsont.Meta.none
731+ "Invalid JMAP Pointer: '-' not supported in result reference paths"
732+ else Token (Token.unescape tok)
733+ ) tokens
734+735+ let of_string s = parse_segments s
736+737+ let of_string_result s =
738+ try Ok (of_string s)
739+ with Jsont.Error e -> Error (Jsont.Error.to_string e)
740+741+ let segment_to_string = function
742+ | Token s -> Token.escape s
743+ | Wildcard -> "*"
744+745+ let to_string p =
746+ if p = [] then ""
747+ else
748+ let b = Buffer.create 64 in
749+ List.iter (fun seg ->
750+ Buffer.add_char b '/';
751+ Buffer.add_string b (segment_to_string seg)
752+ ) p;
753+ Buffer.contents b
754+755+ let pp ppf p = Format.pp_print_string ppf (to_string p)
756+757+ (* Evaluation with wildcard support *)
758+ let rec eval_segments segments json =
759+ match segments with
760+ | [] -> json
761+ | Wildcard :: rest ->
762+ (* Wildcard: map through array, flatten results *)
763+ (match json with
764+ | Jsont.Array (elements, meta) ->
765+ let results = List.map (eval_segments rest) elements in
766+ (* Flatten: if a result is an array, inline its contents *)
767+ let flattened = List.concat_map (function
768+ | Jsont.Array (elems, _) -> elems
769+ | other -> [other]
770+ ) results in
771+ Jsont.Array (flattened, meta)
772+ | _ ->
773+ Jsont.Error.msgf (Jsont.Json.meta json)
774+ "JMAP Pointer: '*' can only be used on arrays, got %s"
775+ (json_sort_string json))
776+ | Token token :: rest ->
777+ (* Standard token: navigate into object or array *)
778+ (match json with
779+ | Jsont.Object (members, _) ->
780+ (match get_member token members with
781+ | Some (_, value) -> eval_segments rest value
782+ | None ->
783+ Jsont.Error.msgf (Jsont.Json.meta json)
784+ "JMAP Pointer: member '%s' not found" token)
785+ | Jsont.Array (elements, _) ->
786+ (match Token.is_valid_array_index token with
787+ | Some n ->
788+ (match get_nth n elements with
789+ | Some value -> eval_segments rest value
790+ | None ->
791+ Jsont.Error.msgf (Jsont.Json.meta json)
792+ "JMAP Pointer: index %d out of bounds (array has %d elements)"
793+ n (List.length elements))
794+ | None ->
795+ Jsont.Error.msgf (Jsont.Json.meta json)
796+ "JMAP Pointer: invalid array index '%s'" token)
797+ | _ ->
798+ Jsont.Error.msgf (Jsont.Json.meta json)
799+ "JMAP Pointer: cannot index into %s with '%s'"
800+ (json_sort_string json) token)
801+802+ let eval p json = eval_segments p json
803+804+ let eval_result p json =
805+ try Ok (eval p json)
806+ with Jsont.Error e -> Error e
807+808+ let find p json =
809+ try Some (eval p json)
810+ with Jsont.Error _ -> None
811+812+ let jsont : t Jsont.t =
813+ let dec _meta s = of_string s in
814+ let enc p = to_string p in
815+ Jsont.Base.string (Jsont.Base.map
816+ ~kind:"JMAP Pointer"
817+ ~doc:"RFC 8620 JMAP extended JSON Pointer"
818+ ~dec ~enc ())
819+820+ (* Query combinators *)
821+822+ let path ?absent p codec =
823+ let dec json =
824+ match find p json with
825+ | Some extracted ->
826+ (match Jsont.Json.decode' codec extracted with
827+ | Ok v -> v
828+ | Error e -> raise (Jsont.Error e))
829+ | None ->
830+ match absent with
831+ | Some v -> v
832+ | None ->
833+ Jsont.Error.msgf Jsont.Meta.none
834+ "JMAP Pointer %s: path not found" (to_string p)
835+ in
836+ Jsont.map Jsont.json ~dec ~enc:(fun _ ->
837+ Jsont.Error.msgf Jsont.Meta.none "Jmap.path: encode not supported")
838+839+ let path_list p elem_codec =
840+ path p (Jsont.list elem_codec)
841+end
+101
src/jsont_pointer.mli
···423424 If [allow_absent] is [true] (default [false]), does nothing if
425 the pointer doesn't resolve instead of raising. *)
00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
···423424 If [allow_absent] is [true] (default [false]), does nothing if
425 the pointer doesn't resolve instead of raising. *)
426+427+(** {1:jmap JMAP Extended Pointers}
428+429+ {{:https://www.rfc-editor.org/rfc/rfc8620#section-3.7}RFC 8620 Section 3.7}
430+ extends JSON Pointer with a wildcard token [*] for mapping through arrays.
431+ This is used in JMAP result references.
432+433+ The wildcard semantics are:
434+ {ul
435+ {- When the current value is an array and the token is [*], apply the rest
436+ of the pointer to each element, collecting results into a new array.}
437+ {- If a mapped result is itself an array, its contents are flattened into
438+ the output (i.e., array of arrays becomes a single array).}}
439+440+ Example: Given [{"list": \[{"id": "a"}, {"id": "b"}\]}], the extended
441+ pointer [/list/*/id] evaluates to [["a", "b"]].
442+443+ {b Note}: These extended pointers are {e not} valid RFC 6901 JSON Pointers.
444+ They should only be used for JMAP result reference resolution. *)
445+446+module Jmap : sig
447+ (** JMAP extended JSON Pointer with wildcard support. *)
448+449+ type t
450+ (** The type for JMAP extended pointers. Unlike standard pointers, these
451+ may contain [*] tokens for array mapping. *)
452+453+ val of_string : string -> t
454+ (** [of_string s] parses a JMAP extended pointer.
455+456+ The syntax is the same as RFC 6901 JSON Pointer, except [*] is allowed
457+ as a reference token for array mapping.
458+459+ @raise Jsont.Error if [s] has invalid syntax. *)
460+461+ val of_string_result : string -> (t, string) result
462+ (** [of_string_result s] is like {!of_string} but returns a result. *)
463+464+ val to_string : t -> string
465+ (** [to_string p] serializes [p] to string form. *)
466+467+ val pp : Format.formatter -> t -> unit
468+ (** [pp] formats a pointer using {!to_string}. *)
469+470+ val eval : t -> Jsont.json -> Jsont.json
471+ (** [eval p json] evaluates the extended pointer [p] against [json].
472+473+ For [*] tokens on arrays, maps through all elements and collects results.
474+ Results that are arrays are flattened into the output.
475+476+ @raise Jsont.Error if:
477+ - A standard token doesn't resolve (member not found, index out of bounds)
478+ - [*] is used on a non-array value
479+ - [-] appears in the pointer (not supported in JMAP extended pointers) *)
480+481+ val eval_result : t -> Jsont.json -> (Jsont.json, Jsont.Error.t) result
482+ (** [eval_result p json] is like {!eval} but returns a result. *)
483+484+ val find : t -> Jsont.json -> Jsont.json option
485+ (** [find p json] is like {!eval} but returns [None] on errors. *)
486+487+ val jsont : t Jsont.t
488+ (** [jsont] is a {!Jsont.t} codec for JMAP extended pointers. *)
489+490+ (** {2:combinators Query combinators}
491+492+ These combinators integrate JMAP extended pointers with jsont codecs,
493+ enabling typed extraction from JSON using pointer paths. *)
494+495+ val path : ?absent:'a -> t -> 'a Jsont.t -> 'a Jsont.t
496+ (** [path p codec] extracts the value at pointer [p] and decodes it with [codec].
497+498+ If [absent] is provided and the pointer doesn't resolve, returns [absent].
499+ Otherwise raises on pointer resolution failure.
500+501+ Example: Extract all thread IDs from an Email/get response:
502+ {[
503+ let thread_ids =
504+ Jmap.path
505+ (Jmap.of_string "/list/*/threadId")
506+ (Jsont.list Jsont.string)
507+ ]}
508+509+ @raise Jsont.Error if the pointer fails to resolve (and no [absent])
510+ or if decoding with [codec] fails. *)
511+512+ val path_list : t -> 'a Jsont.t -> 'a list Jsont.t
513+ (** [path_list p codec] extracts the array at pointer [p] and decodes each
514+ element with [codec].
515+516+ This is a convenience for the common JMAP pattern where wildcards produce
517+ arrays that need element-wise decoding:
518+ {[
519+ (* These are equivalent: *)
520+ Jmap.path_list (Jmap.of_string "/list/*/id") Jsont.string
521+ Jmap.path (Jmap.of_string "/list/*/id") (Jsont.list Jsont.string)
522+ ]}
523+524+ @raise Jsont.Error if pointer resolution fails, the result is not an array,
525+ or any element fails to decode. *)
526+end
···1+(* Toplevel printers for Jsont_pointer.t, Jsont.json, and Jsont.Error.t
2+3+ Usage in toplevel:
4+ #require "jsont-pointer.top";;
5+ #install_printer Jsont_pointer_top.nav_printer;;
6+ #install_printer Jsont_pointer_top.append_printer;;
7+ #install_printer Jsont_pointer_top.json_printer;;
8+ #install_printer Jsont_pointer_top.error_printer;;
9+*)
10+11+let nav_printer ppf (p : Jsont_pointer.nav Jsont_pointer.t) =
12+ Jsont_pointer.pp_verbose ppf p
13+14+let append_printer ppf (p : Jsont_pointer.append Jsont_pointer.t) =
15+ Jsont_pointer.pp_verbose ppf p
16+17+let json_printer ppf (json : Jsont.json) =
18+ match Jsont_bytesrw.encode_string Jsont.json json with
19+ | Ok s -> Format.pp_print_string ppf s
20+ | Error e -> Format.fprintf ppf "<json encoding error: %s>" e
21+22+let error_printer ppf (e : Jsont.Error.t) =
23+ Format.pp_print_string ppf (Jsont.Error.to_string e)
+44
src/top/jsont_pointer_top.mli
···00000000000000000000000000000000000000000000
···1+(** Toplevel printers for {!Jsont_pointer}, {!Jsont.json}, and {!Jsont.Error.t}.
2+3+ To use in the OCaml toplevel or utop:
4+ {[
5+ #require "jsont-pointer.top";;
6+ #install_printer Jsont_pointer_top.nav_printer;;
7+ #install_printer Jsont_pointer_top.append_printer;;
8+ #install_printer Jsont_pointer_top.json_printer;;
9+ #install_printer Jsont_pointer_top.error_printer;;
10+ ]}
11+12+ After installation, JSON Pointers will display their structure:
13+ {[
14+ # Jsont_pointer.of_string_nav "/foo/0";;
15+ - : Jsont_pointer.nav Jsont_pointer.t = [Mem "foo"; Nth 0]
16+ ]}
17+18+ JSON values will display as formatted JSON strings:
19+ {[
20+ # Jsont_bytesrw.decode_string Jsont.json {|{"foo": [1, 2]}|};;
21+ - : Jsont.json = {"foo": [1, 2]}
22+ ]}
23+24+ And errors will display as readable messages:
25+ {[
26+ # Jsont_pointer.of_string "invalid";;
27+ Exception: Jsont.Error: Invalid JSON Pointer: must be empty or start with '/'
28+ ]} *)
29+30+val nav_printer : Format.formatter -> Jsont_pointer.nav Jsont_pointer.t -> unit
31+(** [nav_printer] formats a navigation JSON Pointer showing its index structure.
32+ Suitable for use with [#install_printer]. *)
33+34+val append_printer : Format.formatter -> Jsont_pointer.append Jsont_pointer.t -> unit
35+(** [append_printer] formats an append JSON Pointer showing its index structure.
36+ Suitable for use with [#install_printer]. *)
37+38+val json_printer : Format.formatter -> Jsont.json -> unit
39+(** [json_printer] formats a {!Jsont.json} value as a human-readable
40+ JSON string. Suitable for use with [#install_printer]. *)
41+42+val error_printer : Format.formatter -> Jsont.Error.t -> unit
43+(** [error_printer] formats a {!Jsont.Error.t} as a human-readable
44+ error message. Suitable for use with [#install_printer]. *)