From 4df3992669cc7ac0231bf6335b5e9c67535234e5 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 9 Mar 2016 20:50:37 -0500 Subject: [PATCH 1/7] Convert buildsystem to use ppx We must create a preprocessor using ppx_driver and then applit with the `pp` tag. driver must be used instead of ppx_deriving b/c that's the only way to use ppx_optcomp for now. --- Makefile | 12 ++++++++---- build.sh | 38 ++++++++++++++++++++++++-------------- myocamlbuild.ml | 2 -- opam | 8 +++++--- 4 files changed, 37 insertions(+), 23 deletions(-) diff --git a/Makefile b/Makefile index c865e374..eb71fdd6 100644 --- a/Makefile +++ b/Makefile @@ -2,16 +2,16 @@ PREFIX ?= /usr/local/bin -all: +all: ppx @./build.sh -install: +install: ppx @./build.sh true clean: - rm -rf _build _install + rm -rf _build _install ppx lib/conduit_config.mlh -doc: +doc: ppx @BUILD_DOC=true ./build.sh github: doc @@ -39,3 +39,7 @@ release: pr: opam publish prepare $(NAME).$(VERSION) $(ARCHIVE) OPAMYES=1 opam publish submit $(NAME).$(VERSION) && rm -rf $(NAME).$(VERSION) + +ppx: + ocamlfind ocamlopt -predicates ppx_driver -o ppx -linkpkg \ + -package ppx_sexp_conv ppx_driver_runner.cmxa diff --git a/build.sh b/build.sh index aaa92f85..01c7bbe3 100755 --- a/build.sh +++ b/build.sh @@ -4,20 +4,9 @@ TAGS=principal,annot,bin_annot,short_paths,thread,strict_sequence J_FLAG=2 BASE_PKG="sexplib ipaddr cstruct uri stringext" -SYNTAX_PKG="camlp4.macro pa_sexp_conv" - -# The Async backend is only supported in OCaml 4.01.0+ -OCAML_VERSION=`ocamlc -version` -case $OCAML_VERSION in -4.01.*|4.00.*|3.*) - echo Minimum OCaml version is 4.02 - ;; -*) + HAVE_ASYNC=`ocamlfind query async 2>/dev/null || true` HAVE_ASYNC_SSL=`ocamlfind query async_ssl 2>/dev/null || true` -;; -esac - HAVE_LWT=`ocamlfind query lwt 2>/dev/null || true` HAVE_LWT_SSL=`ocamlfind query lwt.ssl 2>/dev/null || true` HAVE_LWT_TLS=`ocamlfind query tls.lwt 2>/dev/null || true` @@ -35,7 +24,28 @@ add_pkg () { PKG="$PKG $1" } -add_pkg "$SYNTAX_PKG" +CONDUIT_CONFIG="" +mlh_exp() { + if [ "$1" != "" ]; then + CONDUIT_CONFIG="$CONDUIT_CONFIG\n#let $2 = true" + else + CONDUIT_CONFIG="$CONDUIT_CONFIG\n#let $2 = false" + fi +} + +mlh_exp "$HAVE_ASYNC" HAVE_ASYNC +mlh_exp "$HAVE_ASYNC_SSL" HAVE_ASYNC_SSL +mlh_exp "$HAVE_LWT" HAVE_LWT +mlh_exp "$HAVE_LWT_SSL" HAVE_LWT_SSL +mlh_exp "$HAVE_LWT_TLS" HAVE_LWT_TLS +mlh_exp "$HAVE_MIRAGE" HAVE_MIRAGE +mlh_exp "$HAVE_MIRAGE_TLS" HAVE_MIRAGE_TLS +mlh_exp "$HAVE_VCHAN" HAVE_VCHAN +mlh_exp "$HAVE_VCHAN_LWT" HAVE_VCHAN_LWT +mlh_exp "$HAVE_LAUNCHD_LWT" HAVE_LAUNCHD_LWT + +echo $CONDUIT_CONFIG > lib/conduit_config.mlh + add_pkg "$BASE_PKG" add_target "conduit" rm -f lib/*.odocl @@ -48,7 +58,7 @@ rm -f _tags rm -rf _install mkdir -p _install -echo 'true: syntax(camlp4o)' >> _tags +echo 'true: pp(/Users/rgrinberg/reps/ml/ocaml-conduit/ppx)' >> _tags if [ "$HAVE_ASYNC" != "" ]; then echo "Building with Async support." diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 3da2415e..f1472a72 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -2,8 +2,6 @@ open Ocamlbuild_plugin ;; dispatch ( function | After_rules -> - pflag ["ocaml";"compile";] "define" (fun s -> S [A"-ppopt"; A ("-D"^s)]); - pflag ["ocaml";"ocamldep";] "define" (fun s -> S [A"-ppopt"; A ("-D"^s)]); dep ["ocaml"; "doc"] ["lib/intro.html"]; flag ["ocaml"; "doc"] (S[A"-hide-warnings"; A"-short-functors"; A"-sort"; A"-m"; A"A"; A"-intro"; A"lib/intro.html"; A"-t"; A"Conduit URI resolution"]); | _ -> () diff --git a/opam b/opam index 0afc6329..e2d02964 100644 --- a/opam +++ b/opam @@ -14,8 +14,10 @@ remove: ["ocamlfind" "remove" "conduit"] depends: [ "ocamlfind" {build} "ocamlbuild" {build} - "pa_sexp_conv" - "type_conv" + "ppx_driver" {build} + "ppx_optcomp" {build} + "ppx_sexp_conv" {build} + "sexplib" "stringext" "uri" "cstruct" {>="1.0.1"} @@ -42,4 +44,4 @@ conflicts: [ "vchan" {<"2.0.0"} "nocrypto" {<"0.4.0"} ] -available: [ocaml-version >= "4.02.0"] +available: [ocaml-version >= "4.01.0"] From f1860f5081d4d98198bdbf48c783dd0f73680999 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 9 Mar 2016 20:50:58 -0500 Subject: [PATCH 2/7] Convert all camlp4 to ppx --- lib/conduit.ml | 2 +- lib/conduit.mli | 2 +- lib/conduit_async.ml | 46 +++++++++++----------- lib/conduit_async.mli | 21 +++++----- lib/conduit_lwt_unix.ml | 84 ++++++++++++++++++++-------------------- lib/conduit_lwt_unix.mli | 20 +++++----- lib/conduit_mirage.ml | 69 +++++++++++++++++---------------- lib/conduit_mirage.mli | 21 +++++----- lib/conduit_trie.ml | 2 +- lib/conduit_trie.mli | 2 +- lib/conduit_xenstore.ml | 2 +- lib/resolver.ml | 14 +++---- lib/resolver.mli | 6 +-- 13 files changed, 149 insertions(+), 142 deletions(-) diff --git a/lib/conduit.ml b/lib/conduit.ml index 26fc7044..3ccba695 100644 --- a/lib/conduit.ml +++ b/lib/conduit.ml @@ -26,7 +26,7 @@ type endp = [ | `Vchan_domain_socket of string * string | `TLS of string * endp (** wrap in a TLS channel, [hostname,endp] *) | `Unknown of string (** failed resolution *) -] with sexp +] [@@deriving sexp] module type IO = sig type +'a t diff --git a/lib/conduit.mli b/lib/conduit.mli index 7d2c24a3..37456a45 100644 --- a/lib/conduit.mli +++ b/lib/conduit.mli @@ -56,7 +56,7 @@ type endp = [ | `Vchan_domain_socket of string * string (** Vchan Xen domain socket *) | `TLS of string * endp (** Wrap in a TLS channel, [hostname,endp] *) | `Unknown of string (** Failed resolution *) -] with sexp +] [@@deriving sexp] (** Module type for cooperative threading that can be satisfied by Lwt or Async *) diff --git a/lib/conduit_async.ml b/lib/conduit_async.ml index 4c99b1a4..b261601c 100644 --- a/lib/conduit_async.ml +++ b/lib/conduit_async.ml @@ -15,17 +15,19 @@ * *) +#import "conduit_config.mlh" + open Core.Std open Async.Std -exception Ssl_unsupported with sexp +exception Ssl_unsupported [@@deriving sexp] -IFDEF HAVE_ASYNC_SSL THEN +#if HAVE_ASYNC_SSL open Async_ssl.Std -END +#endif module Ssl = struct -IFDEF HAVE_ASYNC_SSL THEN +#if HAVE_ASYNC_SSL type config = { version : Ssl.Version.t option; name : string option; @@ -33,7 +35,7 @@ IFDEF HAVE_ASYNC_SSL THEN ca_path : string option; session : Ssl.Session.t option sexp_opaque; verify : (Ssl.Connection.t -> bool Deferred.t) option; - } with sexp + } [@@deriving sexp] let verify_certificate connection = match Ssl.Connection.peer_certificate connection with @@ -43,15 +45,15 @@ IFDEF HAVE_ASYNC_SSL THEN let configure ?version ?name ?ca_file ?ca_path ?session ?verify () = { version; name; ca_file; ca_path; session; verify} -ELSE - type config = unit with sexp +#else + type config = unit [@@deriving sexp] let verify_certificate _ = raise Ssl_unsupported let configure ?version ?name ?ca_file ?ca_path ?session ?verify () = raise Ssl_unsupported -END +#endif end type +'a io = 'a Deferred.t @@ -63,7 +65,7 @@ type addr = [ | `OpenSSL_with_config of string * Ipaddr.t * int * Ssl.config | `TCP of Ipaddr.t * int | `Unix_domain_socket of string -] with sexp +] [@@deriving sexp] let connect ?interrupt dst = match dst with @@ -72,24 +74,24 @@ let connect ?interrupt dst = >>= fun (_, rd, wr) -> return (rd,wr) end | `OpenSSL (host, ip, port) -> begin -IFDEF HAVE_ASYNC_SSL THEN +#if HAVE_ASYNC_SSL Tcp.connect ?interrupt (Tcp.to_host_and_port (Ipaddr.to_string ip) port) >>= fun (_, rd, wr) -> Conduit_async_ssl.ssl_connect rd wr -ELSE +#else raise Ssl_unsupported -END +#endif end | `OpenSSL_with_config (host, ip, port, config) -> begin -IFDEF HAVE_ASYNC_SSL THEN +#if HAVE_ASYNC_SSL Tcp.connect ?interrupt (Tcp.to_host_and_port (Ipaddr.to_string ip) port) >>= fun (_, rd, wr) -> let open Ssl in match config with | {version; name; ca_file; ca_path; session; verify} -> Conduit_async_ssl.ssl_connect ?version ?name ?ca_file ?ca_path ?session ?verify rd wr -ELSE +#else raise Ssl_unsupported -END +#endif end | `Unix_domain_socket file -> begin Tcp.connect ?interrupt (Tcp.to_file file) @@ -103,23 +105,23 @@ type trust_chain = [ | `Search_file_first_then_path of [ `File of string ] * [ `Path of string ] -] with sexp +] [@@deriving sexp] type openssl = [ | `OpenSSL of [ `Crt_file_path of string ] * [ `Key_file_path of string ] -] with sexp +] [@@deriving sexp] type requires_async_ssl = [ | openssl | `OpenSSL_with_trust_chain of openssl * trust_chain -] with sexp +] [@@deriving sexp] type server = [ | `TCP | requires_async_ssl -] with sexp +] [@@deriving sexp] let serve ?max_connections @@ -128,7 +130,7 @@ let serve match mode with | `TCP -> handle_request sock rd wr | #requires_async_ssl as async_ssl -> -IFDEF HAVE_ASYNC_SSL THEN +#if HAVE_ASYNC_SSL let (crt_file, key_file, ca_file, ca_path) = match async_ssl with | `OpenSSL (`Crt_file_path crt_file, `Key_file_path key_file) -> @@ -146,9 +148,9 @@ IFDEF HAVE_ASYNC_SSL THEN in Conduit_async_ssl.ssl_listen ?ca_file ?ca_path ~crt_file ~key_file rd wr >>= fun (rd,wr) -> handle_request sock rd wr -ELSE +#else raise Ssl_unsupported -END +#endif in Tcp.Server.create ?max_connections ?buffer_age_limit ?on_handler_error diff --git a/lib/conduit_async.mli b/lib/conduit_async.mli index e434671c..7eaa887f 100644 --- a/lib/conduit_async.mli +++ b/lib/conduit_async.mli @@ -17,20 +17,21 @@ (** Connection establishment using the {{:https://github.com/janestreet/async}Async} library *) +#import "conduit_config.mlh" open Core.Std open Async.Std -exception Ssl_unsupported with sexp +exception Ssl_unsupported [@@deriving sexp] -IFDEF HAVE_ASYNC_SSL THEN +#if HAVE_ASYNC_SSL open Async_ssl.Std -END +#endif module Ssl : sig type config -IFDEF HAVE_ASYNC_SSL THEN +#if HAVE_ASYNC_SSL val verify_certificate : Ssl.Connection.t -> bool Deferred.t @@ -44,7 +45,7 @@ IFDEF HAVE_ASYNC_SSL THEN ?verify:(Ssl.Connection.t -> bool Deferred.t) -> unit -> config -ELSE +#else val verify_certificate : 'a -> bool Deferred.t @@ -58,7 +59,7 @@ ELSE ?verify:'f -> unit -> config -END +#endif end type +'a io = 'a Deferred.t @@ -70,7 +71,7 @@ type addr = [ | `OpenSSL_with_config of string * Ipaddr.t * int * Ssl.config | `TCP of Ipaddr.t * int | `Unix_domain_socket of string -] with sexp +] [@@deriving sexp] val connect : ?interrupt:unit io -> addr -> (ic * oc) io @@ -80,20 +81,20 @@ type trust_chain = | `Search_file_first_then_path of [ `File of string ] * [ `Path of string ] - ] with sexp + ] [@@deriving sexp] type openssl = [ `OpenSSL of [ `Crt_file_path of string ] * [ `Key_file_path of string ] - ] with sexp + ] [@@deriving sexp] type server = [ | openssl | `TCP | `OpenSSL_with_trust_chain of (openssl * trust_chain) -] with sexp +] [@@deriving sexp] val serve : ?max_connections:int -> diff --git a/lib/conduit_lwt_unix.ml b/lib/conduit_lwt_unix.ml index 7114f337..37609769 100644 --- a/lib/conduit_lwt_unix.ml +++ b/lib/conduit_lwt_unix.ml @@ -16,6 +16,8 @@ * *) +#import "conduit_config.mlh" + open Lwt open Sexplib.Conv @@ -27,26 +29,26 @@ let () = debug := true with Not_found -> () -type tls_lib = | OpenSSL | Native | No_tls with sexp +type tls_lib = | OpenSSL | Native | No_tls [@@deriving sexp] let tls_library = ref No_tls let () = -IFDEF HAVE_LWT_SSL THEN - IFDEF HAVE_LWT_TLS THEN +#if HAVE_LWT_SSL +#if HAVE_LWT_TLS tls_library := try match Sys.getenv "CONDUIT_TLS" with | "native" | "Native" | "NATIVE" -> Native | _ -> OpenSSL with Not_found -> OpenSSL - ELSE +#else tls_library := OpenSSL - END -ELSE - IFDEF HAVE_LWT_TLS THEN +#endif +#else +#if HAVE_LWT_TLS tls_library := Native - ELSE +#else tls_library := No_tls - END -END +#endif +#endif let () = if !debug then !debug_print "Selected TLS library: %s\n" @@ -60,7 +62,7 @@ type client_tls_config = [ `Hostname of string ] * [ `IP of Ipaddr.t ] * [ `Port of int ] -with sexp +[@@deriving sexp] type client = [ | `TLS of client_tls_config @@ -70,7 +72,7 @@ type client = [ | `Unix_domain_socket of [ `File of string ] | `Vchan_direct of [ `Domid of int ] * [ `Port of string ] | `Vchan_domain_socket of [ `Domain_name of string ] * [ `Port of string ] -] with sexp +] [@@deriving sexp] (** Configuration fragment for a listening TLS server *) type server_tls_config = @@ -78,7 +80,7 @@ type server_tls_config = [ `Key_file_path of string ] * [ `Password of bool -> string | `No_password ] * [ `Port of int ] -with sexp +[@@deriving sexp] (** Set of supported listening mechanisms that are supported by this module. *) type server = [ @@ -90,7 +92,7 @@ type server = [ | `Vchan_direct of int * string | `Vchan_domain_socket of string * string | `Launchd of string -] with sexp +] [@@deriving sexp] type tls_server_key = [ | `None @@ -98,7 +100,7 @@ type tls_server_key = [ [ `Crt_file_path of string ] * [ `Key_file_path of string ] * [ `Password of bool -> string | `No_password ] -] with sexp +] [@@deriving sexp] type ctx = { src: Unix.sockaddr option; @@ -114,7 +116,7 @@ let string_of_unix_sockaddr sa = Printf.sprintf "ADDR_INET(%s,%d)" (string_of_inet_addr ia) port let sexp_of_ctx ctx = - <:sexp_of< string option * tls_server_key >> + [%sexp_of: string option * tls_server_key ] ((match ctx.src with | None -> None | Some sa -> Some (string_of_unix_sockaddr sa)), @@ -124,23 +126,23 @@ type tcp_flow = { fd: Lwt_unix.file_descr sexp_opaque; ip: Ipaddr.t; port: int; -} with sexp +} [@@deriving sexp] type domain_flow = { fd: Lwt_unix.file_descr sexp_opaque; path: string; -} with sexp +} [@@deriving sexp] type vchan_flow = { domid: int; port: string; -} with sexp +} [@@deriving sexp] type flow = | TCP of tcp_flow | Domain_socket of domain_flow | Vchan of vchan_flow -with sexp +[@@deriving sexp] let flow_of_fd fd sa = match sa with @@ -243,26 +245,26 @@ end (** TLS client connection functions *) let connect_with_tls_native ~ctx (`Hostname hostname, `IP ip, `Port port) = -IFDEF HAVE_LWT_TLS THEN +#if HAVE_LWT_TLS let sa = Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ip,port) in Conduit_lwt_tls.Client.connect ?src:ctx.src hostname sa >|= fun (fd, ic, oc) -> let flow = TCP { fd ; ip ; port } in (flow, ic, oc) -ELSE +#else fail (Failure "No TLS support compiled into Conduit") -ENDIF +#endif let connect_with_openssl ~ctx (`Hostname hostname, `IP ip, `Port port) = -IFDEF HAVE_LWT_SSL THEN +#if HAVE_LWT_SSL let sa = Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ip,port) in Conduit_lwt_unix_ssl.Client.connect ?src:ctx.src sa >>= fun (fd, ic, oc) -> let flow = TCP {fd;ip;port} in return (flow, ic, oc) -ELSE +#else fail (Failure "No SSL support compiled into Conduit") -END +#endif let connect_with_default_tls ~ctx tls_client_config = match !tls_library with @@ -272,7 +274,7 @@ let connect_with_default_tls ~ctx tls_client_config = (** VChan connection functions *) let connect_with_vchan_lwt ~ctx (`Domid domid, `Port sport) = -IFDEF HAVE_VCHAN_LWT THEN +#if HAVE_VCHAN_LWT (match Vchan.Port.of_string sport with | `Error s -> fail (Failure ("Invalid vchan port: " ^ s)) | `Ok p -> return p) @@ -280,10 +282,10 @@ IFDEF HAVE_VCHAN_LWT THEN let flow = Vchan { domid; port=sport } in Vchan_lwt_unix.open_client ~domid ~port () >>= fun (ic, oc) -> return (flow, ic, oc) -ELSE +#else let _domid = domid in let _sport = sport in fail (Failure "No Vchan support compiled into Conduit") -END +#endif (** Main connection function *) @@ -316,7 +318,7 @@ let sockaddr_on_tcp_port ctx port = let serve_with_openssl ?timeout ?stop ~ctx ~certfile ~keyfile ~pass ~port callback t = -IFDEF HAVE_LWT_SSL THEN +#if HAVE_LWT_SSL let sockaddr, ip = sockaddr_on_tcp_port ctx port in let password = match pass with @@ -327,13 +329,13 @@ IFDEF HAVE_LWT_SSL THEN ?password ~certfile ~keyfile ?timeout ?stop sockaddr (fun fd ic oc -> callback (TCP {fd;ip;port}) ic oc) >>= fun () -> t -ELSE +#else fail (Failure "No SSL support compiled into Conduit") -END +#endif let serve_with_tls_native ?timeout ?stop ~ctx ~certfile ~keyfile ~pass ~port callback t = -IFDEF HAVE_LWT_TLS THEN +#if HAVE_LWT_TLS let sockaddr, ip = sockaddr_on_tcp_port ctx port in (match pass with | `No_password -> return () @@ -343,9 +345,9 @@ IFDEF HAVE_LWT_TLS THEN ~certfile ~keyfile ?timeout ?stop sockaddr (fun fd ic oc -> callback (TCP {fd;ip;port}) ic oc) >>= fun () -> t -ELSE +#else fail (Failure "No TLS support compiled into Conduit") -END +#endif let serve_with_default_tls ?timeout ?stop ~ctx ~certfile ~keyfile ~pass ~port callback t = @@ -380,20 +382,20 @@ let serve ?timeout ?stop ~(ctx:ctx) ~(mode:server) callback = serve_with_tls_native ?timeout ?stop ~ctx ~certfile ~keyfile ~pass ~port callback t |`Vchan_direct (domid, sport) -> -IFDEF HAVE_VCHAN_LWT THEN +#if HAVE_VCHAN_LWT begin match Vchan.Port.of_string sport with | `Error s -> fail (Failure ("Invalid vchan port: " ^ s)) | `Ok p -> return p end >>= fun port -> Vchan_lwt_unix.open_server ~domid ~port () >>= fun (ic, oc) -> callback (Vchan {domid; port=sport}) ic oc -ELSE +#else fail (Failure "No Vchan support compiled into Conduit") -END +#endif | `Vchan_domain_socket uuid -> fail (Failure "Vchan_domain_socket not implemented") | `Launchd name -> -IFDEF HAVE_LAUNCHD_LWT THEN +#if HAVE_LAUNCHD_LWT Lwt_launchd.activate_socket name >>= fun sockets -> begin match (Launchd.error_to_msg sockets) with @@ -405,9 +407,9 @@ IFDEF HAVE_LAUNCHD_LWT THEN | Result.Error (`Msg m) -> fail (Failure m) end >>= fun () -> t -ELSE +#else fail (Failure "No Launchd support compiled into Conduit") -END +#endif let endp_of_flow = function | TCP { ip; port; _ } -> `TCP (ip, port) diff --git a/lib/conduit_lwt_unix.mli b/lib/conduit_lwt_unix.mli index 4853faa8..ef998c6c 100644 --- a/lib/conduit_lwt_unix.mli +++ b/lib/conduit_lwt_unix.mli @@ -28,7 +28,7 @@ type client_tls_config = [ `Hostname of string ] * [ `IP of Ipaddr.t ] * [ `Port of int ] -with sexp +[@@deriving sexp] (** Set of supported client connections that are supported by this module: @@ -61,7 +61,7 @@ type client = [ (** Connect to the remote VM on the [domid], [port] tuple. *) | `Vchan_domain_socket of [ `Domain_name of string ] * [ `Port of string ] (** Use the Vchan name resolution to connect *) -] with sexp +] [@@deriving sexp] (** Configuration fragment for a listening TLS server *) type server_tls_config = @@ -69,7 +69,7 @@ type server_tls_config = [ `Key_file_path of string ] * [ `Password of bool -> string | `No_password ] * [ `Port of int ] -with sexp +[@@deriving sexp] (** Set of supported listening mechanisms that are supported by this module. - [`TLS server_tls_config]: Use OCaml-TLS or OpenSSL (depending on CONDUIT_TLS) to connect @@ -93,7 +93,7 @@ type server = [ | `Vchan_direct of int * string | `Vchan_domain_socket of string * string | `Launchd of string -] with sexp +] [@@deriving sexp] type 'a io = 'a Lwt.t type ic = Lwt_io.input_channel @@ -104,21 +104,21 @@ type tcp_flow = private { fd: Lwt_unix.file_descr sexp_opaque; ip: Ipaddr.t; port: int; -} with sexp_of +} [@@deriving sexp_of] (** [domain_flow] contains the state of a single Unix domain socket connection. *) type domain_flow = private { fd: Lwt_unix.file_descr sexp_opaque; path: string; -} with sexp_of +} [@@deriving sexp_of] (** [vchan_flow] contains the state of a single Vchan shared memory connection. *) type vchan_flow = private { domid: int; port: string; -} with sexp_of +} [@@deriving sexp_of] (** A [flow] contains the state of a single connection, over a specific transport method. *) @@ -126,7 +126,7 @@ type flow = private | TCP of tcp_flow | Domain_socket of domain_flow | Vchan of vchan_flow -with sexp_of +[@@deriving sexp_of] (** Type describing where to locate a PEM key in the filesystem *) type tls_server_key = [ @@ -135,10 +135,10 @@ type tls_server_key = [ [ `Crt_file_path of string ] * [ `Key_file_path of string ] * [ `Password of bool -> string | `No_password ] -] with sexp +] [@@deriving sexp] (** State handler for an active conduit *) -type ctx with sexp_of +type ctx [@@deriving sexp_of] (** {2 Connection and listening} *) diff --git a/lib/conduit_mirage.ml b/lib/conduit_mirage.ml index 29556034..024d1e68 100644 --- a/lib/conduit_mirage.ml +++ b/lib/conduit_mirage.ml @@ -15,6 +15,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. * *) +#import "conduit_config.mlh" open Sexplib.Std open Sexplib.Conv @@ -55,19 +56,19 @@ type callback = Flow.flow -> unit Lwt.t module type Handler = sig (** Runtime handler *) type t - type client with sexp - type server with sexp + type client [@@deriving sexp] + type server [@@deriving sexp] val connect: t -> client -> Flow.flow Lwt.t val listen: t -> server -> callback -> unit Lwt.t end -type tcp_client = [ `TCP of Ipaddr.t * int ] with sexp -type tcp_server = [ `TCP of int ] with sexp +type tcp_client = [ `TCP of Ipaddr.t * int ] [@@deriving sexp] +type tcp_server = [ `TCP of int ] [@@deriving sexp] type 'a stackv4 = (module V1_LWT.STACKV4 with type t = 'a) let stackv4 x = x -IFDEF HAVE_VCHAN THEN +#if HAVE_VCHAN module type VCHAN = Vchan.S.ENDPOINT with type port = Vchan.Port.t module type XS = Xs_client_lwt.S @@ -77,24 +78,24 @@ type vchan_client = [ | `Direct of int * Vchan.Port.t (** domain id, port *) | `Domain_socket of string * Vchan.Port.t (** Vchan Xen domain socket *) ] -] with sexp +] [@@deriving sexp] type vchan_server = [ | `Vchan of [ | `Direct of int * Vchan.Port.t (** domain id, port *) | `Domain_socket (** Vchan Xen domain socket *) ] -] with sexp +] [@@deriving sexp] -ELSE +#else module type VCHAN = sig type t end module type XS = sig end -type vchan_client = [ `Vchan of [`None] ] with sexp -type vchan_server = [ `Vchan of [`None] ] with sexp +type vchan_client = [ `Vchan of [`None] ] [@@deriving sexp] +type vchan_server = [ `Vchan of [`None] ] [@@deriving sexp] -ENDIF +#endif type vchan = (module VCHAN) type xs = (module XS) @@ -102,23 +103,23 @@ type xs = (module XS) let vchan x = x let xs x = x -IFDEF HAVE_MIRAGE_TLS THEN +#if HAVE_MIRAGE_TLS -type 'a tls_client = [ `TLS of Tls.Config.client * 'a ] with sexp -type 'a tls_server = [ `TLS of Tls.Config.server * 'a ] with sexp +type 'a tls_client = [ `TLS of Tls.Config.client * 'a ] [@@deriving sexp] +type 'a tls_server = [ `TLS of Tls.Config.server * 'a ] [@@deriving sexp] -ELSE +#else -type 'a tls_client = [`TLS of [`None] ] with sexp -type 'a tls_server = [`TLS of [`None] ] with sexp +type 'a tls_client = [`TLS of [`None] ] [@@deriving sexp] +type 'a tls_server = [`TLS of [`None] ] [@@deriving sexp] -ENDIF +#endif -type client = [ tcp_client | vchan_client | client tls_client ] with sexp -type server = [ tcp_server | vchan_server | server tls_server ] with sexp +type client = [ tcp_client | vchan_client | client tls_client ] [@@deriving sexp] +type server = [ tcp_server | vchan_server | server tls_server ] [@@deriving sexp] -type tls_client' = client tls_client with sexp -type tls_server' = server tls_server with sexp +type tls_client' = client tls_client [@@deriving sexp] +type tls_server' = server tls_server [@@deriving sexp] type ('c, 's) handler = S: (module Handler with type t = 'a and type client = 'c and type server = 's) @@ -178,8 +179,8 @@ let listen t (s:server) f = match s with module TCP (S: V1_LWT.STACKV4) = struct type t = S.t - type client = tcp_client with sexp - type server = tcp_server with sexp + type client = tcp_client [@@deriving sexp] + type server = tcp_server [@@deriving sexp] let err_tcp e = fail "TCP connection failed: %s" (S.TCPV4.error_message e) let connect t (`TCP (ip, port): client) = @@ -215,7 +216,7 @@ let with_tcp (type t) t (module S: V1_LWT.STACKV4 with type t = t) stack = (* VCHAN *) -IFDEF HAVE_VCHAN THEN +#if HAVE_VCHAN let err_vchan_port = fail "%s: invalid Vchan port" @@ -238,8 +239,8 @@ module Vchan (Xs: Xs_client_lwt.S) (V: VCHAN) = struct module XS = Conduit_xenstore.Make(Xs) type t = XS.t - type client = vchan_client with sexp - type server = vchan_server with sexp + type client = vchan_client [@@deriving sexp] + type server = vchan_server [@@deriving sexp] let register = XS.register @@ -270,19 +271,19 @@ let mk_vchan (type t) (module X: XS) (module V: VCHAN) t = V.register t >|= fun t -> S ((module V), t) -ELSE +#else let mk_vchan _ _ _ = err_vchan_not_supported "register" let vchan_client _ = err_vchan_not_supported "client" let vchan_server _ = err_vchan_not_supported "server" -ENDIF +#endif let with_vchan t x y z = mk_vchan x y z >|= fun x -> { t with vchan = Some x } (* TLS *) -IFDEF HAVE_MIRAGE_TLS THEN +#if HAVE_MIRAGE_TLS let err_eof = fail "%s: End-of-file!" @@ -303,8 +304,8 @@ module TLS = struct type x = t type t = x - type client = tls_client' with sexp - type server = tls_server' with sexp + type client = tls_client' [@@deriving sexp] + type server = tls_server' [@@deriving sexp] let connect (t:t) (`TLS (c, x): client) = connect t x >>= fun flow -> @@ -325,13 +326,13 @@ end let tls t = Lwt.return (S ( (module TLS), t)) -ELSE +#else let tls_client _ _ = err_tls_not_supported "client" let tls_server _ _ = err_tls_not_supported "server" let tls _ = err_tls_not_supported "register" -ENDIF +#endif let with_tls t = tls t >|= fun x -> { t with tls = Some x } diff --git a/lib/conduit_mirage.mli b/lib/conduit_mirage.mli index 4426ad77..76108374 100644 --- a/lib/conduit_mirage.mli +++ b/lib/conduit_mirage.mli @@ -19,6 +19,7 @@ (** Functorial connection establishment interface that is compatible with the Mirage libraries. *) +#import "conduit_config.mlh" module Flow: V1_LWT.FLOW (** Dynamic flows. *) @@ -32,10 +33,10 @@ module type Handler = sig type t (** The type for runtime handlers. *) - type client with sexp + type client [@@deriving sexp] (** The type for client configuration values. *) - type server with sexp + type server [@@deriving sexp] (** The type for server configuration values. *) val connect: t -> client -> Flow.flow Lwt.t @@ -58,7 +59,7 @@ val stackv4: (module V1_LWT.STACKV4 with type t = 'a) -> 'a stackv4 (** {1 VCHAN} *) -IFDEF HAVE_VCHAN THEN +#if HAVE_VCHAN type vchan_client = [ | `Vchan of [ @@ -75,14 +76,14 @@ type vchan_server = [ module type VCHAN = Vchan.S.ENDPOINT with type port = Vchan.Port.t module type XS = Xs_client_lwt.S -ELSE +#else type vchan_client = [`Vchan of [`None]] type vchan_server = [`Vchan of [`None]] module type VCHAN = sig type t end module type XS = sig end -ENDIF +#endif type vchan type xs @@ -92,19 +93,19 @@ val xs: (module XS) -> xs (** {1 TLS} *) -IFDEF HAVE_MIRAGE_TLS THEN +#if HAVE_MIRAGE_TLS type 'a tls_client = [ `TLS of Tls.Config.client * 'a ] type 'a tls_server = [ `TLS of Tls.Config.server * 'a ] -ELSE +#else type 'a tls_client = [`TLS of [`None]] type 'a tls_server = [`TLS of [`None]] -ENDIF +#endif -type client = [ tcp_client | vchan_client | client tls_client ] with sexp +type client = [ tcp_client | vchan_client | client tls_client ] [@@deriving sexp] (** The type for client configuration values. *) -type server = [ tcp_server | vchan_server | server tls_server ] with sexp +type server = [ tcp_server | vchan_server | server tls_server ] [@@deriving sexp] (** The type for server configuration values. *) val client: Conduit.endp -> client Lwt.t diff --git a/lib/conduit_trie.ml b/lib/conduit_trie.ml index 1719f285..969eb9ec 100644 --- a/lib/conduit_trie.ml +++ b/lib/conduit_trie.ml @@ -19,7 +19,7 @@ open Sexplib.Std type 'a t = - | Node of string * 'a option * 'a t list with sexp + | Node of string * 'a option * 'a t list [@@deriving sexp] (* Invariant: the only node with an empty string is the root *) let empty = Node("", None, []) diff --git a/lib/conduit_trie.mli b/lib/conduit_trie.mli index 94737ed9..66e777cc 100644 --- a/lib/conduit_trie.mli +++ b/lib/conduit_trie.mli @@ -19,7 +19,7 @@ (** Radix tree that can do longest-prefix searches on string keys *) (** Radix tree that maps [string] keys to ['a] values *) -type 'a t with sexp +type 'a t [@@deriving sexp] (** An empty tree *) val empty : 'a t diff --git a/lib/conduit_xenstore.ml b/lib/conduit_xenstore.ml index cac520c8..bcd729fb 100644 --- a/lib/conduit_xenstore.ml +++ b/lib/conduit_xenstore.ml @@ -31,7 +31,7 @@ let err_port = fail "%s: invalid port" module Make (Xs: Xs_client_lwt.S) = struct - type t = { xs: Xs.client sexp_opaque; name: string } with sexp_of + type t = { xs: Xs.client sexp_opaque; name: string } [@@deriving sexp_of] let get_my_id xs = Xs.(immediate xs (fun h -> read h "domid")) diff --git a/lib/resolver.ml b/lib/resolver.ml index 8eeb6b53..be52a9ad 100644 --- a/lib/resolver.ml +++ b/lib/resolver.ml @@ -21,7 +21,7 @@ type service = { name: string; port: int; tls: bool -} with sexp +} [@@deriving sexp] (** Module type for a {{!resolution}resolver} that can map URIs to concrete {{!Conduit.endp}endpoints} that stream connections can be @@ -33,11 +33,11 @@ module type S = sig type +'a io (** State handle for a running resolver *) - type t with sexp + type t [@@deriving sexp] (** Abstract type for a service entry, which maps a URI scheme into a protocol handler and TCP port *) - type svc with sexp + type svc [@@deriving sexp] (** A rewrite function resolves a {{!svc}service} and a URI into a concrete endpoint. *) @@ -83,19 +83,19 @@ end module Make(IO:Conduit.IO) = struct open IO - type svc = service with sexp + type svc = service [@@deriving sexp] type 'a io = 'a IO.t (** A rewrite modifies an input URI with more specialization towards a concrete [endp] *) - type rewrite_fn = service -> Uri.t -> Conduit.endp IO.t with sexp - type service_fn = string -> service option IO.t with sexp + type rewrite_fn = service -> Uri.t -> Conduit.endp IO.t [@@deriving sexp] + type service_fn = string -> service option IO.t [@@deriving sexp] type t = { default_lookup : rewrite_fn; mutable domains: rewrite_fn Conduit_trie.t; mutable service: service_fn; - } with sexp + } [@@deriving sexp] let default_lookup _ uri = (* TODO log *) diff --git a/lib/resolver.mli b/lib/resolver.mli index a75b476c..22246162 100644 --- a/lib/resolver.mli +++ b/lib/resolver.mli @@ -25,7 +25,7 @@ type service = { name: string; port: int; tls: bool -} with sexp +} [@@deriving sexp] (** Module type for a {{!resolution}resolver} that can map URIs to concrete {{!endp}endpoints} that stream connections can be @@ -37,11 +37,11 @@ module type S = sig type +'a io (** State handle for a running resolver *) - type t with sexp + type t [@@deriving sexp] (** Abstract type for a service entry, which maps a URI scheme into a protocol handler and TCP port *) - type svc with sexp + type svc [@@deriving sexp] (** A rewrite function resolves a {{!svc}service} and a URI into a concrete endpoint. *) From 5fea906e4b75d1a8d8c2347d5e76f38b89d0c17c Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 9 Mar 2016 20:51:20 -0500 Subject: [PATCH 3/7] Update gitignore --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 3300da70..8b060869 100644 --- a/.gitignore +++ b/.gitignore @@ -18,3 +18,5 @@ _install/ *.native *.byte *.xl +ppx +*.mlh From f6af47cb5dde7bae171b98e4b483179284b0beba Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: Wed, 9 Mar 2016 22:59:09 -0500 Subject: [PATCH 4/7] Properly use ocamlbuild to generate preprocessor --- build.sh | 11 +++++------ lib/conduit_lwt_unix.ml | 2 +- myocamlbuild.ml | 1 + 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/build.sh b/build.sh index 01c7bbe3..01ed8bb9 100755 --- a/build.sh +++ b/build.sh @@ -24,12 +24,11 @@ add_pkg () { PKG="$PKG $1" } -CONDUIT_CONFIG="" mlh_exp() { if [ "$1" != "" ]; then - CONDUIT_CONFIG="$CONDUIT_CONFIG\n#let $2 = true" + echo "#let $2 = true" >> lib/conduit_config.mlh else - CONDUIT_CONFIG="$CONDUIT_CONFIG\n#let $2 = false" + echo "#let $2 = false" >> lib/conduit_config.mlh fi } @@ -44,8 +43,6 @@ mlh_exp "$HAVE_VCHAN" HAVE_VCHAN mlh_exp "$HAVE_VCHAN_LWT" HAVE_VCHAN_LWT mlh_exp "$HAVE_LAUNCHD_LWT" HAVE_LAUNCHD_LWT -echo $CONDUIT_CONFIG > lib/conduit_config.mlh - add_pkg "$BASE_PKG" add_target "conduit" rm -f lib/*.odocl @@ -58,7 +55,9 @@ rm -f _tags rm -rf _install mkdir -p _install -echo 'true: pp(/Users/rgrinberg/reps/ml/ocaml-conduit/ppx)' >> _tags +echo "true: config" >> _tags + +echo "true: pp($(pwd)/ppx)" >> _tags if [ "$HAVE_ASYNC" != "" ]; then echo "Building with Async support." diff --git a/lib/conduit_lwt_unix.ml b/lib/conduit_lwt_unix.ml index 37609769..f1c725e6 100644 --- a/lib/conduit_lwt_unix.ml +++ b/lib/conduit_lwt_unix.ml @@ -16,7 +16,7 @@ * *) -#import "conduit_config.mlh" +#import "lib/conduit_config.mlh" open Lwt open Sexplib.Conv diff --git a/myocamlbuild.ml b/myocamlbuild.ml index f1472a72..ec92d998 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -2,6 +2,7 @@ open Ocamlbuild_plugin ;; dispatch ( function | After_rules -> + dep ["ocaml"; "config"] ["lib/conduit_config.mlh"]; dep ["ocaml"; "doc"] ["lib/intro.html"]; flag ["ocaml"; "doc"] (S[A"-hide-warnings"; A"-short-functors"; A"-sort"; A"-m"; A"A"; A"-intro"; A"lib/intro.html"; A"-t"; A"Conduit URI resolution"]); | _ -> () From 1d88ed2abb239f9d3692aba8943eeab8d5a199bc Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 9 Mar 2016 23:03:21 -0500 Subject: [PATCH 5/7] Undo using full path for #import --- lib/conduit_lwt_unix.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/conduit_lwt_unix.ml b/lib/conduit_lwt_unix.ml index f1c725e6..37609769 100644 --- a/lib/conduit_lwt_unix.ml +++ b/lib/conduit_lwt_unix.ml @@ -16,7 +16,7 @@ * *) -#import "lib/conduit_config.mlh" +#import "conduit_config.mlh" open Lwt open Sexplib.Conv From c17b3c6f9a5d90e70f5260926afa2e448c29659f Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 9 Mar 2016 23:07:11 -0500 Subject: [PATCH 6/7] Remove adding preprocessor files to _tags file --- build.sh | 8 -------- 1 file changed, 8 deletions(-) diff --git a/build.sh b/build.sh index 01ed8bb9..a77605d5 100755 --- a/build.sh +++ b/build.sh @@ -68,7 +68,6 @@ if [ "$HAVE_ASYNC" != "" ]; then if [ "$HAVE_ASYNC_SSL" != "" ]; then echo "Building with Async/SSL support." - echo 'true: define(HAVE_ASYNC_SSL)' >> _tags ASYNC_REQUIRES="$ASYNC_REQUIRES async_ssl" echo Conduit_async_ssl >> lib/conduit-async.mllib fi @@ -89,14 +88,12 @@ if [ "$HAVE_LWT" != "" ]; then if [ "$HAVE_LWT_SSL" != "" ]; then echo "Building with Lwt/SSL support." - echo 'true: define(HAVE_LWT_SSL)' >> _tags LWT_UNIX_REQUIRES="$LWT_UNIX_REQUIRES lwt.ssl" echo Conduit_lwt_unix_ssl >> lib/conduit-lwt-unix.mllib fi if [ "$HAVE_LWT_TLS" != "" ]; then echo "Building with Lwt/TLS support." - echo 'true: define(HAVE_LWT_TLS)' >> _tags LWT_UNIX_REQUIRES="$LWT_UNIX_REQUIRES tls tls.lwt" echo Conduit_lwt_tls >> lib/conduit-lwt-unix.mllib fi @@ -106,20 +103,17 @@ if [ "$HAVE_LWT" != "" ]; then if [ "$HAVE_MIRAGE" != "" ]; then echo "Building with Mirage support." - echo 'true: define(HAVE_MIRAGE)' >> _tags echo Conduit_mirage > lib/conduit-lwt-mirage.mllib echo Resolver_mirage >> lib/conduit-lwt-mirage.mllib MIRAGE_REQUIRES="mirage-types dns.mirage uri.services" if [ "$HAVE_VCHAN" != "" ]; then echo "Building with Mirage Vchan support." - echo 'true: define(HAVE_VCHAN)' >> _tags MIRAGE_REQUIRES="$MIRAGE_REQUIRES vchan" echo Conduit_xenstore >> lib/conduit-lwt-mirage.mllib echo '"scripts/xenstore-conduit-init" {"xenstore-conduit-init"}' > _install/bin fi if [ "$HAVE_MIRAGE_TLS" != "" ]; then echo "Building with Mirage TLS support." - echo 'true: define(HAVE_MIRAGE_TLS)' >> _tags MIRAGE_REQUIRES="$MIRAGE_REQUIRES tls tls.mirage" fi add_target "conduit-lwt-mirage" @@ -130,13 +124,11 @@ fi if [ "$HAVE_VCHAN_LWT" != "" ]; then echo "Building with Vchan Lwt_unix support." - echo 'true: define(HAVE_VCHAN_LWT)' >> _tags VCHAN_LWT_REQUIRES="vchan.lwt" fi if [ "$HAVE_LAUNCHD_LWT" != "" ]; then echo "Building with Launchd Lwt_unix support." - echo 'true: define(HAVE_LAUNCHD_LWT)' >> _tags LAUNCHD_LWT_REQUIRES="launchd.lwt" fi From d4642c34dee869d4adb78f7d129c8dede6934ba5 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sun, 27 Mar 2016 11:01:23 -0400 Subject: [PATCH 7/7] Bump minimum ocaml version Need 4.02.3 for using ppx --- opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/opam b/opam index e2d02964..efeec0de 100644 --- a/opam +++ b/opam @@ -44,4 +44,4 @@ conflicts: [ "vchan" {<"2.0.0"} "nocrypto" {<"0.4.0"} ] -available: [ocaml-version >= "4.01.0"] +available: [ocaml-version >= "4.02.3"]