Merge pull request #21 from avsm/master

Better debugging via CONDUIT_DEBUG, and expose more type representations in Unix

.travis-ci.sh

@@ -1,10 +1,12 @@
 OPAM_DEPENDS="sexplib ipaddr cstruct stringext uri vchan"
 
 case "$OCAML_VERSION,$OPAM_VERSION" in
-4.00.1,1.0.0) ppa=avsm/ocaml40+opam10 ;;
 4.00.1,1.1.0) ppa=avsm/ocaml40+opam11 ;;
-4.01.0,1.0.0) ppa=avsm/ocaml41+opam10 ;;
+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
 

.travis.yml

@@ -2,3 +2,5 @@ language: c
 script: bash -ex .travis-ci.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

CHANGES

@@ -1,9 +1,17 @@
-0.6.0 (trunk):
+0.6.0 (2014-11-04):
 * Add an explicit `ctx` content to track every conduit's runtime state.
 * Allow the source interface for a conduit to be set.
 * Support a `password` callback for the SSL layer (#4).
-* Add a `conn` value to the callback to query more information about the current connection (#2).
 * [lwt] Add stop parameters in main-loop of the server (#5).
+* Add `Conduit_mirage` with Mirage functor suport.
+* Add ocamldoc of most interfaces.
+* Add a `CONDUIT_DEBUG` environment variable to the Unix backends for
+  live debugging.
+* Add a `conn` value to the callback to query more information about the
+  current connection (#2).
+* Expose the representation of `Conduit_lwt_unix.flow` in the external signature.
+  This lets library users obtain the original `Lwt_unix.file_descr` when using
+  Conduit libraries like Cohttp.
 
 0.5.1 (2014-08-07):
 * Reenable Async SSL by default.

README.md

@@ -14,9 +14,20 @@ as well as which library is used (just OpenSSL for now).
 
 Source code is in `lib/`.
 
-* `Conduit_lwt` has the Lwt UNIX modules.
+* `Conduit_lwt_unix` has the Lwt UNIX modules.
 * `Conduit_async` has the Core/Async modules.
 
+There are also resolvers that map URIs to Conduit endpoints.
+See <https://avsm.github.io/ocaml-conduit> for the online `ocamldoc`
+for more details.
+
+### Debugging
+
+Some of the `Lwt_unix`-based modules use a non-empty `CONDUIT_DEBUG`
+environment variable to output debugging information to standard error.
+Just set this variable when running the program to see what URIs
+are being resolved to.
+
 ### Further Informartion
 
 * **WWW:** https://github.com/mirage/ocaml-conduit

lib/conduit_lwt_unix.ml

@@ -258,10 +258,14 @@ let endp_to_client ~ctx (endp:Conduit.endp) =
   match endp with
   | `TCP (_ip, _port) as mode -> return mode
   | `Unix_domain_socket _path as mode -> return mode
-  | `TLS (host, `TCP (ip, port)) -> return (`OpenSSL (host, ip, port))
   | `Vchan_direct _ as mode -> return mode
   | `Vchan_domain_socket _ as mode -> return mode
-  | `TLS (_host, _) -> fail (Failure "TLS to non-TCP currently unsupported")
+  | `TLS (host, (`TCP (ip, port))) -> return (`OpenSSL (host, ip, port))
+  | `TLS (host, endp) -> begin
+       fail (Failure (Printf.sprintf
+         "TLS to non-TCP currently unsupported: host=%s endp=%s"
+         host (Sexplib.Sexp.to_string_hum (Conduit.sexp_of_endp endp))))
+  end
   | `Unknown err -> fail (Failure ("resolution failed: " ^ err))
 
 let endp_to_server ~ctx (endp:Conduit.endp) =

lib/conduit_lwt_unix.mli

@@ -18,6 +18,8 @@
 (** Connection establishment using the
     {{:http://ocsigen.org/lwt/api/Lwt_unix}Lwt_unix} library *) 
 
+open Sexplib.Conv
+
 (** Set of supported client connections that are supported by this module. *)
 type client = [
   | `OpenSSL of string * Ipaddr.t * int (** Use OpenSSL to connect to the given [host], [ip], [port] tuple via TCP *)
@@ -44,8 +46,27 @@ type 'a io = 'a Lwt.t
 type ic = Lwt_io.input_channel
 type oc = Lwt_io.output_channel
 
-(** Type of an established connection *)
-type flow with sexp
+type tcp_flow = private {
+  fd: Lwt_unix.file_descr sexp_opaque;
+  ip: Ipaddr.t;
+  port: int;
+} with sexp_of
+
+type domain_flow = private {
+  fd: Lwt_unix.file_descr sexp_opaque;
+  path: string;
+} with sexp_of
+
+type vchan_flow = private {
+  domid: int;
+  port: string;
+} with sexp_of
+
+type flow = private
+  | TCP of tcp_flow
+  | Domain_socket of domain_flow
+  | Vchan of vchan_flow
+with sexp_of
 
 (** Type describing where to locate an OpenSSL-format
     key in the filesystem *)

lib/intro.html

@@ -2,9 +2,10 @@
 peers that may be running within the same host (e.g. in another virtual
 machine) or on a remote host via TCP.  It consists of:
 
-- The {!Conduit} module with basic type definitions
-- Modules for {{!transport}establishing individual connections}
-- Modules for {{!resolution}name resolvers} that maps URIs to endpoints
+- The {!Conduit} module with basic type definitions for endpoints
+- OS-specific modules for {{!transport}establishing individual connections}
+- The {!Resolver} module for mapping URIs to endpoints
+- OS-specific {{!resolution}name resolvers} that use available resolution mechanisms
 
 {2:transport Connection Establishment} 
 
@@ -24,8 +25,15 @@
 This deals with resolving URIs into a list of {{!Conduit.endp}endp} addresses that can
 then be connected to by the {{!transport}connection establishment} modules.
 
-All of the name resolvers conform to the {!Conduit.RESOLVER} module type.
+All of the name resolvers conform to the {!Resolver.S} module type.
 The OS-specific implementations of this interface are: 
 {!modules: Resolver_lwt Resolver_lwt_unix Resolver_mirage}
 
+{2:resolution Mirage Connections}
+
+On Mirage, the networking stack is configured via the application
+of functors to satisfy various signatures.  Some of the available
+functors are:
+{!modules: Conduit_xenstore Conduit_localhost}
+
 {!indexlist}

lib/resolver_lwt_unix.ml

@@ -17,6 +17,22 @@
 
 open Lwt
 
+let debug = ref false
+let debug_print = ref Printf.eprintf
+let () =
+  try
+    ignore(Sys.getenv "CONDUIT_DEBUG");
+    debug := true
+  with Not_found -> ()
+
+let return_endp name svc uri endp =
+  if !debug then
+    !debug_print "Resolver %s: %s %s -> %s\n%!"
+     name (Uri.to_string uri)
+     (Sexplib.Sexp.to_string_hum (Resolver.sexp_of_service svc))
+     (Sexplib.Sexp.to_string_hum (Conduit.sexp_of_endp endp));
+  return endp
+
 let is_tls_service =
   (* TODO fill in the blanks. nowhere else to get this information *)
   function
@@ -62,17 +78,17 @@ let system_resolver service uri =
   let port = get_port service uri in
   getaddrinfo host (string_of_int port) [AI_SOCKTYPE SOCK_STREAM]
   >>= function
-  | [] -> return (`Unknown ("name resolution failed"))
+  | [] -> return_endp "system" service uri (`Unknown ("name resolution failed"))
   | {ai_addr=ADDR_INET (addr,port);_}::_ ->
-      return (`TCP (Ipaddr_unix.of_inet_addr addr, port))
+      return_endp "system" service uri (`TCP (Ipaddr_unix.of_inet_addr addr, port))
   | {ai_addr=ADDR_UNIX file;_}::_ ->
-      return (`Unix_domain_socket file)
+      return_endp "system" service uri (`Unix_domain_socket file)
 
-let static_resolver hosts _service uri =
+let static_resolver hosts service uri =
   try
-    return (Hashtbl.find hosts (get_host uri))
+    return_endp "static" service uri (Hashtbl.find hosts (get_host uri))
   with Not_found ->
-    return (`Unknown ("name resolution failed"))
+    return_endp "static" service uri (`Unknown ("name resolution failed"))
 
 let system =
   let service = system_service in

lib/resolver_lwt_unix.mli

@@ -17,6 +17,8 @@
 
 (** Resolve URIs to endpoints using Unix system calls *)
 
+(** {2 Prebuilt resolvers} *)
+
 (** Use the Unix system name resolver via [getaddrinfo] and
     [getservbyname] *)
 val system : Resolver_lwt.t
@@ -25,3 +27,32 @@ val system : Resolver_lwt.t
     requests from the static [hosts] hashtable instead of using the
     system resolver. *)
 val static : (string, Conduit.endp) Hashtbl.t -> Resolver_lwt.t
+
+(** {2 Rewrite and service functions}
+    These can be used to assemble your own resolvers if the
+    prebuilt ones are not quite what you need. *)
+
+(** Perform service lookup using [getservbyname] *)
+val system_service : string -> Resolver_lwt.svc option Lwt.t
+
+(** Perform service lookup using the builtin {!Uri_services} module *)
+val static_service : string -> Resolver_lwt.svc option Lwt.t
+
+(** Rewrite function that uses the {!system_service} and {!static_service}
+    to resolve hosts *)
+val system_resolver : Resolver_lwt.rewrite_fn
+
+(** {2 Debugging Hooks} *)
+
+(** If [debug] is true, the builtin resolvers will output their
+    resolution responses via the {!debug_print} function.  The default
+    value of [debug] is true if the [CONDUIT_DEBUG] environment variable
+    is set, and false otherwise. *)
+val debug : bool ref
+
+(** [debug_print] is called by the {!debug} functions to output the
+    results of resolution.  Defaults to {!Printf.eprintf} to go to
+    the standard error. *)
+val debug_print : 
+    ((string -> string -> string -> string -> unit, out_channel, unit)
+     format -> string -> string -> string -> string -> unit) ref