Merge pull request #1981 from talex5/https-unikernel

Add https example
This commit is contained in:
Justin Cormack 2017-06-16 09:18:59 -07:00 committed by GitHub
commit 88d9fb3211
20 changed files with 616 additions and 0 deletions

View File

@ -0,0 +1,5 @@
_build
rpc
Dockerfile
tls-secrets
www-data

View File

@ -0,0 +1,8 @@
.merlin
_build
proto.ml
proto.mli
lib/schema.ml
lib/schema.mli
www-data
tls-secrets

View File

@ -0,0 +1,23 @@
FROM ocaml/opam@sha256:a469435632d0cacbceab799d7e48201b727d025fa1805cbbe210d94233b251ad
#FROM ocaml/opam:debian-9_ocaml-4.04.0
RUN opam pin add -yn capnp 'https://github.com/talex5/capnp-ocaml.git#demo1'
RUN opam pin add -yn capnp-rpc 'https://github.com/talex5/capnp-rpc.git#demo1'
RUN opam pin add -yn capnp-rpc-lwt 'https://github.com/talex5/capnp-rpc.git#demo1'
RUN opam depext -i -y jbuilder lwt cohttp astring tls capnp camlzip alcotest cohttp
RUN sudo apt-get install -y screen python-pip python-setuptools python-dev --no-install-recommends
RUN pip install cython pycapnp
ADD opam /home/opam/src/opam
RUN opam pin add -ny mypkg /home/opam/src
RUN opam install --deps-only mypkg
ENV JBUILD_STATIC=true
WORKDIR /home/opam/src
ADD . /home/opam/src
RUN sudo chown -R opam .
RUN opam config exec -- make
USER root
RUN cp _build/default/src/main.exe /usr/bin/https-unikernel-single && \
cp _build/default/src/store_main.exe /usr/bin/https-unikernel-store && \
cp _build/default/src/http_main.exe /usr/bin/https-unikernel-http && \
cp _build/default/src/tls_main.exe /usr/bin/https-unikernel-tls
USER opam
ENV SHELL=bash

View File

@ -0,0 +1,31 @@
.PHONY: all docker docker-run clean
all: www-data
jbuilder build --dev src/main.exe src/store_main.exe src/http_main.exe src/tls_main.exe
docker:
docker build -t https-unikernel .
docker-run: tls-secrets/server.crt
docker run --rm -it -v ${PWD}/tls-secrets:/home/opam/src/tls-secrets -p 8443:8443 https-unikernel bash -c 'reset; screen'
clean:
rm -rf _build
tls-secrets/server.key:
@echo Generating server key...
[ -d tls-secrets ] || mkdir -p tls-secrets
openssl genrsa -out $@ 4096
tls-secrets/server.crt: tls-secrets/server.key
@echo ">>> Generating server X.509 certificate."
@echo ">>> Enter the server's full hostname as the 'Common Name' (e.g. demo.mynet)."
@echo ">>> Everything else can be left blank."
@echo
@openssl req -new -x509 -key $< -out $@ -days 10000
www-data:
git init www-data
echo '<p>It works!</p><p>Powered by Irmin.</p>' > www-data/index.html
git -C www-data add index.html
git -C www-data commit --author 'Test <test@example.com>' -m 'Initial state'

View File

@ -0,0 +1,70 @@
## https-unikernel example service
This sample service implements an https web-server as a set of three components communicating using [Cap'n Proto RPC][].
1. The `store` service accepts requests for web pages and returns the page content.
2. The `http` service accepts HTTP connections over RPC and handles GET requests using `store`.
3. The `tls` service accepts encrypted HTTPS connections and provides them as a plain-text stream to `http`.
The protocols implemented by the services can be found in the `proto.capnp` file.
The services can be run in separate processes so that they are isolated from each other.
For example, only the `tls` component needs access to the private key, so
a bug in the HTTP protocol decoder cannot leak the key.
Although the example services are all written in OCaml, it should be possible to replace any of them with a different implementation written in any other language with Cap'n Proto RPC support.
### Running the samples
The easiest way to build and run is using Docker:
make docker
make docker-run
Once inside the container, you can run all the services in a single process like this:
reset
https-unikernel-single
You should be able to try out the service by opening <https://localhost:8443> in a browser.
You can also run the service as three separate processes.
The easiest way to do this is by running `screen`.
First, start the store:
https-unikernel-store /tmp/store.sock
Then, create a new window (`Ctrl-A c`) and start the http service:
https-unikernel-http /tmp/http.sock --store=/tmp/store.sock
Finally, make another window and run the TLS terminator:
https-unikernel-tls --http /tmp/http.sock --port 8443
### Testing with Python
With the services running as separate processes (i.e. with socket files available), you can also invoke services from other languages.
For example, using Python (make another screen split):
```
$ cd src
$ python
>>> import capnp
>>> import proto_capnp
>>> import socket
>>> s = socket.socket(socket.AF_UNIX, socket.SOCK_STREAM, 0)
>>> s.connect('/tmp/store.sock')
>>> client = capnp.TwoPartyClient(s)
>>> store = client.bootstrap().cast_as(proto_capnp.Store)
>>> r = store.get(['index.html'])
>>> print r.wait()
( ok = "<p>It works!</p><p>Powered by Irmin.</p>\n" )
```
(or just do `python test_store.py`)
[Cap'n Proto RPC]: https://capnproto.org/rpc.html

View File

@ -0,0 +1,18 @@
opam-version: "1.2"
name: "https-unikernel"
version: "0.1"
maintainer: "Thomas Leonard <thomas.leonard@docker.com>"
authors: "Thomas Leonard <thomas.leonard@docker.com>"
build: [
[make]
]
depends: [
"lwt"
"cohttp"
"astring"
"tls"
"irmin-unix"
"capnp-rpc-lwt"
"jbuilder" {build}
"ocamlfind" {build}
]

View File

@ -0,0 +1 @@
include Proto.MakeRPC(Capnp.BytesMessage)(Capnp_rpc_lwt)

View File

@ -0,0 +1,77 @@
open Lwt.Infix
open Capnp_rpc_lwt
let connect ~switch path =
Logs.info (fun f -> f "Connecting to %S" path);
let socket = Unix.(socket PF_UNIX SOCK_STREAM 0) in
begin
try Unix.connect socket (Unix.ADDR_UNIX path)
with Unix.Unix_error(Unix.ECONNREFUSED, "connect", "") ->
Logs.err (fun f -> f "Failed to connect to %S" path);
exit 1
end;
let endpoint = Endpoint.of_socket ~switch socket in
let conn = CapTP.of_endpoint ~switch endpoint in
CapTP.bootstrap conn
let rm_socket path =
match Unix.lstat path with
| stat when stat.Unix.st_kind = Unix.S_SOCK -> Unix.unlink path
| _ -> failwith (Fmt.strf "%S exists and is not a socket" path)
| exception Unix.Unix_error(Unix.ENOENT, "lstat", _) -> ()
let listen ~switch ~offer path =
let socket = Unix.(socket PF_UNIX SOCK_STREAM 0) in
Lwt_switch.add_hook (Some switch) (fun () -> Unix.close socket; Lwt.return_unit);
rm_socket path;
Unix.bind socket (Unix.ADDR_UNIX path);
Unix.listen socket 5;
let socket = Lwt_unix.of_unix_file_descr socket in
Logs.info (fun f -> f "Waiting for connections on %S" path);
let rec loop () =
Lwt_unix.accept socket >>= fun (c, _) ->
Logs.info (fun f -> f "Got connection on %S" path);
Lwt_switch.with_switch @@ fun switch -> (* todo: with_child_switch *)
let endpoint = Endpoint.of_socket ~switch (Lwt_unix.unix_file_descr c) in
ignore (CapTP.of_endpoint ~switch ~offer endpoint);
loop () in
loop ()
module Actor = struct
type t = Fmt.style * string
let pp f (style, name) = Fmt.(styled style (const string name)) f ()
let tag = Logs.Tag.def "actor" pp
end
let pp_qid f = function
| None -> ()
| Some x ->
let s = Uint32.to_string x in
Fmt.(styled `Magenta (fun f x -> Fmt.pf f " (qid=%s)" x)) f s
let reporter =
let report src level ~over k msgf =
let src = Logs.Src.name src in
msgf @@ fun ?header ?(tags=Logs.Tag.empty) fmt ->
let actor =
match Logs.Tag.find Actor.tag tags with
| Some x -> x
| None -> `Black, "------"
in
let qid = Logs.Tag.find Capnp_rpc.Debug.qid_tag tags in
let print _ =
Fmt.(pf stderr) "%a@." pp_qid qid;
over ();
k ()
in
Fmt.kpf print Fmt.stderr ("%a %a %a: @[" ^^ fmt ^^ "@]")
Fmt.(styled `Magenta string) (Printf.sprintf "%11s" src)
Logs_fmt.pp_header (level, header)
Actor.pp actor
in
{ Logs.report = report }
let init_logging () =
Fmt_tty.setup_std_outputs ();
Logs.set_reporter reporter;
Logs.set_level (Some Logs.Info)

View File

@ -0,0 +1 @@
let endpoint_tag = Logs.Tag.def "endpoint" Fmt.string

View File

@ -0,0 +1,24 @@
let () = Common.init_logging ()
let main store_socket http_socket =
Lwt_main.run begin
Lwt_switch.with_switch @@ fun switch ->
let store = Common.connect ~switch store_socket in
let http = Http_server.service store in
Common.listen ~switch ~offer:http http_socket
end
open Cmdliner
let store =
let doc = "The database store to use" in
Arg.(required @@ opt (some string) None @@ info ~doc ~docv:"STORE" ["store"])
let http =
let doc = "The http socket to provide" in
Arg.(required @@ pos 0 (some string) None @@ info ~doc ~docv:"HTTP" [])
let cmd =
Term.(const main $ store $ http), Term.info "http"
let () = Term.(exit @@ eval cmd)

View File

@ -0,0 +1,135 @@
let src = Logs.Src.create "web.http" ~doc:"HTTP engine for web server"
module Log = (val Logs.src_log src: Logs.LOG)
open Capnp_rpc_lwt
open Lwt.Infix
open Astring
module Remote_flow = struct
type buffer = Cstruct.t
type flow = Api.Reader.Flow.t Capability.t
type error = [`Capnp of Capnp_rpc.Error.t]
type write_error = [Mirage_flow.write_error | `Capnp of Capnp_rpc.Error.t]
type 'a io = 'a Lwt.t
let create x = x
let read t =
let module R = Api.Reader.Flow.Read_results in
let req = Capability.Request.create_no_args () in
let proxy = new Api.Reader.Flow.client t in
Capability.call_for_value_exn proxy#read req >>= fun resp ->
let p = R.of_payload resp in
let data = R.data_get p in
Lwt.return (Ok (`Data (Cstruct.of_string data)))
let write t data =
let module P = Api.Builder.Flow.Write_params in
let req, p = Capability.Request.create P.init_pointer in
let proxy = new Api.Reader.Flow.client t in
P.data_set p (Cstruct.to_string data);
Capability.call_for_value_exn proxy#write req >>= fun _ ->
Lwt.return (Ok ())
let writev t data =
write t (Cstruct.concat data)
let close _ = failwith "TODO: close"
let pp_error f = function
| `Capnp e -> Capnp_rpc.Error.pp f e
| `Closed -> Fmt.string f "Closed"
let pp_write_error f = function
| `Capnp e -> Capnp_rpc.Error.pp f e
| #Mirage_flow.write_error as e -> Mirage_flow.pp_write_error f e
end
module IO = struct
type 'a t = 'a Lwt.t
let (>>=) = Lwt.bind
let return = Lwt.return
type ic = Lwt_io.input_channel
type oc = Lwt_io.output_channel
type conn = Remote_flow.flow
let read_line ic =
Lwt_io.read_line_opt ic
let read ic count =
let count = min count Sys.max_string_length in
Lwt_io.read ~count ic
let write oc buf =
Lwt_io.write oc buf
let flush oc =
Lwt_io.flush oc
end
module Server = Cohttp_lwt.Make_server(IO)
type t = Api.Reader.Store.t Capability.t
(* Make a Cap'n'Proto call to the store service *)
let get t path =
let module P = Api.Builder.Store.Get_params in
let req, p = Capability.Request.create P.init_pointer in
ignore (P.path_set_list p path);
let proxy = new Api.Reader.Store.client t in
Capability.call_for_value_exn proxy#get req >>= fun resp ->
let open Api.Reader.Store in
match GetResults.get (GetResults.of_payload resp) with
| GetResults.NotFound -> Lwt.return None
| GetResults.Ok data -> Lwt.return (Some data)
| GetResults.Undefined _ -> failwith "Protocol error: bad msg type"
(* Handle HTTP requests *)
let callback t _conn req _body =
let open Cohttp in
let uri = Request.uri req in
Log.info (fun f -> f "HTTP request for %a" Uri.pp_hum uri);
match Request.meth req with
| `GET ->
let path = String.cuts ~empty:false ~sep:"/" (Uri.path uri) in
let path =
match path with
| [] -> ["index.html"]
| p -> p
in
begin get t path >>= function
| Some body -> Server.respond_string ~status:`OK ~body ()
| None -> Server.respond_not_found ~uri ()
end
| m ->
let body = Fmt.strf "Bad method %S" (Code.string_of_method m) in
Server.respond_error ~status:`Bad_request ~body ()
let callback t = Server.callback (Server.make ~callback:(callback t) ())
module Remote_flow_unix = Mirage_flow_unix.Make(Remote_flow)
let handle_connection store c =
Log.info (fun f -> f "Handing new connection");
let flow = Remote_flow.create c in
callback store flow (Remote_flow_unix.ic flow) (Remote_flow_unix.oc flow) >>= fun () ->
Capability.dec_ref c;
Lwt.return_unit
let service store =
Api.Builder.HttpServer.local @@
object (_ : Api.Builder.HttpServer.service)
method accept req =
Log.info (fun f -> f "Handing new connection");
let module P = Api.Reader.HttpServer.Accept_params in
let p = P.of_payload req in
match P.connection_get p with
| None -> Service.fail "No connection!"
| Some i ->
let c = Payload.import req i in
Service.return_lwt (fun () ->
handle_connection store c >|= fun () ->
Ok (Service.Response.create_empty ())
)
end

View File

@ -0,0 +1,25 @@
(* -*- tuareg -*- *)
open Jbuild_plugin.V1
let extra_flags =
match Sys.getenv "JBUILD_STATIC" with
| "true" -> "-cclib -static"
| x -> failwith (Printf.sprintf "JBUILD_STATIC: unknown value %S" x)
| exception Not_found -> ""
let sexp = Printf.sprintf {|
(jbuild_version 1)
(executables (
(names (main store_main http_main tls_main))
(libraries (capnp-rpc-lwt cohttp.lwt irmin-unix cmdliner fmt.tty))
(flags (:standard -w -53-55 %s))
))
(rule
((targets (proto.ml proto.mli))
(deps (proto.capnp))
(action (run capnpc -o ocaml ${<}))))
|} extra_flags
let () =
send sexp

View File

@ -0,0 +1,37 @@
open Lwt.Infix
open Capnp_rpc_lwt
let switch = Lwt_switch.create ()
let socket_pair ~switch =
let client, server = Unix.(socketpair PF_UNIX SOCK_STREAM 0) in
Lwt_switch.add_hook (Some switch) (fun () ->
Unix.close client;
Unix.close server;
Lwt.return ()
);
(Endpoint.of_socket ~switch client, Endpoint.of_socket ~switch server)
let store_to_http, http_to_store = socket_pair ~switch
let http_to_tls, tls_to_http = socket_pair ~switch
let () =
Common.init_logging ();
Lwt_main.run begin
begin
Store.service () >>= fun service ->
let tags = Logs.Tag.add Common.Actor.tag (`Green, "Store ") Logs.Tag.empty in
let _ : CapTP.t = CapTP.of_endpoint ~offer:service ~tags ~switch store_to_http in
Lwt.return ()
end
>>= fun () ->
begin
let tags = Logs.Tag.add Common.Actor.tag (`Red, "HTTP ") Logs.Tag.empty in
let store = CapTP.bootstrap (CapTP.of_endpoint ~tags ~switch http_to_store) in
let service = Http_server.service store in
let _ : CapTP.t = CapTP.of_endpoint ~offer:service ~tags ~switch http_to_tls in
Lwt.return ()
end
>>= fun () ->
Tls_terminator.init ~switch ~to_http:tls_to_http
end

View File

@ -0,0 +1,21 @@
@0xe81d238ec50a0daa;
interface Store {
struct GetResults {
union {
ok @0 :Text;
notFound @1 :Void;
}
}
get @0 (path :List(Text)) -> GetResults;
}
interface Flow {
read @0 () -> (data :Data);
write @1 (data :Data) -> ();
}
interface HttpServer {
accept @0 (connection :Flow) -> ();
}

View File

@ -0,0 +1,33 @@
let src = Logs.Src.create "web.store" ~doc:"Datastore for web server"
module Log = (val Logs.src_log src: Logs.LOG)
module Irmin_store = Irmin_unix.Git.FS.KV(Irmin.Contents.String)
open Lwt.Infix
open Capnp_rpc_lwt
open Astring
(* The Cap'n'Proto service interface we expose. *)
let service () =
let config = Irmin_fs.config "www-data" in
Irmin_store.Repo.v config >>= fun repo ->
Irmin_store.of_branch repo Irmin_store.Branch.master >|= fun db ->
Api.Builder.Store.local @@
object (_ : Api.Builder.Store.service)
method get req =
let module P = Api.Reader.Store.Get_params in
let module R = Api.Builder.Store.GetResults in
let params = P.of_payload req in
let path = P.path_get_list params in
Log.info (fun f -> f "Handing request for %a" (Fmt.Dump.list String.dump) path);
Service.return_lwt (fun () ->
let resp, results = Service.Response.create R.init_pointer in
begin
Irmin_store.find db path >|= function
| Some data -> R.ok_set results data
| None -> R.not_found_set results
end
>>= fun () ->
Lwt.return (Ok resp)
)
end

View File

@ -0,0 +1,21 @@
open Lwt.Infix
let () = Common.init_logging ()
let main store_socket =
Lwt_main.run begin
Lwt_switch.with_switch @@ fun switch ->
Store.service () >>= fun store ->
Common.listen ~switch ~offer:store store_socket
end
open Cmdliner
let store =
let doc = "The database store to serve" in
Arg.(required @@ pos 0 (some string) None @@ info ~doc ~docv:"STORE" [])
let cmd =
Term.(const main $ store), Term.info "store"
let () = Term.(exit @@ eval cmd)

View File

@ -0,0 +1,10 @@
import capnp
import capnp
import proto_capnp
import socket
s = socket.socket(socket.AF_UNIX, socket.SOCK_STREAM, 0)
s.connect('/tmp/store.sock')
client = capnp.TwoPartyClient(s)
store = client.bootstrap().cast_as(proto_capnp.Store)
r = store.get(['index.html'])
print r.wait()

View File

@ -0,0 +1,23 @@
let () = Common.init_logging ()
let main http_socket port =
Lwt_main.run begin
Lwt_switch.with_switch @@ fun switch ->
let http_service = Common.connect ~switch http_socket in
Tls_terminator.run ~http_service ~port
end
open Cmdliner
let http =
let doc = "The HTTP service to use" in
Arg.(required @@ opt (some string) None @@ info ~doc ~docv:"HTTP" ["http"])
let tls =
let doc = "The TLS port on which to listen for incoming connections" in
Arg.(value @@ opt int 8443 @@ info ~doc ~docv:"PORT" ["port"])
let cmd =
Term.(const main $ http $ tls), Term.info "tls"
let () = Term.(exit @@ eval cmd)

View File

@ -0,0 +1,53 @@
open Lwt.Infix
open Capnp_rpc_lwt
let make_flow _flow ic oc =
Api.Builder.Flow.local @@
object (_ : Api.Builder.Flow.service)
method read _ =
Service.return_lwt (fun () ->
Lwt_io.read ~count:4096 ic >|= fun data ->
let module R = Api.Builder.Flow.Read_results in
let resp, results = Service.Response.create R.init_pointer in
R.data_set results data;
Ok resp
)
method write req =
let module R = Api.Reader.Flow.Write_params in
let p = R.of_payload req in
let data = R.data_get p in
Service.return_lwt (fun () ->
Lwt_io.write oc data >>= fun () ->
Lwt.return (Ok (Service.Response.create_empty ()))
)
end
let handle ~http_service flow =
let proxy = new Api.Reader.HttpServer.client http_service in
let module P = Api.Builder.HttpServer.Accept_params in
let req, p = Capability.Request.create P.init_pointer in
P.connection_set p (Some (Capability.Request.export req flow));
Capability.call_for_value proxy#accept req >|= function
| Ok _ -> ()
| Error e -> Logs.warn (fun f -> f "Error from HTTP server: %a" Capnp_rpc.Error.pp e)
let run ~port ~http_service =
let tls_config : Conduit_lwt_unix.server_tls_config =
`Crt_file_path "tls-secrets/server.crt",
`Key_file_path "tls-secrets/server.key",
`No_password,
`Port port
in
let mode = `TLS tls_config in
Logs.info (fun f -> f "Listening on https port %d" port);
Conduit_lwt_unix.(serve ~ctx:default_ctx) ~mode (fun flow ic oc ->
Logs.info (fun f -> f "Got new TLS connection");
let flow_obj = make_flow flow ic oc in
handle ~http_service flow_obj
)
let init ~switch ~to_http =
let tags = Logs.Tag.add Common.Actor.tag (`Blue, "TLS ") Logs.Tag.empty in
let http_service = CapTP.bootstrap (CapTP.of_endpoint ~tags ~switch to_http) in
run ~http_service ~port:8443