Hermes, an XRPC client for atproto

README.md

···
 
 This repo contains several libraries in addition to the `pegasus` PDS:
 
-| library  | description                                                                                                                                                                      |
-| -------- | -------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- |
-| frontend | The PDS frontend, containing the admin dashboard and account page.                                                                                                               |
-| ipld     | A mostly [DASL-compliant](https://dasl.ing/) implementation of [CIDs](https://dasl.ing/cid.html), [CAR](https://dasl.ing/car.html), and [DAG-CBOR](https://dasl.ing/drisl.html). |
-| kleidos  | An atproto-valid interface for secp256k1 and secp256r1 key management, signing/verifying, and encoding/decoding.                                                                 |
-| mist     | A [Merkle Search Tree](https://atproto.com/specs/repository#mst-structure) implementation for data repository purposes.                                                          |
-| pegasus  | The PDS implementation.                                                                                                                                                          |
+| library    | description                                                                                                                                                                      |
+| ---------- | -------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- |
+| frontend   | The PDS frontend, containing the admin dashboard and account page.                                                                                                               |
+| ipld       | A mostly [DASL-compliant](https://dasl.ing/) implementation of [CIDs](https://dasl.ing/cid.html), [CAR](https://dasl.ing/car.html), and [DAG-CBOR](https://dasl.ing/drisl.html). |
+| kleidos    | An atproto-valid interface for secp256k1 and secp256r1 key management, signing/verifying, and encoding/decoding.                                                                 |
+| mist       | A [Merkle Search Tree](https://atproto.com/specs/repository#mst-structure) implementation for data repository purposes.                                                          |
+| hermes     | An XRPC client for atproto.                                                                                                                                                      |
+| hermes_ppx | A preprocessor for hermes, making API calls more ergonomic.                                                                                                                      |
+| hermes-cli | A CLI to generate OCaml types from atproto lexicons.                                                                                                                             |
+| pegasus    | The PDS implementation.                                                                                                                                                          |
 
 To start developing, you'll need:
 

dune-project

···
   (multibase (>= 0.1.0))))
 
 (package
+ (name hermes)
+ (synopsis "Type-safe XRPC client for ATProto")
+ (description "XRPC client with PPX extensions for type-safe API calls")
+ (allow_empty)
+ (depends
+  (ocaml (= 5.2.1))
+  dune
+  lwt
+  (cohttp-lwt-unix (>= 6.1.1))
+  (uri (>= 4.4.0))
+  (yojson (>= 3.0.0))
+  (base64 (>= 3.5.0))
+  (lwt_ppx (>= 5.9.1))
+  (ppx_deriving_yojson (>= 3.9.1))))
+
+(package
+ (name hermes-cli)
+ (synopsis "Code generator for Hermes from ATProto lexicons")
+ (allow_empty)
+ (depends
+  (ocaml (= 5.2.1))
+  dune
+  (cmdliner (>= 1.2.0))
+  (yojson (>= 3.0.0))
+  (fmt (>= 0.9.0))
+  (fpath (>= 0.7.3))))
+
+(package
+ (name hermes_ppx)
+ (synopsis "PPX extension for Hermes XRPC calls")
+ (allow_empty)
+ (depends
+  (ocaml (= 5.2.1))
+  dune
+  (ppxlib (>= 0.32.0))))
+
+(package
  (name tailwindcss)
  (allow_empty))
 

hermes-cli.opam

···
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "Code generator for Hermes from ATProto lexicons"
+maintainer: ["futurGH"]
+authors: ["futurGH"]
+license: "MPL-2.0"
+homepage: "https://github.com/futurGH/pegasus"
+bug-reports: "https://github.com/futurGH/pegasus/issues"
+depends: [
+  "ocaml" {= "5.2.1"}
+  "dune" {>= "3.20"}
+  "cmdliner" {>= "1.2.0"}
+  "yojson" {>= "3.0.0"}
+  "fmt" {>= "0.9.0"}
+  "fpath" {>= "0.7.3"}
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
+dev-repo: "git+https://github.com/futurGH/pegasus.git"
+x-maintenance-intent: ["(latest)"]

hermes-cli/bin/dune

···
+(executable
+ (name main)
+ (public_name hermes-cli)
+ (package hermes-cli)
+ (libraries hermes_cli cmdliner))

hermes-cli/bin/main.ml

···
+open Hermes_cli
+
+(* recursively find all json files in a directory *)
+let find_json_files dir =
+  let rec aux acc path =
+    if Sys.is_directory path then
+      Sys.readdir path |> Array.to_list
+      |> List.map (Filename.concat path)
+      |> List.fold_left aux acc
+    else if Filename.check_suffix path ".json" then path :: acc
+    else acc
+  in
+  aux [] dir
+
+(* generate module structure from lexicons *)
+let generate ~input_dir ~output_dir ~module_name =
+  (* create output directory *)
+  if not (Sys.file_exists output_dir) then Sys.mkdir output_dir 0o755 ;
+  (* find all lexicon files *)
+  let files = find_json_files input_dir in
+  Printf.printf "Found %d lexicon files\n" (List.length files) ;
+  (* parse all files *)
+  let lexicons =
+    List.filter_map
+      (fun path ->
+        match Parser.parse_file path with
+        | Ok doc ->
+            Printf.printf "  Parsed: %s\n" doc.Lexicon_types.id ;
+            Some doc
+        | Error e ->
+            Printf.eprintf "  Error parsing %s: %s\n" path e ;
+            None )
+      files
+  in
+  Printf.printf "Successfully parsed %d lexicons\n" (List.length lexicons) ;
+  (* group by namespace, all but last segment *)
+  let by_namespace = Hashtbl.create 64 in
+  List.iter
+    (fun doc ->
+      let segments = String.split_on_char '.' doc.Lexicon_types.id in
+      match List.rev segments with
+      | _last :: rest ->
+          let ns = String.concat "." (List.rev rest) in
+          let existing =
+            try Hashtbl.find by_namespace ns with Not_found -> []
+          in
+          Hashtbl.replace by_namespace ns (doc :: existing)
+      | [] ->
+          () )
+    lexicons ;
+  (* generate file for each lexicon *)
+  List.iter
+    (fun doc ->
+      let code = Codegen.gen_lexicon_module doc in
+      let rel_path = Naming.file_path_of_nsid doc.Lexicon_types.id in
+      let full_path = Filename.concat output_dir rel_path in
+      (* write file *)
+      let oc = open_out full_path in
+      output_string oc code ;
+      close_out oc ;
+      Printf.printf "  Generated: %s\n" rel_path )
+    lexicons ;
+  (* generate index file *)
+  let index_path =
+    Filename.concat output_dir (String.lowercase_ascii module_name ^ ".ml")
+  in
+  let oc = open_out index_path in
+  Printf.fprintf oc "(* %s - generated from atproto lexicons *)\n\n" module_name ;
+  (* export each lexicon as a module alias *)
+  List.iter
+    (fun doc ->
+      let flat_module = Naming.flat_module_name_of_nsid doc.Lexicon_types.id in
+      Printf.fprintf oc "module %s = %s\n" flat_module flat_module )
+    lexicons ;
+  close_out oc ;
+  Printf.printf "Generated index: %s\n" index_path ;
+  (* generate dune file *)
+  let dune_path = Filename.concat output_dir "dune" in
+  let oc = open_out dune_path in
+  Printf.fprintf oc "(library\n" ;
+  Printf.fprintf oc " (name %s)\n" (String.lowercase_ascii module_name) ;
+  Printf.fprintf oc " (libraries hermes yojson lwt)\n" ;
+  Printf.fprintf oc " (preprocess (pps ppx_deriving_yojson)))\n" ;
+  close_out oc ;
+  Printf.printf "Generated dune file\n" ;
+  Printf.printf "Done! Generated %d modules\n" (List.length lexicons)
+
+let input_dir =
+  let doc = "directory containing lexicon JSON files" in
+  Cmdliner.Arg.(
+    required & opt (some dir) None & info ["i"; "input"] ~docv:"DIR" ~doc )
+
+let output_dir =
+  let doc = "output directory for generated code" in
+  Cmdliner.Arg.(
+    required & opt (some string) None & info ["o"; "output"] ~docv:"DIR" ~doc )
+
+let module_name =
+  let doc = "name of the generated module" in
+  Cmdliner.Arg.(
+    value
+    & opt string "Hermes_lexicons"
+    & info ["m"; "module-name"] ~docv:"NAME" ~doc )
+
+let generate_cmd =
+  let doc = "generate ocaml types from atproto lexicons" in
+  let info = Cmdliner.Cmd.info "generate" ~doc in
+  let generate' input_dir output_dir module_name =
+    generate ~input_dir ~output_dir ~module_name
+  in
+  Cmdliner.Cmd.v info
+    Cmdliner.Term.(const generate' $ input_dir $ output_dir $ module_name)
+
+let main_cmd =
+  let doc = "hermes - atproto lexicon code generator" in
+  let info = Cmdliner.Cmd.info "hermes-cli" ~version:"0.1.0" ~doc in
+  Cmdliner.Cmd.group info [generate_cmd]
+
+let () = exit (Cmdliner.Cmd.eval main_cmd)

hermes-cli/lib/codegen.ml

···
+open Lexicon_types
+
+type output =
+  { mutable imports: string list
+  ; mutable generated_unions: string list
+  ; buf: Buffer.t }
+
+let make_output () = {imports= []; generated_unions= []; buf= Buffer.create 4096}
+
+let add_import out module_name =
+  if not (List.mem module_name out.imports) then
+    out.imports <- module_name :: out.imports
+
+let mark_union_generated out union_name =
+  if not (List.mem union_name out.generated_unions) then
+    out.generated_unions <- union_name :: out.generated_unions
+
+let is_union_generated out union_name = List.mem union_name out.generated_unions
+
+let emit out s = Buffer.add_string out.buf s
+
+let emitln out s =
+  Buffer.add_string out.buf s ;
+  Buffer.add_char out.buf '\n'
+
+let emit_newline out = Buffer.add_char out.buf '\n'
+
+(* generate ocaml type for a primitive type *)
+let rec gen_type_ref nsid out (type_def : type_def) : string =
+  match type_def with
+  | String _ ->
+      "string"
+  | Integer {maximum; _} -> (
+    (* use int64 for large integers *)
+    match maximum with
+    | Some m when m > 1073741823 ->
+        "int64"
+    | _ ->
+        "int" )
+  | Boolean _ ->
+      "bool"
+  | Bytes _ ->
+      "bytes"
+  | Blob _ ->
+      "Hermes.blob"
+  | CidLink _ ->
+      "Cid.t"
+  | Array {items; _} ->
+      let item_type = gen_type_ref nsid out items in
+      item_type ^ " list"
+  | Object _ ->
+      (* objects should be defined separately *)
+      "object_todo"
+  | Ref {ref_; _} ->
+      gen_ref_type nsid out ref_
+  | Union {refs; _} ->
+      (* generate inline union reference *)
+      gen_union_type_name refs
+  | Token _ ->
+      "string"
+  | Unknown _ ->
+      "Yojson.Safe.t"
+  | Query _ | Procedure _ | Subscription _ | Record _ ->
+      "unit (* primary type *)"
+
+(* generate reference to another type *)
+and gen_ref_type _nsid out ref_str : string =
+  if String.length ref_str > 0 && ref_str.[0] = '#' then begin
+    (* local ref: #someDef -> someDef *)
+    let def_name = String.sub ref_str 1 (String.length ref_str - 1) in
+    Naming.type_name def_name
+  end
+  else begin
+    (* external ref: com.example.defs#someDef *)
+    match String.split_on_char '#' ref_str with
+    | [ext_nsid; def_name] ->
+        (* use flat module names for include_subdirs unqualified *)
+        let flat_module = Naming.flat_module_name_of_nsid ext_nsid in
+        add_import out flat_module ;
+        flat_module ^ "." ^ Naming.type_name def_name
+    | [ext_nsid] ->
+        (* just nsid, refers to main def *)
+        let flat_module = Naming.flat_module_name_of_nsid ext_nsid in
+        add_import out flat_module ; flat_module ^ ".main"
+    | _ ->
+        "invalid_ref"
+  end
+
+and gen_union_type_name refs = Naming.union_type_name refs
+
+(* generate full type uri for a ref *)
+let gen_type_uri nsid ref_str =
+  if String.length ref_str > 0 && ref_str.[0] = '#' then
+    (* local ref *)
+    nsid ^ ref_str
+  else
+    (* external ref, use as-is *)
+    ref_str
+
+(* collect inline union specs from object properties *)
+let rec collect_inline_unions acc type_def =
+  match type_def with
+  | Union spec ->
+      (spec.refs, spec) :: acc
+  | Array {items; _} ->
+      collect_inline_unions acc items
+  | _ ->
+      acc
+
+let collect_inline_unions_from_properties properties =
+  List.fold_left
+    (fun acc (_, (prop : property)) -> collect_inline_unions acc prop.type_def)
+    [] properties
+
+(* generate inline union types that appear in object properties *)
+let gen_inline_unions nsid out properties =
+  let inline_unions = collect_inline_unions_from_properties properties in
+  List.iter
+    (fun (refs, spec) ->
+      let type_name = Naming.union_type_name refs in
+      (* skip if already generated *)
+      if not (is_union_generated out type_name) then begin
+        mark_union_generated out type_name ;
+        let is_closed = Option.value spec.closed ~default:false in
+        emitln out (Printf.sprintf "type %s =" type_name) ;
+        List.iter
+          (fun ref_str ->
+            let variant_name = Naming.variant_name_of_ref ref_str in
+            let payload_type = gen_ref_type nsid out ref_str in
+            emitln out (Printf.sprintf "  | %s of %s" variant_name payload_type) )
+          refs ;
+        if not is_closed then emitln out "  | Unknown of Yojson.Safe.t" ;
+        emit_newline out ;
+        (* generate of_yojson function *)
+        emitln out (Printf.sprintf "let %s_of_yojson json =" type_name) ;
+        emitln out "  let open Yojson.Safe.Util in" ;
+        emitln out "  try" ;
+        emitln out "    match json |> member \"$type\" |> to_string with" ;
+        List.iter
+          (fun ref_str ->
+            let variant_name = Naming.variant_name_of_ref ref_str in
+            let full_type_uri = gen_type_uri nsid ref_str in
+            let payload_type = gen_ref_type nsid out ref_str in
+            emitln out (Printf.sprintf "    | \"%s\" ->" full_type_uri) ;
+            emitln out
+              (Printf.sprintf "        (match %s_of_yojson json with"
+                 payload_type ) ;
+            emitln out
+              (Printf.sprintf "         | Ok v -> Ok (%s v)" variant_name) ;
+            emitln out "         | Error e -> Error e)" )
+          refs ;
+        if is_closed then
+          emitln out "    | t -> Error (\"unknown union type: \" ^ t)"
+        else emitln out "    | _ -> Ok (Unknown json)" ;
+        emitln out "  with _ -> Error \"failed to parse union\"" ;
+        emit_newline out ;
+        (* generate to_yojson function *)
+        emitln out (Printf.sprintf "let %s_to_yojson = function" type_name) ;
+        List.iter
+          (fun ref_str ->
+            let variant_name = Naming.variant_name_of_ref ref_str in
+            let payload_type = gen_ref_type nsid out ref_str in
+            emitln out
+              (Printf.sprintf "  | %s v -> %s_to_yojson v" variant_name
+                 payload_type ) )
+          refs ;
+        if not is_closed then emitln out "  | Unknown j -> j" ;
+        emit_newline out
+      end )
+    inline_unions
+
+(* generate object type definition *)
+let gen_object_type nsid out name (spec : object_spec) =
+  let required = Option.value spec.required ~default:[] in
+  let nullable = Option.value spec.nullable ~default:[] in
+  (* handle empty objects as unit *)
+  if spec.properties = [] then begin
+    emitln out (Printf.sprintf "type %s = unit" (Naming.type_name name)) ;
+    emitln out
+      (Printf.sprintf "let %s_of_yojson _ = Ok ()" (Naming.type_name name)) ;
+    emitln out
+      (Printf.sprintf "let %s_to_yojson () = `Assoc []" (Naming.type_name name)) ;
+    emit_newline out
+  end
+  else begin
+    (* generate inline union types first *)
+    gen_inline_unions nsid out spec.properties ;
+    emitln out (Printf.sprintf "type %s =" (Naming.type_name name)) ;
+    emitln out "  {" ;
+    List.iter
+      (fun (prop_name, (prop : property)) ->
+        let ocaml_name = Naming.field_name prop_name in
+        let base_type = gen_type_ref nsid out prop.type_def in
+        let is_required = List.mem prop_name required in
+        let is_nullable = List.mem prop_name nullable in
+        let type_str =
+          if is_required && not is_nullable then base_type
+          else base_type ^ " option"
+        in
+        let key_attr = Naming.key_annotation prop_name ocaml_name in
+        let default_attr =
+          if is_required && not is_nullable then "" else " [@default None]"
+        in
+        emitln out
+          (Printf.sprintf "    %s: %s%s%s;" ocaml_name type_str key_attr
+             default_attr ) )
+      spec.properties ;
+    emitln out "  }" ;
+    emitln out "[@@deriving yojson {strict= false}]" ;
+    emit_newline out
+  end
+
+(* generate union type definition *)
+let gen_union_type nsid out name (spec : union_spec) =
+  let type_name = Naming.type_name name in
+  let is_closed = Option.value spec.closed ~default:false in
+  emitln out (Printf.sprintf "type %s =" type_name) ;
+  List.iter
+    (fun ref_str ->
+      let variant_name = Naming.variant_name_of_ref ref_str in
+      let payload_type = gen_ref_type nsid out ref_str in
+      emitln out (Printf.sprintf "  | %s of %s" variant_name payload_type) )
+    spec.refs ;
+  if not is_closed then emitln out "  | Unknown of Yojson.Safe.t" ;
+  emit_newline out ;
+  (* generate of_yojson function *)
+  emitln out (Printf.sprintf "let %s_of_yojson json =" type_name) ;
+  emitln out "  let open Yojson.Safe.Util in" ;
+  emitln out "  try" ;
+  emitln out "    match json |> member \"$type\" |> to_string with" ;
+  List.iter
+    (fun ref_str ->
+      let variant_name = Naming.variant_name_of_ref ref_str in
+      let full_type_uri = gen_type_uri nsid ref_str in
+      let payload_type = gen_ref_type nsid out ref_str in
+      emitln out (Printf.sprintf "    | \"%s\" ->" full_type_uri) ;
+      emitln out
+        (Printf.sprintf "        (match %s_of_yojson json with" payload_type) ;
+      emitln out (Printf.sprintf "         | Ok v -> Ok (%s v)" variant_name) ;
+      emitln out "         | Error e -> Error e)" )
+    spec.refs ;
+  if is_closed then emitln out "    | t -> Error (\"unknown union type: \" ^ t)"
+  else emitln out "    | _ -> Ok (Unknown json)" ;
+  emitln out "  with _ -> Error \"failed to parse union\"" ;
+  emit_newline out ;
+  (* generate to_yojson function *)
+  emitln out (Printf.sprintf "let %s_to_yojson = function" type_name) ;
+  List.iter
+    (fun ref_str ->
+      let variant_name = Naming.variant_name_of_ref ref_str in
+      let payload_type = gen_ref_type nsid out ref_str in
+      emitln out
+        (Printf.sprintf "  | %s v -> %s_to_yojson v" variant_name payload_type) )
+    spec.refs ;
+  if not is_closed then emitln out "  | Unknown j -> j" ;
+  emit_newline out
+
+let is_json_encoding encoding = encoding = "application/json" || encoding = ""
+
+let is_bytes_encoding encoding =
+  encoding <> "" && encoding <> "application/json"
+
+(* generate params type for query/procedure *)
+let gen_params_type nsid out (spec : params_spec) =
+  let required = Option.value spec.required ~default:[] in
+  emitln out "type params =" ;
+  emitln out "  {" ;
+  List.iter
+    (fun (prop_name, (prop : property)) ->
+      let ocaml_name = Naming.field_name prop_name in
+      let base_type = gen_type_ref nsid out prop.type_def in
+      let is_required = List.mem prop_name required in
+      let type_str = if is_required then base_type else base_type ^ " option" in
+      let key_attr = Naming.key_annotation prop_name ocaml_name in
+      let default_attr = if is_required then "" else " [@default None]" in
+      emitln out
+        (Printf.sprintf "    %s: %s%s%s;" ocaml_name type_str key_attr
+           default_attr ) )
+    spec.properties ;
+  emitln out "  }" ;
+  emitln out "[@@deriving yojson {strict= false}]" ;
+  emit_newline out
+
+(* generate output type for query/procedure *)
+let gen_output_type nsid out (body : body_def) =
+  match body.schema with
+  | Some (Object spec) ->
+      (* handle empty objects as unit *)
+      if spec.properties = [] then begin
+        emitln out "type output = unit" ;
+        emitln out "let output_of_yojson _ = Ok ()" ;
+        emitln out "let output_to_yojson () = `Assoc []" ;
+        emit_newline out
+      end
+      else begin
+        (* generate inline union types first *)
+        gen_inline_unions nsid out spec.properties ;
+        let required = Option.value spec.required ~default:[] in
+        let nullable = Option.value spec.nullable ~default:[] in
+        emitln out "type output =" ;
+        emitln out "  {" ;
+        List.iter
+          (fun (prop_name, (prop : property)) ->
+            let ocaml_name = Naming.field_name prop_name in
+            let base_type = gen_type_ref nsid out prop.type_def in
+            let is_required = List.mem prop_name required in
+            let is_nullable = List.mem prop_name nullable in
+            let type_str =
+              if is_required && not is_nullable then base_type
+              else base_type ^ " option"
+            in
+            let key_attr = Naming.key_annotation prop_name ocaml_name in
+            let default_attr =
+              if is_required && not is_nullable then "" else " [@default None]"
+            in
+            emitln out
+              (Printf.sprintf "    %s: %s%s%s;" ocaml_name type_str key_attr
+                 default_attr ) )
+          spec.properties ;
+        emitln out "  }" ;
+        emitln out "[@@deriving yojson {strict= false}]" ;
+        emit_newline out
+      end
+  | Some other_type ->
+      let type_str = gen_type_ref nsid out other_type in
+      emitln out (Printf.sprintf "type output = %s" type_str) ;
+      emitln out "[@@deriving yojson {strict= false}]" ;
+      emit_newline out
+  | None ->
+      emitln out "type output = unit" ;
+      emitln out "let output_of_yojson _ = Ok ()" ;
+      emitln out "let output_to_yojson () = `Null" ;
+      emit_newline out
+
+(* generate query module *)
+let gen_query nsid out name (spec : query_spec) =
+  (* check if output is bytes *)
+  let output_is_bytes =
+    match spec.output with
+    | Some body ->
+        is_bytes_encoding body.encoding
+    | None ->
+        false
+  in
+  emitln out
+    (Printf.sprintf "(** %s *)" (Option.value spec.description ~default:name)) ;
+  emitln out (Printf.sprintf "module %s = struct" (Naming.def_module_name name)) ;
+  emitln out (Printf.sprintf "  let nsid = \"%s\"" nsid) ;
+  emit_newline out ;
+  (* generate params type *)
+  ( match spec.parameters with
+  | Some params when params.properties <> [] ->
+      emit out "  " ;
+      gen_params_type nsid out params
+  | _ ->
+      emitln out "  type params = unit" ;
+      emitln out "  let params_to_yojson () = `Assoc []" ;
+      emit_newline out ) ;
+  (* generate output type *)
+  ( if output_is_bytes then begin
+      emitln out "  (** Raw bytes output with content type *)" ;
+      emitln out "  type output = string * string" ;
+      emit_newline out
+    end
+    else
+      match spec.output with
+      | Some body ->
+          emit out "  " ;
+          gen_output_type nsid out body
+      | None ->
+          emitln out "  type output = unit" ;
+          emitln out "  let output_of_yojson _ = Ok ()" ;
+          emit_newline out ) ;
+  (* generate call function *)
+  emitln out "  let call" ;
+  ( match spec.parameters with
+  | Some params when params.properties <> [] ->
+      let required = Option.value params.required ~default:[] in
+      List.iter
+        (fun (prop_name, _) ->
+          let ocaml_name = Naming.field_name prop_name in
+          let is_required = List.mem prop_name required in
+          if is_required then emitln out (Printf.sprintf "      ~%s" ocaml_name)
+          else emitln out (Printf.sprintf "      ?%s" ocaml_name) )
+        params.properties
+  | _ ->
+      () ) ;
+  emitln out "      (client : Hermes.client) : output Lwt.t =" ;
+  ( match spec.parameters with
+  | Some params when params.properties <> [] ->
+      emit out "    let params : params = {" ;
+      let fields =
+        List.map
+          (fun (prop_name, _) -> Naming.field_name prop_name)
+          params.properties
+      in
+      emit out (String.concat "; " fields) ;
+      emitln out "} in" ;
+      if output_is_bytes then
+        emitln out
+          "    Hermes.query_bytes client nsid (params_to_yojson params)"
+      else
+        emitln out
+          "    Hermes.query client nsid (params_to_yojson params) \
+           output_of_yojson"
+  | _ ->
+      if output_is_bytes then
+        emitln out "    Hermes.query_bytes client nsid (`Assoc [])"
+      else
+        emitln out "    Hermes.query client nsid (`Assoc []) output_of_yojson"
+  ) ;
+  emitln out "end" ; emit_newline out
+
+(* generate procedure module *)
+let gen_procedure nsid out name (spec : procedure_spec) =
+  (* check if input/output are bytes *)
+  let input_is_bytes =
+    match spec.input with
+    | Some body ->
+        is_bytes_encoding body.encoding
+    | None ->
+        false
+  in
+  let output_is_bytes =
+    match spec.output with
+    | Some body ->
+        is_bytes_encoding body.encoding
+    | None ->
+        false
+  in
+  let input_content_type =
+    match spec.input with
+    | Some body when is_bytes_encoding body.encoding ->
+        body.encoding
+    | _ ->
+        "application/json"
+  in
+  emitln out
+    (Printf.sprintf "(** %s *)" (Option.value spec.description ~default:name)) ;
+  emitln out (Printf.sprintf "module %s = struct" (Naming.def_module_name name)) ;
+  emitln out (Printf.sprintf "  let nsid = \"%s\"" nsid) ;
+  emit_newline out ;
+  (* generate params type *)
+  ( match spec.parameters with
+  | Some params when params.properties <> [] ->
+      emit out "  " ;
+      gen_params_type nsid out params
+  | _ ->
+      emitln out "  type params = unit" ;
+      emitln out "  let params_to_yojson () = `Assoc []" ;
+      emit_newline out ) ;
+  (* generate input type; only for json input with schema *)
+  ( if not input_is_bytes then
+      match spec.input with
+      | Some body when body.schema <> None ->
+          emit out "  " ;
+          ( match body.schema with
+          | Some (Object spec) ->
+              (* generate inline union types first *)
+              gen_inline_unions nsid out spec.properties ;
+              let required = Option.value spec.required ~default:[] in
+              emitln out "type input =" ;
+              emitln out "    {" ;
+              List.iter
+                (fun (prop_name, (prop : property)) ->
+                  let ocaml_name = Naming.field_name prop_name in
+                  let base_type = gen_type_ref nsid out prop.type_def in
+                  let is_required = List.mem prop_name required in
+                  let type_str =
+                    if is_required then base_type else base_type ^ " option"
+                  in
+                  let key_attr = Naming.key_annotation prop_name ocaml_name in
+                  let default_attr =
+                    if is_required then "" else " [@default None]"
+                  in
+                  emitln out
+                    (Printf.sprintf "      %s: %s%s%s;" ocaml_name type_str
+                       key_attr default_attr ) )
+                spec.properties ;
+              emitln out "    }" ;
+              emitln out "  [@@deriving yojson {strict= false}]"
+          | Some other_type ->
+              emitln out
+                (Printf.sprintf "type input = %s"
+                   (gen_type_ref nsid out other_type) ) ;
+              emitln out "  [@@deriving yojson {strict= false}]"
+          | None ->
+              () ) ;
+          emit_newline out
+      | _ ->
+          () ) ;
+  (* generate output type *)
+  ( if output_is_bytes then begin
+      emitln out "  (** Raw bytes output with content type *)" ;
+      emitln out "  type output = (string * string) option" ;
+      emit_newline out
+    end
+    else
+      match spec.output with
+      | Some body ->
+          emit out "  " ;
+          gen_output_type nsid out body
+      | None ->
+          emitln out "  type output = unit" ;
+          emitln out "  let output_of_yojson _ = Ok ()" ;
+          emit_newline out ) ;
+  (* generate call function *)
+  emitln out "  let call" ;
+  (* add labeled arguments for parameters *)
+  ( match spec.parameters with
+  | Some params when params.properties <> [] ->
+      let required = Option.value params.required ~default:[] in
+      List.iter
+        (fun (prop_name, _) ->
+          let ocaml_name = Naming.field_name prop_name in
+          let is_required = List.mem prop_name required in
+          if is_required then emitln out (Printf.sprintf "      ~%s" ocaml_name)
+          else emitln out (Printf.sprintf "      ?%s" ocaml_name) )
+        params.properties
+  | _ ->
+      () ) ;
+  (* add labeled arguments for input *)
+  ( if input_is_bytes then
+      (* for bytes input, take raw string *)
+      emitln out "      ?input"
+    else
+      match spec.input with
+      | Some body -> (
+        match body.schema with
+        | Some (Object obj_spec) ->
+            let required = Option.value obj_spec.required ~default:[] in
+            List.iter
+              (fun (prop_name, _) ->
+                let ocaml_name = Naming.field_name prop_name in
+                let is_required = List.mem prop_name required in
+                if is_required then
+                  emitln out (Printf.sprintf "      ~%s" ocaml_name)
+                else emitln out (Printf.sprintf "      ?%s" ocaml_name) )
+              obj_spec.properties
+        | Some _ ->
+            (* non-object input, take as single argument *)
+            emitln out "      ~input"
+        | None ->
+            () )
+      | None ->
+          () ) ;
+  emitln out "      (client : Hermes.client) : output Lwt.t =" ;
+  (* build params record *)
+  ( match spec.parameters with
+  | Some params when params.properties <> [] ->
+      emit out "    let params = {" ;
+      let fields =
+        List.map
+          (fun (prop_name, _) -> Naming.field_name prop_name)
+          params.properties
+      in
+      emit out (String.concat "; " fields) ;
+      emitln out "} in"
+  | _ ->
+      emitln out "    let params = () in" ) ;
+  (* generate the call based on input/output types *)
+  if input_is_bytes then begin
+    (* bytes input - choose between procedure_blob and procedure_bytes *)
+    if output_is_bytes then
+      (* bytes-in, bytes-out: use procedure_bytes *)
+      emitln out
+        (Printf.sprintf
+           "    Hermes.procedure_bytes client nsid (params_to_yojson params) \
+            input ~content_type:\"%s\""
+           input_content_type )
+    else if spec.output = None then
+      (* bytes-in, no output: use procedure_bytes and map to unit *)
+      emitln out
+        (Printf.sprintf
+           "    let open Lwt.Syntax in\n\
+           \    let* _ = Hermes.procedure_bytes client nsid (params_to_yojson \
+            params) input ~content_type:\"%s\" in\n\
+           \    Lwt.return ()"
+           input_content_type )
+    else
+      (* bytes-in, json-out: use procedure_blob *)
+      emitln out
+        (Printf.sprintf
+           "    Hermes.procedure_blob client nsid (params_to_yojson params) \
+            (Bytes.of_string (Option.value input ~default:\"\")) \
+            ~content_type:\"%s\" output_of_yojson"
+           input_content_type )
+  end
+  else begin
+    (* json input - build input and use procedure *)
+    ( match spec.input with
+    | Some body -> (
+      match body.schema with
+      | Some (Object obj_spec) ->
+          emit out "    let input = Some ({" ;
+          let fields =
+            List.map
+              (fun (prop_name, _) -> Naming.field_name prop_name)
+              obj_spec.properties
+          in
+          emit out (String.concat "; " fields) ;
+          emitln out "} |> input_to_yojson) in"
+      | Some _ ->
+          emitln out "    let input = Some (input_to_yojson input) in"
+      | None ->
+          emitln out "    let input = None in" )
+    | None ->
+        emitln out "    let input = None in" ) ;
+    emitln out
+      "    Hermes.procedure client nsid (params_to_yojson params) input \
+       output_of_yojson"
+  end ;
+  emitln out "end" ;
+  emit_newline out
+
+(* generate token constant *)
+let gen_token nsid out name (spec : token_spec) =
+  let full_uri = nsid ^ "#" ^ name in
+  emitln out
+    (Printf.sprintf "(** %s *)" (Option.value spec.description ~default:name)) ;
+  emitln out (Printf.sprintf "let %s = \"%s\"" (Naming.type_name name) full_uri) ;
+  emit_newline out
+
+(* generate string type alias (for strings with knownValues) *)
+let gen_string_type _nsid out name (spec : string_spec) =
+  let type_name = Naming.type_name name in
+  emitln out
+    (Printf.sprintf "(** String type with known values%s *)"
+       (match spec.description with Some d -> ": " ^ d | None -> "") ) ;
+  emitln out (Printf.sprintf "type %s = string" type_name) ;
+  emitln out (Printf.sprintf "let %s_of_yojson = function" type_name) ;
+  emitln out "  | `String s -> Ok s" ;
+  emitln out (Printf.sprintf "  | _ -> Error \"%s: expected string\"" type_name) ;
+  emitln out (Printf.sprintf "let %s_to_yojson s = `String s" type_name) ;
+  emit_newline out
+
+(* collect local refs from a type definition *)
+let rec collect_local_refs acc = function
+  | Array {items; _} ->
+      collect_local_refs acc items
+  | Ref {ref_; _} ->
+      if String.length ref_ > 0 && ref_.[0] = '#' then
+        let def_name = String.sub ref_ 1 (String.length ref_ - 1) in
+        def_name :: acc
+      else acc
+  | Union {refs; _} ->
+      List.fold_left
+        (fun a r ->
+          if String.length r > 0 && r.[0] = '#' then
+            let def_name = String.sub r 1 (String.length r - 1) in
+            def_name :: a
+          else a )
+        acc refs
+  | Object {properties; _} ->
+      List.fold_left
+        (fun a (_, (prop : property)) -> collect_local_refs a prop.type_def)
+        acc properties
+  | Record {record; _} ->
+      List.fold_left
+        (fun a (_, (prop : property)) -> collect_local_refs a prop.type_def)
+        acc record.properties
+  | Query {parameters; output; _} -> (
+      let acc =
+        match parameters with
+        | Some params ->
+            List.fold_left
+              (fun a (_, (prop : property)) ->
+                collect_local_refs a prop.type_def )
+              acc params.properties
+        | None ->
+            acc
+      in
+      match output with
+      | Some body ->
+          Option.fold ~none:acc ~some:(collect_local_refs acc) body.schema
+      | None ->
+          acc )
+  | Procedure {parameters; input; output; _} -> (
+      let acc =
+        match parameters with
+        | Some params ->
+            List.fold_left
+              (fun a (_, (prop : property)) ->
+                collect_local_refs a prop.type_def )
+              acc params.properties
+        | None ->
+            acc
+      in
+      let acc =
+        match input with
+        | Some body ->
+            Option.fold ~none:acc ~some:(collect_local_refs acc) body.schema
+        | None ->
+            acc
+      in
+      match output with
+      | Some body ->
+          Option.fold ~none:acc ~some:(collect_local_refs acc) body.schema
+      | None ->
+          acc )
+  | _ ->
+      acc
+
+(* sort definitions so dependencies come first *)
+let sort_definitions (defs : def_entry list) : def_entry list =
+  (* build dependency map: name -> list of dependencies *)
+  let deps =
+    List.map (fun def -> (def.name, collect_local_refs [] def.type_def)) defs
+  in
+  (* create name -> def map *)
+  let def_map = List.fold_left (fun m def -> (def.name, def) :: m) [] defs in
+  (* topological sort *)
+  let rec visit visited sorted name =
+    if List.mem name visited then (visited, sorted)
+    else
+      let visited = name :: visited in
+      let dep_names = try List.assoc name deps with Not_found -> [] in
+      let visited, sorted =
+        List.fold_left (fun (v, s) d -> visit v s d) (visited, sorted) dep_names
+      in
+      let sorted =
+        match List.assoc_opt name def_map with
+        | Some def ->
+            def :: sorted
+        | None ->
+            sorted
+      in
+      (visited, sorted)
+  in
+  let _, sorted =
+    List.fold_left (fun (v, s) def -> visit v s def.name) ([], []) defs
+  in
+  (* sorted is in reverse order, reverse it *)
+  List.rev sorted
+
+(* generate complete lexicon module *)
+let gen_lexicon_module (doc : lexicon_doc) : string =
+  let out = make_output () in
+  let nsid = doc.id in
+  (* header *)
+  emitln out (Printf.sprintf "(* generated from %s *)" nsid) ;
+  emit_newline out ;
+  (* sort definitions by dependencies *)
+  let sorted_defs = sort_definitions doc.defs in
+  (* generate each definition *)
+  List.iter
+    (fun def ->
+      match def.type_def with
+      | Object spec ->
+          gen_object_type nsid out def.name spec
+      | Union spec ->
+          gen_union_type nsid out def.name spec
+      | Token spec ->
+          gen_token nsid out def.name spec
+      | Query spec ->
+          gen_query nsid out def.name spec
+      | Procedure spec ->
+          gen_procedure nsid out def.name spec
+      | Record spec ->
+          (* generate record as object type *)
+          gen_object_type nsid out def.name spec.record
+      | String spec when spec.known_values <> None ->
+          (* generate type alias for strings with known values *)
+          gen_string_type nsid out def.name spec
+      | String _
+      | Integer _
+      | Boolean _
+      | Bytes _
+      | Blob _
+      | CidLink _
+      | Array _
+      | Ref _
+      | Unknown _
+      | Subscription _ ->
+          (* these are typically not standalone definitions *)
+          () )
+    sorted_defs ;
+  Buffer.contents out.buf
+
+(* get all imports needed for a lexicon *)
+let get_imports (doc : lexicon_doc) : string list =
+  let out = make_output () in
+  let nsid = doc.id in
+  (* traverse all definitions to collect imports *)
+  let rec collect_from_type = function
+    | Array {items; _} ->
+        collect_from_type items
+    | Ref {ref_; _} ->
+        let _ = gen_ref_type nsid out ref_ in
+        ()
+    | Union {refs; _} ->
+        List.iter
+          (fun r ->
+            let _ = gen_ref_type nsid out r in
+            () )
+          refs
+    | Object {properties; _} ->
+        List.iter
+          (fun (_, (prop : property)) -> collect_from_type prop.type_def)
+          properties
+    | Query {parameters; output; _} ->
+        Option.iter
+          (fun p ->
+            List.iter
+              (fun (_, (prop : property)) -> collect_from_type prop.type_def)
+              p.properties )
+          parameters ;
+        Option.iter (fun o -> Option.iter collect_from_type o.schema) output
+    | Procedure {parameters; input; output; _} ->
+        Option.iter
+          (fun p ->
+            List.iter
+              (fun (_, (prop : property)) -> collect_from_type prop.type_def)
+              p.properties )
+          parameters ;
+        Option.iter (fun i -> Option.iter collect_from_type i.schema) input ;
+        Option.iter (fun o -> Option.iter collect_from_type o.schema) output
+    | Record {record; _} ->
+        List.iter
+          (fun (_, (prop : property)) -> collect_from_type prop.type_def)
+          record.properties
+    | _ ->
+        ()
+  in
+  List.iter (fun def -> collect_from_type def.type_def) doc.defs ;
+  out.imports

hermes-cli/lib/dune

···
+(library
+ (name hermes_cli)
+ (libraries yojson fmt fpath str))

hermes-cli/lib/lexicon_types.ml

···
+type string_spec =
+  { format: string option
+  ; min_length: int option
+  ; max_length: int option
+  ; min_graphemes: int option
+  ; max_graphemes: int option
+  ; known_values: string list option
+  ; enum: string list option
+  ; const: string option
+  ; default: string option
+  ; description: string option }
+
+type integer_spec =
+  { minimum: int option
+  ; maximum: int option
+  ; enum: int list option
+  ; const: int option
+  ; default: int option
+  ; description: string option }
+
+type boolean_spec =
+  {const: bool option; default: bool option; description: string option}
+
+type bytes_spec =
+  {min_length: int option; max_length: int option; description: string option}
+
+type blob_spec =
+  {accept: string list option; max_size: int option; description: string option}
+
+type cid_link_spec = {description: string option}
+
+type array_spec =
+  { items: type_def
+  ; min_length: int option
+  ; max_length: int option
+  ; description: string option }
+
+and property = {type_def: type_def; description: string option}
+
+and object_spec =
+  { properties: (string * property) list
+  ; required: string list option
+  ; nullable: string list option
+  ; description: string option }
+
+and ref_spec =
+  { ref_: string (* e.g., "#localDef" or "com.example.defs#someDef" *)
+  ; description: string option }
+
+and union_spec =
+  {refs: string list; closed: bool option; description: string option}
+
+and token_spec = {description: string option}
+
+and unknown_spec = {description: string option}
+
+and params_spec =
+  { properties: (string * property) list
+  ; required: string list option
+  ; description: string option }
+
+and body_def =
+  {encoding: string; schema: type_def option; description: string option}
+
+and error_def = {name: string; description: string option}
+
+and query_spec =
+  { parameters: params_spec option
+  ; output: body_def option
+  ; errors: error_def list option
+  ; description: string option }
+
+and procedure_spec =
+  { parameters: params_spec option
+  ; input: body_def option
+  ; output: body_def option
+  ; errors: error_def list option
+  ; description: string option }
+
+and subscription_spec =
+  { parameters: params_spec option
+  ; message: body_def option
+  ; errors: error_def list option
+  ; description: string option }
+
+and record_spec =
+  { key: string (* "tid", "nsid", etc. *)
+  ; record: object_spec
+  ; description: string option }
+
+and type_def =
+  | String of string_spec
+  | Integer of integer_spec
+  | Boolean of boolean_spec
+  | Bytes of bytes_spec
+  | Blob of blob_spec
+  | CidLink of cid_link_spec
+  | Array of array_spec
+  | Object of object_spec
+  | Ref of ref_spec
+  | Union of union_spec
+  | Token of token_spec
+  | Unknown of unknown_spec
+  | Query of query_spec
+  | Procedure of procedure_spec
+  | Subscription of subscription_spec
+  | Record of record_spec
+
+type def_entry = {name: string; type_def: type_def}
+
+type lexicon_doc =
+  { lexicon: int (* always 1 *)
+  ; id: string (* nsid *)
+  ; revision: int option
+  ; description: string option
+  ; defs: def_entry list }
+
+type parse_result = (lexicon_doc, string) result

hermes-cli/lib/naming.ml

···
+(* ocaml reserved keywords that need escaping *)
+let reserved_keywords =
+  [ "and"
+  ; "as"
+  ; "assert"
+  ; "asr"
+  ; "begin"
+  ; "class"
+  ; "constraint"
+  ; "do"
+  ; "done"
+  ; "downto"
+  ; "else"
+  ; "end"
+  ; "exception"
+  ; "external"
+  ; "false"
+  ; "for"
+  ; "fun"
+  ; "function"
+  ; "functor"
+  ; "if"
+  ; "in"
+  ; "include"
+  ; "inherit"
+  ; "initializer"
+  ; "land"
+  ; "lazy"
+  ; "let"
+  ; "lor"
+  ; "lsl"
+  ; "lsr"
+  ; "lxor"
+  ; "match"
+  ; "method"
+  ; "mod"
+  ; "module"
+  ; "mutable"
+  ; "new"
+  ; "nonrec"
+  ; "object"
+  ; "of"
+  ; "open"
+  ; "or"
+  ; "private"
+  ; "rec"
+  ; "sig"
+  ; "struct"
+  ; "then"
+  ; "to"
+  ; "true"
+  ; "try"
+  ; "type"
+  ; "val"
+  ; "virtual"
+  ; "when"
+  ; "while"
+  ; "with" ]
+
+let is_reserved name = List.mem (String.lowercase_ascii name) reserved_keywords
+
+(* convert camelCase to snake_case *)
+let camel_to_snake s =
+  let buf = Buffer.create (String.length s * 2) in
+  String.iteri
+    (fun i c ->
+      if Char.uppercase_ascii c = c && c <> Char.lowercase_ascii c then begin
+        if i > 0 then Buffer.add_char buf '_' ;
+        Buffer.add_char buf (Char.lowercase_ascii c)
+      end
+      else Buffer.add_char buf c )
+    s ;
+  Buffer.contents buf
+
+let escape_keyword name = if is_reserved name then name ^ "_" else name
+
+let field_name name = escape_keyword (camel_to_snake name)
+
+let module_name_of_segment segment =
+  if String.length segment = 0 then segment else String.capitalize_ascii segment
+
+let module_path_of_nsid nsid =
+  String.split_on_char '.' nsid |> List.map module_name_of_segment
+
+let type_name_of_nsid nsid =
+  let segments = String.split_on_char '.' nsid in
+  match List.rev segments with
+  | last :: _ ->
+      camel_to_snake last
+  | [] ->
+      "unknown"
+
+let type_name name = escape_keyword (camel_to_snake name)
+
+let def_module_name name = String.capitalize_ascii name
+
+(* generate variant constructor name from ref *)
+let variant_name_of_ref ref_str =
+  (* "#localDef" -> "LocalDef", "com.example.defs#someDef" -> "SomeDef" *)
+  let name =
+    match String.split_on_char '#' ref_str with
+    | [_; def] ->
+        def
+    | [def] -> (
+      (* just nsid, use last segment *)
+      match List.rev (String.split_on_char '.' def) with
+      | last :: _ ->
+          last
+      | [] ->
+          "Unknown" )
+    | _ ->
+        "Unknown"
+  in
+  String.capitalize_ascii name
+
+let union_type_name refs =
+  match refs with
+  | [] ->
+      "unknown_union"
+  | [r] ->
+      type_name (variant_name_of_ref r)
+  | _ -> (
+      (* use first two refs to generate a name *)
+      let names = List.map variant_name_of_ref refs in
+      let sorted = List.sort String.compare names in
+      match sorted with
+      | a :: b :: _ ->
+          camel_to_snake a ^ "_or_" ^ camel_to_snake b
+      | [a] ->
+          camel_to_snake a
+      | [] ->
+          "unknown_union" )
+
+(* convert nsid to flat file path and module name *)
+let flat_name_of_nsid nsid = String.split_on_char '.' nsid |> String.concat "_"
+
+let file_path_of_nsid nsid = flat_name_of_nsid nsid ^ ".ml"
+
+let flat_module_name_of_nsid nsid =
+  String.capitalize_ascii (flat_name_of_nsid nsid)
+
+let needs_key_annotation original_name ocaml_name = original_name <> ocaml_name
+
+let key_annotation original_name ocaml_name =
+  if needs_key_annotation original_name ocaml_name then
+    Printf.sprintf " [@key \"%s\"]" original_name
+  else ""

hermes-cli/lib/parser.ml

···
+(* parse lexicon json files into lexicon_types *)
+
+open Lexicon_types
+
+let get_string_opt key json =
+  match json with
+  | `Assoc pairs -> (
+    match List.assoc_opt key pairs with Some (`String s) -> Some s | _ -> None )
+  | _ ->
+      None
+
+let get_string key json =
+  match get_string_opt key json with
+  | Some s ->
+      s
+  | None ->
+      failwith ("missing required string field: " ^ key)
+
+let get_int_opt key json =
+  match json with
+  | `Assoc pairs -> (
+    match List.assoc_opt key pairs with Some (`Int i) -> Some i | _ -> None )
+  | _ ->
+      None
+
+let get_int key json =
+  match get_int_opt key json with
+  | Some i ->
+      i
+  | None ->
+      failwith ("missing required int field: " ^ key)
+
+let get_bool_opt key json =
+  match json with
+  | `Assoc pairs -> (
+    match List.assoc_opt key pairs with Some (`Bool b) -> Some b | _ -> None )
+  | _ ->
+      None
+
+let get_list_opt key json =
+  match json with
+  | `Assoc pairs -> (
+    match List.assoc_opt key pairs with Some (`List l) -> Some l | _ -> None )
+  | _ ->
+      None
+
+let get_string_list_opt key json =
+  match get_list_opt key json with
+  | Some l ->
+      Some (List.filter_map (function `String s -> Some s | _ -> None) l)
+  | None ->
+      None
+
+let get_int_list_opt key json =
+  match get_list_opt key json with
+  | Some l ->
+      Some (List.filter_map (function `Int i -> Some i | _ -> None) l)
+  | None ->
+      None
+
+let get_assoc key json =
+  match json with
+  | `Assoc pairs -> (
+    match List.assoc_opt key pairs with
+    | Some (`Assoc _ as a) ->
+        Some a
+    | _ ->
+        None )
+  | _ ->
+      None
+
+(* parse type definition from json *)
+let rec parse_type_def json : type_def =
+  let type_str = get_string "type" json in
+  match type_str with
+  | "string" ->
+      String
+        { format= get_string_opt "format" json
+        ; min_length= get_int_opt "minLength" json
+        ; max_length= get_int_opt "maxLength" json
+        ; min_graphemes= get_int_opt "minGraphemes" json
+        ; max_graphemes= get_int_opt "maxGraphemes" json
+        ; known_values= get_string_list_opt "knownValues" json
+        ; enum= get_string_list_opt "enum" json
+        ; const= get_string_opt "const" json
+        ; default= get_string_opt "default" json
+        ; description= get_string_opt "description" json }
+  | "integer" ->
+      Integer
+        { minimum= get_int_opt "minimum" json
+        ; maximum= get_int_opt "maximum" json
+        ; enum= get_int_list_opt "enum" json
+        ; const= get_int_opt "const" json
+        ; default= get_int_opt "default" json
+        ; description= get_string_opt "description" json }
+  | "boolean" ->
+      Boolean
+        { const= get_bool_opt "const" json
+        ; default= get_bool_opt "default" json
+        ; description= get_string_opt "description" json }
+  | "bytes" ->
+      Bytes
+        { min_length= get_int_opt "minLength" json
+        ; max_length= get_int_opt "maxLength" json
+        ; description= get_string_opt "description" json }
+  | "blob" ->
+      Blob
+        { accept= get_string_list_opt "accept" json
+        ; max_size= get_int_opt "maxSize" json
+        ; description= get_string_opt "description" json }
+  | "cid-link" ->
+      CidLink {description= get_string_opt "description" json}
+  | "array" ->
+      let items_json =
+        match get_assoc "items" json with
+        | Some j ->
+            j
+        | None ->
+            failwith "array type missing items"
+      in
+      Array
+        { items= parse_type_def items_json
+        ; min_length= get_int_opt "minLength" json
+        ; max_length= get_int_opt "maxLength" json
+        ; description= get_string_opt "description" json }
+  | "object" ->
+      Object (parse_object_spec json)
+  | "ref" ->
+      Ref
+        { ref_= get_string "ref" json
+        ; description= get_string_opt "description" json }
+  | "union" ->
+      Union
+        { refs=
+            ( match get_string_list_opt "refs" json with
+            | Some l ->
+                l
+            | None ->
+                [] )
+        ; closed= get_bool_opt "closed" json
+        ; description= get_string_opt "description" json }
+  | "token" ->
+      Token {description= get_string_opt "description" json}
+  | "unknown" ->
+      Unknown {description= get_string_opt "description" json}
+  | "query" ->
+      Query (parse_query_spec json)
+  | "procedure" ->
+      Procedure (parse_procedure_spec json)
+  | "subscription" ->
+      Subscription (parse_subscription_spec json)
+  | "record" ->
+      Record (parse_record_spec json)
+  | t ->
+      failwith ("unknown type: " ^ t)
+
+and parse_object_spec json : object_spec =
+  let properties =
+    match get_assoc "properties" json with
+    | Some (`Assoc pairs) ->
+        List.map
+          (fun (name, prop_json) ->
+            let type_def = parse_type_def prop_json in
+            let description = get_string_opt "description" prop_json in
+            (name, {type_def; description}) )
+          pairs
+    | _ ->
+        []
+  in
+  { properties
+  ; required= get_string_list_opt "required" json
+  ; nullable= get_string_list_opt "nullable" json
+  ; description= get_string_opt "description" json }
+
+and parse_params_spec json : params_spec =
+  let properties =
+    match get_assoc "properties" json with
+    | Some (`Assoc pairs) ->
+        List.map
+          (fun (name, prop_json) ->
+            let type_def = parse_type_def prop_json in
+            let description = get_string_opt "description" prop_json in
+            (name, {type_def; description}) )
+          pairs
+    | _ ->
+        []
+  in
+  { properties
+  ; required= get_string_list_opt "required" json
+  ; description= get_string_opt "description" json }
+
+and parse_body_def json : body_def =
+  { encoding= get_string "encoding" json
+  ; schema=
+      ( match get_assoc "schema" json with
+      | Some j ->
+          Some (parse_type_def j)
+      | None ->
+          None )
+  ; description= get_string_opt "description" json }
+
+and parse_error_def json : error_def =
+  {name= get_string "name" json; description= get_string_opt "description" json}
+
+and parse_query_spec json : query_spec =
+  let parameters =
+    match get_assoc "parameters" json with
+    | Some j ->
+        Some (parse_params_spec j)
+    | None ->
+        None
+  in
+  let output =
+    match get_assoc "output" json with
+    | Some j ->
+        Some (parse_body_def j)
+    | None ->
+        None
+  in
+  let errors =
+    match get_list_opt "errors" json with
+    | Some l ->
+        Some
+          (List.map
+             (function
+               | `Assoc _ as j ->
+                   parse_error_def j
+               | _ ->
+                   failwith "invalid error def" )
+             l )
+    | None ->
+        None
+  in
+  {parameters; output; errors; description= get_string_opt "description" json}
+
+and parse_procedure_spec json : procedure_spec =
+  let parameters =
+    match get_assoc "parameters" json with
+    | Some j ->
+        Some (parse_params_spec j)
+    | None ->
+        None
+  in
+  let input =
+    match get_assoc "input" json with
+    | Some j ->
+        Some (parse_body_def j)
+    | None ->
+        None
+  in
+  let output =
+    match get_assoc "output" json with
+    | Some j ->
+        Some (parse_body_def j)
+    | None ->
+        None
+  in
+  let errors =
+    match get_list_opt "errors" json with
+    | Some l ->
+        Some
+          (List.map
+             (function
+               | `Assoc _ as j ->
+                   parse_error_def j
+               | _ ->
+                   failwith "invalid error def" )
+             l )
+    | None ->
+        None
+  in
+  { parameters
+  ; input
+  ; output
+  ; errors
+  ; description= get_string_opt "description" json }
+
+and parse_subscription_spec json : subscription_spec =
+  let parameters =
+    match get_assoc "parameters" json with
+    | Some j ->
+        Some (parse_params_spec j)
+    | None ->
+        None
+  in
+  let message =
+    match get_assoc "message" json with
+    | Some j ->
+        Some (parse_body_def j)
+    | None ->
+        None
+  in
+  let errors =
+    match get_list_opt "errors" json with
+    | Some l ->
+        Some
+          (List.map
+             (function
+               | `Assoc _ as j ->
+                   parse_error_def j
+               | _ ->
+                   failwith "invalid error def" )
+             l )
+    | None ->
+        None
+  in
+  {parameters; message; errors; description= get_string_opt "description" json}
+
+and parse_record_spec json : record_spec =
+  let key = get_string "key" json in
+  let record_json =
+    match get_assoc "record" json with
+    | Some j ->
+        j
+    | None ->
+        failwith "record type missing record field"
+  in
+  { key
+  ; record= parse_object_spec record_json
+  ; description= get_string_opt "description" json }
+
+(* parse complete lexicon document *)
+let parse_lexicon_doc json : lexicon_doc =
+  let lexicon = get_int "lexicon" json in
+  let id = get_string "id" json in
+  let revision = get_int_opt "revision" json in
+  let description = get_string_opt "description" json in
+  let defs =
+    match get_assoc "defs" json with
+    | Some (`Assoc pairs) ->
+        List.map
+          (fun (name, def_json) -> {name; type_def= parse_type_def def_json})
+          pairs
+    | _ ->
+        []
+  in
+  {lexicon; id; revision; description; defs}
+
+(* parse lexicon file *)
+let parse_file path : parse_result =
+  try
+    let json = Yojson.Safe.from_file path in
+    Ok (parse_lexicon_doc json)
+  with
+  | Yojson.Json_error e ->
+      Error ("JSON parse error: " ^ e)
+  | Failure e ->
+      Error ("Parse error: " ^ e)
+  | e ->
+      Error ("Unexpected error: " ^ Printexc.to_string e)
+
+(* parse json string *)
+let parse_string content : parse_result =
+  try
+    let json = Yojson.Safe.from_string content in
+    Ok (parse_lexicon_doc json)
+  with
+  | Yojson.Json_error e ->
+      Error ("JSON parse error: " ^ e)
+  | Failure e ->
+      Error ("Parse error: " ^ e)
+  | e ->
+      Error ("Unexpected error: " ^ Printexc.to_string e)

hermes-cli/test/dune

···
+(test
+ (name test_naming)
+ (libraries alcotest hermes_cli))
+
+(test
+ (name test_parser)
+ (libraries alcotest hermes_cli yojson))
+
+(test
+ (name test_codegen)
+ (libraries alcotest hermes_cli))

hermes-cli/test/test_codegen.ml

···
+open Alcotest
+open Hermes_cli
+
+let contains s1 s2 =
+  try
+    let len = String.length s2 in
+    for i = 0 to String.length s1 - len do
+      if String.sub s1 i len = s2 then raise Exit
+    done ;
+    false
+  with Exit -> true
+
+(* create a simple lexicon doc for testing *)
+let make_lexicon id defs =
+  {Lexicon_types.lexicon= 1; id; revision= None; description= None; defs}
+
+let make_def name type_def = {Lexicon_types.name; type_def}
+
+let make_object_spec properties required =
+  { Lexicon_types.properties
+  ; required= Some required
+  ; nullable= None
+  ; description= None }
+
+let make_property type_def = {Lexicon_types.type_def; description= None}
+
+let string_type =
+  Lexicon_types.String
+    { format= None
+    ; min_length= None
+    ; max_length= None
+    ; min_graphemes= None
+    ; max_graphemes= None
+    ; known_values= None
+    ; enum= None
+    ; const= None
+    ; default= None
+    ; description= None }
+
+let int_type =
+  Lexicon_types.Integer
+    { minimum= None
+    ; maximum= None
+    ; enum= None
+    ; const= None
+    ; default= None
+    ; description= None }
+
+let[@warning "-32"] _bool_type =
+  Lexicon_types.Boolean {const= None; default= None; description= None}
+
+(* test generating a simple object type *)
+let test_gen_simple_object () =
+  let obj_spec =
+    make_object_spec
+      [("name", make_property string_type); ("age", make_property int_type)]
+      ["name"; "age"]
+  in
+  let doc =
+    make_lexicon "com.example.test"
+      [make_def "main" (Lexicon_types.Object obj_spec)]
+  in
+  let code = Codegen.gen_lexicon_module doc in
+  check bool "contains type main" true (contains code "type main =") ;
+  check bool "contains name field" true (contains code "name: string") ;
+  check bool "contains age field" true (contains code "age: int") ;
+  check bool "contains deriving" true (contains code "[@@deriving yojson")
+
+(* test generating object with optional fields *)
+let test_gen_optional_fields () =
+  let obj_spec =
+    make_object_spec
+      [ ("required_field", make_property string_type)
+      ; ("optional_field", make_property string_type) ]
+      ["required_field"]
+    (* only required_field is required *)
+  in
+  let doc =
+    make_lexicon "com.example.optional"
+      [make_def "main" (Lexicon_types.Object obj_spec)]
+  in
+  let code = Codegen.gen_lexicon_module doc in
+  check bool "required not option" true
+    (contains code "required_field: string;") ;
+  check bool "optional is option" true
+    (contains code "optional_field: string option")
+
+(* test generating with key annotation *)
+let test_gen_key_annotation () =
+  let obj_spec =
+    make_object_spec [("firstName", make_property string_type)] ["firstName"]
+  in
+  let doc =
+    make_lexicon "com.example.key"
+      [make_def "main" (Lexicon_types.Object obj_spec)]
+  in
+  let code = Codegen.gen_lexicon_module doc in
+  check bool "has snake_case field" true (contains code "first_name:") ;
+  check bool "has key annotation" true (contains code "[@key \"firstName\"]")
+
+(* test generating union type *)
+let test_gen_union_type () =
+  let union_spec =
+    { Lexicon_types.refs= ["#typeA"; "#typeB"]
+    ; closed= Some false
+    ; description= None }
+  in
+  let doc =
+    make_lexicon "com.example.union"
+      [make_def "result" (Lexicon_types.Union union_spec)]
+  in
+  let code = Codegen.gen_lexicon_module doc in
+  check bool "contains type result" true (contains code "type result =") ;
+  check bool "contains TypeA variant" true (contains code "| TypeA of") ;
+  check bool "contains TypeB variant" true (contains code "| TypeB of") ;
+  check bool "contains Unknown (open)" true
+    (contains code "| Unknown of Yojson.Safe.t")
+
+(* test generating closed union *)
+let test_gen_closed_union () =
+  let union_spec =
+    { Lexicon_types.refs= ["#typeA"; "#typeB"]
+    ; closed= Some true
+    ; description= None }
+  in
+  let doc =
+    make_lexicon "com.example.closed"
+      [make_def "result" (Lexicon_types.Union union_spec)]
+  in
+  let code = Codegen.gen_lexicon_module doc in
+  check bool "no Unknown variant" false (contains code "| Unknown of")
+
+(* test generating query module *)
+let test_gen_query_module () =
+  let params_spec =
+    { Lexicon_types.properties= [("userId", make_property string_type)]
+    ; required= Some ["userId"]
+    ; description= None }
+  in
+  let output_schema =
+    Lexicon_types.Object
+      (make_object_spec [("name", make_property string_type)] ["name"])
+  in
+  let output_body =
+    { Lexicon_types.encoding= "application/json"
+    ; schema= Some output_schema
+    ; description= None }
+  in
+  let query_spec =
+    { Lexicon_types.parameters= Some params_spec
+    ; output= Some output_body
+    ; errors= None
+    ; description= Some "Get user by ID" }
+  in
+  let doc =
+    make_lexicon "com.example.getUser"
+      [make_def "main" (Lexicon_types.Query query_spec)]
+  in
+  let code = Codegen.gen_lexicon_module doc in
+  check bool "contains module Main" true (contains code "module Main = struct") ;
+  check bool "contains nsid" true
+    (contains code "let nsid = \"com.example.getUser\"") ;
+  check bool "contains type params" true (contains code "type params =") ;
+  check bool "contains type output" true (contains code "type output =") ;
+  check bool "contains call function" true (contains code "let call") ;
+  check bool "contains ~user_id param" true (contains code "~user_id") ;
+  check bool "calls Hermes.query" true (contains code "Hermes.query")
+
+(* test generating procedure module *)
+let test_gen_procedure_module () =
+  let input_schema =
+    Lexicon_types.Object
+      (make_object_spec
+         [ ("name", make_property string_type)
+         ; ("email", make_property string_type) ]
+         ["name"; "email"] )
+  in
+  let input_body =
+    { Lexicon_types.encoding= "application/json"
+    ; schema= Some input_schema
+    ; description= None }
+  in
+  let output_schema =
+    Lexicon_types.Object
+      (make_object_spec [("id", make_property string_type)] ["id"])
+  in
+  let output_body =
+    { Lexicon_types.encoding= "application/json"
+    ; schema= Some output_schema
+    ; description= None }
+  in
+  let proc_spec =
+    { Lexicon_types.parameters= None
+    ; input= Some input_body
+    ; output= Some output_body
+    ; errors= None
+    ; description= Some "Create user" }
+  in
+  let doc =
+    make_lexicon "com.example.createUser"
+      [make_def "main" (Lexicon_types.Procedure proc_spec)]
+  in
+  let code = Codegen.gen_lexicon_module doc in
+  check bool "contains module Main" true (contains code "module Main = struct") ;
+  check bool "contains type input" true (contains code "type input =") ;
+  check bool "contains type output" true (contains code "type output =") ;
+  check bool "contains call function" true (contains code "let call") ;
+  check bool "contains ~name param" true (contains code "~name") ;
+  check bool "contains ~email param" true (contains code "~email") ;
+  check bool "calls Hermes.procedure" true (contains code "Hermes.procedure")
+
+(* test type ordering with dependencies *)
+let test_type_ordering () =
+  (* create types where typeB depends on typeA *)
+  let type_a_spec =
+    make_object_spec [("value", make_property string_type)] ["value"]
+  in
+  let type_b_spec =
+    make_object_spec
+      [ ( "a"
+        , make_property (Lexicon_types.Ref {ref_= "#typeA"; description= None})
+        ) ]
+      ["a"]
+  in
+  let doc =
+    make_lexicon "com.example.order"
+      [ make_def "typeB" (Lexicon_types.Object type_b_spec)
+      ; make_def "typeA" (Lexicon_types.Object type_a_spec) ]
+  in
+  let code = Codegen.gen_lexicon_module doc in
+  (* typeA should appear before typeB in the generated code *)
+  let pos_a =
+    try Some (Str.search_forward (Str.regexp "type type_a") code 0)
+    with Not_found -> None
+  in
+  let pos_b =
+    try Some (Str.search_forward (Str.regexp "type type_b") code 0)
+    with Not_found -> None
+  in
+  match (pos_a, pos_b) with
+  | Some a, Some b ->
+      check bool "typeA before typeB" true (a < b)
+  | _ ->
+      fail "both types should be present"
+
+(* test generating token *)
+let test_gen_token () =
+  let token_spec : Lexicon_types.token_spec =
+    {description= Some "A token value"}
+  in
+  let doc =
+    make_lexicon "com.example.tokens"
+      [make_def "myToken" (Lexicon_types.Token token_spec)]
+  in
+  let code = Codegen.gen_lexicon_module doc in
+  check bool "contains let my_token" true (contains code "let my_token =") ;
+  check bool "contains full URI" true
+    (contains code "com.example.tokens#myToken")
+
+(* test generating query with bytes output (like getBlob) *)
+let test_gen_query_bytes_output () =
+  let params_spec =
+    { Lexicon_types.properties=
+        [("did", make_property string_type); ("cid", make_property string_type)]
+    ; required= Some ["did"; "cid"]
+    ; description= None }
+  in
+  let output_body =
+    { Lexicon_types.encoding= "*/*" (* bytes output *)
+    ; schema= None
+    ; description= None }
+  in
+  let query_spec =
+    { Lexicon_types.parameters= Some params_spec
+    ; output= Some output_body
+    ; errors= None
+    ; description= Some "Get a blob" }
+  in
+  let doc =
+    make_lexicon "com.atproto.sync.getBlob"
+      [make_def "main" (Lexicon_types.Query query_spec)]
+  in
+  let code = Codegen.gen_lexicon_module doc in
+  check bool "contains module Main" true (contains code "module Main = struct") ;
+  check bool "output is string * string tuple" true
+    (contains code "type output = string * string") ;
+  check bool "calls Hermes.query_bytes" true
+    (contains code "Hermes.query_bytes")
+
+(* test generating procedure with bytes input (like importRepo) *)
+let test_gen_procedure_bytes_input () =
+  let input_body =
+    { Lexicon_types.encoding= "application/vnd.ipld.car" (* bytes input *)
+    ; schema= None
+    ; description= None }
+  in
+  let proc_spec =
+    { Lexicon_types.parameters= None
+    ; input= Some input_body
+    ; output= None
+    ; errors= None
+    ; description= Some "Import a repo" }
+  in
+  let doc =
+    make_lexicon "com.atproto.repo.importRepo"
+      [make_def "main" (Lexicon_types.Procedure proc_spec)]
+  in
+  let code = Codegen.gen_lexicon_module doc in
+  check bool "contains module Main" true (contains code "module Main = struct") ;
+  check bool "has ?input param" true (contains code "?input") ;
+  check bool "calls Hermes.procedure_bytes" true
+    (contains code "Hermes.procedure_bytes") ;
+  check bool "has content_type" true (contains code "application/vnd.ipld.car")
+
+(** tests *)
+
+let object_tests =
+  [ ("simple object", `Quick, test_gen_simple_object)
+  ; ("optional fields", `Quick, test_gen_optional_fields)
+  ; ("key annotation", `Quick, test_gen_key_annotation) ]
+
+let union_tests =
+  [ ("open union", `Quick, test_gen_union_type)
+  ; ("closed union", `Quick, test_gen_closed_union) ]
+
+let xrpc_tests =
+  [ ("query module", `Quick, test_gen_query_module)
+  ; ("procedure module", `Quick, test_gen_procedure_module)
+  ; ("query with bytes output", `Quick, test_gen_query_bytes_output)
+  ; ("procedure with bytes input", `Quick, test_gen_procedure_bytes_input) ]
+
+let ordering_tests = [("type ordering", `Quick, test_type_ordering)]
+
+let token_tests = [("token generation", `Quick, test_gen_token)]
+
+let () =
+  run "Codegen"
+    [ ("objects", object_tests)
+    ; ("unions", union_tests)
+    ; ("xrpc", xrpc_tests)
+    ; ("ordering", ordering_tests)
+    ; ("tokens", token_tests) ]

hermes-cli/test/test_naming.ml

···
+open Alcotest
+open Hermes_cli.Naming
+
+(** helpers *)
+let test_string = testable Fmt.string String.equal
+
+let test_camel_to_snake_simple () =
+  check test_string "simple camelCase" "first_name" (camel_to_snake "firstName")
+
+let test_camel_to_snake_single () =
+  check test_string "single word" "name" (camel_to_snake "name")
+
+let test_camel_to_snake_already_snake () =
+  check test_string "already snake_case" "first_name"
+    (camel_to_snake "first_name")
+
+let test_camel_to_snake_multiple_caps () =
+  check test_string "multiple caps" "auth_factor_token"
+    (camel_to_snake "authFactorToken")
+
+let test_camel_to_snake_leading_cap () =
+  check test_string "leading capital" "name" (camel_to_snake "Name")
+
+let test_camel_to_snake_all_caps () =
+  check test_string "all caps sequence" "d_i_d" (camel_to_snake "DID")
+
+let test_camel_to_snake_empty () =
+  check test_string "empty string" "" (camel_to_snake "")
+
+let test_is_reserved_type () =
+  check bool "type is reserved" true (is_reserved "type")
+
+let test_is_reserved_module () =
+  check bool "module is reserved" true (is_reserved "module")
+
+let test_is_reserved_and () =
+  check bool "and is reserved" true (is_reserved "and")
+
+let test_is_reserved_user () =
+  check bool "user is not reserved" false (is_reserved "user")
+
+let test_is_reserved_case_insensitive () =
+  check bool "TYPE is reserved (case insensitive)" true (is_reserved "TYPE")
+
+let test_escape_keyword_reserved () =
+  check test_string "escapes type" "type_" (escape_keyword "type")
+
+let test_escape_keyword_not_reserved () =
+  check test_string "does not escape user" "user" (escape_keyword "user")
+
+let test_escape_keyword_module () =
+  check test_string "escapes module" "module_" (escape_keyword "module")
+
+let test_field_name_camel () =
+  check test_string "converts camelCase" "first_name" (field_name "firstName")
+
+let test_field_name_reserved () =
+  check test_string "escapes reserved" "type_" (field_name "type")
+
+let test_field_name_camel_reserved () =
+  check test_string "converts and escapes" "to_" (field_name "to")
+
+let test_module_name_simple () =
+  check test_string "capitalizes" "App" (module_name_of_segment "app")
+
+let test_module_name_already_cap () =
+  check test_string "already capitalized" "App" (module_name_of_segment "App")
+
+let test_module_name_empty () =
+  check test_string "empty string" "" (module_name_of_segment "")
+
+let test_module_path_simple () =
+  check (list test_string) "simple path" ["App"; "Bsky"; "Graph"]
+    (module_path_of_nsid "app.bsky.graph")
+
+let test_module_path_single () =
+  check (list test_string) "single segment" ["App"] (module_path_of_nsid "app")
+
+let test_module_path_full () =
+  check (list test_string) "full nsid"
+    ["Com"; "Atproto"; "Server"; "CreateSession"]
+    (module_path_of_nsid "com.atproto.server.createSession")
+
+let test_type_name_of_nsid () =
+  check test_string "extracts last segment" "get_profile"
+    (type_name_of_nsid "app.bsky.actor.getProfile")
+
+let test_type_name_simple () =
+  check test_string "converts name" "invite_code" (type_name "inviteCode")
+
+let test_type_name_reserved () =
+  check test_string "escapes reserved" "type_" (type_name "type")
+
+let test_def_module_name () =
+  check test_string "capitalizes" "InviteCode" (def_module_name "inviteCode")
+
+let test_variant_local_ref () =
+  check test_string "local ref" "Relationship"
+    (variant_name_of_ref "#relationship")
+
+let test_variant_external_ref () =
+  check test_string "external ref" "SomeDef"
+    (variant_name_of_ref "com.example.defs#someDef")
+
+let test_variant_just_nsid () =
+  check test_string "just nsid" "Defs" (variant_name_of_ref "com.example.defs")
+
+let test_flat_module_name () =
+  check test_string "flat name" "Com_atproto_server_defs"
+    (flat_module_name_of_nsid "com.atproto.server.defs")
+
+let test_flat_module_name_short () =
+  check test_string "short nsid" "App_bsky"
+    (flat_module_name_of_nsid "app.bsky")
+
+let test_file_path () =
+  check test_string "file path" "com_atproto_server_defs.ml"
+    (file_path_of_nsid "com.atproto.server.defs")
+
+let test_key_annotation_needed () =
+  check test_string "annotation needed" " [@key \"firstName\"]"
+    (key_annotation "firstName" "first_name")
+
+let test_key_annotation_not_needed () =
+  check test_string "annotation not needed" "" (key_annotation "name" "name")
+
+let camel_to_snake_tests =
+  [ ("simple camelCase", `Quick, test_camel_to_snake_simple)
+  ; ("single word", `Quick, test_camel_to_snake_single)
+  ; ("already snake_case", `Quick, test_camel_to_snake_already_snake)
+  ; ("multiple caps", `Quick, test_camel_to_snake_multiple_caps)
+  ; ("leading capital", `Quick, test_camel_to_snake_leading_cap)
+  ; ("all caps", `Quick, test_camel_to_snake_all_caps)
+  ; ("empty string", `Quick, test_camel_to_snake_empty) ]
+
+let is_reserved_tests =
+  [ ("type is reserved", `Quick, test_is_reserved_type)
+  ; ("module is reserved", `Quick, test_is_reserved_module)
+  ; ("and is reserved", `Quick, test_is_reserved_and)
+  ; ("user is not reserved", `Quick, test_is_reserved_user)
+  ; ("case insensitive", `Quick, test_is_reserved_case_insensitive) ]
+
+let escape_keyword_tests =
+  [ ("escapes reserved", `Quick, test_escape_keyword_reserved)
+  ; ("does not escape non-reserved", `Quick, test_escape_keyword_not_reserved)
+  ; ("escapes module", `Quick, test_escape_keyword_module) ]
+
+let field_name_tests =
+  [ ("converts camelCase", `Quick, test_field_name_camel)
+  ; ("escapes reserved", `Quick, test_field_name_reserved)
+  ; ("converts and escapes", `Quick, test_field_name_camel_reserved) ]
+
+let module_name_tests =
+  [ ("capitalizes segment", `Quick, test_module_name_simple)
+  ; ("already capitalized", `Quick, test_module_name_already_cap)
+  ; ("empty string", `Quick, test_module_name_empty)
+  ; ("module path simple", `Quick, test_module_path_simple)
+  ; ("module path single", `Quick, test_module_path_single)
+  ; ("module path full", `Quick, test_module_path_full) ]
+
+let type_name_tests =
+  [ ("type_name_of_nsid", `Quick, test_type_name_of_nsid)
+  ; ("type_name simple", `Quick, test_type_name_simple)
+  ; ("type_name reserved", `Quick, test_type_name_reserved)
+  ; ("def_module_name", `Quick, test_def_module_name) ]
+
+let variant_name_tests =
+  [ ("local ref", `Quick, test_variant_local_ref)
+  ; ("external ref", `Quick, test_variant_external_ref)
+  ; ("just nsid", `Quick, test_variant_just_nsid) ]
+
+let flat_module_tests =
+  [ ("flat module name", `Quick, test_flat_module_name)
+  ; ("flat module short", `Quick, test_flat_module_name_short)
+  ; ("file path", `Quick, test_file_path) ]
+
+let annotation_tests =
+  [ ("annotation needed", `Quick, test_key_annotation_needed)
+  ; ("annotation not needed", `Quick, test_key_annotation_not_needed) ]
+
+let () =
+  run "Naming"
+    [ ("camel_to_snake", camel_to_snake_tests)
+    ; ("is_reserved", is_reserved_tests)
+    ; ("escape_keyword", escape_keyword_tests)
+    ; ("field_name", field_name_tests)
+    ; ("module_name", module_name_tests)
+    ; ("type_name", type_name_tests)
+    ; ("variant_name", variant_name_tests)
+    ; ("flat_module", flat_module_tests)
+    ; ("annotations", annotation_tests) ]

hermes-cli/test/test_parser.ml

···
+open Alcotest
+open Hermes_cli
+
+(** helpers *)
+let test_string = testable Fmt.string String.equal
+
+(* parsing a simple object type *)
+let test_parse_simple_object () =
+  let json =
+    {|{
+    "lexicon": 1,
+    "id": "com.example.test",
+    "defs": {
+      "main": {
+        "type": "object",
+        "properties": {
+          "name": {"type": "string"},
+          "count": {"type": "integer"}
+        },
+        "required": ["name"]
+      }
+    }
+  }|}
+  in
+  match Parser.parse_string json with
+  | Ok doc ->
+      check test_string "id matches" "com.example.test" doc.id ;
+      check int "lexicon version" 1 doc.lexicon ;
+      check int "one definition" 1 (List.length doc.defs)
+  | Error e ->
+      fail ("parse failed: " ^ e)
+
+(* parsing string type with constraints *)
+let test_parse_string_type () =
+  let json =
+    {|{
+    "lexicon": 1,
+    "id": "com.example.string",
+    "defs": {
+      "main": {
+        "type": "object",
+        "properties": {
+          "handle": {
+            "type": "string",
+            "format": "handle",
+            "minLength": 3,
+            "maxLength": 50
+          }
+        }
+      }
+    }
+  }|}
+  in
+  match Parser.parse_string json with
+  | Ok doc -> (
+      check int "one definition" 1 (List.length doc.defs) ;
+      let def = List.hd doc.defs in
+      match def.type_def with
+      | Lexicon_types.Object spec -> (
+          check int "one property" 1 (List.length spec.properties) ;
+          let _, prop = List.hd spec.properties in
+          match prop.type_def with
+          | Lexicon_types.String s ->
+              check (option test_string) "format" (Some "handle") s.format ;
+              check (option int) "minLength" (Some 3) s.min_length ;
+              check (option int) "maxLength" (Some 50) s.max_length
+          | _ ->
+              fail "expected string type" )
+      | _ ->
+          fail "expected object type" )
+  | Error e ->
+      fail ("parse failed: " ^ e)
+
+(* parsing array type *)
+let test_parse_array_type () =
+  let json =
+    {|{
+    "lexicon": 1,
+    "id": "com.example.array",
+    "defs": {
+      "main": {
+        "type": "object",
+        "properties": {
+          "items": {
+            "type": "array",
+            "items": {"type": "string"},
+            "maxLength": 100
+          }
+        }
+      }
+    }
+  }|}
+  in
+  match Parser.parse_string json with
+  | Ok doc -> (
+      let def = List.hd doc.defs in
+      match def.type_def with
+      | Lexicon_types.Object spec -> (
+          let _, prop = List.hd spec.properties in
+          match prop.type_def with
+          | Lexicon_types.Array arr -> (
+              check (option int) "maxLength" (Some 100) arr.max_length ;
+              match arr.items with
+              | Lexicon_types.String _ ->
+                  ()
+              | _ ->
+                  fail "expected string items" )
+          | _ ->
+              fail "expected array type" )
+      | _ ->
+          fail "expected object type" )
+  | Error e ->
+      fail ("parse failed: " ^ e)
+
+(* parsing ref type *)
+let test_parse_ref_type () =
+  let json =
+    {|{
+    "lexicon": 1,
+    "id": "com.example.ref",
+    "defs": {
+      "main": {
+        "type": "object",
+        "properties": {
+          "user": {
+            "type": "ref",
+            "ref": "com.example.defs#user"
+          }
+        }
+      }
+    }
+  }|}
+  in
+  match Parser.parse_string json with
+  | Ok doc -> (
+      let def = List.hd doc.defs in
+      match def.type_def with
+      | Lexicon_types.Object spec -> (
+          let _, prop = List.hd spec.properties in
+          match prop.type_def with
+          | Lexicon_types.Ref r ->
+              check test_string "ref value" "com.example.defs#user" r.ref_
+          | _ ->
+              fail "expected ref type" )
+      | _ ->
+          fail "expected object type" )
+  | Error e ->
+      fail ("parse failed: " ^ e)
+
+(* parsing union type *)
+let test_parse_union_type () =
+  let json =
+    {|{
+    "lexicon": 1,
+    "id": "com.example.union",
+    "defs": {
+      "main": {
+        "type": "union",
+        "refs": ["#typeA", "#typeB"],
+        "closed": true
+      }
+    }
+  }|}
+  in
+  match Parser.parse_string json with
+  | Ok doc -> (
+      let def = List.hd doc.defs in
+      match def.type_def with
+      | Lexicon_types.Union u ->
+          check int "two refs" 2 (List.length u.refs) ;
+          check (option bool) "closed" (Some true) u.closed
+      | _ ->
+          fail "expected union type" )
+  | Error e ->
+      fail ("parse failed: " ^ e)
+
+(* parsing query type *)
+let test_parse_query_type () =
+  let json =
+    {|{
+    "lexicon": 1,
+    "id": "com.example.getUser",
+    "defs": {
+      "main": {
+        "type": "query",
+        "description": "Get a user",
+        "parameters": {
+          "type": "params",
+          "properties": {
+            "userId": {"type": "string"}
+          },
+          "required": ["userId"]
+        },
+        "output": {
+          "encoding": "application/json",
+          "schema": {
+            "type": "object",
+            "properties": {
+              "name": {"type": "string"}
+            }
+          }
+        }
+      }
+    }
+  }|}
+  in
+  match Parser.parse_string json with
+  | Ok doc -> (
+      let def = List.hd doc.defs in
+      match def.type_def with
+      | Lexicon_types.Query q -> (
+          check (option test_string) "description" (Some "Get a user")
+            q.description ;
+          ( match q.parameters with
+          | Some params ->
+              check int "one param" 1 (List.length params.properties)
+          | None ->
+              fail "expected parameters" ) ;
+          match q.output with
+          | Some output ->
+              check test_string "encoding" "application/json" output.encoding
+          | None ->
+              fail "expected output" )
+      | _ ->
+          fail "expected query type" )
+  | Error e ->
+      fail ("parse failed: " ^ e)
+
+(* parsing procedure type *)
+let test_parse_procedure_type () =
+  let json =
+    {|{
+    "lexicon": 1,
+    "id": "com.example.createUser",
+    "defs": {
+      "main": {
+        "type": "procedure",
+        "input": {
+          "encoding": "application/json",
+          "schema": {
+            "type": "object",
+            "properties": {
+              "name": {"type": "string"}
+            },
+            "required": ["name"]
+          }
+        },
+        "output": {
+          "encoding": "application/json",
+          "schema": {
+            "type": "object",
+            "properties": {
+              "id": {"type": "string"}
+            }
+          }
+        }
+      }
+    }
+  }|}
+  in
+  match Parser.parse_string json with
+  | Ok doc -> (
+      let def = List.hd doc.defs in
+      match def.type_def with
+      | Lexicon_types.Procedure p -> (
+          ( match p.input with
+          | Some input ->
+              check test_string "input encoding" "application/json"
+                input.encoding
+          | None ->
+              fail "expected input" ) ;
+          match p.output with
+          | Some output ->
+              check test_string "output encoding" "application/json"
+                output.encoding
+          | None ->
+              fail "expected output" )
+      | _ ->
+          fail "expected procedure type" )
+  | Error e ->
+      fail ("parse failed: " ^ e)
+
+(* parsing invalid JSON *)
+let test_parse_invalid_json () =
+  let json = {|{ invalid json }|} in
+  match Parser.parse_string json with
+  | Ok _ ->
+      fail "should have failed"
+  | Error e ->
+      check bool "has error message" true (String.length e > 0)
+
+(* parsing missing required field *)
+let test_parse_missing_field () =
+  let json = {|{
+    "lexicon": 1,
+    "defs": {}
+  }|} in
+  match Parser.parse_string json with
+  | Ok _ ->
+      fail "should have failed (missing id)"
+  | Error _ ->
+      ()
+
+(** tests *)
+
+let object_tests =
+  [ ("simple object", `Quick, test_parse_simple_object)
+  ; ("string with constraints", `Quick, test_parse_string_type)
+  ; ("array type", `Quick, test_parse_array_type)
+  ; ("ref type", `Quick, test_parse_ref_type) ]
+
+let complex_type_tests =
+  [ ("union type", `Quick, test_parse_union_type)
+  ; ("query type", `Quick, test_parse_query_type)
+  ; ("procedure type", `Quick, test_parse_procedure_type) ]
+
+let error_tests =
+  [ ("invalid json", `Quick, test_parse_invalid_json)
+  ; ("missing field", `Quick, test_parse_missing_field) ]
+
+let () =
+  run "Parser"
+    [ ("objects", object_tests)
+    ; ("complex_types", complex_type_tests)
+    ; ("errors", error_tests) ]

hermes.opam

···
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "Type-safe XRPC client for ATProto"
+description: "XRPC client with PPX extensions for type-safe API calls"
+maintainer: ["futurGH"]
+authors: ["futurGH"]
+license: "MPL-2.0"
+homepage: "https://github.com/futurGH/pegasus"
+bug-reports: "https://github.com/futurGH/pegasus/issues"
+depends: [
+  "ocaml" {= "5.2.1"}
+  "dune" {>= "3.20"}
+  "lwt"
+  "cohttp-lwt-unix" {>= "6.1.1"}
+  "uri" {>= "4.4.0"}
+  "yojson" {>= "3.0.0"}
+  "base64" {>= "3.5.0"}
+  "lwt_ppx" {>= "5.9.1"}
+  "ppx_deriving_yojson" {>= "3.9.1"}
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
+dev-repo: "git+https://github.com/futurGH/pegasus.git"
+x-maintenance-intent: ["(latest)"]

hermes/README.md

···
+# hermes
+
+is a type-safe XRPC client for atproto.
+
+Hermes provides three components:
+
+- **hermes** - Core library for making XRPC calls
+- **hermes-cli** - Code generator for atproto lexicons
+- **hermes_ppx** - PPX extension for ergonomic API calls
+
+- [Quick Start](#quick-start)
+- [Complete Example](#complete-example)
+- [Installation](#installation)
+- [hermes](#hermes-lib)
+    - [Session Management](#session-management)
+    - [Making XRPC Calls](#making-xrpc-calls)
+    - [Error Handling](#error-handling)
+- [hermes_ppx](#hermes-ppx)
+    - [Setup](#setup)
+    - [Usage](#ppx-usage)
+- [hermes-cli](#hermes-cli)
+    - [Usage](#usage)
+    - [Options](#options)
+    - [Generated Code Structure](#generated-code-structure)
+    - [Type Mappings](#type-mappings)
+    - [Bytes Encoding](#bytes-encoding)
+    - [Union Types](#union-types)
+
+## quick start
+
+```ocaml
+open Hermes_lexicons (* generate lexicons using hermes-cli! *)
+open Lwt.Syntax
+
+let () = Lwt_main.run begin
+  (* Create an unauthenticated client *)
+  let client = Hermes.make_client ~service:"https://public.api.bsky.app" () in
+
+  (* Make a query using the generated module *)
+  let* profile = App_bsky_actor_getProfile.call ~actor:"bsky.app" client in
+  print_endline profile.display_name;
+  Lwt.return_unit
+end
+```
+
+## complete example
+
+```ocaml
+open Hermes_lexicons (* generate lexicons using hermes-cli! *)
+open Lwt.Syntax
+
+let main () =
+  (* Set up credential manager with persistence *)
+  let manager = Hermes.make_credential_manager ~service:"https://pegasus.example" () in
+
+  Hermes.on_session_update manager (fun session ->
+    let json = Hermes.session_to_yojson session in
+    Yojson.Safe.to_file "session.json" json;
+    Lwt.return_unit
+  );
+
+  (* Log in or resume session *)
+  let* client =
+    if Sys.file_exists "session.json" then
+      let json = Yojson.Safe.from_file "session.json" in
+      match Hermes.session_of_yojson json with
+      | Ok session -> Hermes.resume manager ~session ()
+      | Error _ -> failwith "Invalid session file"
+    else
+      Hermes.login manager
+        ~identifier:"you.bsky.social"
+        ~password:"your-app-password"
+        ()
+  in
+
+  (* Fetch your profile *)
+  let session = Hermes.get_session client |> Option.get in
+  let* profile =
+    [%xrpc get "app.bsky.actor.getProfile"]
+      ~actor:session.did
+      client
+  in
+  Printf.printf "Logged in as %s\n" profile.handle;
+
+  (* Create a post *)
+  let* _ =
+    [%xrpc post "com.atproto.repo.createRecord"]
+      ~repo:session.did
+      ~collection:"app.bsky.feed.post"
+      ~record:(`Assoc [
+        ("$type", `String "app.bsky.feed.post");
+        ("text", `String "Hello from Hermes!");
+        ("createdAt", `String (Ptime.to_rfc3339 (Ptime_clock.now ())));
+      ])
+      client
+  in
+  print_endline "Post created!";
+  Lwt.return_unit
+
+let () = Lwt_main.run (main ())
+```
+
+## installation
+
+Add to your `dune-project`:
+
+```lisp
+(depends
+  hermes
+  hermes_ppx)
+```
+
+<h2 id="hermes-lib">hermes</h2>
+
+### session management
+
+```ocaml
+(* Unauthenticated client for public endpoints *)
+let client = Hermes.make_client ~service:"https://public.api.bsky.app" ()
+
+(* Authenticated client with credential manager *)
+let manager = Hermes.make_credential_manager ~service:"https://bsky.social" ()
+
+let%lwt client = Hermes.login manager
+  ~identifier:"user.bsky.social"
+  ~password:"app-password-here"
+  ()
+
+(* Get current session for persistence *)
+let session = Hermes.get_session client
+
+(* Save session to JSON *)
+let json = Hermes.session_to_yojson session
+
+(* Resume from saved session *)
+let%lwt client = Hermes.resume manager ~session ()
+
+(* Auto-save session to disk *)
+let () = Hermes.on_session_update manager (fun session ->
+  save_to_disk (Hermes.session_to_yojson session);
+  Lwt.return_unit
+)
+
+(* Listen for session expiration *)
+let () = Hermes.on_session_expired manager (fun () ->
+  print_endline "session expired, log in again!";
+  Lwt.return_unit
+)
+```
+
+### making XRPC calls
+
+```ocaml
+(* GET request *)
+let%lwt result = Hermes.query client
+  "app.bsky.actor.getProfile"
+  (`Assoc [("actor", `String "bsky.app")])
+  decode_profile
+
+(* GET request returning raw bytes *)
+let%lwt (data, content_type) = Hermes.query_bytes client
+  "com.atproto.sync.getBlob"
+  (`Assoc [("did", `String did); ("cid", `String cid)])
+
+(* POST request *)
+let%lwt result = Hermes.procedure client
+  "com.atproto.repo.createRecord"
+  (`Assoc [])  (* query params *)
+  (Some input_json)
+  decode_response
+
+(* POST request with raw bytes as input *)
+let%lwt response = Hermes.procedure_bytes client
+  "com.atproto.repo.importRepo"
+  (`Assoc [])
+  (Some car_data)
+  ~content_type:"application/vnd.ipld.car"
+
+(* upload bytes, get a blob back *)
+let%lwt blob = Hermes.procedure_blob client
+  "com.atproto.repo.uploadBlob"
+  (`Assoc [])
+  image_bytes
+  ~content_type:"image/jpeg"
+  decode_blob
+```
+
+### error handling
+
+```ocaml
+try%lwt
+  let%lwt _ = some_xrpc_call client in
+  Lwt.return_unit
+with Hermes.Xrpc_error { status; error; message } ->
+  Printf.printf "Error %d: %s (%s)\n"
+    status error (Option.value message ~default:"no message");
+  Lwt.return_unit
+```
+
+<h2 id="hermes-cli">hermes-cli (codegen)</h2>
+
+generates type-safe OCaml modules from atproto lexicon files.
+
+### usage
+
+```bash
+# Generate from lexicons directory
+hermes-cli generate --input ./lexicons --output ./lib/generated
+
+# With custom root module name
+hermes-cli generate -i ./lexicons -o ./lib/generated --module-name Bsky_api
+```
+
+### options
+
+| Option          | Short | Description                             |
+| --------------- | ----- | --------------------------------------- |
+| `--input`       | `-i`  | Directory containing lexicon JSON files |
+| `--output`      | `-o`  | Output directory for generated OCaml    |
+| `--module-name` | `-m`  | Root module name (default: Lexicons)    |
+
+### generated code structure
+
+For a lexicon like `app.bsky.actor.getProfile`, the generator creates:
+
+```
+lib/generated/
+├── dune
+├── lexicons.ml           # Re-exports all modules
+└── app/
+    └── bsky/
+        └── actor/
+            └── getProfile.ml
+```
+
+Each endpoint module contains:
+
+```ocaml
+module GetProfile = struct
+  type params = {
+    actor: string;
+  } [@@deriving yojson]
+
+  type output = {
+    did: string;
+    handle: string;
+    display_name: string option;
+    (* ... *)
+  } [@@deriving yojson]
+
+  let nsid = "app.bsky.actor.getProfile"
+
+  let call ~actor (client : Hermes.client) : output Lwt.t =
+    let params = { actor } in
+    Hermes.query client nsid (params_to_yojson params) output_of_yojson
+end
+```
+
+### type mappings
+
+| Lexicon Type | OCaml Type      |
+| ------------ | --------------- |
+| `boolean`    | `bool`          |
+| `integer`    | `int`           |
+| `string`     | `string`        |
+| `bytes`      | `string`        |
+| `blob`       | `Hermes.blob`   |
+| `cid-link`   | `Cid.t`         |
+| `array`      | `list`          |
+| `object`     | record type     |
+| `union`      | variant type    |
+| `unknown`    | `Yojson.Safe.t` |
+
+### bytes encoding
+
+Endpoints with non-JSON encoding are automatically detected and handled:
+
+- **Queries with bytes output** (e.g., `com.atproto.sync.getBlob` with `encoding: "*/*"`):
+    - Output type is `string * string` (data, content_type)
+    - Generated code uses `Hermes.query_bytes`
+
+- **Procedures with bytes input**:
+    - Input is `?input:string` (optional raw bytes)
+    - Generated code uses `Hermes.procedure_bytes`
+
+### union types
+
+Unions generate variant types with a discriminator:
+
+```ocaml
+type relationship_union =
+  | Relationship of relationship
+  | NotFoundActor of not_found_actor
+  | Unknown of Yojson.Safe.t  (* for open unions *)
+```
+
+<h2 id="hermes-ppx">hermes_ppx (PPX extension)</h2>
+
+Transforms `[%xrpc ...]` into generated module calls.
+
+### setup
+
+```lisp
+(library
+ (name my_app)
+ (libraries hermes hermes_ppx lwt)
+ (preprocess (pps hermes_ppx)))
+```
+
+<h3 id="ppx-usage">usage</h3>
+
+```ocaml
+let get_followers ~actor ~limit client =
+  [%xrpc get "app.bsky.graph.getFollowers"]
+    ~actor
+    ?limit
+    client
+
+let create_post ~text client =
+  let session = Hermes.get_session client |> Option.get in
+  [%xrpc post "com.atproto.repo.createRecord"]
+    ~repo:session.did
+    ~collection:"app.bsky.feed.post"
+    ~record:(`Assoc [
+      ("$type", `String "app.bsky.feed.post");
+      ("text", `String text);
+      ("createdAt", `String (Ptime.to_rfc3339 (Ptime_clock.now ())));
+    ])
+    client
+```

hermes/lib/client.ml

···
+open Lwt.Syntax
+
+type t =
+  { service: Uri.t
+  ; mutable headers: (string * string) list
+  ; mutable session: Types.session option
+  ; on_request: (t -> unit Lwt.t) option
+        (* called before each request for token refresh *) }
+
+module type S = sig
+  val make : service:string -> unit -> t
+
+  val make_with_interceptor :
+    service:string -> on_request:(t -> unit Lwt.t) -> unit -> t
+
+  val set_session : t -> Types.session -> unit
+
+  val clear_session : t -> unit
+
+  val get_session : t -> Types.session option
+
+  val get_service : t -> Uri.t
+
+  val query :
+       t
+    -> string
+    -> Yojson.Safe.t
+    -> (Yojson.Safe.t -> ('a, string) result)
+    -> 'a Lwt.t
+
+  val procedure :
+       t
+    -> string
+    -> Yojson.Safe.t
+    -> Yojson.Safe.t option
+    -> (Yojson.Safe.t -> ('a, string) result)
+    -> 'a Lwt.t
+
+  val query_bytes : t -> string -> Yojson.Safe.t -> (string * string) Lwt.t
+
+  val procedure_bytes :
+       t
+    -> string
+    -> Yojson.Safe.t
+    -> string option
+    -> content_type:string
+    -> (string * string) option Lwt.t
+
+  val procedure_blob :
+       t
+    -> string
+    -> Yojson.Safe.t
+    -> bytes
+    -> content_type:string
+    -> (Yojson.Safe.t -> ('a, string) result)
+    -> 'a Lwt.t
+end
+
+module Make (Http : Http_backend.S) : S = struct
+  let make ~service () =
+    let service = Uri.of_string service in
+    {service; headers= []; session= None; on_request= None}
+
+  let make_with_interceptor ~service ~on_request () =
+    let service = Uri.of_string service in
+    {service; headers= []; session= None; on_request= Some on_request}
+
+  let set_session t session =
+    t.session <- Some session ;
+    t.headers <-
+      List.filter (fun (k, _) -> k <> "Authorization") t.headers
+      @ [("Authorization", "Bearer " ^ session.Types.access_jwt)]
+
+  let clear_session t =
+    t.session <- None ;
+    t.headers <- List.filter (fun (k, _) -> k <> "Authorization") t.headers
+
+  let get_session t = t.session
+
+  let get_service t = t.service
+
+  (* build query string from json params *)
+  let params_to_query (params : Yojson.Safe.t) : (string * string list) list =
+    match params with
+    | `Assoc pairs ->
+        List.filter_map
+          (fun (k, v) ->
+            match v with
+            | `Null ->
+                None
+            | `Bool b ->
+                Some (k, [string_of_bool b])
+            | `Int i ->
+                Some (k, [string_of_int i])
+            | `Float f ->
+                Some (k, [string_of_float f])
+            | `String s ->
+                Some (k, [s])
+            | `List items ->
+                let strs =
+                  List.filter_map
+                    (function
+                      | `String s ->
+                          Some s
+                      | `Int i ->
+                          Some (string_of_int i)
+                      | `Bool b ->
+                          Some (string_of_bool b)
+                      | _ ->
+                          None )
+                    items
+                in
+                if strs = [] then None else Some (k, strs)
+            | _ ->
+                None )
+          pairs
+    | _ ->
+        []
+
+  let make_headers ?(extra = []) ?(accept = "application/json") t =
+    Cohttp.Header.of_list
+      ([("User-Agent", "hermes/1.0"); ("Accept", accept)] @ t.headers @ extra)
+
+  let query (t : t) (nsid : string) (params : Yojson.Safe.t)
+      (of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a Lwt.t =
+    (* call interceptor if present for token refresh *)
+    let* () =
+      match t.on_request with Some f -> f t | None -> Lwt.return_unit
+    in
+    let query = params_to_query params in
+    let uri =
+      Uri.with_path t.service ("/xrpc/" ^ nsid)
+      |> fun u -> Uri.with_query u query
+    in
+    let headers = make_headers t in
+    let* resp, body =
+      Lwt.catch
+        (fun () -> Lwt_unix.with_timeout 30.0 (fun () -> Http.get ~headers uri))
+        (fun exn ->
+          Types.raise_xrpc_error_raw ~status:0 ~error:"NetworkError"
+            ~message:(Printexc.to_string exn) () )
+    in
+    let status = Cohttp.Response.status resp |> Cohttp.Code.code_of_status in
+    let* body_str = Cohttp_lwt.Body.to_string body in
+    if status >= 200 && status < 300 then
+      if String.length body_str = 0 then
+        (* empty response, try parsing empty object *)
+        match of_yojson (`Assoc []) with
+        | Ok v ->
+            Lwt.return v
+        | Error e ->
+            Types.raise_xrpc_error_raw ~status ~error:"ParseError" ~message:e ()
+      else
+        let json = Yojson.Safe.from_string body_str in
+        match of_yojson json with
+        | Ok v ->
+            Lwt.return v
+        | Error e ->
+            Types.raise_xrpc_error_raw ~status ~error:"ParseError" ~message:e ()
+    else
+      let payload =
+        try
+          let json = Yojson.Safe.from_string body_str in
+          match Types.xrpc_error_payload_of_yojson json with
+          | Ok p ->
+              p
+          | Error _ ->
+              {error= "UnknownError"; message= Some body_str}
+        with _ -> {error= "UnknownError"; message= Some body_str}
+      in
+      Types.raise_xrpc_error ~status payload
+
+  let procedure (t : t) (nsid : string) (params : Yojson.Safe.t)
+      (input : Yojson.Safe.t option)
+      (of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a Lwt.t =
+    (* call interceptor if present for token refresh *)
+    let* () =
+      match t.on_request with Some f -> f t | None -> Lwt.return_unit
+    in
+    let query = params_to_query params in
+    let uri =
+      Uri.with_path t.service ("/xrpc/" ^ nsid)
+      |> fun u -> Uri.with_query u query
+    in
+    let body, content_type =
+      match input with
+      | Some json ->
+          ( Cohttp_lwt.Body.of_string (Yojson.Safe.to_string json)
+          , "application/json" )
+      | None ->
+          (Cohttp_lwt.Body.empty, "application/json")
+    in
+    let headers = make_headers ~extra:[("Content-Type", content_type)] t in
+    let* resp, resp_body =
+      Lwt.catch
+        (fun () ->
+          Lwt_unix.with_timeout 30.0 (fun () -> Http.post ~headers ~body uri) )
+        (fun exn ->
+          Types.raise_xrpc_error_raw ~status:0 ~error:"NetworkError"
+            ~message:(Printexc.to_string exn) () )
+    in
+    let status = Cohttp.Response.status resp |> Cohttp.Code.code_of_status in
+    let* body_str = Cohttp_lwt.Body.to_string resp_body in
+    if status >= 200 && status < 300 then
+      if String.length body_str = 0 then
+        match of_yojson (`Assoc []) with
+        | Ok v ->
+            Lwt.return v
+        | Error e ->
+            Types.raise_xrpc_error_raw ~status ~error:"ParseError" ~message:e ()
+      else
+        let json = Yojson.Safe.from_string body_str in
+        match of_yojson json with
+        | Ok v ->
+            Lwt.return v
+        | Error e ->
+            Types.raise_xrpc_error_raw ~status ~error:"ParseError" ~message:e ()
+    else
+      let payload =
+        try
+          let json = Yojson.Safe.from_string body_str in
+          match Types.xrpc_error_payload_of_yojson json with
+          | Ok p ->
+              p
+          | Error _ ->
+              {error= "UnknownError"; message= Some body_str}
+        with _ -> {error= "UnknownError"; message= Some body_str}
+      in
+      Types.raise_xrpc_error ~status payload
+
+  let query_bytes (t : t) (nsid : string) (params : Yojson.Safe.t) :
+      (string * string) Lwt.t =
+    (* call interceptor if present for token refresh *)
+    let* () =
+      match t.on_request with Some f -> f t | None -> Lwt.return_unit
+    in
+    let query = params_to_query params in
+    let uri =
+      Uri.with_path t.service ("/xrpc/" ^ nsid)
+      |> fun u -> Uri.with_query u query
+    in
+    let headers = make_headers ~accept:"*/*" t in
+    let* resp, body =
+      Lwt.catch
+        (fun () -> Lwt_unix.with_timeout 120.0 (fun () -> Http.get ~headers uri))
+        (fun exn ->
+          Types.raise_xrpc_error_raw ~status:0 ~error:"NetworkError"
+            ~message:(Printexc.to_string exn) () )
+    in
+    let status = Cohttp.Response.status resp |> Cohttp.Code.code_of_status in
+    let* body_str = Cohttp_lwt.Body.to_string body in
+    if status >= 200 && status < 300 then
+      let content_type =
+        Cohttp.Response.headers resp
+        |> fun h ->
+        Cohttp.Header.get h "content-type"
+        |> Option.value ~default:"application/octet-stream"
+      in
+      Lwt.return (body_str, content_type)
+    else
+      let payload =
+        try
+          let json = Yojson.Safe.from_string body_str in
+          match Types.xrpc_error_payload_of_yojson json with
+          | Ok p ->
+              p
+          | Error _ ->
+              {error= "UnknownError"; message= Some body_str}
+        with _ -> {error= "UnknownError"; message= Some body_str}
+      in
+      Types.raise_xrpc_error ~status payload
+
+  (* execute procedure with raw bytes input, returns raw bytes or none if no output *)
+  let procedure_bytes (t : t) (nsid : string) (params : Yojson.Safe.t)
+      (input : string option) ~(content_type : string) :
+      (string * string) option Lwt.t =
+    (* call interceptor if present for token refresh *)
+    let* () =
+      match t.on_request with Some f -> f t | None -> Lwt.return_unit
+    in
+    let query = params_to_query params in
+    let uri =
+      Uri.with_path t.service ("/xrpc/" ^ nsid)
+      |> fun u -> Uri.with_query u query
+    in
+    let body =
+      match input with
+      | Some data ->
+          Cohttp_lwt.Body.of_string data
+      | None ->
+          Cohttp_lwt.Body.empty
+    in
+    let headers =
+      make_headers ~extra:[("Content-Type", content_type)] ~accept:"*/*" t
+    in
+    let* resp, resp_body =
+      Lwt.catch
+        (fun () ->
+          Lwt_unix.with_timeout 120.0 (fun () -> Http.post ~headers ~body uri) )
+        (fun exn ->
+          Types.raise_xrpc_error_raw ~status:0 ~error:"NetworkError"
+            ~message:(Printexc.to_string exn) () )
+    in
+    let status = Cohttp.Response.status resp |> Cohttp.Code.code_of_status in
+    let* body_str = Cohttp_lwt.Body.to_string resp_body in
+    if status >= 200 && status < 300 then
+      if String.length body_str = 0 then Lwt.return None
+      else
+        let resp_content_type =
+          Cohttp.Response.headers resp
+          |> fun h ->
+          Cohttp.Header.get h "content-type"
+          |> Option.value ~default:"application/octet-stream"
+        in
+        Lwt.return (Some (body_str, resp_content_type))
+    else
+      let payload =
+        try
+          let json = Yojson.Safe.from_string body_str in
+          match Types.xrpc_error_payload_of_yojson json with
+          | Ok p ->
+              p
+          | Error _ ->
+              {error= "UnknownError"; message= Some body_str}
+        with _ -> {error= "UnknownError"; message= Some body_str}
+      in
+      Types.raise_xrpc_error ~status payload
+
+  let procedure_blob (t : t) (nsid : string) (params : Yojson.Safe.t)
+      (blob_data : bytes) ~(content_type : string)
+      (of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a Lwt.t =
+    (* call interceptor if present for token refresh *)
+    let* () =
+      match t.on_request with Some f -> f t | None -> Lwt.return_unit
+    in
+    let query = params_to_query params in
+    let uri =
+      Uri.with_path t.service ("/xrpc/" ^ nsid)
+      |> fun u -> Uri.with_query u query
+    in
+    let body = Cohttp_lwt.Body.of_string (Bytes.to_string blob_data) in
+    let headers = make_headers ~extra:[("Content-Type", content_type)] t in
+    let* resp, resp_body =
+      Lwt.catch
+        (fun () ->
+          Lwt_unix.with_timeout 120.0 (fun () -> Http.post ~headers ~body uri) )
+        (fun exn ->
+          Types.raise_xrpc_error_raw ~status:0 ~error:"NetworkError"
+            ~message:(Printexc.to_string exn) () )
+    in
+    let status = Cohttp.Response.status resp |> Cohttp.Code.code_of_status in
+    let* body_str = Cohttp_lwt.Body.to_string resp_body in
+    if status >= 200 && status < 300 then
+      let json = Yojson.Safe.from_string body_str in
+      match of_yojson json with
+      | Ok v ->
+          Lwt.return v
+      | Error e ->
+          Types.raise_xrpc_error_raw ~status ~error:"ParseError" ~message:e ()
+    else
+      let payload =
+        try
+          let json = Yojson.Safe.from_string body_str in
+          match Types.xrpc_error_payload_of_yojson json with
+          | Ok p ->
+              p
+          | Error _ ->
+              {error= "UnknownError"; message= Some body_str}
+        with _ -> {error= "UnknownError"; message= Some body_str}
+      in
+      Types.raise_xrpc_error ~status payload
+end
+
+(* default client using real http backend *)
+include Make (Http_backend.Default)

hermes/lib/credential_manager.ml

···
+open Lwt.Syntax
+
+type t =
+  { service: Uri.t
+  ; mutable session: Types.session option
+  ; mutable on_session_update: (Types.session -> unit Lwt.t) option
+  ; mutable on_session_expired: (unit -> unit Lwt.t) option
+  ; refresh_mutex: Lwt_mutex.t
+  ; mutable refresh_promise: unit Lwt.t option }
+
+module type S = sig
+  val make : service:string -> unit -> t
+
+  val on_session_update : t -> (Types.session -> unit Lwt.t) -> unit
+
+  val on_session_expired : t -> (unit -> unit Lwt.t) -> unit
+
+  val get_session : t -> Types.session option
+
+  val login :
+       t
+    -> identifier:string
+    -> password:string
+    -> ?auth_factor_token:string
+    -> unit
+    -> Client.t Lwt.t
+
+  val resume : t -> session:Types.session -> unit -> Client.t Lwt.t
+
+  val logout : t -> unit Lwt.t
+end
+
+module Make (C : Client.S) : S = struct
+  let make ~service () =
+    { service= Uri.of_string service
+    ; session= None
+    ; on_session_update= None
+    ; on_session_expired= None
+    ; refresh_mutex= Lwt_mutex.create ()
+    ; refresh_promise= None }
+
+  let on_session_update t callback = t.on_session_update <- Some callback
+
+  let on_session_expired t callback = t.on_session_expired <- Some callback
+
+  let get_session t = t.session
+
+  (* update session and notify *)
+  let update_session t session =
+    t.session <- Some session ;
+    match t.on_session_update with
+    | Some callback ->
+        callback session
+    | None ->
+        Lwt.return_unit
+
+  (* clear session and notify *)
+  let clear_session t =
+    t.session <- None ;
+    match t.on_session_expired with
+    | Some callback ->
+        callback ()
+    | None ->
+        Lwt.return_unit
+
+  (* create raw client for auth operations *)
+  let make_raw_client t = C.make ~service:(Uri.to_string t.service) ()
+
+  let rec login t ~identifier ~password ?auth_factor_token () =
+    let client = make_raw_client t in
+    let input =
+      Types.login_request_to_yojson
+        {Types.identifier; password; auth_factor_token}
+    in
+    let* session =
+      C.procedure client "com.atproto.server.createSession" (`Assoc [])
+        (Some input) Types.session_of_yojson
+    in
+    let* () = update_session t session in
+    (* create client with request interceptor for auto-refresh *)
+    let authed_client =
+      C.make_with_interceptor ~service:(Uri.to_string t.service)
+        ~on_request:(fun c -> check_and_refresh t c)
+        ()
+    in
+    C.set_session authed_client session ;
+    Lwt.return authed_client
+
+  and resume t ~session () =
+    let* () = update_session t session in
+    let authed_client =
+      C.make_with_interceptor ~service:(Uri.to_string t.service)
+        ~on_request:(fun c -> check_and_refresh t c)
+        ()
+    in
+    C.set_session authed_client session ;
+    Lwt.return authed_client
+
+  (* refresh the session *)
+  and refresh_session t =
+    match t.session with
+    | None ->
+        Types.raise_xrpc_error_raw ~status:401 ~error:"AuthRequired"
+          ~message:"No session to refresh" ()
+    | Some session ->
+        let client = make_raw_client t in
+        (* use refresh token for auth *)
+        C.set_session client {session with access_jwt= session.refresh_jwt} ;
+        Lwt.catch
+          (fun () ->
+            let* new_session =
+              C.procedure client "com.atproto.server.refreshSession" (`Assoc [])
+                None Types.session_of_yojson
+            in
+            let* () = update_session t new_session in
+            Lwt.return (Some new_session) )
+          (fun exn ->
+            match exn with
+            | Types.Xrpc_error {error= "ExpiredToken"; _}
+            | Types.Xrpc_error {error= "InvalidToken"; _} ->
+                let* () = clear_session t in
+                Lwt.return None
+            | _ ->
+                Lwt.reraise exn )
+
+  (* check token expiry and refresh if needed *)
+  and check_and_refresh t client =
+    match t.session with
+    | None ->
+        Lwt.return_unit
+    | Some session ->
+        if Jwt.is_expired ~buffer_seconds:300 session.access_jwt then
+          (* token expired or about to expire, need to refresh *)
+          Lwt_mutex.with_lock t.refresh_mutex (fun () ->
+              (* check again in case another request already refreshed *)
+              match t.session with
+              | None ->
+                  Lwt.return_unit
+              | Some current_session ->
+                  if
+                    Jwt.is_expired ~buffer_seconds:300
+                      current_session.access_jwt
+                  then (
+                    let* new_session = refresh_session t in
+                    match new_session with
+                    | Some s ->
+                        C.set_session client s ; Lwt.return_unit
+                    | None ->
+                        C.clear_session client ;
+                        Types.raise_xrpc_error_raw ~status:401
+                          ~error:"SessionExpired"
+                          ~message:"Failed to refresh session" () )
+                  else (
+                    (* another request already refreshed, just update our client *)
+                    C.set_session client current_session ;
+                    Lwt.return_unit ) )
+        else Lwt.return_unit
+
+  let logout t =
+    match t.session with
+    | None ->
+        Lwt.return_unit
+    | Some session ->
+        let client = make_raw_client t in
+        C.set_session client session ;
+        Lwt.catch
+          (fun () ->
+            let* (_ : Yojson.Safe.t) =
+              C.procedure client "com.atproto.server.deleteSession" (`Assoc [])
+                None (fun j -> Ok j )
+            in
+            let* () = clear_session t in
+            Lwt.return_unit )
+          (fun _ ->
+            (* even if server fails, clear local session *)
+            let* () = clear_session t in
+            Lwt.return_unit )
+end
+
+include Make (Client)

hermes/lib/dune

···
+(library
+ (name hermes)
+ (libraries cohttp-lwt-unix lwt lwt.unix yojson uri base64 ipld mist)
+ (preprocess
+  (pps lwt_ppx ppx_deriving_yojson)))

hermes/lib/hermes.ml

···
+type blob = Types.blob = {ref_: Cid.t; mime_type: string; size: int64}
+
+exception Xrpc_error = Types.Xrpc_error
+
+type session = Types.session =
+  { access_jwt: string
+  ; refresh_jwt: string
+  ; did: string
+  ; handle: string
+  ; pds_uri: string option
+  ; email: string option
+  ; email_confirmed: bool option
+  ; email_auth_factor: bool option
+  ; active: bool option
+  ; status: string option }
+
+type client = Client.t
+
+type credential_manager = Credential_manager.t
+
+let make_client = Client.make
+
+let make_credential_manager = Credential_manager.make
+
+let login = Credential_manager.login
+
+let resume = Credential_manager.resume
+
+let logout = Credential_manager.logout
+
+let get_manager_session = Credential_manager.get_session
+
+let on_session_update = Credential_manager.on_session_update
+
+let on_session_expired = Credential_manager.on_session_expired
+
+let get_session = Client.get_session
+
+let get_service = Client.get_service
+
+let query = Client.query
+
+let procedure = Client.procedure
+
+let procedure_blob = Client.procedure_blob
+
+let query_bytes = Client.query_bytes
+
+let procedure_bytes = Client.procedure_bytes
+
+let session_to_yojson = Types.session_to_yojson
+
+let session_of_yojson = Types.session_of_yojson
+
+let blob_to_yojson = Types.blob_to_yojson
+
+let blob_of_yojson = Types.blob_of_yojson
+
+module Jwt = Jwt
+module Http_backend = Http_backend
+module Client = Client
+module Credential_manager = Credential_manager

hermes/lib/hermes.mli

···
+type blob = {ref_: Cid.t; mime_type: string; size: int64}
+
+exception Xrpc_error of {status: int; error: string; message: string option}
+
+type session =
+  { access_jwt: string
+  ; refresh_jwt: string
+  ; did: string
+  ; handle: string
+  ; pds_uri: string option
+  ; email: string option
+  ; email_confirmed: bool option
+  ; email_auth_factor: bool option
+  ; active: bool option
+  ; status: string option }
+
+type client
+
+type credential_manager
+
+val make_client : service:string -> unit -> client
+
+val make_credential_manager : service:string -> unit -> credential_manager
+
+val login :
+     credential_manager
+  -> identifier:string
+  -> password:string
+  -> ?auth_factor_token:string
+  -> unit
+  -> client Lwt.t
+
+val resume : credential_manager -> session:session -> unit -> client Lwt.t
+
+val logout : credential_manager -> unit Lwt.t
+
+val get_manager_session : credential_manager -> session option
+
+val on_session_update : credential_manager -> (session -> unit Lwt.t) -> unit
+
+val on_session_expired : credential_manager -> (unit -> unit Lwt.t) -> unit
+
+val get_session : client -> session option
+
+val get_service : client -> Uri.t
+
+val query :
+     client
+  -> string
+  -> Yojson.Safe.t
+  -> (Yojson.Safe.t -> ('a, string) result)
+  -> 'a Lwt.t
+
+val procedure :
+     client
+  -> string
+  -> Yojson.Safe.t
+  -> Yojson.Safe.t option
+  -> (Yojson.Safe.t -> ('a, string) result)
+  -> 'a Lwt.t
+
+val procedure_blob :
+     client
+  -> string
+  -> Yojson.Safe.t
+  -> bytes
+  -> content_type:string
+  -> (Yojson.Safe.t -> ('a, string) result)
+  -> 'a Lwt.t
+
+val query_bytes : client -> string -> Yojson.Safe.t -> (string * string) Lwt.t
+
+val procedure_bytes :
+     client
+  -> string
+  -> Yojson.Safe.t
+  -> string option
+  -> content_type:string
+  -> (string * string) option Lwt.t
+
+val session_to_yojson : session -> Yojson.Safe.t
+
+val session_of_yojson : Yojson.Safe.t -> (session, string) result
+
+val blob_to_yojson : blob -> Yojson.Safe.t
+
+val blob_of_yojson : Yojson.Safe.t -> (blob, string) result
+
+module Jwt : sig
+  type payload =
+    { exp: int option
+    ; iat: int option
+    ; sub: string option
+    ; aud: string option
+    ; iss: string option }
+
+  val decode_payload : string -> (payload, string) result
+
+  val is_expired : ?buffer_seconds:int -> string -> bool
+
+  val get_expiration : string -> int option
+end
+
+module Http_backend : sig
+  type response = Cohttp.Response.t * Cohttp_lwt.Body.t
+
+  module type S = sig
+    val get : headers:Cohttp.Header.t -> Uri.t -> response Lwt.t
+
+    val post :
+         headers:Cohttp.Header.t
+      -> body:Cohttp_lwt.Body.t
+      -> Uri.t
+      -> response Lwt.t
+  end
+
+  module Default : S
+end
+
+module Client : sig
+  type t = client
+
+  module type S = sig
+    val make : service:string -> unit -> t
+
+    val make_with_interceptor :
+      service:string -> on_request:(t -> unit Lwt.t) -> unit -> t
+
+    val set_session : t -> session -> unit
+
+    val clear_session : t -> unit
+
+    val get_session : t -> session option
+
+    val get_service : t -> Uri.t
+
+    val query :
+         t
+      -> string
+      -> Yojson.Safe.t
+      -> (Yojson.Safe.t -> ('a, string) result)
+      -> 'a Lwt.t
+
+    val procedure :
+         t
+      -> string
+      -> Yojson.Safe.t
+      -> Yojson.Safe.t option
+      -> (Yojson.Safe.t -> ('a, string) result)
+      -> 'a Lwt.t
+
+    val query_bytes : t -> string -> Yojson.Safe.t -> (string * string) Lwt.t
+
+    val procedure_bytes :
+         t
+      -> string
+      -> Yojson.Safe.t
+      -> string option
+      -> content_type:string
+      -> (string * string) option Lwt.t
+
+    val procedure_blob :
+         t
+      -> string
+      -> Yojson.Safe.t
+      -> bytes
+      -> content_type:string
+      -> (Yojson.Safe.t -> ('a, string) result)
+      -> 'a Lwt.t
+  end
+
+  module Make (_ : Http_backend.S) : S
+end
+
+module Credential_manager : sig
+  type t = credential_manager
+
+  module type S = sig
+    val make : service:string -> unit -> t
+
+    val on_session_update : t -> (session -> unit Lwt.t) -> unit
+
+    val on_session_expired : t -> (unit -> unit Lwt.t) -> unit
+
+    val get_session : t -> session option
+
+    val login :
+         t
+      -> identifier:string
+      -> password:string
+      -> ?auth_factor_token:string
+      -> unit
+      -> Client.t Lwt.t
+
+    val resume : t -> session:session -> unit -> Client.t Lwt.t
+
+    val logout : t -> unit Lwt.t
+  end
+
+  module Make (_ : Client.S) : S
+end

hermes/lib/http_backend.ml

···
+(* abstract http backend for dependency injection *)
+
+type response = Cohttp.Response.t * Cohttp_lwt.Body.t
+
+module type S = sig
+  val get : headers:Cohttp.Header.t -> Uri.t -> response Lwt.t
+
+  val post :
+    headers:Cohttp.Header.t -> body:Cohttp_lwt.Body.t -> Uri.t -> response Lwt.t
+end
+
+(* default implementation using cohttp-lwt-unix *)
+module Default : S = struct
+  let get ~headers uri = Cohttp_lwt_unix.Client.get ~headers uri
+
+  let post ~headers ~body uri = Cohttp_lwt_unix.Client.post ~headers ~body uri
+end

hermes/lib/jwt.ml

···
+type payload =
+  { exp: int option [@default None]
+  ; iat: int option [@default None]
+  ; sub: string option [@default None]
+  ; aud: string option [@default None]
+  ; iss: string option [@default None] }
+[@@deriving yojson {strict= false}]
+
+(* decode jwt payload without signature verification *)
+let decode_payload (jwt : string) : (payload, string) result =
+  try
+    match String.split_on_char '.' jwt with
+    | [_header; payload_str; _signature] -> (
+      match
+        Base64.decode ~pad:false ~alphabet:Base64.uri_safe_alphabet payload_str
+      with
+      | Ok decoded -> (
+          let json = Yojson.Safe.from_string decoded in
+          match payload_of_yojson json with Ok p -> Ok p | Error e -> Error e )
+      | Error (`Msg e) ->
+          Error ("invalid base64 in JWT: " ^ e) )
+    | _ ->
+        Error "invalid JWT format"
+  with
+  | Yojson.Json_error e ->
+      Error ("invalid JSON in JWT payload: " ^ e)
+  | e ->
+      Error (Printexc.to_string e)
+
+(* check if jwt is expired with buffer in seconds *)
+let is_expired ?(buffer_seconds = 60) (jwt : string) : bool =
+  match decode_payload jwt with
+  | Ok {exp= Some exp; _} ->
+      let now = int_of_float (Unix.time ()) in
+      exp - buffer_seconds <= now
+  | Ok {exp= None; _} ->
+      (* no expiration, assume not expired *)
+      false
+  | Error _ ->
+      (* can't decode, assume expired to be safe *)
+      true
+
+(* get expiration time from jwt *)
+let get_expiration (jwt : string) : int option =
+  match decode_payload jwt with Ok {exp; _} -> exp | Error _ -> None

hermes/lib/types.ml

···
+(* core types for xrpc client *)
+
+type blob =
+  {ref_: Cid.t [@key "$link"]; mime_type: string [@key "mimeType"]; size: int64}
+[@@deriving yojson]
+
+type xrpc_error_payload = {error: string; message: string option [@default None]}
+[@@deriving yojson {strict= false}]
+
+exception Xrpc_error of {status: int; error: string; message: string option}
+
+type session =
+  { access_jwt: string [@key "accessJwt"]
+  ; refresh_jwt: string [@key "refreshJwt"]
+  ; did: string
+  ; handle: string
+  ; pds_uri: string option [@key "pdsUri"] [@default None]
+  ; email: string option [@default None]
+  ; email_confirmed: bool option [@key "emailConfirmed"] [@default None]
+  ; email_auth_factor: bool option [@key "emailAuthFactor"] [@default None]
+  ; active: bool option [@default None]
+  ; status: string option [@default None] }
+[@@deriving yojson {strict= false}]
+
+type login_request =
+  { identifier: string
+  ; password: string
+  ; auth_factor_token: string option [@key "authFactorToken"] [@default None] }
+[@@deriving yojson]
+
+type refresh_request = unit [@@deriving yojson]
+
+let raise_xrpc_error ~status (payload : xrpc_error_payload) =
+  raise (Xrpc_error {status; error= payload.error; message= payload.message})
+
+let raise_xrpc_error_raw ~status ~error ?message () =
+  raise (Xrpc_error {status; error; message})

hermes/test/dune

···
+(library
+ (name test_support)
+ (modules mock_http test_utils)
+ (libraries hermes base64 http cohttp cohttp-lwt lwt yojson uri))
+
+(test
+ (name test_types)
+ (modules test_types)
+ (libraries alcotest hermes ipld yojson))
+
+(test
+ (name test_jwt)
+ (modules test_jwt)
+ (libraries alcotest hermes base64))
+
+(test
+ (name test_client)
+ (modules test_client)
+ (libraries alcotest hermes test_support lwt lwt.unix cohttp yojson)
+ (preprocess
+  (pps lwt_ppx)))
+
+(test
+ (name test_credential_manager)
+ (modules test_credential_manager)
+ (libraries alcotest hermes test_support lwt lwt.unix cohttp yojson)
+ (preprocess
+  (pps lwt_ppx)))

hermes/test/mock_http.ml

···
+(** mock HTTP backend for testing *)
+
+open Lwt.Syntax
+
+type request =
+  { meth: [`GET | `POST]
+  ; uri: Uri.t
+  ; headers: Cohttp.Header.t
+  ; body: string option }
+
+type response =
+  { status: Cohttp.Code.status_code
+  ; headers: (string * string) list
+  ; body: string }
+
+type handler = request -> response Lwt.t
+
+let make_cohttp_response (r : response) : Hermes.Http_backend.response =
+  let resp =
+    Cohttp.Response.make ~status:r.status
+      ~headers:(Cohttp.Header.of_list r.headers)
+      ()
+  in
+  let body = Cohttp_lwt.Body.of_string r.body in
+  (resp, body)
+
+(** create a mock HTTP backend with a handler *)
+module Make (Config : sig
+  val handler : handler ref
+end) : Hermes.Http_backend.S = struct
+  let get ~headers uri =
+    let req = {meth= `GET; uri; headers; body= None} in
+    let* r = !Config.handler req in
+    Lwt.return (make_cohttp_response r)
+
+  let post ~headers ~body uri =
+    let* body_str = Cohttp_lwt.Body.to_string body in
+    let req = {meth= `POST; uri; headers; body= Some body_str} in
+    let* r = !Config.handler req in
+    Lwt.return (make_cohttp_response r)
+end
+
+(** simple response builders *)
+
+let json_response ?(status = `OK) ?(headers = []) json =
+  { status
+  ; headers= ("content-type", "application/json") :: headers
+  ; body= Yojson.Safe.to_string json }
+
+let bytes_response ?(status = `OK) ~content_type body =
+  {status; headers= [("content-type", content_type)]; body}
+
+let error_response ~status ~error ?message () =
+  let msg_field =
+    match message with Some m -> [("message", `String m)] | None -> []
+  in
+  json_response ~status (`Assoc ([("error", `String error)] @ msg_field))
+
+let empty_response ?(status = `OK) () = {status; headers= []; body= ""}
+
+(** queue-based mock, returns responses in order *)
+module Queue = struct
+  type t = {mutable responses: response list; mutable requests: request list}
+
+  let create responses = {responses; requests= []}
+
+  let handler q req =
+    q.requests <- q.requests @ [req] ;
+    match q.responses with
+    | [] ->
+        failwith "Mock_http.Queue: no more responses"
+    | r :: rest ->
+        q.responses <- rest ;
+        Lwt.return r
+
+  let get_requests q = q.requests
+
+  let clear q =
+    q.responses <- [] ;
+    q.requests <- []
+end
+
+(** pattern-matching mock, selects responses based on request *)
+module Pattern = struct
+  type rule =
+    { nsid: string option  (** match NSID in path *)
+    ; meth: [`GET | `POST] option  (** match method *)
+    ; response: response }
+
+  type t =
+    {rules: rule list; mutable requests: request list; default: response option}
+
+  let create ?(default = None) rules = {rules; requests= []; default}
+
+  let extract_nsid uri =
+    let path = Uri.path uri in
+    if String.length path > 6 && String.sub path 0 6 = "/xrpc/" then
+      Some (String.sub path 6 (String.length path - 6))
+    else None
+
+  let matches rule req =
+    let nsid_matches =
+      match rule.nsid with
+      | None ->
+          true
+      | Some nsid ->
+          extract_nsid req.uri = Some nsid
+    in
+    let meth_matches =
+      match rule.meth with None -> true | Some m -> req.meth = m
+    in
+    nsid_matches && meth_matches
+
+  let handler t req =
+    t.requests <- t.requests @ [req] ;
+    match List.find_opt (fun r -> matches r req) t.rules with
+    | Some rule ->
+        Lwt.return rule.response
+    | None -> (
+      match t.default with
+      | Some r ->
+          Lwt.return r
+      | None ->
+          failwith
+            ("Mock_http.Pattern: no matching rule for " ^ Uri.to_string req.uri)
+      )
+
+  let get_requests t = t.requests
+end

hermes/test/test_client.ml

···
+open Alcotest
+open Lwt.Syntax
+open Test_support
+
+let run_lwt f = Lwt_main.run (f ())
+
+(* helpers *)
+let test_string = testable Fmt.string String.equal
+
+(** query tests *)
+
+let test_query_success () =
+  run_lwt
+  @@ fun () ->
+  let response =
+    Mock_http.json_response
+      (`Assoc
+         [("did", `String "did:plc:123"); ("handle", `String "test.bsky.social")]
+      )
+  in
+  let* result, requests =
+    Test_utils.with_mock_responses [response] (fun (module C) client ->
+        C.query client "com.atproto.identity.resolveHandle"
+          (`Assoc [("handle", `String "test.bsky.social")])
+          (fun json ->
+            let open Yojson.Safe.Util in
+            Ok (json |> member "did" |> to_string) ) )
+  in
+  check test_string "result" "did:plc:123" result ;
+  check int "request count" 1 (List.length requests) ;
+  let req = List.hd requests in
+  Test_utils.assert_request_path "/xrpc/com.atproto.identity.resolveHandle" req ;
+  Test_utils.assert_request_method `GET req ;
+  Test_utils.assert_request_query_param "handle" "test.bsky.social" req ;
+  Lwt.return_unit
+
+let test_query_with_multiple_params () =
+  run_lwt
+  @@ fun () ->
+  let response = Mock_http.json_response (`Assoc [("followers", `List [])]) in
+  let* _, requests =
+    Test_utils.with_mock_responses [response] (fun (module C) client ->
+        C.query client "app.bsky.graph.getFollowers"
+          (`Assoc
+             [ ("actor", `String "did:plc:123")
+             ; ("limit", `Int 50)
+             ; ("cursor", `String "abc123") ] )
+          (fun _ -> Ok ()) )
+  in
+  let req = List.hd requests in
+  Test_utils.assert_request_query_param "actor" "did:plc:123" req ;
+  Test_utils.assert_request_query_param "limit" "50" req ;
+  Test_utils.assert_request_query_param "cursor" "abc123" req ;
+  Lwt.return_unit
+
+let test_query_error_response () =
+  run_lwt
+  @@ fun () ->
+  let response =
+    Mock_http.error_response ~status:`Bad_request ~error:"InvalidHandle"
+      ~message:"Handle not found" ()
+  in
+  let* () =
+    Test_utils.with_mock_responses [response] (fun (module C) client ->
+        Lwt.catch
+          (fun () ->
+            let* _ =
+              C.query client "com.atproto.identity.resolveHandle"
+                (`Assoc [("handle", `String "invalid")])
+                (fun _ -> Ok ())
+            in
+            fail "should have raised Xrpc_error" )
+          (function
+            | Hermes.Xrpc_error {status; error; message} ->
+                check int "status" 400 status ;
+                check test_string "error" "InvalidHandle" error ;
+                check (option test_string) "message" (Some "Handle not found")
+                  message ;
+                Lwt.return_unit
+            | e ->
+                Lwt.reraise e ) )
+    |> Lwt.map fst
+  in
+  Lwt.return_unit
+
+let test_query_empty_response () =
+  run_lwt
+  @@ fun () ->
+  let response = Mock_http.empty_response () in
+  let* result, _ =
+    Test_utils.with_mock_responses [response] (fun (module C) client ->
+        C.query client "some.endpoint" (`Assoc []) (fun _ -> Ok "empty") )
+  in
+  check test_string "result" "empty" result ;
+  Lwt.return_unit
+
+let test_query_bytes () =
+  run_lwt
+  @@ fun () ->
+  let response =
+    Mock_http.bytes_response ~content_type:"image/jpeg" "fake-image-data"
+  in
+  let* (data, content_type), requests =
+    Test_utils.with_mock_responses [response] (fun (module C) client ->
+        C.query_bytes client "com.atproto.sync.getBlob"
+          (`Assoc [("did", `String "did:plc:123"); ("cid", `String "bafyabc")]) )
+  in
+  check test_string "data" "fake-image-data" data ;
+  check test_string "content_type" "image/jpeg" content_type ;
+  let req = List.hd requests in
+  Test_utils.assert_request_has_header "accept" "*/*" req ;
+  Lwt.return_unit
+
+(** procedure tests *)
+
+let test_procedure_success () =
+  run_lwt
+  @@ fun () ->
+  let response =
+    Mock_http.json_response
+      (`Assoc [("uri", `String "at://did:plc:123/app.bsky.feed.post/abc")])
+  in
+  let* result, requests =
+    Test_utils.with_mock_responses [response] (fun (module C) client ->
+        C.procedure client "com.atproto.repo.createRecord" (`Assoc [])
+          (Some
+             (`Assoc
+                [ ("repo", `String "did:plc:123")
+                ; ("collection", `String "app.bsky.feed.post")
+                ; ( "record"
+                  , `Assoc [("text", `String "This post was sent from PDSls")]
+                  ) ] ) )
+          (fun json ->
+            let open Yojson.Safe.Util in
+            Ok (json |> member "uri" |> to_string) ) )
+  in
+  check test_string "uri" "at://did:plc:123/app.bsky.feed.post/abc" result ;
+  let req = List.hd requests in
+  Test_utils.assert_request_method `POST req ;
+  Test_utils.assert_request_path "/xrpc/com.atproto.repo.createRecord" req ;
+  Test_utils.assert_request_has_header "content-type" "application/json" req ;
+  Test_utils.assert_request_body_contains "This post was sent from PDSls" req ;
+  Lwt.return_unit
+
+let test_procedure_no_input () =
+  run_lwt
+  @@ fun () ->
+  let response = Mock_http.empty_response () in
+  let* _, requests =
+    Test_utils.with_mock_responses [response] (fun (module C) client ->
+        C.procedure client "com.atproto.server.deleteSession" (`Assoc []) None
+          (fun _ -> Ok () ) )
+  in
+  let req = List.hd requests in
+  Test_utils.assert_request_method `POST req ;
+  check (option test_string) "body" (Some "") req.body ;
+  Lwt.return_unit
+
+let test_procedure_bytes () =
+  run_lwt
+  @@ fun () ->
+  let response = Mock_http.empty_response () in
+  let* result, requests =
+    Test_utils.with_mock_responses [response] (fun (module C) client ->
+        C.procedure_bytes client "com.atproto.repo.importRepo" (`Assoc [])
+          (Some "fake-car-data") ~content_type:"application/vnd.ipld.car" )
+  in
+  check (option (pair test_string test_string)) "result" None result ;
+  let req = List.hd requests in
+  Test_utils.assert_request_has_header "content-type" "application/vnd.ipld.car"
+    req ;
+  Test_utils.assert_request_has_header "accept" "*/*" req ;
+  check (option test_string) "body" (Some "fake-car-data") req.body ;
+  Lwt.return_unit
+
+let test_procedure_blob () =
+  run_lwt
+  @@ fun () ->
+  let response =
+    Mock_http.json_response
+      (`Assoc
+         [ ( "blob"
+           , `Assoc
+               [ ("$type", `String "blob")
+               ; ("ref", `Assoc [("$link", `String "bafyabc")])
+               ; ("mimeType", `String "image/jpeg")
+               ; ("size", `Int 1234) ] ) ] )
+  in
+  let* result, requests =
+    Test_utils.with_mock_responses [response] (fun (module C) client ->
+        C.procedure_blob client "com.atproto.repo.uploadBlob" (`Assoc [])
+          (Bytes.of_string "fake-image-bytes") ~content_type:"image/jpeg"
+          (fun json ->
+            let open Yojson.Safe.Util in
+            Ok (json |> member "blob" |> member "mimeType" |> to_string) ) )
+  in
+  check test_string "mimeType" "image/jpeg" result ;
+  let req = List.hd requests in
+  Test_utils.assert_request_has_header "content-type" "image/jpeg" req ;
+  check (option test_string) "body" (Some "fake-image-bytes") req.body ;
+  Lwt.return_unit
+
+(** authentication tests *)
+
+let test_auth_header_added () =
+  run_lwt
+  @@ fun () ->
+  let response = Mock_http.json_response (`Assoc []) in
+  let* _, requests =
+    Test_utils.with_mock_responses [response] (fun (module C) client ->
+        let session = Test_utils.make_test_session () in
+        C.set_session client session ;
+        C.query client "some.endpoint" (`Assoc []) (fun _ -> Ok ()) )
+  in
+  let req = List.hd requests in
+  Test_utils.assert_request_has_auth_header req ;
+  Lwt.return_unit
+
+let test_session_can_be_cleared () =
+  run_lwt
+  @@ fun () ->
+  let response = Mock_http.json_response (`Assoc []) in
+  let* _, requests =
+    Test_utils.with_mock_responses [response] (fun (module C) client ->
+        let session = Test_utils.make_test_session () in
+        C.set_session client session ;
+        C.clear_session client ;
+        C.query client "some.endpoint" (`Assoc []) (fun _ -> Ok ()) )
+  in
+  let req = List.hd requests in
+  let has_auth = Cohttp.Header.get req.headers "authorization" in
+  check (option test_string) "no auth header" None has_auth ;
+  Lwt.return_unit
+
+(** error handling tests *)
+
+let test_401_unauthorized () =
+  run_lwt
+  @@ fun () ->
+  let response =
+    Mock_http.error_response ~status:`Unauthorized ~error:"AuthRequired"
+      ~message:"Authentication required" ()
+  in
+  let* () =
+    Test_utils.with_mock_responses [response] (fun (module C) client ->
+        Lwt.catch
+          (fun () ->
+            let* _ =
+              C.query client "some.protected.endpoint" (`Assoc []) (fun _ ->
+                  Ok () )
+            in
+            fail "should have raised" )
+          (function
+            | Hermes.Xrpc_error {status= 401; error= "AuthRequired"; _} ->
+                Lwt.return_unit
+            | e ->
+                Lwt.reraise e ) )
+    |> Lwt.map fst
+  in
+  Lwt.return_unit
+
+let test_500_server_error () =
+  run_lwt
+  @@ fun () ->
+  let response =
+    Mock_http.error_response ~status:`Internal_server_error
+      ~error:"InternalServerError" ()
+  in
+  let* () =
+    Test_utils.with_mock_responses [response] (fun (module C) client ->
+        Lwt.catch
+          (fun () ->
+            let* _ =
+              C.query client "some.endpoint" (`Assoc []) (fun _ -> Ok ())
+            in
+            fail "Should have raised" )
+          (function
+            | Hermes.Xrpc_error {status= 500; _} ->
+                Lwt.return_unit
+            | e ->
+                Lwt.reraise e ) )
+    |> Lwt.map fst
+  in
+  Lwt.return_unit
+
+let test_malformed_error_response () =
+  run_lwt
+  @@ fun () ->
+  let response =
+    { Mock_http.status= `Bad_request
+    ; headers= [("content-type", "application/json")]
+    ; body= "not valid json" }
+  in
+  let* () =
+    Test_utils.with_mock_responses [response] (fun (module C) client ->
+        Lwt.catch
+          (fun () ->
+            let* _ =
+              C.query client "some.endpoint" (`Assoc []) (fun _ -> Ok ())
+            in
+            fail "should have raised" )
+          (function
+            | Hermes.Xrpc_error {status= 400; error= "UnknownError"; _} ->
+                Lwt.return_unit
+            | e ->
+                Lwt.reraise e ) )
+    |> Lwt.map fst
+  in
+  Lwt.return_unit
+
+(** client creation tests *)
+
+let test_make_client () =
+  let client = Hermes.make_client ~service:"https://api.bsky.app" () in
+  let service = Hermes.get_service client in
+  check (option test_string) "host" (Some "api.bsky.app") (Uri.host service)
+
+let test_client_service_urls () =
+  let urls =
+    [ "https://bsky.social"
+    ; "https://api.bsky.app"
+    ; "http://localhost:3000"
+    ; "https://pds.example.com:8080" ]
+  in
+  List.iter
+    (fun url ->
+      let client = Hermes.make_client ~service:url () in
+      let service = Hermes.get_service client in
+      check bool "service set" true (String.length (Uri.to_string service) > 0) )
+    urls
+
+let test_get_session_unauthenticated () =
+  let client = Hermes.make_client ~service:"https://example.com" () in
+  check (option reject) "no session" None (Hermes.get_session client)
+
+(** tests *)
+
+let query_tests =
+  [ ("query success", `Quick, test_query_success)
+  ; ("query with multiple params", `Quick, test_query_with_multiple_params)
+  ; ("query error response", `Quick, test_query_error_response)
+  ; ("query empty response", `Quick, test_query_empty_response)
+  ; ("query bytes", `Quick, test_query_bytes) ]
+
+let procedure_tests =
+  [ ("procedure success", `Quick, test_procedure_success)
+  ; ("procedure no input", `Quick, test_procedure_no_input)
+  ; ("procedure bytes", `Quick, test_procedure_bytes)
+  ; ("procedure blob", `Quick, test_procedure_blob) ]
+
+let auth_tests =
+  [ ("auth header added", `Quick, test_auth_header_added)
+  ; ("session can be cleared", `Quick, test_session_can_be_cleared) ]
+
+let error_tests =
+  [ ("401 unauthorized", `Quick, test_401_unauthorized)
+  ; ("500 server error", `Quick, test_500_server_error)
+  ; ("malformed error response", `Quick, test_malformed_error_response) ]
+
+let creation_tests =
+  [ ("make_client", `Quick, test_make_client)
+  ; ("service URLs", `Quick, test_client_service_urls)
+  ; ("get_session unauthenticated", `Quick, test_get_session_unauthenticated) ]
+
+let () =
+  run "Client"
+    [ ("query", query_tests)
+    ; ("procedure", procedure_tests)
+    ; ("auth", auth_tests)
+    ; ("errors", error_tests)
+    ; ("creation", creation_tests) ]

hermes/test/test_credential_manager.ml

···
+(** tests for Hermes.Credential_manager *)
+
+open Alcotest
+open Lwt.Syntax
+open Test_support
+
+let run_lwt f = Lwt_main.run (f ())
+
+(* helpers *)
+let test_string = testable Fmt.string String.equal
+
+(** login tests *)
+
+let test_login_success () =
+  run_lwt
+  @@ fun () ->
+  let session = Test_utils.make_test_session () in
+  let response =
+    Mock_http.json_response
+      (`Assoc
+         [ ("accessJwt", `String session.access_jwt)
+         ; ("refreshJwt", `String session.refresh_jwt)
+         ; ("did", `String session.did)
+         ; ("handle", `String session.handle) ] )
+  in
+  let* client, requests =
+    Test_utils.with_mock_credential_manager [response]
+      (fun (module CM) (module C) manager ->
+        let* client =
+          CM.login manager ~identifier:"[e-mail]" ~password:"secret" ()
+        in
+        Lwt.return client )
+  in
+  check int "request count" 1 (List.length requests) ;
+  let req = List.hd requests in
+  Test_utils.assert_request_path "/xrpc/com.atproto.server.createSession" req ;
+  Test_utils.assert_request_method `POST req ;
+  Test_utils.assert_request_body_contains "[e-mail]" req ;
+  Test_utils.assert_request_body_contains "secret" req ;
+  check bool "client has session" true (Hermes.get_session client <> None) ;
+  Lwt.return_unit
+
+let test_login_error () =
+  run_lwt
+  @@ fun () ->
+  let response =
+    Mock_http.error_response ~status:`Unauthorized
+      ~error:"AuthenticationRequired" ~message:"Invalid credentials" ()
+  in
+  let* () =
+    Test_utils.with_mock_credential_manager [response]
+      (fun (module CM) (module C : Hermes.Client.S) manager ->
+        let _ = C.make in
+        (* suppress unused warning *)
+        Lwt.catch
+          (fun () ->
+            let* _ =
+              CM.login manager ~identifier:"[e-mail]" ~password:"wrong"
+                ()
+            in
+            fail "should have raised Xrpc_error" )
+          (function
+            | Hermes.Xrpc_error {status; error; _} ->
+                check int "status" 401 status ;
+                check test_string "error" "AuthenticationRequired" error ;
+                Lwt.return_unit
+            | e ->
+                Lwt.reraise e ) )
+    |> Lwt.map fst
+  in
+  Lwt.return_unit
+
+let test_login_with_auth_factor () =
+  run_lwt
+  @@ fun () ->
+  let session = Test_utils.make_test_session () in
+  let response =
+    Mock_http.json_response
+      (`Assoc
+         [ ("accessJwt", `String session.access_jwt)
+         ; ("refreshJwt", `String session.refresh_jwt)
+         ; ("did", `String session.did)
+         ; ("handle", `String session.handle) ] )
+  in
+  let* _, requests =
+    Test_utils.with_mock_credential_manager [response]
+      (fun (module CM) (module C : Hermes.Client.S) manager ->
+        let* _ =
+          CM.login manager ~identifier:"[e-mail]" ~password:"secret"
+            ~auth_factor_token:"123456" ()
+        in
+        Lwt.return () )
+  in
+  let req = List.hd requests in
+  Test_utils.assert_request_body_contains "123456" req ;
+  Lwt.return_unit
+
+(* resume session tests *)
+
+let test_resume_session () =
+  run_lwt
+  @@ fun () ->
+  let session = Test_utils.make_test_session () in
+  let* client, _requests =
+    Test_utils.with_mock_credential_manager []
+      (fun (module CM) (module C : Hermes.Client.S) manager ->
+        let* client = CM.resume manager ~session () in
+        Lwt.return client )
+  in
+  let client_session = Hermes.get_session client in
+  check bool "client has session" true (client_session <> None) ;
+  let s = Option.get client_session in
+  check test_string "did matches" session.did s.did ;
+  check test_string "handle matches" session.handle s.handle ;
+  Lwt.return_unit
+
+(** session callback tests *)
+
+let test_session_update_callback () =
+  run_lwt
+  @@ fun () ->
+  let session = Test_utils.make_test_session () in
+  let response =
+    Mock_http.json_response
+      (`Assoc
+         [ ("accessJwt", `String session.access_jwt)
+         ; ("refreshJwt", `String session.refresh_jwt)
+         ; ("did", `String session.did)
+         ; ("handle", `String session.handle) ] )
+  in
+  let callback_called = ref false in
+  let received_session = ref None in
+  let* _, _ =
+    Test_utils.with_mock_credential_manager [response]
+      (fun (module CM) (module C : Hermes.Client.S) manager ->
+        CM.on_session_update manager (fun s ->
+            callback_called := true ;
+            received_session := Some s ;
+            Lwt.return_unit ) ;
+        let* _ =
+          CM.login manager ~identifier:"[e-mail]" ~password:"secret" ()
+        in
+        Lwt.return () )
+  in
+  check bool "callback was called" true !callback_called ;
+  check bool "session was received" true (!received_session <> None) ;
+  let s = Option.get !received_session in
+  check test_string "received did" session.did s.did ;
+  Lwt.return_unit
+
+let test_session_expired_callback () =
+  run_lwt
+  @@ fun () ->
+  (* first log in, then log out with server error; should still call expired callback *)
+  let session = Test_utils.make_test_session () in
+  let login_response =
+    Mock_http.json_response
+      (`Assoc
+         [ ("accessJwt", `String session.access_jwt)
+         ; ("refreshJwt", `String session.refresh_jwt)
+         ; ("did", `String session.did)
+         ; ("handle", `String session.handle) ] )
+  in
+  (* log out endpoint returns error but should still clear session *)
+  let logout_response =
+    Mock_http.error_response ~status:`Internal_server_error
+      ~error:"InternalServerError" ()
+  in
+  let expired_called = ref false in
+  let* _, _ =
+    Test_utils.with_mock_credential_manager [login_response; logout_response]
+      (fun (module CM) (module C : Hermes.Client.S) manager ->
+        CM.on_session_expired manager (fun () ->
+            expired_called := true ;
+            Lwt.return_unit ) ;
+        let* _ =
+          CM.login manager ~identifier:"[e-mail]" ~password:"secret" ()
+        in
+        let* () = CM.logout manager in
+        Lwt.return () )
+  in
+  check bool "expired callback was called" true !expired_called ;
+  Lwt.return_unit
+
+(** log out tests *)
+
+let test_logout_success () =
+  run_lwt
+  @@ fun () ->
+  let session = Test_utils.make_test_session () in
+  let login_response =
+    Mock_http.json_response
+      (`Assoc
+         [ ("accessJwt", `String session.access_jwt)
+         ; ("refreshJwt", `String session.refresh_jwt)
+         ; ("did", `String session.did)
+         ; ("handle", `String session.handle) ] )
+  in
+  let logout_response = Mock_http.empty_response () in
+  let* manager_session, requests =
+    Test_utils.with_mock_credential_manager [login_response; logout_response]
+      (fun (module CM) (module C : Hermes.Client.S) manager ->
+        let* _ =
+          CM.login manager ~identifier:"[e-mail]" ~password:"secret" ()
+        in
+        let* () = CM.logout manager in
+        Lwt.return (CM.get_session manager) )
+  in
+  check (option reject) "manager session cleared" None manager_session ;
+  check int "request count" 2 (List.length requests) ;
+  let logout_req = List.nth requests 1 in
+  Test_utils.assert_request_path "/xrpc/com.atproto.server.deleteSession"
+    logout_req ;
+  Test_utils.assert_request_method `POST logout_req ;
+  Lwt.return_unit
+
+let test_logout_no_session () =
+  run_lwt
+  @@ fun () ->
+  let* _, requests =
+    Test_utils.with_mock_credential_manager []
+      (fun (module CM) (module C : Hermes.Client.S) manager ->
+        let* () = CM.logout manager in
+        Lwt.return () )
+  in
+  check int "no requests made" 0 (List.length requests) ;
+  Lwt.return_unit
+
+(* ===== Get Session Tests ===== *)
+
+let test_get_session_before_login () =
+  run_lwt
+  @@ fun () ->
+  let* session, _ =
+    Test_utils.with_mock_credential_manager []
+      (fun (module CM) (module C : Hermes.Client.S) manager ->
+        Lwt.return (CM.get_session manager) )
+  in
+  check (option reject) "no session" None session ;
+  Lwt.return_unit
+
+let test_get_session_after_login () =
+  run_lwt
+  @@ fun () ->
+  let session = Test_utils.make_test_session () in
+  let response =
+    Mock_http.json_response
+      (`Assoc
+         [ ("accessJwt", `String session.access_jwt)
+         ; ("refreshJwt", `String session.refresh_jwt)
+         ; ("did", `String session.did)
+         ; ("handle", `String session.handle) ] )
+  in
+  let* manager_session, _ =
+    Test_utils.with_mock_credential_manager [response]
+      (fun (module CM) (module C : Hermes.Client.S) manager ->
+        let* _ =
+          CM.login manager ~identifier:"[e-mail]" ~password:"secret" ()
+        in
+        Lwt.return (CM.get_session manager) )
+  in
+  check bool "has session" true (manager_session <> None) ;
+  let s = Option.get manager_session in
+  check test_string "did matches" session.did s.did ;
+  Lwt.return_unit
+
+(** token refresh tests *)
+
+let test_automatic_token_refresh () =
+  run_lwt
+  @@ fun () ->
+  (* create session with token expiring soon *)
+  let expired_session = Test_utils.make_test_session ~exp_offset:60 () in
+  let new_session = Test_utils.make_test_session ~exp_offset:3600 () in
+  let login_response =
+    Mock_http.json_response
+      (`Assoc
+         [ ("accessJwt", `String expired_session.access_jwt)
+         ; ("refreshJwt", `String expired_session.refresh_jwt)
+         ; ("did", `String expired_session.did)
+         ; ("handle", `String expired_session.handle) ] )
+  in
+  let refresh_response =
+    Mock_http.json_response
+      (`Assoc
+         [ ("accessJwt", `String new_session.access_jwt)
+         ; ("refreshJwt", `String new_session.refresh_jwt)
+         ; ("did", `String new_session.did)
+         ; ("handle", `String new_session.handle) ] )
+  in
+  (* API call response after refresh *)
+  let api_response =
+    Mock_http.json_response (`Assoc [("data", `String "success")])
+  in
+  let* result, requests =
+    Test_utils.with_mock_credential_manager
+      [login_response; refresh_response; api_response]
+      (fun (module CM) (module C) manager ->
+        let* client =
+          CM.login manager ~identifier:"[e-mail]" ~password:"secret" ()
+        in
+        (* making an API call should trigger token refresh *)
+        let* result =
+          C.query client "test.endpoint" (`Assoc []) (fun json ->
+              let open Yojson.Safe.Util in
+              Ok (json |> member "data" |> to_string) )
+        in
+        Lwt.return result )
+  in
+  check test_string "api result" "success" result ;
+  check int "request count" 3 (List.length requests) ;
+  (* second request should be refresh *)
+  let refresh_req = List.nth requests 1 in
+  Test_utils.assert_request_path "/xrpc/com.atproto.server.refreshSession"
+    refresh_req ;
+  Lwt.return_unit
+
+let test_refresh_failure_clears_session () =
+  run_lwt
+  @@ fun () ->
+  (* create session with expired token *)
+  let expired_session = Test_utils.make_test_session ~exp_offset:60 () in
+  let login_response =
+    Mock_http.json_response
+      (`Assoc
+         [ ("accessJwt", `String expired_session.access_jwt)
+         ; ("refreshJwt", `String expired_session.refresh_jwt)
+         ; ("did", `String expired_session.did)
+         ; ("handle", `String expired_session.handle) ] )
+  in
+  (* refresh fails with ExpiredToken *)
+  let refresh_response =
+    Mock_http.error_response ~status:`Bad_request ~error:"ExpiredToken"
+      ~message:"Refresh token expired" ()
+  in
+  let expired_called = ref false in
+  let* () =
+    Test_utils.with_mock_credential_manager [login_response; refresh_response]
+      (fun (module CM) (module C) manager ->
+        CM.on_session_expired manager (fun () ->
+            expired_called := true ;
+            Lwt.return_unit ) ;
+        let* client =
+          CM.login manager ~identifier:"[e-mail]" ~password:"secret" ()
+        in
+        (* making an API call should trigger token refresh which will fail *)
+        Lwt.catch
+          (fun () ->
+            let* _ =
+              C.query client "test.endpoint" (`Assoc []) (fun _ -> Ok ())
+            in
+            fail "should have raised SessionExpired" )
+          (function
+            | Hermes.Xrpc_error {error= "SessionExpired"; _} ->
+                Lwt.return_unit
+            | e ->
+                Lwt.reraise e ) )
+    |> Lwt.map fst
+  in
+  check bool "expired callback was called" true !expired_called ;
+  Lwt.return_unit
+
+(** tests *)
+
+let login_tests =
+  [ ("login success", `Quick, test_login_success)
+  ; ("login error", `Quick, test_login_error)
+  ; ("login with auth factor", `Quick, test_login_with_auth_factor) ]
+
+let resume_tests = [("resume session", `Quick, test_resume_session)]
+
+let callback_tests =
+  [ ("session update callback", `Quick, test_session_update_callback)
+  ; ("session expired callback", `Quick, test_session_expired_callback) ]
+
+let logout_tests =
+  [ ("logout success", `Quick, test_logout_success)
+  ; ("logout no session", `Quick, test_logout_no_session) ]
+
+let session_tests =
+  [ ("get session before login", `Quick, test_get_session_before_login)
+  ; ("get session after login", `Quick, test_get_session_after_login) ]
+
+let refresh_tests =
+  [ ("automatic token refresh", `Quick, test_automatic_token_refresh)
+  ; ( "refresh failure clears session"
+    , `Quick
+    , test_refresh_failure_clears_session ) ]
+
+let () =
+  run "Credential_manager"
+    [ ("login", login_tests)
+    ; ("resume", resume_tests)
+    ; ("callbacks", callback_tests)
+    ; ("logout", logout_tests)
+    ; ("session", session_tests)
+    ; ("refresh", refresh_tests) ]

hermes/test/test_jwt.ml

···
+open Alcotest
+
+(** helpers *)
+let test_string = testable Fmt.string String.equal
+
+(* create a minimal jwt
+   we only care about the (base64url encoded json) payload, so header and signature can be anything *)
+let make_jwt payload_json =
+  let header = "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9" in
+  (* {"alg":"HS256","typ":"JWT"} *)
+  let payload =
+    Base64.encode_string ~alphabet:Base64.uri_safe_alphabet ~pad:false
+      payload_json
+  in
+  let signature = "signature" in
+  header ^ "." ^ payload ^ "." ^ signature
+
+(* decoding a valid JWT *)
+let test_decode_valid () =
+  let now = int_of_float (Unix.time ()) in
+  let payload_json =
+    Printf.sprintf {|{"sub":"did:plc:test","iat":%d,"exp":%d}|} now (now + 3600)
+  in
+  let jwt = make_jwt payload_json in
+  match Hermes.Jwt.decode_payload jwt with
+  | Ok payload ->
+      check (option test_string) "sub" (Some "did:plc:test") payload.sub ;
+      check (option int) "iat" (Some now) payload.iat ;
+      check (option int) "exp" (Some (now + 3600)) payload.exp
+  | Error e ->
+      fail ("decode failed: " ^ e)
+
+(* decoding JWT with additional fields *)
+let test_decode_with_extra_fields () =
+  let now = int_of_float (Unix.time ()) in
+  let payload_json =
+    Printf.sprintf
+      {|{"sub":"did:plc:extra","iat":%d,"exp":%d,"scope":"atproto","aud":"did:web:server"}|}
+      now (now + 3600)
+  in
+  let jwt = make_jwt payload_json in
+  match Hermes.Jwt.decode_payload jwt with
+  | Ok payload ->
+      check (option test_string) "sub" (Some "did:plc:extra") payload.sub ;
+      check (option int) "exp" (Some (now + 3600)) payload.exp ;
+      check (option test_string) "aud" (Some "did:web:server") payload.aud
+  | Error e ->
+      fail ("decode failed: " ^ e)
+
+(* decoding invalid JWT format *)
+let test_decode_invalid_format () =
+  let invalid = "not.a.jwt.with.wrong.parts" in
+  match Hermes.Jwt.decode_payload invalid with
+  | Ok _ ->
+      fail "should have failed"
+  | Error e ->
+      check bool "has error" true (String.length e > 0)
+
+let test_decode_no_dots () =
+  let invalid = "nodots" in
+  match Hermes.Jwt.decode_payload invalid with
+  | Ok _ ->
+      fail "should have failed"
+  | Error _ ->
+      ()
+
+(* decoding JWT with invalid base64 *)
+let test_decode_invalid_base64 () =
+  let invalid = "header.!!!invalid!!!.signature" in
+  match Hermes.Jwt.decode_payload invalid with
+  | Ok _ ->
+      fail "should have failed"
+  | Error _ ->
+      ()
+
+(* decoding JWT with invalid JSON payload *)
+let test_decode_invalid_json () =
+  let header = "eyJhbGciOiJIUzI1NiJ9" in
+  let payload =
+    Base64.encode_string ~alphabet:Base64.uri_safe_alphabet ~pad:false
+      "not json"
+  in
+  let jwt = header ^ "." ^ payload ^ ".sig" in
+  match Hermes.Jwt.decode_payload jwt with
+  | Ok _ ->
+      fail "should have failed"
+  | Error _ ->
+      ()
+
+(* test is_expired with expired token *)
+let test_expired_token () =
+  let past = int_of_float (Unix.time ()) - 3600 in
+  (* 1 hour ago *)
+  let payload_json =
+    Printf.sprintf {|{"sub":"test","iat":%d,"exp":%d}|} past past
+  in
+  let jwt = make_jwt payload_json in
+  check bool "is expired" true (Hermes.Jwt.is_expired jwt)
+
+(* test is_expired with valid token *)
+let test_valid_token () =
+  let now = int_of_float (Unix.time ()) in
+  let future = now + 3600 in
+  (* 1 hour from now *)
+  let payload_json =
+    Printf.sprintf {|{"sub":"test","iat":%d,"exp":%d}|} now future
+  in
+  let jwt = make_jwt payload_json in
+  check bool "is not expired" false (Hermes.Jwt.is_expired jwt)
+
+(* test is_expired with buffer *)
+let test_expired_with_buffer () =
+  let now = int_of_float (Unix.time ()) in
+  let almost_expired = now + 30 in
+  (* expires in 30 seconds *)
+  let payload_json =
+    Printf.sprintf {|{"sub":"test","iat":%d,"exp":%d}|} now almost_expired
+  in
+  let jwt = make_jwt payload_json in
+  (* default buffer is 60 seconds, so this should be considered expired *)
+  check bool "expired with buffer" true (Hermes.Jwt.is_expired jwt)
+
+(* is_expired with invalid JWT returns true *)
+let test_expired_invalid_jwt () =
+  check bool "invalid JWT treated as expired" true
+    (Hermes.Jwt.is_expired "invalid")
+
+(* test get_expiration *)
+let test_get_expiration () =
+  let now = int_of_float (Unix.time ()) in
+  let exp_time = now + 3600 in
+  let payload_json = Printf.sprintf {|{"sub":"test","exp":%d}|} exp_time in
+  let jwt = make_jwt payload_json in
+  check (option int) "expiration" (Some exp_time)
+    (Hermes.Jwt.get_expiration jwt)
+
+let test_get_expiration_missing () =
+  let payload_json = {|{"sub":"test"}|} in
+  let jwt = make_jwt payload_json in
+  check (option int) "no expiration" None (Hermes.Jwt.get_expiration jwt)
+
+(** tests *)
+
+let decode_tests =
+  [ ("decode valid JWT", `Quick, test_decode_valid)
+  ; ("decode with extra fields", `Quick, test_decode_with_extra_fields)
+  ; ("decode invalid format", `Quick, test_decode_invalid_format)
+  ; ("decode no dots", `Quick, test_decode_no_dots)
+  ; ("decode invalid base64", `Quick, test_decode_invalid_base64)
+  ; ("decode invalid json", `Quick, test_decode_invalid_json) ]
+
+let expiry_tests =
+  [ ("expired token", `Quick, test_expired_token)
+  ; ("valid token", `Quick, test_valid_token)
+  ; ("expired with buffer", `Quick, test_expired_with_buffer)
+  ; ("invalid JWT is expired", `Quick, test_expired_invalid_jwt)
+  ; ("get_expiration", `Quick, test_get_expiration)
+  ; ("get_expiration missing", `Quick, test_get_expiration_missing) ]
+
+let () = run "Jwt" [("decode", decode_tests); ("expiry", expiry_tests)]

hermes/test/test_types.ml

···
+open Alcotest
+
+(** helpers *)
+let test_string = testable Fmt.string String.equal
+
+let test_int64 = testable Fmt.int64 Int64.equal
+
+(* blob tests *)
+let test_blob_to_yojson () =
+  let cid =
+    Cid.of_string "bafyreib7k7m7h7x6qrvxqrwqe2m6q5p5zklvp4fqq2g6hh6h6t6x6x6x6y"
+  in
+  match cid with
+  | Ok cid -> (
+      let blob : Hermes.blob =
+        {ref_= cid; mime_type= "image/png"; size= 12345L}
+      in
+      let json = Hermes.blob_to_yojson blob in
+      let json_str = Yojson.Safe.to_string json in
+      check bool "contains mimeType" true
+        (String.length json_str > 0 && String.sub json_str 0 1 = "{") ;
+      (* verify valid JSON with expected structure *)
+      match json with
+      | `Assoc pairs ->
+          check bool "has mimeType key" true
+            (List.exists (fun (k, _) -> k = "mimeType") pairs) ;
+          check bool "has size key" true
+            (List.exists (fun (k, _) -> k = "size") pairs)
+      | _ ->
+          fail "expected object" )
+  | Error _ ->
+      fail "couldn't parse cid constant"
+
+let test_blob_roundtrip () =
+  let cid =
+    Cid.of_string "bafyreib7k7m7h7x6qrvxqrwqe2m6q5p5zklvp4fqq2g6hh6h6t6x6x6x6y"
+  in
+  match cid with
+  | Ok cid -> (
+      let original : Hermes.blob =
+        {ref_= cid; mime_type= "image/jpeg"; size= 54321L}
+      in
+      let json = Hermes.blob_to_yojson original in
+      match Hermes.blob_of_yojson json with
+      | Ok decoded ->
+          check test_string "mime_type matches" original.mime_type
+            decoded.mime_type ;
+          check test_int64 "size matches" original.size decoded.size
+      | Error e ->
+          fail ("roundtrip failed: " ^ e) )
+  | Error _ ->
+      ()
+
+(** session tests *)
+let test_session_to_yojson () =
+  let session : Hermes.session =
+    { access_jwt= "eyJ..."
+    ; refresh_jwt= "eyJ..."
+    ; did= "did:plc:example"
+    ; handle= "user.bsky.social"
+    ; pds_uri= Some "https://pds.example.com"
+    ; email= Some "[e-mail]"
+    ; email_confirmed= Some true
+    ; email_auth_factor= Some false
+    ; active= Some true
+    ; status= None }
+  in
+  let json = Hermes.session_to_yojson session in
+  match json with
+  | `Assoc pairs ->
+      check bool "has accessJwt" true
+        (List.exists (fun (k, _) -> k = "accessJwt") pairs) ;
+      check bool "has refreshJwt" true
+        (List.exists (fun (k, _) -> k = "refreshJwt") pairs) ;
+      check bool "has did" true (List.exists (fun (k, _) -> k = "did") pairs) ;
+      check bool "has handle" true
+        (List.exists (fun (k, _) -> k = "handle") pairs)
+  | _ ->
+      fail "expected object"
+
+let test_session_of_yojson_full () =
+  let json =
+    Yojson.Safe.from_string
+      {|{
+    "accessJwt": "access_token",
+    "refreshJwt": "refresh_token",
+    "did": "did:plc:test",
+    "handle": "test.bsky.social",
+    "pdsUri": "https://pds.test.com",
+    "email": "[e-mail]",
+    "emailConfirmed": true,
+    "emailAuthFactor": false,
+    "active": true,
+    "status": "active"
+  }|}
+  in
+  match Hermes.session_of_yojson json with
+  | Ok session ->
+      check test_string "access_jwt" "access_token" session.access_jwt ;
+      check test_string "refresh_jwt" "refresh_token" session.refresh_jwt ;
+      check test_string "did" "did:plc:test" session.did ;
+      check test_string "handle" "test.bsky.social" session.handle ;
+      check (option test_string) "pds_uri" (Some "https://pds.test.com")
+        session.pds_uri ;
+      check (option test_string) "email" (Some "[e-mail]") session.email ;
+      check (option bool) "email_confirmed" (Some true) session.email_confirmed ;
+      check (option bool) "email_auth_factor" (Some false)
+        session.email_auth_factor ;
+      check (option bool) "active" (Some true) session.active ;
+      check (option test_string) "status" (Some "active") session.status
+  | Error e ->
+      fail ("parse failed: " ^ e)
+
+let test_session_of_yojson_minimal () =
+  let json =
+    Yojson.Safe.from_string
+      {|{
+    "accessJwt": "access_token",
+    "refreshJwt": "refresh_token",
+    "did": "did:plc:test",
+    "handle": "test.bsky.social"
+  }|}
+  in
+  match Hermes.session_of_yojson json with
+  | Ok session ->
+      check test_string "access_jwt" "access_token" session.access_jwt ;
+      check test_string "did" "did:plc:test" session.did ;
+      check (option test_string) "pds_uri" None session.pds_uri ;
+      check (option test_string) "email" None session.email ;
+      check (option bool) "active" None session.active
+  | Error e ->
+      fail ("parse failed: " ^ e)
+
+let test_session_roundtrip () =
+  let original : Hermes.session =
+    { access_jwt= "access123"
+    ; refresh_jwt= "refresh456"
+    ; did= "did:plc:roundtrip"
+    ; handle= "roundtrip.test"
+    ; pds_uri= None
+    ; email= Some "[e-mail]"
+    ; email_confirmed= None
+    ; email_auth_factor= None
+    ; active= Some true
+    ; status= None }
+  in
+  let json = Hermes.session_to_yojson original in
+  match Hermes.session_of_yojson json with
+  | Ok decoded ->
+      check test_string "access_jwt" original.access_jwt decoded.access_jwt ;
+      check test_string "refresh_jwt" original.refresh_jwt decoded.refresh_jwt ;
+      check test_string "did" original.did decoded.did ;
+      check test_string "handle" original.handle decoded.handle ;
+      check (option test_string) "pds_uri" original.pds_uri decoded.pds_uri ;
+      check (option test_string) "email" original.email decoded.email ;
+      check (option bool) "active" original.active decoded.active
+  | Error e ->
+      fail ("roundtrip failed: " ^ e)
+
+(** tests *)
+
+let blob_tests =
+  [ ("blob_to_yojson", `Quick, test_blob_to_yojson)
+  ; ("blob roundtrip", `Quick, test_blob_roundtrip) ]
+
+let session_tests =
+  [ ("session_to_yojson", `Quick, test_session_to_yojson)
+  ; ("session_of_yojson full", `Quick, test_session_of_yojson_full)
+  ; ("session_of_yojson minimal", `Quick, test_session_of_yojson_minimal)
+  ; ("session roundtrip", `Quick, test_session_roundtrip) ]
+
+let () = run "Types" [("blob", blob_tests); ("session", session_tests)]

hermes/test/test_utils.ml

···
+(** test utilities *)
+
+open Lwt.Syntax
+
+(* run a test with a mock HTTP client using queued responses *)
+let with_mock_responses responses f =
+  let queue = Mock_http.Queue.create responses in
+  let handler_ref = ref (Mock_http.Queue.handler queue) in
+  let module MockHttp = Mock_http.Make (struct
+    let handler = handler_ref
+  end) in
+  let module MockClient = Hermes.Client.Make (MockHttp) in
+  let client = MockClient.make ~service:"https://test.example.com" () in
+  let* result = f (module MockClient : Hermes.Client.S) client in
+  Lwt.return (result, Mock_http.Queue.get_requests queue)
+
+(* run a test with a mock HTTP client using pattern matching *)
+let with_mock_patterns ?default rules f =
+  let pattern = Mock_http.Pattern.create ?default rules in
+  let handler_ref = ref (Mock_http.Pattern.handler pattern) in
+  let module MockHttp = Mock_http.Make (struct
+    let handler = handler_ref
+  end) in
+  let module MockClient = Hermes.Client.Make (MockHttp) in
+  let client = MockClient.make ~service:"https://test.example.com" () in
+  let* result = f (module MockClient : Hermes.Client.S) client in
+  Lwt.return (result, Mock_http.Pattern.get_requests pattern)
+
+(* create a valid JWT for testing *)
+let make_test_jwt ?(exp_offset = 3600) ?(sub = "did:plc:test") () =
+  let now = int_of_float (Unix.time ()) in
+  let exp = now + exp_offset in
+  let header = "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9" in
+  let payload_json =
+    Printf.sprintf {|{"sub":"%s","iat":%d,"exp":%d}|} sub now exp
+  in
+  let payload =
+    Base64.encode_string ~alphabet:Base64.uri_safe_alphabet ~pad:false
+      payload_json
+  in
+  header ^ "." ^ payload ^ ".fake_signature"
+
+(* create a test session *)
+let make_test_session ?(exp_offset = 3600) () : Hermes.session =
+  let jwt = make_test_jwt ~exp_offset () in
+  { access_jwt= jwt
+  ; refresh_jwt= make_test_jwt ~exp_offset:86400 ()
+  ; did= "did:plc:testuser123"
+  ; handle= "test.bsky.social"
+  ; pds_uri= Some "https://pds.example.com"
+  ; email= Some "[e-mail]"
+  ; email_confirmed= Some true
+  ; email_auth_factor= Some false
+  ; active= Some true
+  ; status= None }
+
+(* create a session response JSON *)
+let session_response_json ?(exp_offset = 3600) () =
+  let session = make_test_session ~exp_offset () in
+  `Assoc
+    [ ("accessJwt", `String session.access_jwt)
+    ; ("refreshJwt", `String session.refresh_jwt)
+    ; ("did", `String session.did)
+    ; ("handle", `String session.handle) ]
+
+(** assert helpers for requests *)
+
+let assert_request_path expected_path (req : Mock_http.request) =
+  let actual = Uri.path req.uri in
+  if actual <> expected_path then
+    failwith (Printf.sprintf "expected path %s but got %s" expected_path actual)
+
+let assert_request_method expected_meth (req : Mock_http.request) =
+  if req.meth <> expected_meth then
+    let expected_str =
+      match expected_meth with `GET -> "GET" | `POST -> "POST"
+    in
+    let actual_str = match req.meth with `GET -> "GET" | `POST -> "POST" in
+    failwith
+      (Printf.sprintf "expected method %s but got %s" expected_str actual_str)
+
+let assert_request_has_header name value (req : Mock_http.request) =
+  match Cohttp.Header.get req.headers name with
+  | Some v when v = value ->
+      ()
+  | Some v ->
+      failwith (Printf.sprintf "header %s: expected %s but got %s" name value v)
+  | None ->
+      failwith (Printf.sprintf "header %s not found" name)
+
+let assert_request_has_auth_header (req : Mock_http.request) =
+  match Cohttp.Header.get req.headers "authorization" with
+  | Some v when String.length v > 7 && String.sub v 0 7 = "Bearer " ->
+      ()
+  | Some v ->
+      failwith (Printf.sprintf "invalid auth header: %s" v)
+  | None ->
+      failwith "authorization header not found"
+
+let assert_request_query_param name expected_value (req : Mock_http.request) =
+  let query = Uri.query req.uri in
+  match List.assoc_opt name query with
+  | Some [v] when v = expected_value ->
+      ()
+  | Some [v] ->
+      failwith
+        (Printf.sprintf "query param %s: expected %s but got %s" name
+           expected_value v )
+  | Some vs ->
+      failwith
+        (Printf.sprintf "query param %s has multiple values: %s" name
+           (String.concat ", " vs) )
+  | None ->
+      failwith (Printf.sprintf "query param %s not found" name)
+
+let assert_request_body_contains substring (req : Mock_http.request) =
+  match req.body with
+  | Some body when String.length body > 0 ->
+      if
+        not
+          ( String.length substring <= String.length body
+          &&
+          let rec check i =
+            if i > String.length body - String.length substring then false
+            else if String.sub body i (String.length substring) = substring then
+              true
+            else check (i + 1)
+          in
+          check 0 )
+      then failwith (Printf.sprintf "body does not contain '%s'" substring)
+  | _ ->
+      failwith "expected request body but none found"
+
+(* run a test with a mock credential manager *)
+let with_mock_credential_manager responses f =
+  let queue = Mock_http.Queue.create responses in
+  let handler_ref = ref (Mock_http.Queue.handler queue) in
+  let module MockHttp = Mock_http.Make (struct
+    let handler = handler_ref
+  end) in
+  let module MockClient = Hermes.Client.Make (MockHttp) in
+  let module MockCredManager = Hermes.Credential_manager.Make (MockClient) in
+  let manager = MockCredManager.make ~service:"https://test.example.com" () in
+  let* result =
+    f
+      (module MockCredManager : Hermes.Credential_manager.S)
+      (module MockClient : Hermes.Client.S)
+      manager
+  in
+  Lwt.return (result, Mock_http.Queue.get_requests queue)

hermes_ppx.opam

···
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "PPX extension for Hermes XRPC calls"
+maintainer: ["futurGH"]
+authors: ["futurGH"]
+license: "MPL-2.0"
+homepage: "https://github.com/futurGH/pegasus"
+bug-reports: "https://github.com/futurGH/pegasus/issues"
+depends: [
+  "ocaml" {= "5.2.1"}
+  "dune" {>= "3.20"}
+  "ppxlib" {>= "0.32.0"}
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
+dev-repo: "git+https://github.com/futurGH/pegasus.git"
+x-maintenance-intent: ["(latest)"]

hermes_ppx/lib/dune

···
+(library
+ (name hermes_ppx)
+ (kind ppx_rewriter)
+ (libraries ppxlib)
+ (preprocess
+  (pps ppxlib.metaquot)))

hermes_ppx/lib/hermes_ppx.ml

···
+open Ppxlib
+
+(* convert nsid to module path: "app.bsky.graph.get" -> ["App"; "Bsky"; "Graph"; "Get"] *)
+let nsid_to_module_path nsid =
+  String.split_on_char '.' nsid |> List.map String.capitalize_ascii
+
+(* convert nsid to flat module name: "com.atproto.identity.resolveHandle" -> "Com_atproto_identity_resolveHandle" *)
+let nsid_to_flat_module_name nsid =
+  let flat = String.concat "_" (String.split_on_char '.' nsid) in
+  String.capitalize_ascii flat
+
+(* build module access expression from path: ["App"; "Bsky"] -> App.Bsky *)
+let build_module_path ~loc path =
+  match path with
+  | [] ->
+      Location.raise_errorf ~loc "Empty module path"
+  | first :: rest ->
+      List.fold_left
+        (fun acc part ->
+          let lid = Loc.make ~loc (Longident.Ldot (acc.txt, part)) in
+          lid )
+        (Loc.make ~loc (Longident.Lident first))
+        rest
+
+(* build full expression for flat module structure: Module_name.Main.call *)
+let build_call_expr_flat ~loc nsid =
+  let module_name = nsid_to_flat_module_name nsid in
+  (* Build: Module_name.Main.call *)
+  let lid = Longident.(Ldot (Ldot (Lident module_name, "Main"), "call")) in
+  Ast_builder.Default.pexp_ident ~loc (Loc.make ~loc lid)
+
+(* build full expression: Module.Path.call (nested style, kept for compatibility) *)
+let build_call_expr ~loc nsid =
+  let parts = nsid_to_module_path nsid in
+  let module_lid = build_module_path ~loc parts in
+  let call_lid = Loc.make ~loc (Longident.Ldot (module_lid.txt, "call")) in
+  Ast_builder.Default.pexp_ident ~loc call_lid
+
+(* parse method and nsid from structure items *)
+let parse_method_and_nsid ~loc str =
+  match str with
+  | [{pstr_desc= Pstr_eval (expr, _); _}] -> (
+    match expr.pexp_desc with
+    (* [%xrpc get "nsid"] *)
+    | Pexp_apply
+        ( {pexp_desc= Pexp_ident {txt= Lident method_; _}; _}
+        , [(Nolabel, {pexp_desc= Pexp_constant (Pconst_string (nsid, _, _)); _})]
+        ) ->
+        let method_lower = String.lowercase_ascii method_ in
+        if method_lower = "get" || method_lower = "post" then
+          (method_lower, nsid)
+        else
+          Location.raise_errorf ~loc "Expected 'get' or 'post', got '%s'"
+            method_
+    (* [%xrpc "nsid"] - assume get *)
+    | Pexp_constant (Pconst_string (nsid, _, _)) ->
+        ("get", nsid)
+    | _ ->
+        Location.raise_errorf ~loc
+          "Expected [%%xrpc get \"nsid\"] or [%%xrpc post \"nsid\"]" )
+  | _ ->
+      Location.raise_errorf ~loc
+        "Expected [%%xrpc get \"nsid\"] or [%%xrpc post \"nsid\"]"
+
+let expand ~ctxt str =
+  let loc = Expansion_context.Extension.extension_point_loc ctxt in
+  let _method, nsid = parse_method_and_nsid ~loc str in
+  build_call_expr_flat ~loc nsid
+
+let xrpc_extension =
+  Extension.V3.declare "xrpc" Extension.Context.expression
+    Ast_pattern.(pstr __)
+    expand
+
+let rule = Context_free.Rule.extension xrpc_extension
+
+let () = Driver.register_transformation "hermes_ppx" ~rules:[rule]

hermes_ppx/test/dune

···
+(test
+ (name test_ppx)
+ (libraries alcotest hermes_ppx ppxlib)
+ (preprocess (pps hermes_ppx)))

hermes_ppx/test/test_ppx.ml

···
+open Alcotest
+
+let loc = Location.none
+
+let test_nsid_to_module_path_simple () =
+  let result = Hermes_ppx.nsid_to_module_path "app.bsky.graph" in
+  check (list string) "simple path" ["App"; "Bsky"; "Graph"] result
+
+let test_nsid_to_module_path_camel_case () =
+  let result =
+    Hermes_ppx.nsid_to_module_path "app.bsky.graph.getRelationships"
+  in
+  check (list string) "camelCase"
+    ["App"; "Bsky"; "Graph"; "GetRelationships"]
+    result
+
+let test_nsid_to_module_path_single () =
+  let result = Hermes_ppx.nsid_to_module_path "test" in
+  check (list string) "single segment" ["Test"] result
+
+let test_build_module_path_single () =
+  let result = Hermes_ppx.build_module_path ~loc ["App"] in
+  check string "single module" "App" (Ppxlib.Longident.name result.txt)
+
+let test_build_module_path_nested () =
+  let result = Hermes_ppx.build_module_path ~loc ["App"; "Bsky"; "Graph"] in
+  check string "nested module" "App.Bsky.Graph"
+    (Ppxlib.Longident.name result.txt)
+
+let test_build_call_expr () =
+  let result = Hermes_ppx.build_call_expr ~loc "app.bsky.graph.getProfile" in
+  let expected_str = "App.Bsky.Graph.GetProfile.call" in
+  check string "call expr" expected_str
+    (Ppxlib.Pprintast.string_of_expression result)
+
+let expand_xrpc code =
+  let lexbuf = Lexing.from_string code in
+  let structure = Ppxlib.Parse.implementation lexbuf in
+  let transformed = Ppxlib.Driver.map_structure structure in
+  match transformed with
+  | [{Ppxlib.pstr_desc= Ppxlib.Pstr_eval (expr, _); _}] ->
+      expr
+  | [{Ppxlib.pstr_desc= Ppxlib.Pstr_value (_, [{pvb_expr; _}]); _}] ->
+      pvb_expr
+  | _ ->
+      failwith "unexpected structure after expansion"
+
+let test_expand_get_nsid () =
+  let actual = expand_xrpc {|[%xrpc get "app.bsky.graph.getRelationships"]|} in
+  let expected_str = "App.Bsky.Graph.GetRelationships.call" in
+  check string "get expansion" expected_str
+    (Ppxlib.Pprintast.string_of_expression actual)
+
+let test_expand_post_nsid () =
+  let actual =
+    expand_xrpc {|[%xrpc post "com.atproto.server.createSession"]|}
+  in
+  let expected_str = "Com.Atproto.Server.CreateSession.call" in
+  check string "post expansion" expected_str
+    (Ppxlib.Pprintast.string_of_expression actual)
+
+let test_expand_nsid_only () =
+  (* [%xrpc "nsid"] defaults to get *)
+  let actual = expand_xrpc {|[%xrpc "app.bsky.actor.getProfile"]|} in
+  let expected_str = "App.Bsky.Actor.GetProfile.call" in
+  check string "nsid only expansion" expected_str
+    (Ppxlib.Pprintast.string_of_expression actual)
+
+let unit_tests =
+  [ ("nsid_to_module_path simple", `Quick, test_nsid_to_module_path_simple)
+  ; ( "nsid_to_module_path camelCase"
+    , `Quick
+    , test_nsid_to_module_path_camel_case )
+  ; ("nsid_to_module_path single", `Quick, test_nsid_to_module_path_single)
+  ; ("build_module_path single", `Quick, test_build_module_path_single)
+  ; ("build_module_path nested", `Quick, test_build_module_path_nested)
+  ; ("build_call_expr", `Quick, test_build_call_expr) ]
+
+let expansion_tests =
+  [ ("expand get nsid", `Quick, test_expand_get_nsid)
+  ; ("expand post nsid", `Quick, test_expand_post_nsid)
+  ; ("expand nsid only", `Quick, test_expand_nsid_only) ]
+
+let () = run "hermes_ppx" [("unit", unit_tests); ("expansion", expansion_tests)]