Skip to content

Commit

Permalink
http
Browse files Browse the repository at this point in the history
  • Loading branch information
JamesHinshelwood committed Feb 28, 2024
1 parent eadc40e commit 7c200fc
Show file tree
Hide file tree
Showing 6 changed files with 99 additions and 27 deletions.
4 changes: 3 additions & 1 deletion package.json
Original file line number Diff line number Diff line change
Expand Up @@ -48,7 +48,9 @@
"@opam/ppx_deriving_rpc": ">=6.0.0 <10.0.0",
"@opam/secp256k1": ">=0.4.4 <0.5.0",
"@opam/stdint": ">=0.5.1 <0.8.0",
"@opam/yojson": ">=1.7.0 <2.1.0"
"@opam/yojson": ">=1.7.0 <2.1.0",
"@opam/opium": ">=0.20.0 <1.0.0",
"@opam/ezcurl": ">=0.2.4 <0.3.0"
},
"devDependencies": {
"@opam/merlin": "*",
Expand Down
2 changes: 2 additions & 0 deletions scilla.opam
Original file line number Diff line number Diff line change
Expand Up @@ -49,6 +49,8 @@ depends: [
"seq"
"stdint" {>= "0.5.1" & < "0.8~"}
"yojson" {>= "1.7.0" & < "2.1~"}
"opium" {>= "0.20.0" & < "1.0.0"}
"ezcurl" {>= "0.2.4" & < "0.3.0"}
]
build: [
[ "./scripts/build_deps.sh" ]
Expand Down
39 changes: 18 additions & 21 deletions src/eval/StateIPCClient.ml
Original file line number Diff line number Diff line change
Expand Up @@ -55,22 +55,19 @@ let ipcclient_exn_wrapper thunk =
fail0 ~kind:"StateIPCClient: Unexpected error making JSON-RPC call"
?inst:None

let binary_rpc ~socket_addr (call : Rpc.call) : Rpc.response M.t =
let socket =
Core_unix.socket ~domain:Core_unix.PF_UNIX ~kind:Core_unix.SOCK_STREAM
~protocol:0 ()
in
Core_unix.connect socket ~addr:(Core_unix.ADDR_UNIX socket_addr);
let ic = Core_unix.in_channel_of_descr socket in
let oc = Core_unix.out_channel_of_descr socket in
let http_rpc ~socket_addr (call : Rpc.call) : Rpc.response M.t =
let msg_buf = Jsonrpc.string_of_call ~version:Jsonrpc.V2 call in
DebugMessage.plog (Printf.sprintf "Sending: %s\n" msg_buf);
(* Send data to the socket. *)
let _ = send_delimited oc msg_buf in
(* Get response. *)
let response = Caml.input_line ic in
Core_unix.close socket;
DebugMessage.plog (Printf.sprintf "Response: %s\n" response);
print_endline (Printf.sprintf "Sending: %s\n" msg_buf);
let exception Http_error of string in
let response =
match Ezcurl.post ~content:(`String msg_buf) ~params:[] ~url:socket_addr () with
| Ok response -> response
| Error (_, err) -> raise (Http_error (Printf.sprintf "error calling RPC: %s " err))
in

let response = if response.code = 200 then response.body else raise (Http_error "error response from RPC") in

print_endline (Printf.sprintf "Response: %s\n" response);
M.return @@ Jsonrpc.response_of_string response

(* Encode a literal into bytes, opaque to the backend storage. *)
Expand Down Expand Up @@ -168,7 +165,7 @@ let fetch ~socket_addr ~fname ~keys ~tp =
let%bind q' = encode_serialized_query q in
let%bind res =
let thunk () =
translate_res @@ IPCClient.fetch_state_value (binary_rpc ~socket_addr) q'
translate_res @@ IPCClient.fetch_state_value (http_rpc ~socket_addr) q'
in
ipcclient_exn_wrapper thunk
in
Expand Down Expand Up @@ -211,7 +208,7 @@ let external_fetch ~socket_addr ~caddr ~fname ~keys ~ignoreval =
let%bind res =
let thunk () =
translate_res
@@ IPCClient.fetch_ext_state_value (binary_rpc ~socket_addr) caddr q'
@@ IPCClient.fetch_ext_state_value (http_rpc ~socket_addr) caddr q'
in
ipcclient_exn_wrapper thunk
in
Expand Down Expand Up @@ -247,7 +244,7 @@ let update ~socket_addr ~fname ~keys ~value ~tp =
let%bind () =
let thunk () =
translate_res
@@ IPCClient.update_state_value (binary_rpc ~socket_addr) q' value'
@@ IPCClient.update_state_value (http_rpc ~socket_addr) q' value'
in
ipcclient_exn_wrapper thunk
in
Expand All @@ -267,7 +264,7 @@ let is_member ~socket_addr ~fname ~keys ~tp =
let%bind q' = encode_serialized_query q in
let%bind res =
let thunk () =
translate_res @@ IPCClient.fetch_state_value (binary_rpc ~socket_addr) q'
translate_res @@ IPCClient.fetch_state_value (http_rpc ~socket_addr) q'
in
ipcclient_exn_wrapper thunk
in
Expand All @@ -290,7 +287,7 @@ let remove ~socket_addr ~fname ~keys ~tp =
let%bind () =
let thunk () =
translate_res
@@ IPCClient.update_state_value (binary_rpc ~socket_addr) q' dummy_val
@@ IPCClient.update_state_value (http_rpc ~socket_addr) q' dummy_val
in
ipcclient_exn_wrapper thunk
in
Expand All @@ -304,7 +301,7 @@ let fetch_bcinfo ~socket_addr ~query_name ~query_args =
let%bind res =
let thunk () =
translate_res
@@ IPCClient.fetch_bcinfo (binary_rpc ~socket_addr) query_name query_args
@@ IPCClient.fetch_bcinfo (http_rpc ~socket_addr) query_name query_args
in
ipcclient_exn_wrapper thunk
in
Expand Down
2 changes: 1 addition & 1 deletion src/eval/dune
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,7 @@
(wrapped true)
(modes byte native)
(libraries core core_unix.sys_unix angstrom stdint yojson cryptokit
scilla_base rpclib unix rpclib.json rresult ocaml-protoc)
scilla_base rpclib unix rpclib.json rresult ocaml-protoc ezcurl)
(preprocess
(pps ppx_sexp_conv ppx_let bisect_ppx --conditional ppx_deriving_rpc
ppx_deriving.show ppx_compare))
Expand Down
8 changes: 4 additions & 4 deletions src/runners/dune
Original file line number Diff line number Diff line change
@@ -1,14 +1,14 @@
(executables
(names scilla_runner eval_runner type_checker scilla_checker scilla_server
disambiguate_state_json scilla_fmt scilla_merger)
disambiguate_state_json scilla_fmt scilla_merger scilla_server_http)
(public_names scilla-runner eval-runner type-checker scilla-checker
scilla-server disambiguate_state_json scilla-fmt scilla-merger)
scilla-server disambiguate_state_json scilla-fmt scilla-merger scilla-server-http)
(package scilla)
(modules scilla_runner eval_runner type_checker scilla_checker scilla_server
disambiguate_state_json scilla_fmt scilla_merger)
disambiguate_state_json scilla_fmt scilla_merger scilla_server_http)
(libraries core core_unix.command_unix angstrom yojson cryptokit fileutils
scilla_base scilla_eval scilla_server_lib scilla_crypto scilla_format
scilla_merge cmdliner)
scilla_merge cmdliner opium)
(modes byte native)
(preprocess
(pps ppx_sexp_conv ppx_deriving_yojson ppx_let ppx_deriving.show bisect_ppx --conditional)))
71 changes: 71 additions & 0 deletions src/runners/scilla_server_http.ml
Original file line number Diff line number Diff line change
@@ -0,0 +1,71 @@
open Core
open Scilla_eval
open Opium
open Yojson.Safe
open Core
open Scilla_base
open Scilla_server_lib.Api
open IPCUtil
open ErrorUtils

module M = Idl.IdM
module IDL = Idl.Make (M)
module Server = API (IDL.GenServer ())

let mk_handler_no_args callback () =
try IDL.ErrM.return @@ callback ()
with FatalError msg ->
IDL.ErrM.return_err RPCError.{ code = 0; message = msg }

(* Makes a handler that executes the given [callback] with [args] and returns it. **)
let mk_handler callback args =
(* Force the -jsonerrors flag *)
let args = "-jsonerrors" :: args in
try IDL.ErrM.return @@ callback (Some args)
with FatalError msg ->
IDL.ErrM.return_err RPCError.{ code = 0; message = msg }

let server_implementation () =
let runner args =
let output, _ = Runner.run args ~exe_name:"scilla-runner" in
Yojson.Basic.pretty_to_string output
in
let disambiguator args =
Disambiguator.run args ~exe_name:"scilla-disambiguator"
in
let version () =
let major, minor, patch = Syntax.scilla_version in
Printf.sprintf "{ \"scilla_version\": \"%d.%d.%d\" }" major minor patch
in
(* Handlers *)
Server.runner @@ mk_handler runner;
Server.checker @@ mk_handler (Checker.run ~exe_name:"scilla-checker");
Server.disambiguator @@ mk_handler disambiguator;
Server.version @@ mk_handler_no_args version;
Server.implementation

let run_handler req =
let open Lwt.Syntax in
let+ req = Request.to_plain_text req in
let req = Jsonrpc.call_of_string req in

let rpc = IDL.server (server_implementation ()) in
let res =
try M.run (rpc req)
with e ->
print_endline (Exn.to_string e);
Rpc.failure
(RPCError.rpc_of_t
RPCError.
{ code = 0; message = "scilla-server: incorrect invocation" })
in
let str = Jsonrpc.string_of_response ~version:Jsonrpc.V2 res in

Response.of_plain_text str
;;

let _ =
App.empty
|> App.post "/run" run_handler
|> App.run_command
;;

0 comments on commit 7c200fc

Please sign in to comment.