Apply ocamlformat on our tests
This commit is contained in:
parent
79ceba1c6e
commit
1e86fe54ab
1 changed files with 129 additions and 81 deletions
178
test/test.ml
178
test/test.ml
|
@ -1,83 +1,126 @@
|
||||||
(* Functoria *)
|
(* Functoria *)
|
||||||
|
|
||||||
module DNS_client = Dns_client_mirage.Make (Mirage_random_stdlib) (Time) (Mclock) (Pclock) (Tcpip_stack_socket.V4V6)
|
module DNS_client =
|
||||||
module Happy_eyeballs = Happy_eyeballs_mirage.Make (Time) (Mclock) (Tcpip_stack_socket.V4V6) (DNS_client)
|
Dns_client_mirage.Make (Mirage_random_stdlib) (Time) (Mclock) (Pclock)
|
||||||
module Mimic_happy_eyeballs = Mimic_happy_eyeballs.Make (Tcpip_stack_socket.V4V6) (DNS_client) (Happy_eyeballs)
|
(Tcpip_stack_socket.V4V6)
|
||||||
|
|
||||||
|
module Happy_eyeballs =
|
||||||
|
Happy_eyeballs_mirage.Make (Time) (Mclock) (Tcpip_stack_socket.V4V6)
|
||||||
|
(DNS_client)
|
||||||
|
|
||||||
|
module Mimic_happy_eyeballs =
|
||||||
|
Mimic_happy_eyeballs.Make (Tcpip_stack_socket.V4V6) (DNS_client)
|
||||||
|
(Happy_eyeballs)
|
||||||
|
|
||||||
module HTTP_server = Paf_mirage.Make (Tcpip_stack_socket.V4V6.TCP)
|
module HTTP_server = Paf_mirage.Make (Tcpip_stack_socket.V4V6.TCP)
|
||||||
module HTTP_client = Http_mirage_client.Make (Pclock) (Tcpip_stack_socket.V4V6.TCP) (Mimic_happy_eyeballs)
|
|
||||||
|
module HTTP_client =
|
||||||
|
Http_mirage_client.Make (Pclock) (Tcpip_stack_socket.V4V6.TCP)
|
||||||
|
(Mimic_happy_eyeballs)
|
||||||
|
|
||||||
let http_1_1_error_handler ?notify (ipaddr, port) ?request:_ error respond =
|
let http_1_1_error_handler ?notify (ipaddr, port) ?request:_ error respond =
|
||||||
let contents = match error with
|
let contents =
|
||||||
|
match error with
|
||||||
| `Bad_gateway -> Fmt.str "Bad gateway (%a:%d)" Ipaddr.pp ipaddr port
|
| `Bad_gateway -> Fmt.str "Bad gateway (%a:%d)" Ipaddr.pp ipaddr port
|
||||||
| `Bad_request -> Fmt.str "Bad request (%a:%d)" Ipaddr.pp ipaddr port
|
| `Bad_request -> Fmt.str "Bad request (%a:%d)" Ipaddr.pp ipaddr port
|
||||||
| `Exn exn -> Fmt.str "Exception %S (%a:%d)" (Printexc.to_string exn) Ipaddr.pp ipaddr port
|
| `Exn exn ->
|
||||||
| `Internal_server_error -> Fmt.str "Internal server error (%a:%d)" Ipaddr.pp ipaddr port in
|
Fmt.str "Exception %S (%a:%d)" (Printexc.to_string exn) Ipaddr.pp ipaddr
|
||||||
|
port
|
||||||
|
| `Internal_server_error ->
|
||||||
|
Fmt.str "Internal server error (%a:%d)" Ipaddr.pp ipaddr port in
|
||||||
let open Httpaf in
|
let open Httpaf in
|
||||||
Option.iter (fun push -> push (Some ((ipaddr, port), error))) notify ;
|
Option.iter (fun push -> push (Some ((ipaddr, port), error))) notify
|
||||||
let headers = Headers.of_list
|
; let headers =
|
||||||
[ "content-type", "text/plain"
|
Headers.of_list
|
||||||
|
[
|
||||||
|
"content-type", "text/plain"
|
||||||
; "content-length", string_of_int (String.length contents)
|
; "content-length", string_of_int (String.length contents)
|
||||||
; "connection", "close" ] in
|
; "connection", "close"
|
||||||
|
] in
|
||||||
let body = respond headers in
|
let body = respond headers in
|
||||||
Body.write_string body contents ;
|
Body.write_string body contents
|
||||||
Body.close_writer body
|
; Body.close_writer body
|
||||||
|
|
||||||
let alpn_error_handler
|
let alpn_error_handler :
|
||||||
: type reqd headers request response ro wo.
|
type reqd headers request response ro wo.
|
||||||
?notify:(((Ipaddr.t * int) * Alpn.server_error) option -> unit) ->
|
?notify:(((Ipaddr.t * int) * Alpn.server_error) option -> unit)
|
||||||
(Ipaddr.t * int) -> (reqd, headers, request, response, ro, wo) Alpn.protocol ->
|
-> Ipaddr.t * int
|
||||||
?request:request -> Alpn.server_error -> (headers -> wo) -> unit
|
-> (reqd, headers, request, response, ro, wo) Alpn.protocol
|
||||||
= fun ?notify (ipaddr, port) protocol ?request:_ error respond ->
|
-> ?request:request
|
||||||
let contents = match error with
|
-> Alpn.server_error
|
||||||
|
-> (headers -> wo)
|
||||||
|
-> unit =
|
||||||
|
fun ?notify (ipaddr, port) protocol ?request:_ error respond ->
|
||||||
|
let contents =
|
||||||
|
match error with
|
||||||
| `Bad_gateway -> Fmt.str "Bad gateway (%a:%d)" Ipaddr.pp ipaddr port
|
| `Bad_gateway -> Fmt.str "Bad gateway (%a:%d)" Ipaddr.pp ipaddr port
|
||||||
| `Bad_request -> Fmt.str "Bad request (%a:%d)" Ipaddr.pp ipaddr port
|
| `Bad_request -> Fmt.str "Bad request (%a:%d)" Ipaddr.pp ipaddr port
|
||||||
| `Exn exn -> Fmt.str "Exception %S (%a:%d)" (Printexc.to_string exn) Ipaddr.pp ipaddr port
|
| `Exn exn ->
|
||||||
| `Internal_server_error -> Fmt.str "Internal server error (%a:%d)" Ipaddr.pp ipaddr port in
|
Fmt.str "Exception %S (%a:%d)" (Printexc.to_string exn) Ipaddr.pp ipaddr
|
||||||
Option.iter (fun push -> push (Some ((ipaddr, port), error))) notify ;
|
port
|
||||||
let headers =
|
| `Internal_server_error ->
|
||||||
[ "content-type", "text/plain"
|
Fmt.str "Internal server error (%a:%d)" Ipaddr.pp ipaddr port in
|
||||||
; "content-length", string_of_int (String.length contents) ] in
|
Option.iter (fun push -> push (Some ((ipaddr, port), error))) notify
|
||||||
|
; let headers =
|
||||||
|
[
|
||||||
|
"content-type", "text/plain"
|
||||||
|
; "content-length", string_of_int (String.length contents)
|
||||||
|
] in
|
||||||
match protocol with
|
match protocol with
|
||||||
| Alpn.HTTP_1_1 _ ->
|
| Alpn.HTTP_1_1 _ ->
|
||||||
let open Httpaf in
|
let open Httpaf in
|
||||||
let headers = Headers.of_list (("connection", "close") :: headers) in
|
let headers = Headers.of_list (("connection", "close") :: headers) in
|
||||||
let body = respond headers in
|
let body = respond headers in
|
||||||
Body.write_string body contents ;
|
Body.write_string body contents
|
||||||
Body.close_writer body
|
; Body.close_writer body
|
||||||
| Alpn.H2 _ ->
|
| Alpn.H2 _ ->
|
||||||
let open H2 in
|
let open H2 in
|
||||||
let headers = Headers.of_list headers in
|
let headers = Headers.of_list headers in
|
||||||
let body = respond headers in
|
let body = respond headers in
|
||||||
H2.Body.Writer.write_string body contents ;
|
H2.Body.Writer.write_string body contents
|
||||||
H2.Body.Writer.close body
|
; H2.Body.Writer.close body
|
||||||
|
|
||||||
type alpn_handler =
|
type alpn_handler = {
|
||||||
{ handler : 'reqd 'headers 'request 'response 'ro 'wo.
|
handler:
|
||||||
'reqd -> ('reqd, 'headers, 'request, 'response, 'ro, 'wo) Alpn.protocol -> unit }
|
'reqd 'headers 'request 'response 'ro 'wo.
|
||||||
|
'reqd
|
||||||
|
-> ('reqd, 'headers, 'request, 'response, 'ro, 'wo) Alpn.protocol
|
||||||
|
-> unit
|
||||||
|
}
|
||||||
[@@unboxed]
|
[@@unboxed]
|
||||||
|
|
||||||
let server ?error ?stop stack = function
|
let server ?error ?stop stack = function
|
||||||
| `HTTP_1_1 (port, handler) ->
|
| `HTTP_1_1 (port, handler) ->
|
||||||
let open Lwt.Syntax in
|
let open Lwt.Syntax in
|
||||||
let+ http_server = HTTP_server.init ~port stack in
|
let+ http_server = HTTP_server.init ~port stack in
|
||||||
let http_service = HTTP_server.http_service ~error_handler:(http_1_1_error_handler ?notify:error)
|
let http_service =
|
||||||
|
HTTP_server.http_service
|
||||||
|
~error_handler:(http_1_1_error_handler ?notify:error)
|
||||||
(fun _flow (_ipaddr, _port) -> handler) in
|
(fun _flow (_ipaddr, _port) -> handler) in
|
||||||
HTTP_server.serve ?stop http_service http_server
|
HTTP_server.serve ?stop http_service http_server
|
||||||
| `ALPN (tls, port, handler) ->
|
| `ALPN (tls, port, handler) ->
|
||||||
let open Lwt.Syntax in
|
let open Lwt.Syntax in
|
||||||
let alpn_handler =
|
let alpn_handler =
|
||||||
{ Alpn.error= (fun edn protocol ?request v respond -> alpn_error_handler ?notify:error edn protocol ?request v respond)
|
{
|
||||||
; Alpn.request= (fun _flow (_ipaddr, _port) reqd protocol -> handler.handler reqd protocol) } in
|
Alpn.error=
|
||||||
|
(fun edn protocol ?request v respond ->
|
||||||
|
alpn_error_handler ?notify:error edn protocol ?request v respond)
|
||||||
|
; Alpn.request=
|
||||||
|
(fun _flow (_ipaddr, _port) reqd protocol ->
|
||||||
|
handler.handler reqd protocol)
|
||||||
|
} in
|
||||||
let+ http_server = HTTP_server.init ~port stack in
|
let+ http_server = HTTP_server.init ~port stack in
|
||||||
let alpn_service = HTTP_server.alpn_service ~tls alpn_handler in
|
let alpn_service = HTTP_server.alpn_service ~tls alpn_handler in
|
||||||
HTTP_server.serve ?stop alpn_service http_server
|
HTTP_server.serve ?stop alpn_service http_server
|
||||||
|
|
||||||
let stack ipaddr =
|
let stack ipaddr =
|
||||||
let open Lwt.Syntax in
|
let open Lwt.Syntax in
|
||||||
let* tcpv4v6 = Tcpip_stack_socket.V4V6.TCP.connect ~ipv4_only:false ~ipv6_only:false
|
let* tcpv4v6 =
|
||||||
ipaddr None in
|
Tcpip_stack_socket.V4V6.TCP.connect ~ipv4_only:false ~ipv6_only:false ipaddr
|
||||||
let* udpv4v6 = Tcpip_stack_socket.V4V6.UDP.connect ~ipv4_only:false ~ipv6_only:false
|
None in
|
||||||
ipaddr None in
|
let* udpv4v6 =
|
||||||
|
Tcpip_stack_socket.V4V6.UDP.connect ~ipv4_only:false ~ipv6_only:false ipaddr
|
||||||
|
None in
|
||||||
Tcpip_stack_socket.V4V6.connect udpv4v6 tcpv4v6
|
Tcpip_stack_socket.V4V6.connect udpv4v6 tcpv4v6
|
||||||
|
|
||||||
let test01 =
|
let test01 =
|
||||||
|
@ -87,19 +130,24 @@ let test01 =
|
||||||
let handler reqd =
|
let handler reqd =
|
||||||
let open Httpaf in
|
let open Httpaf in
|
||||||
let contents = "Hello World!" in
|
let contents = "Hello World!" in
|
||||||
let headers = Headers.of_list
|
let headers =
|
||||||
[ "content-type", "text/plain"
|
Headers.of_list
|
||||||
|
[
|
||||||
|
"content-type", "text/plain"
|
||||||
; "content-length", string_of_int (String.length contents)
|
; "content-length", string_of_int (String.length contents)
|
||||||
; "connection", "close" ] in
|
; "connection", "close"
|
||||||
|
] in
|
||||||
let response = Response.create ~headers `OK in
|
let response = Response.create ~headers `OK in
|
||||||
Reqd.respond_with_string reqd response contents in
|
Reqd.respond_with_string reqd response contents in
|
||||||
let* stack = stack Ipaddr.V4.Prefix.loopback in
|
let* stack = stack Ipaddr.V4.Prefix.loopback in
|
||||||
let happy_eyeballs = Happy_eyeballs.create stack in
|
let happy_eyeballs = Happy_eyeballs.create stack in
|
||||||
let* ctx = Mimic_happy_eyeballs.connect happy_eyeballs in
|
let* ctx = Mimic_happy_eyeballs.connect happy_eyeballs in
|
||||||
let* t = HTTP_client.connect ctx in
|
let* t = HTTP_client.connect ctx in
|
||||||
let* `Initialized _thread = server ~stop (Tcpip_stack_socket.V4V6.tcp stack)
|
let* (`Initialized _thread) =
|
||||||
(`HTTP_1_1 (8080, handler)) in
|
server ~stop (Tcpip_stack_socket.V4V6.tcp stack) (`HTTP_1_1 (8080, handler))
|
||||||
let* result = Http_mirage_client.request t "http://localhost:8080/"
|
in
|
||||||
|
let* result =
|
||||||
|
Http_mirage_client.request t "http://localhost:8080/"
|
||||||
(fun _response buf str -> Buffer.add_string buf str ; Lwt.return buf)
|
(fun _response buf str -> Buffer.add_string buf str ; Lwt.return buf)
|
||||||
(Buffer.create 0x100) in
|
(Buffer.create 0x100) in
|
||||||
match result with
|
match result with
|
||||||
|
@ -111,14 +159,15 @@ let test01 =
|
||||||
let* () = Lwt_switch.turn_off stop in
|
let* () = Lwt_switch.turn_off stop in
|
||||||
let* () = Tcpip_stack_socket.V4V6.disconnect stack in
|
let* () = Tcpip_stack_socket.V4V6.disconnect stack in
|
||||||
let body = Buffer.contents buf in
|
let body = Buffer.contents buf in
|
||||||
Alcotest.(check string) "body" "Hello World!" body ;
|
Alcotest.(check string) "body" "Hello World!" body
|
||||||
Lwt.return_unit
|
; Lwt.return_unit
|
||||||
|
|
||||||
let random_string ~len =
|
let random_string ~len =
|
||||||
let res = Bytes.create len in
|
let res = Bytes.create len in
|
||||||
for i = 0 to len - 1 do
|
for i = 0 to len - 1 do
|
||||||
Bytes.set res i (Char.chr (Random.bits () land 0xff))
|
Bytes.set res i (Char.chr (Random.bits () land 0xff))
|
||||||
done ; Bytes.unsafe_to_string res
|
done
|
||||||
|
; Bytes.unsafe_to_string res
|
||||||
|
|
||||||
let test02 =
|
let test02 =
|
||||||
Alcotest_lwt.test_case "Repeat (POST)" `Quick @@ fun _sw () ->
|
Alcotest_lwt.test_case "Repeat (POST)" `Quick @@ fun _sw () ->
|
||||||
|
@ -126,28 +175,27 @@ let test02 =
|
||||||
let stop = Lwt_switch.create () in
|
let stop = Lwt_switch.create () in
|
||||||
let handler reqd =
|
let handler reqd =
|
||||||
let open Httpaf in
|
let open Httpaf in
|
||||||
let { Request.meth; _ } = Reqd.request reqd in
|
let {Request.meth; _} = Reqd.request reqd in
|
||||||
if meth <> `POST then invalid_arg "Invalid HTTP method" ;
|
if meth <> `POST then invalid_arg "Invalid HTTP method"
|
||||||
let headers = Headers.of_list
|
; let headers = Headers.of_list ["content-type", "text/plain"] in
|
||||||
[ "content-type", "text/plain" ] in
|
|
||||||
let response = Response.create ~headers `OK in
|
let response = Response.create ~headers `OK in
|
||||||
let src = Reqd.request_body reqd in
|
let src = Reqd.request_body reqd in
|
||||||
let dst = Reqd.respond_with_streaming reqd response in
|
let dst = Reqd.respond_with_streaming reqd response in
|
||||||
let rec on_eof () =
|
let rec on_eof () = Body.close_reader src ; Body.close_writer dst
|
||||||
Body.close_reader src ;
|
|
||||||
Body.close_writer dst
|
|
||||||
and on_read buf ~off ~len =
|
and on_read buf ~off ~len =
|
||||||
Body.write_bigstring dst ~off ~len buf ;
|
Body.write_bigstring dst ~off ~len buf
|
||||||
Body.schedule_read src ~on_eof ~on_read in
|
; Body.schedule_read src ~on_eof ~on_read in
|
||||||
Body.schedule_read src ~on_eof ~on_read in
|
Body.schedule_read src ~on_eof ~on_read in
|
||||||
let* stack = stack Ipaddr.V4.Prefix.loopback in
|
let* stack = stack Ipaddr.V4.Prefix.loopback in
|
||||||
let happy_eyeballs = Happy_eyeballs.create stack in
|
let happy_eyeballs = Happy_eyeballs.create stack in
|
||||||
let* ctx = Mimic_happy_eyeballs.connect happy_eyeballs in
|
let* ctx = Mimic_happy_eyeballs.connect happy_eyeballs in
|
||||||
let* t = HTTP_client.connect ctx in
|
let* t = HTTP_client.connect ctx in
|
||||||
let* `Initialized _thread = server ~stop (Tcpip_stack_socket.V4V6.tcp stack)
|
let* (`Initialized _thread) =
|
||||||
(`HTTP_1_1 (8080, handler)) in
|
server ~stop (Tcpip_stack_socket.V4V6.tcp stack) (`HTTP_1_1 (8080, handler))
|
||||||
|
in
|
||||||
let str = random_string ~len:0x1000 in
|
let str = random_string ~len:0x1000 in
|
||||||
let* result = Http_mirage_client.request ~meth:`POST ~body:str t "http://localhost:8080/"
|
let* result =
|
||||||
|
Http_mirage_client.request ~meth:`POST ~body:str t "http://localhost:8080/"
|
||||||
(fun _response buf str -> Buffer.add_string buf str ; Lwt.return buf)
|
(fun _response buf str -> Buffer.add_string buf str ; Lwt.return buf)
|
||||||
(Buffer.create 0x1000) in
|
(Buffer.create 0x1000) in
|
||||||
match result with
|
match result with
|
||||||
|
@ -159,9 +207,9 @@ let test02 =
|
||||||
let* () = Lwt_switch.turn_off stop in
|
let* () = Lwt_switch.turn_off stop in
|
||||||
let* () = Tcpip_stack_socket.V4V6.disconnect stack in
|
let* () = Tcpip_stack_socket.V4V6.disconnect stack in
|
||||||
let body = Buffer.contents buf in
|
let body = Buffer.contents buf in
|
||||||
Alcotest.(check string) "body" str body ;
|
Alcotest.(check string) "body" str body
|
||||||
Lwt.return_unit
|
; Lwt.return_unit
|
||||||
|
|
||||||
let () = Alcotest_lwt.run "http-mirage-client"
|
let () =
|
||||||
[ "http/1.1", [ test01; test02 ] ]
|
Alcotest_lwt.run "http-mirage-client" ["http/1.1", [test01; test02]]
|
||||||
|> Lwt_main.run
|
|> Lwt_main.run
|
||||||
|
|
Loading…
Reference in a new issue