diff --git a/Makefile b/Makefile index ab1239ce..a7acd471 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -PACKAGES := dream-pure,dream-httpaf,dream +PACKAGES := dream-pure,dream .PHONY : build build : @@ -10,7 +10,7 @@ watch : .PHONY : deps deps : - opam install --deps-only --with-test ./dream-pure.opam ./dream-httpaf.opam ./dream.opam + opam install --deps-only --with-test ./dream-pure.opam ./dream.opam TEST ?= test ROOT := $(shell [ -f ../dune-workspace ] && echo .. || echo .) diff --git a/dream-httpaf.opam b/dream-httpaf.opam index 57afb7f1..8c8e8bde 100644 --- a/dream-httpaf.opam +++ b/dream-httpaf.opam @@ -15,11 +15,11 @@ maintainer: "Anton Bachin " depends: [ "dream-pure" "dune" {>= "2.7.0"} # --instrument-with. - "lwt" - "lwt_ppx" {>= "1.2.2"} - "lwt_ssl" + # "lwt" + # "lwt_ppx" {>= "1.2.2"} + # "lwt_ssl" "ocaml" {>= "4.08.0"} - "ssl" {>= "0.5.8"} # Ssl.get_negotiated_alpn_protocol. + # "ssl" {>= "0.5.8"} # Ssl.get_negotiated_alpn_protocol. # Currently vendored. # "gluten" @@ -32,14 +32,14 @@ depends: [ # "websocketaf" # Dependencies of vendored packages. - "angstrom" {>= "0.14.0"} - "base64" {>= "3.0.0"} - "bigstringaf" {>= "0.5.0"} # h2. - "digestif" {>= "0.7.2"} # websocket/af, sha1, default implementation. - "faraday" {>= "0.6.1"} - "faraday-lwt-unix" - "lwt_ssl" {>= "1.2.0"} # Gluten. - "psq" # h2. + # "angstrom" {>= "0.14.0"} + # "base64" {>= "3.0.0"} + # "bigstringaf" {>= "0.5.0"} # h2. + # "digestif" {>= "0.7.2"} # websocket/af, sha1, default implementation. + # "faraday" {>= "0.6.1"} + # "faraday-lwt-unix" + # "lwt_ssl" {>= "1.2.0"} # Gluten. + # "psq" # h2. ] build: [ diff --git a/dream-pure.opam b/dream-pure.opam index 6f6b7f26..5aec34b3 100644 --- a/dream-pure.opam +++ b/dream-pure.opam @@ -16,9 +16,8 @@ depends: [ "base64" {>= "3.1.0"} # Base64.encode_string. "bigstringaf" {>= "0.5.0"} # Bigstringaf.to_string. "dune" {>= "2.7.0"} # --instrument-with. + "eio" "hmap" - "lwt" - "lwt_ppx" {>= "1.2.2"} "ocaml" {>= "4.08.0"} "ptime" {>= "0.8.1"} # Ptime.weekday. "uri" {>= "4.2.0"} diff --git a/dream.opam b/dream.opam index fd530bba..dedd9d7f 100644 --- a/dream.opam +++ b/dream.opam @@ -51,28 +51,25 @@ depends: [ "bigarray-compat" "camlp-streams" "caqti" {>= "2.0.0"} - "caqti-lwt" {>= "2.0.0"} + "cohttp-eio" ("conf-libev" {os != "win32"} | "ocaml" {os = "win32"}) "cstruct" {>= "6.0.0"} - "dream-httpaf" {>= "1.0.0~alpha3"} + "digestif" {>= "0.7"} "dream-pure" {>= "1.0.0~alpha2"} "dune" {>= "2.7.0"} # --instrument-with. + "eio" "fmt" {>= "0.8.7"} # `Italic. "graphql_parser" - "graphql-lwt" + "http" "lambdasoup" {>= "0.6.1"} - "lwt" - "lwt_ppx" {>= "1.2.2"} - "lwt_ssl" "logs" {>= "0.5.0"} "magic-mime" "markup" {>= "1.0.2"} "mirage-clock" {>= "3.0.0"} # now_d_ps : unit -> int * int64. "mirage-crypto" {>= "0.8.1"} # AES-256-GCM. "mirage-crypto-rng" - "mirage-crypto-rng-lwt" + "mirage-crypto-rng-eio" "multipart_form" {>= "0.4.0"} - "multipart_form-lwt" "ocaml" {>= "4.08.0"} "ptime" {>= "0.8.1"} # Ptime.v. "ssl" {>= "0.5.8"} # Ssl.get_negotiated_alpn_protocol. @@ -85,6 +82,7 @@ depends: [ "caqti-driver-postgresql" {with-test} "caqti-driver-sqlite3" {with-test} "crunch" {with-test} + "eio_main" {with-test} "js_of_ocaml" {with-test} "js_of_ocaml-ppx" {with-test} "ppx_expect" {with-test & >= "v0.15.0"} # Formatting changes. diff --git a/example/1-hello/dune b/example/1-hello/dune index 212e9fb6..42a205a7 100644 --- a/example/1-hello/dune +++ b/example/1-hello/dune @@ -1,3 +1,3 @@ (executable (name hello) - (libraries dream)) + (libraries dream eio_main)) diff --git a/example/1-hello/hello.ml b/example/1-hello/hello.ml index 5411c9ee..736243c5 100644 --- a/example/1-hello/hello.ml +++ b/example/1-hello/hello.ml @@ -1,3 +1,5 @@ let () = - Dream.run (fun _ -> - Dream.html "Good morning, world!") + Eio_main.run begin fun env -> + Dream.run env (fun _ -> + Dream.html "Good morning, world!") + end diff --git a/example/2-middleware/dune b/example/2-middleware/dune index fd611025..d69b7a27 100644 --- a/example/2-middleware/dune +++ b/example/2-middleware/dune @@ -1,3 +1,3 @@ (executable (name middleware) - (libraries dream)) + (libraries dream eio_main)) diff --git a/example/2-middleware/middleware.ml b/example/2-middleware/middleware.ml index a35eb21d..32b6dee3 100644 --- a/example/2-middleware/middleware.ml +++ b/example/2-middleware/middleware.ml @@ -1,4 +1,6 @@ let () = - Dream.run - @@ Dream.logger - @@ fun _ -> Dream.html "Good morning, world!" + Eio_main.run begin fun env -> + Dream.run env + @@ Dream.logger + @@ fun _ -> Dream.html "Good morning, world!" + end diff --git a/example/3-router/dune b/example/3-router/dune index f19d5c8f..566a72d1 100644 --- a/example/3-router/dune +++ b/example/3-router/dune @@ -1,3 +1,3 @@ (executable (name router) - (libraries dream)) + (libraries dream eio_main)) diff --git a/example/3-router/router.ml b/example/3-router/router.ml index fb1a9dab..0bfdcece 100644 --- a/example/3-router/router.ml +++ b/example/3-router/router.ml @@ -1,5 +1,5 @@ -let () = - Dream.run +let () = Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.router [ diff --git a/example/4-counter/counter.ml b/example/4-counter/counter.ml index 2a1d10ac..cef1b88b 100644 --- a/example/4-counter/counter.ml +++ b/example/4-counter/counter.ml @@ -4,8 +4,8 @@ let count_requests inner_handler request = count := !count + 1; inner_handler request -let () = - Dream.run +let () = Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ count_requests @@ Dream.router [ diff --git a/example/4-counter/dune b/example/4-counter/dune index 6a26e851..6704933b 100644 --- a/example/4-counter/dune +++ b/example/4-counter/dune @@ -1,3 +1,3 @@ (executable (name counter) - (libraries dream)) + (libraries dream eio_main)) diff --git a/example/6-echo/dune b/example/6-echo/dune index 33898b09..ae709efb 100644 --- a/example/6-echo/dune +++ b/example/6-echo/dune @@ -1,4 +1,3 @@ (executable (name echo) - (libraries dream) - (preprocess (pps lwt_ppx))) + (libraries dream eio_main)) diff --git a/example/6-echo/echo.ml b/example/6-echo/echo.ml index 4f63612c..362e2c9b 100644 --- a/example/6-echo/echo.ml +++ b/example/6-echo/echo.ml @@ -1,10 +1,10 @@ -let () = - Dream.run +let () = Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.router [ Dream.post "/echo" (fun request -> - let%lwt body = Dream.body request in + let body = Dream.body request in Dream.respond ~headers:["Content-Type", "application/octet-stream"] body); diff --git a/example/7-template/dune b/example/7-template/dune index 567488d5..2d8c0722 100644 --- a/example/7-template/dune +++ b/example/7-template/dune @@ -1,6 +1,6 @@ (executable (name template) - (libraries dream)) + (libraries dream eio_main)) (rule (targets template.ml) diff --git a/example/7-template/template.eml.ml b/example/7-template/template.eml.ml index f6cd751e..8c9930f5 100644 --- a/example/7-template/template.eml.ml +++ b/example/7-template/template.eml.ml @@ -5,8 +5,8 @@ let render param = -let () = - Dream.run +let () = Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.router [ diff --git a/example/8-debug/debug.ml b/example/8-debug/debug.ml index f7548a38..a8c8973d 100644 --- a/example/8-debug/debug.ml +++ b/example/8-debug/debug.ml @@ -1,5 +1,5 @@ -let () = - Dream.run ~error_handler:Dream.debug_error_handler +let () = Eio_main.run @@ fun env -> + Dream.run ~error_handler:Dream.debug_error_handler env @@ Dream.logger @@ Dream.router [ diff --git a/example/8-debug/dune b/example/8-debug/dune index bd80c111..4ced60a2 100644 --- a/example/8-debug/dune +++ b/example/8-debug/dune @@ -1,3 +1,3 @@ (executable (name debug) - (libraries dream)) + (libraries dream eio_main)) diff --git a/example/9-error/dune b/example/9-error/dune index 24510acd..be163b2a 100644 --- a/example/9-error/dune +++ b/example/9-error/dune @@ -1,6 +1,6 @@ (executable (name error) - (libraries dream)) + (libraries dream eio_main)) (rule (targets error.ml) diff --git a/example/9-error/error.eml.ml b/example/9-error/error.eml.ml index fdd88f81..ec1c19aa 100644 --- a/example/9-error/error.eml.ml +++ b/example/9-error/error.eml.ml @@ -12,9 +12,9 @@ let my_error_template _error debug_info suggested_response = end; - Lwt.return suggested_response + suggested_response -let () = - Dream.run ~error_handler:(Dream.error_template my_error_template) +let () = Eio_main.run @@ fun env -> + Dream.run ~error_handler:(Dream.error_template my_error_template) env @@ Dream.logger @@ fun _ -> Dream.empty `Not_Found diff --git a/example/a-log/dune b/example/a-log/dune index 6d0a5285..595e5c63 100644 --- a/example/a-log/dune +++ b/example/a-log/dune @@ -1,3 +1,3 @@ (executable (name log) - (libraries dream)) + (libraries dream eio_main)) diff --git a/example/a-log/log.ml b/example/a-log/log.ml index 457bf791..09c700c9 100644 --- a/example/a-log/log.ml +++ b/example/a-log/log.ml @@ -1,5 +1,5 @@ -let () = - Dream.run +let () = Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.router [ diff --git a/example/b-session/dune b/example/b-session/dune index 9a5ed7cc..96f87975 100644 --- a/example/b-session/dune +++ b/example/b-session/dune @@ -1,4 +1,3 @@ (executable (name session) - (libraries dream) - (preprocess (pps lwt_ppx))) + (libraries dream eio_main)) diff --git a/example/b-session/session.ml b/example/b-session/session.ml index 8a0c0458..c5d2dd5f 100644 --- a/example/b-session/session.ml +++ b/example/b-session/session.ml @@ -1,15 +1,15 @@ -let () = - Dream.run +let () = Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.memory_sessions @@ fun request -> match Dream.session_field request "user" with | None -> - let%lwt () = Dream.invalidate_session request in - let%lwt () = Dream.set_session_field request "user" "alice" in + Dream.invalidate_session request; + Dream.set_session_field request "user" "alice"; Dream.html "You weren't logged in; but now you are!" | Some username -> - Printf.ksprintf - Dream.html "Welcome back, %s!" (Dream.html_escape username) + Dream.html + (Printf.sprintf "Welcome back, %s!" (Dream.html_escape username)) diff --git a/example/c-cookie/cookie.ml b/example/c-cookie/cookie.ml index e145e5ee..fee15486 100644 --- a/example/c-cookie/cookie.ml +++ b/example/c-cookie/cookie.ml @@ -1,5 +1,5 @@ -let () = - Dream.run +let () = Eio_main.run @@ fun env -> + Dream.run env @@ Dream.set_secret "foo" @@ Dream.logger @@ fun request -> @@ -13,4 +13,4 @@ let () = let response = Dream.response "Set language preference; come again!" in Dream.add_header response "Content-Type" Dream.text_html; Dream.set_cookie response request "ui.language" "ut-OP"; - Lwt.return response + response diff --git a/example/c-cookie/dune b/example/c-cookie/dune index 1e5f4783..4dc3b0a2 100644 --- a/example/c-cookie/dune +++ b/example/c-cookie/dune @@ -1,3 +1,3 @@ (executable (name cookie) - (libraries dream)) + (libraries dream eio_main)) diff --git a/example/d-form/dune b/example/d-form/dune index c1dc4d72..d5e023e8 100644 --- a/example/d-form/dune +++ b/example/d-form/dune @@ -1,7 +1,6 @@ (executable (name form) - (libraries dream) - (preprocess (pps lwt_ppx))) + (libraries dream eio_main)) (rule (targets form.ml) diff --git a/example/d-form/form.eml.ml b/example/d-form/form.eml.ml index 40fe08fa..00f80d86 100644 --- a/example/d-form/form.eml.ml +++ b/example/d-form/form.eml.ml @@ -16,8 +16,8 @@ let show_form ?message request = -let () = - Dream.run +let () = Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.memory_sessions @@ Dream.router [ @@ -28,7 +28,7 @@ let () = Dream.post "/" (fun request -> - match%lwt Dream.form request with + match Dream.form request with | `Ok ["message", message] -> Dream.html (show_form ~message request) | _ -> diff --git a/example/e-json/dune b/example/e-json/dune index 61243317..f003591f 100644 --- a/example/e-json/dune +++ b/example/e-json/dune @@ -1,4 +1,4 @@ (executable (name json) - (libraries dream) - (preprocess (pps lwt_ppx ppx_yojson_conv))) + (libraries dream eio_main) + (preprocess (pps ppx_yojson_conv))) diff --git a/example/e-json/json.ml b/example/e-json/json.ml index 3d839bf6..39cb2003 100644 --- a/example/e-json/json.ml +++ b/example/e-json/json.ml @@ -4,18 +4,16 @@ type message_object = { message : string; } [@@deriving yojson] -let () = - Dream.run +let () = Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.origin_referrer_check @@ Dream.router [ Dream.post "/" (fun request -> - let%lwt body = Dream.body request in - let message_object = - body + Dream.body request |> Yojson.Safe.from_string |> message_object_of_yojson in diff --git a/example/f-static/dune b/example/f-static/dune index 241ee477..904412d8 100644 --- a/example/f-static/dune +++ b/example/f-static/dune @@ -1,3 +1,3 @@ (executable (name static) - (libraries dream)) + (libraries dream eio_main)) diff --git a/example/f-static/static.ml b/example/f-static/static.ml index daf1c776..feadfc0c 100644 --- a/example/f-static/static.ml +++ b/example/f-static/static.ml @@ -1,6 +1,6 @@ -let () = - Dream.run +let () = Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.router [ - Dream.get "/static/**" (Dream.static ".") + Dream.get "/static/**" (Dream.static (Eio.Stdenv.cwd env)) ] diff --git a/src/cipher/dune b/src/cipher/dune index aedd14ee..cc369878 100644 --- a/src/cipher/dune +++ b/src/cipher/dune @@ -7,5 +7,4 @@ mirage-crypto mirage-crypto-rng ) - (preprocess (pps lwt_ppx)) (instrumentation (backend bisect_ppx))) diff --git a/src/cipher/random.ml b/src/cipher/random.ml index 7d104e7a..8798996b 100644 --- a/src/cipher/random.ml +++ b/src/cipher/random.ml @@ -5,20 +5,7 @@ -(* TODO LATER Is there something with lighter dependencies? Although perhaps - these are not so bad... *) - -let _initialized : unit lazy_t option ref = ref None - -let initialized () = - match !_initialized with - | None -> failwith "Entropy is not initialized." - | Some v -> Lazy.force v - -let initialize f = _initialized := Some (Lazy.from_fun f) - let random_buffer n = - initialized () ; Mirage_crypto_rng.generate n let random n = diff --git a/src/dream.ml b/src/dream.ml index 07b9248a..f9e4d72c 100644 --- a/src/dream.ml +++ b/src/dream.ml @@ -9,14 +9,14 @@ module Catch = Dream__server.Catch module Cipher = Dream__cipher.Cipher module Cookie = Dream__server.Cookie module Csrf = Dream__server.Csrf +module Driver = Dream__http.Driver module Echo = Dream__server.Echo module Error_handler = Dream__http.Error_handler module Flash = Dream__server.Flash module Form = Dream__server.Form module Formats = Dream_pure.Formats -module Graphql = Dream__graphql.Graphql +(* module Graphql = Dream__graphql.Graphql *) module Helpers = Dream__server.Helpers -module Http = Dream__http.Http module Livereload = Dream__server.Livereload module Message = Dream_pure.Message module Method = Dream_pure.Method @@ -54,10 +54,6 @@ let () = let now () = Ptime.to_float_s (Ptime.v (Ptime_clock.now_d_ps ())) -let () = - Random.initialize (fun () -> - Mirage_crypto_rng_lwt.initialize (module Mirage_crypto_rng.Fortuna)) - module Session = struct include Dream__server.Session @@ -77,7 +73,6 @@ type route = Router.route type 'a message = 'a Message.message type client = Message.client type server = Message.server -type 'a promise = 'a Message.promise @@ -262,7 +257,8 @@ let all_session_fields = all_session_values let invalidate_session = Session.invalidate_session let memory_sessions = Session.memory_sessions let cookie_sessions = Session.cookie_sessions -let sql_sessions = Sql_session.sql_sessions +(* let sql_sessions = Sql_session.sql_sessions TODO *) +let sql_sessions ?lifetime _ = ignore lifetime; assert false let session_id = Session.session_id let session_label = Session.session_label let session_expires_at = Session.session_expires_at @@ -280,15 +276,19 @@ let add_flash_message = Flash.put_flash (* GraphQL *) -let graphql = Graphql.graphql -let graphiql = Graphql.graphiql +(* let graphql = Graphql.graphql TODO *) +let graphql _ = assert false +(* let graphiql = Graphql.graphiql TODO *) +let graphiql ?default_query:_ _ = assert false (* SQL *) -let sql_pool = Sql.sql_pool -let sql = Sql.sql +(* let sql_pool = Sql.sql_pool TODO *) +let sql_pool ?size:_ _ = assert false +(* let sql = Sql.sql TODO *) +let sql _ = assert false @@ -348,8 +348,8 @@ let catch = Catch.catch (* Servers *) -let run = Http.run -let serve = Http.serve +let run = Driver.run +let serve = Driver.serve let with_site_prefix = Site_prefix.with_site_prefix @@ -390,7 +390,10 @@ let test ?(prefix = "") handler request = @@ handler in - Lwt_main.run (app request) + (* Lwt_main.run (app request) TODO *) + ignore request; + ignore app; + assert false let sort_headers = Message.sort_headers let echo = Echo.echo diff --git a/src/dream.mli b/src/dream.mli index d92444ef..0779bf86 100644 --- a/src/dream.mli +++ b/src/dream.mli @@ -19,7 +19,7 @@ and response = server message (** The remaining three types are for building up Web apps. *) -and handler = request -> response promise +and handler = request -> response (** Handlers are asynchronous functions from requests to responses. Example {{:https://github.com/aantron/dream/tree/master/example/1-hello#files} [1-hello]} shows the simplest handler, an anonymous function which we pass @@ -119,19 +119,6 @@ and server = Dream_pure.Message.server (* TODO These docs need to be clarified. *) (* TODO Hide all the Dream_pure type equalities. *) -and 'a promise = 'a Lwt.t -(** Dream uses {{:https://github.com/ocsigen/lwt} Lwt} for promises and - asynchronous I/O. See example - {{:https://github.com/aantron/dream/tree/master/example/5-promise#files} - [5-promise]}. - - Use [raise] to reject promises. If you are writing a library, you may prefer - using - {{:https://github.com/ocsigen/lwt/blob/9943ba77a5508feaea5e1fb60b011db4179f9c61/src/core/lwt.mli#L459} - [Lwt.fail]} in some places, in order to avoid clobbering your user's current - exception backtrace — though, in most cases, you should still extend it with - [raise] and [let%lwt], instead. *) - (** {1 Methods} *) @@ -435,15 +422,16 @@ val respond : ?status:[< status ] -> ?code:int -> ?headers:(string * string) list -> - string -> response promise + string -> response (** Same as {!Dream.val-response}, but the new {!type-response} is wrapped in a {!type-promise}. *) +(* TODO Remove, or remove response. *) val html : ?status:[< status ] -> ?code:int -> ?headers:(string * string) list -> - string -> response promise + string -> response (** Same as {!Dream.respond}, but adds [Content-Type: text/html; charset=utf-8]. See {!Dream.text_html}. @@ -457,7 +445,7 @@ val json : ?status:[< status ] -> ?code:int -> ?headers:(string * string) list -> - string -> response promise + string -> response (** Same as {!Dream.respond}, but adds [Content-Type: application/json]. See {!Dream.application_json}. *) @@ -465,7 +453,7 @@ val redirect : ?status:[< redirection ] -> ?code:int -> ?headers:(string * string) list -> - request -> string -> response promise + request -> string -> response (** Creates a new {!type-response}. Adds a [Location:] header with the given string. The default status code is [303 See Other], for a temporary redirection. Use [~status:`Moved_Permanently] or [~code:301] for a permanent @@ -477,9 +465,7 @@ val redirect : The {!type-request} is used for retrieving the site prefix, if the string is an absolute path. Most applications don't have a site prefix. *) -val empty : - ?headers:(string * string) list -> - status -> response promise +val empty : ?headers:(string * string) list -> status -> response (** Same as {!Dream.val-response} with the empty string for a body. *) val status : response -> status @@ -672,7 +658,7 @@ val all_cookies : request -> (string * string) list (** {1 Bodies} *) -val body : 'a message -> string promise +val body : 'a message -> string (** Retrieves the entire body. See example {{:https://github.com/aantron/dream/tree/master/example/6-echo#files} [6-echo]}. *) @@ -695,7 +681,7 @@ val stream : ?code:int -> ?headers:(string * string) list -> ?close:bool -> - (stream -> unit promise) -> response promise + (stream -> unit) -> response (** Creates a response with a {!type-stream} open for writing, and passes the stream to the callback when it is ready. See example {{:https://github.com/aantron/dream/tree/master/example/j-stream#files} @@ -710,22 +696,23 @@ val stream : [Dream.stream] automatically closes the stream when the callback returns or raises an exception. Pass [~close:false] to suppress this behavior. *) -val read : stream -> string option promise +val read : stream -> string option (** Retrieves a body chunk. See example {{:https://github.com/aantron/dream/tree/master/example/j-stream#files} [j-stream]}. *) (* TODO Document difference between receiving a request and receiving on a WebSocket. *) -val write : stream -> string -> unit promise +val write : stream -> string -> unit (** Streams out the string. The promise is fulfilled when the response can accept more writes. *) (* TODO Document clearly which of the writing functions can raise exceptions. *) +(* TODO Fix docs -- no more promise. *) -val flush : stream -> unit promise +val flush : stream -> unit (** Flushes the stream's write buffer. Data is sent to the client. *) -val close : stream -> unit promise +val close : stream -> unit (** Closes the stream. *) (** {2 Low-level streaming} @@ -842,7 +829,7 @@ type websocket val websocket : ?headers:(string * string) list -> ?close:bool -> - (websocket -> unit promise) -> response promise + (websocket -> unit) -> response (** Creates a fresh [101 Switching Protocols] response. Once this response is returned to Dream's HTTP layer, the callback is passed a new {!type-websocket}, and the application can begin using it. See example @@ -868,7 +855,7 @@ type end_of_message = [ `End_of_message | `Continues ] val send : ?text_or_binary:[< text_or_binary ] -> ?end_of_message:[< end_of_message ] -> - websocket -> string -> unit promise + websocket -> string -> unit (** Sends a single WebSocket message. The WebSocket is ready for another message when the promise resolves. @@ -883,16 +870,17 @@ val send : [~end_of_message] is ignored for now, as the WebSocket library underlying Dream does not support sending message fragments yet. *) +(* TODO Docs: there is no more promise here. *) -val receive : websocket -> string option promise +val receive : websocket -> string option (** Receives a message. If the WebSocket is closed before a complete message arrives, the result is [None]. *) val receive_fragment : - websocket -> (string * text_or_binary * end_of_message) option promise + websocket -> (string * text_or_binary * end_of_message) option (** Receives a single fragment of a message, streaming it. *) -val close_websocket : ?code:int -> websocket -> unit promise +val close_websocket : ?code:int -> websocket -> unit (** Closes the WebSocket. [~code] is usually not necessary, but is needed for some protocols based on WebSockets. See {{:https://tools.ietf.org/html/rfc6455#section-7.4} RFC 6455 §7.4}. *) @@ -984,7 +972,7 @@ type 'a form_result = [ activity, or tokens so old that decryption keys have since been rotated on the server. *) -val form : ?csrf:bool -> request -> (string * string) list form_result promise +val form : ?csrf:bool -> request -> (string * string) list form_result (** Parses the request body as a form. Performs CSRF checks. Use {!Dream.csrf_tag} in a form template to transparently generate forms that will pass these checks. See {!section-templates} and example @@ -1078,7 +1066,7 @@ type multipart_form = OWASP {i File Upload Cheat Sheet}} for security precautions for upload forms. *) -val multipart : ?csrf:bool -> request -> multipart_form form_result promise +val multipart : ?csrf:bool -> request -> multipart_form form_result (** Like {!Dream.form}, but also reads files, and [Content-Type:] must be [multipart/form-data]. The CSRF token can be generated in a template with @@ -1110,7 +1098,7 @@ type part = string option * string option * ((string * string) list) Note that, in the general case, [filename] and [headers] are not reliable. [name] is the form field name. *) -val upload : request -> part option promise +val upload : request -> part option (** Retrieves the next upload part. Upon getting [Some (name, filename, headers)] from this function, the user @@ -1129,7 +1117,7 @@ val upload : request -> part option promise [FormData]} in the client to submit [multipart/form-data] by AJAX, and include a custom header. *) -val upload_part : request -> string option promise +val upload_part : request -> string option (** Retrieves a part chunk. *) (** {2 CSRF tokens} @@ -1171,7 +1159,7 @@ val csrf_token : ?valid_for:float -> request -> string in seconds. The default value is one hour ([3600.]). Dream uses signed tokens that are not stored server-side. *) -val verify_csrf_token : request -> string -> csrf_result promise +val verify_csrf_token : request -> string -> csrf_result (** Checks that the CSRF token is valid for the {!type-request}'s session. *) @@ -1475,9 +1463,7 @@ val no_route : route (** {1 Static files} *) -val static : - ?loader:(string -> string -> handler) -> - string -> handler +val static : _ Eio.Path.t -> handler (** Serves static files from a local directory. See example {{:https://github.com/aantron/dream/tree/master/example/f-static#files} [f-static]}. @@ -1507,7 +1493,7 @@ val static : {{:https://github.com/aantron/dream/tree/master/example/w-one-binary#files} [w-one-binary]} for a loader that serves files from memory instead. *) -val from_filesystem : string -> string -> handler +val from_filesystem : _ Eio.Path.t -> string -> handler (** [Dream.from_filesystem local_directory path request] responds with a file from the file system found at [local_directory ^ "/" ^ path]. If such a file does not exist, it responds with [404 Not Found]. @@ -1567,17 +1553,18 @@ val mime_lookup : string -> (string * string) list val session_field : request -> string -> string option (** Value from the request's session. *) -val set_session_field : request -> string -> string -> unit promise +val set_session_field : request -> string -> string -> unit (** Mutates a value in the request's session. The back end may commit the value to storage immediately, so this function returns a promise. *) +(* TODO Remove mention of the promise. *) -val drop_session_field : request -> string -> unit promise +val drop_session_field : request -> string -> unit (** Drops a field from the request's session. *) val all_session_fields : request -> (string * string) list (** Full session dictionary. *) -val invalidate_session : request -> unit promise +val invalidate_session : request -> unit (** Invalidates the request's session, replacing it with a fresh, empty pre-session. *) @@ -1659,7 +1646,8 @@ val add_flash_message : request -> string -> string -> unit OWASP {i GraphQL Cheat Sheet}} for an overview of security topics related to GraphQL. *) -val graphql : (request -> 'a promise) -> 'a Graphql_lwt.Schema.schema -> handler +(* TODO Fix this signature. *) +val graphql : (request -> 'a) -> 'a -> handler (** [Dream.graphql make_context schema] serves the GraphQL [schema]. {[ @@ -1747,7 +1735,8 @@ val graphiql : ?default_query:string -> string -> handler val sql_pool : ?size:int -> string -> middleware (** Makes an SQL connection pool available to its inner handler. *) -val sql : request -> (Caqti_lwt.connection -> 'a promise) -> 'a promise +(* TODO Fix this signature. *) +val sql : request -> ('c -> 'a) -> 'a (** Runs the callback with a connection from the SQL pool. See example {{:https://github.com/aantron/dream/tree/master/example/h-sql#files} [h-sql]}. @@ -2020,7 +2009,7 @@ type error = { [true]. }} *) -type error_handler = error -> response option promise +type error_handler = error -> response option (** Error handlers log errors and convert them into responses. Ignore if using {!Dream.error_template}. @@ -2036,7 +2025,7 @@ type error_handler = error -> response option promise (* TODO Get rid of the option? *) val error_template : - (error -> string -> response -> response promise) -> error_handler + (error -> string -> response -> response) -> error_handler (** Builds an {!error_handler} from a template. See example {{:https://github.com/aantron/dream/tree/master/example/9-error#files} [9-error]}. @@ -2081,7 +2070,7 @@ val debug_error_handler : error_handler (** An {!error_handler} for showing extra information about requests and exceptions, for use during development. *) -val catch : (error -> response promise) -> middleware +val catch : (error -> response) -> middleware (** Forwards exceptions, rejections, and [4xx], [5xx] responses from the application to the error handler. See {!section-errors}. *) (* TODO Error handler should not return an option, and then the type can be @@ -2095,7 +2084,7 @@ val run : ?interface:string -> ?port:int -> ?socket_path:string -> - ?stop:unit promise -> + ?stop:unit -> (* TODO What should this be? And fix the docs. *) ?error_handler:error_handler -> ?tls:bool -> ?certificate_file:string -> @@ -2103,6 +2092,10 @@ val run : ?builtins:bool -> ?greeting:bool -> ?adjust_terminal:bool -> + [> `Generic ] Eio.Net.ty ] Eio.Resource.t; + secure_random:_ Eio.Flow.source; ..> -> handler -> unit (** Runs the Web application represented by the {!handler}, by default at {{:http://localhost:8080} http://localhost:8080}. @@ -2156,13 +2149,17 @@ val serve : ?interface:string -> ?port:int -> ?socket_path:string -> - ?stop:unit promise -> + ?stop:unit -> ?error_handler:error_handler -> ?tls:bool -> ?certificate_file:string -> ?key_file:string -> ?builtins:bool -> - handler -> unit promise + [> `Generic ] Eio.Net.ty ] Eio.Resource.t; + secure_random:_ Eio.Flow.source; ..> -> + handler -> unit (** Like {!Dream.run}, but returns a promise that does not resolve until the server stops listening, instead of calling {{:https://ocsigen.org/lwt/latest/api/Lwt_main#VALrun} [Lwt_main.run]}. @@ -2438,6 +2435,7 @@ val test : ?prefix:string -> handler -> (request -> response) internally to await the response, which is why the response returned from the test is not wrapped in a promise. If you don't need these facilities, you can test [handler] by calling it directly with a request. *) +(* TODO Fix docs. *) val sort_headers : (string * string) list -> (string * string) list (** Sorts headers by name. Headers with the same name are not sorted by value or diff --git a/src/dune b/src/dune index a82c981c..9501c4ee 100644 --- a/src/dune +++ b/src/dune @@ -3,19 +3,15 @@ (wrapped false) (modules dream) (libraries - caqti-lwt dream.cipher - dream.graphql + ; dream.graphql TODO Restore. dream.http dream.server dream.unix dream-pure dream.sql + eio fmt.tty - graphql-lwt logs - lwt - lwt.unix - mirage-crypto-rng-lwt ptime.clock.os )) diff --git a/src/graphql/dune b/src/graphql/dune index 7397ce17..8df3f438 100644 --- a/src/graphql/dune +++ b/src/graphql/dune @@ -6,10 +6,7 @@ dream-pure dream.server graphql_parser - graphql-lwt - lwt str yojson ) - (preprocess (pps lwt_ppx)) (instrumentation (backend bisect_ppx))) diff --git a/src/graphql/graphql.ml b/src/graphql/graphql.ml index 25c548b5..4ec4140b 100644 --- a/src/graphql/graphql.ml +++ b/src/graphql/graphql.ml @@ -24,6 +24,8 @@ module Stream = Dream_pure.Stream https://github.com/enisdenjo/graphql-ws/blob/master/PROTOCOL.md *) +(* TODO Restore. + let log = Log.sub_log "dream.graphql" @@ -345,3 +347,4 @@ let graphiql ?(default_query = "") graphql_endpoint = fun _request -> Helpers.html (Lazy.force html) +*) diff --git a/src/http/adapt.ml b/src/http/adapt.ml index 8f822c0b..02a159fc 100644 --- a/src/http/adapt.ml +++ b/src/http/adapt.ml @@ -5,18 +5,18 @@ -module Httpaf = Dream_httpaf_.Httpaf -module H2 = Dream_h2.H2 - module Stream = Dream_pure.Stream module Message = Dream_pure.Message -let address_to_string : Unix.sockaddr -> string = function - | ADDR_UNIX path -> path - | ADDR_INET (address, port) -> - Printf.sprintf "%s:%i" (Unix.string_of_inet_addr address) port +let address_to_string : Eio.Net.Sockaddr.stream -> string = function + | `Unix path -> path + | `Tcp (address, port) -> + let address = + Eio.Net.Ipaddr.pp (Format.get_str_formatter ()) address; + Format.flush_str_formatter () in + Printf.sprintf "%s:%i" address port @@ -69,6 +69,7 @@ let forward_body_general send () +(* TODO Restore these or analogues. let forward_body (response : Message.response) (body : Httpaf.Body.Writer.t) = @@ -90,3 +91,4 @@ let forward_body_h2 (H2.Body.Writer.write_bigstring body) (H2.Body.Writer.flush body) (fun _code -> H2.Body.Writer.close body) +*) diff --git a/src/http/http.ml b/src/http/driver.ml similarity index 80% rename from src/http/http.ml rename to src/http/driver.ml index 7b77bc41..97e40815 100644 --- a/src/http/http.ml +++ b/src/http/driver.ml @@ -5,13 +5,7 @@ -module Gluten = Dream_gluten.Gluten -module Gluten_lwt_unix = Dream_gluten_lwt_unix.Gluten_lwt_unix -module Httpaf = Dream_httpaf_.Httpaf -module Httpaf_lwt_unix = Dream_httpaf__lwt_unix.Httpaf_lwt_unix -module H2 = Dream_h2.H2 -module H2_lwt_unix = Dream_h2_lwt_unix.H2_lwt_unix -module Websocketaf = Dream_websocketaf.Websocketaf +module Cohttp_http = Http module Catch = Dream__server.Catch module Helpers = Dream__server.Helpers @@ -27,14 +21,90 @@ module Stream = Dream_pure.Stream -let to_dream_method method_ = - Httpaf.Method.to_string method_ |> Method.string_to_method +(* TODO Move somewhere. *) +module Stream_adapter = +struct + type t = { + response : Message.response; + mutable closed : bool; + mutable chunk : Stream.buffer option; + } -let to_httpaf_status status = - Status.status_to_int status |> Httpaf.Status.of_code + let create response = { + response; + closed = false; + chunk = None; + } -let to_h2_status status = - Status.status_to_int status |> H2.Status.of_code + let read_methods = [] + + (* TODO Flush? *) + let rec single_read stream destination = + if stream.closed then + raise End_of_file + else + match stream.chunk with + | Some chunk -> + let chunk_length = Bigarray.Array1.dim chunk in + let bytes_to_provide = min chunk_length (Cstruct.length destination) in + let cstruct = Cstruct.buffer ~len:bytes_to_provide chunk in + Cstruct.blit cstruct 0 destination 0 bytes_to_provide; + begin + if bytes_to_provide = chunk_length then + stream.chunk <- None + else + let chunk = + Bigarray.Array1.sub + chunk bytes_to_provide (chunk_length - bytes_to_provide) in + stream.chunk <- Some chunk + end; + bytes_to_provide + | None -> + (* TODO This seems like the sort of code that would deadlock in some + circumstances; requires careful consideration. *) + let chunk_promise, resolver = Eio.Promise.create () in + let rec chunk_loop () = + Stream.read + (Message.client_stream stream.response) + ~data:begin fun chunk offset length _binary _fin -> + if length = 0 then + chunk_loop () + else + let chunk = Bigarray.Array1.sub chunk offset length in + stream.chunk <- Some chunk; + single_read stream destination + |> Eio.Promise.resolve_ok resolver + end + ~flush:(fun () -> chunk_loop ()) + ~ping:(fun _buffer _length _offset -> chunk_loop ()) + ~pong:(fun _buffer _length _offset -> chunk_loop ()) + ~close:(fun _code -> + stream.closed <- true; + Eio.Promise.resolve_error resolver End_of_file) + ~exn:(fun exn -> + stream.closed <- true; + Eio.Promise.resolve_error resolver exn) + in + chunk_loop (); + Eio.Promise.await_exn chunk_promise +end + + + +let to_dream_method : Cohttp_http.Method.t -> Method.method_ = function + | `GET -> `GET + | `POST -> `POST + | `HEAD -> `HEAD + | `DELETE -> `DELETE + | `PATCH -> `PATCH + | `PUT -> `PUT + | `OPTIONS -> `OPTIONS + | `TRACE -> `TRACE + | `CONNECT -> `CONNECT + | `Other method_ -> `Method method_ + +let to_cohttp_status status = + Status.status_to_int status |> Cohttp_http.Status.of_int let sha1 s = s @@ -62,38 +132,44 @@ let wrap_handler (user's_error_handler : Catch.error_handler) (user's_dream_handler : Message.handler) = - let httpaf_request_handler = fun client_address (conn : _ Gluten.Reqd.t) -> - Log.set_up_exception_hook (); + ignore user's_error_handler; + + let httpaf_request_handler + (connection : Cohttp_eio.Server.conn) + (request : Cohttp_http.Request.t) + (body : Cohttp_eio.Server.body) + : (Cohttp_http.Response.t * Cohttp_eio.Server.body) = - let conn, upgrade = conn.reqd, conn.upgrade in + Log.set_up_exception_hook (); - (* Covert the http/af request to a Dream request. *) - let httpaf_request : Httpaf.Request.t = - Httpaf.Reqd.request conn in + (* Convert the Cohttp request to a Dream request. *) let client = - Adapt.address_to_string client_address in + Adapt.address_to_string (snd (fst connection)) in let method_ = - to_dream_method httpaf_request.meth in + to_dream_method (Cohttp_http.Request.meth request) in let target = - httpaf_request.target in + Cohttp_http.Request.resource request in let headers = - Httpaf.Headers.to_list httpaf_request.headers in + Cohttp_http.Header.to_list (Cohttp_http.Request.headers request) in - let body = - Httpaf.Reqd.request_body conn in (* TODO Review per-chunk allocations. *) (* TODO Should the stream be auto-closed? It doesn't even have a closed state. The whole thing is just a wrapper for whatever the http/af behavior is. *) - let read ~data ~flush:_ ~ping:_ ~pong:_ ~close ~exn:_ = - Httpaf.Body.Reader.schedule_read - body - ~on_eof:(fun () -> close 1000) - ~on_read:(fun buffer ~off ~len -> data buffer off len true false) + let read_buffer = Cstruct.create 16384 in + let read ~data ~flush:_ ~ping:_ ~pong:_ ~close ~exn = + try + let bytes_read = Eio.Flow.single_read body read_buffer in + let slice = Cstruct.sub read_buffer 0 bytes_read in + data (Cstruct.to_bigarray slice) 0 bytes_read true false + with + | End_of_file -> close 1000 + | exn' -> exn exn' in - let close _code = - Httpaf.Body.Reader.close body in + (* let close _code = + Eio.Flow.close body in *) + let close = ignore in let body = Stream.reader ~read ~close ~abort:close in let body = @@ -102,6 +178,19 @@ let wrap_handler let request : Message.request = Helpers.request ~client ~method_ ~target ~tls ~headers body in + let response = user's_dream_handler request in + + let response_body = + Eio.Resource.T + (Stream_adapter.create response, + Eio.Flow.Pi.source (module Stream_adapter)) in + + Cohttp_eio.Server.respond + ~status:(to_cohttp_status (Message.status response)) + ~headers:(Cohttp.Header.of_list (Message.all_headers response)) + ~body:response_body () + in + (* Call the user's handler. If it raises an exception or returns a promise that rejects with an exception, pass the exception up to Httpaf. This will cause it to call its (low-level) error handler with variand `Exn _. @@ -112,6 +201,7 @@ let wrap_handler customizable here. The handler itself is customizable (to catch all) exceptions, and the error callback that gets leaked exceptions is also customizable. *) + (* TODO Restore. Lwt.async begin fun () -> Lwt.catch begin fun () -> (* Do the big call. *) @@ -180,11 +270,13 @@ let wrap_handler Lwt.return_unit end in + *) httpaf_request_handler +(* TODO Restore (* TODO Factor out what is in common between the http/af and h2 handlers. *) let wrap_handler_h2 tls @@ -278,6 +370,7 @@ let wrap_handler_h2 in httpaf_request_handler +*) @@ -286,6 +379,7 @@ let log = +(* type tls_library = { create_handler : certificate_file:string -> @@ -379,11 +473,12 @@ let ocaml_tls = { ~request_handler:(wrap_handler true error_handler handler) ~error_handler:(Error_handler.httpaf error_handler) } +*) let check_headers_middleware next_handler request = - let%lwt response = next_handler request in + let response = next_handler request in let invalid_headers_exist = Message.all_headers response |> List.exists (fun (name, _) -> String.trim name = "") @@ -391,7 +486,7 @@ let check_headers_middleware next_handler request = if invalid_headers_exist then log.warning (fun log -> log ~request "A response header is empty or contains only whitespace"); - Lwt.return response + response let built_in_middleware error_handler = Message.pipeline [ @@ -402,6 +497,7 @@ let built_in_middleware error_handler = let serve_with_details caller_function_for_error_messages tls_library + env ~interface ~network ~stop @@ -411,6 +507,11 @@ let serve_with_details ~builtins user's_dream_handler = + ignore certificate_file; + ignore key_file; + ignore stop; + ignore tls_library; + (* TODO DOC *) (* https://letsencrypt.org/docs/certificates-for-localhost/ *) @@ -422,16 +523,14 @@ let serve_with_details in (* Create the wrapped httpaf or h2 handler from the user's Dream handler. *) - let httpaf_connection_handler = - tls_library.create_handler - ~certificate_file - ~key_file - ~handler:user's_dream_handler - ~error_handler - in + let cohttp_server = + Cohttp_eio.Server.make + () ~callback:(wrap_handler false error_handler user's_dream_handler) in (* TODO Should probably move out to the TLS library options. *) + (* TODO Restore let tls_error_handler = Error_handler.tls error_handler in + *) (* Some parts of the various HTTP servers that are under heavy development ( *cough* Gluten SSL/TLS at the moment) leak exceptions out of the @@ -448,6 +547,7 @@ let serve_with_details be pattern matching on the exception (but that might introduce dependency coupling), or the upstream should be patched to distinguish the errors in some useful way. *) + (* TODO Restore let httpaf_connection_handler client_address socket = Lwt.catch (fun () -> @@ -456,34 +556,52 @@ let serve_with_details tls_error_handler client_address exn; Lwt.return_unit) in + *) (* Look up the low-level address corresponding to the interface. Hopefully, this is a local interface. *) - let%lwt listen_address = + let listen_address = match network with | `Unix path -> - Lwt.return (Lwt_unix.ADDR_UNIX path) + `Unix path | `Inet port -> - let%lwt addresses = - Lwt_unix.getaddrinfo interface (string_of_int port) [] in + let addresses = + Eio.Net.getaddrinfo_stream + env#net interface ~service:(string_of_int port) in match addresses with | [] -> Printf.ksprintf failwith "Dream.%s: no interface with address %s" caller_function_for_error_messages interface | address::_ -> - Lwt.return Lwt_unix.(address.ai_addr) + address in + (* TODO Value of the backlog argument? *) + Eio.Switch.run begin fun sw -> + let socket = + Eio.Net.listen + ~sw env#net listen_address ~reuse_addr:true ~backlog:1000 in + + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env + @@ fun () -> + + (* TODO The error handler. *) + Cohttp_eio.Server.run ~on_error:raise socket cohttp_server + |> ignore + end + + (* TODO Use stop. *) + (* Bring up the HTTP server. Wait for the server to actually get started. Then, wait for the ~stop promise. If the ~stop promise ever resolves, stop the server. *) - let%lwt server = + (* let%lwt server = Lwt_io.establish_server_with_client_socket listen_address httpaf_connection_handler in let%lwt () = stop in - Lwt_io.shutdown_server server + Lwt_io.shutdown_server server *) @@ -492,6 +610,7 @@ let is_localhost interface = let serve_with_maybe_https caller_function_for_error_messages + env ~interface ~network ~stop @@ -502,7 +621,12 @@ let serve_with_maybe_https ~builtins user's_dream_handler = - try%lwt + ignore certificate_file; + ignore certificate_string; + ignore key_file; + ignore key_string; + + try (* This check will at least catch secrets like "foo" when used on a public interface. *) (* if not (is_localhost interface) then @@ -517,7 +641,8 @@ let serve_with_maybe_https | `No -> serve_with_details caller_function_for_error_messages - no_tls + (* TODO no_tls *) () + env ~interface ~network ~stop @@ -527,6 +652,7 @@ let serve_with_maybe_https ~builtins user's_dream_handler +(* TODO Restore | `OpenSSL | `OCaml_TLS as tls_library -> (* TODO Writing temporary files is extremely questionable for anything except the fake localhost certificate. This needs loud warnings. IIRC @@ -622,7 +748,7 @@ let serve_with_maybe_https end end - +*) with exn -> let backtrace = Printexc.get_backtrace () in log.error (fun log -> @@ -636,7 +762,7 @@ let serve_with_maybe_https let default_interface = "localhost" let default_port = 8080 -let never = fst (Lwt.wait ()) +(* let never = fst (Lwt.wait ()) TODO *) let network ~port ~socket_path = match socket_path with @@ -647,21 +773,24 @@ let serve ?(interface = default_interface) ?(port = default_port) ?socket_path - ?(stop = never) + ?(stop = ()) (* TODO *) ?(error_handler = Error_handler.default) ?(tls = false) ?certificate_file ?key_file ?(builtins = true) + env user's_dream_handler = + ignore tls; serve_with_maybe_https "serve" + env ~interface ~network:(network ~port ~socket_path) ~stop ~error_handler - ~tls:(if tls then `OpenSSL else `No) + (* ~tls:(if tls then `OpenSSL else `No) TODO *) ~tls:`No ?certificate_file ?key_file ?certificate_string:None @@ -675,7 +804,7 @@ let run ?(interface = default_interface) ?(port = default_port) ?socket_path - ?(stop = never) + ?(stop = ()) (* TODO *) ?(error_handler = Error_handler.default) ?(tls = false) ?certificate_file @@ -683,6 +812,7 @@ let run ?(builtins = true) ?(greeting = true) ?(adjust_terminal = true) + env user's_dream_handler = let () = if Sys.unix then @@ -749,19 +879,20 @@ let run end; try - Lwt_main.run begin + (* Lwt_main.run begin TODO *) serve_with_maybe_https "run" + env ~interface ~network:(network ~port ~socket_path) ~stop ~error_handler - ~tls:(if tls then `OpenSSL else `No) + (* ~tls:(if tls then `OpenSSL else `No) TODO *) ~tls:`No ?certificate_file ?key_file ?certificate_string:None ?key_string:None ~builtins user's_dream_handler - end; + (* end; TODO *) ; restore_terminal () with exn -> diff --git a/src/http/dune b/src/http/dune index 76ddb65e..1c99b93d 100644 --- a/src/http/dune +++ b/src/http/dune @@ -2,23 +2,15 @@ (public_name dream.http) (name dream__http) (libraries + cohttp-eio digestif dream.certificate dream.cipher dream-pure dream.server - dream-httpaf - dream-httpaf.dream-gluten - dream-httpaf.dream-gluten-lwt-unix - dream-httpaf.dream-h2 - dream-httpaf.dream-h2-lwt-unix - dream-httpaf.dream-httpaf_ - dream-httpaf.dream-httpaf_-lwt-unix - lwt - lwt.unix - lwt_ssl + eio + http + mirage-crypto-rng-eio ssl - dream-httpaf.dream-websocketaf ) - (preprocess (pps lwt_ppx)) (instrumentation (backend bisect_ppx))) diff --git a/src/http/error_handler.ml b/src/http/error_handler.ml index d371ea75..5ecb3c5a 100644 --- a/src/http/error_handler.ml +++ b/src/http/error_handler.ml @@ -5,10 +5,6 @@ -module Httpaf = Dream_httpaf_.Httpaf -module H2 = Dream_h2.H2 -module Websocketaf = Dream_websocketaf.Websocketaf - module Catch = Dream__server.Catch module Error_template = Dream__server.Error_template module Method = Dream_pure.Method @@ -161,7 +157,7 @@ let customize template (error : Catch.error) = Then, call the template, and return the response. *) if not error.will_send_response then - Lwt.return_none + None else let debug_dump = dump error in @@ -181,13 +177,12 @@ let customize template (error : Catch.error) = (* No need to catch errors when calling the template, because every call site of the error handler already has error handlers for catching double faults. *) - let%lwt response = template error debug_dump response in - Lwt.return (Some response) + Some (template error debug_dump response) let default_template _error _debug_dump response = - Lwt.return response + response let debug_template _error debug_dump response = let status = Message.status response in @@ -195,7 +190,7 @@ let debug_template _error debug_dump response = and reason = Status.status_to_string status in Message.set_header response "Content-Type" Dream_pure.Formats.text_html; Message.set_body response (Error_template.render ~debug_dump ~code ~reason); - Lwt.return response + response let default = customize default_template @@ -210,7 +205,8 @@ let debug_error_handler = let double_faults f default = - Lwt.catch f begin fun exn -> + try f () + with exn -> let backtrace = Printexc.get_backtrace () in log.error (fun log -> @@ -221,7 +217,6 @@ let double_faults f default = log.error (fun log -> log "%s" line)); default () - end (* If the user's handler fails to provide a response, return an empty 500 response. Don't return the original response we passed to the error handler, @@ -232,15 +227,14 @@ let double_faults f default = let respond_with_option f = double_faults (fun () -> - f () - |> Lwt.map (function + (* TODO Fix indentation. *) + match f () with | Some response -> response | None -> Message.response - ~status:`Internal_Server_Error Stream.empty Stream.null)) + ~status:`Internal_Server_Error Stream.empty Stream.null) (fun () -> - Message.response ~status:`Internal_Server_Error Stream.empty Stream.null - |> Lwt.return) + Message.response ~status:`Internal_Server_Error Stream.empty Stream.null) @@ -260,6 +254,7 @@ let app +(* TODO Response or adapt. let default_response = function | `Server -> Message.response ~status:`Internal_Server_Error Stream.empty Stream.null @@ -457,3 +452,4 @@ let websocket_handshake } in respond_with_option (fun () -> user's_error_handler error) +*) diff --git a/src/http/error_handler.mli b/src/http/error_handler.mli index f2a06390..a33b5528 100644 --- a/src/http/error_handler.mli +++ b/src/http/error_handler.mli @@ -5,10 +5,6 @@ -module Httpaf = Dream_httpaf_.Httpaf -module H2 = Dream_h2.H2 -module Websocketaf = Dream_websocketaf.Websocketaf - module Catch = Dream__server.Catch module Log = Dream__server.Log module Message = Dream_pure.Message @@ -21,7 +17,7 @@ module Message = Dream_pure.Message val default : Catch.error_handler val debug_error_handler : Catch.error_handler val customize : - (Catch.error -> string -> Message.response -> Message.response Lwt.t) -> + (Catch.error -> string -> Message.response -> Message.response) -> Catch.error_handler @@ -39,8 +35,9 @@ val customize : val app : Catch.error_handler -> - (Catch.error -> Message.response Lwt.t) + (Catch.error -> Message.response) +(* TODO Restore or adapt. val httpaf : Catch.error_handler -> (Unix.sockaddr -> Httpaf.Server_connection.error_handler) @@ -62,6 +59,7 @@ val websocket : val websocket_handshake : Catch.error_handler -> (Message.request -> Message.response -> string -> Message.response Lwt.t) + *) diff --git a/src/pure/dune b/src/pure/dune index 76415568..fa1ac76d 100644 --- a/src/pure/dune +++ b/src/pure/dune @@ -4,10 +4,9 @@ (libraries base64 bigstringaf + eio hmap - lwt uri ptime ) - (preprocess (pps lwt_ppx)) (instrumentation (backend bisect_ppx))) diff --git a/src/pure/message.ml b/src/pure/message.ml index e96da42c..f970435a 100644 --- a/src/pure/message.ml +++ b/src/pure/message.ml @@ -7,8 +7,6 @@ (* Type abbreviations and modules used in defining the primary types *) -type 'a promise = 'a Lwt.t - type 'a field_metadata = { name : string option; show_value : ('a -> string) option; @@ -39,7 +37,7 @@ type 'a message = { mutable headers : (string * string) list; mutable client_stream : Stream.stream; mutable server_stream : Stream.stream; - mutable body : string promise option; + mutable body : string Eio.Promise.or_exn option; mutable fields : Fields.t; } @@ -50,7 +48,7 @@ type response = server message (* Functions of messages *) -type handler = request -> response Lwt.t +type handler = request -> response type middleware = handler -> handler @@ -189,7 +187,8 @@ let lowercase_headers message = let body message = match message.body with - | Some body_promise -> body_promise + | Some body_promise -> + Eio.Promise.await_exn body_promise | None -> let stream = match message.kind with @@ -198,15 +197,16 @@ let body message = in let body_promise = Stream.read_until_close stream in message.body <- Some body_promise; - body_promise + Eio.Promise.await_exn body_promise let set_body message body = - message.body <- Some (Lwt.return body); + message.body <- Some (Eio.Promise.create_resolved (Ok body)); match message.kind with | Request -> message.server_stream <- Stream.string body | Response -> message.client_stream <- Stream.string body let set_content_length_headers message = + (* TODO Restore. if has_header message "Content-Length" then () else @@ -223,6 +223,9 @@ let set_content_length_headers message = | Some body -> let length = string_of_int (String.length body) in add_header message "Content-Length" length + *) + ignore message; + assert false let drop_content_length_headers message = drop_header message "Content-Length"; @@ -236,6 +239,7 @@ let read stream = Stream.read_convenience stream let write stream chunk = + (* TODO Restore. let promise, resolver = Lwt.wait () in let length = String.length chunk in let buffer = Bigstringaf.of_string ~off:0 ~len:length chunk in @@ -246,8 +250,13 @@ let write stream chunk = ~exn:(fun exn -> Lwt.wakeup_later_exn resolver exn) (fun () -> Lwt.wakeup_later resolver ()); promise + *) + ignore stream; + ignore chunk; + assert false let flush stream = + (* TODO Restore. let promise, resolver = Lwt.wait () in Stream.flush stream @@ -255,10 +264,12 @@ let flush stream = ~exn:(fun exn -> Lwt.wakeup_later_exn resolver exn) (Lwt.wakeup_later resolver); promise + *) + ignore stream; + assert false let close stream = - Stream.close stream 1000; - Lwt.return_unit + Stream.close stream 1000 let client_stream message = message.client_stream @@ -288,8 +299,7 @@ let get_websocket response = let close_websocket ?(code = 1000) (client_stream, server_stream) = Stream.close client_stream code; - Stream.close server_stream code; - Lwt.return_unit + Stream.close server_stream code type text_or_binary = [ | `Text @@ -302,6 +312,7 @@ type end_of_message = [ ] let receive_fragment stream = + (* TODO Restore. let promise, resolver = Lwt.wait () in let close _code = Lwt.wakeup_later resolver None in let abort exn = Lwt.wakeup_later_exn resolver exn in @@ -333,12 +344,16 @@ let receive_fragment stream = loop (); promise + *) + ignore stream; + assert false (* TODO This can be optimized by using a buffer, and also by immediately returning the first chunk without accumulation if FIN is set on it. *) (* TODO Test what happens on end of stream without FIN set. The next read should still gracefully return None. *) let receive_full stream = + (* TODO Restore. let rec receive_continuations text_or_binary acc = match%lwt receive_fragment stream with | None -> @@ -355,13 +370,22 @@ let receive_full stream = Lwt.return (Some (fragment, text_or_binary)) | Some (fragment, text_or_binary, `Continues) -> receive_continuations text_or_binary fragment + *) + ignore stream; + assert false let receive stream = + (* TODO Restore. match%lwt receive_full stream with | None -> Lwt.return_none | Some (message, _) -> Lwt.return (Some message) + *) + ignore receive_full; + ignore stream; + assert false let send ?text_or_binary ?end_of_message stream data = + (* TODO Restore. let promise, resolver = Lwt.wait () in let binary = match text_or_binary with @@ -383,6 +407,12 @@ let send ?text_or_binary ?end_of_message stream data = ~exn:(fun exn -> Lwt.wakeup_later_exn resolver exn) (fun () -> Lwt.wakeup_later resolver ()); promise + *) + ignore text_or_binary; + ignore end_of_message; + ignore stream; + ignore data; + assert false diff --git a/src/pure/message.mli b/src/pure/message.mli index b05da05d..55b82827 100644 --- a/src/pure/message.mli +++ b/src/pure/message.mli @@ -15,8 +15,7 @@ type 'a message type request = client message type response = server message -type 'a promise = 'a Lwt.t -type handler = request -> response promise +type handler = request -> response type middleware = handler -> handler @@ -62,17 +61,17 @@ val lowercase_headers : 'a message -> unit -val body : 'a message -> string promise +val body : 'a message -> string val set_body : 'a message -> string -> unit val set_content_length_headers : 'a message -> unit val drop_content_length_headers : 'a message -> unit -val read : Stream.stream -> string option promise -val write : Stream.stream -> string -> unit promise -val flush : Stream.stream -> unit promise -val close : Stream.stream -> unit promise +val read : Stream.stream -> string option +val write : Stream.stream -> string -> unit +val flush : Stream.stream -> unit +val close : Stream.stream -> unit val client_stream : 'a message -> Stream.stream val server_stream : 'a message -> Stream.stream val set_client_stream : 'a message -> Stream.stream -> unit @@ -82,7 +81,7 @@ val set_server_stream : 'a message -> Stream.stream -> unit val create_websocket : response -> (Stream.stream * Stream.stream) val get_websocket : response -> (Stream.stream * Stream.stream) option -val close_websocket : ?code:int -> Stream.stream * Stream.stream -> unit promise +val close_websocket : ?code:int -> Stream.stream * Stream.stream -> unit type text_or_binary = [ | `Text @@ -95,16 +94,15 @@ type end_of_message = [ ] (* TODO This also needs message length limits. *) -val receive : - Stream.stream -> string option promise +val receive : Stream.stream -> string option val receive_fragment : - Stream.stream -> (string * text_or_binary * end_of_message) option promise + Stream.stream -> (string * text_or_binary * end_of_message) option val send : ?text_or_binary:[< text_or_binary ] -> ?end_of_message:[< end_of_message ] -> Stream.stream -> string -> - unit promise + unit diff --git a/src/pure/stream.ml b/src/pure/stream.ml index 72d121db..3179cb9e 100644 --- a/src/pure/stream.ml +++ b/src/pure/stream.ml @@ -8,9 +8,6 @@ type buffer = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t -type 'a promise = - 'a Lwt.t - type read = data:(buffer -> int -> int -> bool -> bool -> unit) -> flush:(unit -> unit) -> @@ -396,6 +393,7 @@ let forward (reader : reader) stream = loop () let read_convenience stream = + (* TODO Restore let promise, resolver = Lwt.wait () in let close _code = Lwt.wakeup_later resolver None in let abort exn = Lwt.wakeup_later_exn resolver exn in @@ -423,19 +421,22 @@ let read_convenience stream = loop (); promise + *) + ignore stream; + assert false (* TODO It's probably best to protect "wakeups" of the promise to prevent Invalid_argument from Lwt. *) let read_until_close stream = - let promise, resolver = Lwt.wait () in + let promise, resolver = Eio.Promise.create () in let length = ref 0 in let buffer = ref (Bigstringaf.create 4096) in let close _code = Bigstringaf.sub !buffer ~off:0 ~len:!length |> Bigstringaf.to_string - |> Lwt.wakeup_later resolver + |> Eio.Promise.resolve_ok resolver in - let abort exn = Lwt.wakeup_later_exn resolver exn in + let abort exn = Eio.Promise.resolve_error resolver exn in let rec loop () = stream.reader.read diff --git a/src/pure/stream.mli b/src/pure/stream.mli index 53e64d6f..fb81964d 100644 --- a/src/pure/stream.mli +++ b/src/pure/stream.mli @@ -15,8 +15,6 @@ type stream type buffer = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t -type 'a promise = - 'a Lwt.t type read = data:(buffer -> int -> int -> bool -> bool -> unit) -> @@ -78,12 +76,14 @@ val abort : stream -> exn -> unit val read : stream -> read (** Awaits the next stream event. See {!Stream.type-read}. *) -val read_convenience : stream -> string option promise +val read_convenience : stream -> string option (** A wrapper around {!Stream.val-read} that converts [~data] with content [s] into [Some s], and [~close] into [None], and uses them to resolve a promise. [~flush] is ignored. *) -val read_until_close : stream -> string promise +(* TODO This should probably do the full read loop, instead of exposing a + promise. *) +val read_until_close : stream -> string Eio.Promise.or_exn (** Reads a stream completely until [~close], and accumulates the data into a string. *) diff --git a/src/server/catch.ml b/src/server/catch.ml index da550b78..78b4c149 100644 --- a/src/server/catch.ml +++ b/src/server/catch.ml @@ -34,7 +34,7 @@ type error = { will_send_response : bool; } -type error_handler = error -> Message.response option Message.promise +type error_handler = error -> Message.response option (* This error handler actually *is* a middleware, but it is just one pathway for reaching the centralized error handler provided by the user, so it is built @@ -42,12 +42,9 @@ type error_handler = error -> Message.response option Message.promise (* TODO The option return value thing is pretty awkward. *) let catch error_handler next_handler request = - - Lwt.try_bind - - (fun () -> - next_handler request) - + match next_handler request with + (* TODO Simplify away the functions. *) + | response -> response |> (fun response -> let status = Message.status response in @@ -74,12 +71,13 @@ let catch error_handler next_handler request = error_handler error end else - Lwt.return response) + response) (* This exception handler is partially redundant, in that the HTTP-level handlers will also catch exceptions. However, this handler is able to capture more relevant context. We leave the HTTP-level handlers for truly severe protocol-level errors and integration mistakes. *) + | exception exn -> exn |> (fun exn -> let error = { condition = `Exn exn; diff --git a/src/server/csrf.ml b/src/server/csrf.ml index 13da958b..60892a14 100644 --- a/src/server/csrf.ml +++ b/src/server/csrf.ml @@ -37,7 +37,7 @@ type csrf_result = [ | `Invalid ] -let verify_csrf_token ~now request token = Lwt.return @@ +let verify_csrf_token ~now request token = match Dream_pure.Formats.from_base64url token with | None -> log.warning (fun log -> log ~request "CSRF token not Base64-encoded"); diff --git a/src/server/dune b/src/server/dune index 4e5125e6..68deee5a 100644 --- a/src/server/dune +++ b/src/server/dune @@ -8,18 +8,15 @@ fmt lambdasoup logs - lwt magic-mime markup mirage-clock multipart_form - multipart_form-lwt ptime unstrctrd uri yojson ) - (preprocess (pps lwt_ppx)) (instrumentation (backend bisect_ppx))) (rule diff --git a/src/server/echo.ml b/src/server/echo.ml index 093c652d..0a26c6c6 100644 --- a/src/server/echo.ml +++ b/src/server/echo.ml @@ -12,4 +12,3 @@ module Stream = Dream_pure.Stream let echo request = Message.response (Message.server_stream request) Stream.null - |> Lwt.return diff --git a/src/server/flash.ml b/src/server/flash.ml index dbec2ee9..87012c26 100644 --- a/src/server/flash.ml +++ b/src/server/flash.ml @@ -77,7 +77,7 @@ let flash_messages inner_handler request = let outbox = ref [] in Message.set_field request storage_field outbox; let existing = Cookie.cookie request flash_cookie in - let%lwt response = inner_handler request in + let response = inner_handler request in let entries = List.rev !outbox in let () = match existing, entries with @@ -102,4 +102,4 @@ let flash_messages inner_handler request = Cookie.set_cookie response request flash_cookie value ~max_age:five_minutes in - Lwt.return response + response diff --git a/src/server/form.ml b/src/server/form.ml index 98f4299f..fd3d3596 100644 --- a/src/server/form.ml +++ b/src/server/form.ml @@ -33,32 +33,32 @@ let sort_and_check_form ~now to_value form request = match csrf_token with | [_, value] -> - begin match%lwt Csrf.verify_csrf_token ~now request (to_value value) with + begin match Csrf.verify_csrf_token ~now request (to_value value) with | `Ok -> - Lwt.return (`Ok form) + `Ok form | `Expired time -> - Lwt.return (`Expired (form, time)) + `Expired (form, time) | `Wrong_session -> - Lwt.return (`Wrong_session form) + `Wrong_session form | `Invalid -> - Lwt.return (`Invalid_token form) + `Invalid_token form end | [] -> log.warning (fun log -> log ~request "CSRF token missing"); - Lwt.return (`Missing_token form) + `Missing_token form | _::_::_ -> log.warning (fun log -> log ~request "CSRF token duplicated"); - Lwt.return (`Many_tokens form) + `Many_tokens form let wrong_content_type request = log.warning (fun log -> log ~request "Content-Type not 'application/x-www-form-urlencoded'"); - Lwt.return `Wrong_content_type + `Wrong_content_type let form ?(csrf = true) ~now request = match Message.header request "Content-Type" with @@ -67,11 +67,11 @@ let form ?(csrf = true) ~now request = | Some content_type -> match String.split_on_char ';' content_type with | "application/x-www-form-urlencoded"::_ -> - let%lwt body = Message.body request in + let body = Message.body request in let form = Formats.from_form_urlencoded body in if csrf then sort_and_check_form ~now (fun string -> string) form request else - Lwt.return (`Ok (sort form)) + `Ok (sort form) | _ -> wrong_content_type request diff --git a/src/server/helpers.ml b/src/server/helpers.ml index 139a3324..5fd82c95 100644 --- a/src/server/helpers.ml +++ b/src/server/helpers.ml @@ -65,17 +65,17 @@ let response_with_body ?status ?code ?headers body = response let respond ?status ?code ?headers body = - Lwt.return (response_with_body ?status ?code ?headers body) + response_with_body ?status ?code ?headers body let html ?status ?code ?headers body = let response = response_with_body ?status ?code ?headers body in Message.set_header response "Content-Type" Formats.text_html; - Lwt.return response + response let json ?status ?code ?headers body = let response = response_with_body ?status ?code ?headers body in Message.set_header response "Content-Type" Formats.application_json; - Lwt.return response + response (* TODO Actually use the request and extract the site prefix. *) let redirect ?status ?code ?headers _request location = @@ -87,7 +87,7 @@ let redirect ?status ?code ?headers _request location = in let response = response_with_body ?status ?code ?headers "" in Message.set_header response "Location" location; - Lwt.return response + response let stream ?status ?code ?headers ?(close = true) callback = let reader, writer = Stream.pipe () in @@ -97,6 +97,9 @@ let stream ?status ?code ?headers ?(close = true) callback = Message.response ?status ?code ?headers client_stream server_stream in (* TODO Make sure the request id is propagated to the callback. *) + (* TODO This needs to become a fiber, or to be called afterwards in the + current fiber, after having Cohttp start the response -- depends on the + semantics of Cohttp. Lwt.async (fun () -> if close then match%lwt callback server_stream with @@ -107,8 +110,11 @@ let stream ?status ?code ?headers ?(close = true) callback = raise exn else callback server_stream); + *) + ignore close; + ignore callback; - Lwt.return response + response let empty ?headers status = respond ?headers ~status "" @@ -125,6 +131,7 @@ let websocket ?headers ?(close = true) callback = let websocket = Message.create_websocket response in (* TODO Make sure the request id is propagated to the callback. *) + (* TODO Get this working, depending on the semantics of Cohttp. Lwt.async (fun () -> if close then match%lwt callback websocket with @@ -135,8 +142,12 @@ let websocket ?headers ?(close = true) callback = raise exn else callback websocket); + *) + ignore websocket; + ignore callback; + ignore close; - Lwt.return response + response let receive (_, server_stream) = Message.receive server_stream diff --git a/src/server/livereload.ml b/src/server/livereload.ml index 399cfbb6..d6db0564 100644 --- a/src/server/livereload.ml +++ b/src/server/livereload.ml @@ -59,14 +59,14 @@ let livereload next_handler request = match Message.target request with | target when target = route -> Helpers.websocket @@ fun socket -> - let%lwt _ = Helpers.receive socket in + ignore (Helpers.receive socket); Message.close_websocket socket | _ -> - let%lwt response = next_handler request in + let response = next_handler request in match Message.header response "Content-Type" with | Some ("text/html" | "text/html; charset=utf-8") -> - let%lwt body = Message.body response in + let body = Message.body response in let soup = Markup.string body |> Markup.parse_html ~context:`Document @@ -75,14 +75,14 @@ let livereload next_handler request = in begin match Soup.Infix.(soup $? "head") with | None -> - Lwt.return response + response | Some head -> Soup.create_element "script" ~inner_text:script |> Soup.append_child head; soup |> Soup.to_string |> Message.set_body response; - Lwt.return response + response end - | _ -> Lwt.return response + | _ -> response diff --git a/src/server/log.ml b/src/server/log.ml index 4718a281..216a999d 100644 --- a/src/server/log.ml +++ b/src/server/log.ml @@ -70,8 +70,10 @@ let logs_lib_tag : string Logs.Tag.def = (* Lwt sequence-associated storage key used to pass request ids for use when ~request is not provided. *) +(* TODO Is there an equivalent mechanism with Eio? let id_lwt_key : string Lwt.key = Lwt.new_key () +*) (* The actual request id "field" associated with each request by the logger. If this field is missing, the logger assigns the request a fresh id. *) @@ -88,9 +90,12 @@ let get_request_id ?request () = | None -> None | Some request -> Message.field request id_field in + (* TODO Re-enable if there is an equivalent mechanism with Eio. match request_id with | Some _ -> request_id | None -> Lwt.get id_lwt_key + *) + request_id (* The current state of the request id sequence. *) let last_id = @@ -383,6 +388,7 @@ let log = let set_up_exception_hook () = + (* TODO Is there an Eio equivalent? if !set_async_exception_hook then begin set_async_exception_hook := false; Lwt.async_exception_hook := fun exn -> @@ -391,6 +397,8 @@ let set_up_exception_hook () = backtrace |> iter_backtrace (fun line -> log.error (fun log -> log "%s" line)) end + *) + () let initialize_log ?(backtraces = true) @@ -481,6 +489,7 @@ struct Message.set_field request id_field id; id in + ignore id; (* TODO Actually use the id. *) (* Identify the request in the log. *) let user_agent = @@ -496,10 +505,9 @@ struct user_agent); (* Call the rest of the app. *) - Lwt.try_bind - (fun () -> - Lwt.with_value id_lwt_key (Some id) (fun () -> - next_handler request)) + (* TODO Simplify the passing of values to the old functions away. *) + match next_handler request with + | response -> response |> (fun response -> (* Log the elapsed time. If the response is a redirection, log the target. *) @@ -534,8 +542,9 @@ struct log.info report end; - Lwt.return response) + response) + | exception exn -> exn |> (fun exn -> let backtrace = Printexc.get_backtrace () in (* In case of exception, log the exception. We alsp log the backtrace @@ -548,7 +557,7 @@ struct backtrace |> iter_backtrace (fun line -> log.warning (fun log -> log "%s" line)); - Lwt.fail exn) + raise exn) end diff --git a/src/server/origin_referrer_check.ml b/src/server/origin_referrer_check.ml index f5177720..8d8dd0ae 100644 --- a/src/server/origin_referrer_check.ml +++ b/src/server/origin_referrer_check.ml @@ -32,7 +32,6 @@ let origin_referrer_check inner_handler request = log.warning (fun log -> log ~request "Origin and Referer headers both missing"); Message.response ~status:`Bad_Request Stream.empty Stream.null - |> Lwt.return (* TODO Also recommend Uri to users. *) | Some origin -> @@ -41,7 +40,6 @@ let origin_referrer_check inner_handler request = | None -> log.warning (fun log -> log ~request "Host header missing"); Message.response ~status:`Bad_Request Stream.empty Stream.null - |> Lwt.return | Some host -> @@ -76,5 +74,4 @@ let origin_referrer_check inner_handler request = log.warning (fun log -> log ~request "Origin-Host mismatch: '%s' vs. '%s'" origin host); Message.response ~status:`Bad_Request Stream.empty Stream.null - |> Lwt.return end diff --git a/src/server/session.ml b/src/server/session.ml index 24942545..ff1c90c7 100644 --- a/src/server/session.ml +++ b/src/server/session.ml @@ -15,14 +15,14 @@ let log = Log.sub_log "dream.session" type 'a back_end = { - load : Message.request -> 'a Lwt.t; - send : 'a -> Message.request -> Message.response -> Message.response Lwt.t; + load : Message.request -> 'a; + send : 'a -> Message.request -> Message.response -> Message.response; } let middleware field back_end = fun inner_handler request -> - let%lwt session = back_end.load request in + let session = back_end.load request in Message.set_field request field session; - let%lwt response = inner_handler request in + let response = inner_handler request in back_end.send session request response let getter field request = @@ -56,9 +56,9 @@ type session = { } type operations = { - put : string -> string -> unit Lwt.t; - drop : string -> unit Lwt.t; - invalidate : unit -> unit Lwt.t; + put : string -> string -> unit; + drop : string -> unit; + invalidate : unit -> unit; mutable dirty : bool; } @@ -125,20 +125,17 @@ struct session.payload |> List.remove_assoc name |> fun dictionary -> (name, value)::dictionary - |> fun dictionary -> session.payload <- dictionary; - Lwt.return_unit + |> fun dictionary -> session.payload <- dictionary let drop session name = session.payload |> List.remove_assoc name - |> fun dictionary -> session.payload <- dictionary; - Lwt.return_unit + |> fun dictionary -> session.payload <- dictionary let invalidate hash_table ~now lifetime operations session = Hashtbl.remove hash_table !session.id; session := create hash_table (now () +. lifetime); - operations.dirty <- true; - Lwt.return_unit + operations.dirty <- true let operations ~now hash_table lifetime session dirty = let rec operations = { @@ -182,7 +179,7 @@ struct in let session = ref session in - Lwt.return (operations ~now:gettimeofday hash_table lifetime session dirty, session) + operations ~now:gettimeofday hash_table lifetime session dirty, session let send ~now (operations, session) request response = if operations.dirty then begin @@ -191,7 +188,7 @@ struct Cookie.set_cookie response request session_cookie id ~encrypt:false ~max_age end; - Lwt.return response + response let back_end ~now lifetime = let hash_table = Hashtbl.create 256 in @@ -222,20 +219,17 @@ struct |> List.remove_assoc name |> fun dictionary -> (name, value)::dictionary |> fun dictionary -> session.payload <- dictionary; - operations.dirty <- true; - Lwt.return_unit + operations.dirty <- true let drop operations session name = session.payload |> List.remove_assoc name |> fun dictionary -> session.payload <- dictionary; - operations.dirty <- true; - Lwt.return_unit + operations.dirty <- true let invalidate ~now lifetime operations session = session := create (now () +. lifetime); - operations.dirty <- true; - Lwt.return_unit + operations.dirty <- true let operations ~now lifetime session dirty = let rec operations = { @@ -301,7 +295,7 @@ struct in let session = ref session in - Lwt.return (operations ~now:gettimeofday lifetime session dirty, session) + operations ~now:gettimeofday lifetime session dirty, session let send ~now (operations, session) request response = if operations.dirty then begin @@ -319,7 +313,7 @@ struct in Cookie.set_cookie response request session_cookie value ~max_age end; - Lwt.return response + response let back_end ~now lifetime = { load = load ~now lifetime; diff --git a/src/server/site_prefix.ml b/src/server/site_prefix.ml index 6a41d2f6..e425d028 100644 --- a/src/server/site_prefix.ml +++ b/src/server/site_prefix.ml @@ -36,7 +36,6 @@ let with_site_prefix prefix = match match_site_prefix prefix (Router.path request) with | None -> Message.response ~status:`Bad_Gateway Stream.empty Stream.null - |> Lwt.return | Some path -> (* TODO This doesn't need to be recomputed on each request - can cache the result in the app. *) diff --git a/src/server/upload.ml b/src/server/upload.ml index e296c8ee..3cc1c395 100644 --- a/src/server/upload.ml +++ b/src/server/upload.ml @@ -19,14 +19,18 @@ type multipart_state = { mutable state_init : bool; mutable name : string option; mutable filename : string option; + (* TODO Restore mutable stream : (< > * Multipart_form.Header.t * string Lwt_stream.t) Lwt_stream.t; + *) } let initial_multipart_state () = { state_init = true; name = None; filename = None; + (* TODO Restore stream = Lwt_stream.of_list []; + *) } (* TODO Dump the value of the multipart state somehow? *) @@ -61,6 +65,7 @@ let field_to_string (request : Message.request) field = let log = Log.sub_log "dream.upload" let upload_part (request : Message.request) = + (* TODO Restore let state = multipart_state request in match%lwt Lwt_stream.peek state.stream with | None -> Lwt.return_none @@ -72,12 +77,16 @@ let upload_part (request : Message.request) = let%lwt () = Lwt_stream.junk state.stream in (* XXX(dinosaure): delete the current part from the [stream]. *) Lwt.return_none + *) + ignore request; + assert false let identify _ = object end type part = string option * string option * ((string * string) list) let rec state (request : Message.request) = + (* TODO Restore let state' = multipart_state request in let stream = state'.stream in match%lwt Lwt_stream.peek stream with @@ -91,8 +100,13 @@ let rec state (request : Message.request) = let part = state'.name, state'.filename, headers in Lwt.return (Some part) + *) + ignore state; + ignore request; + assert false and upload (request : Message.request) = + (* TODO Restore let state' = multipart_state request in match state'.state_init with | false -> @@ -124,12 +138,16 @@ and upload (request : Message.request) = state'.stream <- stream; state'.state_init <- false; state request + *) + ignore request; + assert false type multipart_form = (string * ((string option * string) list)) list module Map = Map.Make (String) let multipart ?(csrf=true) ~now request = + (* TODO Restore let content_type = match Message.header request "Content-Type" with | Some content_type -> Result.to_option (Multipart_form.Content_type.of_string (content_type ^ "\r\n")) @@ -177,3 +195,8 @@ let multipart ?(csrf=true) ~now request = else let form = Form.sort parts in Lwt.return (`Ok form) + *) + ignore csrf; + ignore now; + ignore request; + assert false diff --git a/src/sql/dune b/src/sql/dune index e8bab617..09e36906 100644 --- a/src/sql/dune +++ b/src/sql/dune @@ -3,12 +3,9 @@ (name dream__sql) (libraries caqti - caqti-lwt - caqti-lwt.unix dream.cipher dream-pure dream.server uri yojson) - (preprocess (pps lwt_ppx)) (instrumentation (backend bisect_ppx))) diff --git a/src/sql/session.ml b/src/sql/session.ml index 728fa48b..96963715 100644 --- a/src/sql/session.ml +++ b/src/sql/session.ml @@ -14,6 +14,9 @@ module Session = Dream__server.Session let (|>?) = Option.bind +(* TODO Restore everything here. *) +(* + module type DB = Caqti_lwt.CONNECTION module R = Caqti_request @@ -213,3 +216,4 @@ let back_end lifetime = { let sql_sessions ?(lifetime = Session.two_weeks) = Session.middleware (back_end lifetime) +*) diff --git a/src/sql/sql.ml b/src/sql/sql.ml index e778fd30..531bbc22 100644 --- a/src/sql/sql.ml +++ b/src/sql/sql.ml @@ -13,6 +13,8 @@ module Message = Dream_pure.Message let log = Log.sub_log "dream.sql" +(* TODO Restore everything here. *) +(** (* TODO Debug metadata for the pools. *) let pool_field : (_, Caqti_error.t) Caqti_lwt_unix.Pool.t Message.field = Message.new_field () @@ -81,3 +83,4 @@ let sql request callback = | exception exn -> raise exn) in Caqti_lwt.or_fail result +*) diff --git a/src/unix/dune b/src/unix/dune index 170fa3a8..0b8f9627 100644 --- a/src/unix/dune +++ b/src/unix/dune @@ -5,8 +5,6 @@ digestif dream-pure dream.server - lwt.unix magic-mime ) - (preprocess (pps lwt_ppx)) (instrumentation (backend bisect_ppx))) diff --git a/src/unix/static.ml b/src/unix/static.ml index c3c0470c..e247bfa3 100644 --- a/src/unix/static.ml +++ b/src/unix/static.ml @@ -27,17 +27,15 @@ let mime_lookup filename = ["Content-Type", content_type] let from_filesystem local_root path _ = - let file = Filename.concat local_root path in - Lwt.catch - (fun () -> - Lwt_io.(with_file ~mode:Input file) (fun channel -> - let%lwt content = Lwt_io.read channel in + let (/) = Eio.Path.(/) in + let file = local_root / path in + (* TODO Indentation below. *) + try + let content = Eio.Path.load file in Message.response ~headers:(mime_lookup path) (Stream.string content) Stream.null - |> Lwt.return)) - (fun _exn -> + with _exn -> Message.response ~status:`Not_Found Stream.empty Stream.null - |> Lwt.return) (* TODO Add ETag handling. *) (* TODO Add Content-Length handling? *) @@ -72,20 +70,20 @@ let validate_path request = else None -let static ?(loader = from_filesystem) local_root = fun request -> - +let static local_root = fun request -> if not @@ Method.methods_equal (Message.method_ request) `GET then Message.response ~status:`Not_Found Stream.empty Stream.null - |> Lwt.return else match validate_path request with | None -> Message.response ~status:`Not_Found Stream.empty Stream.null - |> Lwt.return | Some path -> - let%lwt response = loader local_root path request in + (* TODO Using from_filesystem because of row type unification problems in + the phantom type parameters of Eio path capabilities -- a completely + artificial regression. *) + let response = from_filesystem local_root path request in if not (Message.has_header response "Content-Type") then begin match Message.status response with | `OK @@ -97,4 +95,4 @@ let static ?(loader = from_filesystem) local_root = fun request -> | _ -> () end; - Lwt.return response + response