如前所述,问题是将启用 TLS 的管道传递给最终的 Cohttp 客户端。这是我的海市蜃楼“config.ml”文件。
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
]
请注意,我还需要 DNS 才能使 http 客户端正常工作。关键部分是~tls:true
在
let conduit = conduit_direct ~tls:true sv4 in ...
在调度文件(MyDispatch.ml,为了避免名称冲突,我有:
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
这里的关键部分是将 DNS 解析器添加到(启用了 TLS 的)上下文并将其传递给回调,因此它最终可以被客户端使用。ServiceHandlers
使用 Webmachine 并且是一个带有Cohttp_lwt.Client
模块的仿函数(Cohttp_lwt_mirage.Client
在本例中为 )。最终,客户端使用启用了 TLS/DNS 的上下文进行调用(handle_response
是特定于应用程序的代码。):
Client.post ~ctx:ctx_with_tls_dns ~headers ~body uri >>= handle_response
“当您知道如何(tm)时,这很容易”。请注意,到目前为止,我只使用 Mirage/unix 运行它,而不是 Mirage/xen。