diff --git a/test/dune b/test/dune new file mode 100644 index 0000000..34b428b --- /dev/null +++ b/test/dune @@ -0,0 +1,9 @@ +(executable + (name test) + (libraries http-mirage-client tcpip.stack-socket paf.mirage + mirage-clock-unix mirage-random-stdlib happy-eyeballs-lwt mirage-time-unix + mimic-happy-eyeballs alcotest-lwt)) + +(rule + (alias runtest) + (action (run ./test.exe --color=always))) diff --git a/test/test.ml b/test/test.ml new file mode 100644 index 0000000..8ff98c0 --- /dev/null +++ b/test/test.ml @@ -0,0 +1,119 @@ +(* Functoria *) + +module DNS_client = Dns_client_mirage.Make (Mirage_random_stdlib) (Time) (Mclock) (Pclock) (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_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 contents = match error with + | `Bad_gateway -> Fmt.str "Bad gateway (%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 + | `Internal_server_error -> Fmt.str "Internal server error (%a:%d)" Ipaddr.pp ipaddr port in + let open Httpaf in + Option.iter (fun push -> push (Some ((ipaddr, port), error))) notify ; + let headers = Headers.of_list + [ "content-type", "text/plain" + ; "content-length", string_of_int (String.length contents) + ; "connection", "close" ] in + let body = respond headers in + Body.write_string body contents ; + Body.close_writer body + +let alpn_error_handler + : type reqd headers request response ro wo. + ?notify:(((Ipaddr.t * int) * Alpn.server_error) option -> unit) -> + (Ipaddr.t * int) -> (reqd, headers, request, response, ro, wo) Alpn.protocol -> + ?request:request -> 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_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 + | `Internal_server_error -> Fmt.str "Internal server error (%a:%d)" Ipaddr.pp ipaddr port 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 + | Alpn.HTTP_1_1 _ -> + let open Httpaf in + let headers = Headers.of_list (("connection", "close") :: headers) in + let body = respond headers in + Body.write_string body contents ; + Body.close_writer body + | Alpn.H2 _ -> + let open H2 in + let headers = Headers.of_list headers in + let body = respond headers in + H2.Body.Writer.write_string body contents ; + H2.Body.Writer.close body + +type alpn_handler = + { handler : 'reqd 'headers 'request 'response 'ro 'wo. + 'reqd -> ('reqd, 'headers, 'request, 'response, 'ro, 'wo) Alpn.protocol -> unit } +[@@unboxed] + +let server ?error ?stop stack = function + | `HTTP_1_1 (port, handler) -> + let open Lwt.Syntax 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) + (fun _flow (_ipaddr, _port) -> handler) in + HTTP_server.serve ?stop http_service http_server + | `ALPN (tls, port, handler) -> + let open Lwt.Syntax in + 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 + let+ http_server = HTTP_server.init ~port stack in + let alpn_service = HTTP_server.alpn_service ~tls alpn_handler in + HTTP_server.serve ?stop alpn_service http_server + +let stack ipaddr = + let open Lwt.Syntax in + let* tcpv4v6 = Tcpip_stack_socket.V4V6.TCP.connect ~ipv4_only:false ~ipv6_only:false + 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 + +let test01 = + Alcotest_lwt.test_case "Simple Hello World! (GET)" `Quick @@ fun _sw () -> + let open Lwt.Syntax in + let stop = Lwt_switch.create () in + let handler reqd = + let open Httpaf in + let contents = "Hello World!" in + let headers = Headers.of_list + [ "content-type", "text/plain" + ; "content-length", string_of_int (String.length contents) + ; "connection", "close" ] in + let response = Response.create ~headers `OK in + Reqd.respond_with_string reqd response contents in + let* stack = stack Ipaddr.V4.Prefix.loopback in + let happy_eyeballs = Happy_eyeballs.create stack in + let* ctx = Mimic_happy_eyeballs.connect happy_eyeballs in + let* t = HTTP_client.connect ctx in + let* `Initialized _thread = server ~stop (Tcpip_stack_socket.V4V6.tcp stack) + (`HTTP_1_1 (8080, handler)) in + let* result = Http_mirage_client.request t "http://localhost:8080/" + (fun _response buf str -> Buffer.add_string buf str ; Lwt.return buf) + (Buffer.create 0x100) in + match result with + | Error err -> + let* () = Lwt_switch.turn_off stop in + let* () = Tcpip_stack_socket.V4V6.disconnect stack in + Alcotest.failf "Client error: %a" Mimic.pp_error err + | Ok (_response, buf) -> + let* () = Lwt_switch.turn_off stop in + let* () = Tcpip_stack_socket.V4V6.disconnect stack in + let body = Buffer.contents buf in + Alcotest.(check string) "body" "Hello World!" body ; + Lwt.return_unit + + let () = Alcotest_lwt.run "http-mirage-client" + [ "simple", [ test01 ] ] + |> Lwt_main.run