Does Cohttp_mirage.Client support TLS?

Question

Can anyone confirm whether or not Cohttp_mirage.Client supports TLS (https)? The digging I've done seems to indicate that Conduit_mirage does support Client tls, but in Cohttp_mirage, while Server is functor taking a Flow which can be tcp or tls (as gleened from the mirage-www dispatch_tls.ml file).

If it does support TLS, are there any examples of how to set this up (for Mirage)? I couldn't find anything online or in mirage-skeleton. I'm writing a client to to single web-service, so I'm guessing it would only need the one certificate.

If the answer is "no, it does not support TLS," is there any work being done on it? Perhaps I could try digging in to myself. I've been programming for ever 15 years, but I'm still pretty new to OCaml.

Answer 1

I don't understand your question, since you say that mirage-http does support TLS - so where are you stuck? I guess you need to pass a TLS-enabled conduit to connect_uri.

On the server side, the project's web-site (https://mirage.io/) is a unikernel that supports TLS.

Example projects (all servers though, but client should work too):

• https://github.com/samoht/mirage-seal (serve static directory over https)
• https://github.com/talex5/cuekeeper (backend for CueKeeper GTD client, communicating over https with the browser)
• The BTC Piñata runs as both a client and server using TLS: http://ownme.ipredator.se/ (but only acts as a server for HTTP).

Answer 2

As mentioned, the issue is passing a TLS enabled conduit to the final Cohttp client. Here is my mirage "config.ml" file.

open Mirage

let net =
  try match Sys.getenv "NET" with
    | "direct" -> `Direct
    | "socket" -> `Socket
    | _        -> `Direct
  with Not_found -> `Socket

let dhcp =
  try match Sys.getenv "DHCP" with
    | "" -> false
    | _  -> true
  with Not_found -> false

let stack console =
  match net, dhcp with
  | `Direct, true  -> direct_stackv4_with_dhcp console tap0
  | `Direct, false -> direct_stackv4_with_default_ipv4 console tap0
  | `Socket, _     -> socket_stackv4 console [Ipaddr.V4.any]

let main =
  foreign "MyDispatch.Main" (console @-> http @-> resolver @-> conduit @-> job)

let () =
  let sv4 = stack default_console in
  let res_dns = resolver_dns sv4 in
  let conduit = conduit_direct ~tls:true sv4 in
  let http_srv = http_server conduit ind
  register "ident" [
    main $ default_console $ http_srv $ res_dns $ conduit
  ]

Note that I also need DNS for the http client to work. The critical part is the ~tls:true in

let conduit = conduit_direct ~tls:true sv4 in ...

In the dispatch file (MyDispatch.ml, to avoid name conflicts, I have:

open Lwt
open Cohttp
open Printf
open V1_LWT

module Main (C:CONSOLE) (S:Cohttp_lwt.Server) (RES: Resolver_lwt.S) (CON: Conduit_mirage.S) = struct
    module SH = ServiceHandlers.Make (Cohttp_mirage.Client)
    module Wm = SH.Wm

    let routes ctx = [
        ("/v1/ident/initiate", fun () -> new SH.initiate_session ctx );
    ]

    let callback ctx (ch,conn) request body =
        Wm.dispatch' (routes ctx) ~body ~request
    >|= begin function
        | None        -> (`Not_found, Header.init (), `String "Not found", [])
        | Some result -> result
    end
    >>= fun (status, headers, body, path) ->
        let path =
            match Sys.getenv "DEBUG_PATH" with
        | _ -> Printf.sprintf " - %s" (String.concat ", " path)
        | exception Not_found   -> ""
        in
      Printf.eprintf "%d - %s %s%s"
        (Code.code_of_status status)
        (Code.string_of_method (Request.meth request))
        (Uri.path (Request.uri request))
        path;
      S.respond ~headers ~body ~status ()

    let start c http (res_dns) (ctx:CON.t) =
        let ctx = Cohttp_mirage.Client.ctx res_dns ctx in
        let callback = callback ctx in
        let conn_closed (_,conn_id) =
            let cid = Cohttp.Connection.to_string conn_id in
            C.log c (Printf.sprintf "conn %s closed" cid)
            in
    http (`TCP 8080) (S.make ~conn_closed ~callback ())
end

Here the critical part is adding the DNS resover to the (TLS enabled) context and passing that to the callback, so it can eventually be used by the client. ServiceHandlers uses Webmachine and is a functor taking a Cohttp_lwt.Client module (Cohttp_lwt_mirage.Client, in this case). Ultimately, the client uses the TLS/DNS enabled context to make the call (handle_response is application specific code.):

Client.post ~ctx:ctx_with_tls_dns ~headers ~body uri >>= handle_response

"It's easy when you know how (tm)". Note that so far I have only run this with Mirage/unix, not Mirage/xen.