This commit is contained in:
parent
84afc29675
commit
d93b1e37e1
1 changed files with 71 additions and 373 deletions
|
|
@ -6,157 +6,9 @@ module Log = (val Logs.src_log src : Logs.LOG)
|
|||
|
||||
let is_digit = function '0' .. '9' -> true | _ -> false
|
||||
|
||||
let root =
|
||||
{plain|Hello fellows!
|
||||
|
||||
This unikernel is a simple example of a website that supports HTTP/1.1, H2 and
|
||||
the TLS security layer. This is an example of how to make a website with
|
||||
MirageOS.
|
||||
|
||||
The website has several endpoints:
|
||||
- `http{,s}://$hostname/` the page you are about to read.
|
||||
- `http{,s}://$hostname/transmit` a page that copies what is sent (no matter
|
||||
how big it is)
|
||||
- `http{,s}://$hostname/hash` calculates a hash from a random content
|
||||
generated by a seed `x-seed`
|
||||
- `http{,s}://$hostname/random` a page that waits in the request for a size
|
||||
(`x-length`) and generates a random (optionally seeded by `x-seed`) content
|
||||
encoded in base64
|
||||
|
||||
These different endpoints allow performance tests of what MirageOS can offer.
|
||||
Have fun, and hack it!
|
||||
|plain}
|
||||
|
||||
let random_cstruct ~g buf len =
|
||||
for i = 0 to Cstruct.length buf - 1 do
|
||||
let v = Random.State.bits g land 0xff in
|
||||
Cstruct.set_uint8 buf i v
|
||||
done;
|
||||
Cstruct.sub buf 0 len
|
||||
|
||||
let random_state_of_seed str =
|
||||
match Base64.decode str with
|
||||
| Error _ -> None
|
||||
| Ok seed ->
|
||||
let res = Array.make (String.length seed / 2) 0 in
|
||||
for i = 0 to (String.length seed / 2) - 1 do
|
||||
res.(i) <-
|
||||
(Char.code seed.[i * 2] lsl 8) lor Char.code seed.[(i * 2) + 1]
|
||||
done;
|
||||
Some (Random.State.make res)
|
||||
|
||||
let transmit_random ~write_string ~flush ~close_writer
|
||||
?(g = Random.State.make_self_init ()) length body =
|
||||
let tmp = Bytes.create (0x1000 * 4) in
|
||||
let rnd = Cstruct.create 0x1000 in
|
||||
let ctx = Digestif.SHA256.empty in
|
||||
|
||||
let encoder = Base64_rfc2045.encoder `Manual in
|
||||
|
||||
let rec go ctx length cs = function
|
||||
| `Ok when Cstruct.length cs = 0 -> encode ctx length
|
||||
| `Ok ->
|
||||
go ctx length (Cstruct.shift cs 1)
|
||||
(Base64_rfc2045.encode encoder (`Char (Cstruct.get_char cs 0)))
|
||||
| `Partial ->
|
||||
let len = Bytes.length tmp - Base64_rfc2045.dst_rem encoder in
|
||||
write_string body (Bytes.sub_string tmp 0 len);
|
||||
Base64_rfc2045.dst encoder tmp 0 (Bytes.length tmp);
|
||||
let next () = go ctx length cs (Base64_rfc2045.encode encoder `Await) in
|
||||
flush body next
|
||||
and encode ctx = function
|
||||
| 0L -> finalize ctx (Base64_rfc2045.encode encoder `End)
|
||||
| length ->
|
||||
let len = min (Int64.of_int (Cstruct.length rnd)) length in
|
||||
let ({ Cstruct.buffer; off; len= buffer_len } as rnd) =
|
||||
random_cstruct ~g rnd (Int64.to_int len)
|
||||
in
|
||||
Log.debug (fun m ->
|
||||
m "@[<hov>%a@]"
|
||||
(Hxd_string.pp Hxd.default)
|
||||
(Bigstringaf.substring buffer ~off ~len:buffer_len));
|
||||
let ctx =
|
||||
Digestif.SHA256.feed_bigstring ctx ~off ~len:buffer_len buffer
|
||||
in
|
||||
go ctx (Int64.sub length len) rnd `Ok
|
||||
and finalize ctx = function
|
||||
| `Partial ->
|
||||
let len = Bytes.length tmp - Base64_rfc2045.dst_rem encoder in
|
||||
write_string body (Bytes.sub_string tmp 0 len);
|
||||
Base64_rfc2045.dst encoder tmp 0 (Bytes.length tmp);
|
||||
let next () = finalize ctx (Base64_rfc2045.encode encoder `Await) in
|
||||
flush body next
|
||||
| `Ok ->
|
||||
Logs.debug (fun m ->
|
||||
m "%a" Digestif.SHA256.pp (Digestif.SHA256.get ctx));
|
||||
close_writer body
|
||||
in
|
||||
|
||||
Base64_rfc2045.dst encoder tmp 0 (Bytes.length tmp);
|
||||
encode ctx length
|
||||
|
||||
let hash ~version ~create ?seed length =
|
||||
let rec go g rnd ctx = function
|
||||
| 0L ->
|
||||
let headers =
|
||||
[
|
||||
("content-length", string_of_int (Digestif.SHA256.digest_size * 2));
|
||||
("content-type", "text/plain");
|
||||
]
|
||||
in
|
||||
(* XXX(dinosaure): Connection: Close header is only true for http/1.1.
|
||||
For h2, curl complains and abruptely closes the connection. The most
|
||||
important seems Content-Length which closes properly the connection
|
||||
on both sides. *)
|
||||
let headers =
|
||||
match version with
|
||||
| `HTTP_1_1 -> ("connection", "close") :: headers
|
||||
| `HTTP_2_0 -> headers
|
||||
in
|
||||
let response = create headers `OK in
|
||||
(response, Digestif.SHA256.(to_hex (get ctx)))
|
||||
| length ->
|
||||
let len = min (Int64.of_int (Cstruct.length rnd)) length in
|
||||
let { Cstruct.buffer; off; len= buffer_len } =
|
||||
random_cstruct ~g rnd (Int64.to_int len)
|
||||
in
|
||||
Log.debug (fun m ->
|
||||
m "@[<hov>%a@]"
|
||||
(Hxd_string.pp Hxd.default)
|
||||
(Bigstringaf.substring buffer ~off ~len:buffer_len));
|
||||
let ctx =
|
||||
Digestif.SHA256.feed_bigstring ctx ~off ~len:buffer_len buffer
|
||||
in
|
||||
go g rnd ctx (Int64.sub length len)
|
||||
in
|
||||
match
|
||||
( Option.bind seed random_state_of_seed,
|
||||
Option.bind length Int64.of_string_opt )
|
||||
with
|
||||
| Some g, Some length ->
|
||||
go g (Cstruct.create 0x1000) Digestif.SHA256.empty length
|
||||
| _ ->
|
||||
let contents = "Invalid seed." in
|
||||
let headers =
|
||||
[
|
||||
("content-length", string_of_int (String.length contents));
|
||||
("content-type", "text/plain");
|
||||
]
|
||||
in
|
||||
let headers =
|
||||
match version with
|
||||
| `HTTP_1_1 -> ("connection", "close") :: headers
|
||||
| `HTTP_2_0 -> headers
|
||||
in
|
||||
let response = create headers `Bad_request in
|
||||
(response, contents)
|
||||
|
||||
module Cache = Ephemeron.K1.Make (struct
|
||||
type t = string option * string option
|
||||
|
||||
let equal = ( = )
|
||||
let hash = Hashtbl.hash
|
||||
end)
|
||||
let root = {|Hello!
|
||||
This is MTE, the MirageOS Taler Exchange unikernel.
|
||||
|}
|
||||
|
||||
module type S = sig
|
||||
type response
|
||||
|
|
@ -169,37 +21,6 @@ module type S = sig
|
|||
val get : request -> string -> string option
|
||||
end
|
||||
|
||||
let hash_of_seed : type response request.
|
||||
(module S with type response = response and type request = request) ->
|
||||
respond:(response -> string -> unit) ->
|
||||
request ->
|
||||
unit =
|
||||
fun (module S) ->
|
||||
();
|
||||
let tbl = Cache.create 0x100 in
|
||||
fun ~respond request ->
|
||||
let seed = S.get request "x-seed" and length = S.get request "x-length" in
|
||||
|
||||
match
|
||||
(Cache.find_opt tbl (seed, length), S.get request "if-none-match")
|
||||
with
|
||||
| None, _ | Some _, None ->
|
||||
let response, contents =
|
||||
hash ~version:S.version ~create:S.create ?seed length
|
||||
in
|
||||
Cache.add tbl (seed, length) (response, contents);
|
||||
respond response contents
|
||||
| Some (response, contents), Some etags ->
|
||||
let hash = Digestif.SHA256.digest_string contents in
|
||||
let hash = Digestif.SHA256.to_hex hash in
|
||||
|
||||
if List.mem hash (String.split_on_char ',' etags) then
|
||||
let response =
|
||||
S.with_etag hash (S.with_status `Not_modified response)
|
||||
in
|
||||
respond response String.empty
|
||||
else respond response contents
|
||||
|
||||
let transmit_over_http : to_close:_ -> Mimic.flow -> Mimic.flow -> unit Lwt.t =
|
||||
fun ~to_close src dst ->
|
||||
let closed = Lwt_mvar.create_empty () in
|
||||
|
|
@ -272,14 +93,6 @@ module S_HTTP_1_1 = struct
|
|||
| _ -> assert false
|
||||
end
|
||||
|
||||
let transmit src dst =
|
||||
let rec on_eof () = H1.Body.Reader.close src; H1.Body.Writer.close dst
|
||||
and on_read buf ~off ~len =
|
||||
H1.Body.Writer.write_bigstring dst ~off ~len buf;
|
||||
H1.Body.Reader.schedule_read src ~on_eof ~on_read
|
||||
in
|
||||
H1.Body.Reader.schedule_read src ~on_eof ~on_read
|
||||
|
||||
let connect_http_1_1 ~ctx ~authenticator ~to_close flow reqd =
|
||||
let request = H1.Reqd.request reqd in
|
||||
match H1.Headers.get request.H1.Request.headers "host" with
|
||||
|
|
@ -328,101 +141,39 @@ let connect_http_1_1 ~ctx ~authenticator ~to_close flow reqd =
|
|||
H1.Reqd.respond_with_string reqd response contents
|
||||
|
||||
let http_1_1_request_handler ~ctx ~authenticator ~to_close =
|
||||
let hash_of_seed = hash_of_seed (module S_HTTP_1_1) in
|
||||
fun flow reqd ->
|
||||
let request = H1.Reqd.request reqd in
|
||||
Log.debug (fun m ->
|
||||
m "(HTTP/1.1) request-handler: %S" request.H1.Request.target);
|
||||
match request.H1.Request.meth with
|
||||
| `CONNECT ->
|
||||
Log.debug (fun m -> m "Start to transmit data over HTTP/1.1.");
|
||||
connect_http_1_1 ~ctx ~authenticator ~to_close flow reqd
|
||||
| _meth -> (
|
||||
match String.split_on_char '/' request.H1.Request.target with
|
||||
| [ ""; "" ] ->
|
||||
let headers =
|
||||
H1.Headers.of_list
|
||||
[
|
||||
("content-length", string_of_int (String.length root));
|
||||
("connection", "close"); ("content-type", "text/plain");
|
||||
]
|
||||
in
|
||||
let response = H1.Response.create ~reason:"root" ~headers `OK in
|
||||
H1.Reqd.respond_with_string reqd response root
|
||||
| [ ""; "transmit" ] ->
|
||||
let content_type =
|
||||
H1.Headers.get request.H1.Request.headers "content-type"
|
||||
in
|
||||
let content_type =
|
||||
Option.value ~default:"application/octet-stream" content_type
|
||||
in
|
||||
let headers =
|
||||
H1.Headers.of_list
|
||||
[
|
||||
("transfer-encoding", "chunked");
|
||||
("content-type", content_type);
|
||||
]
|
||||
in
|
||||
let response = H1.Response.create ~reason:"transmit" ~headers `OK in
|
||||
let src = H1.Reqd.request_body reqd in
|
||||
let dst = H1.Reqd.respond_with_streaming reqd response in
|
||||
transmit src dst
|
||||
| [ ""; "hash" ] ->
|
||||
let respond response contents =
|
||||
H1.Reqd.respond_with_string reqd response contents
|
||||
in
|
||||
hash_of_seed ~respond request
|
||||
| [ ""; "random" ] -> (
|
||||
match H1.Headers.get request.H1.Request.headers "x-length" with
|
||||
| Some v when String.for_all is_digit v ->
|
||||
let length = Int64.of_string v in
|
||||
let g =
|
||||
Option.bind
|
||||
(H1.Headers.get request.H1.Request.headers "x-seed")
|
||||
random_state_of_seed
|
||||
in
|
||||
let headers =
|
||||
H1.Headers.of_list
|
||||
[
|
||||
("content-type", "text/plain");
|
||||
("transfer-encoding", "chunked");
|
||||
]
|
||||
in
|
||||
let response =
|
||||
H1.Response.create ~reason:"random" ~headers `OK
|
||||
in
|
||||
let body = H1.Reqd.respond_with_streaming reqd response in
|
||||
transmit_random
|
||||
~write_string:(fun body str ->
|
||||
H1.Body.Writer.write_string body str)
|
||||
~flush:H1.Body.Writer.flush ~close_writer:H1.Body.Writer.close
|
||||
?g length body
|
||||
| _ ->
|
||||
let contents = "Invalid length." in
|
||||
let headers =
|
||||
H1.Headers.of_list
|
||||
[
|
||||
("content-length", string_of_int (String.length contents));
|
||||
("connection", "close"); ("content-type", "text/plain");
|
||||
]
|
||||
in
|
||||
let response =
|
||||
H1.Response.create ~reason:"random" ~headers `Bad_request
|
||||
in
|
||||
H1.Reqd.respond_with_string reqd response contents)
|
||||
| _ ->
|
||||
let contents = "Not found." in
|
||||
let headers =
|
||||
H1.Headers.of_list
|
||||
[
|
||||
("content-type", "text/plain"); ("connection", "close");
|
||||
("content-length", string_of_int (String.length contents));
|
||||
]
|
||||
in
|
||||
let response =
|
||||
H1.Response.create ~reason:"not-found" ~headers `Not_found
|
||||
in
|
||||
H1.Reqd.respond_with_string reqd response contents)
|
||||
fun flow reqd ->
|
||||
let request = H1.Reqd.request reqd in
|
||||
Log.debug (fun m ->
|
||||
m "(HTTP/1.1) request-handler: %S" request.H1.Request.target);
|
||||
match request.H1.Request.meth with
|
||||
| `CONNECT ->
|
||||
Log.debug (fun m -> m "Start to transmit data over HTTP/1.1.");
|
||||
connect_http_1_1 ~ctx ~authenticator ~to_close flow reqd
|
||||
| _meth -> (
|
||||
match String.split_on_char '/' request.H1.Request.target with
|
||||
| [ ""; "" ] ->
|
||||
let headers =
|
||||
H1.Headers.of_list
|
||||
[
|
||||
("content-length", string_of_int (String.length root));
|
||||
("connection", "close"); ("content-type", "text/plain");
|
||||
]
|
||||
in
|
||||
let response = H1.Response.create ~reason:"root" ~headers `OK in
|
||||
H1.Reqd.respond_with_string reqd response root
|
||||
| _ ->
|
||||
let contents = "Not found." in
|
||||
let headers =
|
||||
H1.Headers.of_list
|
||||
[
|
||||
("content-type", "text/plain"); ("connection", "close");
|
||||
("content-length", string_of_int (String.length contents));
|
||||
]
|
||||
in
|
||||
let response =
|
||||
H1.Response.create ~reason:"not-found" ~headers `Not_found
|
||||
in
|
||||
H1.Reqd.respond_with_string reqd response contents)
|
||||
|
||||
(***** H2 *****)
|
||||
|
||||
|
|
@ -492,88 +243,36 @@ let connect_http_2_0 ~ctx ~authenticator ~to_close flow reqd =
|
|||
H2.Reqd.respond_with_string reqd response contents
|
||||
|
||||
let http_2_0_request_handler ~ctx ~authenticator ~to_close =
|
||||
let hash_of_seed = hash_of_seed (module S_HTTP_2_0) in
|
||||
fun flow reqd ->
|
||||
let request = H2.Reqd.request reqd in
|
||||
Log.debug (fun m -> m "(H2) request-handler: %S" request.H2.Request.target);
|
||||
match request.H2.Request.meth with
|
||||
| `CONNECT ->
|
||||
Log.debug (fun m -> m "Start to transmit data over H2.");
|
||||
connect_http_2_0 ~ctx ~authenticator ~to_close flow reqd
|
||||
| _meth -> (
|
||||
match String.split_on_char '/' request.H2.Request.target with
|
||||
| [ ""; "" ] ->
|
||||
let headers =
|
||||
H2.Headers.of_list
|
||||
[
|
||||
("content-length", string_of_int (String.length root));
|
||||
("content-type", "text/plain");
|
||||
]
|
||||
in
|
||||
let response = H2.Response.create ~headers `OK in
|
||||
H2.Reqd.respond_with_string reqd response root
|
||||
| [ ""; "transmit" ] ->
|
||||
let content_type =
|
||||
H2.Headers.get request.H2.Request.headers "content-type"
|
||||
in
|
||||
let content_type =
|
||||
Option.value ~default:"application/octet-stream" content_type
|
||||
in
|
||||
let headers =
|
||||
H2.Headers.of_list [ ("content-type", content_type) ]
|
||||
in
|
||||
let response = H2.Response.create ~headers `OK in
|
||||
let src = H2.Reqd.request_body reqd in
|
||||
let dst = H2.Reqd.respond_with_streaming reqd response in
|
||||
transmit src dst
|
||||
| [ ""; "hash" ] ->
|
||||
let respond response contents =
|
||||
H2.Reqd.respond_with_string reqd response contents
|
||||
in
|
||||
hash_of_seed ~respond request
|
||||
| [ ""; "random" ] -> (
|
||||
match H2.Headers.get request.H2.Request.headers "x-length" with
|
||||
| Some v when String.for_all is_digit v ->
|
||||
let length = Int64.of_string v in
|
||||
let g =
|
||||
Option.bind
|
||||
(H2.Headers.get request.H2.Request.headers "x-seed")
|
||||
random_state_of_seed
|
||||
in
|
||||
let headers =
|
||||
H2.Headers.of_list [ ("content-type", "text/plain") ]
|
||||
in
|
||||
let response = H2.Response.create ~headers `OK in
|
||||
let body = H2.Reqd.respond_with_streaming reqd response in
|
||||
let flush body next =
|
||||
H2.Body.Writer.flush body (fun _reason -> next ())
|
||||
in
|
||||
transmit_random
|
||||
~write_string:(fun body str ->
|
||||
H2.Body.Writer.write_string body str)
|
||||
~flush ~close_writer:H2.Body.Writer.close ?g length body
|
||||
| _ ->
|
||||
let contents = "Invalid length." in
|
||||
let headers =
|
||||
H2.Headers.of_list
|
||||
[
|
||||
("content-length", string_of_int (String.length contents));
|
||||
("content-type", "text/plain");
|
||||
]
|
||||
in
|
||||
let response = H2.Response.create ~headers `Bad_request in
|
||||
H2.Reqd.respond_with_string reqd response contents)
|
||||
| _ ->
|
||||
let contents = "Not found." in
|
||||
let headers =
|
||||
H2.Headers.of_list
|
||||
[
|
||||
("content-type", "text/plain");
|
||||
("content-length", string_of_int (String.length contents));
|
||||
]
|
||||
in
|
||||
let response = H2.Response.create ~headers `Not_found in
|
||||
H2.Reqd.respond_with_string reqd response contents)
|
||||
fun flow reqd ->
|
||||
let request = H2.Reqd.request reqd in
|
||||
Log.debug (fun m -> m "(H2) request-handler: %S" request.H2.Request.target);
|
||||
match request.H2.Request.meth with
|
||||
| `CONNECT ->
|
||||
Log.debug (fun m -> m "Start to transmit data over H2.");
|
||||
connect_http_2_0 ~ctx ~authenticator ~to_close flow reqd
|
||||
| _meth -> (
|
||||
match String.split_on_char '/' request.H2.Request.target with
|
||||
| [ ""; "" ] ->
|
||||
let headers =
|
||||
H2.Headers.of_list
|
||||
[
|
||||
("content-length", string_of_int (String.length root));
|
||||
("content-type", "text/plain");
|
||||
]
|
||||
in
|
||||
let response = H2.Response.create ~headers `OK in
|
||||
H2.Reqd.respond_with_string reqd response root
|
||||
| _ ->
|
||||
let contents = "Not found." in
|
||||
let headers =
|
||||
H2.Headers.of_list
|
||||
[
|
||||
("content-type", "text/plain");
|
||||
("content-length", string_of_int (String.length contents));
|
||||
]
|
||||
in
|
||||
let response = H2.Response.create ~headers `Not_found in
|
||||
H2.Reqd.respond_with_string reqd response contents)
|
||||
|
||||
let alpn_request_handler : type reqd headers request response ro wo.
|
||||
ctx:_ ->
|
||||
|
|
@ -626,13 +325,12 @@ let alpn_error_handler : type reqd headers request response ro wo.
|
|||
fun _edn protocol ?request:_ error respond ->
|
||||
let contents =
|
||||
match error with
|
||||
| `Bad_gateway -> {plain|Bad gateway.|plain}
|
||||
| `Bad_request -> {plain|Bad request.|plain}
|
||||
| `Bad_gateway -> {|Bad gateway.|}
|
||||
| `Bad_request -> {|Bad request.|}
|
||||
| `Exn (Paf.Flow err) | `Exn (Paf.Flow_write err) ->
|
||||
Fmt.str {plain|I/O error: %s.|plain} err
|
||||
| `Exn exn ->
|
||||
Fmt.str {plain|Unknown error: %S.|plain} (Printexc.to_string exn)
|
||||
| `Internal_server_error -> {plain|Internal server error.|plain}
|
||||
Fmt.str {|I/O error: %s.|} err
|
||||
| `Exn exn -> Fmt.str {|Unknown error: %S.|} (Printexc.to_string exn)
|
||||
| `Internal_server_error -> {|Internal server error.|}
|
||||
in
|
||||
let headers =
|
||||
headers_of_list protocol
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue