mirror of
https://github.com/linuxkit/linuxkit.git
synced 2025-07-24 19:28:09 +00:00
commit
88d9fb3211
@ -0,0 +1,5 @@
|
||||
_build
|
||||
rpc
|
||||
Dockerfile
|
||||
tls-secrets
|
||||
www-data
|
8
projects/miragesdk/examples/https-unikernel/.gitignore
vendored
Normal file
8
projects/miragesdk/examples/https-unikernel/.gitignore
vendored
Normal file
@ -0,0 +1,8 @@
|
||||
.merlin
|
||||
_build
|
||||
proto.ml
|
||||
proto.mli
|
||||
lib/schema.ml
|
||||
lib/schema.mli
|
||||
www-data
|
||||
tls-secrets
|
23
projects/miragesdk/examples/https-unikernel/Dockerfile
Normal file
23
projects/miragesdk/examples/https-unikernel/Dockerfile
Normal 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
|
31
projects/miragesdk/examples/https-unikernel/Makefile
Normal file
31
projects/miragesdk/examples/https-unikernel/Makefile
Normal 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'
|
70
projects/miragesdk/examples/https-unikernel/README.md
Normal file
70
projects/miragesdk/examples/https-unikernel/README.md
Normal 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
|
18
projects/miragesdk/examples/https-unikernel/opam
Normal file
18
projects/miragesdk/examples/https-unikernel/opam
Normal 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}
|
||||
]
|
1
projects/miragesdk/examples/https-unikernel/src/api.ml
Normal file
1
projects/miragesdk/examples/https-unikernel/src/api.ml
Normal file
@ -0,0 +1 @@
|
||||
include Proto.MakeRPC(Capnp.BytesMessage)(Capnp_rpc_lwt)
|
77
projects/miragesdk/examples/https-unikernel/src/common.ml
Normal file
77
projects/miragesdk/examples/https-unikernel/src/common.ml
Normal 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)
|
1
projects/miragesdk/examples/https-unikernel/src/debug.ml
Normal file
1
projects/miragesdk/examples/https-unikernel/src/debug.ml
Normal file
@ -0,0 +1 @@
|
||||
let endpoint_tag = Logs.Tag.def "endpoint" Fmt.string
|
24
projects/miragesdk/examples/https-unikernel/src/http_main.ml
Normal file
24
projects/miragesdk/examples/https-unikernel/src/http_main.ml
Normal 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)
|
135
projects/miragesdk/examples/https-unikernel/src/http_server.ml
Normal file
135
projects/miragesdk/examples/https-unikernel/src/http_server.ml
Normal 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
|
25
projects/miragesdk/examples/https-unikernel/src/jbuild
Normal file
25
projects/miragesdk/examples/https-unikernel/src/jbuild
Normal 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
|
37
projects/miragesdk/examples/https-unikernel/src/main.ml
Normal file
37
projects/miragesdk/examples/https-unikernel/src/main.ml
Normal 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
|
21
projects/miragesdk/examples/https-unikernel/src/proto.capnp
Normal file
21
projects/miragesdk/examples/https-unikernel/src/proto.capnp
Normal 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) -> ();
|
||||
}
|
33
projects/miragesdk/examples/https-unikernel/src/store.ml
Normal file
33
projects/miragesdk/examples/https-unikernel/src/store.ml
Normal 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
|
@ -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)
|
@ -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()
|
23
projects/miragesdk/examples/https-unikernel/src/tls_main.ml
Normal file
23
projects/miragesdk/examples/https-unikernel/src/tls_main.ml
Normal 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)
|
@ -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
|
Loading…
Reference in New Issue
Block a user