diff --git a/.travis-ci.sh b/.travis-ci.sh deleted file mode 100755 index 3649e365..00000000 --- a/.travis-ci.sh +++ /dev/null @@ -1,64 +0,0 @@ -OPAM_DEPENDS="sexplib ipaddr cstruct stringext uri vchan" - -case "$OCAML_VERSION,$OPAM_VERSION" in -4.00.1,1.1.0) ppa=avsm/ocaml40+opam11 ;; -4.00.1,1.2.0) ppa=avsm/ocaml40+opam12 ;; -4.01.0,1.1.0) ppa=avsm/ocaml41+opam11 ;; -4.01.0,1.2.0) ppa=avsm/ocaml41+opam12 ;; -4.02.1,1.1.0) ppa=avsm/ocaml42+opam11 ;; -4.02.1,1.2.0) ppa=avsm/ocaml42+opam12 ;; -*) echo Unknown $OCAML_VERSION,$OPAM_VERSION; exit 1 ;; -esac - -echo "yes" | sudo add-apt-repository ppa:$ppa -sudo apt-get update -qq -sudo apt-get install -qq ocaml ocaml-native-compilers camlp4-extra opam time libssl-dev -sudo apt-get install libxen-dev uuid-dev - -export OPAMYES=1 -echo OCaml version -ocaml -version -echo OPAM versions -opam --version -opam --git-version - -opam init -a -opam remote add mirage-dev git://github.com/mirage/mirage-dev -opam update -opam install ${OPAM_DEPENDS} - -eval `opam config env` -make - -opam install lwt -make clean -make -make install - -opam remove lwt -opam install async -make clean -make -make install - -opam install async_ssl -make clean -make -make install - -opam install lwt -make clean -make -make install - -opam install ssl -make clean -make -make install - -opam install dns tcpip mirage-types vchan -make clean -make -make install - -opam install cohttp cowabloga diff --git a/.travis.yml b/.travis.yml index 09b442b6..a689d811 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,12 @@ language: c -script: bash -ex .travis-ci.sh +install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-opam.sh +script: bash -ex .travis-opam.sh env: - - OCAML_VERSION=4.01.0 OPAM_VERSION=1.1.0 - - OCAML_VERSION=4.01.0 OPAM_VERSION=1.2.0 - - OCAML_VERSION=4.02.1 OPAM_VERSION=1.2.0 + - OCAML_VERSION=4.02 + - OCAML_VERSION=4.01 + - OCAML_VERSION=4.02 DEPOPTS=lwt + - OCAML_VERSION=4.02 DEPOPTS=async + - OCAML_VERSION=4.02 DEPOPTS=async_ssl + - OCAML_VERSION=4.02 DEPOPTS=ssl + - OCAML_VERSION=4.02 DEPOPTS="dns tcpip mirage-types vchan" + - OCAML_VERSION=4.02 PACKAGE="conduit" POST_INSTALL_HOOK="opam install cohttp cowabloga" diff --git a/build.sh b/build.sh index 2c0cc777..3b2ad599 100755 --- a/build.sh +++ b/build.sh @@ -21,7 +21,7 @@ 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` -HAVE_MIRAGE=`ocamlfind query mirage-types dns.mirage tcpip 2>/dev/null || true` +HAVE_MIRAGE=`ocamlfind query mirage-types dns.mirage tcpip tls 2>/dev/null || true` HAVE_VCHAN=`ocamlfind query vchan 2>/dev/null || true` HAVE_VCHAN_LWT=`ocamlfind query vchan.lwt xen-evtchn.unix 2>/dev/null || true` HAVE_XEN=`ocamlfind query mirage-xen xenstore_transport 2>/dev/null || true` @@ -105,6 +105,7 @@ if [ "$HAVE_LWT" != "" ]; then echo "Building with Mirage Vchan support." LWT_MIRAGE_REQUIRES="$LWT_MIRAGE_REQUIRES vchan" fi + LWT_MIRAGE_REQUIRES="$LWT_MIRAGE_REQUIRES tls tls.mirage" add_target "conduit-lwt-mirage" cp lib/conduit-lwt-mirage.mllib lib/conduit-lwt-mirage.odocl if [ "$HAVE_XEN" != "" ]; then diff --git a/lib/conduit_async_ssl.ml b/lib/conduit_async_ssl.ml index a7cfee56..b6f94d28 100644 --- a/lib/conduit_async_ssl.ml +++ b/lib/conduit_async_ssl.ml @@ -25,8 +25,8 @@ let ssl_connect net_to_ssl ssl_to_net = let ssl_to_net = Writer.pipe ssl_to_net in let app_to_ssl, app_wr = Pipe.create () in let app_rd, ssl_to_app = Pipe.create () in - don't_wait_for (Ssl.client ~app_to_ssl ~ssl_to_app ~net_to_ssl - ~ssl_to_net ()); + let client = Ssl.client ~app_to_ssl ~ssl_to_app ~net_to_ssl ~ssl_to_net () in + don't_wait_for (client >>= fun _con -> return ()); Reader.of_pipe (Info.of_string "async_conduit_ssl_reader") app_rd >>= fun app_rd -> Writer.of_pipe (Info.of_string "async_conduit_ssl_writer") app_wr @@ -38,14 +38,16 @@ let ssl_listen ~crt_file ~key_file rd wr = let ssl_to_net = Writer.pipe wr in let app_to_ssl, app_wr = Pipe.create () in let app_rd, ssl_to_app = Pipe.create () in - Ssl.server - ~crt_file + let server = Ssl.server + ~crt_file ~key_file ~app_to_ssl ~ssl_to_app ~net_to_ssl ~ssl_to_net - () |> don't_wait_for; + () + in + don't_wait_for (server >>= fun _con -> return ()); Reader.of_pipe (Info.of_string "async_conduit_ssl_reader") app_rd >>= fun app_rd -> Writer.of_pipe (Info.of_string "async_conduit_ssl_writer") app_wr diff --git a/lib/conduit_lwt_tls.ml b/lib/conduit_lwt_tls.ml index f694f16a..158d8e57 100644 --- a/lib/conduit_lwt_tls.ml +++ b/lib/conduit_lwt_tls.ml @@ -59,7 +59,7 @@ module Server = struct let init ?(nconn=20) ~certfile ~keyfile ?(stop = fst (Lwt.wait ())) ?timeout sa callback = X509_lwt.private_of_pems ~cert:certfile ~priv_key:keyfile >>= fun certificate -> - let config = Tls.Config.server ~certificate () in + let config = Tls.Config.server ~certificates:(`Single certificate) () in let s = listen nconn sa in let cont = ref true in async (fun () -> diff --git a/lib/conduit_mirage.ml b/lib/conduit_mirage.ml index 9248f822..a4b78318 100644 --- a/lib/conduit_mirage.ml +++ b/lib/conduit_mirage.ml @@ -28,6 +28,7 @@ type client = [ ] with sexp type server = [ + | `TLS of Tls.Config.server * server | `TCP of [ `Port of int ] | `Vchan_direct of [`Remote_domid of int] * vchan_port | `Vchan_domain_socket of [ `Uuid of string ] * [ `Port of vchan_port ] @@ -39,58 +40,26 @@ module type VCHAN_FLOW = V1_LWT.FLOW with type error := unknown (** All the possible connection types supported *) -module Make_flow(S:V1_LWT.TCPV4)(V:VCHAN_FLOW) = struct +module Dynamic_flow = struct type 'a io = 'a Lwt.t - type error = [ `Refused | `Timeout | `Unknown of string ] - - let error_message = function - | `Refused -> "Refused" - | `Timeout -> "Timeout" - | `Unknown msg -> msg - + type error = unit -> string type buffer = Cstruct.t type flow = - | TCPv4 of S.flow - | Vchan of V.flow - - let of_tcpv4 f = TCPv4 f - let of_vchan f = Vchan f - - let vchan_error t = - t >>= function - | `Error (`Unknown x) -> return (`Error (`Unknown x)) - | `Eof -> return (`Eof) - | `Ok b -> return (`Ok b) - - let stack_error t = - t >>= function - | `Error (`Unknown x) -> return (`Error (`Unknown x)) - | `Error (`Refused) -> return (`Error (`Refused)) - | `Error (`Timeout) -> return (`Error (`Timeout)) - | `Eof -> return (`Eof) - | `Ok b -> return (`Ok b) - - let read flow = - match flow with - | Vchan t -> vchan_error (V.read t) - | TCPv4 t -> stack_error (S.read t) - - let write flow buf = - match flow with - | Vchan t -> vchan_error (V.write t buf) - | TCPv4 t -> stack_error (S.write t buf) - - let writev flow bufv = - match flow with - | Vchan t -> vchan_error (V.writev t bufv) - | TCPv4 t -> stack_error (S.writev t bufv) - - let close flow = - match flow with - | Vchan t -> V.close t - | TCPv4 t -> S.close t + | Flow : (module V1_LWT.FLOW with + type flow = 'a) * 'a -> flow + + let error_message fn = fn () + let wrap_errors (type e) (module F : V1_LWT.FLOW with type error = e) v = + v >>= function + | `Error (err : e) -> return (`Error (fun () -> F.error_message err)) + | `Ok _ | `Eof as other -> return other + + let read (Flow ((module F), flow)) = wrap_errors (module F) (F.read flow) + let write (Flow ((module F), flow)) b = wrap_errors (module F) (F.write flow b) + let writev (Flow ((module F), flow)) b = wrap_errors (module F) (F.writev flow b) + let close (Flow ((module F), flow)) = F.close flow end module type ENDPOINT = sig @@ -140,9 +109,28 @@ module type VCHAN_PEER = PEER with type uuid = string and type port = vchan_port -module Make(S:V1_LWT.STACKV4)(V:VCHAN_PEER) = struct +module type TLS = sig + module FLOW : V1_LWT.FLOW (* Underlying (encrypted) flow *) + with type flow = Dynamic_flow.flow + include V1_LWT.FLOW + type tracer + val server_of_flow : + ?trace:tracer -> + Tls.Config.server -> FLOW.flow -> + [> `Ok of flow | `Error of error | `Eof ] Lwt.t +end + +module No_TLS : TLS = struct + module FLOW = Dynamic_flow + include FLOW + type tracer = unit + let server_of_flow ?trace:_ _config _underlying = + return (`Error (fun () -> "No_TLS: TLS support for Conduit is disabled")) +end + +module Make(S:V1_LWT.STACKV4)(V:VCHAN_PEER)(TLS:TLS) = struct - module Flow = Make_flow(S.TCPV4)(V.Endpoint) + module Flow = Dynamic_flow type +'a io = 'a Lwt.t type ic = Flow.flow type oc = Flow.flow @@ -223,7 +211,7 @@ module Make(S:V1_LWT.STACKV4)(V:VCHAN_PEER) = struct V.Endpoint.client ~domid ~port () >>= fun flow -> Printf.printf "Conduit.connect: connected!\n%!"; - let flow = Flow.of_vchan flow in + let flow = Dynamic_flow.Flow ((module V.Endpoint), flow) in return (flow, flow, flow) | `TCP (Ipaddr.V6 _ip, _port), _ -> fail (Failure "No IPv6 support compiled into Conduit") @@ -233,10 +221,10 @@ module Make(S:V1_LWT.STACKV4)(V:VCHAN_PEER) = struct S.TCPV4.create_connection (S.tcpv4 tcp) (ip,port) >>= function | `Error _err -> fail (Failure "connection failed") | `Ok flow -> - let flow = Flow.of_tcpv4 flow in + let flow = Dynamic_flow.Flow ((module S.TCPV4), flow) in return (flow, flow, flow) - let serve ?(timeout=60) ?stop:_ ~ctx ~(mode:server) fn = + let rec serve ?(timeout=60) ?stop ~ctx ~(mode:server) fn = let _ = timeout in let t, _u = Lwt.task () in Lwt.on_cancel t (fun () -> print_endline "Stopping server thread"); @@ -254,7 +242,7 @@ module Make(S:V1_LWT.STACKV4)(V:VCHAN_PEER) = struct | `Vchan_direct (`Remote_domid domid, port) -> V.Endpoint.server ~domid ~port () >>= fun t -> - let f = Flow.of_vchan t in + let f = Dynamic_flow.Flow ((module V.Endpoint), t) in fn f f f | _ -> fail (Failure "TODO") ) conns @@ -264,16 +252,24 @@ module Make(S:V1_LWT.STACKV4)(V:VCHAN_PEER) = struct |`TCP (`Port port), Some stack -> S.listen_tcpv4 stack ~port (fun flow -> - let f = Flow.of_tcpv4 flow in + let f = Dynamic_flow.Flow ((module S.TCPV4), flow) in fn f f f ); t |`Vchan_direct (`Remote_domid domid, port), _ -> V.Endpoint.server ~domid ~port () >>= fun t -> - let f = Flow.of_vchan t in + let f = Dynamic_flow.Flow ((module V.Endpoint), t) in fn f f f - + |`TLS (config, underlying), _ -> + serve ~timeout ?stop ~ctx ~mode:underlying (fun f _ _ -> + TLS.server_of_flow config f >>= function + | `Error err -> fail (Failure (TLS.error_message err)) + | `Eof -> fail (Failure "End-of-file from TLS.server_of_flow") + | `Ok underlying -> + let flow = Dynamic_flow.Flow ((module TLS), underlying) in + fn flow flow flow (* XXX: why in triplicate? *) + ) end module type S = sig diff --git a/lib/conduit_mirage.mli b/lib/conduit_mirage.mli index be3768fb..5e09be18 100644 --- a/lib/conduit_mirage.mli +++ b/lib/conduit_mirage.mli @@ -36,6 +36,7 @@ type client = [ (** Configuration for listening on a server port. *) type server = [ + | `TLS of Tls.Config.server * server | `TCP of [ `Port of int ] | `Vchan_direct of [ `Remote_domid of int ] * vchan_port | `Vchan_domain_socket of [ `Uuid of string ] * [ `Port of vchan_port ] @@ -107,6 +108,8 @@ module type PEER = sig end +module Dynamic_flow : V1_LWT.FLOW + module type VCHAN_PEER = PEER with type uuid = string and type port = vchan_port @@ -115,9 +118,19 @@ type unknown = [ `Unknown of string ] module type VCHAN_FLOW = V1_LWT.FLOW with type error := unknown -(** Functor to construct a {!V1_LWT.FLOW} module that internally contains - all of the supported transport mechanisms, such as TCPv4 and Vchan. *) -module Make_flow(S:V1_LWT.TCPV4)(V:VCHAN_FLOW) : V1_LWT.FLOW +module type TLS = sig + module FLOW : V1_LWT.FLOW (* Underlying (encrypted) flow *) + with type flow = Dynamic_flow.flow + include V1_LWT.FLOW + type tracer + val server_of_flow : + ?trace:tracer -> + Tls.Config.server -> FLOW.flow -> + [> `Ok of flow | `Error of error | `Eof ] Lwt.t +end + +module No_TLS : TLS +(** Dummy TLS module which can be used if you don't want TLS support. *) module type S = sig @@ -148,6 +161,6 @@ module type S = sig val endp_to_server: ctx:ctx -> Conduit.endp -> server io end -module Make(S:V1_LWT.STACKV4)(V: VCHAN_PEER) : +module Make(S:V1_LWT.STACKV4)(V: VCHAN_PEER)(T:TLS) : S with type stack = S.t and type peer = V.t diff --git a/opam b/opam index 827f9587..5f439a37 100644 --- a/opam +++ b/opam @@ -1,13 +1,15 @@ -opam-version: "1.1" -maintainer: "anil@recoil.org" -tags: [ - "org:mirage" -] -build: [ - [make] - [make "install"] -] -remove: ["ocamlfind" "remove" "conduit"] +opam-version: "1.2" +maintainer: "anil@recoil.org" +authors: "anil@recoil.org" +homepage: "https://github.com/mirage/ocaml-conduit" +dev-repo: "https://github.com/mirage/ocaml-conduit.git" +bug-reports: "https://github.com/mirage/ocaml-conduit/issues" +tags: "org:mirage" + +build: [make] +install: [make "install"] +remove: ["ocamlfind" "remove" "conduit"] + depends: [ "ocamlfind" "sexplib" {>="109.15.00"}