├── .gitignore ├── .travis.yml ├── Makefile ├── README.md ├── dune-project ├── jsonrpc2-lwt.opam ├── jsonrpc2-sync.opam ├── jsonrpc2.opam ├── src ├── dune ├── jsonrpc2.ml ├── jsonrpc2_core.ml ├── jsonrpc2_intf.ml ├── lwt │ ├── dune │ └── jsonrpc2_lwt.ml └── sync │ ├── dune │ └── jsonrpc2_sync.ml └── tests ├── dune └── test_server.ml /.gitignore: -------------------------------------------------------------------------------- 1 | .git 2 | _build 3 | *.install 4 | .merlin 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh 3 | script: bash -ex .travis-docker.sh 4 | services: 5 | - docker 6 | env: 7 | global: 8 | - PINS="jsonrpc2:. jsonrpc2-sync" 9 | - DISTRO="ubuntu-16.04" 10 | - PACKAGE="jsonrpc2-sync" 11 | matrix: 12 | - OCAML_VERSION="4.03" 13 | - OCAML_VERSION="4.04" 14 | - OCAML_VERSION="4.06" 15 | - OCAML_VERSION="4.07" 16 | - OCAML_VERSION="4.09" 17 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | 3 | all: build test 4 | 5 | build: 6 | @dune build @install 7 | 8 | test: 9 | @dune runtest --no-buffer --force 10 | 11 | clean: 12 | @dune clean 13 | 14 | doc: 15 | @dune build @doc 16 | 17 | watch: 18 | @dune build @all -w 19 | 20 | .PHONY: benchs tests build watch 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | # Jsonrpc2 [![build status](https://travis-ci.org/c-cube/jsonrpc2.svg?branch=master)](https://travis-ci.org/c-cube/jsonrpc2) 3 | 4 | A modular Jsonrpc2 client and server, usable with sync or async IO. 5 | 6 | ## Documentation 7 | 8 | See https://c-cube.github.io/jsonrpc2/ 9 | 10 | ## License 11 | 12 | MIT. 13 | 14 | 15 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.1) 2 | -------------------------------------------------------------------------------- /jsonrpc2-lwt.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "jsonrpc2-lwt" 3 | version: "0.1" 4 | authors: ["Simon Cruanes"] 5 | maintainer: "simon.cruanes.2007@m4x.org" 6 | license: "MIT" 7 | synopsis: "JSONRPC2 implementation: lwt adapter" 8 | build: [ 9 | ["dune" "build" "@install" "-p" name "-j" jobs] 10 | ["dune" "build" "@doc" "-p" name] {with-doc} 11 | ["dune" "runtest" "-p" name] {with-test} 12 | ] 13 | depends: [ 14 | "dune" { >= "1.1" } 15 | "jsonrpc2" { = version } 16 | "lwt" { >= "3.0" } 17 | "base-unix" 18 | "odoc" {with-doc} 19 | "ocaml" { >= "4.03.0" } 20 | ] 21 | tags: [ "rpc" "jsonrpc" "jsonrcp2" ] 22 | homepage: "https://github.com/c-cube/jsonrpc2/" 23 | doc: "https://c-cube.github.io/jsonrpc2/" 24 | bug-reports: "https://github.com/c-cube/jsonrpc2/issues" 25 | dev-repo: "git+https://github.com/c-cube/jsonrpc2.git" 26 | -------------------------------------------------------------------------------- /jsonrpc2-sync.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "jsonrpc2-sync" 3 | version: "0.1" 4 | authors: ["Simon Cruanes"] 5 | maintainer: "simon.cruanes.2007@m4x.org" 6 | license: "MIT" 7 | synopsis: "JSONRPC2 implementation: synchronous adapter" 8 | build: [ 9 | ["dune" "build" "@install" "-p" name "-j" jobs] 10 | ["dune" "build" "@doc" "-p" name] {with-doc} 11 | ["dune" "runtest" "-p" name] {with-test} 12 | ] 13 | depends: [ 14 | "dune" { >= "1.1" } 15 | "jsonrpc2" { = version } 16 | "base-unix" 17 | "base-threads" 18 | "odoc" {with-doc} 19 | "decoders-yojson" {with-test} 20 | ] 21 | tags: [ "rpc" "jsonrpc" "jsonrcp2" "sync" ] 22 | homepage: "https://github.com/c-cube/jsonrpc2/" 23 | doc: "https://c-cube.github.io/jsonrpc2/" 24 | bug-reports: "https://github.com/c-cube/jsonrpc2/issues" 25 | dev-repo: "git+https://github.com/c-cube/jsonrpc2.git" 26 | -------------------------------------------------------------------------------- /jsonrpc2.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "jsonrpc2" 3 | version: "0.1" 4 | authors: ["Simon Cruanes"] 5 | maintainer: "simon.cruanes.2007@m4x.org" 6 | license: "MIT" 7 | synopsis: "JSONRPC2 implementation" 8 | build: [ 9 | ["dune" "build" "@install" "-p" name "-j" jobs] 10 | ["dune" "build" "@doc" "-p" name] {with-doc} 11 | ["dune" "runtest" "-p" name] {with-test} 12 | ] 13 | depends: [ 14 | "dune" { >= "1.1" } 15 | "yojson" { >= "1.6" } 16 | "odoc" {with-doc} 17 | "ocaml" { >= "4.03.0" } 18 | ] 19 | tags: [ "rpc" "jsonrpc" "jsonrcp2" ] 20 | homepage: "https://github.com/c-cube/jsonrpc2/" 21 | doc: "https://c-cube.github.io/jsonrpc2/" 22 | bug-reports: "https://github.com/c-cube/jsonrpc2/issues" 23 | dev-repo: "git+https://github.com/c-cube/jsonrpc2.git" 24 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (env 2 | (_ (flags :standard -warn-error -3 -safe-string))) 3 | 4 | (library 5 | (name jsonrpc2) 6 | (public_name jsonrpc2) 7 | (flags :standard -warn-error -3) 8 | (libraries yojson)) 9 | -------------------------------------------------------------------------------- /src/jsonrpc2.ml: -------------------------------------------------------------------------------- 1 | 2 | (** {1 Simple JSON-RPC2 implementation} 3 | 4 | See {{: https://www.jsonrpc.org/specification} the spec} *) 5 | 6 | module type IO = Jsonrpc2_intf.IO 7 | module type S = Jsonrpc2_intf.S 8 | 9 | module Make = Jsonrpc2_core.Make 10 | -------------------------------------------------------------------------------- /src/jsonrpc2_core.ml: -------------------------------------------------------------------------------- 1 | 2 | module J = Yojson.Safe 3 | 4 | type 'a printer = Format.formatter -> 'a -> unit 5 | 6 | type code = int 7 | let code_parse_error : code = (-32700) 8 | let code_invalid_request : code = (-32600) 9 | let code_method_not_found : code = (-32601) 10 | let code_invalid_param : code = (-32602) 11 | let code_internal_error : code = (-32603) 12 | 13 | let opt_map_ f = function None -> None | Some x -> Some (f x) 14 | 15 | (** {2 The protocol part, independent from IO and Transport} *) 16 | module Protocol : sig 17 | type json = J.t 18 | 19 | type t 20 | (** A jsonrpc2 connection. *) 21 | 22 | val create : unit -> t 23 | (** Create a state machine for Jsonrpc2 *) 24 | 25 | val clear : t -> unit 26 | (** Clear all internal state. *) 27 | 28 | module Id : sig 29 | type t 30 | 31 | val equal : t -> t -> bool 32 | val hash : t -> int 33 | val pp : t printer 34 | 35 | module Tbl : Hashtbl.S with type key = t 36 | end 37 | 38 | (** {3 Send requests and notifications to the other side} *) 39 | 40 | type message = json 41 | (** Message sent to the other side *) 42 | 43 | val error : t -> code -> string -> message 44 | 45 | val request : t -> meth:string -> params:json option -> message * Id.t 46 | (** Create a request message, for which an answer is expected. *) 47 | 48 | val notify : t -> meth:string -> params:json option -> message 49 | (** Create a notification message, ie. no response is expected. *) 50 | 51 | (** Actions to be done next. This includes sending messages out 52 | on the connection, calling a method, or finishing a local request. *) 53 | type action = 54 | | Send of message 55 | | Send_batch of message list 56 | | Start_call of (Id.t * string * json option) 57 | | Notify of string * json option 58 | | Fill_request of (Id.t * (json,int * string) result) 59 | | Error_without_id of int * string 60 | 61 | val process_msg : t -> message -> (action list, code*string) result 62 | (** Process incoming message *) 63 | 64 | val process_call_reply : t -> Id.t -> (json, string) result -> action list 65 | (** Send the response for the given call to the other side *) 66 | end = struct 67 | type json = J.t 68 | 69 | module Id = struct 70 | type t = 71 | | Int of int 72 | | String of string 73 | | Null 74 | 75 | let equal = (=) 76 | let hash = Hashtbl.hash 77 | let to_string = function 78 | | Int i -> string_of_int i 79 | | String s -> s 80 | | Null -> "null" 81 | let pp out id = Format.pp_print_string out (to_string id) 82 | 83 | let to_json = function 84 | | Int i -> `Int i 85 | | String s -> `String s 86 | | Null -> `Null 87 | 88 | module Tbl = Hashtbl.Make(struct 89 | type nonrec t = t 90 | let equal = equal 91 | let hash = hash 92 | end) 93 | end 94 | 95 | type message = json 96 | 97 | type to_reply = 98 | | TR_single 99 | | TR_batch of { 100 | mutable missing: int; 101 | mutable done_: message list; 102 | } 103 | 104 | type t = { 105 | mutable id_ : int; 106 | active: unit Id.Tbl.t; (* active requests *) 107 | to_reply: to_reply Id.Tbl.t; (* active calls to which we shall answer *) 108 | } 109 | 110 | let create () : t = 111 | { id_=0; active=Id.Tbl.create 24; to_reply=Id.Tbl.create 24; } 112 | 113 | let clear (self:t) : unit = 114 | self.id_ <- 0; 115 | Id.Tbl.clear self.active; 116 | Id.Tbl.clear self.to_reply 117 | 118 | (* Get a fresh ID for this connection *) 119 | let fresh_id_ (self:t) : Id.t = 120 | let i = self.id_ in 121 | self.id_ <- i + 1; 122 | Id.Int i 123 | 124 | (* Build the JSON message to send for the given {b request} *) 125 | let mk_request_ ~id ~meth ~params = 126 | let l = [ 127 | "method", `String meth; 128 | "jsonrpc", `String "2.0"; 129 | "id", Id.to_json id; 130 | ] in 131 | let l = match params with None -> l | Some x -> ("params",x) :: l in 132 | `Assoc l 133 | 134 | (* Build the JSON message to send for the given {b notification} *) 135 | let mk_notify_ ~meth ~params = 136 | let l = [ 137 | "method", `String meth; 138 | "jsonrpc", `String "2.0"; 139 | ] in 140 | let l = match params with None -> l | Some x -> ("params", x) :: l in 141 | `Assoc l 142 | 143 | (* Build a response message *) 144 | let mk_response (id:Id.t) msg : json = 145 | `Assoc [ 146 | "jsonrpc", `String "2.0"; 147 | "result", msg; 148 | "id", Id.to_json id; 149 | ] 150 | 151 | (* Build an error message *) 152 | let error_ _self ~id code msg : json = 153 | let l = [ 154 | "jsonrpc", `String "2.0"; 155 | "error", `Assoc [ 156 | "code", `Int code; 157 | "message", `String msg; 158 | ] 159 | ] in 160 | let l = match id with 161 | | None -> l 162 | | Some id -> ("id", Id.to_json id) :: l 163 | in 164 | `Assoc l 165 | 166 | let error self code msg = error_ ~id:None self code msg 167 | 168 | let request (self:t) ~meth ~params : message * Id.t = 169 | let id = fresh_id_ self in 170 | Id.Tbl.add self.active id (); 171 | let msg = mk_request_ ~id ~meth ~params in 172 | msg, id 173 | 174 | (* Notify the remote server *) 175 | let notify (_self:t) ~meth ~params : message = 176 | mk_notify_ ~meth ~params 177 | 178 | module P_ : sig 179 | type +'a t 180 | val return : 'a -> 'a t 181 | val fail : string -> _ t 182 | val is_list : bool t 183 | val (>>=) : 'a t -> ('a -> 'b t) -> 'b t 184 | val (>|=) : 'a t -> ('a -> 'b) -> 'b t 185 | val field : string -> 'a t -> 'a t 186 | val field_opt : string -> 'a t -> 'a option t 187 | val json : json t 188 | val one_of : string -> 'a t list -> 'a t 189 | val int : int t 190 | val string : string t 191 | val null : unit t 192 | val list : 'a t -> 'a list t 193 | val run : 'a t -> json -> ('a, string lazy_t) result 194 | end = struct 195 | type +'a t = json -> ('a, (string * json) list) result 196 | let return x _ = Ok x 197 | let error_ ?(ctx=[]) j e = Error ((e,j)::ctx) 198 | let errorf_ ?ctx j fmt = Printf.ksprintf (error_ ?ctx j) fmt 199 | let fail s j = Error [s,j] 200 | let (>>=) x f j = match x j with 201 | | Ok x -> f x j 202 | | Error e -> Error e 203 | let (>|=) x f j = match x j with 204 | | Ok x -> Ok (f x) 205 | | Error e -> Error e 206 | let json j = Ok j 207 | let is_list = function `List _ -> Ok true | _ -> Ok false 208 | let int = function 209 | | `Int i -> Ok i 210 | | `String s as j -> 211 | (try Ok (int_of_string s) with _ -> errorf_ j "expected int") 212 | | j -> error_ j "expected int" 213 | let string = function 214 | | `Int i -> Ok (string_of_int i) 215 | | `String s -> Ok s 216 | | j -> error_ j "expected string" 217 | let null = function `Null -> Ok () | j -> error_ j "expected null" 218 | let field name f : _ t = function 219 | | `Assoc l as j -> 220 | (match List.assoc name l with 221 | | x -> f x 222 | | exception Not_found -> errorf_ j "no field '%s' found in object" name) 223 | | j -> error_ j "expected object" 224 | let field_opt name f : _ t = function 225 | | `Assoc l -> 226 | (match List.assoc name l with 227 | | x -> (match f x with Ok x -> Ok (Some x) | Error e -> Error e) 228 | | exception Not_found -> Ok None) 229 | | j -> error_ j "expected object" 230 | let rec one_of what l j = 231 | match l with 232 | | [] -> errorf_ j "expected %s, none matched the given list" what 233 | | x :: tl -> 234 | match x j with 235 | | Ok x -> Ok x 236 | | Error _ -> one_of what tl j 237 | 238 | let list f : _ t = function 239 | | `List l -> 240 | let rec aux acc = function 241 | | [] -> Ok (List.rev acc) 242 | | x :: tl -> 243 | match f x with 244 | | Error ctx -> error_ ~ctx x "in list" 245 | | Ok x -> aux (x::acc) tl 246 | in 247 | aux [] l 248 | | j -> error_ j "expected list" 249 | 250 | let run (p:_ t) (j:json) : _ result = 251 | match p j with 252 | | Ok x -> Ok x 253 | | Error l -> 254 | let msg = lazy ( 255 | String.concat "\n" @@ 256 | List.rev_map (fun (e,j) -> e ^ " in " ^ J.to_string j) l 257 | ) in 258 | Error msg 259 | end 260 | 261 | type incoming = 262 | | I_error of Id.t * code * string 263 | | I_request of Id.t * string * json option 264 | | I_notify of string * json option 265 | | I_response of Id.t * json 266 | 267 | type incoming_full = 268 | | IF_one of incoming 269 | | IF_batch of incoming list 270 | 271 | let parse_id : Id.t P_.t = 272 | let open P_ in 273 | one_of "id" [ 274 | (int >|= fun x -> Id.Int x); 275 | (string >|= fun x -> Id.String x); 276 | (null >|= fun () -> Id.Null); 277 | ] 278 | 279 | let parse_error : (int*string) P_.t = 280 | let open P_ in 281 | field "code" int >>= fun code -> 282 | field "message" string >|= fun msg -> (code,msg) 283 | 284 | let parse_incoming : incoming P_.t = 285 | let open P_ in 286 | field "jsonrpc" string >>= function 287 | | "2.0" -> 288 | one_of "incoming message" [ 289 | (field "error" parse_error >>= fun (c,e) -> 290 | field "id" parse_id >|= fun id -> 291 | I_error (id,c,e)); 292 | (field "result" json >>= fun j -> 293 | field "id" parse_id >|= fun id -> 294 | I_response(id,j)); 295 | (field "method" string >>= fun name -> 296 | field_opt "params" json >>= fun params -> 297 | field_opt "id" parse_id >|= function 298 | | Some id -> I_request (id, name, params) 299 | | None -> I_notify (name, params)) 300 | ] 301 | | _ -> fail "expected field 'jsonrpc' to contain '2.0'" 302 | 303 | let parse_incoming_full : incoming_full P_.t = 304 | let open P_ in 305 | is_list >>= function 306 | | true -> 307 | list parse_incoming >>= fun l -> 308 | if l=[] then fail "batch must be non-empty" 309 | else return (IF_batch l) 310 | | false -> parse_incoming >|= fun x -> IF_one x 311 | 312 | (** Actions to be done next. This includes sending messages out 313 | on the connection, calling a method, or finishing a local request. *) 314 | type action = 315 | | Send of message 316 | | Send_batch of message list 317 | | Start_call of (Id.t * string * json option) 318 | | Notify of string * json option 319 | | Fill_request of (Id.t * (json,int * string) result) 320 | | Error_without_id of int * string 321 | 322 | let acts_of_inc self ~tr (i:incoming) : action = 323 | match i with 324 | | I_notify (s,m) -> Notify (s,m) 325 | | I_request (id,s,m) -> 326 | if Id.Tbl.mem self.to_reply id then ( 327 | Send (error_ self ~id:None code_internal_error "ID already used in a request") 328 | ) else ( 329 | Id.Tbl.add self.to_reply id tr; 330 | (* update count of messages in this batch to answer to *) 331 | (match tr with TR_single -> () | TR_batch r -> r.missing <- r.missing + 1); 332 | Start_call (id,s,m) 333 | ) 334 | | I_response (id,m) -> 335 | if Id.Tbl.mem self.active id then ( 336 | Id.Tbl.remove self.active id; 337 | Fill_request (id,Ok m) 338 | ) else ( 339 | Send (error_ self ~id:None code_internal_error "no request with given ID") 340 | ) 341 | | I_error (Id.Null,code,msg) -> 342 | Error_without_id (code,msg) 343 | | I_error (id,code,msg) -> 344 | if Id.Tbl.mem self.active id then ( 345 | Id.Tbl.remove self.active id; 346 | Fill_request (id, Error (code, msg)) 347 | ) else ( 348 | Send (error_ self ~id:None code_internal_error "no request with given ID") 349 | ) 350 | 351 | let process_msg (self:t) (m:message) : (action list, _) result = 352 | match P_.run parse_incoming_full m with 353 | | Error (lazy e) -> Error (code_invalid_request, e) 354 | | Ok (IF_one m) -> Ok [acts_of_inc ~tr:TR_single self m] 355 | | Ok (IF_batch l) -> 356 | let tr = TR_batch {missing=0; done_=[]} in 357 | Ok (List.map (acts_of_inc ~tr self) l) 358 | 359 | let process_call_reply self id res : _ list = 360 | let msg_of_res = function 361 | | Ok res -> 362 | mk_response id res 363 | | Error e -> 364 | error_ self ~id:(Some id) code_invalid_param e 365 | in 366 | match Id.Tbl.find self.to_reply id with 367 | | exception Not_found -> 368 | invalid_arg (Printf.sprintf "already replied to id %s" (Id.to_string id)) 369 | | TR_single -> 370 | Id.Tbl.remove self.to_reply id; 371 | [Send (msg_of_res res)] 372 | | TR_batch r -> 373 | Id.Tbl.remove self.to_reply id; 374 | r.done_ <- msg_of_res res :: r.done_; 375 | r.missing <- r.missing - 1; 376 | if r.missing = 0 then ( 377 | [Send_batch r.done_] 378 | ) else [] 379 | end 380 | 381 | module Make(IO : Jsonrpc2_intf.IO) 382 | : Jsonrpc2_intf.S with module IO = IO 383 | = struct 384 | module IO = IO 385 | module Id = Protocol.Id 386 | type json = J.t 387 | 388 | type t = { 389 | proto: Protocol.t; 390 | methods: (string, method_) Hashtbl.t; 391 | reponse_promises: 392 | (json, code*string) result IO.Future.promise Id.Tbl.t; (* promises to fullfill *) 393 | ic: IO.in_channel; 394 | oc: IO.out_channel; 395 | send_lock: IO.lock; (* avoid concurrent writes *) 396 | } 397 | 398 | and method_ = 399 | (t -> params:json option -> return:((json, string) result -> unit) -> unit) 400 | (** A method available through JSON-RPC *) 401 | 402 | let create ~ic ~oc () : t = 403 | { ic; oc; reponse_promises=Id.Tbl.create 32; methods=Hashtbl.create 16; 404 | send_lock=IO.create_lock(); proto=Protocol.create(); } 405 | 406 | let declare_method (self:t) name meth : unit = 407 | Hashtbl.replace self.methods name meth 408 | 409 | let declare_method_with self ~decode_arg ~encode_res name f : unit = 410 | declare_method self name 411 | (fun self ~params ~return -> 412 | match params with 413 | | None -> 414 | (* pass [return] as a continuation to {!f} *) 415 | f self ~params:None ~return:(fun y -> return (Ok (encode_res y))) 416 | | Some p -> 417 | match decode_arg p with 418 | | Error e -> return (Error e) 419 | | Ok x -> 420 | (* pass [return] as a continuation to {!f} *) 421 | f self ~params:(Some x) ~return:(fun y -> return (Ok (encode_res y)))) 422 | 423 | let declare_blocking_method_with self ~decode_arg ~encode_res name f : unit = 424 | declare_method self name 425 | (fun _self ~params ~return -> 426 | match params with 427 | | None -> return (Ok (encode_res (f None))) 428 | | Some p -> 429 | match decode_arg p with 430 | | Error e -> return (Error e) 431 | | Ok x -> return (Ok (encode_res (f (Some x))))) 432 | 433 | (** {2 Client side} *) 434 | 435 | exception Jsonrpc2_error of int * string 436 | (** Code + message *) 437 | 438 | type message = json 439 | 440 | let request (self:t) ~meth ~params : message * _ IO.Future.t = 441 | let msg, id = Protocol.request self.proto ~meth ~params in 442 | (* future response, with sender associated to ID *) 443 | let future, promise = 444 | IO.Future.make 445 | ~on_cancel:(fun () -> Id.Tbl.remove self.reponse_promises id) 446 | () 447 | in 448 | Id.Tbl.add self.reponse_promises id promise; 449 | msg, future 450 | 451 | (* Notify the remote server *) 452 | let notify (self:t) ~meth ~params : message = 453 | Protocol.notify self.proto ~meth ~params 454 | 455 | let send_msg_ (self:t) (s:string) : _ IO.t = 456 | IO.with_lock self.send_lock 457 | (fun () -> IO.write_string self.oc s) 458 | 459 | (* send a single message *) 460 | let send (self:t) (m:message) : _ result IO.t = 461 | let json = J.to_string m in 462 | let full_s = 463 | Printf.sprintf "Content-Length: %d\r\n\r\n%s" 464 | (String.length json) json 465 | in 466 | send_msg_ self full_s 467 | 468 | let send_request self ~meth ~params : _ IO.t = 469 | let open IO.Infix in 470 | let msg, res = request self ~meth ~params in 471 | send self msg >>= function 472 | | Error e -> IO.return (Error e) 473 | | Ok () -> 474 | IO.Future.wait res >|= fun r -> 475 | match r with 476 | | Ok x -> Ok x 477 | | Error (code,e) -> Error (Jsonrpc2_error (code,e)) 478 | 479 | let send_notify self ~meth ~params : _ IO.t = 480 | let msg = notify self ~meth ~params in 481 | send self msg 482 | 483 | let send_request_with ~encode_params ~decode_res self ~meth ~params : _ IO.t = 484 | let open IO.Infix in 485 | send_request self ~meth ~params:(opt_map_ encode_params params) 486 | >>= function 487 | | Error _ as e -> IO.return e 488 | | Ok x -> 489 | let r = match decode_res x with 490 | | Ok x -> Ok x 491 | | Error s -> Error (Jsonrpc2_error (code_invalid_request, s)) 492 | in 493 | IO.return r 494 | 495 | let send_notify_with ~encode_params self ~meth ~params : _ IO.t = 496 | send_notify self ~meth ~params:(opt_map_ encode_params params) 497 | 498 | (* send a batch message *) 499 | let send_batch (self:t) (l:message list) : _ result IO.t = 500 | let json = J.to_string (`List l) in 501 | let full_s = 502 | Printf.sprintf "Content-Length: %d\r\n\r\n%s" 503 | (String.length json) json 504 | in 505 | send_msg_ self full_s 506 | 507 | (* bind on IO+result *) 508 | let (>>=?) x f = 509 | let open IO.Infix in 510 | x >>= function 511 | | Error _ as err -> IO.return err 512 | | Ok x -> f x 513 | 514 | (* read a full message *) 515 | let read_msg (self:t) : ((string * string) list * json, exn) result IO.t = 516 | let rec read_headers acc = 517 | IO.read_line self.ic >>=? function 518 | | "\r" -> IO.return (Ok acc) (* last separator *) 519 | | line -> 520 | begin match 521 | if String.get line (String.length line-1) <> '\r' then raise Not_found; 522 | let i = String.index line ':' in 523 | if i<0 || String.get line (i+1) <> ' ' then raise Not_found; 524 | String.sub line 0 i, String.trim (String.sub line (i+1) (String.length line-i-2)) 525 | with 526 | | pair -> read_headers (pair :: acc) 527 | | exception _ -> 528 | IO.return (Error (Jsonrpc2_error (code_parse_error, "invalid header: " ^ line))) 529 | end 530 | in 531 | read_headers [] >>=? fun headers -> 532 | let ok = match List.assoc "Content-Type" headers with 533 | | "utf8" | "utf-8" -> true 534 | | _ -> false 535 | | exception Not_found -> true 536 | in 537 | if ok then ( 538 | match int_of_string (List.assoc "Content-Length" headers) with 539 | | n -> 540 | let buf = Bytes.make n '\000' in 541 | IO.read_exact self.ic buf n >>=? fun () -> 542 | begin match J.from_string (Bytes.unsafe_to_string buf) with 543 | | j -> IO.return @@ Ok (headers, j) 544 | | exception _ -> 545 | IO.return (Error (Jsonrpc2_error (code_parse_error, "cannot decode json"))) 546 | end 547 | | exception _ -> 548 | IO.return @@ Error (Jsonrpc2_error(code_parse_error, "missing Content-Length' header")) 549 | ) else ( 550 | IO.return @@ Error (Jsonrpc2_error(code_invalid_request, "content-type must be 'utf-8'")) 551 | ) 552 | 553 | (* execute actions demanded by the protocole *) 554 | let rec exec_actions (self:t) l : _ result IO.t = 555 | let open IO.Infix in 556 | match l with 557 | | [] -> IO.return (Ok ()) 558 | | a :: tl -> 559 | begin match a with 560 | | Protocol.Send msg -> send self msg 561 | | Protocol.Send_batch l -> send_batch self l 562 | | Protocol.Start_call (id, name, params) -> 563 | begin match Hashtbl.find self.methods name with 564 | | m -> 565 | let fut, promise = IO.Future.make () in 566 | m self ~params 567 | ~return:(fun r -> IO.Future.fullfill promise r); 568 | (* now wait for the method's response, and reply to protocol *) 569 | IO.Future.wait fut >>= fun res -> 570 | let acts' = Protocol.process_call_reply self.proto id res in 571 | exec_actions self acts' 572 | | exception Not_found -> 573 | send self 574 | (Protocol.error self.proto code_method_not_found "method not found") 575 | end 576 | | Protocol.Notify (name,params) -> 577 | begin match Hashtbl.find self.methods name with 578 | | m -> 579 | (* execute notification, do not process response *) 580 | m self ~params ~return:(fun _ -> ()); 581 | IO.return (Ok ()) 582 | | exception Not_found -> 583 | send self 584 | (Protocol.error self.proto code_method_not_found "method not found") 585 | end 586 | | Protocol.Fill_request (id, res) -> 587 | begin match Id.Tbl.find self.reponse_promises id with 588 | | promise -> 589 | IO.Future.fullfill promise res; 590 | IO.return (Ok ()) 591 | | exception Not_found -> 592 | send self @@ Protocol.error self.proto code_internal_error "no such request" 593 | end 594 | | Protocol.Error_without_id (code,msg) -> 595 | IO.return (Error (Jsonrpc2_error (code,msg))) 596 | end 597 | >>=? fun () -> 598 | exec_actions self tl 599 | 600 | let run (self:t) : _ IO.t = 601 | let open IO.Infix in 602 | let rec loop() : _ IO.t = 603 | read_msg self >>= function 604 | | Error End_of_file -> 605 | IO.return (Ok ()) (* done! *) 606 | | Error (Jsonrpc2_error (code, msg)) -> 607 | send self (Protocol.error self.proto code msg) >>=? fun () -> loop () 608 | | Error _ as err -> IO.return err (* exit now *) 609 | | Ok (_hd, msg) -> 610 | begin match Protocol.process_msg self.proto msg with 611 | | Ok actions -> 612 | exec_actions self actions 613 | | Error (code,msg) -> 614 | send self (Protocol.error self.proto code msg) 615 | end 616 | >>=? fun () -> loop () 617 | in 618 | loop () 619 | end 620 | -------------------------------------------------------------------------------- /src/jsonrpc2_intf.ml: -------------------------------------------------------------------------------- 1 | 2 | (** {1 Main Interface} *) 3 | 4 | module J = Yojson.Safe 5 | 6 | type 'a printer = Format.formatter -> 'a -> unit 7 | 8 | module type FUTURE = sig 9 | type 'a t 10 | (** Future value *) 11 | 12 | type 'a promise 13 | (** How to fill an existing future with a value *) 14 | 15 | val fullfill : 'a promise -> 'a -> unit 16 | (** Fill a promise with a value. Behavior is not specified if this 17 | is called several times *) 18 | 19 | val cancel : _ t -> unit 20 | (** Cancel a future. Does nothing if the promise is filled already 21 | or if there's no meaningful notion of cancellation. *) 22 | 23 | val make : 24 | ?on_cancel:(unit -> unit) -> 25 | unit -> 26 | 'a t * 'a promise 27 | (** Make a future with the accompanying promise to fullfill it. 28 | @param on_cancel if provided, call this function upon cancellation. *) 29 | 30 | type 'a wait 31 | 32 | val wait : 'a t -> 'a wait 33 | (** Wait for the future to be filled *) 34 | end 35 | 36 | module type IO = sig 37 | type 'a t 38 | 39 | val return : 'a -> 'a t 40 | 41 | module Infix : sig 42 | val (>>=) : 'a t -> ('a -> 'b t) -> 'b t 43 | val (>|=) : 'a t -> ('a -> 'b) -> 'b t 44 | end 45 | include module type of Infix 46 | 47 | module Future : FUTURE with type 'a wait = 'a t 48 | 49 | type lock 50 | 51 | val create_lock : unit -> lock 52 | val with_lock : lock -> (unit -> 'a t) -> 'a t 53 | 54 | type in_channel 55 | type out_channel 56 | 57 | val read_line : in_channel -> (string, exn) result t 58 | (** Read a full line, including the trailing '\n' *) 59 | 60 | val read_exact : in_channel -> bytes -> int -> (unit, exn) result t 61 | (** [read_exact ic buf n] reads exactly [n] bytes into [buf], starting 62 | at index 0. *) 63 | 64 | val write_string : out_channel -> string -> (unit, exn) result t 65 | (** write to the channel. *) 66 | end 67 | 68 | (** {2 Main Interface} *) 69 | 70 | (** Signature for a JSONRPC-2 implementation *) 71 | module type S = sig 72 | module IO : IO 73 | 74 | type json = J.t 75 | 76 | type t 77 | (** A jsonrpc2 connection. *) 78 | 79 | val create : 80 | ic:IO.in_channel -> 81 | oc:IO.out_channel -> 82 | unit -> 83 | t 84 | (** Create a connection from the pair of channels *) 85 | 86 | (** {3 Declare methods available from the other side} *) 87 | 88 | type method_ = 89 | (t -> params:json option -> return:((json, string) result -> unit) -> unit) 90 | 91 | val declare_method : t -> string -> method_ -> unit 92 | (** Add a method that can be called from the other side. 93 | The method, when called, {b must} at some point call its [return] paramter 94 | with a result. *) 95 | 96 | val declare_method_with : 97 | t -> 98 | decode_arg:(json -> ('a, string) result) -> 99 | encode_res:('b -> json) -> 100 | string -> 101 | (t -> params:'a option -> return:('b -> unit) -> unit) -> 102 | unit 103 | (** Sugar around {!declare_method}, with automatic encoding and 104 | decoding of JSON values. *) 105 | 106 | val declare_blocking_method_with : 107 | t -> 108 | decode_arg:(json -> ('a, string) result) -> 109 | encode_res:('b -> json) -> 110 | string -> 111 | ('a option -> 'b) -> 112 | unit 113 | (** Sugar around {!declare_method_with} when the function returns 114 | quickly (no scheduling in the background), with automatic encoding and 115 | decoding of JSON values. 116 | The function is invoked immediately and returns a value that is then 117 | fed to the underlying [return] callback. 118 | *) 119 | 120 | (** {3 Send requests and notifications to the other side} *) 121 | 122 | exception Jsonrpc2_error of int * string 123 | (** Code + message *) 124 | 125 | type message 126 | (** Message sent to the other side *) 127 | 128 | val request : 129 | t -> meth:string -> params:json option -> 130 | message * (json, int * string) result IO.Future.t 131 | (** Create a request message, for which an answer is expected. *) 132 | 133 | val notify : t -> meth:string -> params:json option -> message 134 | (** Create a notification message, ie. no response is expected. *) 135 | 136 | val send : t -> message -> (unit, exn) result IO.t 137 | (** Send the message. *) 138 | 139 | val send_batch : t -> message list -> (unit, exn) result IO.t 140 | (** Send a batch of messages. *) 141 | 142 | val send_request : 143 | t -> meth:string -> params:json option -> 144 | (json, exn) result IO.t 145 | (** Combination of {!send} and {!request} *) 146 | 147 | val send_notify: 148 | t -> meth:string -> params:json option -> 149 | (unit, exn) result IO.t 150 | (** Combination of {!send} and {!notify} *) 151 | 152 | val send_request_with : 153 | encode_params:('a -> json) -> 154 | decode_res:(json -> ('b,string) result) -> 155 | t -> meth:string -> params:'a option -> 156 | ('b, exn) result IO.t 157 | (** Decoders + {!send_request} *) 158 | 159 | val send_notify_with : 160 | encode_params:('a -> json) -> 161 | t -> meth:string -> params:'a option -> 162 | (unit, exn) result IO.t 163 | (** Encoder + {!send_notify} *) 164 | 165 | val run : t -> (unit, exn) result IO.t 166 | (** Listen for incoming messages and responses *) 167 | end 168 | -------------------------------------------------------------------------------- /src/lwt/dune: -------------------------------------------------------------------------------- 1 | 2 | (library 3 | (name jsonrpc2_lwt) 4 | (public_name jsonrpc2-lwt) 5 | (libraries jsonrpc2 lwt lwt.unix)) 6 | -------------------------------------------------------------------------------- /src/lwt/jsonrpc2_lwt.ml: -------------------------------------------------------------------------------- 1 | 2 | module IO_lwt 3 | : Jsonrpc2.IO 4 | with type 'a t = 'a Lwt.t 5 | and type 'a Future.t = 'a Lwt.t 6 | and type 'a Future.promise = 'a Lwt.u 7 | and type in_channel = Lwt_io.input_channel 8 | and type out_channel = Lwt_io.output_channel 9 | = struct 10 | type 'a t = 'a Lwt.t 11 | let return = Lwt.return 12 | module Infix = Lwt.Infix 13 | include Infix 14 | 15 | module Future = struct 16 | type 'a t = 'a Lwt.t 17 | type 'a wait = 'a Lwt.t 18 | type 'a promise = 'a Lwt.u 19 | let fullfill = Lwt.wakeup 20 | let cancel = Lwt.cancel 21 | let make ?on_cancel () : _ t * _ promise = 22 | let fut, promise = Lwt.wait () in 23 | (match on_cancel with Some f -> Lwt.on_cancel fut f | None -> ()); 24 | fut, promise 25 | let wait x = x 26 | end 27 | 28 | type lock = Lwt_mutex.t 29 | let create_lock() : lock = Lwt_mutex.create() 30 | let with_lock = Lwt_mutex.with_lock 31 | 32 | type in_channel = Lwt_io.input_channel 33 | type out_channel = Lwt_io.output_channel 34 | 35 | let read_line ic = 36 | Lwt_io.read_line_opt ic >|= function 37 | | Some x -> Ok x 38 | | None -> Error End_of_file 39 | 40 | let read_exact ic buf n : _ result t = 41 | Lwt.catch 42 | (fun () -> Lwt_io.read_into_exactly ic buf 0 n >|= fun () -> Ok ()) 43 | (fun e -> return (Error e)) 44 | 45 | let write_string oc (s:string) : _ result t = 46 | Lwt.catch 47 | (fun () -> 48 | Lwt_io.write_from_string_exactly oc s 0 (String.length s) >|= fun () -> Ok ()) 49 | (fun e -> return (Error e)) 50 | end 51 | 52 | include Jsonrpc2.Make(IO_lwt) 53 | 54 | -------------------------------------------------------------------------------- /src/sync/dune: -------------------------------------------------------------------------------- 1 | 2 | 3 | (library 4 | (name jsonrpc2_sync) 5 | (public_name jsonrpc2-sync) 6 | (libraries jsonrpc2 unix threads)) 7 | -------------------------------------------------------------------------------- /src/sync/jsonrpc2_sync.ml: -------------------------------------------------------------------------------- 1 | 2 | (** {1 Blocking API for jsonrpc2} *) 3 | 4 | module IO_sync 5 | : Jsonrpc2.IO 6 | with type 'a t = 'a 7 | and type in_channel = in_channel 8 | and type out_channel = out_channel 9 | = struct 10 | type 'a t = 'a 11 | let return x = x 12 | module Infix = struct 13 | let (>|=) x f = f x 14 | let (>>=) x f = f x 15 | end 16 | include Infix 17 | 18 | let with_lock lock f = 19 | Mutex.lock lock; 20 | try 21 | let x = f() in 22 | Mutex.unlock lock; 23 | x 24 | with e -> 25 | Mutex.unlock lock; 26 | raise e 27 | 28 | module Future = struct 29 | type 'a state = 30 | | Waiting 31 | | Cancelled 32 | | Done of 'a 33 | 34 | type 'a t = { 35 | mutable st: 'a state; 36 | mutex: Mutex.t; 37 | cond: Condition.t; 38 | on_cancel: (unit -> unit); 39 | } 40 | type 'a wait = 'a 41 | type 'a promise = 'a t 42 | 43 | let make ?(on_cancel=fun () -> ()) () = 44 | let r = { 45 | st=Waiting; 46 | on_cancel; 47 | mutex=Mutex.create(); 48 | cond=Condition.create(); 49 | } in 50 | r, r 51 | 52 | let cancel p = 53 | let call_f = with_lock p.mutex 54 | (fun () -> 55 | if p.st = Waiting then ( 56 | p.st <- Cancelled; 57 | true 58 | ) else false) in 59 | 60 | if call_f then p.on_cancel () 61 | 62 | let fullfill (p:_ promise) x = 63 | with_lock p.mutex 64 | (fun () -> 65 | if p.st <> Waiting then failwith "promise already fullfilled"; 66 | p.st <- Done x; 67 | Condition.broadcast p.cond) 68 | 69 | let rec wait r = 70 | let x = 71 | with_lock r.mutex 72 | (fun () -> 73 | if r.st = Waiting then Condition.wait r.cond r.mutex; 74 | r.st) 75 | in 76 | match x with 77 | | Done y -> y 78 | | Cancelled -> failwith "cancelled" 79 | | Waiting -> wait r 80 | end 81 | 82 | type lock = Mutex.t 83 | let create_lock = Mutex.create 84 | 85 | type nonrec in_channel = in_channel 86 | type nonrec out_channel = out_channel 87 | 88 | let read_line ic = 89 | try Ok (input_line ic) 90 | with e -> Error e 91 | 92 | let read_exact ic buf n : _ result = 93 | try 94 | let n' = input ic buf 0 n in 95 | if n=n' then Ok () 96 | else ( 97 | let msg = Printf.sprintf "incomplete read: %d bytes when %d expected" n' n in 98 | Error (Failure msg) 99 | ) 100 | 101 | with e -> Error e 102 | 103 | let write_string oc (s:string) : _ result = 104 | try 105 | output_string oc s; 106 | flush oc; 107 | Ok () 108 | with e -> Error e 109 | end 110 | 111 | include Jsonrpc2.Make(IO_sync) 112 | 113 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | 2 | (executables 3 | (names test_server) 4 | (libraries jsonrpc2_sync decoders-yojson threads)) 5 | 6 | (alias 7 | (name runtest) 8 | (action (run ./test_server.exe))) 9 | -------------------------------------------------------------------------------- /tests/test_server.ml: -------------------------------------------------------------------------------- 1 | module J = Decoders_yojson.Safe 2 | module R = Jsonrpc2_sync 3 | 4 | let debug = ref (try ignore (Sys.getenv "DEBUG"); true with _ -> false) 5 | 6 | let get_err = function 7 | | Ok x -> x 8 | | Error e -> 9 | if !debug then Printf.eprintf "got error: %s\n%!" (Printexc.to_string e); 10 | raise e 11 | 12 | module Server = struct 13 | let sum (c:R.t) (l:int list) : (int,_) result = 14 | R.send_request_with 15 | ~encode_params:(fun l -> `List (List.map (fun x->`Int x) l)) 16 | ~decode_res:(function (`Int i) -> Ok i | _ -> Error "expected int") 17 | c ~meth:"sum" ~params:(Some l) 18 | 19 | let set_offset (c:R.t) (x: int option) : (unit,_) result = 20 | R.send_notify_with 21 | ~encode_params:(fun i -> `List [`Int i]) 22 | c ~meth:"set-offset" ~params:x 23 | 24 | let run () = 25 | if !debug then Printf.eprintf "server: start subprocess\n%!"; 26 | let ic, oc = 27 | Unix.open_process 28 | (Printf.sprintf "%s -sub %s" Sys.executable_name (if !debug then "-debug" else "")) in 29 | let c = R.create ~ic ~oc () in 30 | let thread = Thread.create R.run c in 31 | if !debug then Printf.eprintf "server: initialize test\n%!"; 32 | (* first sum *) 33 | let sum1 = sum c [1;2] |> get_err in 34 | if !debug then Printf.eprintf "server: sum1: %d\n%!" sum1; 35 | assert (sum1 = 3); 36 | 37 | (* set offset *) 38 | set_offset c (Some 42) |> get_err; 39 | 40 | (* second sum *) 41 | let sum2 = sum c [1;2] |> get_err in 42 | if !debug then Printf.eprintf "server: sum2: %d\n%!" sum2; 43 | assert (sum2 = 42 +3); 44 | 45 | (* set offset to 0 *) 46 | set_offset c None |> get_err; 47 | 48 | (* third sum *) 49 | let sum3 = sum c [1;2;3] |> get_err in 50 | if !debug then Printf.eprintf "server: sum2: %d\n%!" sum3; 51 | assert (sum3 = 6); 52 | 53 | ignore (Unix.close_process (ic,oc) : Unix.process_status); 54 | Thread.join thread 55 | end 56 | 57 | module Sub = struct 58 | let decode_ dec j = match J.Decode.decode_value dec j with 59 | | Ok x -> Ok x 60 | | Error e -> Error (J.Decode.string_of_error e) 61 | 62 | type state = { 63 | c: R.t; 64 | mutable cur_offset: int; 65 | } 66 | 67 | let declare_meths (self:state) : unit = 68 | R.declare_blocking_method_with self.c 69 | ~decode_arg:(decode_ J.Decode.(list int)) 70 | ~encode_res:J.Encode.(fun x -> int x) 71 | "sum" 72 | (function 73 | | None -> 74 | if !debug then Printf.eprintf "client: sum None (offset %d)\n%!" self.cur_offset; 75 | self.cur_offset 76 | | Some l -> 77 | if !debug then Printf.eprintf "client: sum [%s] (offset %d)\n%!" 78 | (String.concat";" @@ List.map string_of_int l) self.cur_offset; 79 | List.fold_left (+) self.cur_offset l); 80 | R.declare_blocking_method_with self.c 81 | ~decode_arg:(function 82 | | (`List [`Int i]) -> Ok i 83 | | _ -> Error "expected an int") 84 | ~encode_res:(fun b -> `Bool b) 85 | "set-offset" 86 | (function 87 | | None -> 88 | if !debug then Printf.eprintf "client: set-offset None\n%!"; 89 | self.cur_offset <- 0; true 90 | | Some i -> 91 | if !debug then Printf.eprintf "client: set-offset %d\n%!" i; 92 | self.cur_offset <- i; true); 93 | () 94 | 95 | let run () = 96 | let c = R.create ~ic:stdin ~oc:stdout () in 97 | let st = {c; cur_offset=0} in 98 | if !debug then Printf.eprintf "client: declare meths\n%!"; 99 | declare_meths st; 100 | if !debug then Printf.eprintf "client: run\n%!"; 101 | get_err @@ R.run c 102 | end 103 | 104 | let () = 105 | let sub = ref false in 106 | Arg.parse [ 107 | "-debug", Arg.Set debug, " enable debug"; 108 | "-sub", Arg.Set sub, " start in sub mode"; 109 | ] (fun _ -> raise (Arg.Bad "no arg expected")) "test-server"; 110 | if !sub 111 | then Sub.run() 112 | else Server.run() 113 | 114 | --------------------------------------------------------------------------------