Try using httpaf as backing http implementation (rgrinberg#94)

* Link OCaml Webapp Tutorial from README  (rgrinberg#131)

Link "Lightweight OCaml Webapp Tutorial" from README

Followup to rgrinberg#127

* remove unused dependencies (rgrinberg#132)

* feat: support cohttp lwt_stream body (rgrinberg#135)

* Update stream impl (rgrinberg#137)

* forward headers and code

* First try with httpaf

* add logs + bigstringaf as deps

* run ocamlformat

* Fix opam files

Co-authored-by: Shon Feder <[email protected]>

TODO.md

@@ -0,0 +1,9 @@
+## Things missing when compared to version based on Cohttp
+
+* ~~Request body isn't handled yet (most important task for now)~~
+* No sexp derivers (Httpaf doesn't have sexp derivers for their types, consider using their pretty printers instead?)
+* ~~No static file serving.~~
+* No cookie module (will need something similar to Cohttp's cookie module)
+* No SSL (https://github.com/inhabitedtype/httpaf/pull/83 should help)
+
+Update this file as more gaps are found

dune-project

@@ -16,14 +16,16 @@
   (ocaml (>= 4.04.1))
   (dune (>= 1.11))
   hmap
-  cohttp
-  cohttp-lwt
+  httpaf
   lwt
   fieldslib
   sexplib
   ppx_fields_conv
   ppx_sexp_conv
+  logs
+  bigstringaf
   re
+  uri
   (alcotest :with-test))
  )
 
@@ -41,14 +43,15 @@
   (ocaml (>= 4.04.1))
   (dune (>= 1.11))
   opium_kernel
-  cohttp-lwt-unix
+  httpaf-lwt-unix
   ezjsonm
   lwt
   logs
   cmdliner
   ppx_fields_conv
   ppx_sexp_conv
   re
+  logs
   magic-mime
   (alcotest :with-test))
  )

examples/hello_world.ml

@@ -8,6 +8,7 @@ let json_of_person {name; age} =
 
 let print_param =
   put "/hello/:name" (fun req ->
+      Logs.info (fun m -> m "Request body: %s\n" (Rock.Body.to_string req.body)) ;
       `String ("Hello " ^ param req "name") |> respond')
 
 let streaming =
@@ -35,5 +36,7 @@ let print_person =
       `Json (person |> json_of_person) |> respond')
 
 let _ =
+  Logs.set_reporter (Logs_fmt.reporter ()) ;
+  Logs.set_level (Some Logs.Debug) ;
   App.empty |> print_param |> print_person |> streaming |> default
   |> App.run_command

examples/hello_world_log.ml

@@ -10,7 +10,7 @@ let logger =
     let uri = Request.uri req |> Uri.path_and_query in
     handler req
     >|= fun response ->
-    let code = response |> Response.code |> Cohttp.Code.code_of_status in
+    let code = response |> Response.code |> Httpaf.Status.to_code in
     Logs.info (fun m -> m "Responded to '%s' with %d" uri code) ;
     response
   in
@@ -31,6 +31,7 @@ let () =
         Logs.set_level (Some Logs.Info) ;
         app
       in
-      ignore (Lwt_main.run s)
+      Lwt.async (fun () -> s >>= fun _ -> Lwt.return_unit) ;
+      Lwt_main.run (fst (Lwt.wait ()))
   | `Error -> exit 1
   | `Not_running -> exit 0

opium.opam

@@ -17,14 +17,15 @@ depends: [
   "ocaml" {>= "4.04.1"}
   "dune" {>= "1.11"}
   "opium_kernel"
-  "cohttp-lwt-unix"
+  "httpaf-lwt-unix"
   "ezjsonm"
   "lwt"
   "logs"
   "cmdliner"
   "ppx_fields_conv"
   "ppx_sexp_conv"
   "re"
+  "logs"
   "magic-mime"
   "alcotest" {with-test}
 ]

opium/app.ml

@@ -1,44 +1,90 @@
 open Opium_kernel__Misc
-open Sexplib.Std
 module Rock = Opium_kernel.Rock
 module Router = Opium_kernel.Router
 module Route = Opium_kernel.Route
-module Server = Cohttp_lwt_unix.Server
+module Server = Httpaf_lwt_unix.Server
+module Reqd = Httpaf.Reqd
 open Rock
-module Co = Cohttp
 
 let run_unix ?ssl t ~port =
   let middlewares = t |> App.middlewares |> List.map ~f:Middleware.filter in
   let handler = App.handler t in
-  let mode =
+  let _mode =
     Option.value_map ssl
       ~default:(`TCP (`Port port))
       ~f:(fun (c, k) -> `TLS (c, k, `No_password, `Port port))
   in
-  Server.create ~mode
-    (Server.make
-       ~callback:(fun _ req body ->
-         let req = Request.create ~body req in
-         let handler = Filter.apply_all middlewares handler in
-         handler req
-         >>= fun {Response.code; headers; body; _} ->
-         Server.respond ~headers ~body ~status:code ())
-       ())
+  let listen_address = Unix.(ADDR_INET (inet_addr_loopback, port)) in
+  let connection_handler =
+    let read_body m request_body =
+      let body_read, finished = Lwt.wait () in
+      ( match m with
+      | `POST | `PUT ->
+          let b =
+            Buffer.create Httpaf.Config.default.request_body_buffer_size
+          in
+          let rec on_read bs ~off ~len =
+            let b' = Bytes.create len in
+            Bigstringaf.blit_to_bytes bs ~src_off:off b' ~dst_off:0 ~len ;
+            Buffer.add_bytes b b' ;
+            Httpaf.Body.schedule_read request_body ~on_read ~on_eof
+          and on_eof () =
+            Lwt.wakeup_later finished (Body.of_string (Buffer.contents b))
+          in
+          Httpaf.Body.schedule_read request_body ~on_read ~on_eof
+      | _ -> Lwt.wakeup_later finished Rock.Body.empty ) ;
+      body_read
+    in
+    let request_handler _ reqd =
+      Lwt.async (fun () ->
+          let request = Reqd.request reqd in
+          read_body request.meth (Httpaf.Reqd.request_body reqd)
+          >>= fun body ->
+          let req = Request.create ~body request in
+          let handler = Filter.apply_all middlewares handler in
+          handler req
+          >>| fun {Response.code; headers; body; _} ->
+          let headers =
+            Httpaf.Headers.add_unless_exists headers "Content-Length"
+              (string_of_int (Body.length body))
+          in
+          let response = Httpaf.Response.create ~headers code in
+          match body with
+          | `Empty -> Reqd.respond_with_string reqd response ""
+          | `String s -> Reqd.respond_with_string reqd response s
+          | `Streaming _ -> body |> Body.to_string |> Reqd.respond_with_string reqd response
+          | `Bigstring b -> Reqd.respond_with_bigstring reqd response b)
+    in
+    let error_handler _ ?request:_ error start_response =
+      let response_body = start_response Httpaf.Headers.empty in
+      ( match error with
+      | `Exn exn ->
+          Httpaf.Body.write_string response_body (Printexc.to_string exn) ;
+          Httpaf.Body.write_string response_body "\n"
+      | #Httpaf.Status.standard as error ->
+          Httpaf.Body.write_string response_body
+            (Httpaf.Status.default_reason_phrase error) ) ;
+      Httpaf.Body.close_writer response_body
+    in
+    Server.create_connection_handler ~request_handler ~error_handler
+  in
+  Lwt_io.establish_server_with_client_socket ~backlog:128 listen_address
+    connection_handler
 
 type t =
   { port: int
   ; ssl: ([`Crt_file_path of string] * [`Key_file_path of string]) option
   ; debug: bool
   ; verbose: bool
-  ; routes: (Co.Code.meth * Route.t * Handler.t) list
+  ; routes: (Httpaf.Method.t * Route.t * Handler.t) list
   ; middlewares: Middleware.t list
   ; name: string
   ; not_found: Handler.t }
-[@@deriving fields, sexp_of]
+[@@deriving fields]
 
-type builder = t -> t [@@deriving sexp]
+type builder = t -> t
 
-type route = string -> Handler.t -> builder [@@deriving sexp]
+type route = string -> Handler.t -> builder
 
 let register app ~meth ~route ~action =
   {app with routes= (meth, route, action) :: app.routes}
@@ -97,9 +143,8 @@ let delete route action =
 let put route action =
   register ~meth:`PUT ~route:(Route.of_string route) ~action
 
-let patch route action =
-  register ~meth:`PATCH ~route:(Route.of_string route) ~action
-
+(* let patch route action = *)
+(* register ~meth:`PATCH ~route:(Route.of_string route) ~action *)
 let head route action =
   register ~meth:`HEAD ~route:(Route.of_string route) ~action
 
@@ -117,7 +162,7 @@ let any methods route action t =
   |> List.fold_left ~init:t ~f:(fun app meth ->
          app |> register ~meth ~route ~action)
 
-let all = any [`GET; `POST; `DELETE; `PUT; `PATCH; `HEAD; `OPTIONS]
+let all = any [`GET; `POST; `DELETE; `PUT; (* `PATCH; *)`HEAD; `OPTIONS]
 
 let to_rock app =
   Rock.App.create ~middlewares:(attach_middleware app) ~handler:app.not_found
@@ -142,7 +187,7 @@ let print_routes_f routes =
   Hashtbl.iter
     (fun key data ->
       Printf.printf "> %s (%s)\n" (Route.to_string key)
-        (data |> List.map ~f:Cohttp.Code.string_of_method |> String.concat " "))
+        (data |> List.map ~f:Httpaf.Method.to_string |> String.concat " "))
     routes_tbl
 
 let print_middleware_f middlewares =
@@ -233,7 +278,10 @@ let run_command' app =
 
 let run_command app =
   match app |> run_command' with
-  | `Ok a -> Lwt_main.run a
+  | `Ok a ->
+      Lwt.async (fun () -> a >>= fun _server -> Lwt.return_unit) ;
+      let forever, _ = Lwt.wait () in
+      Lwt_main.run forever
   | `Error -> exit 1
   | `Not_running -> exit 0
 
@@ -242,10 +290,16 @@ type body =
   | `Json of Ezjsonm.t
   | `Xml of string
   | `String of string
-  | `Streaming of string Lwt_stream.t ]
+  | `Streaming of string Lwt_stream.t
+  | `Bigstring of Bigstringaf.t ]
 
 module Response_helpers = struct
-  let content_type ct h = Cohttp.Header.add_opt h "Content-Type" ct
+  let add_opt headers k v =
+    match headers with
+    | Some h -> Httpaf.Headers.add h k v
+    | None -> Httpaf.Headers.of_list [(k, v)]
+
+  let content_type ct h = add_opt h "Content-Type" ct
 
   let json_header = content_type "application/json"
 
@@ -255,8 +309,11 @@ module Response_helpers = struct
 
   let respond_with_string = Response.of_string_body
 
+  let respond_with_bigstring = Response.of_bigstring_body
+
   let respond ?headers ?(code = `OK) = function
     | `String s -> respond_with_string ?headers ~code s
+    | `Bigstring s -> respond_with_bigstring ?headers ~code s
     | `Json s ->
         respond_with_string ~code ~headers:(json_header headers)
           (Ezjsonm.to_string s)
@@ -277,22 +334,20 @@ module Response_helpers = struct
     (f, p')
 
   let redirect ?headers uri =
-    let headers =
-      Cohttp.Header.add_opt headers "Location" (Uri.to_string uri)
-    in
+    let headers = add_opt headers "Location" (Uri.to_string uri) in
     Response.create ~headers ~code:`Found ()
 
   let redirect' ?headers uri = uri |> redirect ?headers |> return
 end
 
 module Request_helpers = struct
   let json_exn req =
-    req |> Request.body |> Cohttp_lwt.Body.to_string >>| Ezjsonm.from_string
+    req |> Request.body |> Body.to_string_promise >>| Ezjsonm.from_string
 
-  let string_exn req = req |> Request.body |> Cohttp_lwt.Body.to_string
+  let string_exn req = req |> Request.body |> Body.to_string_promise
 
   let pairs_exn req =
-    req |> Request.body |> Cohttp_lwt.Body.to_string >>| Uri.query_of_encoded
+    req |> Request.body |> Body.to_string_promise >>| Uri.query_of_encoded
 end
 
 let json_of_body_exn = Request_helpers.json_exn