···706706 remove p json
707707 in
708708 Jsont.map Jsont.json ~dec ~enc:(fun j -> j)
709709+710710+(* JMAP Extended Pointers - RFC 8620 Section 3.7 *)
711711+module Jmap = struct
712712+ (* Extended segment type: regular tokens or wildcard *)
713713+ type segment =
714714+ | Token of string (* Unescaped reference token *)
715715+ | Wildcard (* The * token for array mapping *)
716716+717717+ type t = segment list
718718+719719+ let parse_segments s =
720720+ if s = "" then []
721721+ else if s.[0] <> '/' then
722722+ Jsont.Error.msgf Jsont.Meta.none
723723+ "Invalid JMAP Pointer: must be empty or start with '/': %s" s
724724+ else
725725+ let rest = String.sub s 1 (String.length s - 1) in
726726+ let tokens = String.split_on_char '/' rest in
727727+ List.map (fun tok ->
728728+ if tok = "*" then Wildcard
729729+ else if tok = "-" then
730730+ Jsont.Error.msgf Jsont.Meta.none
731731+ "Invalid JMAP Pointer: '-' not supported in result reference paths"
732732+ else Token (Token.unescape tok)
733733+ ) tokens
734734+735735+ let of_string s = parse_segments s
736736+737737+ let of_string_result s =
738738+ try Ok (of_string s)
739739+ with Jsont.Error e -> Error (Jsont.Error.to_string e)
740740+741741+ let segment_to_string = function
742742+ | Token s -> Token.escape s
743743+ | Wildcard -> "*"
744744+745745+ let to_string p =
746746+ if p = [] then ""
747747+ else
748748+ let b = Buffer.create 64 in
749749+ List.iter (fun seg ->
750750+ Buffer.add_char b '/';
751751+ Buffer.add_string b (segment_to_string seg)
752752+ ) p;
753753+ Buffer.contents b
754754+755755+ let pp ppf p = Format.pp_print_string ppf (to_string p)
756756+757757+ (* Evaluation with wildcard support *)
758758+ let rec eval_segments segments json =
759759+ match segments with
760760+ | [] -> json
761761+ | Wildcard :: rest ->
762762+ (* Wildcard: map through array, flatten results *)
763763+ (match json with
764764+ | Jsont.Array (elements, meta) ->
765765+ let results = List.map (eval_segments rest) elements in
766766+ (* Flatten: if a result is an array, inline its contents *)
767767+ let flattened = List.concat_map (function
768768+ | Jsont.Array (elems, _) -> elems
769769+ | other -> [other]
770770+ ) results in
771771+ Jsont.Array (flattened, meta)
772772+ | _ ->
773773+ Jsont.Error.msgf (Jsont.Json.meta json)
774774+ "JMAP Pointer: '*' can only be used on arrays, got %s"
775775+ (json_sort_string json))
776776+ | Token token :: rest ->
777777+ (* Standard token: navigate into object or array *)
778778+ (match json with
779779+ | Jsont.Object (members, _) ->
780780+ (match get_member token members with
781781+ | Some (_, value) -> eval_segments rest value
782782+ | None ->
783783+ Jsont.Error.msgf (Jsont.Json.meta json)
784784+ "JMAP Pointer: member '%s' not found" token)
785785+ | Jsont.Array (elements, _) ->
786786+ (match Token.is_valid_array_index token with
787787+ | Some n ->
788788+ (match get_nth n elements with
789789+ | Some value -> eval_segments rest value
790790+ | None ->
791791+ Jsont.Error.msgf (Jsont.Json.meta json)
792792+ "JMAP Pointer: index %d out of bounds (array has %d elements)"
793793+ n (List.length elements))
794794+ | None ->
795795+ Jsont.Error.msgf (Jsont.Json.meta json)
796796+ "JMAP Pointer: invalid array index '%s'" token)
797797+ | _ ->
798798+ Jsont.Error.msgf (Jsont.Json.meta json)
799799+ "JMAP Pointer: cannot index into %s with '%s'"
800800+ (json_sort_string json) token)
801801+802802+ let eval p json = eval_segments p json
803803+804804+ let eval_result p json =
805805+ try Ok (eval p json)
806806+ with Jsont.Error e -> Error e
807807+808808+ let find p json =
809809+ try Some (eval p json)
810810+ with Jsont.Error _ -> None
811811+812812+ let jsont : t Jsont.t =
813813+ let dec _meta s = of_string s in
814814+ let enc p = to_string p in
815815+ Jsont.Base.string (Jsont.Base.map
816816+ ~kind:"JMAP Pointer"
817817+ ~doc:"RFC 8620 JMAP extended JSON Pointer"
818818+ ~dec ~enc ())
819819+820820+ (* Query combinators *)
821821+822822+ let path ?absent p codec =
823823+ let dec json =
824824+ match find p json with
825825+ | Some extracted ->
826826+ (match Jsont.Json.decode' codec extracted with
827827+ | Ok v -> v
828828+ | Error e -> raise (Jsont.Error e))
829829+ | None ->
830830+ match absent with
831831+ | Some v -> v
832832+ | None ->
833833+ Jsont.Error.msgf Jsont.Meta.none
834834+ "JMAP Pointer %s: path not found" (to_string p)
835835+ in
836836+ Jsont.map Jsont.json ~dec ~enc:(fun _ ->
837837+ Jsont.Error.msgf Jsont.Meta.none "Jmap.path: encode not supported")
838838+839839+ let path_list p elem_codec =
840840+ path p (Jsont.list elem_codec)
841841+end
+101
src/jsont_pointer.mli
···423423424424 If [allow_absent] is [true] (default [false]), does nothing if
425425 the pointer doesn't resolve instead of raising. *)
426426+427427+(** {1:jmap JMAP Extended Pointers}
428428+429429+ {{:https://www.rfc-editor.org/rfc/rfc8620#section-3.7}RFC 8620 Section 3.7}
430430+ extends JSON Pointer with a wildcard token [*] for mapping through arrays.
431431+ This is used in JMAP result references.
432432+433433+ The wildcard semantics are:
434434+ {ul
435435+ {- When the current value is an array and the token is [*], apply the rest
436436+ of the pointer to each element, collecting results into a new array.}
437437+ {- If a mapped result is itself an array, its contents are flattened into
438438+ the output (i.e., array of arrays becomes a single array).}}
439439+440440+ Example: Given [{"list": \[{"id": "a"}, {"id": "b"}\]}], the extended
441441+ pointer [/list/*/id] evaluates to [["a", "b"]].
442442+443443+ {b Note}: These extended pointers are {e not} valid RFC 6901 JSON Pointers.
444444+ They should only be used for JMAP result reference resolution. *)
445445+446446+module Jmap : sig
447447+ (** JMAP extended JSON Pointer with wildcard support. *)
448448+449449+ type t
450450+ (** The type for JMAP extended pointers. Unlike standard pointers, these
451451+ may contain [*] tokens for array mapping. *)
452452+453453+ val of_string : string -> t
454454+ (** [of_string s] parses a JMAP extended pointer.
455455+456456+ The syntax is the same as RFC 6901 JSON Pointer, except [*] is allowed
457457+ as a reference token for array mapping.
458458+459459+ @raise Jsont.Error if [s] has invalid syntax. *)
460460+461461+ val of_string_result : string -> (t, string) result
462462+ (** [of_string_result s] is like {!of_string} but returns a result. *)
463463+464464+ val to_string : t -> string
465465+ (** [to_string p] serializes [p] to string form. *)
466466+467467+ val pp : Format.formatter -> t -> unit
468468+ (** [pp] formats a pointer using {!to_string}. *)
469469+470470+ val eval : t -> Jsont.json -> Jsont.json
471471+ (** [eval p json] evaluates the extended pointer [p] against [json].
472472+473473+ For [*] tokens on arrays, maps through all elements and collects results.
474474+ Results that are arrays are flattened into the output.
475475+476476+ @raise Jsont.Error if:
477477+ - A standard token doesn't resolve (member not found, index out of bounds)
478478+ - [*] is used on a non-array value
479479+ - [-] appears in the pointer (not supported in JMAP extended pointers) *)
480480+481481+ val eval_result : t -> Jsont.json -> (Jsont.json, Jsont.Error.t) result
482482+ (** [eval_result p json] is like {!eval} but returns a result. *)
483483+484484+ val find : t -> Jsont.json -> Jsont.json option
485485+ (** [find p json] is like {!eval} but returns [None] on errors. *)
486486+487487+ val jsont : t Jsont.t
488488+ (** [jsont] is a {!Jsont.t} codec for JMAP extended pointers. *)
489489+490490+ (** {2:combinators Query combinators}
491491+492492+ These combinators integrate JMAP extended pointers with jsont codecs,
493493+ enabling typed extraction from JSON using pointer paths. *)
494494+495495+ val path : ?absent:'a -> t -> 'a Jsont.t -> 'a Jsont.t
496496+ (** [path p codec] extracts the value at pointer [p] and decodes it with [codec].
497497+498498+ If [absent] is provided and the pointer doesn't resolve, returns [absent].
499499+ Otherwise raises on pointer resolution failure.
500500+501501+ Example: Extract all thread IDs from an Email/get response:
502502+ {[
503503+ let thread_ids =
504504+ Jmap.path
505505+ (Jmap.of_string "/list/*/threadId")
506506+ (Jsont.list Jsont.string)
507507+ ]}
508508+509509+ @raise Jsont.Error if the pointer fails to resolve (and no [absent])
510510+ or if decoding with [codec] fails. *)
511511+512512+ val path_list : t -> 'a Jsont.t -> 'a list Jsont.t
513513+ (** [path_list p codec] extracts the array at pointer [p] and decodes each
514514+ element with [codec].
515515+516516+ This is a convenience for the common JMAP pattern where wildcards produce
517517+ arrays that need element-wise decoding:
518518+ {[
519519+ (* These are equivalent: *)
520520+ Jmap.path_list (Jmap.of_string "/list/*/id") Jsont.string
521521+ Jmap.path (Jmap.of_string "/list/*/id") (Jsont.list Jsont.string)
522522+ ]}
523523+524524+ @raise Jsont.Error if pointer resolution fails, the result is not an array,
525525+ or any element fails to decode. *)
526526+end
···11+(* Toplevel printers for Jsont_pointer.t, Jsont.json, and Jsont.Error.t
22+33+ Usage in toplevel:
44+ #require "jsont-pointer.top";;
55+ #install_printer Jsont_pointer_top.nav_printer;;
66+ #install_printer Jsont_pointer_top.append_printer;;
77+ #install_printer Jsont_pointer_top.json_printer;;
88+ #install_printer Jsont_pointer_top.error_printer;;
99+*)
1010+1111+let nav_printer ppf (p : Jsont_pointer.nav Jsont_pointer.t) =
1212+ Jsont_pointer.pp_verbose ppf p
1313+1414+let append_printer ppf (p : Jsont_pointer.append Jsont_pointer.t) =
1515+ Jsont_pointer.pp_verbose ppf p
1616+1717+let json_printer ppf (json : Jsont.json) =
1818+ match Jsont_bytesrw.encode_string Jsont.json json with
1919+ | Ok s -> Format.pp_print_string ppf s
2020+ | Error e -> Format.fprintf ppf "<json encoding error: %s>" e
2121+2222+let error_printer ppf (e : Jsont.Error.t) =
2323+ Format.pp_print_string ppf (Jsont.Error.to_string e)
+44
src/top/jsont_pointer_top.mli
···11+(** Toplevel printers for {!Jsont_pointer}, {!Jsont.json}, and {!Jsont.Error.t}.
22+33+ To use in the OCaml toplevel or utop:
44+ {[
55+ #require "jsont-pointer.top";;
66+ #install_printer Jsont_pointer_top.nav_printer;;
77+ #install_printer Jsont_pointer_top.append_printer;;
88+ #install_printer Jsont_pointer_top.json_printer;;
99+ #install_printer Jsont_pointer_top.error_printer;;
1010+ ]}
1111+1212+ After installation, JSON Pointers will display their structure:
1313+ {[
1414+ # Jsont_pointer.of_string_nav "/foo/0";;
1515+ - : Jsont_pointer.nav Jsont_pointer.t = [Mem "foo"; Nth 0]
1616+ ]}
1717+1818+ JSON values will display as formatted JSON strings:
1919+ {[
2020+ # Jsont_bytesrw.decode_string Jsont.json {|{"foo": [1, 2]}|};;
2121+ - : Jsont.json = {"foo": [1, 2]}
2222+ ]}
2323+2424+ And errors will display as readable messages:
2525+ {[
2626+ # Jsont_pointer.of_string "invalid";;
2727+ Exception: Jsont.Error: Invalid JSON Pointer: must be empty or start with '/'
2828+ ]} *)
2929+3030+val nav_printer : Format.formatter -> Jsont_pointer.nav Jsont_pointer.t -> unit
3131+(** [nav_printer] formats a navigation JSON Pointer showing its index structure.
3232+ Suitable for use with [#install_printer]. *)
3333+3434+val append_printer : Format.formatter -> Jsont_pointer.append Jsont_pointer.t -> unit
3535+(** [append_printer] formats an append JSON Pointer showing its index structure.
3636+ Suitable for use with [#install_printer]. *)
3737+3838+val json_printer : Format.formatter -> Jsont.json -> unit
3939+(** [json_printer] formats a {!Jsont.json} value as a human-readable
4040+ JSON string. Suitable for use with [#install_printer]. *)
4141+4242+val error_printer : Format.formatter -> Jsont.Error.t -> unit
4343+(** [error_printer] formats a {!Jsont.Error.t} as a human-readable
4444+ error message. Suitable for use with [#install_printer]. *)