From e80ce7d579b7d0d616e12161425cf39274cb5509 Mon Sep 17 00:00:00 2001 From: Anurag Soni Date: Sat, 11 Jan 2020 12:14:41 -0500 Subject: [PATCH] Try using `httpaf` as backing http implementation (#94) * Link OCaml Webapp Tutorial from README (#131) Link "Lightweight OCaml Webapp Tutorial" from README Followup to #127 * remove unused dependencies (#132) * feat: support cohttp lwt_stream body (#135) * Update stream impl (#137) * forward headers and code * First try with httpaf * add logs + bigstringaf as deps * run ocamlformat * Fix opam files Co-authored-by: Shon Feder --- README.cpp.md | 10 ++- README.md | 16 +++- TODO.md | 9 +++ dune-project | 13 +-- examples/hello_world.ml | 10 +-- examples/hello_world_log.ml | 5 +- opium.opam | 5 +- opium/app.ml | 119 ++++++++++++++++++++------- opium/app.mli | 67 +++++++++------- opium/debug.ml | 2 +- opium/dune | 2 +- opium/opium.ml | 1 - opium/static_serve.ml | 52 +++++++++--- opium/static_serve.mli | 2 +- opium_kernel.opam | 8 +- opium_kernel/cookie.ml | 151 +++++++++++++++++------------------ opium_kernel/cookie.mli | 56 ++++++------- opium_kernel/dune | 2 +- opium_kernel/misc.ml | 23 +++++- opium_kernel/opium_kernel.ml | 4 +- opium_kernel/rock.ml | 85 +++++++++++--------- opium_kernel/rock.mli | 83 ++++++++++--------- opium_kernel/router.ml | 5 +- opium_kernel/router.mli | 4 +- opium_kernel/std.ml | 3 +- 25 files changed, 444 insertions(+), 293 deletions(-) create mode 100644 TODO.md diff --git a/README.cpp.md b/README.cpp.md index cc205296..b6037b56 100644 --- a/README.cpp.md +++ b/README.cpp.md @@ -37,13 +37,19 @@ $ opam pin add opium --dev-repo ## Documentation -For the API documentation: +For the **API documentation**: - Read [the hosted documentation for the latest version][hosted-docs]. - Build and view the docs for version installed locally using [`odig`][odig]: `odig doc opium`. -For examples of idiomatic usage, see the [./examples directory](./examples) +The following **tutorials** walk through various usecases of Opium: + +- [A Lightweight OCaml Webapp Tutorial](https://shonfeder.gitlab.io/ocaml_webapp/) + covers a simple webapp generating dynamic HTML on the backend and + interfacing with PostgreSQL. + +For **examples** of idiomatic usage, see the [./examples directory](./examples) and the simple examples below. [hosted-docs]: https://rgrinberg.github.io/opium/ diff --git a/README.md b/README.md index dd71142a..dbed926e 100644 --- a/README.md +++ b/README.md @@ -37,13 +37,19 @@ $ opam pin add opium --dev-repo ## Documentation -For the API documentation: +For the **API documentation**: - Read [the hosted documentation for the latest version][hosted-docs]. - Build and view the docs for version installed locally using [`odig`][odig]: `odig doc opium`. -For examples of idiomatic usage, see the [./examples directory](./examples) +The following **tutorials** walk through various usecases of Opium: + +- [A Lightweight OCaml Webapp Tutorial](https://shonfeder.gitlab.io/ocaml_webapp/) + covers a simple webapp generating dynamic HTML on the backend and + interfacing with PostgreSQL. + +For **examples** of idiomatic usage, see the [./examples directory](./examples) and the simple examples below. [hosted-docs]: https://rgrinberg.github.io/opium/ @@ -76,6 +82,10 @@ let print_param = put "/hello/:name" (fun req -> `String ("Hello " ^ param req "name") |> respond') +let default = + not_found (fun req -> + `Json Ezjsonm.(dict [("message", string "Route not found")]) |> respond') + let print_person = get "/person/:name/:age" (fun req -> let person = @@ -83,7 +93,7 @@ let print_person = in `Json (person |> json_of_person) |> respond') -let _ = App.empty |> print_param |> print_person |> App.run_command +let _ = App.empty |> print_param |> print_person |> default |> App.run_command ``` compile and run with: diff --git a/TODO.md b/TODO.md new file mode 100644 index 00000000..964e103e --- /dev/null +++ b/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 diff --git a/dune-project b/dune-project index 578b655f..021f45f6 100644 --- a/dune-project +++ b/dune-project @@ -16,16 +16,16 @@ (ocaml (>= 4.04.1)) (dune (>= 1.11)) hmap - cohttp - cohttp-lwt - ezjsonm - base64 + httpaf lwt fieldslib sexplib ppx_fields_conv ppx_sexp_conv + logs + bigstringaf re + uri (alcotest :with-test)) ) @@ -43,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 - stringext (alcotest :with-test)) ) diff --git a/examples/hello_world.ml b/examples/hello_world.ml index 1d2ff78e..bdca5768 100644 --- a/examples/hello_world.ml +++ b/examples/hello_world.ml @@ -8,12 +8,9 @@ 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 default = - not_found (fun req -> - `Json Ezjsonm.(dict [("message", string "Route not found")]) |> respond') - let print_person = get "/person/:name/:age" (fun req -> let person = @@ -21,4 +18,7 @@ let print_person = in `Json (person |> json_of_person) |> respond') -let _ = App.empty |> print_param |> print_person |> default |> App.run_command +let _ = + Logs.set_reporter (Logs_fmt.reporter ()) ; + Logs.set_level (Some Logs.Debug) ; + App.empty |> print_param |> print_person |> App.run_command diff --git a/examples/hello_world_log.ml b/examples/hello_world_log.ml index 5fd3a007..62f128d3 100644 --- a/examples/hello_world_log.ml +++ b/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 diff --git a/opium.opam b/opium.opam index 98a29d0f..bed7152a 100644 --- a/opium.opam +++ b/opium.opam @@ -17,15 +17,16 @@ 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" - "stringext" "alcotest" {with-test} ] build: [ diff --git a/opium/app.ml b/opium/app.ml index afbf4e39..f6c8a2b0 100644 --- a/opium/app.ml +++ b/opium/app.ml @@ -1,44 +1,89 @@ 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 + | `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 +142,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 +161,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; `HEAD; `OPTIONS] let to_rock app = Rock.App.create ~middlewares:(attach_middleware app) ~handler:app.not_found @@ -142,7 +186,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,15 +277,27 @@ 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 type body = - [`Html of string | `Json of Ezjsonm.t | `Xml of string | `String of string] + [ `Html of string + | `Json of Ezjsonm.t + | `Xml of string + | `String of string + | `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" @@ -251,8 +307,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) @@ -262,9 +321,7 @@ module Response_helpers = struct let respond' ?headers ?code s = s |> respond ?headers ?code |> return 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 @@ -272,12 +329,12 @@ 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 diff --git a/opium/app.mli b/opium/app.mli index 81dd2092..2c73867f 100644 --- a/opium/app.mli +++ b/opium/app.mli @@ -6,16 +6,16 @@ open Opium_kernel.Rock - Easy handling of routes and bodies - Automatic generation of a command line app *) -type t [@@deriving sexp_of] (** An opium app is a simple builder wrapper around a rock app *) +type t val empty : t (** A basic empty app *) -type builder = t -> t [@@deriving sexp_of] (** A builder is a function that transforms an [app] by adding some - functionality. Builders are usuallys composed with a base app using (|>) to - create a full app *) + functionality. Builders are usuallys composed with a base app + using (|>) to create a full app *) +type builder = t -> t val port : int -> builder @@ -23,14 +23,14 @@ val ssl : cert:string -> key:string -> builder val cmd_name : string -> builder -type route = string -> Handler.t -> builder [@@deriving sexp_of] -(** A route is a function that returns a buidler that hooks up a handler to a - url mapping *) - val not_found : Handler.t -> builder (** [not_found] accepts a regular Opium handler that will be used instead of the default 404 handler. *) +(** A route is a function that returns a buidler that hooks up a + handler to a url mapping *) +type route = string -> Handler.t -> builder + val get : route (** Method specific routes *) @@ -40,42 +40,47 @@ val delete : route val put : route -val patch : route -(** Less common method specific routes *) - +(** Less common method specific routes *) +(* val patch : route *) val options : route val head : route -val any : Cohttp.Code.meth list -> route -(** any [methods] will bind a route to any http method inside of [methods] *) - +(** any [methods] will bind a route to any http method inside of + [methods] *) +val any : Httpaf.Method.t list -> route +(** all [methods] will bind a route to a URL regardless of the http method. + You may escape the actual method used from the request passed. *) val all : route (** all [methods] will bind a route to a URL regardless of the http method. You may escape the actual method used from the request passed. *) -val action : Cohttp.Code.meth -> route +val action : Httpaf.Method.t -> route val middleware : Middleware.t -> builder val to_rock : t -> Opium_kernel.Rock.App.t (** Convert an opium app to a rock app *) -val start : t -> unit Lwt.t (** Start an opium server. The thread returned can be cancelled to shutdown the server *) +val start : t -> Lwt_io.server Lwt.t val run_command : t -> unit (** Create a cmdliner command from an app and run lwt's event loop *) -(* Run a cmdliner command from an app. Does not launch Lwt's event loop. `Error - is returned if the command line arguments are incorrect. `Not_running is - returned if the command was completed without the server being launched *) -val run_command' : t -> [> `Ok of unit Lwt.t | `Error | `Not_running] +(* Run a cmdliner command from an app. Does not launch Lwt's event loop. + `Error is returned if the command line arguments are incorrect. + `Not_running is returned if the command was completed without the server + being launched *) +val run_command' : t -> [> `Ok of Lwt_io.server Lwt.t | `Error | `Not_running ] type body = - [`Html of string | `Json of Ezjsonm.t | `Xml of string | `String of string] -(** Convenience functions for a running opium app *) + [ `Html of string + | `Json of Ezjsonm.t + | `Xml of string + | `String of string + | `Bigstring of Bigstringaf.t] val json_of_body_exn : Request.t -> Ezjsonm.t Lwt.t @@ -91,20 +96,22 @@ val param : Request.t -> string -> string val splat : Request.t -> string list -val respond : - ?headers:Cohttp.Header.t - -> ?code:Cohttp.Code.status_code +val respond : ?headers:Httpaf.Headers.t + -> ?code:Httpaf.Status.t -> body -> Response.t (* Same as return (respond ...) *) -val respond' : - ?headers:Cohttp.Header.t - -> ?code:Cohttp.Code.status_code +val respond' : ?headers:Httpaf.Headers.t + -> ?code: Httpaf.Status.t -> body -> Response.t Lwt.t -val redirect : ?headers:Cohttp.Header.t -> Uri.t -> Response.t +val redirect : ?headers: Httpaf.Headers.t + -> Uri.t + -> Response.t (* Same as return (redirect ...) *) -val redirect' : ?headers:Cohttp.Header.t -> Uri.t -> Response.t Lwt.t +val redirect' : ?headers: Httpaf.Headers.t + -> Uri.t + -> Response.t Lwt.t diff --git a/opium/debug.ml b/opium/debug.ml index 4fc96f6d..5549c7aa 100644 --- a/opium/debug.ml +++ b/opium/debug.ml @@ -33,7 +33,7 @@ let trace = let filter handler req = 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.debug ~src:log_src (fun m -> m "Responded with %d" code) ; response in diff --git a/opium/dune b/opium/dune index 11a17aba..0a2a9b0a 100644 --- a/opium/dune +++ b/opium/dune @@ -4,4 +4,4 @@ (:standard -safe-string)) (preprocess (pps ppx_sexp_conv ppx_fields_conv)) - (libraries opium_kernel cmdliner cohttp-lwt-unix magic-mime logs stringext)) + (libraries opium_kernel cmdliner httpaf httpaf-lwt-unix magic-mime logs)) diff --git a/opium/opium.ml b/opium/opium.ml index 957b0a58..e082c4a1 100644 --- a/opium/opium.ml +++ b/opium/opium.ml @@ -46,7 +46,6 @@ module Std = struct include Opium_kernel.Std module Middleware = Middleware include App_export - module Body = Cohttp_lwt.Body end module Hmap = Opium_kernel.Hmap diff --git a/opium/static_serve.ml b/opium/static_serve.ml index 573ef397..e0195128 100644 --- a/opium/static_serve.ml +++ b/opium/static_serve.ml @@ -1,6 +1,6 @@ open Opium_kernel__Misc open Sexplib.Std -module Server = Cohttp_lwt_unix.Server +module Server = Httpaf_lwt_unix.Server open Opium_kernel.Rock type t = {prefix: string; local_path: string} [@@deriving fields, sexp] @@ -11,7 +11,38 @@ let legal_path {prefix; local_path} requested = if String.is_prefix requested_path ~prefix:local_path then Some requested_path else None -let public_serve t ~requested ~request_if_none_match ?etag_of_fname ?headers () +exception Isnt_a_file + +let add_opt_header_unless_exists headers k v = + match headers with + | Some h -> Httpaf.Headers.add_unless_exists h k v + | None -> Httpaf.Headers.of_list [(k, v)] + +let respond_with_file ?headers ~name () = + Lwt.catch + (fun () -> + Lwt_unix.stat name + >>= (fun s -> + if Unix.(s.st_kind <> S_REG) then Lwt.fail Isnt_a_file + else Lwt.return_unit) + >>= fun () -> + Lwt_io.with_file ~mode:Lwt_io.input name (fun ic -> + Lwt_io.read ic + >>= fun body -> + let mime_type = Magic_mime.lookup name in + let headers = + add_opt_header_unless_exists headers "content-type" mime_type + in + let resp = Httpaf.Response.create ~headers `OK in + return (resp, body))) + (fun e -> + match e with + | Isnt_a_file -> + let resp = Httpaf.Response.create `Not_found in + return (resp, "") + | exn -> Lwt.fail exn) + +let public_serve t ~requested ~request_if_none_match ?etag_of_fname ?(headers = Httpaf.Headers.empty) () = match legal_path t requested with | None -> return `Not_found @@ -21,14 +52,9 @@ let public_serve t ~requested ~request_if_none_match ?etag_of_fname ?headers () | Some f -> Some (Printf.sprintf "%S" (f legal_path)) | None -> None in - let mime_type = Magic_mime.lookup legal_path in - let headers = - Cohttp.Header.add_opt_unless_exists headers "content-type" mime_type - in let headers = match etag_quoted with - | Some etag_quoted -> - Cohttp.Header.add_unless_exists headers "etag" etag_quoted + | Some etag_quoted -> Httpaf.Headers.add_unless_exists headers "etag" etag_quoted | None -> headers in let request_matches_etag = @@ -42,10 +68,10 @@ let public_serve t ~requested ~request_if_none_match ?etag_of_fname ?headers () if request_matches_etag then `Ok (Response.create ~code:`Not_modified ~headers ()) |> Lwt.return else - Server.respond_file ~headers ~fname:legal_path () - >>| fun resp -> - if resp |> fst |> Cohttp.Response.status = `Not_found then `Not_found - else `Ok (Response.of_response_body resp) + respond_with_file ~headers ~name:legal_path () + >>| fun (resp, body) -> + if resp.status = `Not_found then `Not_found + else `Ok (Response.of_response_body (resp, `String body)) let m ~local_path ~uri_prefix ?headers ?etag_of_fname () = let filter handler req = @@ -54,7 +80,7 @@ let m ~local_path ~uri_prefix ?headers ?etag_of_fname () = let local_path = req |> Request.uri |> Uri.path in if local_path |> String.is_prefix ~prefix:uri_prefix then let request_if_none_match = - Cohttp.Header.get (Request.headers req) "If-None-Match" + Httpaf.Headers.get (Request.headers req) "If-None-Match" in public_serve local_map ~requested:local_path ~request_if_none_match ?etag_of_fname ?headers () diff --git a/opium/static_serve.mli b/opium/static_serve.mli index b265fdfd..aef2ae45 100644 --- a/opium/static_serve.mli +++ b/opium/static_serve.mli @@ -1,7 +1,7 @@ val m : local_path:string -> uri_prefix:string - -> ?headers:Cohttp.Header.t + -> ?headers:Httpaf.Headers.t -> ?etag_of_fname:(string -> string) -> unit -> Opium_kernel.Rock.Middleware.t diff --git a/opium_kernel.opam b/opium_kernel.opam index 9a939e6b..0a5889e5 100644 --- a/opium_kernel.opam +++ b/opium_kernel.opam @@ -12,16 +12,16 @@ depends: [ "ocaml" {>= "4.04.1"} "dune" {>= "1.11"} "hmap" - "cohttp" - "cohttp-lwt" - "ezjsonm" - "base64" + "httpaf" "lwt" "fieldslib" "sexplib" "ppx_fields_conv" "ppx_sexp_conv" + "logs" + "bigstringaf" "re" + "uri" "alcotest" {with-test} ] build: [ diff --git a/opium_kernel/cookie.ml b/opium_kernel/cookie.ml index 645f120f..b9a66690 100644 --- a/opium_kernel/cookie.ml +++ b/opium_kernel/cookie.ml @@ -1,90 +1,87 @@ -open Misc -open Sexplib.Std -module Co = Cohttp +(* open Misc *) +(* open Sexplib.Std *) -let encode x = Uri.pct_encode ~component:`Query_key x +(* module Co = Cohttp *) -let decode = Uri.pct_decode +(* let encode x = *) +(* Uri.pct_encode ~component:`Query_key x *) -module Env = struct - type cookie = (string * string) list +(* let decode = Uri.pct_decode *) - let key : cookie Hmap0.key = - Hmap0.Key.create ("cookie", [%sexp_of: (string * string) list]) -end +(* module Env = struct *) +(* type cookie = (string * string) list *) +(* let key : cookie Hmap0.key = *) +(* Hmap0.Key.create ("cookie",[%sexp_of: (string * string) list]) *) +(* end *) -module Env_resp = struct - type cookie = Co.Cookie.Set_cookie_hdr.t list +(* module Env_resp = struct *) +(* type cookie = Co.Cookie.Set_cookie_hdr.t list *) +(* let key : cookie Hmap0.key = *) +(* Hmap0.Key.create *) +(* ("cookie_res",[%sexp_of: Co.Cookie.Set_cookie_hdr.t list]) *) +(* end *) - let key : cookie Hmap0.key = - Hmap0.Key.create ("cookie_res", [%sexp_of: Co.Cookie.Set_cookie_hdr.t list]) -end +(* let current_cookies env record = *) +(* Option.value ~default:[] (Hmap0.find Env.key (env record) ) *) -let current_cookies env record = - Option.value ~default:[] (Hmap0.find Env.key (env record)) +(* let current_cookies_resp env record = *) +(* Option.value ~default:[] (Hmap0.find Env_resp.key (env record)) *) -let current_cookies_resp env record = - Option.value ~default:[] (Hmap0.find Env_resp.key (env record)) +(* let cookies_raw req = *) +(* req *) +(* |> Rock.Request.request *) +(* |> Co.Request.headers *) +(* |> Co.Cookie.Cookie_hdr.extract *) -let cookies_raw req = - req |> Rock.Request.request |> Co.Request.headers - |> Co.Cookie.Cookie_hdr.extract +(* let cookies req = *) +(* req *) +(* |> cookies_raw *) +(* |> List.filter_map ~f:(fun (k,v) -> *) +(* (1* ignore bad cookies *1) *) +(* Option.try_with (fun () -> (k, decode v))) *) -let cookies req = - req |> cookies_raw - |> List.filter_map ~f:(fun (k, v) -> - (* ignore bad cookies *) - Option.try_with (fun () -> (k, decode v))) +(* let get req ~key = *) +(* let cookie1 = *) +(* let env = current_cookies (fun r -> r.Rock.Request.env) req in *) +(* List.find_map env ~f:(fun (k,v) -> if k = key then Some v else None) *) +(* in *) +(* match cookie1 with *) +(* | Some cookie -> Some cookie *) +(* | None -> *) +(* let cookies = cookies_raw req in *) +(* cookies *) +(* |> List.find_map ~f:(fun (k,v) -> *) +(* if k = key then Some (decode v) else None) *) -let get req ~key = - let cookie1 = - let env = current_cookies (fun r -> r.Rock.Request.env) req in - List.find_map env ~f:(fun (k, v) -> if k = key then Some v else None) - in - match cookie1 with - | Some cookie -> Some cookie - | None -> - let cookies = cookies_raw req in - cookies - |> List.find_map ~f:(fun (k, v) -> - if k = key then Some (decode v) else None) +(* (1* Path defaulted to "/" as otherwise the default is the path of the + request's URI *1) *) +(* let set_cookies ?expiration ?(path = "/") ?domain ?secure ?http_only resp + cookies = *) +(* let env = Rock.Response.env resp in *) +(* let current_cookies = current_cookies_resp (fun r->r.Rock.Response.env) resp + in *) +(* let cookies' = List.map cookies ~f:(fun (key, data) -> *) +(* Co.Cookie.Set_cookie_hdr.make ~path ?domain ?expiration ?secure ?http_only + (key, encode data)) in *) +(* (1* WRONG cookies cannot just be concatenated *1) *) +(* let all_cookies = current_cookies @ cookies' in *) +(* { resp with Rock.Response.env=(Hmap0.add Env_resp.key all_cookies env) } *) -(* Path defaulted to "/" as otherwise the default is the path of the request's - URI *) -let set_cookies ?expiration ?(path = "/") ?domain ?secure ?http_only resp - cookies = - let env = Rock.Response.env resp in - let current_cookies = - current_cookies_resp (fun r -> r.Rock.Response.env) resp - in - let cookies' = - List.map cookies ~f:(fun (key, data) -> - Co.Cookie.Set_cookie_hdr.make ~path ?domain ?expiration ?secure - ?http_only - (key, encode data)) - in - (* WRONG cookies cannot just be concatenated *) - let all_cookies = current_cookies @ cookies' in - {resp with Rock.Response.env= Hmap0.add Env_resp.key all_cookies env} +(* let set ?expiration ?path ?domain ?secure ?http_only resp ~key ~data = *) +(* set_cookies ?expiration ?path ?domain ?secure ?http_only resp [(key, data)] *) -let set ?expiration ?path ?domain ?secure ?http_only resp ~key ~data = - set_cookies ?expiration ?path ?domain ?secure ?http_only resp [(key, data)] - -let m = - (* TODO: "optimize" *) - let filter handler req = - handler req - >>| fun response -> - let cookie_headers = - let module Cookie = Co.Cookie.Set_cookie_hdr in - response - |> current_cookies_resp (fun r -> r.Rock.Response.env) - |> List.map ~f:Cookie.serialize - in - let old_headers = Rock.Response.headers response in - { response with - Rock.Response.headers= - List.fold_left cookie_headers ~init:old_headers - ~f:(fun headers (k, v) -> Co.Header.add headers k v) } - in - Rock.Middleware.create ~filter ~name:"Cookie" +(* let m = (1* TODO: "optimize" *1) *) +(* let filter handler req = *) +(* handler req >>| fun response -> *) +(* let cookie_headers = *) +(* let module Cookie = Co.Cookie.Set_cookie_hdr in *) +(* response *) +(* |> current_cookies_resp (fun r -> r.Rock.Response.env) *) +(* |> List.map ~f:Cookie.serialize *) +(* in *) +(* let old_headers = Rock.Response.headers response in *) +(* { response with Rock.Response.headers=( *) +(* List.fold_left cookie_headers ~init:old_headers *) +(* ~f:(fun headers (k,v) -> Co.Header.add headers k v)) *) +(* } *) +(* in Rock.Middleware.create ~filter ~name:"Cookie" *) diff --git a/opium_kernel/cookie.mli b/opium_kernel/cookie.mli index e7c1e073..0cf2665b 100644 --- a/opium_kernel/cookie.mli +++ b/opium_kernel/cookie.mli @@ -1,33 +1,33 @@ -(** Simple cookie module. Cookie values are percent encoded. *) +(*(1** Simple cookie module. Cookie values are percent encoded. *1) *) -val cookies : Rock.Request.t -> (string * string) list -(** Fetch all cookies from a rock request *) +(*(1** Fetch all cookies from a rock request *1) *) +(*val cookies : Rock.Request.t -> (string * string) list *) -val get : Rock.Request.t -> key:string -> string option -(** Get the follow of a cookie with a certain key *) +(*(1** Get the follow of a cookie with a certain key *1) *) +(*val get : Rock.Request.t -> key:string -> string option *) -val set : - ?expiration:Cohttp.Cookie.expiration - -> ?path:string - -> ?domain:string - -> ?secure:bool - -> ?http_only:bool - -> Rock.Response.t - -> key:string - -> data:string - -> Rock.Response.t -(** Set the value of a cookie with a certain key in a response *) +(*(1** Set the value of a cookie with a certain key in a response *1) *) +(*val set *) +(* : ?expiration:Cohttp.Cookie.expiration *) +(* -> ?path:string *) +(* -> ?domain:string *) +(* -> ?secure:bool *) +(* -> ?http_only:bool *) +(* -> Rock.Response.t *) +(* -> key:string *) +(* -> data:string *) +(* -> Rock.Response.t *) -val set_cookies : - ?expiration:Cohttp.Cookie.expiration - -> ?path:string - -> ?domain:string - -> ?secure:bool - -> ?http_only:bool - -> Rock.Response.t - -> (string * string) list - -> Rock.Response.t -(** Like set but will do multiple cookies at once *) +(*(1** Like set but will do multiple cookies at once *1) *) +(*val set_cookies *) +(* : ?expiration:Cohttp.Cookie.expiration *) +(* -> ?path:string *) +(* -> ?domain:string *) +(* -> ?secure:bool *) +(* -> ?http_only:bool *) +(* -> Rock.Response.t *) +(* -> (string * string) list *) +(* -> Rock.Response.t *) -val m : Rock.Middleware.t -(** Rock middleware to add the the functionality above *) +(*(1** Rock middleware to add the the functionality above *1) *) +(*val m : Rock.Middleware.t *) diff --git a/opium_kernel/dune b/opium_kernel/dune index a6d2f3a5..5baaa726 100644 --- a/opium_kernel/dune +++ b/opium_kernel/dune @@ -4,4 +4,4 @@ (:standard -safe-string)) (preprocess (pps ppx_sexp_conv ppx_fields_conv)) - (libraries hmap cohttp-lwt ezjsonm)) + (libraries hmap httpaf lwt logs bigstringaf re uri ezjsonm)) diff --git a/opium_kernel/misc.ml b/opium_kernel/misc.ml index 94fb19d6..6bafc70f 100644 --- a/opium_kernel/misc.ml +++ b/opium_kernel/misc.ml @@ -1,4 +1,5 @@ open Sexplib +open Sexplib.Std let return = Lwt.return @@ -6,7 +7,27 @@ let ( >>= ) = Lwt.( >>= ) let ( >>| ) = Lwt.( >|= ) -module Body = Cohttp_lwt.Body +module Body = struct + type t = [`Empty | `String of string | `Bigstring of Bigstringaf.t] + + let empty = `Empty + + let of_string s = `String s + + let of_bigstring b = `Bigstring b + + let length = function + | `Empty -> 0 + | `String s -> String.length s + | `Bigstring b -> Bigstringaf.length b + + let to_string = function + | `Empty -> "" + | `String s -> s + | `Bigstring b -> Bigstringaf.to_string b + + let to_string_promise t = Lwt.return (to_string t) +end module Fn = struct let compose f g x = f (g x) diff --git a/opium_kernel/opium_kernel.ml b/opium_kernel/opium_kernel.ml index b3d5d116..68cd07e6 100644 --- a/opium_kernel/opium_kernel.ml +++ b/opium_kernel/opium_kernel.ml @@ -2,9 +2,11 @@ module Export = struct module Rock = Rock module Response = Rock.Response module Request = Rock.Request - module Cookie = Cookie + + (* module Cookie = Cookie *) module Router = Router module Route = Route + module Body = Misc.Body end include Export diff --git a/opium_kernel/rock.ml b/opium_kernel/rock.ml index 6439752b..d3f9d8c1 100644 --- a/opium_kernel/rock.ml +++ b/opium_kernel/rock.ml @@ -1,9 +1,10 @@ -open Sexplib.Std +open Sexplib open Misc -module Header = Cohttp.Header +module Header = Httpaf.Headers +module Body = Misc.Body module Service = struct - type ('req, 'rep) t = 'req -> 'rep Lwt.t [@@deriving sexp] + type ('req, 'rep) t = 'req -> 'rep Lwt.t let id req = return req @@ -13,9 +14,8 @@ end module Filter = struct type ('req, 'rep, 'req_, 'rep_) t = ('req, 'rep) Service.t -> ('req_, 'rep_) Service.t - [@@deriving sexp] - type ('req, 'rep) simple = ('req, 'rep, 'req, 'rep) t [@@deriving sexp] + type ('req, 'rep) simple = ('req, 'rep, 'req, 'rep) t let id s = s @@ -25,47 +25,56 @@ module Filter = struct end module Request = struct - type t = {request: Cohttp.Request.t; body: Cohttp_lwt.Body.t; env: Hmap0.t} - [@@deriving fields, sexp_of] - - let create ?(body = Cohttp_lwt.Body.empty) ?(env = Hmap0.empty) request = - {request; env; body} - - let uri {request; _} = Cohttp.Request.uri request - - let meth {request; _} = Cohttp.Request.meth request - - let headers {request; _} = Cohttp.Request.headers request + type t = {request: Httpaf.Request.t; uri: Uri.t; body: Body.t; env: Hmap0.t} + [@@deriving fields] + + let create ?(body = Body.empty) ?(env = Hmap0.empty) request = + {request; env; body; uri= Uri.of_string request.target} + + let uri {uri; _} = uri + + let meth {request; _} = request.meth + + let headers {request; _} = request.headers + + let sexp_of_t {request; body; uri; env} = + Sexp.( + List + [ List + [ Atom (Httpaf.Method.to_string request.meth) + ; Atom request.target + ; Atom (Httpaf.Version.to_string request.version) + ; List + (List.map + ~f:(fun (a, b) -> List [Atom a; Atom b]) + (Httpaf.Headers.to_list request.headers)) ] + ; Atom (Body.to_string body) + ; Atom (Uri.to_string uri) + ; Hmap0.sexp_of_t env ]) end module Response = struct - type t = - { code: Cohttp.Code.status_code - ; headers: Header.t - ; body: Cohttp_lwt.Body.t - ; env: Hmap0.t } - [@@deriving fields, sexp_of] + type t = {code: Httpaf.Status.t; headers: Header.t; body: Body.t; env: Hmap0.t} + [@@deriving fields] - let default_header = Option.value ~default:(Header.init ()) + let default_header = Option.value ~default:Header.empty - let create ?(env = Hmap0.empty) ?(body = Cohttp_lwt.Body.empty) ?headers - ?(code = `OK) () = - {code; env; headers= Option.value ~default:(Header.init ()) headers; body} + let create ?(env = Hmap0.empty) ?(body = Body.empty) ?headers ?(code = `OK) () + = + {code; env; headers= Option.value ~default:Header.empty headers; body} let of_string_body ?(env = Hmap0.empty) ?headers ?(code = `OK) body = - { env - ; code - ; headers= default_header headers - ; body= Cohttp_lwt.Body.of_string body } - - let of_response_body (resp, body) = - let code = Cohttp.Response.status resp in - let headers = Cohttp.Response.headers resp in - create ~code ~headers ~body () + {env; code; headers= default_header headers; body= Body.of_string body} + + let of_bigstring_body ?(env = Hmap0.empty) ?headers ?(code = `OK) body = + {env; code; headers= default_header headers; body= Body.of_bigstring body} + + let of_response_body ({Httpaf.Response.status; headers; _}, body) = + create ~code:status ~headers ~body () end module Handler = struct - type t = (Request.t, Response.t) Service.t [@@deriving sexp_of] + type t = (Request.t, Response.t) Service.t let default _ = return (Response.of_string_body "route failed (404)") @@ -77,7 +86,7 @@ end module Middleware = struct type t = {filter: (Request.t, Response.t) Filter.simple; name: string} - [@@deriving fields, sexp_of] + [@@deriving fields] let create ~filter ~name = {filter; name} @@ -104,7 +113,7 @@ end module App = struct type t = {middlewares: Middleware.t list; handler: Handler.t} - [@@deriving fields, sexp_of] + [@@deriving fields] let append_middleware t m = {t with middlewares= t.middlewares @ [m]} diff --git a/opium_kernel/rock.mli b/opium_kernel/rock.mli index e4ce5544..855e1568 100644 --- a/opium_kernel/rock.mli +++ b/opium_kernel/rock.mli @@ -2,9 +2,12 @@ general and inspired by Finagle. It's not imperative to have this to for such a tiny framework but it makes extensions a lot more straightforward *) -(** A service is simply a function that returns its result asynchronously *) +module Body = Misc.Body + +(** A service is simply a function that returns its result + asynchronously *) module Service : sig - type ('req, 'rep) t = 'req -> 'rep Lwt.t [@@deriving sexp] + type ('req, 'rep) t = 'req -> 'rep Lwt.t val id : ('a, 'a) t @@ -16,10 +19,8 @@ end module Filter : sig type ('req, 'rep, 'req', 'rep') t = ('req, 'rep) Service.t -> ('req', 'rep') Service.t - [@@deriving sexp] - type ('req, 'rep) simple = ('req, 'rep, 'req, 'rep) t [@@deriving sexp] - (** A filter is simple when it preserves the type of a service *) + type ('req, 'rep) simple = ('req, 'rep, 'req, 'rep) t val id : ('req, 'rep) simple @@ -31,49 +32,55 @@ module Filter : sig end module Request : sig - type t = {request: Cohttp.Request.t; body: Cohttp_lwt.Body.t; env: Hmap0.t} - [@@deriving fields, sexp_of] - - val create : ?body:Cohttp_lwt.Body.t -> ?env:Hmap0.t -> Cohttp.Request.t -> t - - (* Convenience accessors on the request field *) + type t = { + request: Httpaf.Request.t; + uri: Uri.t; + body: Body.t; + env: Hmap0.t; + } [@@deriving fields, sexp_of] + + val create : ?body:Body.t + -> ?env:Hmap0.t + -> Httpaf.Request.t -> t + (** Convenience accessors on the request field *) val uri : t -> Uri.t - - val meth : t -> Cohttp.Code.meth - - val headers : t -> Cohttp.Header.t + val meth : t -> Httpaf.Method.t + val headers : t -> Httpaf.Headers.t end module Response : sig - type t = - { code: Cohttp.Code.status_code - ; headers: Cohttp.Header.t - ; body: Cohttp_lwt.Body.t - ; env: Hmap0.t } - [@@deriving fields, sexp_of] + type t = { + code: Httpaf.Status.t; + headers: Httpaf.Headers.t; + body: Body.t; + env: Hmap0.t + } [@@deriving fields] val create : - ?env:Hmap0.t - -> ?body:Cohttp_lwt.Body.t - -> ?headers:Cohttp.Header.t - -> ?code:Cohttp.Code.status_code - -> unit - -> t + ?env: Hmap0.t -> + ?body: Body.t -> + ?headers: Httpaf.Headers.t -> + ?code: Httpaf.Status.t -> + unit -> t val of_string_body : - ?env:Hmap0.t - -> ?headers:Cohttp.Header.t - -> ?code:Cohttp.Code.status_code - -> string - -> t - - val of_response_body : Cohttp.Response.t * Cohttp_lwt.Body.t -> t + ?env: Hmap0.t -> + ?headers: Httpaf.Headers.t -> + ?code: Httpaf.Status.t -> + string -> t + + val of_bigstring_body : + ?env: Hmap0.t -> + ?headers: Httpaf.Headers.t -> + ?code: Httpaf.Status.t -> + Bigstringaf.t -> t + + val of_response_body : Httpaf.Response.t * Body.t -> t end (** A handler is a rock specific service *) module Handler : sig - type t = (Request.t, Response.t) Service.t [@@deriving sexp_of] - + type t = (Request.t, Response.t) Service.t val default : t val not_found : t @@ -82,7 +89,7 @@ end (** Middleware is a named, simple filter, that only works on rock requests/response *) module Middleware : sig - type t [@@deriving sexp_of] + type t val filter : t -> (Request.t, Response.t) Filter.simple @@ -95,7 +102,7 @@ module Middleware : sig end module App : sig - type t [@@deriving sexp_of] + type t val handler : t -> Handler.t diff --git a/opium_kernel/router.ml b/opium_kernel/router.ml index 81f72fd5..6a8d71df 100644 --- a/opium_kernel/router.ml +++ b/opium_kernel/router.ml @@ -1,11 +1,9 @@ open Misc -open Sexplib.Std -module Co = Cohttp module Rock = Rock module Route = Route open Rock -type 'a t = (Route.t * 'a) Queue.t array [@@deriving sexp] +type 'a t = (Route.t * 'a) Queue.t array let create () = Array.init 7 (fun _ -> Queue.create ()) @@ -15,7 +13,6 @@ let int_of_meth = function | `PUT -> 2 | `DELETE -> 3 | `HEAD -> 4 - | `PATCH -> 5 | `OPTIONS -> 6 | _ -> failwith "non standard http verbs not supported" diff --git a/opium_kernel/router.mli b/opium_kernel/router.mli index f8a2c456..7f447b5b 100644 --- a/opium_kernel/router.mli +++ b/opium_kernel/router.mli @@ -1,8 +1,8 @@ -type 'action t [@@deriving sexp] +type 'action t val create : unit -> _ t -val add : 'a t -> route:Route.t -> meth:Cohttp.Code.meth -> action:'a -> unit +val add : 'a t -> route:Route.t -> meth:Httpaf.Method.t -> action:'a -> unit val param : Rock.Request.t -> string -> string diff --git a/opium_kernel/std.ml b/opium_kernel/std.ml index ebbad383..b64553ca 100644 --- a/opium_kernel/std.ml +++ b/opium_kernel/std.ml @@ -1,7 +1,8 @@ module Rock = Rock module Response = Rock.Response module Request = Rock.Request -module Cookie = Cookie + +(* module Cookie = Cookie *) module Router = Router module Route = Route include Misc