From 6f608d0c3ad562d0eb1dab2fd0cb85e94b6f30c1 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Wed, 19 Jan 2022 08:51:51 +0000 Subject: [PATCH 01/42] Disable openssl for now It segfaults under multicore: see https://github.com/savonet/ocaml-ssl/issues/76 --- src/http/dune | 1 + src/http/http.ml | 3 +++ src/vendor/dune | 2 +- src/vendor/gluten | 2 +- src/vendor/h2 | 2 +- src/vendor/httpaf | 2 +- src/vendor/paf | 2 +- src/vendor/websocketaf | 2 +- 8 files changed, 10 insertions(+), 6 deletions(-) diff --git a/src/http/dune b/src/http/dune index 76ddb65e..b9a7d974 100644 --- a/src/http/dune +++ b/src/http/dune @@ -19,6 +19,7 @@ lwt_ssl ssl dream-httpaf.dream-websocketaf + dream-httpaf.websocketaf ) (preprocess (pps lwt_ppx)) (instrumentation (backend bisect_ppx))) diff --git a/src/http/http.ml b/src/http/http.ml index 10d56902..5f259617 100644 --- a/src/http/http.ml +++ b/src/http/http.ml @@ -310,6 +310,8 @@ let no_tls = { } let openssl = { + create_handler = fun ~certificate_file:_ -> failwith "https://github.com/savonet/ocaml-ssl/issues/76" +(* create_handler = begin fun ~certificate_file ~key_file ~handler @@ -365,6 +367,7 @@ let openssl = { | Some _ -> assert false end; +*) } (* TODO LATER Add ALPN + HTTP/2.0 with ocaml-tls, too. *) diff --git a/src/vendor/dune b/src/vendor/dune index 07b8d615..3341ce42 100644 --- a/src/vendor/dune +++ b/src/vendor/dune @@ -32,7 +32,7 @@ (select ssl_io.ml from - (lwt_ssl -> ssl_io.real.ml) + (lwt_ssl_disabled -> ssl_io.real.ml) (-> ssl_io.dummy.ml)) (select tls_io.ml diff --git a/src/vendor/gluten b/src/vendor/gluten index b2aea887..0c9341a6 160000 --- a/src/vendor/gluten +++ b/src/vendor/gluten @@ -1 +1 @@ -Subproject commit b2aea88753540b4b315d9a242ccb2cdafd18dd91 +Subproject commit 0c9341a64ee7432c7a3e1a5e97b4012fee2775c2 diff --git a/src/vendor/h2 b/src/vendor/h2 index c372c736..fa0c8a47 160000 --- a/src/vendor/h2 +++ b/src/vendor/h2 @@ -1 +1 @@ -Subproject commit c372c736a278e3c5e4ea75adecb2cd400cedcdb1 +Subproject commit fa0c8a4746fdc50183e254f8c08239fc5b67717d diff --git a/src/vendor/httpaf b/src/vendor/httpaf index 340ba8c6..3a74fd88 160000 --- a/src/vendor/httpaf +++ b/src/vendor/httpaf @@ -1 +1 @@ -Subproject commit 340ba8c662a2b1cf3305cd46ad4eee65a6de9b7d +Subproject commit 3a74fd8851e3019f5889ae1bf9350e90ed40017d diff --git a/src/vendor/paf b/src/vendor/paf index 14059ba8..b52b0e6b 160000 --- a/src/vendor/paf +++ b/src/vendor/paf @@ -1 +1 @@ -Subproject commit 14059ba85f886cf6babe9b8ce5a53a5b1f1bf3e8 +Subproject commit b52b0e6be8b7bb6f0dcb84c4d82963114468956a diff --git a/src/vendor/websocketaf b/src/vendor/websocketaf index 7530659c..248a2cb0 160000 --- a/src/vendor/websocketaf +++ b/src/vendor/websocketaf @@ -1 +1 @@ -Subproject commit 7530659c8a3fd1beed5197acde37dc7a20acd0af +Subproject commit 248a2cb0dcffa51996c3ad7643577dce75d67454 From ef7d7befe6c5f1c5f4ccdd6aa2e9d9f59dc9f629 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Tue, 18 Jan 2022 09:13:43 +0000 Subject: [PATCH 02/42] Get rid of stuff that doesn't build --- Makefile | 4 + example/w-fullstack-jsoo/.gitignore | 1 - example/w-fullstack-jsoo/client/client.ml | 7 - example/w-fullstack-jsoo/client/dune | 5 - example/w-fullstack-jsoo/common/common.ml | 3 - example/w-fullstack-jsoo/common/dune | 2 - example/w-fullstack-jsoo/dune | 1 - example/w-fullstack-jsoo/dune-project | 1 - example/w-fullstack-jsoo/server/dune | 8 - example/z-playground/.gitignore | 1 - example/z-playground/README.md | 24 -- example/z-playground/client/client.eml.html | 63 ---- example/z-playground/client/dune | 8 - example/z-playground/client/playground.css | 312 ------------------ example/z-playground/client/playground.js | 113 ------- example/z-playground/dune | 1 - example/z-playground/dune-project | 1 - example/z-playground/package-lock.json | 12 - example/z-playground/package.json | 9 - example/z-playground/runtime/dune | 9 - .../z-playground/runtime/playground.eml.ml | 62 ---- example/z-playground/sandbox/ocaml/keep | 0 example/z-playground/sandbox/reason/keep | 0 example/z-playground/server/build.sh | 13 - example/z-playground/server/deploy.sh | 18 - example/z-playground/server/dune | 4 - .../z-playground/server/playground.service | 17 - example/z-playground/server/setup.sh | 53 --- src/vendor/dune | 1 - test/expect/pure/stream/dune | 5 - 30 files changed, 4 insertions(+), 754 deletions(-) delete mode 100644 example/w-fullstack-jsoo/.gitignore delete mode 100644 example/w-fullstack-jsoo/client/client.ml delete mode 100644 example/w-fullstack-jsoo/client/dune delete mode 100644 example/w-fullstack-jsoo/common/common.ml delete mode 100644 example/w-fullstack-jsoo/common/dune delete mode 100644 example/w-fullstack-jsoo/dune delete mode 100644 example/w-fullstack-jsoo/dune-project delete mode 100644 example/w-fullstack-jsoo/server/dune delete mode 100644 example/z-playground/.gitignore delete mode 100644 example/z-playground/README.md delete mode 100644 example/z-playground/client/client.eml.html delete mode 100644 example/z-playground/client/dune delete mode 100644 example/z-playground/client/playground.css delete mode 100644 example/z-playground/client/playground.js delete mode 100644 example/z-playground/dune delete mode 100644 example/z-playground/dune-project delete mode 100644 example/z-playground/package-lock.json delete mode 100644 example/z-playground/package.json delete mode 100644 example/z-playground/runtime/dune delete mode 100644 example/z-playground/runtime/playground.eml.ml delete mode 100644 example/z-playground/sandbox/ocaml/keep delete mode 100644 example/z-playground/sandbox/reason/keep delete mode 100644 example/z-playground/server/build.sh delete mode 100644 example/z-playground/server/deploy.sh delete mode 100644 example/z-playground/server/dune delete mode 100644 example/z-playground/server/playground.service delete mode 100644 example/z-playground/server/setup.sh delete mode 100644 test/expect/pure/stream/dune diff --git a/Makefile b/Makefile index d50013f1..b79cec96 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,8 @@ .PHONY : build + +default: + @dune build + build : @dune build -p dream-pure,dream-httpaf,dream --no-print-directory @install diff --git a/example/w-fullstack-jsoo/.gitignore b/example/w-fullstack-jsoo/.gitignore deleted file mode 100644 index 980c8512..00000000 --- a/example/w-fullstack-jsoo/.gitignore +++ /dev/null @@ -1 +0,0 @@ -static/ diff --git a/example/w-fullstack-jsoo/client/client.ml b/example/w-fullstack-jsoo/client/client.ml deleted file mode 100644 index 50b65562..00000000 --- a/example/w-fullstack-jsoo/client/client.ml +++ /dev/null @@ -1,7 +0,0 @@ -open Js_of_ocaml - -let () = - let body = Dom_html.getElementById_exn "body" in - let p = Dom_html.(createP document) in - p##.innerHTML := Js.string (Common.greet `Client); - Dom.appendChild body p diff --git a/example/w-fullstack-jsoo/client/dune b/example/w-fullstack-jsoo/client/dune deleted file mode 100644 index 45f19c4d..00000000 --- a/example/w-fullstack-jsoo/client/dune +++ /dev/null @@ -1,5 +0,0 @@ -(executable - (name client) - (modes js) - (libraries common js_of_ocaml) - (preprocess (pps js_of_ocaml-ppx))) diff --git a/example/w-fullstack-jsoo/common/common.ml b/example/w-fullstack-jsoo/common/common.ml deleted file mode 100644 index 6a1a1208..00000000 --- a/example/w-fullstack-jsoo/common/common.ml +++ /dev/null @@ -1,3 +0,0 @@ -let greet = function - | `Server -> "Hello..." - | `Client -> "...world!" diff --git a/example/w-fullstack-jsoo/common/dune b/example/w-fullstack-jsoo/common/dune deleted file mode 100644 index 35b99062..00000000 --- a/example/w-fullstack-jsoo/common/dune +++ /dev/null @@ -1,2 +0,0 @@ -(library - (name common)) diff --git a/example/w-fullstack-jsoo/dune b/example/w-fullstack-jsoo/dune deleted file mode 100644 index 8ab777a7..00000000 --- a/example/w-fullstack-jsoo/dune +++ /dev/null @@ -1 +0,0 @@ -(data_only_dirs _esy esy.lock lib node_modules) diff --git a/example/w-fullstack-jsoo/dune-project b/example/w-fullstack-jsoo/dune-project deleted file mode 100644 index 929c696e..00000000 --- a/example/w-fullstack-jsoo/dune-project +++ /dev/null @@ -1 +0,0 @@ -(lang dune 2.0) diff --git a/example/w-fullstack-jsoo/server/dune b/example/w-fullstack-jsoo/server/dune deleted file mode 100644 index e167254b..00000000 --- a/example/w-fullstack-jsoo/server/dune +++ /dev/null @@ -1,8 +0,0 @@ -(executable - (name server) - (libraries common dream)) - -(rule - (targets server.ml) - (deps server.eml.ml) - (action (run dream_eml %{deps} --workspace %{workspace_root}))) diff --git a/example/z-playground/.gitignore b/example/z-playground/.gitignore deleted file mode 100644 index 3189f954..00000000 --- a/example/z-playground/.gitignore +++ /dev/null @@ -1 +0,0 @@ -!package-lock.json diff --git a/example/z-playground/README.md b/example/z-playground/README.md deleted file mode 100644 index 112aa46c..00000000 --- a/example/z-playground/README.md +++ /dev/null @@ -1,24 +0,0 @@ -# `z-playground` - -
- -This “example” is, in fact, the Dream online playground, running at -[http://dream.as](http://dream.as). - -It's a simple, one-page app that uses a WebSocket to communicates with its -server. The server starts and stops Docker containers that run visitors' code. -An ` - - - - - - diff --git a/example/z-playground/client/dune b/example/z-playground/client/dune deleted file mode 100644 index 6c6dcf4f..00000000 --- a/example/z-playground/client/dune +++ /dev/null @@ -1,8 +0,0 @@ -(library - (name client) - (libraries dream)) - -(rule - (targets client.ml) - (deps client.eml.html) - (action (run dream_eml %{deps} --workspace %{workspace_root}))) diff --git a/example/z-playground/client/playground.css b/example/z-playground/client/playground.css deleted file mode 100644 index 0e0f462a..00000000 --- a/example/z-playground/client/playground.css +++ /dev/null @@ -1,312 +0,0 @@ -/* This file is part of Dream, released under the MIT license. See LICENSE.md - for details, or visit https://github.com/aantron/dream. - - Copyright 2021 Anton Bachin */ - -/* - -Playground layout: 2 panels with normal element and fluid -┌──────────────────────────────────────────────────┐ -│ │ -│ body (desktop) │ -│ │ -│ ┌───────────────────────┐ ┌────────────────────┐ │ -│ │ │ │ │ │ -│ │ ┌───────────────────┐ │ │ ┌────────────────┐ │ │ -│ │ │ │ │ │ │ │ │ │ -│ │ │ .panel-element │ │ │ │ .panel-element │ │ │ -│ │ ├───────────────────┤ │ │ ├────────────────┤ │ │ -│ │ │ │ │ │ │ │ │ │ -│ │ │ .panel-fluid │ │ │ │ .panel-fluid │ │ │ -│ │ │ │ │ │ │ │ │ │ -│ │ │ │ │ │ │ │ │ │ -│ │ │ │ │ │ │ │ │ │ -│ │ │ │ │ │ │ │ │ │ -│ │ │ │ │ │ │ │ │ │ -│ │ │ │ │ │ │ │ │ │ -│ │ │ │ │ │ │ │ │ │ -│ │ │ │ │ │ │ │ │ │ -│ │ │ │ │ │ │ │ │ │ -│ │ │ │ │ │ │ │ │ │ -│ │ │ │ │ │ │ │ │ │ -│ │ │ │ │ │ │ │ │ │ -│ │ │ │ │ │ │ │ │ │ -│ │ └───────────────────┘ │ │ └────────────────┘ │ │ -│ │ │ │ │ │ -│ │ │ │ │ │ -│ └───────────────────────┘ └────────────────────┘ │ -│ │ -└──────────────────────────────────────────────────┘ - -This is on mobile or when pressing Change -┌──────────────────────────────────────────────────┐ -│ │ -│ body (mobile/Change view actived) │ -│ ┌──────────────────────────────────────────────┐ │ -│ │ │ │ -│ │ ┌──────────────────────────────────────────┐ │ │ -│ │ │ .panel-element │ │ │ -│ │ │ │ │ │ -│ │ ├──────────────────────────────────────────┤ │ │ -│ │ │ .panel-fluid │ │ │ -│ │ │ │ │ │ -│ │ │ │ │ │ -│ │ │ │ │ │ -│ │ │ │ │ │ -│ │ └──────────────────────────────────────────┘ │ │ -│ │ │ │ -│ ├──────────────────────────────────────────────┤ │ -│ │ │ │ -│ │ ┌──────────────────────────────────────────┐ │ │ -│ │ │ .panel-element │ │ │ -│ │ │ │ │ │ -│ │ ├──────────────────────────────────────────┤ │ │ -│ │ │ .panel-fluid │ │ │ -│ │ │ │ │ │ -│ │ │ │ │ │ -│ │ │ │ │ │ -│ │ └──────────────────────────────────────────┘ │ │ -│ │ │ │ -│ └──────────────────────────────────────────────┘ │ -│ │ -└──────────────────────────────────────────────────┘ - */ -body { - margin: 0; - font-size: 14px; - line-height: 21px; - color: #ddd; - font-family: -apple-system, BlinkMacSystemFont, Segoe UI, Roboto, Oxygen, Ubuntu, Cantarell, Open Sans, Helvetica Neue, Helvetica, Arial, sans-serif; - display: flex; - height: 100vh; - overflow-y: hidden; -} - -@supports (-webkit-touch-callout: none) { - body { - /* The hack for Safari Mobile hack */ - height: -webkit-fill-available; - } -} - -.panel { - flex: 0 0 50%; - width: 50%; - display: flex; - flex-direction: column; -} -.panel-fluid { - flex: 1 0 auto; - min-height: 300px; -} - -/* - * Change view activation and mobile mode is the same - * Please ensure that they are in perfect sync - */ -body.full-editor { - flex-direction: column; - overflow-y: auto; - height: auto; -} - -.full-editor .panel { - width: 100%; -} - -@media (max-width: 1100px) { - body { - flex-direction: column; - overflow-y: auto; - height: auto; - } - .panel { - width: 100%; - } -} - -#textarea { - position: relative; -} -#textarea .CodeMirror { - height: 100%; - position: absolute; - top: 0; - bottom: 0; - left: 0; - right: 0; -} - -header { - height: 64px; - display: flex; - align-items: center -} -/* Editor */ - -h1 { - margin: 0; - display: inline-block; - margin-left: 24px; - font-weight: normal; -} - -#log { - height: 100px; - margin: 0; - overflow-x: hidden; - padding-left: 34px; - padding-top: 14px; - overflow: auto; -} - -.CodeMirror, #log { - font-family: SFMono-Regular, Consolas, Liberation Mono, Menlo, monospace; -} - -#editor button { - font: inherit; - color: inherit; - margin-left: 2em; - background-color: #4338CA; - font-weight: bold; - border: none; - padding: 4px 8px; - border-radius: 4px; -} - -#editor button:hover { - cursor: pointer; - background-color: #3730A3; -} - -#editor header > a { - color: inherit; - text-decoration: none; - flex: 1; - text-align: right; - margin-right: 24px; -} - -@media (max-width: 550px) { - #editor header > a { - display: none; - } -} - -/* width */ -::-webkit-scrollbar { - width: 10px; - height: 10px; - opacity: 0.2; -} - -/* Track */ -::-webkit-scrollbar-track { - background: rgba(255, 255, 255, 0.2); -} - -/* Handle */ -::-webkit-scrollbar-thumb { - background: #888; -} - -/* Handle on hover */ -::-webkit-scrollbar-thumb:hover { - background: #555; -} - -/* Client */ - -#client header { - background-color: #eee; - box-sizing: border-box; - border-bottom: 1px solid #ccc; - padding: 16px; -} - -#client input { - width: 100%; - height: 100%; - background: none; - border: none; - border: 1px solid #aaa; - padding: 8px; -} - -#client input:focus { - outline: none; -} - -#client iframe { - border: 0; - width: 100%; - background-color: white; -} - - -/* Syntax */ - -.cm-s-dream.CodeMirror, body { - background-color: #181b1e; -} - -.cm-s-dream.CodeMirror, #editor > header { - border-bottom: 1px solid #263838; - box-sizing: border-box; -} - -.cm-s-dream.CodeMirror { - color: #ddd; - border-bottom: 1px solid #2a2a26; -} - -#log { - color: #ddd; -} - -.cm-s-dream .CodeMirror-gutters { - background: none; - border-right: 1px solid #262626; -} - -.cm-s-dream .CodeMirror-linenumber { - color: #999; -} - -.cm-s-dream .cm-keyword, .t-magenta { - color: #ff6c9b; -} - -.cm-s-dream .cm-operator, .t-cyan { - color: #8dc5ff; -} - -.cm-s-dream .cm-string, .t-yellow { - color: #e3db7a; -} - -.cm-s-dream .cm-variable { - color: #ddd; -} - -.cm-s-dream .cm-variable-2, .t-green { - color: #70df5c; -} - -.t-dim { - color: #999; - display: none; -} - -.t-white { - color: #ddd; -} - -.t-red { - color: #ff2300; -} - -.t-blue { - color: #81a2ff; -} diff --git a/example/z-playground/client/playground.js b/example/z-playground/client/playground.js deleted file mode 100644 index aded91d8..00000000 --- a/example/z-playground/client/playground.js +++ /dev/null @@ -1,113 +0,0 @@ -// This file is part of Dream, released under the MIT license. See LICENSE.md -// for details, or visit https://github.com/aantron/dream. -// -// Copyright 2021 Anton Bachin *) - - - -var editor = document.querySelector("#textarea"); -var run = document.querySelector("#run"); -var refresh = document.querySelector("#refresh"); -var address = document.querySelector("input"); -var iframe = document.querySelector("iframe"); -var pre = document.querySelector("pre"); -var chview = document.querySelector("#chview"); - -var codemirror = CodeMirror(editor, { - theme: "material dream", - lineNumbers: true, - tabSize: 2, - extraKeys: { - "Tab": function (editor) { - if (editor.somethingSelected()) - editor.execCommand("indentMore"); - else - editor.execCommand("insertSoftTab"); - } - } -}); - -function colorizeLog(string) { - return string - .replace(/&/g, "&") - .replace(//g, ">") - .replace(/"/g, """) - .replace(/'/g, "'") - .replace(/\033\[\?7l/g, "") - .replace(/\033\[2m/g, "") - .replace(/\033\[35m\033\[3m/g, "") - .replace(/\033\[36m\033\[3m/g, "") - .replace(/\033\[37m\033\[3m/g, "") - .replace(/\033\[0;35m\033\[0m/g, "") - .replace(/\033\[0;36m\033\[0m/g, "") - .replace(/\033\[0;37m\033\[0m/g, "") - .replace(/\033\[31m/g, "") - .replace(/\033\[32m/g, "") - .replace(/\033\[33m/g, "") - .replace(/\033\[34m/g, "") - .replace(/\033\[35m/g, "") - .replace(/\033\[36m/g, "") - .replace(/\033\[37m/g, "") - .replace(/\033\[0m/g, "") - ; -}; - -var components = window.location.pathname.split("/"); -var sandbox = components[1]; -sandbox = sandbox || "ocaml"; -var socket = - new WebSocket("ws://" + window.location.host + "/socket?sandbox=" + sandbox); - -var path = components.slice(2).join("/"); -if (path !== "") - path = "/" + path; - -var firstStart = true; - -socket.onmessage = function (e) { - var message = JSON.parse(e.data); - switch (message.kind) { - case "content": - codemirror.setValue(message.payload); - pre.innerHTML += "Building image...\n"; - socket.send(codemirror.getValue()); - break; - - case "log": - pre.innerHTML += colorizeLog(message.payload); - pre.scrollTop = pre.scrollHeight; - break; - - case "started": { - var frame_location = - window.location.protocol + "//" + - window.location.hostname + ":" + message.port + path + location.search; - iframe.src = frame_location; - address.value = frame_location; - history.replaceState( - null, "", "/" + message.sandbox + path + location.search); - if (firstStart) - firstStart = false; - else - pre.scrollIntoView(); - break; - } - } -}; - -run.onclick = function () { - pre.innerHTML += "Building image...\n"; - pre.scrollTop = pre.scrollHeight; - socket.send(codemirror.getValue()); -}; - -chview.onclick = function(){ - var body = document.body; - body.classList.toggle("full-editor") -} - -address.onkeyup = function (event) { - if (event.keyCode === 13) - iframe.src = this.value; -}; diff --git a/example/z-playground/dune b/example/z-playground/dune deleted file mode 100644 index 8ab777a7..00000000 --- a/example/z-playground/dune +++ /dev/null @@ -1 +0,0 @@ -(data_only_dirs _esy esy.lock lib node_modules) diff --git a/example/z-playground/dune-project b/example/z-playground/dune-project deleted file mode 100644 index 929c696e..00000000 --- a/example/z-playground/dune-project +++ /dev/null @@ -1 +0,0 @@ -(lang dune 2.0) diff --git a/example/z-playground/package-lock.json b/example/z-playground/package-lock.json deleted file mode 100644 index f34206be..00000000 --- a/example/z-playground/package-lock.json +++ /dev/null @@ -1,12 +0,0 @@ -{ - "name": "dream-playground", - "requires": true, - "lockfileVersion": 1, - "dependencies": { - "codemirror": { - "version": "5.61.0", - "resolved": "https://registry.npmjs.org/codemirror/-/codemirror-5.61.0.tgz", - "integrity": "sha512-D3wYH90tYY1BsKlUe0oNj2JAhQ9TepkD51auk3N7q+4uz7A/cgJ5JsWHreT0PqieW1QhOuqxQ2reCXV1YXzecg==" - } - } -} diff --git a/example/z-playground/package.json b/example/z-playground/package.json deleted file mode 100644 index 224b9483..00000000 --- a/example/z-playground/package.json +++ /dev/null @@ -1,9 +0,0 @@ -{ - "name": "dream-playground", - "dependencies": { - "codemirror": "*" - }, - "scripts": { - "start": "npm run bundle && opam exec -- dune exec server/playground.exe" - } -} diff --git a/example/z-playground/runtime/dune b/example/z-playground/runtime/dune deleted file mode 100644 index 0a30838c..00000000 --- a/example/z-playground/runtime/dune +++ /dev/null @@ -1,9 +0,0 @@ -(library - (name runtime) - (wrapped false) - (libraries dream)) - -(rule - (targets playground.ml) - (deps playground.eml.ml) - (action (run dream_eml %{deps} --workspace %{workspace_root}))) diff --git a/example/z-playground/runtime/playground.eml.ml b/example/z-playground/runtime/playground.eml.ml deleted file mode 100644 index c959f54f..00000000 --- a/example/z-playground/runtime/playground.eml.ml +++ /dev/null @@ -1,62 +0,0 @@ -(* This file is part of Dream, released under the MIT license. See LICENSE.md - for details, or visit https://github.com/aantron/dream. - - Copyright 2021 Anton Bachin *) - - - -let welcome = - - - - - - - - -

Welcome to the Dream Playground!

-

- Edit the code to the left, and press Run to recompile! Use - the navigation bar above to visit different paths on your server. Many of - the - examples are loaded into the playground. For example, try - dream.as/2-middleware. -

-

Links:

- -

Loaded examples:

- - - diff --git a/example/z-playground/sandbox/ocaml/keep b/example/z-playground/sandbox/ocaml/keep deleted file mode 100644 index e69de29b..00000000 diff --git a/example/z-playground/sandbox/reason/keep b/example/z-playground/sandbox/reason/keep deleted file mode 100644 index e69de29b..00000000 diff --git a/example/z-playground/server/build.sh b/example/z-playground/server/build.sh deleted file mode 100644 index 9e5e4101..00000000 --- a/example/z-playground/server/build.sh +++ /dev/null @@ -1,13 +0,0 @@ -#!/bin/bash - -set -e -set -x - -mkdir -p static -cp node_modules/codemirror/lib/codemirror.js static/ -cp node_modules/codemirror/lib/codemirror.css static/ -cp node_modules/codemirror/theme/material.css static/ -cp node_modules/codemirror/mode/mllike/mllike.js static/ -cp client/playground.css static/ -cp client/playground.js static/ -opam exec -- dune build server/playground.exe diff --git a/example/z-playground/server/deploy.sh b/example/z-playground/server/deploy.sh deleted file mode 100644 index ba2ba326..00000000 --- a/example/z-playground/server/deploy.sh +++ /dev/null @@ -1,18 +0,0 @@ -#!/bin/bash - -set -e -set -x - -sudo cp \ - /home/playground/playground/example/z-playground/server/playground.service \ - /etc/systemd/system -sudo chmod a-x /etc/systemd/system/playground.service -sudo systemctl daemon-reload -sudo systemctl stop playground -(cd /home/playground/playground/example/z-playground \ - && sudo -H -u playground bash server/build.sh) -sudo cp \ - /home/playground/playground/_build/default/example/z-playground/server/playground.exe \ - /usr/local/bin/playground -sudo chown root:root /usr/local/bin/playground -sudo systemctl start playground diff --git a/example/z-playground/server/dune b/example/z-playground/server/dune deleted file mode 100644 index ce57b96e..00000000 --- a/example/z-playground/server/dune +++ /dev/null @@ -1,4 +0,0 @@ -(executable - (name playground) - (libraries client dream) - (preprocess (pps lwt_ppx))) diff --git a/example/z-playground/server/playground.service b/example/z-playground/server/playground.service deleted file mode 100644 index 732c14d6..00000000 --- a/example/z-playground/server/playground.service +++ /dev/null @@ -1,17 +0,0 @@ -[Unit] -Description=Dream Playground -After=network.target -Requires=docker.service - -[Service] -Type=simple -User=playground -Restart=on-failure -RestartSec=1 -StandardOutput=journal -WorkingDirectory=/home/playground/playground/example/z-playground -ExecStart=/usr/local/bin/playground -AmbientCapabilities=CAP_NET_BIND_SERVICE - -[Install] -WantedBy=multi-user.target diff --git a/example/z-playground/server/setup.sh b/example/z-playground/server/setup.sh deleted file mode 100644 index 2657f90b..00000000 --- a/example/z-playground/server/setup.sh +++ /dev/null @@ -1,53 +0,0 @@ -#!/bin/bash - -# Upon getting a fresh Droplet (virtual machine), the system packages inside the -# image it was made from are likely somewhat out of date. Upgrade them -# immediately. -sudo apt update -sudo apt -y upgrade - -# A restart is likely needed, as there is often a kernel upgrade. -sudo init 6 - -# Install the latest Docker. We use an APT repository for the absolute latest -# release, including all the latest security features. The commands are based on -# https://www.digitalocean.com/community/tutorials/how-to-install-and-use-docker-on-ubuntu-20-04 -curl -fsSL https://download.docker.com/linux/ubuntu/gpg | sudo apt-key add - -sudo add-apt-repository "deb [arch=amd64] https://download.docker.com/linux/ubuntu focal stable" -sudo apt update -sudo apt install -y docker-ce - -# Install packages required for building OCaml projects and opam, including a C -# compiler as part of build-essential. -sudo apt install -y build-essential m4 unzip bubblewrap pkg-config - -# Install opam itself. -wget -O opam https://github.com/ocaml/opam/releases/download/2.0.8/opam-2.0.8-x86_64-linux -sudo mv opam /usr/local/bin/ -sudo chmod a+x /usr/local/bin/opam - -# Install npm, which we use to build the client. -sudo apt install -y npm - -# Install system libraries that will be needed by Dream. -sudo apt install -y libev-dev libsqlite3-dev libssl-dev pkg-config - -# Create users. User playground is used for building and running the playground. -# The reason there isn't a separate user for buulding it is that the playground -# itself will use the build setup to build the sandboxes. User sandbox is for -# the containers. -sudo adduser --disabled-password playground -sudo usermod -a -G docker playground -sudo -H -u playground mkdir /home/playground/.ssh -m 700 -sudo cp .ssh/authorized_keys /home/playground/.ssh/ -sudo chown playground:playground /home/playground/.ssh/authorized_keys -sudo adduser --system sandbox - -# Initialize opam and install a compiler. -sudo -H -u playground opam init --no-setup --bare -sudo -H -u playground opam switch create 4.12.0 - -# Set up UFW. -sudo ufw allow ssh -sudo ufw allow http -sudo ufw enable diff --git a/src/vendor/dune b/src/vendor/dune index 3341ce42..8e3c810b 100644 --- a/src/vendor/dune +++ b/src/vendor/dune @@ -1,7 +1,6 @@ (data_only_dirs *) - (subdir gluten/lib (library (name dream_gluten) diff --git a/test/expect/pure/stream/dune b/test/expect/pure/stream/dune deleted file mode 100644 index b012b025..00000000 --- a/test/expect/pure/stream/dune +++ /dev/null @@ -1,5 +0,0 @@ -(library - (name test_expect_pure_stream) - (libraries test_expect_pure) - (inline_tests) - (preprocess (pps lwt_ppx ppx_expect))) From 6c4ed2dff220f7374673a70f3a3b0d45be3787ab Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Mon, 3 Apr 2023 10:36:36 +0200 Subject: [PATCH 03/42] Initial port to Eio This is a proof-of-concept port of Dream to Eio. Most of the public API in dream.mli has been changed to no longer use promises and the main tutorial examples (`[1-9a-l]-*`) have been updated and are working. The documentation mostly hasn't been updated. Internally, it's still using Lwt in many places, using Lwt_eio to convert between them. The main changes are: - User code doesn't need to use lwt (or lwt_ppx) now for Dream stuff. However, the SQL example still uses lwt for the Caqti callback. - Dream servers must be wrapped in an `Eio_main.run`. Unlike Lwt, where you can somewhat get away with running other services with `Lwt.async` before `Dream.run` and relying on the mainloop picking them up later, everything in Eio must be started from inside the loop. Personally, I think this is clearer and less magical, making it obvious that Dream can run alongside other Eio code, but obviously Dream had previously made the choice to hide the `Lwt_main.run` by default. - `Dream.run` now takes an `env` argument (from `Eio_main.run`), granting it access to the environment. At present, it uses this just to start `Lwt_eio`, but once fully converted it should also use it to listen on the network and read certificates, etc. Error handling isn't quite right yet. Ideally, we'd create a new Eio switch for each new connection, and that would get the errors. However, connection creation is currently handled by Lwt. Also, it still tries to attach the request ID to the Lwt thread for logging, which likely won't work. I should provide a way to add log tags to fibres in Eio. Note: `example/k-websocket` logs `Async exception: (Failure "cannot write to closed writer")`. It does that on `master` with Lwt too. --- example/1-hello/README.md | 11 ++- example/1-hello/hello.ml | 6 +- example/2-middleware/README.md | 10 +-- example/2-middleware/middleware.ml | 3 +- example/3-router/router.ml | 3 +- example/4-counter/counter.ml | 3 +- example/5-promise/README.md | 57 +++------------ example/5-promise/dune | 3 +- example/5-promise/promise.ml | 10 +-- example/6-echo/dune | 3 +- example/6-echo/echo.ml | 5 +- example/7-template/README.md | 3 +- example/7-template/template.eml.ml | 3 +- example/8-debug/debug.ml | 3 +- example/9-error/error.eml.ml | 5 +- example/a-log/log.ml | 3 +- example/b-session/dune | 3 +- example/b-session/session.ml | 7 +- example/c-cookie/cookie.ml | 5 +- example/d-form/dune | 3 +- example/d-form/form.eml.ml | 5 +- example/e-json/README.md | 2 +- example/e-json/dune | 2 +- example/e-json/json.ml | 7 +- example/f-static/static.ml | 3 +- example/g-upload/dune | 3 +- example/g-upload/upload.eml.ml | 5 +- example/h-sql/sql.eml.ml | 9 +-- example/i-graphql/graphql.ml | 3 +- example/j-stream/dune | 3 +- example/j-stream/stream.ml | 3 +- example/k-websocket/dune | 3 +- example/k-websocket/websocket.eml.ml | 11 +-- example/l-https/https.ml | 3 +- example/r-advanced-template/template.eml.re | 51 +++++++++++++ .../r-fullstack-melange/server/server.eml.re | 3 +- example/r-graphql/graphql.re | 3 +- example/r-hello/hello.re | 3 +- example/r-template-files/server.re | 3 +- .../r-template-stream/template_stream.eml.re | 21 +++++- example/r-template/template.eml.re | 3 +- example/r-tyxml/tyxml.re | 3 +- example/w-advanced-template/template.eml.ml | 57 +++++++++++++++ example/w-chat/chat.eml.ml | 16 +++-- .../content_security_policy.eml.ml | 5 +- example/w-esy/hello.ml | 3 +- example/w-flash/flash.eml.ml | 5 +- example/w-fswatch/hello.ml | 3 +- .../w-fullstack-rescript/server/server.eml.ml | 3 +- .../graphql_subscription.ml | 3 +- example/w-live-reload/live_reload.ml | 19 ++--- example/w-long-polling/long_polling.eml.ml | 59 +++++++++------ .../w-multipart-dump/multipart_dump.eml.ml | 5 +- example/w-nginx/server.eml.ml | 3 +- example/w-one-binary/one_binary.ml | 3 +- example/w-postgres/postgres.eml.ml | 9 +-- example/w-query/query.ml | 3 +- .../server_sent_events.eml.ml | 47 +++++++----- example/w-stress-response/stress_response.ml | 26 +++---- .../stress_websocket_send.eml.ml | 24 ++++--- example/w-template-files/server.ml | 3 +- .../w-template-stream/template_stream.eml.ml | 19 ++++- example/w-tyxml/tyxml.ml | 3 +- example/w-upload-stream/upload_stream.eml.ml | 7 +- example/z-docker-esy/app.ml | 3 +- example/z-docker-opam/app.ml | 3 +- example/z-fly/app.ml | 3 +- example/z-heroku/app.ml | 3 +- example/z-systemd/app.ml | 3 +- src/dream.ml | 18 +++-- src/dream.mli | 39 +++++----- src/eml/eml.ml | 16 ++--- src/graphql/graphql.ml | 46 ++++++------ src/http/dune | 2 + src/http/error_handler.ml | 34 ++++----- src/http/error_handler.mli | 6 +- src/http/http.ml | 71 ++++++++++--------- src/pure/dune | 1 + src/pure/message.ml | 3 +- src/pure/message.mli | 2 +- src/server/catch.ml | 16 ++--- src/server/content_length.ml | 24 +++++++ src/server/dune | 1 + src/server/echo.ml | 1 - src/server/flash.ml | 4 +- src/server/helpers.ml | 60 ++++++++++++++-- src/server/log.ml | 30 ++++---- src/server/lowercase_headers.ml | 23 ++++++ src/server/origin_referrer_check.ml | 3 - src/server/session.ml | 22 +++--- src/server/site_prefix.ml | 1 - src/sql/session.ml | 18 +++-- src/unix/static.ml | 24 +++---- 93 files changed, 698 insertions(+), 408 deletions(-) create mode 100644 example/r-advanced-template/template.eml.re create mode 100644 example/w-advanced-template/template.eml.ml create mode 100644 src/server/content_length.ml create mode 100644 src/server/lowercase_headers.ml diff --git a/example/1-hello/README.md b/example/1-hello/README.md index 9de605ca..22909023 100644 --- a/example/1-hello/README.md +++ b/example/1-hello/README.md @@ -6,8 +6,10 @@ This project is so simple that it doesn't even log requests! ```ocaml let () = - Dream.run (fun _ -> - Dream.html "Good morning, world!") + Eio_main.run (fun env -> + Dream.run env (fun _ -> + Dream.html "Good morning, world!") + ) ```
@@ -39,6 +41,11 @@ name of the `.ml` file, but with `.ml` changed to `.exe`.
+A Dream server runs in an [Eio](https://github.com/ocaml-multicore/eio) event loop, +which is created by `Eio_main.run`. + +
+ **Next steps:** - The next example, [**`2-middleware`**](../2-middleware#files), adds a logger diff --git a/example/1-hello/hello.ml b/example/1-hello/hello.ml index 5411c9ee..83de636c 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 (fun env -> + Dream.run env (fun _ -> + Dream.html "Good morning, world!") + ) diff --git a/example/2-middleware/README.md b/example/2-middleware/README.md index 5ec6b67e..3949861e 100644 --- a/example/2-middleware/README.md +++ b/example/2-middleware/README.md @@ -9,9 +9,10 @@ middlewares, the [*logger*](https://aantron.github.io/dream/#val-logger): ```ocaml let () = - Dream.run - (Dream.logger (fun _ -> - Dream.html "Good morning, world!")) + Eio_main.run (fun env -> + Dream.run env + (Dream.logger (fun _ -> + Dream.html "Good morning, world!"))) ```
@@ -25,7 +26,8 @@ in this example looks like this: ```ocaml let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ fun _ -> Dream.html "Good morning, world!" ``` diff --git a/example/2-middleware/middleware.ml b/example/2-middleware/middleware.ml index a35eb21d..c04d64f5 100644 --- a/example/2-middleware/middleware.ml +++ b/example/2-middleware/middleware.ml @@ -1,4 +1,5 @@ let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ fun _ -> Dream.html "Good morning, world!" diff --git a/example/3-router/router.ml b/example/3-router/router.ml index fb1a9dab..fc0ede3a 100644 --- a/example/3-router/router.ml +++ b/example/3-router/router.ml @@ -1,5 +1,6 @@ let () = - Dream.run + 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..6581b441 100644 --- a/example/4-counter/counter.ml +++ b/example/4-counter/counter.ml @@ -5,7 +5,8 @@ let count_requests inner_handler request = inner_handler request let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ count_requests @@ Dream.router [ diff --git a/example/5-promise/README.md b/example/5-promise/README.md index a8d932e3..63e7575e 100644 --- a/example/5-promise/README.md +++ b/example/5-promise/README.md @@ -1,29 +1,30 @@ # `5-promise` +(note this example is now badly named, as it doesn't use any promises) +
[**`4-counter`**](../4-counter#files) was limited to counting requests *before* -passing them on to the rest of the app. With the promise library -[Lwt](https://github.com/ocsigen/lwt), we can await responses, and do something -*after*. In this example, we separately count requests that were handled -successfully, and those that caused an exception: +passing them on to the rest of the app. We can also await responses, and do +something *after*. In this example, we separately count requests that were +handled successfully, and those that caused an exception: ```ocaml let successful = ref 0 let failed = ref 0 let count_requests inner_handler request = - try%lwt - let%lwt response = inner_handler request in + try + let response = inner_handler request in successful := !successful + 1; - Lwt.return response - + response with exn -> failed := !failed + 1; raise exn let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ count_requests @@ Dream.router [ @@ -48,49 +49,13 @@ Try it in the [playground](http://dream.as/5-promise).
-As you can see, the -[core constructs](https://ocsigen.org/lwt/latest/api/Ppx_lwt) of Lwt are: - -- `let%lwt` to await the result of a promise. -- `try%lwt` to catch both exceptions and rejections. Lwt promises can only be - rejected with exceptions, of OCaml type `exn`. -- `Lwt.return` to resolve a promise. - -Besides these, Lwt has a lot of [convenience -functions](https://ocsigen.org/lwt/latest/api/Lwt), and an [asychronous -I/O library](https://ocsigen.org/lwt/latest/api/Lwt_unix). +As you can see, we use `try` to catch both exceptions and rejections.
-To use `let%lwt`, we need to modify our -[`dune`](https://github.com/aantron/dream/blob/master/example/5-promise/dune) -file a bit to include `lwt_ppx`: - -
(executable
- (name promise)
- (libraries dream)
- (preprocess (pps lwt_ppx)))
-
- -There are other ways to write *await* and *catch* in Lwt that don't require -`lwt_ppx`, but `lwt_ppx` is presently the best for preserving nice stack traces. -For example, `let%lwt` is equivalent to... - -- [`Lwt.bind`](https://github.com/ocsigen/lwt/blob/c5f895e35a38df2d06f19fd23bf553129b9e95b3/src/core/lwt.mli#L475), - which is almost never used directly. -- [`>>=`](https://github.com/ocsigen/lwt/blob/c5f895e35a38df2d06f19fd23bf553129b9e95b3/src/core/lwt.mli#L1395) - from module `Lwt.Infix`. -- [`let*`](https://github.com/ocsigen/lwt/blob/c5f895e35a38df2d06f19fd23bf553129b9e95b3/src/core/lwt.mli#L1511) - from module `Lwt.Syntax`, which is showcased in Lwt's - [README](https://github.com/ocsigen/lwt#readme). - -We will stick to `let%lwt` in the examples and keep things tidy. - -
- **Next steps:** - [**`6-echo`**](../6-echo#files) uses Dream and Lwt to read a request body. diff --git a/example/5-promise/dune b/example/5-promise/dune index 438ffc03..b5b1aa57 100644 --- a/example/5-promise/dune +++ b/example/5-promise/dune @@ -1,6 +1,5 @@ (executable (name promise) - (libraries dream) - (preprocess (pps lwt_ppx))) + (libraries dream)) (data_only_dirs _esy esy.lock lib node_modules) diff --git a/example/5-promise/promise.ml b/example/5-promise/promise.ml index ffa27902..c31d5305 100644 --- a/example/5-promise/promise.ml +++ b/example/5-promise/promise.ml @@ -2,17 +2,17 @@ let successful = ref 0 let failed = ref 0 let count_requests inner_handler request = - try%lwt - let%lwt response = inner_handler request in + try + let response = inner_handler request in successful := !successful + 1; - Lwt.return response - + response with exn -> failed := !failed + 1; raise exn let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ count_requests @@ Dream.router [ diff --git a/example/6-echo/dune b/example/6-echo/dune index aeebe713..8784a629 100644 --- a/example/6-echo/dune +++ b/example/6-echo/dune @@ -1,6 +1,5 @@ (executable (name echo) - (libraries dream) - (preprocess (pps lwt_ppx))) + (libraries dream)) (data_only_dirs _esy esy.lock lib node_modules) diff --git a/example/6-echo/echo.ml b/example/6-echo/echo.ml index 4f63612c..bfc29ade 100644 --- a/example/6-echo/echo.ml +++ b/example/6-echo/echo.ml @@ -1,10 +1,11 @@ let () = - Dream.run + 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/README.md b/example/7-template/README.md index 03ec529a..acb1347c 100644 --- a/example/7-template/README.md +++ b/example/7-template/README.md @@ -42,8 +42,7 @@ file to run the template preprocessor:
(executable
  (name template)
- (libraries dream)
- (preprocess (pps lwt_ppx)))
+ (libraries dream))
 
 (rule
  (targets template.ml)
diff --git a/example/7-template/template.eml.ml b/example/7-template/template.eml.ml
index f6cd751e..7e185cc0 100644
--- a/example/7-template/template.eml.ml
+++ b/example/7-template/template.eml.ml
@@ -6,7 +6,8 @@ let render param =
   
 
 let () =
-  Dream.run
+  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..90f85964 100644
--- a/example/8-debug/debug.ml
+++ b/example/8-debug/debug.ml
@@ -1,5 +1,6 @@
 let () =
-  Dream.run ~error_handler:Dream.debug_error_handler
+  Eio_main.run @@ fun env ->
+  Dream.run ~error_handler:Dream.debug_error_handler env
   @@ Dream.logger
   @@ Dream.router [
 
diff --git a/example/9-error/error.eml.ml b/example/9-error/error.eml.ml
index 515091cf..67937346 100644
--- a/example/9-error/error.eml.ml
+++ b/example/9-error/error.eml.ml
@@ -12,9 +12,10 @@ 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)
+  Eio_main.run @@ fun env ->
+  Dream.run ~error_handler:(Dream.error_template my_error_template) env
   @@ Dream.logger
   @@ Dream.not_found
diff --git a/example/a-log/log.ml b/example/a-log/log.ml
index 457bf791..8ef667db 100644
--- a/example/a-log/log.ml
+++ b/example/a-log/log.ml
@@ -1,5 +1,6 @@
 let () =
-  Dream.run
+  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 0087f76d..557b34a4 100644
--- a/example/b-session/dune
+++ b/example/b-session/dune
@@ -1,6 +1,5 @@
 (executable
  (name session)
- (libraries dream)
- (preprocess (pps lwt_ppx)))
+ (libraries dream))
 
 (data_only_dirs _esy esy.lock lib node_modules)
diff --git a/example/b-session/session.ml b/example/b-session/session.ml
index 8a0c0458..ded5081f 100644
--- a/example/b-session/session.ml
+++ b/example/b-session/session.ml
@@ -1,13 +1,14 @@
 let () =
-  Dream.run
+  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 ->
diff --git a/example/c-cookie/cookie.ml b/example/c-cookie/cookie.ml
index e145e5ee..3e5f15c8 100644
--- a/example/c-cookie/cookie.ml
+++ b/example/c-cookie/cookie.ml
@@ -1,5 +1,6 @@
 let () =
-  Dream.run
+  Eio_main.run @@ fun env ->
+  Dream.run env
   @@ Dream.set_secret "foo"
   @@ Dream.logger
   @@ fun request ->
@@ -13,4 +14,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/d-form/dune b/example/d-form/dune
index 6918056c..d8ba1e88 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))
 
 (rule
  (targets form.ml)
diff --git a/example/d-form/form.eml.ml b/example/d-form/form.eml.ml
index 40fe08fa..ac5cd2bf 100644
--- a/example/d-form/form.eml.ml
+++ b/example/d-form/form.eml.ml
@@ -17,7 +17,8 @@ let show_form ?message request =
   
 
 let () =
-  Dream.run
+  Eio_main.run @@ fun env ->
+  Dream.run env
   @@ Dream.logger
   @@ Dream.memory_sessions
   @@ Dream.router [
@@ -28,7 +29,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/README.md b/example/e-json/README.md
index 8857fc7d..0dbbb3e7 100644
--- a/example/e-json/README.md
+++ b/example/e-json/README.md
@@ -43,7 +43,7 @@ To get this working, we have to add `ppx_yojson_conv` to our
 
(executable
  (name json)
  (libraries dream)
- (preprocess (pps lwt_ppx ppx_yojson_conv)))
+ (preprocess (pps ppx_yojson_conv)))
 
and to diff --git a/example/e-json/dune b/example/e-json/dune index 15568cec..dc82cfd9 100644 --- a/example/e-json/dune +++ b/example/e-json/dune @@ -1,6 +1,6 @@ (executable (name json) (libraries dream) - (preprocess (pps lwt_ppx ppx_yojson_conv))) + (preprocess (pps ppx_yojson_conv))) (data_only_dirs _esy esy.lock lib node_modules) diff --git a/example/e-json/json.ml b/example/e-json/json.ml index 6fde9607..6275cf09 100644 --- a/example/e-json/json.ml +++ b/example/e-json/json.ml @@ -3,17 +3,16 @@ type message_object = { } [@@deriving yojson] let () = - Dream.run + 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/static.ml b/example/f-static/static.ml index daf1c776..acd50a2f 100644 --- a/example/f-static/static.ml +++ b/example/f-static/static.ml @@ -1,5 +1,6 @@ let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.router [ Dream.get "/static/**" (Dream.static ".") diff --git a/example/g-upload/dune b/example/g-upload/dune index 72f71e70..b5700e4e 100644 --- a/example/g-upload/dune +++ b/example/g-upload/dune @@ -1,7 +1,6 @@ (executable (name upload) - (libraries dream) - (preprocess (pps lwt_ppx))) + (libraries dream)) (rule (targets upload.ml) diff --git a/example/g-upload/upload.eml.ml b/example/g-upload/upload.eml.ml index 2471a4ac..c2b80cef 100644 --- a/example/g-upload/upload.eml.ml +++ b/example/g-upload/upload.eml.ml @@ -24,7 +24,8 @@ let report files = let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.memory_sessions @@ Dream.router [ @@ -33,7 +34,7 @@ let () = Dream.html (home request)); Dream.post "/" (fun request -> - match%lwt Dream.multipart request with + match Dream.multipart request with | `Ok ["files", files] -> Dream.html (report files) | _ -> Dream.empty `Bad_Request); diff --git a/example/h-sql/sql.eml.ml b/example/h-sql/sql.eml.ml index 619bae41..060f38bc 100644 --- a/example/h-sql/sql.eml.ml +++ b/example/h-sql/sql.eml.ml @@ -35,20 +35,21 @@ let render comments request = let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.sql_pool "sqlite3:db.sqlite" @@ Dream.sql_sessions @@ Dream.router [ Dream.get "/" (fun request -> - let%lwt comments = Dream.sql request list_comments in + let comments = Dream.sql request list_comments in Dream.html (render comments request)); Dream.post "/" (fun request -> - match%lwt Dream.form request with + match Dream.form request with | `Ok ["text", text] -> - let%lwt () = Dream.sql request (add_comment text) in + Dream.sql request (add_comment text); Dream.redirect request "/" | _ -> Dream.empty `Bad_Request); diff --git a/example/i-graphql/graphql.ml b/example/i-graphql/graphql.ml index 45d52d82..8466487a 100644 --- a/example/i-graphql/graphql.ml +++ b/example/i-graphql/graphql.ml @@ -36,7 +36,8 @@ let default_query = "{\\n users {\\n name\\n id\\n }\\n}\\n" let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.origin_referrer_check @@ Dream.router [ diff --git a/example/j-stream/dune b/example/j-stream/dune index 9cf43884..dedf8f7b 100644 --- a/example/j-stream/dune +++ b/example/j-stream/dune @@ -1,6 +1,5 @@ (executable (name stream) - (libraries dream) - (preprocess (pps lwt_ppx))) + (libraries dream)) (data_only_dirs _esy esy.lock lib node_modules) diff --git a/example/j-stream/stream.ml b/example/j-stream/stream.ml index 08a222ca..7a67fa88 100644 --- a/example/j-stream/stream.ml +++ b/example/j-stream/stream.ml @@ -1,5 +1,6 @@ let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.router [ diff --git a/example/k-websocket/dune b/example/k-websocket/dune index 2e18f039..2ad9a331 100644 --- a/example/k-websocket/dune +++ b/example/k-websocket/dune @@ -1,7 +1,6 @@ (executable (name websocket) - (libraries dream) - (preprocess (pps lwt_ppx))) + (libraries dream)) (rule (targets websocket.ml) diff --git a/example/k-websocket/websocket.eml.ml b/example/k-websocket/websocket.eml.ml index d75df5dc..ebbb5abc 100644 --- a/example/k-websocket/websocket.eml.ml +++ b/example/k-websocket/websocket.eml.ml @@ -18,7 +18,8 @@ let home = let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.router [ @@ -27,11 +28,13 @@ let () = Dream.html home); Dream.get "/websocket" - (fun _ -> - Dream.websocket (fun websocket -> - match%lwt Dream.receive websocket with + (fun request -> + Dream.websocket request (fun websocket -> + match Dream.receive websocket with | Some "Hello?" -> Dream.send websocket "Good-bye!" + (* Dream.write response "Good-bye!"; *) + (* Dream.close response *) | _ -> Dream.close_websocket websocket)); diff --git a/example/l-https/https.ml b/example/l-https/https.ml index d3a9c565..9a4e646d 100644 --- a/example/l-https/https.ml +++ b/example/l-https/https.ml @@ -1,4 +1,5 @@ let () = - Dream.run ~tls:true + Eio_main.run @@ fun env -> + Dream.run ~tls:true env @@ Dream.logger @@ fun _ -> Dream.html "Good morning, world!" diff --git a/example/r-advanced-template/template.eml.re b/example/r-advanced-template/template.eml.re new file mode 100644 index 00000000..da357d2a --- /dev/null +++ b/example/r-advanced-template/template.eml.re @@ -0,0 +1,51 @@ +let render_home = tasks => { + + +

My TODO

+ <% tasks |> List.iter(((name, complete)) => { %> +

Task <%s name %>: + <% if (complete) { %> + complete! + <% } else { %> + not complete + <% }; %> +

+ <% }); %> + + +}; + + +// You can begin a line with `%` instead of using `<% ... %>` +let render_task = (tasks, task) => { + + +% (switch (List.find_opt(((task_, _)) => task == task_, tasks)) { +% | Some((name, complete)) => +

TODO task: <%s name %>, complete: <%B complete %>

+% | None => +

Task not found!

+% }); + + +}; + +let tasks = [ + ("write documentation", true), + ("create examples", true), + ("publish website", true), + ("profit", false), +]; + +let () = + Eio_main.run @@ env => + Dream.run(env) + @@ Dream.logger + @@ Dream.router([ + Dream.get("/", _ => render_home(tasks) |> Dream.html), + Dream.get("/:task", request => + Dream.param(request, "task") |> render_task(tasks) |> Dream.html + ), + ]) + @@ Dream.not_found; + diff --git a/example/r-fullstack-melange/server/server.eml.re b/example/r-fullstack-melange/server/server.eml.re index 98b2d3bd..1fd611fe 100644 --- a/example/r-fullstack-melange/server/server.eml.re +++ b/example/r-fullstack-melange/server/server.eml.re @@ -8,7 +8,8 @@ let home = { }; let () = - Dream.run + Eio_main.run @@ env => + Dream.run(env) @@ Dream.logger @@ Dream.router([ diff --git a/example/r-graphql/graphql.re b/example/r-graphql/graphql.re index d4f14f05..e454ab99 100644 --- a/example/r-graphql/graphql.re +++ b/example/r-graphql/graphql.re @@ -47,7 +47,8 @@ let default_query = "{\\n users {\\n name\\n id\\n }\\n}\\n"; let () = - Dream.run + Eio_main.run @@ env => + Dream.run(env) @@ Dream.logger @@ Dream.origin_referrer_check @@ Dream.router([ diff --git a/example/r-hello/hello.re b/example/r-hello/hello.re index d6fdbaf3..7ac71b66 100644 --- a/example/r-hello/hello.re +++ b/example/r-hello/hello.re @@ -1,3 +1,4 @@ let () = - Dream.run(_ => + Eio_main.run @@ env => + Dream.run(env, _ => Dream.html("Good morning, reasonable world!")); diff --git a/example/r-template-files/server.re b/example/r-template-files/server.re index 303f0902..d775c8ae 100644 --- a/example/r-template-files/server.re +++ b/example/r-template-files/server.re @@ -1,5 +1,6 @@ let () = - Dream.run + Eio_main.run @@ env => + Dream.run env @@ Dream.logger @@ Dream.router([ diff --git a/example/r-template-stream/template_stream.eml.re b/example/r-template-stream/template_stream.eml.re index d5afce58..ef79b3be 100644 --- a/example/r-template-stream/template_stream.eml.re +++ b/example/r-template-stream/template_stream.eml.re @@ -1,4 +1,4 @@ -let render = response => { +let render = clock => response => { %% response @@ -11,11 +11,26 @@ let render = response => { % }; % let%lwt () = paragraphs(0); +# let render = clock => response => { +# let () = { +# %% response +# +# + +# % let rec paragraphs = index => { +#

<%i index %>

+# % Dream.flush(response); +# % Eio.Time.sleep(clock, 1.); +# % if (index < 10) paragraphs(index + 1); +# % }; +# % paragraphs(0); + }; let () = - Dream.run + Eio_main.run @@ env => + Dream.run(env) @@ Dream.logger - @@ _ => Dream.stream(~headers=[("Content-Type", Dream.text_html)], render); + @@ request => Dream.stream(~headers=[("Content-Type", Dream.text_html)], request, render(env#clock)); diff --git a/example/r-template/template.eml.re b/example/r-template/template.eml.re index 3ed3b4ae..de81dc6c 100644 --- a/example/r-template/template.eml.re +++ b/example/r-template/template.eml.re @@ -7,7 +7,8 @@ let greet = who => { }; let () = - Dream.run + Eio_main.run @@ env => + Dream.run(env) @@ Dream.logger @@ Dream.router([ diff --git a/example/r-tyxml/tyxml.re b/example/r-tyxml/tyxml.re index 6324f7aa..f8d64fd2 100644 --- a/example/r-tyxml/tyxml.re +++ b/example/r-tyxml/tyxml.re @@ -12,7 +12,8 @@ let html_to_string = html => Format.asprintf("%a", Tyxml.Html.pp(), html); let () = - Dream.run + Eio_main.run @@ env => + Dream.run(env) @@ Dream.logger @@ Dream.router([ diff --git a/example/w-advanced-template/template.eml.ml b/example/w-advanced-template/template.eml.ml new file mode 100644 index 00000000..7e26831e --- /dev/null +++ b/example/w-advanced-template/template.eml.ml @@ -0,0 +1,57 @@ +(* In OCaml, `begin ... end` is the same as `( ... )` *) +let render_home tasks = + + +

My TODO

+ <% tasks |> List.iter begin fun (name, complete) -> %> +

Task <%s name %>: + <% if complete then ( %> + complete! + <% ) else ( %> + not complete + <% ); %> +

+ <% end; %> + + + + +(* You can also begin a line with `%` instead of using `<% ... %>` *) +let render_task tasks task = + + +% (match List.find_opt (fun (task_, _) -> task = task_) tasks with +% | Some (name, complete) -> +

TODO task: <%s name %>, complete: <%B complete %>

+% | None -> begin +

Task not found!

+% end); + + + +let tasks = [ + ("write documentation", true); + ("create examples", true); + ("publish website", true); + ("profit", false); +] + +let () = + Eio_main.run @@ fun env -> + Dream.run env + @@ Dream.logger + @@ Dream.router [ + Dream.get "/" + (fun _ -> + render_home tasks + |> Dream.html); + + + Dream.get "/:task" + (fun request -> + Dream.param request "task" + |> render_task tasks + |> Dream.html); + + ] + @@ Dream.not_found diff --git a/example/w-chat/chat.eml.ml b/example/w-chat/chat.eml.ml index 5bec1d71..7e390bdc 100644 --- a/example/w-chat/chat.eml.ml +++ b/example/w-chat/chat.eml.ml @@ -1,3 +1,5 @@ +open Eio.Std + let home = @@ -44,16 +46,19 @@ let forget client_id = Hashtbl.remove clients client_id let send message = + Switch.run @@ fun sw -> Hashtbl.to_seq_values clients |> List.of_seq - |> Lwt_list.iter_p (fun client -> Dream.send client message) + |> List.iter (fun client -> + Fibre.fork ~sw (fun () -> Dream.send client message) + ) let handle_client client = let client_id = track client in let rec loop () = - match%lwt Dream.receive client with + match Dream.receive client with | Some message -> - let%lwt () = send message in + send message; loop () | None -> forget client_id; @@ -62,7 +67,8 @@ let handle_client client = loop () let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.router [ @@ -70,6 +76,6 @@ let () = (fun _ -> Dream.html home); Dream.get "/websocket" - (fun _ -> Dream.websocket handle_client); + (fun request -> Dream.websocket request handle_client); ] diff --git a/example/w-content-security-policy/content_security_policy.eml.ml b/example/w-content-security-policy/content_security_policy.eml.ml index ad9da9cb..894a65fb 100644 --- a/example/w-content-security-policy/content_security_policy.eml.ml +++ b/example/w-content-security-policy/content_security_policy.eml.ml @@ -6,7 +6,8 @@ let home = let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.router [ @@ -21,7 +22,7 @@ let () = "You should not be able to see this inside a frame!"); Dream.post "/violation" (fun request -> - let%lwt report = Dream.body request in + let report = Dream.body request in Dream.error (fun log -> log "%s" report); Dream.empty `OK); diff --git a/example/w-esy/hello.ml b/example/w-esy/hello.ml index a35eb21d..c04d64f5 100644 --- a/example/w-esy/hello.ml +++ b/example/w-esy/hello.ml @@ -1,4 +1,5 @@ let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ fun _ -> Dream.html "Good morning, world!" diff --git a/example/w-flash/flash.eml.ml b/example/w-flash/flash.eml.ml index 3db146cc..5bd49342 100644 --- a/example/w-flash/flash.eml.ml +++ b/example/w-flash/flash.eml.ml @@ -20,7 +20,8 @@ let result request = let () = Dream.set_log_level "dream.flash" `Debug; - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.memory_sessions @@ Dream.flash @@ -32,7 +33,7 @@ let () = Dream.post "/" (fun request -> - match%lwt Dream.form request with + match Dream.form request with | `Ok ["text", text] -> let () = Dream.add_flash_message request "Info" text in Dream.redirect request "/result" diff --git a/example/w-fswatch/hello.ml b/example/w-fswatch/hello.ml index a35eb21d..c04d64f5 100644 --- a/example/w-fswatch/hello.ml +++ b/example/w-fswatch/hello.ml @@ -1,4 +1,5 @@ let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ fun _ -> Dream.html "Good morning, world!" diff --git a/example/w-fullstack-rescript/server/server.eml.ml b/example/w-fullstack-rescript/server/server.eml.ml index 203cb7ad..9bb25152 100644 --- a/example/w-fullstack-rescript/server/server.eml.ml +++ b/example/w-fullstack-rescript/server/server.eml.ml @@ -7,7 +7,8 @@ let home = let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.router [ diff --git a/example/w-graphql-subscription/graphql_subscription.ml b/example/w-graphql-subscription/graphql_subscription.ml index b30457ff..b3939987 100644 --- a/example/w-graphql-subscription/graphql_subscription.ml +++ b/example/w-graphql-subscription/graphql_subscription.ml @@ -29,7 +29,8 @@ let default_query = "subscription {\\n count(until: 3)\\n}\\n" let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.origin_referrer_check @@ Dream.router [ diff --git a/example/w-live-reload/live_reload.ml b/example/w-live-reload/live_reload.ml index 999c53b3..9eee6752 100644 --- a/example/w-live-reload/live_reload.ml +++ b/example/w-live-reload/live_reload.ml @@ -33,11 +33,11 @@ socket.onclose = function(event) { |js} let inject_live_reload_script inner_handler request = - let%lwt response = inner_handler request in + let response = inner_handler request in match Dream.header response "Content-Type" with | Some "text/html; charset=utf-8" -> - let%lwt body = Dream.body response in + let body = Dream.body response in let soup = Markup.string body |> Markup.parse_html ~context:`Document @@ -47,19 +47,20 @@ let inject_live_reload_script inner_handler request = begin match Soup.Infix.(soup $? "head") with | None -> - Lwt.return response + response | Some head -> Soup.create_element "script" ~inner_text:live_reload_script |> Soup.append_child head; Dream.set_body response (Soup.to_string soup); - Lwt.return response + response end | _ -> - Lwt.return response + response let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ inject_live_reload_script @@ Dream.router [ @@ -70,9 +71,9 @@ let () = |> Printf.sprintf "Good morning, world! Random tag: %s" |> Dream.html); - Dream.get "/_live-reload" (fun _ -> - Dream.websocket (fun socket -> - let%lwt _ = Dream.receive socket in + Dream.get "/_live-reload" (fun request -> + Dream.websocket request (fun socket -> + let _ = Dream.receive socket in Dream.close_websocket socket)); ] diff --git a/example/w-long-polling/long_polling.eml.ml b/example/w-long-polling/long_polling.eml.ml index 2aefa528..86c12044 100644 --- a/example/w-long-polling/long_polling.eml.ml +++ b/example/w-long-polling/long_polling.eml.ml @@ -1,3 +1,5 @@ +open Eio.Std + let home = @@ -34,31 +36,46 @@ let server_state = let last_message = ref 0 -let rec message_loop () = - let%lwt () = Lwt_unix.sleep (Random.float 2.) in - incr last_message; - - let message = string_of_int !last_message in - Dream.log "Generated message %s" message; +let message_loop clock = + while true do + Eio.Time.sleep clock (Random.float 2.); + incr last_message; - begin match !server_state with - | Client_waiting f -> - server_state := Messages_accumulating []; - f message - | Messages_accumulating list -> - server_state := Messages_accumulating (message::list) - end; + let message = string_of_int !last_message in + Dream.log "Generated message %s" message; - message_loop () + begin match !server_state with + | Client_waiting f -> + server_state := Messages_accumulating []; + f message + | Messages_accumulating list -> + server_state := Messages_accumulating (message::list) + end + done let () = - Lwt.async message_loop; - - Dream.run - @@ Dream.logger - @@ Dream.router [ - - Dream.get "/" (fun _ -> Dream.html home); + Eio_main.run @@ fun env -> + Fibre.both + (fun () -> message_loop env#clock) + (fun () -> + Dream.run env + @@ Dream.logger + @@ Dream.router [ + + Dream.get "/" (fun _ -> Dream.html home); + + Dream.get "/poll" (fun _ -> + match !server_state with + | Client_waiting _ -> + Dream.empty `Unauthorized + | Messages_accumulating [] -> + let response_promise, respond = Promise.create () in + server_state := Client_waiting (fun message -> + Promise.fulfill respond (Dream.response message)); + Promise.await response_promise + | Messages_accumulating messages -> + server_state := Messages_accumulating []; + Dream.html (String.concat "\n" (List.rev messages))); Dream.get "/poll" (fun _ -> match !server_state with diff --git a/example/w-multipart-dump/multipart_dump.eml.ml b/example/w-multipart-dump/multipart_dump.eml.ml index 000d1e1b..4babc265 100644 --- a/example/w-multipart-dump/multipart_dump.eml.ml +++ b/example/w-multipart-dump/multipart_dump.eml.ml @@ -11,7 +11,8 @@ let home request = let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.memory_sessions @@ Dream.router [ @@ -20,7 +21,7 @@ let () = Dream.html (home request)); Dream.post "/" (fun request -> - let%lwt body = Dream.body request in + let body = Dream.body request in Dream.respond ~headers:["Content-Type", "text/plain"] body); diff --git a/example/w-nginx/server.eml.ml b/example/w-nginx/server.eml.ml index 3167a8ab..65b627db 100644 --- a/example/w-nginx/server.eml.ml +++ b/example/w-nginx/server.eml.ml @@ -9,7 +9,8 @@ let home = let () = - Dream.run ~interface:"0.0.0.0" ~port:8081 + Eio_main.run @@ fun env -> + Dream.run ~interface:"0.0.0.0" ~port:8081 env @@ Dream.logger @@ Dream.router [ Dream.get "/" (fun _request -> Dream.html home) diff --git a/example/w-one-binary/one_binary.ml b/example/w-one-binary/one_binary.ml index 3fae42e0..f96b2277 100644 --- a/example/w-one-binary/one_binary.ml +++ b/example/w-one-binary/one_binary.ml @@ -4,7 +4,8 @@ let loader _root path _request = | Some asset -> Dream.respond asset let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.router [ Dream.get "/assets/**" (Dream.static ~loader "") diff --git a/example/w-postgres/postgres.eml.ml b/example/w-postgres/postgres.eml.ml index 7c9e844e..5edaa979 100644 --- a/example/w-postgres/postgres.eml.ml +++ b/example/w-postgres/postgres.eml.ml @@ -36,20 +36,21 @@ let render comments request = let () = - Dream.run ~interface:"0.0.0.0" + Eio_main.run @@ fun env -> + Dream.run ~interface:"0.0.0.0" env @@ Dream.logger @@ Dream.sql_pool "postgresql://dream:password@postgres/dream" @@ Dream.sql_sessions @@ Dream.router [ Dream.get "/" (fun request -> - let%lwt comments = Dream.sql request list_comments in + let comments = Dream.sql request list_comments in Dream.html (render comments request)); Dream.post "/" (fun request -> - match%lwt Dream.form request with + match Dream.form request with | `Ok ["text", text] -> - let%lwt () = Dream.sql request (add_comment text) in + Dream.sql request (add_comment text); Dream.redirect request "/" | _ -> Dream.empty `Bad_Request); diff --git a/example/w-query/query.ml b/example/w-query/query.ml index 3d9b70ca..febc074d 100644 --- a/example/w-query/query.ml +++ b/example/w-query/query.ml @@ -1,5 +1,6 @@ let () = - Dream.run (fun request -> + Eio_main.run @@ fun env -> + Dream.run env (fun request -> match Dream.query request "echo" with | None -> Dream.html "Use ?echo=foo to give a message to echo!" diff --git a/example/w-server-sent-events/server_sent_events.eml.ml b/example/w-server-sent-events/server_sent_events.eml.ml index 25eab88b..8b76223e 100644 --- a/example/w-server-sent-events/server_sent_events.eml.ml +++ b/example/w-server-sent-events/server_sent_events.eml.ml @@ -1,3 +1,5 @@ +open Eio.Std + let home = @@ -26,17 +28,17 @@ let notify = let last_message = ref 0 -let rec message_loop () = - let%lwt () = Lwt_unix.sleep (Random.float 2.) in - - incr last_message; - let message = string_of_int !last_message in - Dream.log "Generated message %s" message; +let message_loop clock = + while true do + Eio.Time.sleep clock (Random.float 2.); - server_state := message::!server_state; - !notify (); + incr last_message; + let message = string_of_int !last_message in + Dream.log "Generated message %s" message; - message_loop () + server_state := message::!server_state; + !notify () + done let rec forward_messages stream = let%lwt messages = @@ -58,18 +60,27 @@ let rec forward_messages stream = |> List.map (Printf.sprintf "data: %s\n\n") |> String.concat "" |> fun text -> - let%lwt () = Dream.write stream text in - let%lwt () = Dream.flush stream in + let () = Dream.write stream text in + let () = Dream.flush stream in forward_messages stream -let () = - Lwt.async message_loop; +let forward_messages response = Lwt_eio.Promise.await_lwt (forward_messages response) - Dream.run - @@ Dream.logger - @@ Dream.router [ - - Dream.get "/" (fun _ -> Dream.html home); +let () = + Eio_main.run @@ fun env -> + Fibre.both + (fun () -> message_loop env#clock) + (fun () -> + Dream.run env + @@ Dream.logger + @@ Dream.router [ + + Dream.get "/" (fun _ -> Dream.html home); + + Dream.get "/push" (fun request -> + Dream.stream request + ~headers:["Content-Type", "text/event-stream"] + forward_messages); Dream.get "/push" (fun _ -> Dream.stream diff --git a/example/w-stress-response/stress_response.ml b/example/w-stress-response/stress_response.ml index dcfefedc..c7d6599b 100644 --- a/example/w-stress-response/stress_response.ml +++ b/example/w-stress-response/stress_response.ml @@ -1,3 +1,5 @@ +open Eio.Std + let show_heap_size () = Gc.((quick_stat ()).heap_words) * 8 |> float_of_int @@ -15,22 +17,21 @@ let stress ?(megabytes = 1024) ?(chunk = 64) stream = let rec loop sent = if sent >= limit then - let%lwt () = Dream.flush stream in - let%lwt () = Dream.close stream in - Lwt.return (Unix.gettimeofday () -. start) + let () = Dream.flush stream in + let () = Dream.close stream in + Unix.gettimeofday () -. start else - let%lwt () = Dream.write stream chunk_a in - let%lwt () = Dream.write stream chunk_b in - let%lwt () = Lwt.pause () in + let () = Dream.write stream chunk_a in + let () = Dream.write stream chunk_b in + let () = Fiber.yield () in loop (sent + chunk + chunk) + ) in - let%lwt elapsed = loop 0 in + let elapsed = loop 0 in Dream.log "%.0f MB/s over %.1f s" ((float_of_int megabytes) /. elapsed) elapsed; - show_heap_size (); - - Lwt.return_unit + show_heap_size () let query_int request name = Dream.query request name |> Option.map int_of_string @@ -38,12 +39,13 @@ let query_int request name = let () = show_heap_size (); - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.router [ Dream.get "/" (fun request -> - Dream.stream + Dream.stream request ~headers:["Content-Type", "application/octet-stream"] (stress ?megabytes:(query_int request "mb") diff --git a/example/w-stress-websocket-send/stress_websocket_send.eml.ml b/example/w-stress-websocket-send/stress_websocket_send.eml.ml index f8d910b3..af96aca1 100644 --- a/example/w-stress-websocket-send/stress_websocket_send.eml.ml +++ b/example/w-stress-websocket-send/stress_websocket_send.eml.ml @@ -1,5 +1,7 @@ (* TODO Definitely needs flow control. *) +open Eio.Std + let home = @@ -42,26 +44,26 @@ let stress websocket = let start = Unix.gettimeofday () in let rec loop sent = if sent >= limit then - let%lwt () = Dream.close_websocket websocket in - Lwt.return (Unix.gettimeofday () -. start) + let () = Dream.close_websocket websocket in + Unix.gettimeofday () -. start else - let%lwt () = Dream.send websocket frame_a ~text_or_binary:`Binary in - let%lwt () = Dream.send websocket frame_b ~text_or_binary:`Binary in - let%lwt () = Lwt.pause () in + let () = Dream.send websocket frame_a ~text_or_binary:`Binary in + let () = Dream.send websocket frame_b ~text_or_binary:`Binary in + let () = Fiber.yield () in loop (sent + frame + frame) + ) in - let%lwt elapsed = loop 0 in + let elapsed = loop 0 in Dream.log "%.0f MB/s over %.1f s" ((float_of_int limit) /. elapsed /. 1024. /. 1024.) elapsed; - show_heap_size (); - - Lwt.return_unit + show_heap_size () let () = show_heap_size (); - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.router [ @@ -69,6 +71,6 @@ let () = (fun _ -> Dream.html home); Dream.get "/websocket" - (fun _ -> Dream.websocket stress); + (fun request -> Dream.websocket request stress); ] diff --git a/example/w-template-files/server.ml b/example/w-template-files/server.ml index fac41063..b5d2ccaf 100644 --- a/example/w-template-files/server.ml +++ b/example/w-template-files/server.ml @@ -1,5 +1,6 @@ let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.router [ diff --git a/example/w-template-stream/template_stream.eml.ml b/example/w-template-stream/template_stream.eml.ml index abe787d1..7a61b91c 100644 --- a/example/w-template-stream/template_stream.eml.ml +++ b/example/w-template-stream/template_stream.eml.ml @@ -11,10 +11,25 @@ let render response = % in % let%lwt () = paragraphs 0 in +(* let render ~clock response = *) +(* let () = *) +(* %% response *) +(* *) +(* *) + +(* % let rec paragraphs index = *) +(*

<%i index %>

*) +(* % Dream.flush response; *) +(* % Eio.Time.sleep clock 1.; *) +(* % if index < 10 then paragraphs (index + 1) *) +(* % in *) +(* % paragraphs 0; *) + let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger - @@ fun _ -> Dream.stream ~headers:["Content-Type", Dream.text_html] render + @@ fun request -> Dream.stream ~headers:["Content-Type", Dream.text_html] request (render ~clock:env#clock) diff --git a/example/w-tyxml/tyxml.ml b/example/w-tyxml/tyxml.ml index 132996d5..b7107746 100644 --- a/example/w-tyxml/tyxml.ml +++ b/example/w-tyxml/tyxml.ml @@ -12,7 +12,8 @@ let html_to_string html = Format.asprintf "%a" (Tyxml.Html.pp ()) html let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.router [ diff --git a/example/w-upload-stream/upload_stream.eml.ml b/example/w-upload-stream/upload_stream.eml.ml index e6d086f9..fffb4aab 100644 --- a/example/w-upload-stream/upload_stream.eml.ml +++ b/example/w-upload-stream/upload_stream.eml.ml @@ -24,7 +24,8 @@ let report files = let () = - Dream.run + Eio_main.run @@ fun env -> + Dream.run env @@ Dream.logger @@ Dream.memory_sessions @@ Dream.router [ @@ -34,11 +35,11 @@ let () = Dream.post "/" (fun request -> let rec receive file_sizes = - match%lwt Dream.upload request with + match Dream.upload request with | None -> Dream.html (report (List.rev file_sizes)) | Some (_, filename, _) -> let rec count_size size = - match%lwt Dream.upload_part request with + match Dream.upload_part request with | None -> receive ((filename, size)::file_sizes) | Some chunk -> count_size (size + String.length chunk) in diff --git a/example/z-docker-esy/app.ml b/example/z-docker-esy/app.ml index fe07cf92..0274b694 100644 --- a/example/z-docker-esy/app.ml +++ b/example/z-docker-esy/app.ml @@ -1,5 +1,6 @@ let () = - Dream.run ~interface:"0.0.0.0" + Eio_main.run @@ fun env -> + Dream.run ~interface:"0.0.0.0" env @@ Dream.logger @@ Dream.router [ Dream.get "/" (fun _ -> diff --git a/example/z-docker-opam/app.ml b/example/z-docker-opam/app.ml index df300152..47bc9955 100644 --- a/example/z-docker-opam/app.ml +++ b/example/z-docker-opam/app.ml @@ -1,5 +1,6 @@ let () = - Dream.run ~interface:"0.0.0.0" + Eio_main.run @@ fun env -> + Dream.run ~interface:"0.0.0.0" env @@ Dream.logger @@ Dream.router [ Dream.get "/" (fun _ -> diff --git a/example/z-fly/app.ml b/example/z-fly/app.ml index 698d7581..e728dc23 100644 --- a/example/z-fly/app.ml +++ b/example/z-fly/app.ml @@ -1,5 +1,6 @@ let () = - Dream.run ~interface:"0.0.0.0" + Eio_main.run @@ fun env -> + Dream.run ~interface:"0.0.0.0" env @@ Dream.logger @@ Dream.router [ Dream.get "/" (fun _ -> Dream.html "Dream deployed on Fly.io!"); diff --git a/example/z-heroku/app.ml b/example/z-heroku/app.ml index 232682e6..e7224891 100644 --- a/example/z-heroku/app.ml +++ b/example/z-heroku/app.ml @@ -1,5 +1,6 @@ let () = - Dream.run ~interface:"0.0.0.0" ~port:(int_of_string (Sys.getenv "PORT")) + Eio_main.run @@ fun env -> + Dream.run ~interface:"0.0.0.0" ~port:(int_of_string (Sys.getenv "PORT")) env @@ Dream.logger @@ Dream.router [ Dream.get "/" (fun _ -> Dream.html "Dream running in Heroku!"); diff --git a/example/z-systemd/app.ml b/example/z-systemd/app.ml index 87703ff6..4acf4312 100644 --- a/example/z-systemd/app.ml +++ b/example/z-systemd/app.ml @@ -1,5 +1,6 @@ let () = - Dream.run ~interface:"0.0.0.0" ~port:80 + Eio_main.run @@ fun env -> + Dream.run ~interface:"0.0.0.0" ~port:80 env @@ Dream.logger @@ Dream.router [ Dream.get "/" (fun _ -> Dream.html "Dream started by systemd!"); diff --git a/src/dream.ml b/src/dream.ml index 9f01675b..a2c0e25d 100644 --- a/src/dream.ml +++ b/src/dream.ml @@ -144,7 +144,7 @@ let all_cookies = Cookie.all_cookies (* Bodies *) -let body = Message.body +let body x = Lwt_eio.Promise.await_lwt (Message.body x) let set_body = Message.set_body @@ -195,12 +195,12 @@ let origin_referrer_check = Origin_referrer_check.origin_referrer_check (* Forms *) type 'a form_result = 'a Form.form_result -let form = Form.form ~now +let form ?csrf x = Lwt_eio.Promise.await_lwt (Form.form ~now ?csrf x) type multipart_form = Upload.multipart_form -let multipart = Upload.multipart ~now +let multipart ?csrf x = Lwt_eio.Promise.await_lwt (Upload.multipart ~now ?csrf x) type part = Upload.part -let upload = Upload.upload -let upload_part = Upload.upload_part +let upload request = Lwt_eio.Promise.await_lwt (Upload.upload request) +let upload_part request = Lwt_eio.Promise.await_lwt (Upload.upload_part request) type csrf_result = Csrf.csrf_result let csrf_token = Csrf.csrf_token ~now let verify_csrf_token = Csrf.verify_csrf_token ~now @@ -289,7 +289,7 @@ let graphiql = Graphql.graphiql (* SQL *) let sql_pool = Sql.sql_pool -let sql = Sql.sql +let sql req fn = Lwt_eio.Promise.await_lwt (Sql.sql req fn) @@ -391,7 +391,11 @@ let test ?(prefix = "") handler request = @@ handler in - Lwt_main.run (app request) + let result = ref None in + Eio_main.run (fun _env -> + result := Some (app request) + ); + Option.get !result let sort_headers = Message.sort_headers let echo = Echo.echo diff --git a/src/dream.mli b/src/dream.mli index 53d63986..cd600b0c 100644 --- a/src/dream.mli +++ b/src/dream.mli @@ -4,7 +4,6 @@ Copyright 2021 Anton Bachin *) - (** {1 Types} Dream is built on just five types. The first two are the data types of @@ -19,7 +18,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]} \[{{:http://dream.as/1-hello} playground}\] shows the simplest @@ -451,7 +450,7 @@ 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}. *) @@ -459,7 +458,7 @@ 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}. @@ -473,7 +472,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}. *) @@ -481,7 +480,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 @@ -495,9 +494,10 @@ val redirect : val empty : ?headers:(string * string) list -> - status -> response promise + status -> response (** Same as {!Dream.val-response} with the empty string for a body. *) + val status : response -> status (** Response {!type-status}. For example, [`OK]. *) @@ -696,7 +696,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]}. *) @@ -870,7 +870,7 @@ val abort_stream : stream -> exn -> unit (**/**) val write_buffer : - ?offset:int -> ?length:int -> response -> buffer -> unit promise + ?offset:int -> ?length:int -> response -> buffer -> unit [@@ocaml.deprecated "Use Dream.write_stream. See https://aantron.github.io/dream/#val-write_stream @@ -1033,7 +1033,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 @@ -1126,7 +1126,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 @@ -1158,7 +1158,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 @@ -1177,7 +1177,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} @@ -1846,7 +1846,7 @@ 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 +val sql : request -> (Caqti_lwt.connection -> 'a promise) -> '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]}. @@ -2121,7 +2121,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}. @@ -2137,7 +2137,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]} \[{{:http://dream.as/9-error} playground}\]. @@ -2182,7 +2182,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 @@ -2203,6 +2203,7 @@ val run : ?builtins:bool -> ?greeting:bool -> ?adjust_terminal:bool -> + < clock: Eio.Time.clock; ..> -> handler -> unit (** Runs the Web application represented by the {!handler}, by default at {{:http://localhost:8080} http://localhost:8080}. @@ -2260,7 +2261,7 @@ val serve : ?certificate_file:string -> ?key_file:string -> ?builtins:bool -> - handler -> unit promise + 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]}. @@ -2555,7 +2556,7 @@ val request : ?method_:[< method_ ] -> ?target:string -> ?headers:(string * string) list -> - string -> request + string -> request (** [Dream.request body] creates a fresh request with the given body for testing. The optional arguments set the corresponding {{!requests} request fields}. *) diff --git a/src/eml/eml.ml b/src/eml/eml.ml index 64c714f3..f9460c52 100644 --- a/src/eml/eml.ml +++ b/src/eml/eml.ml @@ -688,17 +688,16 @@ struct init = (fun () -> print "let ___eml_write string = Dream.write response string in\n"); - finish = (fun () -> - print "Lwt.return_unit\n"); + finish = ignore; text = - Printf.ksprintf print "let%%lwt () = ___eml_write %S in\n"; + Printf.ksprintf print "___eml_write %S;\n"; format = - Printf.ksprintf print "let%%lwt () = Printf.ksprintf ___eml_write %S "; + Printf.ksprintf print "Printf.ksprintf ___eml_write %S "; format_end = (fun () -> - print " in\n"); + print ";\n"); } let stream_reason print = { @@ -707,14 +706,13 @@ struct init = (fun () -> print "let ___eml_write = string => Dream.write(response, string);\n"); - finish = (fun () -> - print "Lwt.return_unit\n"); + finish = ignore; text = - Printf.ksprintf print "let%%lwt () = ___eml_write(%S);\n"; + Printf.ksprintf print "___eml_write(%S);\n"; format = - Printf.ksprintf print "let%%lwt () = Printf.ksprintf(___eml_write, %S)"; + Printf.ksprintf print "Printf.ksprintf(___eml_write, %S)"; format_end = (fun () -> print ";\n"); diff --git a/src/graphql/graphql.ml b/src/graphql/graphql.ml index 25c548b5..6a994ae8 100644 --- a/src/graphql/graphql.ml +++ b/src/graphql/graphql.ml @@ -115,6 +115,7 @@ let complete_message id = (* TODO Take care to pass around the request Lwt.key in async, etc. *) (* TODO Test client complete racing against a stream. *) let handle_over_websocket make_context schema subscriptions request websocket = + Lwt_eio.Promise.await_lwt @@ let rec loop inited = match%lwt Helpers.receive websocket with | None -> @@ -279,47 +280,50 @@ let graphql make_context schema = fun request -> | Some "websocket", Some "graphql-transport-ws" -> Helpers.websocket ~headers:["Sec-WebSocket-Protocol", "graphql-transport-ws"] + request (handle_over_websocket make_context schema (Hashtbl.create 16) request) | _ -> log.warning (fun log -> log ~request "Upgrade: websocket header missing"); Message.response ~status:`Not_Found Stream.empty Stream.null - |> Lwt.return end | `POST -> begin match Message.header request "Content-Type" with | Some "application/json" -> - let%lwt body = Message.body request in - (* TODO This almost certainly raises exceptions... *) - let json = Yojson.Basic.from_string body in - - begin match%lwt run_query make_context schema request json with - | Error json -> - Yojson.Basic.to_string json - |> Helpers.json - - | Ok (`Response json) -> - Yojson.Basic.to_string json - |> Helpers.json - - | Ok (`Stream _) -> - make_error "Subscriptions and streaming should use WebSocket transport" - |> Yojson.Basic.to_string - |> Helpers.json - end + Lwt_eio.Promise.await_lwt ( + let%lwt body = Message.body request in + (* TODO This almost certainly raises exceptions... *) + let json = Yojson.Basic.from_string body in + + begin match%lwt run_query make_context schema request json with + | Error json -> + Yojson.Basic.to_string json + |> Helpers.json + |> Lwt.return + + | Ok (`Response json) -> + Yojson.Basic.to_string json + |> Helpers.json + |> Lwt.return + + | Ok (`Stream _) -> + make_error "Subscriptions and streaming should use WebSocket transport" + |> Yojson.Basic.to_string + |> Helpers.json + |> Lwt.return + end + ) | _ -> log.warning (fun log -> log ~request "Content-Type not 'application/json'"); Message.response ~status:`Bad_Request Stream.empty Stream.null - |> Lwt.return end | method_ -> log.error (fun log -> log ~request "Method %s; must be GET or POST" (Method.method_to_string method_)); Message.response ~status:`Not_Found Stream.empty Stream.null - |> Lwt.return diff --git a/src/http/dune b/src/http/dune index b9a7d974..df64dc5b 100644 --- a/src/http/dune +++ b/src/http/dune @@ -19,6 +19,8 @@ lwt_ssl ssl dream-httpaf.dream-websocketaf + lwt_eio + eio_main dream-httpaf.websocketaf ) (preprocess (pps lwt_ppx)) diff --git a/src/http/error_handler.ml b/src/http/error_handler.ml index d371ea75..7e92b930 100644 --- a/src/http/error_handler.ml +++ b/src/http/error_handler.ml @@ -161,7 +161,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 +181,13 @@ 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) + let response = template error debug_dump response in + Some 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 +195,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 @@ -230,17 +230,19 @@ let double_faults f default = is a programming error, so it's probably fine to return a generic server error. *) let respond_with_option f = + Lwt_eio.Promise.await_lwt @@ double_faults (fun () -> - f () - |> Lwt.map (function - | Some response -> response - | None -> - Message.response - ~status:`Internal_Server_Error Stream.empty Stream.null)) + Lwt_eio.run_eio @@ fun () -> + match f () with + | Some response -> response + | None -> + Message.response + ~status:`Internal_Server_Error Stream.empty Stream.null) (fun () -> Message.response ~status:`Internal_Server_Error Stream.empty Stream.null - |> Lwt.return) + |> Lwt.return + ) @@ -306,7 +308,7 @@ let httpaf Lwt.async begin fun () -> double_faults begin fun () -> - let%lwt response = user's_error_handler error in + let%lwt response = Lwt_eio.run_eio (fun () -> user's_error_handler error) in let response = match response with @@ -364,7 +366,7 @@ let h2 Lwt.async begin fun () -> double_faults begin fun () -> - let%lwt response = user's_error_handler error in + let%lwt response = Lwt_eio.run_eio (fun () -> user's_error_handler error) in let response = match response with @@ -405,7 +407,7 @@ let tls Lwt.async (fun () -> double_faults - (fun () -> Lwt.map ignore (user's_error_handler error)) + (fun () -> Lwt_eio.run_eio (fun () -> user's_error_handler error |> ignore)) Lwt.return) @@ -436,7 +438,7 @@ let websocket Lwt.async (fun () -> double_faults - (fun () -> Lwt.map ignore (user's_error_handler error)) + (fun () -> Lwt_eio.run_eio (fun () -> user's_error_handler error |> ignore)) Lwt.return) diff --git a/src/http/error_handler.mli b/src/http/error_handler.mli index f2a06390..3645a689 100644 --- a/src/http/error_handler.mli +++ b/src/http/error_handler.mli @@ -21,7 +21,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,7 +39,7 @@ val customize : val app : Catch.error_handler -> - (Catch.error -> Message.response Lwt.t) + (Catch.error -> Message.response) val httpaf : Catch.error_handler -> @@ -61,7 +61,7 @@ val websocket : val websocket_handshake : Catch.error_handler -> - (Message.request -> Message.response -> string -> Message.response Lwt.t) + (Message.request -> Message.response -> string -> Message.response) diff --git a/src/http/http.ml b/src/http/http.ml index 5f259617..5bbc6a8b 100644 --- a/src/http/http.ml +++ b/src/http/http.ml @@ -4,6 +4,7 @@ Copyright 2021 Anton Bachin *) +open Eio.Std module Gluten = Dream_gluten.Gluten module Gluten_lwt_unix = Dream_gluten_lwt_unix.Gluten_lwt_unix @@ -57,7 +58,7 @@ let websocket_log = that ordinarily shouldn't be relied on by the user - this is just our last chance to tell the user that something is wrong with their app. *) (* TODO Rename conn like in the body branch. *) -let wrap_handler +let wrap_handler ~sw tls (user's_error_handler : Catch.error_handler) (user's_dream_handler : Message.handler) = @@ -100,7 +101,7 @@ let wrap_handler Stream.stream body Stream.no_writer in let request : Message.request = - Helpers.request ~client ~method_ ~target ~tls ~headers body in + Helpers.request ~sw ~client ~method_ ~target ~tls ~headers 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 @@ -115,7 +116,7 @@ let wrap_handler Lwt.async begin fun () -> Lwt.catch begin fun () -> (* Do the big call. *) - let%lwt response = user's_dream_handler request in + let%lwt response = Lwt_eio.run_eio (fun () -> user's_dream_handler request) in (* Extract the Dream response's headers. *) @@ -167,7 +168,7 @@ let wrap_handler |> function | Ok () -> Lwt.return_unit | Error error_string -> - let%lwt response = + let response = Error_handler.websocket_handshake user's_error_handler request response error_string in @@ -186,7 +187,7 @@ let wrap_handler (* TODO Factor out what is in common between the http/af and h2 handlers. *) -let wrap_handler_h2 +let wrap_handler_h2 ~sw tls (_user's_error_handler : Catch.error_handler) (user's_dream_handler : Message.handler) = @@ -223,7 +224,7 @@ let wrap_handler_h2 Stream.stream body Stream.no_writer in let request : Message.request = - Helpers.request ~client ~method_ ~target ~tls ~headers body in + Helpers.request ~sw ~client ~method_ ~target ~tls ~headers 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 @@ -238,7 +239,7 @@ let wrap_handler_h2 Lwt.async begin fun () -> Lwt.catch begin fun () -> (* Do the big call. *) - let%lwt response = user's_dream_handler request in + let%lwt response = Lwt_eio.run_eio (fun () -> user's_dream_handler request) in (* Extract the Dream response's headers. *) @@ -297,19 +298,19 @@ type tls_library = { unit Lwt.t; } -let no_tls = { +let no_tls ~sw = { create_handler = begin fun ~certificate_file:_ ~key_file:_ ~handler ~error_handler -> Httpaf_lwt_unix.Server.create_connection_handler ?config:None - ~request_handler:(wrap_handler false error_handler handler) + ~request_handler:(wrap_handler ~sw false error_handler handler) ~error_handler:(Error_handler.httpaf error_handler) end; } -let openssl = { +let openssl ~sw:_ = { create_handler = fun ~certificate_file:_ -> failwith "https://github.com/savonet/ocaml-ssl/issues/76" (* create_handler = begin fun @@ -320,15 +321,15 @@ let openssl = { let httpaf_handler = Httpaf_lwt_unix.Server.SSL.create_connection_handler ?config:None - ~request_handler:(wrap_handler true error_handler handler) - ~error_handler:(Error_handler.httpaf error_handler) + ~request_handler:(wrap_handler ~sw true error_handler handler) + ~error_handler:(Error_handler.httpaf ~sw error_handler) in let h2_handler = H2_lwt_unix.Server.SSL.create_connection_handler ?config:None ~request_handler:(wrap_handler_h2 true error_handler handler) - ~error_handler:(Error_handler.h2 error_handler) + ~error_handler:(Error_handler.h2 ~sw error_handler) in let perform_tls_handshake = @@ -371,7 +372,7 @@ let openssl = { } (* TODO LATER Add ALPN + HTTP/2.0 with ocaml-tls, too. *) -let ocaml_tls = { +let ocaml_tls ~sw = { create_handler = fun ~certificate_file ~key_file ~handler @@ -379,7 +380,7 @@ let ocaml_tls = { Httpaf_lwt_unix.Server.TLS.create_connection_handler_with_default ~certfile:certificate_file ~keyfile:key_file ?config:None - ~request_handler:(wrap_handler true error_handler handler) + ~request_handler:(wrap_handler ~sw true error_handler handler) ~error_handler:(Error_handler.httpaf error_handler) } @@ -444,10 +445,10 @@ let serve_with_details let httpaf_connection_handler client_address socket = Lwt.catch (fun () -> - httpaf_connection_handler client_address socket) + httpaf_connection_handler client_address socket) (fun exn -> - tls_error_handler client_address exn; - Lwt.return_unit) + tls_error_handler client_address exn; + Lwt.return_unit) in (* Look up the low-level address corresponding to the interface. Hopefully, @@ -458,19 +459,19 @@ let serve_with_details Printf.ksprintf failwith "Dream.%s: no interface with address %s" caller_function_for_error_messages interface | address::_ -> - let listen_address = Lwt_unix.(address.ai_addr) in + let listen_address = Lwt_unix.(address.ai_addr) in - (* 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 = - Lwt_io.establish_server_with_client_socket - listen_address - httpaf_connection_handler in + (* 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 = + Lwt_io.establish_server_with_client_socket + listen_address + httpaf_connection_handler in - let%lwt () = stop in - Lwt_io.shutdown_server server + let%lwt () = stop in + Lwt_io.shutdown_server server @@ -489,7 +490,9 @@ let serve_with_maybe_https ~builtins user's_dream_handler = - try%lwt + Switch.run @@ fun sw -> + try + Lwt_eio.Promise.await_lwt @@ (* This check will at least catch secrets like "foo" when used on a public interface. *) (* if not (is_localhost interface) then @@ -504,7 +507,7 @@ let serve_with_maybe_https | `No -> serve_with_details caller_function_for_error_messages - no_tls + (no_tls ~sw) ~interface ~port ~stop @@ -561,8 +564,8 @@ let serve_with_maybe_https let tls_library = match tls_library with - | `OpenSSL -> openssl - | `OCaml_TLS -> ocaml_tls + | `OpenSSL -> openssl ~sw + | `OCaml_TLS -> ocaml_tls ~sw in match certificate_and_key with @@ -665,6 +668,7 @@ let run ?(builtins = true) ?(greeting = true) ?(adjust_terminal = true) + env user's_dream_handler = let () = if Sys.unix then @@ -729,7 +733,8 @@ let run end; try - Lwt_main.run begin + begin + Lwt_eio.with_event_loop ~clock:env#clock @@ fun () -> serve_with_maybe_https "run" ~interface diff --git a/src/pure/dune b/src/pure/dune index 76415568..ef00d0e2 100644 --- a/src/pure/dune +++ b/src/pure/dune @@ -6,6 +6,7 @@ bigstringaf hmap lwt + eio uri ptime ) diff --git a/src/pure/message.ml b/src/pure/message.ml index e96da42c..a8f4d140 100644 --- a/src/pure/message.ml +++ b/src/pure/message.ml @@ -4,7 +4,6 @@ Copyright 2021 Anton Bachin *) - (* Type abbreviations and modules used in defining the primary types *) type 'a promise = 'a Lwt.t @@ -50,7 +49,7 @@ type response = server message (* Functions of messages *) -type handler = request -> response Lwt.t +type handler = request -> response type middleware = handler -> handler diff --git a/src/pure/message.mli b/src/pure/message.mli index b05da05d..e8fbe854 100644 --- a/src/pure/message.mli +++ b/src/pure/message.mli @@ -16,7 +16,7 @@ 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 diff --git a/src/server/catch.ml b/src/server/catch.ml index da550b78..a02d37aa 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 @@ -43,12 +43,8 @@ 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) - - (fun response -> + match next_handler request with + | response -> let status = Message.status response in (* TODO Overfull hbox. *) @@ -74,13 +70,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. *) - (fun exn -> + | exception exn -> let error = { condition = `Exn exn; layer = `App; @@ -92,4 +88,4 @@ let catch error_handler next_handler request = will_send_response = true; } in - error_handler error) + error_handler error diff --git a/src/server/content_length.ml b/src/server/content_length.ml new file mode 100644 index 00000000..81568c65 --- /dev/null +++ b/src/server/content_length.ml @@ -0,0 +1,24 @@ +(* This file is part of Dream, released under the MIT license. See LICENSE.md + for details, or visit https://github.com/aantron/dream. + + Copyright 2021 Anton Bachin *) + + + +module Message = Dream_pure.Message + + + +(* TODO Also mind Connection: close. *) +(* TODO Test in integration with HTTP/2. *) +(* TODO This could be renamed transfer_encoding at this point. *) +(* Add a Content-Length header to HTTP 1.x responses that have a fixed body but + don't yet have the header. *) +let content_length next_handler request = + if fst (Message.version request) <> 1 then + next_handler request + else + let (response : Message.response) = next_handler request in + if not (Message.has_header response "Transfer-Encoding") then + Message.add_header response "Transfer-Encoding" "chunked"; + response diff --git a/src/server/dune b/src/server/dune index d7dd67b7..113bb915 100644 --- a/src/server/dune +++ b/src/server/dune @@ -16,6 +16,7 @@ unstrctrd uri yojson + lwt_eio ) (preprocess (pps lwt_ppx)) (instrumentation (backend bisect_ppx))) 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/helpers.ml b/src/server/helpers.ml index 139a3324..e0b919d4 100644 --- a/src/server/helpers.ml +++ b/src/server/helpers.ml @@ -4,6 +4,7 @@ Copyright 2021 Anton Bachin *) +open Eio.Std module Formats = Dream_pure.Formats module Message = Dream_pure.Message @@ -46,7 +47,13 @@ let set_tls request tls = -let request ~client ~method_ ~target ~tls ~headers server_stream = +let switch_field = + Message.new_field + ~name:"dream.switch" + ~show_value:(Fmt.to_to_string Switch.dump) + () + +let request ~sw ~client ~method_ ~target ~tls ~headers server_stream = let request = Message.request ~method_ ~target ~headers Stream.null server_stream in set_client request client; @@ -70,12 +77,12 @@ let respond ?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,9 +94,24 @@ 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 + +(* Ideally, we'd create a new Eio switch for each connection. + But connection creation happens from Lwt at the moment, so we just + push the exception back to Lwt to keep things working as before. *) +let fork_from_lwt ~sw fn = + Fibre.fork ~sw (fun () -> + try fn () + with ex -> !Lwt.async_exception_hook ex + ) + +let get_switch request = + match Message.field request switch_field with + | Some sw -> sw + | None -> failwith "Missing switch field on request!" let stream ?status ?code ?headers ?(close = true) callback = + let sw = get_switch request in let reader, writer = Stream.pipe () in let client_stream = Stream.stream reader Stream.no_writer and server_stream = Stream.stream Stream.no_reader writer in @@ -109,6 +131,36 @@ let stream ?status ?code ?headers ?(close = true) callback = callback server_stream); Lwt.return response + (* let wrapped_callback _ = fork_from_lwt ~sw (fun () -> callback response) in *) + (* Stream.ready server_stream ~close:wrapped_callback wrapped_callback; *) + (* response *) + +let websocket_field = + Message.new_field + ~name:"dream.websocket" + ~show_value:(Printf.sprintf "%b") + () + +let is_websocket response = + match Message.field response websocket_field with + | Some true -> true + | _ -> false + +(* TODO Mark the request as a WebSocket request for HTTP. *) +let websocket ?headers request callback = + let sw = get_switch request in + let in_reader, in_writer = Stream.pipe () + and out_reader, out_writer = Stream.pipe () in + let client_stream = Stream.stream out_reader in_writer + and server_stream = Stream.stream in_reader out_writer in + let response = + Message.response + ~status:`Switching_Protocols ?headers client_stream server_stream in + Message.set_field response websocket_field true; + (* TODO Make sure the request id is propagated to the callback. *) + let wrapped_callback _ = fork_from_lwt ~sw (fun () -> callback response) in + Stream.ready server_stream ~close:wrapped_callback wrapped_callback; + response let empty ?headers status = respond ?headers ~status "" diff --git a/src/server/log.ml b/src/server/log.ml index f2a664f2..bd4064e6 100644 --- a/src/server/log.ml +++ b/src/server/log.ml @@ -493,11 +493,8 @@ 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)) - (fun response -> + match Lwt.with_value id_lwt_key (Some id) (fun () -> next_handler request) with + | response -> (* Log the elapsed time. If the response is a redirection, log the target. *) let location = @@ -531,21 +528,20 @@ struct log.info report end; - Lwt.return response) - - (fun exn -> - let backtrace = Printexc.get_backtrace () in - (* In case of exception, log the exception. We alsp log the backtrace - here, even though it is likely to be redundant, because some OCaml - libraries install exception printers that will clobber the backtrace - right during Printexc.to_string! *) - log.warning (fun log -> + response + | exception exn -> + let backtrace = Printexc.get_backtrace () in + (* In case of exception, log the exception. We alsp log the backtrace + here, even though it is likely to be redundant, because some OCaml + libraries install exception printers that will clobber the backtrace + right during Printexc.to_string! *) + log.warning (fun log -> log ~request "Aborted by: %s" (Printexc.to_string exn)); - backtrace - |> iter_backtrace (fun line -> log.warning (fun log -> log "%s" line)); + backtrace + |> iter_backtrace (fun line -> log.warning (fun log -> log "%s" line)); - Lwt.fail exn) + raise exn end diff --git a/src/server/lowercase_headers.ml b/src/server/lowercase_headers.ml new file mode 100644 index 00000000..fec6dced --- /dev/null +++ b/src/server/lowercase_headers.ml @@ -0,0 +1,23 @@ +(* This file is part of Dream, released under the MIT license. See LICENSE.md + for details, or visit https://github.com/aantron/dream. + + Copyright 2021 Anton Bachin *) + + + +module Message = Dream_pure.Message + + + +(* TODO This middleware might need to be applied right in the h2 adapter, + because error handlers might generate headers that cannot be rewritten + inside the normal stack. *) +(* TODO This can be optimized not to convert a header if it is already + lowercase. Another option is to use memoization to reduce GC pressure. *) +let lowercase_headers inner_handler request = + let response = inner_handler request in + if fst (Message.version request) <> 1 then + Message.all_headers response + |> List.map (fun (name, value) -> String.lowercase_ascii name, value) + |> Message.set_all_headers response; + response 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 57de3d74..8b1cf9bf 100644 --- a/src/server/session.ml +++ b/src/server/session.ml @@ -20,10 +20,10 @@ type 'a back_end = { } let middleware field back_end = fun inner_handler request -> - let%lwt session = back_end.load request in + let session = Lwt_eio.Promise.await_lwt (back_end.load request) in Message.set_field request field session; - let%lwt response = inner_handler request in - back_end.send session request response + let response = inner_handler request in + Lwt_eio.Promise.await_lwt (back_end.send session request response) let getter field request = match Message.field request field with @@ -56,8 +56,8 @@ type session = { } type operations = { - put : string -> string -> unit Lwt.t; - invalidate : unit -> unit Lwt.t; + put : string -> string -> unit; + invalidate : unit -> unit; mutable dirty : bool; } @@ -124,14 +124,12 @@ 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 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 = { @@ -213,13 +211,11 @@ 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 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 = { 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/sql/session.ml b/src/sql/session.ml index 28242e45..a3a8d279 100644 --- a/src/sql/session.ml +++ b/src/sql/session.ml @@ -125,15 +125,19 @@ let put request (session : Session.session) name value = |> List.remove_assoc name |> fun dictionary -> (name, value)::dictionary |> fun dictionary -> session.payload <- dictionary; - Sql.sql request (fun db -> update db session) + Lwt_eio.Promise.await_lwt begin + Sql.sql request (fun db -> update db session) + end let invalidate request lifetime operations (session : Session.session ref) = - Sql.sql request begin fun db -> - let%lwt () = remove db !session.id in - let%lwt new_session = create db (Unix.gettimeofday () +. lifetime) 1 in - session := new_session; - operations.Session.dirty <- true; - Lwt.return_unit + Lwt_eio.Promise.await_lwt begin + Sql.sql request begin fun db -> + let%lwt () = remove db !session.id in + let%lwt new_session = create db (Unix.gettimeofday () +. lifetime) 1 in + session := new_session; + operations.Session.dirty <- true; + Lwt.return_unit + end end let operations request lifetime (session : Session.session ref) dirty = diff --git a/src/unix/static.ml b/src/unix/static.ml index c3c0470c..06e8764a 100644 --- a/src/unix/static.ml +++ b/src/unix/static.ml @@ -28,16 +28,16 @@ let mime_lookup filename = let from_filesystem local_root path _ = let file = Filename.concat local_root path in - Lwt.catch - (fun () -> + try + Lwt_eio.Promise.await_lwt ( Lwt_io.(with_file ~mode:Input file) (fun channel -> - let%lwt content = Lwt_io.read channel in - Message.response - ~headers:(mime_lookup path) (Stream.string content) Stream.null - |> Lwt.return)) - (fun _exn -> - Message.response ~status:`Not_Found Stream.empty Stream.null - |> Lwt.return) + let%lwt content = Lwt_io.read channel in + Message.response + ~headers:(mime_lookup path) (Stream.string content) Stream.null + |> Lwt.return) + ) + with _exn -> + Message.response ~status:`Not_Found Stream.empty Stream.null (* TODO Add ETag handling. *) (* TODO Add Content-Length handling? *) @@ -76,16 +76,14 @@ let static ?(loader = from_filesystem) 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 + let response = loader 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 From 5c276c54f918fe9f9d6fb2beb18a03f37b226795 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Mon, 3 Apr 2023 10:37:14 +0200 Subject: [PATCH 04/42] Use Eio to accept network connections After accepting a connection we convert it to a Lwt_unix.file_descr and continue as before. The `stop` argument has gone, as you can now just cancel the Eio fibre instead. Note that this will cancel all running requests too (unlike the previous behaviour, where it only stopped accepting new connections). --- src/dream.mli | 9 +--- src/http/http.ml | 109 ++++++++++++++++++++++++------------------ src/server/helpers.ml | 14 ++---- 3 files changed, 68 insertions(+), 64 deletions(-) diff --git a/src/dream.mli b/src/dream.mli index cd600b0c..e86c2f08 100644 --- a/src/dream.mli +++ b/src/dream.mli @@ -2195,7 +2195,6 @@ val catch : (error -> response) -> middleware val run : ?interface:string -> ?port:int -> - ?stop:unit promise -> ?error_handler:error_handler -> ?tls:bool -> ?certificate_file:string -> @@ -2203,7 +2202,7 @@ val run : ?builtins:bool -> ?greeting:bool -> ?adjust_terminal:bool -> - < clock: Eio.Time.clock; ..> -> + < clock:#Eio.Time.clock; net:#Eio.Net.t; ..> -> handler -> unit (** Runs the Web application represented by the {!handler}, by default at {{:http://localhost:8080} http://localhost:8080}. @@ -2215,10 +2214,6 @@ val run : - [~interface] is the network interface to listen on. Defaults to ["localhost"]. Use ["0.0.0.0"] to listen on all interfaces. - [~port] is the port to listen on. Defaults to [8080]. - - [~stop] is a promise that causes the server to stop accepting new - requests, and {!Dream.run} to return. Requests that have already entered - the Web application continue to be processed. The default value is a - promise that never resolves. However, see also [~stop_on_input]. - [~debug:true] enables debug information in error templates. See {!Dream.error_template}. The default is [false], to prevent accidental deployment with debug output turned on. See example @@ -2255,12 +2250,12 @@ val run : val serve : ?interface:string -> ?port:int -> - ?stop:unit promise -> ?error_handler:error_handler -> ?tls:bool -> ?certificate_file:string -> ?key_file:string -> ?builtins:bool -> + net:#Eio.Net.t -> handler -> unit (** Like {!Dream.run}, but returns a promise that does not resolve until the server stops listening, instead of calling diff --git a/src/http/http.ml b/src/http/http.ml index 5bbc6a8b..62918828 100644 --- a/src/http/http.ml +++ b/src/http/http.ml @@ -293,16 +293,18 @@ type tls_library = { key_file:string -> handler:Message.handler -> error_handler:Catch.error_handler -> + sw:Switch.t -> Unix.sockaddr -> Lwt_unix.file_descr -> unit Lwt.t; } -let no_tls ~sw = { +let no_tls = { create_handler = begin fun ~certificate_file:_ ~key_file:_ ~handler - ~error_handler -> + ~error_handler + ~sw -> Httpaf_lwt_unix.Server.create_connection_handler ?config:None ~request_handler:(wrap_handler ~sw false error_handler handler) @@ -310,7 +312,7 @@ let no_tls ~sw = { end; } -let openssl ~sw:_ = { +let openssl = { create_handler = fun ~certificate_file:_ -> failwith "https://github.com/savonet/ocaml-ssl/issues/76" (* create_handler = begin fun @@ -372,11 +374,12 @@ let openssl ~sw:_ = { } (* TODO LATER Add ALPN + HTTP/2.0 with ocaml-tls, too. *) -let ocaml_tls ~sw = { +let ocaml_tls = { create_handler = fun ~certificate_file ~key_file ~handler - ~error_handler -> + ~error_handler + ~sw -> Httpaf_lwt_unix.Server.TLS.create_connection_handler_with_default ~certfile:certificate_file ~keyfile:key_file ?config:None @@ -393,12 +396,22 @@ let built_in_middleware error_handler = +let of_unix_addr = function + | Unix.ADDR_INET (host, port) -> `Tcp (host, port) + | Unix.ADDR_UNIX path -> `Unix path + +let to_unix_addr = function + | `Tcp (host, port) -> Unix.ADDR_INET (host, port) + | `Unix path -> Unix.ADDR_UNIX path + + + let serve_with_details caller_function_for_error_messages tls_library + ~net ~interface ~port - ~stop ~error_handler ~certificate_file ~key_file @@ -442,36 +455,40 @@ 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. *) - let httpaf_connection_handler client_address socket = - Lwt.catch - (fun () -> - httpaf_connection_handler client_address socket) - (fun exn -> - tls_error_handler client_address exn; - Lwt.return_unit) + let httpaf_connection_handler ~sw flow client_address = + let client_address = to_unix_addr client_address in + try + let fd = Eio_unix.FD.take flow |> Option.get in + let socket = Lwt_unix.of_unix_file_descr fd in + Lwt_eio.Promise.await_lwt @@ + httpaf_connection_handler ~sw client_address socket + with exn -> + tls_error_handler client_address exn in - (* Look up the low-level address corresponding to the interface. Hopefully, - this is a local interface. *) - let%lwt addresses = Lwt_unix.getaddrinfo interface (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::_ -> - let listen_address = Lwt_unix.(address.ai_addr) in - - - (* 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 = - Lwt_io.establish_server_with_client_socket - listen_address - httpaf_connection_handler in + let listen_address = Lwt_eio.Promise.await_lwt @@ + (* Look up the low-level address corresponding to the interface. Hopefully, + this is a local interface. *) + let%lwt addresses = Lwt_unix.getaddrinfo interface (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 (of_unix_addr Lwt_unix.(address.ai_addr)) + in - let%lwt () = stop in - Lwt_io.shutdown_server server + (* Bring up the HTTP server. *) + Switch.run @@ fun sw -> + let socket = + Eio.Net.listen ~sw net listen_address + ~reuse_addr:true + ~backlog:(Lwt_unix.somaxconn () [@ocaml.warning "-3"]) + in + while true do + Eio.Net.accept_sub ~sw socket httpaf_connection_handler + ~on_error:(fun ex -> !Lwt.async_exception_hook ex) + done @@ -482,17 +499,15 @@ let serve_with_maybe_https caller_function_for_error_messages ~interface ~port - ~stop ~error_handler ~tls ?certificate_file ?key_file ?certificate_string ?key_string ~builtins + ~net user's_dream_handler = - Switch.run @@ fun sw -> try - Lwt_eio.Promise.await_lwt @@ (* This check will at least catch secrets like "foo" when used on a public interface. *) (* if not (is_localhost interface) then @@ -507,10 +522,10 @@ let serve_with_maybe_https | `No -> serve_with_details caller_function_for_error_messages - (no_tls ~sw) + no_tls + ~net ~interface ~port - ~stop ~error_handler ~certificate_file:"" ~key_file:"" @@ -564,8 +579,8 @@ let serve_with_maybe_https let tls_library = match tls_library with - | `OpenSSL -> openssl ~sw - | `OCaml_TLS -> ocaml_tls ~sw + | `OpenSSL -> openssl + | `OCaml_TLS -> ocaml_tls in match certificate_and_key with @@ -573,9 +588,9 @@ let serve_with_maybe_https serve_with_details caller_function_for_error_messages tls_library + ~net ~interface ~port - ~stop ~error_handler ~certificate_file ~key_file @@ -583,6 +598,7 @@ let serve_with_maybe_https user's_dream_handler | `Memory (certificate_string, key_string, verbose_or_silent) -> + Lwt_eio.Promise.await_lwt @@ Lwt_io.with_temp_file begin fun (certificate_file, certificate_stream) -> Lwt_io.with_temp_file begin fun (key_file, key_stream) -> @@ -598,16 +614,17 @@ let serve_with_maybe_https let%lwt () = Lwt_io.close certificate_stream in let%lwt () = Lwt_io.close key_stream in + Lwt_eio.run_eio @@ fun () -> serve_with_details caller_function_for_error_messages tls_library ~interface ~port - ~stop ~error_handler ~certificate_file ~key_file ~builtins + ~net user's_dream_handler end @@ -626,26 +643,25 @@ let serve_with_maybe_https let default_interface = "localhost" let default_port = 8080 -let never = fst (Lwt.wait ()) let serve ?(interface = default_interface) ?(port = default_port) - ?(stop = never) ?(error_handler = Error_handler.default) ?(tls = false) ?certificate_file ?key_file ?(builtins = true) + ~net user's_dream_handler = serve_with_maybe_https "serve" + ~net ~interface ~port - ~stop ~error_handler ~tls:(if tls then `OpenSSL else `No) ?certificate_file @@ -660,7 +676,6 @@ let serve let run ?(interface = default_interface) ?(port = default_port) - ?(stop = never) ?(error_handler = Error_handler.default) ?(tls = false) ?certificate_file @@ -737,9 +752,9 @@ let run Lwt_eio.with_event_loop ~clock:env#clock @@ fun () -> serve_with_maybe_https "run" + ~net:env#net ~interface ~port - ~stop ~error_handler ~tls:(if tls then `OpenSSL else `No) ?certificate_file ?key_file diff --git a/src/server/helpers.ml b/src/server/helpers.ml index e0b919d4..b8b47201 100644 --- a/src/server/helpers.ml +++ b/src/server/helpers.ml @@ -96,15 +96,6 @@ let redirect ?status ?code ?headers _request location = Message.set_header response "Location" location; response -(* Ideally, we'd create a new Eio switch for each connection. - But connection creation happens from Lwt at the moment, so we just - push the exception back to Lwt to keep things working as before. *) -let fork_from_lwt ~sw fn = - Fibre.fork ~sw (fun () -> - try fn () - with ex -> !Lwt.async_exception_hook ex - ) - let get_switch request = match Message.field request switch_field with | Some sw -> sw @@ -134,6 +125,9 @@ let stream ?status ?code ?headers ?(close = true) callback = (* let wrapped_callback _ = fork_from_lwt ~sw (fun () -> callback response) in *) (* Stream.ready server_stream ~close:wrapped_callback wrapped_callback; *) (* response *) + (* let wrapped_callback _ = Fibre.fork ~sw (fun () -> callback response) in *) + (* Stream.ready server_stream ~close:wrapped_callback wrapped_callback; *) + (* response *) let websocket_field = Message.new_field @@ -158,7 +152,7 @@ let websocket ?headers request callback = ~status:`Switching_Protocols ?headers client_stream server_stream in Message.set_field response websocket_field true; (* TODO Make sure the request id is propagated to the callback. *) - let wrapped_callback _ = fork_from_lwt ~sw (fun () -> callback response) in + let wrapped_callback _ = Fibre.fork ~sw (fun () -> callback response) in Stream.ready server_stream ~close:wrapped_callback wrapped_callback; response From 5a6cac010393032690f586f63faedc0f263745f6 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Thu, 3 Feb 2022 11:16:40 +0000 Subject: [PATCH 05/42] Remove ssl dependency Segfaults due to https://github.com/savonet/ocaml-ssl/issues/76 --- dream-httpaf.opam | 2 -- dream.opam | 2 -- 2 files changed, 4 deletions(-) diff --git a/dream-httpaf.opam b/dream-httpaf.opam index 292bd829..1387d422 100644 --- a/dream-httpaf.opam +++ b/dream-httpaf.opam @@ -17,9 +17,7 @@ depends: [ "dune" {>= "2.7.0"} # --instrument-with. "lwt" "lwt_ppx" {>= "1.2.2"} - "lwt_ssl" "ocaml" {>= "4.08.0"} - "ssl" {>= "0.5.8"} # Ssl.get_negotiated_alpn_protocol. # Currently vendored. # "gluten" diff --git a/dream.opam b/dream.opam index 07e14a0b..27a7da02 100644 --- a/dream.opam +++ b/dream.opam @@ -62,7 +62,6 @@ depends: [ "graphql-lwt" "lwt" "lwt_ppx" {>= "1.2.2"} - "lwt_ssl" "logs" {>= "0.5.0"} "magic-mime" "mirage-clock" {>= "3.0.0"} # now_d_ps : unit -> int * int64. @@ -73,7 +72,6 @@ depends: [ "multipart_form-lwt" "ocaml" {>= "4.08.0"} "ptime" {>= "0.8.1"} # Ptime.v. - "ssl" {>= "0.5.8"} # Ssl.get_negotiated_alpn_protocol. "uri" {>= "4.2.0"} "yojson" # ... From 703db62b2d511cd2d99c84ae2169b6fa144b91a0 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Thu, 3 Feb 2022 11:21:11 +0000 Subject: [PATCH 06/42] Update to Eio 0.1 --- dream-pure.opam | 1 + dream.opam | 2 ++ example/w-long-polling/long_polling.eml.ml | 2 +- src/http/http.ml | 4 ++-- 4 files changed, 6 insertions(+), 3 deletions(-) diff --git a/dream-pure.opam b/dream-pure.opam index 6f6b7f26..78ed4cb9 100644 --- a/dream-pure.opam +++ b/dream-pure.opam @@ -22,6 +22,7 @@ depends: [ "ocaml" {>= "4.08.0"} "ptime" {>= "0.8.1"} # Ptime.weekday. "uri" {>= "4.2.0"} + "eio" {>= "0.1"} # Testing, development. "alcotest" {with-test} diff --git a/dream.opam b/dream.opam index 27a7da02..41ff0027 100644 --- a/dream.opam +++ b/dream.opam @@ -74,6 +74,8 @@ depends: [ "ptime" {>= "0.8.1"} # Ptime.v. "uri" {>= "4.2.0"} "yojson" # ... + "eio_main" {>= "0.1"} + "lwt_eio" {>= "0.1"} # Testing, development. "alcotest" {with-test} diff --git a/example/w-long-polling/long_polling.eml.ml b/example/w-long-polling/long_polling.eml.ml index 86c12044..4ba1135e 100644 --- a/example/w-long-polling/long_polling.eml.ml +++ b/example/w-long-polling/long_polling.eml.ml @@ -71,7 +71,7 @@ let () = | Messages_accumulating [] -> let response_promise, respond = Promise.create () in server_state := Client_waiting (fun message -> - Promise.fulfill respond (Dream.response message)); + Promise.resolve respond (Dream.response message)); Promise.await response_promise | Messages_accumulating messages -> server_state := Messages_accumulating []; diff --git a/src/http/http.ml b/src/http/http.ml index 62918828..301315a4 100644 --- a/src/http/http.ml +++ b/src/http/http.ml @@ -397,11 +397,11 @@ let built_in_middleware error_handler = let of_unix_addr = function - | Unix.ADDR_INET (host, port) -> `Tcp (host, port) + | Unix.ADDR_INET (host, port) -> `Tcp (Eio_unix.Ipaddr.of_unix host, port) | Unix.ADDR_UNIX path -> `Unix path let to_unix_addr = function - | `Tcp (host, port) -> Unix.ADDR_INET (host, port) + | `Tcp (host, port) -> Unix.ADDR_INET (Eio_unix.Ipaddr.to_unix host, port) | `Unix path -> Unix.ADDR_UNIX path From 88d0b24722ba021fedbe54cd39e8e2b9b1282658 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Mon, 3 Apr 2023 10:40:43 +0200 Subject: [PATCH 07/42] Update to Eio 0.2 Just fixes some deprecation warnings. --- dream-pure.opam | 2 +- dream.opam | 2 +- example/w-chat/chat.eml.ml | 2 +- example/w-long-polling/long_polling.eml.ml | 2 +- .../w-server-sent-events/server_sent_events.eml.ml | 2 +- example/w-stress-response/stress_response.ml | 14 +++++++------- .../stress_websocket_send.eml.ml | 12 ++++++------ src/server/helpers.ml | 7 ++----- 8 files changed, 20 insertions(+), 23 deletions(-) diff --git a/dream-pure.opam b/dream-pure.opam index 78ed4cb9..b3a44e28 100644 --- a/dream-pure.opam +++ b/dream-pure.opam @@ -22,7 +22,7 @@ depends: [ "ocaml" {>= "4.08.0"} "ptime" {>= "0.8.1"} # Ptime.weekday. "uri" {>= "4.2.0"} - "eio" {>= "0.1"} + "eio" {>= "0.2"} # Testing, development. "alcotest" {with-test} diff --git a/dream.opam b/dream.opam index 41ff0027..56110801 100644 --- a/dream.opam +++ b/dream.opam @@ -74,7 +74,7 @@ depends: [ "ptime" {>= "0.8.1"} # Ptime.v. "uri" {>= "4.2.0"} "yojson" # ... - "eio_main" {>= "0.1"} + "eio_main" {>= "0.2"} "lwt_eio" {>= "0.1"} # Testing, development. diff --git a/example/w-chat/chat.eml.ml b/example/w-chat/chat.eml.ml index 7e390bdc..84f0ab22 100644 --- a/example/w-chat/chat.eml.ml +++ b/example/w-chat/chat.eml.ml @@ -50,7 +50,7 @@ let send message = Hashtbl.to_seq_values clients |> List.of_seq |> List.iter (fun client -> - Fibre.fork ~sw (fun () -> Dream.send client message) + Fiber.fork ~sw (fun () -> Dream.send client message) ) let handle_client client = diff --git a/example/w-long-polling/long_polling.eml.ml b/example/w-long-polling/long_polling.eml.ml index 4ba1135e..9f642104 100644 --- a/example/w-long-polling/long_polling.eml.ml +++ b/example/w-long-polling/long_polling.eml.ml @@ -55,7 +55,7 @@ let message_loop clock = let () = Eio_main.run @@ fun env -> - Fibre.both + Fiber.both (fun () -> message_loop env#clock) (fun () -> Dream.run env diff --git a/example/w-server-sent-events/server_sent_events.eml.ml b/example/w-server-sent-events/server_sent_events.eml.ml index 8b76223e..874027ce 100644 --- a/example/w-server-sent-events/server_sent_events.eml.ml +++ b/example/w-server-sent-events/server_sent_events.eml.ml @@ -68,7 +68,7 @@ let forward_messages response = Lwt_eio.Promise.await_lwt (forward_messages resp let () = Eio_main.run @@ fun env -> - Fibre.both + Fiber.both (fun () -> message_loop env#clock) (fun () -> Dream.run env diff --git a/example/w-stress-response/stress_response.ml b/example/w-stress-response/stress_response.ml index c7d6599b..f93c6e48 100644 --- a/example/w-stress-response/stress_response.ml +++ b/example/w-stress-response/stress_response.ml @@ -16,14 +16,14 @@ let stress ?(megabytes = 1024) ?(chunk = 64) stream = let start = Unix.gettimeofday () in let rec loop sent = - if sent >= limit then - let () = Dream.flush stream in - let () = Dream.close stream in + if sent >= limit then ( + Dream.flush stream; + Dream.close stream; Unix.gettimeofday () -. start - else - let () = Dream.write stream chunk_a in - let () = Dream.write stream chunk_b in - let () = Fiber.yield () in + ) else ( + Dream.write stream chunk_a; + Dream.write stream chunk_b; + Fiber.yield (); loop (sent + chunk + chunk) ) in diff --git a/example/w-stress-websocket-send/stress_websocket_send.eml.ml b/example/w-stress-websocket-send/stress_websocket_send.eml.ml index af96aca1..fe4d921f 100644 --- a/example/w-stress-websocket-send/stress_websocket_send.eml.ml +++ b/example/w-stress-websocket-send/stress_websocket_send.eml.ml @@ -43,13 +43,13 @@ let stress websocket = let limit = 1024 * 1024 * 1024 in let start = Unix.gettimeofday () in let rec loop sent = - if sent >= limit then - let () = Dream.close_websocket websocket in + if sent >= limit then ( + Dream.close_websocket websocket; Unix.gettimeofday () -. start - else - let () = Dream.send websocket frame_a ~text_or_binary:`Binary in - let () = Dream.send websocket frame_b ~text_or_binary:`Binary in - let () = Fiber.yield () in + ) else ( + Dream.send websocket frame_a ~text_or_binary:`Binary; + Dream.send websocket frame_b ~text_or_binary:`Binary; + Fiber.yield (); loop (sent + frame + frame) ) in diff --git a/src/server/helpers.ml b/src/server/helpers.ml index b8b47201..920be103 100644 --- a/src/server/helpers.ml +++ b/src/server/helpers.ml @@ -122,10 +122,7 @@ let stream ?status ?code ?headers ?(close = true) callback = callback server_stream); Lwt.return response - (* let wrapped_callback _ = fork_from_lwt ~sw (fun () -> callback response) in *) - (* Stream.ready server_stream ~close:wrapped_callback wrapped_callback; *) - (* response *) - (* let wrapped_callback _ = Fibre.fork ~sw (fun () -> callback response) in *) + (* let wrapped_callback _ = Fiber.fork ~sw (fun () -> callback response) in *) (* Stream.ready server_stream ~close:wrapped_callback wrapped_callback; *) (* response *) @@ -152,7 +149,7 @@ let websocket ?headers request callback = ~status:`Switching_Protocols ?headers client_stream server_stream in Message.set_field response websocket_field true; (* TODO Make sure the request id is propagated to the callback. *) - let wrapped_callback _ = Fibre.fork ~sw (fun () -> callback response) in + let wrapped_callback _ = Fiber.fork ~sw (fun () -> callback response) in Stream.ready server_stream ~close:wrapped_callback wrapped_callback; response From 942dbfcd01f53aa9741a3723a2c5ed911822ec84 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Mon, 3 Apr 2023 10:41:27 +0200 Subject: [PATCH 08/42] Use Eio_unix.sleep in examples Anton says he prefers not passing the clock as an argument. --- example/r-template-stream/template_stream.eml.re | 7 +++---- example/w-long-polling/long_polling.eml.ml | 6 +++--- .../w-server-sent-events/server_sent_events.eml.ml | 6 +++--- example/w-template-stream/template_stream.eml.ml | 14 +++++++++++++- 4 files changed, 22 insertions(+), 11 deletions(-) diff --git a/example/r-template-stream/template_stream.eml.re b/example/r-template-stream/template_stream.eml.re index ef79b3be..83f10e33 100644 --- a/example/r-template-stream/template_stream.eml.re +++ b/example/r-template-stream/template_stream.eml.re @@ -10,8 +10,7 @@ let render = clock => response => { % paragraphs(index + 1); % }; % let%lwt () = paragraphs(0); - -# let render = clock => response => { +# let render = response => { # let () = { # %% response # @@ -20,7 +19,7 @@ let render = clock => response => { # % let rec paragraphs = index => { #

<%i index %>

# % Dream.flush(response); -# % Eio.Time.sleep(clock, 1.); +# % Eio_unix.sleep(1.); # % if (index < 10) paragraphs(index + 1); # % }; # % paragraphs(0); @@ -33,4 +32,4 @@ let () = Eio_main.run @@ env => Dream.run(env) @@ Dream.logger - @@ request => Dream.stream(~headers=[("Content-Type", Dream.text_html)], request, render(env#clock)); + @@ request => Dream.stream(~headers=[("Content-Type", Dream.text_html)], request, render); diff --git a/example/w-long-polling/long_polling.eml.ml b/example/w-long-polling/long_polling.eml.ml index 9f642104..1f185a06 100644 --- a/example/w-long-polling/long_polling.eml.ml +++ b/example/w-long-polling/long_polling.eml.ml @@ -36,9 +36,9 @@ let server_state = let last_message = ref 0 -let message_loop clock = +let message_loop () = while true do - Eio.Time.sleep clock (Random.float 2.); + Eio_unix.sleep (Random.float 2.); incr last_message; let message = string_of_int !last_message in @@ -56,7 +56,7 @@ let message_loop clock = let () = Eio_main.run @@ fun env -> Fiber.both - (fun () -> message_loop env#clock) + message_loop (fun () -> Dream.run env @@ Dream.logger diff --git a/example/w-server-sent-events/server_sent_events.eml.ml b/example/w-server-sent-events/server_sent_events.eml.ml index 874027ce..51604048 100644 --- a/example/w-server-sent-events/server_sent_events.eml.ml +++ b/example/w-server-sent-events/server_sent_events.eml.ml @@ -28,9 +28,9 @@ let notify = let last_message = ref 0 -let message_loop clock = +let message_loop () = while true do - Eio.Time.sleep clock (Random.float 2.); + Eio_unix.sleep (Random.float 2.); incr last_message; let message = string_of_int !last_message in @@ -69,7 +69,7 @@ let forward_messages response = Lwt_eio.Promise.await_lwt (forward_messages resp let () = Eio_main.run @@ fun env -> Fiber.both - (fun () -> message_loop env#clock) + message_loop (fun () -> Dream.run env @@ Dream.logger diff --git a/example/w-template-stream/template_stream.eml.ml b/example/w-template-stream/template_stream.eml.ml index 7a61b91c..bd7d2c5c 100644 --- a/example/w-template-stream/template_stream.eml.ml +++ b/example/w-template-stream/template_stream.eml.ml @@ -10,6 +10,18 @@ let render response = % paragraphs (index + 1) % in % let%lwt () = paragraphs 0 in +(* let () = *) +(* %% response *) +(* *) +(* *) + +(* % let rec paragraphs index = *) +(*

<%i index %>

*) +(* % Dream.flush response; *) +(* % Eio_unix.sleep 1.; *) +(* % if index < 10 then paragraphs (index + 1) *) +(* % in *) +(* % paragraphs 0; *) (* let render ~clock response = *) (* let () = *) @@ -32,4 +44,4 @@ let () = Eio_main.run @@ fun env -> Dream.run env @@ Dream.logger - @@ fun request -> Dream.stream ~headers:["Content-Type", Dream.text_html] request (render ~clock:env#clock) + @@ fun request -> Dream.stream ~headers:["Content-Type", Dream.text_html] request render From 189929e79741188c811b0a29748ae939fad5f8df Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Mon, 13 Mar 2023 12:11:18 +0100 Subject: [PATCH 09/42] Fix most remaining errors --- example/r-template-logic/template.eml.re | 3 +- example/w-chat/chat.eml.ml | 2 +- example/w-fullstack-jsoo/server/server.eml.ml | 3 +- example/w-live-reload/live_reload.ml | 2 +- .../server_sent_events.eml.ml | 7 ++- example/w-stress-response/stress_response.ml | 2 +- .../stress_websocket_send.eml.ml | 2 +- example/w-template-logic/template.eml.ml | 3 +- .../w-template-stream/template_stream.eml.ml | 7 +++ example/z-playground/server/playground.ml | 34 +++++------ src/dream.mli | 10 +-- src/graphql/graphql.ml | 61 ++++++++----------- src/http/http.ml | 15 +++-- src/mirage/error_handler.ml | 48 ++++++--------- src/mirage/mirage.ml | 8 +-- src/mirage/mirage.mli | 36 +++++------ src/server/content_length.ml | 24 -------- src/server/helpers.ml | 29 +++------ src/server/lowercase_headers.ml | 23 ------- test/expect/pure/message/message.ml | 10 +-- 20 files changed, 127 insertions(+), 202 deletions(-) delete mode 100644 src/server/content_length.ml delete mode 100644 src/server/lowercase_headers.ml diff --git a/example/r-template-logic/template.eml.re b/example/r-template-logic/template.eml.re index f9f44f95..ba58d0bb 100644 --- a/example/r-template-logic/template.eml.re +++ b/example/r-template-logic/template.eml.re @@ -36,7 +36,8 @@ let tasks = [ ]; let () = - Dream.run + Eio_main.run + @@ fun env -> Dream.run env @@ Dream.logger @@ Dream.router([ diff --git a/example/w-chat/chat.eml.ml b/example/w-chat/chat.eml.ml index 84f0ab22..8e21662e 100644 --- a/example/w-chat/chat.eml.ml +++ b/example/w-chat/chat.eml.ml @@ -76,6 +76,6 @@ let () = (fun _ -> Dream.html home); Dream.get "/websocket" - (fun request -> Dream.websocket request handle_client); + (fun _ -> Dream.websocket handle_client); ] diff --git a/example/w-fullstack-jsoo/server/server.eml.ml b/example/w-fullstack-jsoo/server/server.eml.ml index 9f97307b..40cad8ab 100644 --- a/example/w-fullstack-jsoo/server/server.eml.ml +++ b/example/w-fullstack-jsoo/server/server.eml.ml @@ -7,7 +7,8 @@ let home = let () = - Dream.run + Eio_main.run + @@ fun env -> Dream.run env @@ Dream.logger @@ Dream.router [ diff --git a/example/w-live-reload/live_reload.ml b/example/w-live-reload/live_reload.ml index 9eee6752..b267af62 100644 --- a/example/w-live-reload/live_reload.ml +++ b/example/w-live-reload/live_reload.ml @@ -72,7 +72,7 @@ let () = |> Dream.html); Dream.get "/_live-reload" (fun request -> - Dream.websocket request (fun socket -> + Dream.websocket (fun socket -> let _ = Dream.receive socket in Dream.close_websocket socket)); diff --git a/example/w-server-sent-events/server_sent_events.eml.ml b/example/w-server-sent-events/server_sent_events.eml.ml index 51604048..d5d22047 100644 --- a/example/w-server-sent-events/server_sent_events.eml.ml +++ b/example/w-server-sent-events/server_sent_events.eml.ml @@ -77,8 +77,8 @@ let () = Dream.get "/" (fun _ -> Dream.html home); - Dream.get "/push" (fun request -> - Dream.stream request + Dream.get "/push" (fun _ -> + Dream.stream ~headers:["Content-Type", "text/event-stream"] forward_messages); @@ -87,4 +87,5 @@ let () = ~headers:["Content-Type", "text/event-stream"] forward_messages); - ] + ] + ) diff --git a/example/w-stress-response/stress_response.ml b/example/w-stress-response/stress_response.ml index f93c6e48..f614baaf 100644 --- a/example/w-stress-response/stress_response.ml +++ b/example/w-stress-response/stress_response.ml @@ -45,7 +45,7 @@ let () = @@ Dream.router [ Dream.get "/" (fun request -> - Dream.stream request + Dream.stream ~headers:["Content-Type", "application/octet-stream"] (stress ?megabytes:(query_int request "mb") diff --git a/example/w-stress-websocket-send/stress_websocket_send.eml.ml b/example/w-stress-websocket-send/stress_websocket_send.eml.ml index fe4d921f..5385317a 100644 --- a/example/w-stress-websocket-send/stress_websocket_send.eml.ml +++ b/example/w-stress-websocket-send/stress_websocket_send.eml.ml @@ -71,6 +71,6 @@ let () = (fun _ -> Dream.html home); Dream.get "/websocket" - (fun request -> Dream.websocket request stress); + (fun _ -> Dream.websocket stress); ] diff --git a/example/w-template-logic/template.eml.ml b/example/w-template-logic/template.eml.ml index b2c60c66..af93db55 100644 --- a/example/w-template-logic/template.eml.ml +++ b/example/w-template-logic/template.eml.ml @@ -35,7 +35,8 @@ let tasks = [ ] let () = - Dream.run + Eio_main.run + @@ fun env -> Dream.run env @@ Dream.logger @@ Dream.router [ diff --git a/example/w-template-stream/template_stream.eml.ml b/example/w-template-stream/template_stream.eml.ml index bd7d2c5c..42e73b63 100644 --- a/example/w-template-stream/template_stream.eml.ml +++ b/example/w-template-stream/template_stream.eml.ml @@ -36,6 +36,13 @@ let render response = (* % if index < 10 then paragraphs (index + 1) *) (* % in *) (* % paragraphs 0; *) +(* % let rec paragraphs index = *) +(*

<%i index %>

*) +(* % Dream.flush response; *) +(* % Eio_unix.sleep 1.; *) +(* % paragraphs (index + 1) *) +(* % in *) +(* % paragraphs 0 *) diff --git a/example/z-playground/server/playground.ml b/example/z-playground/server/playground.ml index 52a7e665..3579df1c 100644 --- a/example/z-playground/server/playground.ml +++ b/example/z-playground/server/playground.ml @@ -66,7 +66,7 @@ let create_sandboxes_directory () = | exception Unix.(Unix_error (EEXIST, _, _)) -> Lwt.return_unit let exists sandbox = - Lwt_unix.file_exists (sandbox_root // sandbox) + Lwt_eio.Promise.await_lwt @@ Lwt_unix.file_exists (sandbox_root // sandbox) let write_file sandbox file content = Lwt_io.(with_file @@ -97,7 +97,7 @@ let rec create ?(attempts = 3) syntax eml code = match sandbox.[0] with | '_' | '-' -> create ~attempts syntax eml code | _ -> - match%lwt exists sandbox with + match exists sandbox with | true -> create ~attempts:(attempts - 1) syntax eml code | false -> create_named sandbox syntax eml code @@ -152,15 +152,14 @@ let allocated_ports = let kill_container session = match session.container with - | None -> Lwt.return_unit + | None -> () | Some {container_id; port} -> session.container <- None; Dream.info (fun log -> log "Sandbox %s: killing container %s" session.sandbox container_id); - let%lwt _status = + let _status = exec "docker kill %s > /dev/null 2> /dev/null" container_id in - Hashtbl.remove allocated_ports port; - Lwt.return_unit + Hashtbl.remove allocated_ports port let min_port = 9000 let max_port = 9999 @@ -241,7 +240,7 @@ let build session = | Some output -> Dream.info (fun log -> log "Sandbox %s: sending build output" session.sandbox); - client_log session output;%lwt + client_log session output; Lwt.return_false let image_exists sandbox = @@ -301,13 +300,13 @@ let run session = client_log ~add_newline:true session line) end; alive;%lwt - started session port;%lwt + started session port; Dream.info (fun log -> log "Sandbox %s: started %s on port %i" session.sandbox container_id port); Lwt.return_unit let kill session = - let%lwt () = kill_container session in + kill_container session; Dream.close_websocket session.socket @@ -350,7 +349,7 @@ let lock_sandbox sandbox f = Lwt.return_unit) let rec listen session = - match%lwt Dream.receive session.socket with + match Dream.receive session.socket with | None -> Dream.info (fun log -> log "WebSocket closed by client"); kill session @@ -504,23 +503,22 @@ let () = match validate_id sandbox with | false -> Dream.empty `Not_Found | true -> - match%lwt exists sandbox with + match exists sandbox with | false -> Dream.empty `Not_Found | true -> - let%lwt example = + let example = match sandbox.[1] with | '-' -> - if%lwt Lwt_unix.file_exists (sandbox_root // sandbox // "keep") then - Lwt.return (Some sandbox) + if Lwt_eio.Promise.await_lwt @@ Lwt_unix.file_exists (sandbox_root // sandbox // "keep") then + Some sandbox else - Lwt.return_none - | _ -> Lwt.return_none - | exception _ -> Lwt.return_none + None + | _ | exception _ -> None in Dream.html (Client.html example) in - Dream.run ~interface:"0.0.0.0" ~port:80 ~stop ~adjust_terminal:false + Eio_main.run (fun env -> Dream.run env ~interface:"0.0.0.0" ~port:80 ~adjust_terminal:false @@ Dream.logger @@ Dream.router [ diff --git a/src/dream.mli b/src/dream.mli index e86c2f08..dcfacb8f 100644 --- a/src/dream.mli +++ b/src/dream.mli @@ -891,7 +891,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 @@ -917,7 +917,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 another message when the promise resolves. @@ -933,7 +933,7 @@ val send : [~end_of_message] is ignored for now, as the WebSocket library underlying Dream does not support sending message fragments yet. *) -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]. *) @@ -941,7 +941,7 @@ val receive_fragment : websocket -> (string * text_or_binary * end_of_message) option promise (** 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}. *) @@ -1758,7 +1758,7 @@ https://aantron.github.io/dream/#val-add_flash_message 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 +val graphql : (request -> 'a) -> 'a Graphql_lwt.Schema.schema -> handler (** [Dream.graphql make_context schema] serves the GraphQL [schema]. {[ diff --git a/src/graphql/graphql.ml b/src/graphql/graphql.ml index 6a994ae8..6c6df9ba 100644 --- a/src/graphql/graphql.ml +++ b/src/graphql/graphql.ml @@ -48,11 +48,11 @@ let run_query make_context schema request json = and variables = json |> Y.member "variables" |> Option.some in match query with - | None -> Lwt.return (Error (make_error "No query")) + | None -> Error (make_error "No query") | Some query -> match Graphql_parser.parse query with - | Error message -> Lwt.return (Error (make_error message)) + | Error message -> Error (make_error message) | Ok query -> (* TODO Consider being more strict here, allowing only `Assoc and `Null. *) @@ -66,9 +66,9 @@ let run_query make_context schema request json = None in - let%lwt context = make_context request in + let context = make_context request in - Graphql_lwt.Schema.execute + Lwt_eio.Promise.await_lwt @@ Graphql_lwt.Schema.execute ?variables ?operation_name schema context query @@ -79,9 +79,8 @@ let operation_id json = Yojson.Basic.Util.(json |> member "id" |> to_string_option) let close_and_clean ?code subscriptions websocket = - let%lwt () = Message.close_websocket ?code websocket in - Hashtbl.iter (fun _ close -> close ()) subscriptions; - Lwt.return_unit + Message.close_websocket ?code websocket; + Hashtbl.iter (fun _ close -> close ()) subscriptions let ack_message = `Assoc [ @@ -115,9 +114,8 @@ let complete_message id = (* TODO Take care to pass around the request Lwt.key in async, etc. *) (* TODO Test client complete racing against a stream. *) let handle_over_websocket make_context schema subscriptions request websocket = - Lwt_eio.Promise.await_lwt @@ let rec loop inited = - match%lwt Helpers.receive websocket with + match Helpers.receive websocket with | None -> log.info (fun log -> log ~request "GraphQL WebSocket closed by client"); close_and_clean subscriptions websocket @@ -146,7 +144,7 @@ let handle_over_websocket make_context schema subscriptions request websocket = close_and_clean subscriptions websocket ~code:4429 end else begin - let%lwt () = Helpers.send websocket ack_message in + Helpers.send websocket ack_message; loop true end @@ -185,11 +183,11 @@ let handle_over_websocket make_context schema subscriptions request websocket = let payload = json |> Yojson.Basic.Util.member "payload" in - Lwt.async begin fun () -> + begin let subscribed = ref false in - try%lwt - match%lwt run_query make_context schema request payload with + try + match run_query make_context schema request payload with | Error json -> log.warning (fun log -> log ~request @@ -199,9 +197,8 @@ let handle_over_websocket make_context schema subscriptions request websocket = (* It's not clear that this case ever occurs, because graphql-ws is only used for subscriptions, at the protocol level. *) | Ok (`Response json) -> - let%lwt () = Helpers.send websocket (data_message id json) in - let%lwt () = Helpers.send websocket (complete_message id) in - Lwt.return_unit + Helpers.send websocket (data_message id json); + Helpers.send websocket (complete_message id) | Ok (`Stream (stream, close)) -> match Hashtbl.mem subscriptions id with @@ -214,20 +211,17 @@ let handle_over_websocket make_context schema subscriptions request websocket = Hashtbl.replace subscriptions id close; subscribed := true; - let%lwt () = - stream |> Lwt_stream.iter_s (function + Lwt_eio.Promise.await_lwt (stream |> Lwt_stream.iter (function | Ok json -> Helpers.send websocket (data_message id json) | Error json -> log.warning (fun log -> - log ~request - "Subscription: error %s" (Yojson.Basic.to_string json)); - Helpers.send websocket (error_message id json)) - in + log ~request + "Subscription: error %s" (Yojson.Basic.to_string json)); + Helpers.send websocket (error_message id json))); - let%lwt () = Helpers.send websocket (complete_message id) in - Hashtbl.remove subscriptions id; - Lwt.return_unit + Helpers.send websocket (complete_message id); + Hashtbl.remove subscriptions id with exn -> let backtrace = Printexc.get_backtrace () in @@ -239,18 +233,14 @@ let handle_over_websocket make_context schema subscriptions request websocket = |> Log.iter_backtrace (fun line -> log.error (fun log -> log ~request "%s" line)); - try%lwt - let%lwt () = - Helpers.send - websocket - (error_message id (make_error "Internal Server Error")) - in + try + Helpers.send + websocket + (error_message id (make_error "Internal Server Error")); if !subscribed then Helpers.send websocket (complete_message id) - else - Lwt.return_unit with _ -> - Lwt.return_unit + () end; loop inited @@ -280,7 +270,6 @@ let graphql make_context schema = fun request -> | Some "websocket", Some "graphql-transport-ws" -> Helpers.websocket ~headers:["Sec-WebSocket-Protocol", "graphql-transport-ws"] - request (handle_over_websocket make_context schema (Hashtbl.create 16) request) | _ -> log.warning (fun log -> log ~request "Upgrade: websocket header missing"); @@ -295,7 +284,7 @@ let graphql make_context schema = fun request -> (* TODO This almost certainly raises exceptions... *) let json = Yojson.Basic.from_string body in - begin match%lwt run_query make_context schema request json with + begin match run_query make_context schema request json with | Error json -> Yojson.Basic.to_string json |> Helpers.json diff --git a/src/http/http.ml b/src/http/http.ml index 301315a4..f2f2afa1 100644 --- a/src/http/http.ml +++ b/src/http/http.ml @@ -313,25 +313,24 @@ let no_tls = { } let openssl = { - create_handler = fun ~certificate_file:_ -> failwith "https://github.com/savonet/ocaml-ssl/issues/76" -(* create_handler = begin fun ~certificate_file ~key_file ~handler - ~error_handler -> + ~error_handler + ~sw -> let httpaf_handler = Httpaf_lwt_unix.Server.SSL.create_connection_handler ?config:None ~request_handler:(wrap_handler ~sw true error_handler handler) - ~error_handler:(Error_handler.httpaf ~sw error_handler) + ~error_handler:(Error_handler.httpaf error_handler) in let h2_handler = H2_lwt_unix.Server.SSL.create_connection_handler ?config:None - ~request_handler:(wrap_handler_h2 true error_handler handler) - ~error_handler:(Error_handler.h2 ~sw error_handler) + ~request_handler:(wrap_handler_h2 ~sw true error_handler handler) + ~error_handler:(Error_handler.h2 error_handler) in let perform_tls_handshake = @@ -458,7 +457,7 @@ let serve_with_details let httpaf_connection_handler ~sw flow client_address = let client_address = to_unix_addr client_address in try - let fd = Eio_unix.FD.take flow |> Option.get in + let fd = Eio_unix.FD.take_opt flow |> Option.get in let socket = Lwt_unix.of_unix_file_descr fd in Lwt_eio.Promise.await_lwt @@ httpaf_connection_handler ~sw client_address socket @@ -486,7 +485,7 @@ let serve_with_details ~backlog:(Lwt_unix.somaxconn () [@ocaml.warning "-3"]) in while true do - Eio.Net.accept_sub ~sw socket httpaf_connection_handler + Eio.Net.accept_fork ~sw socket (httpaf_connection_handler ~sw) ~on_error:(fun ex -> !Lwt.async_exception_hook ex) done diff --git a/src/mirage/error_handler.ml b/src/mirage/error_handler.ml index 958a01a8..a60fe0a5 100644 --- a/src/mirage/error_handler.ml +++ b/src/mirage/error_handler.ml @@ -141,7 +141,7 @@ let select_log = function 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 @@ -161,8 +161,8 @@ let select_log = function (* 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) + let response = template error debug_dump response in + Some response let default_response = function | `Server -> @@ -171,13 +171,13 @@ let select_log = function Message.response ~status:`Bad_Request Stream.empty Stream.null let default_template _error _debug_dump response = - Lwt.return response + response let default = customize default_template 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 -> @@ -188,7 +188,6 @@ let double_faults f default = log.error (fun log -> log "%s" line)); default () - end let httpaf user's_error_handler = fun client_address ?request:_ error start_response -> let condition, severity, caused_by = match error with @@ -216,33 +215,26 @@ let httpaf user's_error_handler = fun client_address ?request:_ error start_resp will_send_response = true; } in - Lwt.async begin fun () -> - double_faults begin fun () -> - let%lwt response = user's_error_handler error in - let response = match response with - | Some response -> response - | None -> default_response caused_by in - let headers = Httpaf.Headers.of_list (Message.all_headers response) in - let body = start_response headers in - Adapt.forward_body response body; - Lwt.return_unit - end - Lwt.return - end + double_faults begin fun () -> + let response = user's_error_handler error in + let response = match response with + | Some response -> response + | None -> default_response caused_by in + let headers = Httpaf.Headers.of_list (Message.all_headers response) in + let body = start_response headers in + Adapt.forward_body response body + end (fun () -> ()) let respond_with_option f = double_faults (fun () -> - f () - |> Lwt.map (function - | Some response -> response - | None -> - Message.response - ~status:`Internal_Server_Error Stream.empty Stream.null)) + match f () with + | Some response -> response + | None -> + Message.response + ~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) let app user's_error_handler = fun error -> respond_with_option (fun () -> user's_error_handler error) diff --git a/src/mirage/mirage.ml b/src/mirage/mirage.ml index 6f5f5a09..12ecbc86 100644 --- a/src/mirage/mirage.ml +++ b/src/mirage/mirage.ml @@ -64,7 +64,7 @@ let wrap_handler_httpaf _user's_error_handler user's_dream_handler = Lwt.async begin fun () -> Lwt.catch begin fun () -> (* Do the big call. *) - let%lwt response = user's_dream_handler request in + let response = user's_dream_handler request in (* Extract the Dream response's headers. *) @@ -503,16 +503,14 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Time : Mirage_time.S) (Stack : Tcpip 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 + let response = loader local_root path request in if not (Message.has_header response "Content-Type") then begin match Message.status response with | `OK @@ -524,7 +522,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Time : Mirage_time.S) (Stack : Tcpip | _ -> () end; - Lwt.return response + response end diff --git a/src/mirage/mirage.mli b/src/mirage/mirage.mli index 177860ed..9a7e2473 100644 --- a/src/mirage/mirage.mli +++ b/src/mirage/mirage.mli @@ -3,7 +3,7 @@ type server type 'a message type request = client message type response = server message -type handler = request -> response Lwt.t +type handler = request -> response type middleware = handler -> handler module Make @@ -28,7 +28,7 @@ module Make (** 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]} \[{{:http://dream.as/1-hello} playground}\] shows the simplest @@ -420,7 +420,7 @@ module Make ?code:int -> ?headers:(string * string) list -> string -> - response promise + response (** Same as {!Dream.val-response}, but the new {!type-response} is wrapped in a {!type-promise}. *) @@ -429,7 +429,7 @@ module Make ?code:int -> ?headers:(string * string) list -> string -> - response promise + response (** Same as {!Dream.respond}, but adds [Content-Type: text/html; charset=utf-8]. See {!Dream.text_html}. @@ -444,7 +444,7 @@ module Make ?code:int -> ?headers:(string * string) list -> string -> - response promise + response (** Same as {!Dream.respond}, but adds [Content-Type: application/json]. See {!Dream.application_json}. *) @@ -454,7 +454,7 @@ module Make ?headers:(string * string) list -> request -> string -> - response promise + 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 @@ -466,7 +466,7 @@ module Make 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. *) type websocket @@ -477,8 +477,8 @@ module Make 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 @@ -510,7 +510,7 @@ module Make ?end_of_message:[< end_of_message] -> websocket -> string -> - unit promise + unit (** Sends a single WebSocket message. The WebSocket is ready another message when the promise resolves. @@ -526,7 +526,7 @@ module Make [~end_of_message] is ignored for now, as the WebSocket library underlying Dream does not support sending message fragments yet. *) - 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]. *) @@ -768,8 +768,8 @@ module Make ?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} @@ -1473,14 +1473,14 @@ module Make val session : string -> request -> string option (** Value from the request's session. *) - val put_session : string -> string -> request -> unit promise + val put_session : string -> string -> request -> 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. *) val all_session_values : 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. *) @@ -1766,7 +1766,7 @@ module Make [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}. @@ -1782,7 +1782,7 @@ module Make (* 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]} \[{{:http://dream.as/9-error} playground}\]. @@ -1823,7 +1823,7 @@ module Make If the template itself raises an exception or rejects, an empty [500 Internal Server Error] will be sent in contexts that require a response. *) - 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 diff --git a/src/server/content_length.ml b/src/server/content_length.ml deleted file mode 100644 index 81568c65..00000000 --- a/src/server/content_length.ml +++ /dev/null @@ -1,24 +0,0 @@ -(* This file is part of Dream, released under the MIT license. See LICENSE.md - for details, or visit https://github.com/aantron/dream. - - Copyright 2021 Anton Bachin *) - - - -module Message = Dream_pure.Message - - - -(* TODO Also mind Connection: close. *) -(* TODO Test in integration with HTTP/2. *) -(* TODO This could be renamed transfer_encoding at this point. *) -(* Add a Content-Length header to HTTP 1.x responses that have a fixed body but - don't yet have the header. *) -let content_length next_handler request = - if fst (Message.version request) <> 1 then - next_handler request - else - let (response : Message.response) = next_handler request in - if not (Message.has_header response "Transfer-Encoding") then - Message.add_header response "Transfer-Encoding" "chunked"; - response diff --git a/src/server/helpers.ml b/src/server/helpers.ml index 920be103..9140943a 100644 --- a/src/server/helpers.ml +++ b/src/server/helpers.ml @@ -72,7 +72,7 @@ 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 @@ -137,22 +137,6 @@ let is_websocket response = | Some true -> true | _ -> false -(* TODO Mark the request as a WebSocket request for HTTP. *) -let websocket ?headers request callback = - let sw = get_switch request in - let in_reader, in_writer = Stream.pipe () - and out_reader, out_writer = Stream.pipe () in - let client_stream = Stream.stream out_reader in_writer - and server_stream = Stream.stream in_reader out_writer in - let response = - Message.response - ~status:`Switching_Protocols ?headers client_stream server_stream in - Message.set_field response websocket_field true; - (* TODO Make sure the request id is propagated to the callback. *) - let wrapped_callback _ = Fiber.fork ~sw (fun () -> callback response) in - Stream.ready server_stream ~close:wrapped_callback wrapped_callback; - response - let empty ?headers status = respond ?headers ~status "" @@ -168,18 +152,19 @@ let websocket ?headers ?(close = true) callback = let websocket = Message.create_websocket response in (* TODO Make sure the request id is propagated to the callback. *) - Lwt.async (fun () -> + begin if close then - match%lwt callback websocket with + match callback websocket with | () -> Message.close_websocket websocket | exception exn -> - let%lwt () = Message.close_websocket websocket ~code:1005 in + Message.close_websocket websocket ~code:1005; raise exn else - callback websocket); + callback websocket + end; - Lwt.return response + response let receive (_, server_stream) = Message.receive server_stream diff --git a/src/server/lowercase_headers.ml b/src/server/lowercase_headers.ml deleted file mode 100644 index fec6dced..00000000 --- a/src/server/lowercase_headers.ml +++ /dev/null @@ -1,23 +0,0 @@ -(* This file is part of Dream, released under the MIT license. See LICENSE.md - for details, or visit https://github.com/aantron/dream. - - Copyright 2021 Anton Bachin *) - - - -module Message = Dream_pure.Message - - - -(* TODO This middleware might need to be applied right in the h2 adapter, - because error handlers might generate headers that cannot be rewritten - inside the normal stack. *) -(* TODO This can be optimized not to convert a header if it is already - lowercase. Another option is to use memoization to reduce GC pressure. *) -let lowercase_headers inner_handler request = - let response = inner_handler request in - if fst (Message.version request) <> 1 then - Message.all_headers response - |> List.map (fun (name, value) -> String.lowercase_ascii name, value) - |> Message.set_all_headers response; - response diff --git a/test/expect/pure/message/message.ml b/test/expect/pure/message/message.ml index bbeae946..7d84a465 100644 --- a/test/expect/pure/message/message.ml +++ b/test/expect/pure/message/message.ml @@ -12,15 +12,15 @@ let%expect_test _ = in let inner_middleware handler request = print_endline "inner middleware: request"; - let%lwt response = handler request in + let response = handler request in print_endline "inner middleware: response"; - Lwt.return response + response in let outer_middleware handler request = print_endline "outer middleware: request"; - let%lwt response = handler request in + let response = handler request in print_endline "outer middleware: response"; - Lwt.return response + response in let server = Dream.pipeline [ @@ -29,7 +29,7 @@ let%expect_test _ = ] @@ handler in - ignore (Lwt_main.run (server (Dream.request ""))); + ignore (server (Dream.request "")); [%expect {| outer middleware: request inner middleware: request From 72896f8743ce35f3ab4a9bb33495acdda45a0049 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Sun, 2 Apr 2023 21:53:31 +0200 Subject: [PATCH 10/42] Remove lwt from pure --- src/pure/dune | 2 -- src/pure/message.ml | 80 ++++++++++++++++++++------------------------ src/pure/message.mli | 19 +++++------ src/pure/stream.ml | 21 +++++------- src/pure/stream.mli | 6 ++-- 5 files changed, 56 insertions(+), 72 deletions(-) diff --git a/src/pure/dune b/src/pure/dune index ef00d0e2..c29cd827 100644 --- a/src/pure/dune +++ b/src/pure/dune @@ -5,10 +5,8 @@ base64 bigstringaf hmap - lwt eio uri ptime ) - (preprocess (pps lwt_ppx)) (instrumentation (backend bisect_ppx))) diff --git a/src/pure/message.ml b/src/pure/message.ml index a8f4d140..963d6304 100644 --- a/src/pure/message.ml +++ b/src/pure/message.ml @@ -6,8 +6,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; @@ -38,7 +36,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 option; mutable fields : Fields.t; } @@ -200,7 +198,7 @@ let body message = body_promise let set_body message body = - message.body <- Some (Lwt.return body); + message.body <- Some body; match message.kind with | Request -> message.server_stream <- Stream.string body | Response -> message.client_stream <- Stream.string body @@ -215,13 +213,9 @@ let set_content_length_headers message = match message.body with | None -> add_header message "Transfer-Encoding" "chunked" - | Some body_promise -> - match Lwt.poll body_promise with - | None -> - add_header message "Transfer-Encoding" "chunked" - | Some body -> - let length = string_of_int (String.length body) in - add_header message "Content-Length" length + | Some body -> + let length = string_of_int (String.length body) in + add_header message "Content-Length" length let drop_content_length_headers message = drop_header message "Content-Length"; @@ -235,29 +229,28 @@ let read stream = Stream.read_convenience stream let write stream chunk = - let promise, resolver = Lwt.wait () in + let promise, resolver = Eio.Promise.create () in let length = String.length chunk in let buffer = Bigstringaf.of_string ~off:0 ~len:length chunk in Stream.write stream buffer 0 length false true - ~close:(fun _code -> Lwt.wakeup_later_exn resolver End_of_file) - ~exn:(fun exn -> Lwt.wakeup_later_exn resolver exn) - (fun () -> Lwt.wakeup_later resolver ()); - promise + ~close:(fun _code -> Eio.Promise.resolve_error resolver End_of_file) + ~exn:(fun exn -> Eio.Promise.resolve_error resolver exn) + (fun () -> Eio.Promise.resolve_ok resolver ()); + Eio.Promise.await_exn promise let flush stream = - let promise, resolver = Lwt.wait () in + let promise, resolver = Eio.Promise.create () in Stream.flush stream - ~close:(fun _code -> Lwt.wakeup_later_exn resolver End_of_file) - ~exn:(fun exn -> Lwt.wakeup_later_exn resolver exn) - (Lwt.wakeup_later resolver); - promise + ~close:(fun _code -> Eio.Promise.resolve_error resolver End_of_file) + ~exn:(fun exn -> Eio.Promise.resolve_error resolver exn) + (Eio.Promise.resolve_ok resolver); + Eio.Promise.await_exn promise let close stream = - Stream.close stream 1000; - Lwt.return_unit + Stream.close stream 1000 let client_stream message = message.client_stream @@ -287,8 +280,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 @@ -301,9 +293,9 @@ type end_of_message = [ ] let receive_fragment stream = - 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 + let promise, resolver = Eio.Promise.create () in + let close _code = Eio.Promise.resolve_ok resolver None in + let abort exn = Eio.Promise.resolve_error resolver exn in let rec loop () = Stream.read stream @@ -314,7 +306,7 @@ let receive_fragment stream = in let text_or_binary = if binary then `Binary else `Text in let end_of_message = if fin then `End_of_message else `Continues in - Lwt.wakeup_later + Eio.Promise.resolve_ok resolver (Some (string, text_or_binary, end_of_message))) ~flush:loop @@ -331,7 +323,7 @@ let receive_fragment stream = in loop (); - promise + Eio.Promise.await_exn promise (* 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. *) @@ -339,29 +331,29 @@ let receive_fragment stream = still gracefully return None. *) let receive_full stream = let rec receive_continuations text_or_binary acc = - match%lwt receive_fragment stream with + match receive_fragment stream with | None -> - Lwt.return (Some (acc, text_or_binary)) + Some (acc, text_or_binary) | Some (fragment, _, `End_of_message) -> - Lwt.return (Some (acc ^ fragment, text_or_binary)) + Some (acc ^ fragment, text_or_binary) | Some (fragment, _, `Continues) -> receive_continuations text_or_binary (acc ^ fragment) in - match%lwt receive_fragment stream with + match receive_fragment stream with | None -> - Lwt.return_none + None | Some (fragment, text_or_binary, `End_of_message) -> - Lwt.return (Some (fragment, text_or_binary)) + Some (fragment, text_or_binary) | Some (fragment, text_or_binary, `Continues) -> receive_continuations text_or_binary fragment let receive stream = - match%lwt receive_full stream with - | None -> Lwt.return_none - | Some (message, _) -> Lwt.return (Some message) + match receive_full stream with + | None -> None + | Some (message, _) -> Some message let send ?text_or_binary ?end_of_message stream data = - let promise, resolver = Lwt.wait () in + let promise, resolver = Eio.Promise.create () in let binary = match text_or_binary with | Some `Binary -> true @@ -378,10 +370,10 @@ let send ?text_or_binary ?end_of_message stream data = let buffer = Bigstringaf.of_string ~off:0 ~len:length data in Stream.write stream buffer 0 length binary fin - ~close:(fun _code -> Lwt.wakeup_later_exn resolver End_of_file) - ~exn:(fun exn -> Lwt.wakeup_later_exn resolver exn) - (fun () -> Lwt.wakeup_later resolver ()); - promise + ~close:(fun _code -> Eio.Promise.resolve_error resolver End_of_file) + ~exn:(fun exn -> Eio.Promise.resolve_error resolver exn) + (fun () -> Eio.Promise.resolve_ok resolver ()); + Eio.Promise.await_exn promise diff --git a/src/pure/message.mli b/src/pure/message.mli index e8fbe854..18db684d 100644 --- a/src/pure/message.mli +++ b/src/pure/message.mli @@ -15,7 +15,6 @@ type 'a message type request = client message type response = server message -type 'a promise = 'a Lwt.t 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 @@ -96,15 +95,15 @@ type end_of_message = [ (* TODO This also needs message length limits. *) val receive : - Stream.stream -> string option promise + 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..abe93617 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,9 +393,9 @@ let forward (reader : reader) stream = loop () let read_convenience stream = - 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 + let promise, resolver = Eio.Promise.create () in + let close _code = Eio.Promise.resolve_ok resolver None in + let abort exn = Eio.Promise.resolve_error resolver exn in let rec loop () = stream.reader.read @@ -406,7 +403,7 @@ let read_convenience stream = Bigstringaf.sub buffer ~off:offset ~len:length |> Bigstringaf.to_string |> Option.some - |> Lwt.wakeup_later resolver) + |> Eio.Promise.resolve_ok resolver) ~flush:loop @@ -422,20 +419,20 @@ let read_convenience stream = in loop (); - promise + Eio.Promise.await_exn promise (* 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 @@ -469,4 +466,4 @@ let read_until_close stream = in loop (); - promise + Eio.Promise.await_exn promise diff --git a/src/pure/stream.mli b/src/pure/stream.mli index fa4814ef..a0571af1 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,12 @@ 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.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 +val read_until_close : stream -> string (** Reads a stream completely until [~close], and accumulates the data into a string. *) From 9a1cada94d1f4fd7952658bed45e58405ec76f81 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Sun, 2 Apr 2023 22:12:03 +0200 Subject: [PATCH 11/42] Remove Lwt from server/ as far as possible upload.ml uses Lwt_streams, we convert them directly with lwt_eio --- src/server/csrf.ml | 2 +- src/server/dune | 2 -- src/server/form.ml | 20 ++++++++++---------- src/server/helpers.ml | 29 +++++++++++++---------------- src/server/session.ml | 16 ++++++++-------- src/server/upload.ml | 36 +++++++++++++++++++----------------- 6 files changed, 51 insertions(+), 54 deletions(-) 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 113bb915..1e1afc1e 100644 --- a/src/server/dune +++ b/src/server/dune @@ -7,7 +7,6 @@ dream-pure fmt logs - lwt magic-mime mirage-clock multipart_form @@ -18,7 +17,6 @@ yojson lwt_eio ) - (preprocess (pps lwt_ppx)) (instrumentation (backend bisect_ppx))) (rule 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 9140943a..6cccc6ad 100644 --- a/src/server/helpers.ml +++ b/src/server/helpers.ml @@ -102,29 +102,26 @@ let get_switch request = | None -> failwith "Missing switch field on request!" let stream ?status ?code ?headers ?(close = true) callback = - let sw = get_switch request in let reader, writer = Stream.pipe () in let client_stream = Stream.stream reader Stream.no_writer and server_stream = Stream.stream Stream.no_reader writer in let response = Message.response ?status ?code ?headers client_stream server_stream in + (* FIXME untested *) + let sw = get_switch response in + let callback stream = Fiber.fork ~sw (fun () -> callback stream) in (* TODO Make sure the request id is propagated to the callback. *) - Lwt.async (fun () -> - if close then - match%lwt callback server_stream with - | () -> - Message.close server_stream - | exception exn -> - let%lwt () = Message.close server_stream in - raise exn - else - callback server_stream); - - Lwt.return response - (* let wrapped_callback _ = Fiber.fork ~sw (fun () -> callback response) in *) - (* Stream.ready server_stream ~close:wrapped_callback wrapped_callback; *) - (* response *) + (if close then + match callback server_stream with + | () -> + Message.close server_stream + | exception exn -> + Message.close server_stream; + raise exn + else + callback server_stream); + response let websocket_field = Message.new_field diff --git a/src/server/session.ml b/src/server/session.ml index 8b1cf9bf..6d79424c 100644 --- a/src/server/session.ml +++ b/src/server/session.ml @@ -15,15 +15,15 @@ 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 session = Lwt_eio.Promise.await_lwt (back_end.load request) in + let session = back_end.load request in Message.set_field request field session; let response = inner_handler request in - Lwt_eio.Promise.await_lwt (back_end.send session request response) + back_end.send session request response let getter field request = match Message.field request field with @@ -171,7 +171,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 @@ -180,7 +180,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 @@ -280,7 +280,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 @@ -298,7 +298,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/upload.ml b/src/server/upload.ml index e296c8ee..48ad3332 100644 --- a/src/server/upload.ml +++ b/src/server/upload.ml @@ -62,16 +62,16 @@ let log = Log.sub_log "dream.upload" let upload_part (request : Message.request) = let state = multipart_state request in - match%lwt Lwt_stream.peek state.stream with - | None -> Lwt.return_none + match Lwt_eio.Promise.await_lwt @@ Lwt_stream.peek state.stream with + | None -> None | Some (_uid, _header, stream) -> - match%lwt Lwt_stream.get stream with - | Some _ as v -> Lwt.return v + match Lwt_eio.Promise.await_lwt @@ Lwt_stream.get stream with + | Some _ as v -> v | None -> log.debug (fun m -> m "End of the part.") ; - let%lwt () = Lwt_stream.junk state.stream in + Lwt_eio.Promise.await_lwt @@ Lwt_stream.junk state.stream; + None (* XXX(dinosaure): delete the current part from the [stream]. *) - Lwt.return_none let identify _ = object end @@ -80,8 +80,10 @@ type part = string option * string option * ((string * string) list) let rec state (request : Message.request) = let state' = multipart_state request in let stream = state'.stream in - match%lwt Lwt_stream.peek stream with - | None -> let%lwt () = Lwt_stream.junk stream in Lwt.return_none + match Lwt_eio.Promise.await_lwt @@ Lwt_stream.peek stream with + | None -> + Lwt_eio.Promise.await_lwt @@ Lwt_stream.junk stream; + None | Some (_, headers, _stream) -> let headers = headers @@ -90,7 +92,7 @@ let rec state (request : Message.request) = in let part = state'.name, state'.filename, headers in - Lwt.return (Some part) + Some part and upload (request : Message.request) = let state' = multipart_state request in @@ -116,11 +118,11 @@ and upload (request : Message.request) = | Some content_type -> let body = - Lwt_stream.from (fun () -> - Message.read (Message.server_stream request)) in + Lwt_stream.from_direct (fun () -> + Message.read (Message.server_stream request)) in let `Parse th, stream = Multipart_form_lwt.stream ~identify body content_type in - Lwt.async (fun () -> let%lwt _ = th in Lwt.return_unit); + let _ = Lwt_eio.Promise.await_lwt th in state'.stream <- stream; state'.state_init <- false; state request @@ -135,14 +137,14 @@ let multipart ?(csrf=true) ~now request = Result.to_option (Multipart_form.Content_type.of_string (content_type ^ "\r\n")) | None -> None in match content_type with - | None -> Lwt.return `Wrong_content_type + | None -> `Wrong_content_type | Some content_type -> let body = - Lwt_stream.from (fun () -> + Lwt_stream.from_direct (fun () -> Message.read (Message.server_stream request)) in - match%lwt Multipart_form_lwt.of_stream_to_list body content_type with + match Lwt_eio.Promise.await_lwt @@ Multipart_form_lwt.of_stream_to_list body content_type with | Error (`Msg _err) -> - Lwt.return `Wrong_content_type (* XXX(dinosaure): better error? *) + `Wrong_content_type (* XXX(dinosaure): better error? *) | Ok (tree, assoc) -> let open Multipart_form in let tree = flatten tree in @@ -176,4 +178,4 @@ let multipart ?(csrf=true) ~now request = parts request else let form = Form.sort parts in - Lwt.return (`Ok form) + `Ok form From c1021d6829d5167552f59024ea1e0a1498d07054 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Sun, 2 Apr 2023 22:14:53 +0200 Subject: [PATCH 12/42] Remove lwt from graphql/ --- src/graphql/dune | 2 -- src/graphql/graphql.ml | 7 +------ 2 files changed, 1 insertion(+), 8 deletions(-) diff --git a/src/graphql/dune b/src/graphql/dune index 7397ce17..f21f3cff 100644 --- a/src/graphql/dune +++ b/src/graphql/dune @@ -7,9 +7,7 @@ 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 6c6df9ba..0d86383c 100644 --- a/src/graphql/graphql.ml +++ b/src/graphql/graphql.ml @@ -279,8 +279,7 @@ let graphql make_context schema = fun request -> | `POST -> begin match Message.header request "Content-Type" with | Some "application/json" -> - Lwt_eio.Promise.await_lwt ( - let%lwt body = Message.body request in + let body = Message.body request in (* TODO This almost certainly raises exceptions... *) let json = Yojson.Basic.from_string body in @@ -288,20 +287,16 @@ let graphql make_context schema = fun request -> | Error json -> Yojson.Basic.to_string json |> Helpers.json - |> Lwt.return | Ok (`Response json) -> Yojson.Basic.to_string json |> Helpers.json - |> Lwt.return | Ok (`Stream _) -> make_error "Subscriptions and streaming should use WebSocket transport" |> Yojson.Basic.to_string |> Helpers.json - |> Lwt.return end - ) | _ -> log.warning (fun log -> log ~request From 59af592cfafed889115c9ccc3d41df25827a91e5 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Sun, 2 Apr 2023 22:20:46 +0200 Subject: [PATCH 13/42] Remove Lwt from mirage/ --- src/mirage/dune | 2 -- src/mirage/mirage.ml | 1 - src/mirage/mirage.mli | 25 ++++++++++++------------- 3 files changed, 12 insertions(+), 16 deletions(-) diff --git a/src/mirage/dune b/src/mirage/dune index 4cc14e8f..14a75c11 100644 --- a/src/mirage/dune +++ b/src/mirage/dune @@ -10,11 +10,9 @@ dream.certificate dream-pure dream-httpaf.dream-h2 - lwt tcpip dream-mirage.dream-paf dream-mirage.dream-paf.alpn dream-mirage.dream-paf.mirage ) - (preprocess (pps lwt_ppx)) (instrumentation (backend bisect_ppx))) diff --git a/src/mirage/mirage.ml b/src/mirage/mirage.ml index 12ecbc86..1eaa876a 100644 --- a/src/mirage/mirage.ml +++ b/src/mirage/mirage.ml @@ -202,7 +202,6 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Time : Mirage_time.S) (Stack : Tcpip type 'a message = 'a Message.message type client = Message.client type server = Message.server - type 'a promise = 'a Message.promise (* Requests *) diff --git a/src/mirage/mirage.mli b/src/mirage/mirage.mli index 9a7e2473..771dd258 100644 --- a/src/mirage/mirage.mli +++ b/src/mirage/mirage.mli @@ -128,7 +128,6 @@ module Make (* 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} @@ -531,10 +530,10 @@ module Make 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}. *) @@ -728,7 +727,7 @@ module Make (** {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]}. *) @@ -784,22 +783,22 @@ module Make [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. *) - 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. *) val client_stream : 'a message -> stream @@ -951,7 +950,7 @@ module Make 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.form_tag} in a template to transparently generate forms that will pass these checks. See {!section-templates} and example @@ -1041,7 +1040,7 @@ module Make 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 [
] tag and CSRF token can be generated in a template with @@ -1074,7 +1073,7 @@ module Make 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 @@ -1093,7 +1092,7 @@ module Make [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} @@ -1133,7 +1132,7 @@ module Make 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. *) val csrf_tag : request -> string From a46bb20f14fe6a3b51f48662e37c9fa080ca3ee1 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Sun, 2 Apr 2023 22:25:42 +0200 Subject: [PATCH 14/42] Remove lwt from sql/ as far as possible --- src/sql/dune | 1 - src/sql/session.ml | 78 ++++++++++++++++++++++------------------------ src/sql/sql.ml | 7 +++-- 3 files changed, 41 insertions(+), 45 deletions(-) diff --git a/src/sql/dune b/src/sql/dune index e4244f42..faeaef3c 100644 --- a/src/sql/dune +++ b/src/sql/dune @@ -9,5 +9,4 @@ 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 a3a8d279..5562173e 100644 --- a/src/sql/session.ml +++ b/src/sql/session.ml @@ -35,9 +35,10 @@ let insert = fun (module Db : DB) (session : Session.session) -> let payload = serialize_payload session.payload in - let%lwt result = + let result = + Lwt_eio.Promise.await_lwt @@ Db.exec query (session.id, session.label, session.expires_at, payload) in - Caqti_lwt.or_fail result + Lwt_eio.Promise.await_lwt @@ Caqti_lwt.or_fail result let find_opt = let query = @@ -46,9 +47,9 @@ let find_opt = "SELECT label, expires_at, payload FROM dream_session WHERE id = $1" in fun (module Db : DB) id -> - let%lwt result = Db.find_opt query id in - match%lwt Caqti_lwt.or_fail result with - | None -> Lwt.return_none + let result = Lwt_eio.Promise.await_lwt @@ Db.find_opt query id in + match Lwt_eio.Promise.await_lwt @@ Caqti_lwt.or_fail result with + | None -> None | Some (label, expires_at, payload) -> (* TODO Mind exceptions! *) let payload = @@ -60,7 +61,7 @@ let find_opt = | _ -> failwith "Bad payload") | _ -> failwith "Bad payload" in - Lwt.return_some Session.{ + Some Session.{ id; label; expires_at; @@ -74,8 +75,8 @@ let refresh = "UPDATE dream_session SET expires_at = $1 WHERE id = $2" in fun (module Db : DB) (session : Session.session) -> - let%lwt result = Db.exec query (session.expires_at, session.id) in - Caqti_lwt.or_fail result + let result = Lwt_eio.Promise.await_lwt @@ Db.exec query (session.expires_at, session.id) in + Lwt_eio.Promise.await_lwt @@ Caqti_lwt.or_fail result let update = let query = @@ -85,8 +86,8 @@ let update = fun (module Db : DB) (session : Session.session) -> let payload = serialize_payload session.payload in - let%lwt result = Db.exec query (payload, session.id) in - Caqti_lwt.or_fail result + let result = Lwt_eio.Promise.await_lwt @@ Db.exec query (payload, session.id) in + Lwt_eio.Promise.await_lwt @@ Caqti_lwt.or_fail result let remove = let query = @@ -94,8 +95,8 @@ let remove = (T.string ->. T.unit) "DELETE FROM dream_session WHERE id = $1" in fun (module Db : DB) id -> - let%lwt result = Db.exec query id in - Caqti_lwt.or_fail result + let result = Lwt_eio.Promise.await_lwt @@ Db.exec query id in + Lwt_eio.Promise.await_lwt @@ Caqti_lwt.or_fail result (* TODO Session sharing is greatly complicated by the backing store; is it ok to just work with snapshots? All kinds of race conditions may be possible, @@ -114,30 +115,25 @@ let rec create db expires_at attempt = } in (* Assume that any exception is a PRIMARY KEY collision (extremely unlikely) and try a couple more times. *) - match%lwt insert db session with + match insert db session with | exception Caqti_error.Exn _ when attempt <= 3 -> create db expires_at (attempt + 1) | () -> - Lwt.return session + session let put request (session : Session.session) name value = session.payload |> List.remove_assoc name |> fun dictionary -> (name, value)::dictionary |> fun dictionary -> session.payload <- dictionary; - Lwt_eio.Promise.await_lwt begin - Sql.sql request (fun db -> update db session) - end + Sql.sql request (fun db -> update db session) let invalidate request lifetime operations (session : Session.session ref) = - Lwt_eio.Promise.await_lwt begin - Sql.sql request begin fun db -> - let%lwt () = remove db !session.id in - let%lwt new_session = create db (Unix.gettimeofday () +. lifetime) 1 in - session := new_session; - operations.Session.dirty <- true; - Lwt.return_unit - end + Sql.sql request begin fun db -> + remove db !session.id; + let new_session = create db (Unix.gettimeofday () +. lifetime) 1 in + session := new_session; + operations.Session.dirty <- true end let operations request lifetime (session : Session.session ref) dirty = @@ -152,41 +148,41 @@ let load lifetime request = Sql.sql request begin fun db -> let now = Unix.gettimeofday () in - let%lwt valid_session = + let valid_session = match Cookie.cookie request ~decrypt:false Session.session_cookie with - | None -> Lwt.return_none + | None -> None | Some id -> match Session.read_session_id id with - | None -> Lwt.return_none + | None -> None | Some id -> - match%lwt find_opt db id with - | None -> Lwt.return_none + match find_opt db id with + | None -> None | Some session -> if session.expires_at > now then - Lwt.return (Some session) + Some session else begin - let%lwt () = remove db id in - Lwt.return_none + remove db id; + None end in - let%lwt dirty, session = + let dirty, session = match valid_session with | Some session -> if session.expires_at -. now > (lifetime /. 2.) then - Lwt.return (false, session) + false, session else begin session.expires_at <- now +. lifetime; - let%lwt () = refresh db session in - Lwt.return (true, session) + refresh db session; + true, session end | None -> - let%lwt session = create db (now +. lifetime) 1 in - Lwt.return (true, session) + let session = create db (now +. lifetime) 1 in + true, session in let session = ref session in - Lwt.return (operations request lifetime session dirty, session) + operations request lifetime session dirty, session end let send (operations, session) request response = @@ -201,7 +197,7 @@ let send (operations, session) request response = ~encrypt:false ~max_age end; - Lwt.return response + response let back_end lifetime = { Session.load = load lifetime; diff --git a/src/sql/sql.ml b/src/sql/sql.ml index a5f16c0d..4ed8115a 100644 --- a/src/sql/sql.ml +++ b/src/sql/sql.ml @@ -71,12 +71,13 @@ let sql request callback = log.error (fun log -> log ~request "%s" message); failwith message | Some pool -> - let%lwt result = + let result = pool |> Caqti_lwt.Pool.use (fun db -> (* The special exception handling is a workaround for https://github.com/paurkedal/ocaml-caqti/issues/68. *) - match%lwt callback db with + match callback db with | result -> Lwt.return (Ok result) | exception exn -> raise exn) + |> Lwt_eio.Promise.await_lwt in - Caqti_lwt.or_fail result + Lwt_eio.Promise.await_lwt @@ Caqti_lwt.or_fail result From c1e5e91f77ae34efec4d9197714afb9824d232bc Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Sun, 2 Apr 2023 22:56:20 +0200 Subject: [PATCH 15/42] Remove lwt from http/ as far as possible --- src/http/dune | 2 - src/http/error_handler.ml | 36 ++----- src/http/http.ml | 203 ++++++++++++++++++----------------- src/http/shared/dune | 2 +- src/http/shared/websocket.ml | 2 +- 5 files changed, 115 insertions(+), 130 deletions(-) diff --git a/src/http/dune b/src/http/dune index df64dc5b..4e2c2e99 100644 --- a/src/http/dune +++ b/src/http/dune @@ -14,14 +14,12 @@ dream-httpaf.dream-h2-lwt-unix dream-httpaf.dream-httpaf_ dream-httpaf.dream-httpaf_-lwt-unix - lwt lwt.unix lwt_ssl ssl dream-httpaf.dream-websocketaf lwt_eio eio_main - dream-httpaf.websocketaf ) (preprocess (pps lwt_ppx)) (instrumentation (backend bisect_ppx))) diff --git a/src/http/error_handler.ml b/src/http/error_handler.ml index 7e92b930..c61d8c9e 100644 --- a/src/http/error_handler.ml +++ b/src/http/error_handler.ml @@ -210,7 +210,7 @@ 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 +221,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, @@ -230,10 +229,8 @@ let double_faults f default = is a programming error, so it's probably fine to return a generic server error. *) let respond_with_option f = - Lwt_eio.Promise.await_lwt @@ double_faults (fun () -> - Lwt_eio.run_eio @@ fun () -> match f () with | Some response -> response | None -> @@ -241,7 +238,6 @@ let respond_with_option f = ~status:`Internal_Server_Error Stream.empty Stream.null) (fun () -> Message.response ~status:`Internal_Server_Error Stream.empty Stream.null - |> Lwt.return ) @@ -306,9 +302,8 @@ let httpaf will_send_response = true; } in - Lwt.async begin fun () -> double_faults begin fun () -> - let%lwt response = Lwt_eio.run_eio (fun () -> user's_error_handler error) in + let response = user's_error_handler error in let response = match response with @@ -319,12 +314,9 @@ let httpaf let headers = Httpaf.Headers.of_list (Message.all_headers response) in let body = start_response headers in - Adapt.forward_body response body; - - Lwt.return_unit + Adapt.forward_body response body end - Lwt.return - end + (fun () -> ()) @@ -364,9 +356,8 @@ let h2 will_send_response = true; } in - Lwt.async begin fun () -> double_faults begin fun () -> - let%lwt response = Lwt_eio.run_eio (fun () -> user's_error_handler error) in + let response = user's_error_handler error in let response = match response with @@ -377,12 +368,9 @@ let h2 let headers = H2.Headers.of_list (Message.all_headers response) in let body = start_response headers in - Adapt.forward_body_h2 response body; - - Lwt.return_unit + Adapt.forward_body_h2 response body end - Lwt.return - end + (fun () -> ()) @@ -405,10 +393,9 @@ let tls will_send_response = false; } in - Lwt.async (fun () -> double_faults - (fun () -> Lwt_eio.run_eio (fun () -> user's_error_handler error |> ignore)) - Lwt.return) + (fun () -> user's_error_handler error |> ignore) + (fun () -> ()) @@ -436,10 +423,9 @@ let websocket will_send_response = false; } in - Lwt.async (fun () -> double_faults - (fun () -> Lwt_eio.run_eio (fun () -> user's_error_handler error |> ignore)) - Lwt.return) + (fun () -> user's_error_handler error |> ignore) + (fun () -> ()) diff --git a/src/http/http.ml b/src/http/http.ml index f2f2afa1..6d0537c8 100644 --- a/src/http/http.ml +++ b/src/http/http.ml @@ -113,73 +113,67 @@ let wrap_handler ~sw customizable here. The handler itself is customizable (to catch all) exceptions, and the error callback that gets leaked exceptions is also customizable. *) - Lwt.async begin fun () -> - Lwt.catch begin fun () -> - (* Do the big call. *) - let%lwt response = Lwt_eio.run_eio (fun () -> user's_dream_handler request) in + try + (* Do the big call. *) + let response = user's_dream_handler request in - (* Extract the Dream response's headers. *) + (* Extract the Dream response's headers. *) - (* This is the default function that translates the Dream response to an + (* This is the default function that translates the Dream response to an http/af response and sends it. We pre-define the function, however, because it is called from two places: 1. Upon a normal response, the function is called unconditionally. 2. Upon failure to establish a WebSocket, the function is called to transmit the resulting error response. *) - let forward_response response = - Message.set_content_length_headers response; + let forward_response response = + Message.set_content_length_headers response; - let headers = - Httpaf.Headers.of_list (Message.all_headers response) in + let headers = + Httpaf.Headers.of_list (Message.all_headers response) in - let status = - to_httpaf_status (Message.status response) in + let status = + to_httpaf_status (Message.status response) in - let httpaf_response = - Httpaf.Response.create ~headers status in - let body = - Httpaf.Reqd.respond_with_streaming conn httpaf_response in + let httpaf_response = + Httpaf.Response.create ~headers status in + let body = + Httpaf.Reqd.respond_with_streaming conn httpaf_response in - Adapt.forward_body response body; + Adapt.forward_body response body + in - Lwt.return_unit + match Message.get_websocket response with + | None -> + forward_response response + | Some (client_stream, _server_stream) -> + let error_handler = + Error_handler.websocket user's_error_handler request response in + + let proceed () = + Websocketaf.Server_connection.create_websocket + ~error_handler + (Dream_httpaf.Websocket.websocket_handler client_stream) + |> Gluten.make (module Websocketaf.Server_connection) + |> upgrade in - match Message.get_websocket response with - | None -> - forward_response response - | Some (client_stream, _server_stream) -> - let error_handler = - Error_handler.websocket user's_error_handler request response in - - let proceed () = - Websocketaf.Server_connection.create_websocket - ~error_handler - (Dream_httpaf.Websocket.websocket_handler client_stream) - |> Gluten.make (module Websocketaf.Server_connection) - |> upgrade - in + let headers = + Httpaf.Headers.of_list (Message.all_headers response) in - let headers = - Httpaf.Headers.of_list (Message.all_headers response) in - - Websocketaf.Handshake.respond_with_upgrade ~headers ~sha1 conn proceed - |> function - | Ok () -> Lwt.return_unit - | Error error_string -> - let response = - Error_handler.websocket_handshake - user's_error_handler request response error_string - in - forward_response response - end - @@ fun exn -> - (* TODO There was something in the fork changelogs about not requiring + Websocketaf.Handshake.respond_with_upgrade ~headers ~sha1 conn proceed + |> function + | Ok () -> () + | Error error_string -> + let response = + Error_handler.websocket_handshake + user's_error_handler request response error_string + in + forward_response response + with exn -> + (* TODO There was something in the fork changelogs about not requiring report exn. Is it relevant to this? *) - Httpaf.Reqd.report_exn conn exn; - Lwt.return_unit - end + Httpaf.Reqd.report_exn conn exn in httpaf_request_handler @@ -236,46 +230,40 @@ let wrap_handler_h2 ~sw customizable here. The handler itself is customizable (to catch all) exceptions, and the error callback that gets leaked exceptions is also customizable. *) - Lwt.async begin fun () -> - Lwt.catch begin fun () -> - (* Do the big call. *) - let%lwt response = Lwt_eio.run_eio (fun () -> user's_dream_handler request) in - - (* Extract the Dream response's headers. *) - - let forward_response response = - Message.drop_content_length_headers response; - Message.lowercase_headers response; - let headers = - H2.Headers.of_list (Message.all_headers response) in - let status = - to_h2_status (Message.status response) in - let h2_response = - H2.Response.create ~headers status in - let body = - H2.Reqd.respond_with_streaming conn h2_response in - - Adapt.forward_body_h2 response body; - - Lwt.return_unit - in + try + (* Do the big call. *) + let response = user's_dream_handler request in + + (* Extract the Dream response's headers. *) + + let forward_response response = + Message.drop_content_length_headers response; + Message.lowercase_headers response; + let headers = + H2.Headers.of_list (Message.all_headers response) in + let status = + to_h2_status (Message.status response) in + let h2_response = + H2.Response.create ~headers status in + let body = + H2.Reqd.respond_with_streaming conn h2_response in + + Adapt.forward_body_h2 response body + in - match Message.get_websocket response with - | None -> - forward_response response - | Some _ -> + match Message.get_websocket response with + | None -> + forward_response response + | Some _ -> (* TODO DOC H2 appears not to support WebSocket upgrade at present. RFC 8441. *) (* TODO DOC Do we need a CONNECT method? Do users need to be informed of this? *) - Lwt.return_unit - end - @@ fun exn -> - (* TODO LATER There was something in the fork changelogs about not + () + with exn -> + (* TODO LATER There was something in the fork changelogs about not requiring report_exn. Is it relevant to this? *) - H2.Reqd.report_exn conn exn; - Lwt.return_unit - end + H2.Reqd.report_exn conn exn in httpaf_request_handler @@ -294,9 +282,9 @@ type tls_library = { handler:Message.handler -> error_handler:Catch.error_handler -> sw:Switch.t -> - Unix.sockaddr -> - Lwt_unix.file_descr -> - unit Lwt.t; + Unix.sockaddr -> + Lwt_unix.file_descr -> + unit; } let no_tls = { @@ -304,11 +292,16 @@ let no_tls = { ~certificate_file:_ ~key_file:_ ~handler ~error_handler - ~sw -> - Httpaf_lwt_unix.Server.create_connection_handler - ?config:None - ~request_handler:(wrap_handler ~sw false error_handler handler) - ~error_handler:(Error_handler.httpaf error_handler) + ~sw + sockaddr + fd -> + Lwt_eio.Promise.await_lwt @@ + Httpaf_lwt_unix.Server.create_connection_handler + ?config:None + ~request_handler:(wrap_handler ~sw false error_handler handler) + ~error_handler:(Error_handler.httpaf error_handler) + sockaddr + fd end; } @@ -319,18 +312,22 @@ let openssl = { ~error_handler ~sw -> - let httpaf_handler = + let httpaf_handler sockaddr socket = Httpaf_lwt_unix.Server.SSL.create_connection_handler ?config:None ~request_handler:(wrap_handler ~sw true error_handler handler) ~error_handler:(Error_handler.httpaf error_handler) + sockaddr socket + |> Lwt_eio.Promise.await_lwt in - let h2_handler = + let h2_handler sockaddr socket = H2_lwt_unix.Server.SSL.create_connection_handler ?config:None ~request_handler:(wrap_handler_h2 ~sw true error_handler handler) ~error_handler:(Error_handler.h2 error_handler) + sockaddr socket + |> Lwt_eio.Promise.await_lwt in let perform_tls_handshake = @@ -341,7 +338,7 @@ let openssl = { in fun client_address unix_socket -> - let%lwt tls_endpoint = perform_tls_handshake client_address unix_socket in + let tls_endpoint = Lwt_eio.Promise.await_lwt @@ perform_tls_handshake client_address unix_socket in (* TODO LATER This part with getting the negotiated protocol belongs in Gluten. Right now, we've picked up a hard dep on OpenSSL. *) (* See also https://github.com/anmonteiro/ocaml-h2/blob/66d92f1694b488ea638aa5073c796e164d5fbd9e/examples/alpn/unix/alpn_server_ssl.ml#L57 *) @@ -369,7 +366,6 @@ let openssl = { | Some _ -> assert false end; -*) } (* TODO LATER Add ALPN + HTTP/2.0 with ocaml-tls, too. *) @@ -378,12 +374,17 @@ let ocaml_tls = { ~certificate_file ~key_file ~handler ~error_handler - ~sw -> + ~sw + sockaddr + fd -> + Lwt_eio.Promise.await_lwt @@ Httpaf_lwt_unix.Server.TLS.create_connection_handler_with_default ~certfile:certificate_file ~keyfile:key_file ?config:None ~request_handler:(wrap_handler ~sw true error_handler handler) ~error_handler:(Error_handler.httpaf error_handler) + sockaddr + fd } @@ -459,22 +460,22 @@ let serve_with_details try let fd = Eio_unix.FD.take_opt flow |> Option.get in let socket = Lwt_unix.of_unix_file_descr fd in - Lwt_eio.Promise.await_lwt @@ httpaf_connection_handler ~sw client_address socket with exn -> tls_error_handler client_address exn in - let listen_address = Lwt_eio.Promise.await_lwt @@ + let listen_address = (* Look up the low-level address corresponding to the interface. Hopefully, this is a local interface. *) - let%lwt addresses = Lwt_unix.getaddrinfo interface (string_of_int port) [] in + let addresses = Lwt_eio.Promise.await_lwt @@ Lwt_unix.getaddrinfo interface (string_of_int port) [] in match addresses with | [] -> + Lwt_eio.Promise.await_lwt @@ Printf.ksprintf failwith "Dream.%s: no interface with address %s" caller_function_for_error_messages interface | address::_ -> - Lwt.return (of_unix_addr Lwt_unix.(address.ai_addr)) + of_unix_addr Lwt_unix.(address.ai_addr) in (* Bring up the HTTP server. *) diff --git a/src/http/shared/dune b/src/http/shared/dune index 31b3c06a..3da01ba3 100644 --- a/src/http/shared/dune +++ b/src/http/shared/dune @@ -5,6 +5,6 @@ bigstringaf dream-pure dream-httpaf.dream-websocketaf + lwt_eio ) - (preprocess (pps lwt_ppx)) (instrumentation (backend bisect_ppx))) diff --git a/src/http/shared/websocket.ml b/src/http/shared/websocket.ml index 358d5774..93e85586 100644 --- a/src/http/shared/websocket.ml +++ b/src/http/shared/websocket.ml @@ -100,7 +100,7 @@ let websocket_handler stream socket = else match !current_payload with | None -> - Lwt.on_success (Lwt_stream.get frames) begin function + begin match Lwt_eio.Promise.await_lwt (Lwt_stream.get frames) with | None -> if not !closed then begin closed := true; From b600bc191d14964eaf8a93fd067ea087ed371947 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Sun, 2 Apr 2023 22:56:53 +0200 Subject: [PATCH 16/42] Update dream.mli --- src/cipher/dune | 1 - src/dream.ml | 13 ++++++------- src/dream.mli | 15 +++++++-------- test/expect/server/router.ml | 2 +- 4 files changed, 14 insertions(+), 17 deletions(-) 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/dream.ml b/src/dream.ml index a2c0e25d..c186a326 100644 --- a/src/dream.ml +++ b/src/dream.ml @@ -76,7 +76,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 @@ -144,7 +143,7 @@ let all_cookies = Cookie.all_cookies (* Bodies *) -let body x = Lwt_eio.Promise.await_lwt (Message.body x) +let body x = Message.body x let set_body = Message.set_body @@ -195,12 +194,12 @@ let origin_referrer_check = Origin_referrer_check.origin_referrer_check (* Forms *) type 'a form_result = 'a Form.form_result -let form ?csrf x = Lwt_eio.Promise.await_lwt (Form.form ~now ?csrf x) +let form ?csrf x = Form.form ~now ?csrf x type multipart_form = Upload.multipart_form -let multipart ?csrf x = Lwt_eio.Promise.await_lwt (Upload.multipart ~now ?csrf x) +let multipart ?csrf x = Upload.multipart ~now ?csrf x type part = Upload.part -let upload request = Lwt_eio.Promise.await_lwt (Upload.upload request) -let upload_part request = Lwt_eio.Promise.await_lwt (Upload.upload_part request) +let upload request = Upload.upload request +let upload_part request = Upload.upload_part request type csrf_result = Csrf.csrf_result let csrf_token = Csrf.csrf_token ~now let verify_csrf_token = Csrf.verify_csrf_token ~now @@ -289,7 +288,7 @@ let graphiql = Graphql.graphiql (* SQL *) let sql_pool = Sql.sql_pool -let sql req fn = Lwt_eio.Promise.await_lwt (Sql.sql req fn) +let sql req fn = Sql.sql req fn diff --git a/src/dream.mli b/src/dream.mli index dcfacb8f..0d57318c 100644 --- a/src/dream.mli +++ b/src/dream.mli @@ -118,7 +118,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} @@ -742,7 +741,7 @@ 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]}. *) @@ -757,15 +756,15 @@ https://aantron.github.io/dream/#val-set_stream "] (**/**) -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. *) -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} @@ -938,7 +937,7 @@ val receive : websocket -> string option 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 @@ -1219,7 +1218,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. *) @@ -1846,7 +1845,7 @@ 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 +val sql : request -> (Caqti_lwt.connection -> '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]}. diff --git a/test/expect/server/router.ml b/test/expect/server/router.ml index ff38d935..b715fe21 100644 --- a/test/expect/server/router.ml +++ b/test/expect/server/router.ml @@ -96,11 +96,11 @@ let show ?(prefix = "/") ?(method_ = `GET) target router = |> Dream.test ~prefix router |> fun response -> let body = + Eio_main.run @@ fun env -> Dream.client_stream response |> Obj.magic (* TODO Needs to be replaced by exposing read_until_close as a function on abstract streams. *) |> Dream_pure.Stream.read_until_close - |> Lwt_main.run in let status = Dream.status response in Printf.printf "Response: %i %s\n" From 02208cdfa747a70f4b7546229c3786e7f20e844c Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Sun, 2 Apr 2023 23:15:10 +0200 Subject: [PATCH 17/42] Fix examples --- example/h-sql/sql.eml.ml | 8 +- example/w-postgres/postgres.eml.ml | 10 ++- example/z-playground/server/playground.ml | 101 +++++++++++----------- 3 files changed, 59 insertions(+), 60 deletions(-) diff --git a/example/h-sql/sql.eml.ml b/example/h-sql/sql.eml.ml index 060f38bc..5abec84e 100644 --- a/example/h-sql/sql.eml.ml +++ b/example/h-sql/sql.eml.ml @@ -7,8 +7,8 @@ let list_comments = (T.unit ->* T.(tup2 int string)) "SELECT id, text FROM comment" in fun (module Db : DB) -> - let%lwt comments_or_error = Db.collect_list query () in - Caqti_lwt.or_fail comments_or_error + let comments_or_error = Lwt_eio.Promise.await_lwt @@ Db.collect_list query () in + Lwt_eio.Promise.await_lwt @@ Caqti_lwt.or_fail comments_or_error let add_comment = let query = @@ -16,8 +16,8 @@ let add_comment = (T.string ->. T.unit) "INSERT INTO comment (text) VALUES ($1)" in fun text (module Db : DB) -> - let%lwt unit_or_error = Db.exec query text in - Caqti_lwt.or_fail unit_or_error + let unit_or_error = Lwt_eio.Promise.await_lwt @@ Db.exec query text in + Lwt_eio.Promise.await_lwt @@ Caqti_lwt.or_fail unit_or_error let render comments request = diff --git a/example/w-postgres/postgres.eml.ml b/example/w-postgres/postgres.eml.ml index 5edaa979..e7a3a558 100644 --- a/example/w-postgres/postgres.eml.ml +++ b/example/w-postgres/postgres.eml.ml @@ -8,8 +8,9 @@ let list_comments = (T.unit ->* T.(tup2 int string)) "SELECT id, text FROM comment" in fun (module Db : DB) -> - let%lwt comments_or_error = Db.collect_list query () in - Caqti_lwt.or_fail comments_or_error + Lwt_eio.Promise.await_lwt ( + let%lwt comments_or_error = Db.collect_list query () in + Caqti_lwt.or_fail comments_or_error) let add_comment = let query = @@ -17,8 +18,9 @@ let add_comment = (T.string ->. T.unit) "INSERT INTO comment (text) VALUES ($1)" in fun text (module Db : DB) -> - let%lwt unit_or_error = Db.exec query text in - Caqti_lwt.or_fail unit_or_error + Lwt_eio.Promise.await_lwt ( + let%lwt unit_or_error = Db.exec query text in + Caqti_lwt.or_fail unit_or_error) let render comments request = diff --git a/example/z-playground/server/playground.ml b/example/z-playground/server/playground.ml index 3579df1c..76bf72e3 100644 --- a/example/z-playground/server/playground.ml +++ b/example/z-playground/server/playground.ml @@ -58,7 +58,7 @@ COPY server.exe server.exe |} let exec format = - Printf.ksprintf (fun command -> Lwt_process.(exec (shell command))) format + Printf.ksprintf (fun command -> Lwt_eio.Promise.await_lwt @@ Lwt_process.(exec (shell command))) format let create_sandboxes_directory () = match%lwt Lwt_unix.mkdir sandbox_root 0o755 with @@ -102,22 +102,22 @@ let rec create ?(attempts = 3) syntax eml code = | false -> create_named sandbox syntax eml code let read sandbox = - let%lwt no_eml_exists = - Lwt_unix.file_exists (sandbox_root // sandbox // "no-eml") in + let no_eml_exists = + Lwt_eio.Promise.await_lwt @@ Lwt_unix.file_exists (sandbox_root // sandbox // "no-eml") in let eml = not no_eml_exists in let base = if eml then "server.eml" else "server" in let ocaml_promise = - Lwt_io.(with_file + Lwt_eio.Promise.await_lwt @@ Lwt_io.(with_file ~mode:Input (sandbox_root // sandbox // base ^ ".ml") read) in - match%lwt ocaml_promise with - | content -> Lwt.return (content, `OCaml, eml) + match ocaml_promise with + | content -> content, `OCaml, eml | exception _ -> - let%lwt content = - Lwt_io.(with_file + let content = + Lwt_eio.Promise.await_lwt @@ Lwt_io.(with_file ~mode:Input (sandbox_root // sandbox // base ^ ".re") read) in - Lwt.return (content, `Reason, eml) + content, `Reason, eml let init_client socket content = `Assoc [ @@ -172,19 +172,15 @@ let next_port = let rec allocate_port () = let port = !next_port in incr next_port; - let%lwt () = - if !next_port > max_port then begin - next_port := min_port; - Lwt.pause () - end - else - Lwt.return_unit - in + if !next_port > max_port then begin + next_port := min_port; + Eio.Fiber.yield () + end; if Hashtbl.mem allocated_ports port then allocate_port () else begin Hashtbl.replace allocated_ports port (); - Lwt.return port + port end let client_log ?(add_newline = false) session message = @@ -213,7 +209,7 @@ let build_sandbox sandbox syntax eml = else write_file sandbox "no-eml" "" end;%lwt - let%lwt _status = exec "rm -f %s/server.exe" (sandbox_root // sandbox) in + let _status = exec "rm -f %s/server.exe" (sandbox_root // sandbox) in let process = Printf.sprintf "cd %s && opam exec %s -- dune build %s ./server.exe 2>&1" @@ -223,7 +219,7 @@ let build_sandbox sandbox syntax eml = let%lwt output = Lwt_io.read process#stdout in match%lwt process#close with | Unix.WEXITED 0 -> - let%lwt _status = + let _status = exec "cp ../../_build/default/example/z-playground/%s/server.exe %s" (sandbox_root // sandbox) (sandbox_root // sandbox) @@ -244,13 +240,13 @@ let build session = Lwt.return_false let image_exists sandbox = - match%lwt exec "docker image inspect sandbox:%s 2>&1 > /dev/null" sandbox with - | Unix.WEXITED 0 -> Lwt.return_true - | _ -> Lwt.return_false + match exec "docker image inspect sandbox:%s 2>&1 > /dev/null" sandbox with + | Unix.WEXITED 0 -> true + | _ -> false let image_sandbox sandbox = write_file sandbox "Dockerfile" sandbox_dockerfile;%lwt - let%lwt _status = + let _status = exec "cd %s && docker build -t sandbox:%s . 2>&1" (sandbox_root // sandbox) sandbox in Lwt.return_unit @@ -286,7 +282,7 @@ let run session = Lwt.wakeup_later signal_alive () end in - let%lwt port = allocate_port () in + let port = allocate_port () in let container_id = make_container_id () in session.container <- Some {container_id; port}; Lwt.async begin fun () -> @@ -297,7 +293,7 @@ let run session = |> Lwt_process.pread_lines |> Lwt_stream.iter_s (fun line -> signal_alive (); - client_log ~add_newline:true session line) + Lwt.return @@ client_log ~add_newline:true session line) end; alive;%lwt started session port; @@ -327,9 +323,9 @@ let sandbox_locks = let lock_sandbox sandbox f = begin match !gc_running with - | None -> Lwt.return_unit - | Some finished -> finished - end;%lwt + | None -> () + | Some finished -> Lwt_eio.Promise.await_lwt finished + end; incr sandbox_users; let mutex = @@ -340,13 +336,11 @@ let lock_sandbox sandbox f = Hashtbl.add sandbox_locks sandbox mutex; mutex in - Lwt.finalize - (fun () -> Lwt_mutex.with_lock mutex f) - (fun () -> + Fun.protect ~finally:(fun () -> decr sandbox_users; if !sandbox_users = 0 then - !notify_gc (); - Lwt.return_unit) + !notify_gc ()) + (fun () -> Lwt_eio.Promise.await_lwt @@ Lwt_mutex.with_lock mutex f) let rec listen session = match Dream.receive session.socket with @@ -360,7 +354,7 @@ let rec listen session = lock_sandbox session.sandbox begin fun () -> - let%lwt current_code, _, _ = read session.sandbox in + let current_code, _, _ = read session.sandbox in if code = current_code then Lwt.return_unit else begin @@ -369,7 +363,7 @@ let rec listen session = Lwt.return_unit end;%lwt - match%lwt image_exists session.sandbox with + match image_exists session.sandbox with | true -> run session | false -> match%lwt build session with @@ -377,15 +371,15 @@ let rec listen session = | true -> image session;%lwt run session - end;%lwt + end; listen session let listen session = - try%lwt + try listen session with exn -> - kill session;%lwt + kill session; raise exn @@ -432,14 +426,14 @@ let rec gc ?(initial = true) () = | _ -> None) in - let%lwt _status = exec "docker rmi %s" (String.concat " " images) in + let _status = exec "docker rmi %s" (String.concat " " images) in Lwt_unix.files_of_directory "sandbox" |> Lwt_stream.iter_n ~max_concurrency:16 begin fun sandbox -> if List.mem sandbox keep then Lwt.return_unit else - let%lwt _status = exec "rm -rf sandbox/%s/_build" sandbox in + let _status = exec "rm -rf sandbox/%s/_build" sandbox in Lwt.return_unit end;%lwt @@ -455,17 +449,19 @@ let rec gc ?(initial = true) () = Dream.log "Warming caches"; keep |> Lwt_list.iteri_s begin fun index sandbox -> - Lwt_unix.sleep 1.;%lwt + Eio_unix.sleep 1.; if initial then Dream.log "Warming %s (%i/%i)" sandbox (index + 1) (List.length keep); lock_sandbox sandbox (fun () -> - if%lwt image_exists sandbox then - Lwt.return_unit + if image_exists sandbox then + () else begin - let%lwt _, syntax, eml = read sandbox in - let%lwt _ = build_sandbox sandbox syntax eml in - image_sandbox sandbox - end) + let _, syntax, eml = read sandbox in + let _ = Lwt_eio.Promise.await_lwt @@ build_sandbox sandbox syntax eml in + Lwt_eio.Promise.await_lwt @@ image_sandbox sandbox + end; + Lwt.return_unit); + Lwt.return_unit end;%lwt next;%lwt @@ -490,7 +486,7 @@ let () = write channel base_dockerfile));%lwt Lwt_io.(with_file ~mode:Output ".dockerignore" (fun channel -> write channel base_dockerignore));%lwt - let%lwt _status = exec "docker build -t base:base . 2>&1" in + let _status = exec "docker build -t base:base . 2>&1" in Lwt.return_unit end; @@ -518,7 +514,8 @@ let () = Dream.html (Client.html example) in - Eio_main.run (fun env -> Dream.run env ~interface:"0.0.0.0" ~port:80 ~adjust_terminal:false + Eio_main.run @@ fun env -> + Dream.run env ~interface:"0.0.0.0" ~port:80 ~adjust_terminal:false @@ Dream.logger @@ Dream.router [ @@ -539,9 +536,9 @@ let () = | true -> (* Read the sandbox. If the requested sandbox doesn't exist, this will raise an exception, causing a 500 reply to the JavaScript client. *) - let%lwt content, syntax, eml = read sandbox in + let content, syntax, eml = read sandbox in Dream.websocket (fun socket -> - init_client socket content;%lwt + init_client socket content; Dream.info (fun log -> log "Sandbox %s: content sent to client" sandbox); listen {container = None; sandbox; syntax; eml; socket})); From a9cca15b75d1d96577dda563ba75b90c09026303 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Sat, 8 Apr 2023 15:11:34 +0200 Subject: [PATCH 18/42] Update dependencies to master --- src/vendor/gluten | 2 +- src/vendor/h2 | 2 +- src/vendor/httpaf | 2 +- src/vendor/paf | 2 +- src/vendor/websocketaf | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/vendor/gluten b/src/vendor/gluten index 0c9341a6..b2aea887 160000 --- a/src/vendor/gluten +++ b/src/vendor/gluten @@ -1 +1 @@ -Subproject commit 0c9341a64ee7432c7a3e1a5e97b4012fee2775c2 +Subproject commit b2aea88753540b4b315d9a242ccb2cdafd18dd91 diff --git a/src/vendor/h2 b/src/vendor/h2 index fa0c8a47..c372c736 160000 --- a/src/vendor/h2 +++ b/src/vendor/h2 @@ -1 +1 @@ -Subproject commit fa0c8a4746fdc50183e254f8c08239fc5b67717d +Subproject commit c372c736a278e3c5e4ea75adecb2cd400cedcdb1 diff --git a/src/vendor/httpaf b/src/vendor/httpaf index 3a74fd88..340ba8c6 160000 --- a/src/vendor/httpaf +++ b/src/vendor/httpaf @@ -1 +1 @@ -Subproject commit 3a74fd8851e3019f5889ae1bf9350e90ed40017d +Subproject commit 340ba8c662a2b1cf3305cd46ad4eee65a6de9b7d diff --git a/src/vendor/paf b/src/vendor/paf index b52b0e6b..14059ba8 160000 --- a/src/vendor/paf +++ b/src/vendor/paf @@ -1 +1 @@ -Subproject commit b52b0e6be8b7bb6f0dcb84c4d82963114468956a +Subproject commit 14059ba85f886cf6babe9b8ce5a53a5b1f1bf3e8 diff --git a/src/vendor/websocketaf b/src/vendor/websocketaf index 248a2cb0..7530659c 160000 --- a/src/vendor/websocketaf +++ b/src/vendor/websocketaf @@ -1 +1 @@ -Subproject commit 248a2cb0dcffa51996c3ad7643577dce75d67454 +Subproject commit 7530659c8a3fd1beed5197acde37dc7a20acd0af From b30594ea1a433ce49ba45799b3e3ae981b71794a Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Sat, 8 Apr 2023 19:55:44 +0200 Subject: [PATCH 19/42] Revert "Disable openssl for now" This reverts commit 6f608d0c3ad562d0eb1dab2fd0cb85e94b6f30c1. --- src/vendor/dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/vendor/dune b/src/vendor/dune index 8e3c810b..e951e762 100644 --- a/src/vendor/dune +++ b/src/vendor/dune @@ -31,7 +31,7 @@ (select ssl_io.ml from - (lwt_ssl_disabled -> ssl_io.real.ml) + (lwt_ssl -> ssl_io.real.ml) (-> ssl_io.dummy.ml)) (select tls_io.ml From c44b79c8c8ccfb0e477b60f44c5217d1ffff1903 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Sat, 8 Apr 2023 20:22:04 +0200 Subject: [PATCH 20/42] Remove promises from dream.mli --- src/dream.mli | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/dream.mli b/src/dream.mli index 0d57318c..1609c057 100644 --- a/src/dream.mli +++ b/src/dream.mli @@ -726,7 +726,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} @@ -1643,12 +1643,12 @@ https://aantron.github.io/dream/#val-session_field "] (**/**) -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. *) (**/**) -val put_session : string -> string -> request -> unit promise +val put_session : string -> string -> request -> unit [@ocaml.deprecated "Renamed to Dream.set_session_field. See https://aantron.github.io/dream/#val-set_session_field @@ -1666,7 +1666,7 @@ https://aantron.github.io/dream/#val-all_session_fields "] (**/**) -val invalidate_session : request -> unit promise +val invalidate_session : request -> unit (** Invalidates the request's session, replacing it with a fresh, empty pre-session. *) From 47a4617cacd49f2d3458099165843d2d109c3c07 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Sat, 8 Apr 2023 21:42:12 +0200 Subject: [PATCH 21/42] Replace gluten and httpaf lwt variants with eio --- src/http/adapt.ml | 10 +++++++--- src/http/dune | 3 ++- src/http/error_handler.mli | 6 +++--- src/http/http.ml | 17 ++++++----------- src/vendor/dune | 23 ++++++++++++++++++++++- 5 files changed, 40 insertions(+), 19 deletions(-) diff --git a/src/http/adapt.ml b/src/http/adapt.ml index 8f822c0b..ffcf6166 100644 --- a/src/http/adapt.ml +++ b/src/http/adapt.ml @@ -13,9 +13,13 @@ module Message = Dream_pure.Message -let address_to_string : Unix.sockaddr -> string = function - | ADDR_UNIX path -> path - | ADDR_INET (address, port) -> +let address_to_string : Eio.Net.Sockaddr.stream -> string = function + | `Unix path -> path + | `Tcp (address, port) -> + let address = + address + |> Eio_unix.Ipaddr.to_unix + in Printf.sprintf "%s:%i" (Unix.string_of_inet_addr address) port diff --git a/src/http/dune b/src/http/dune index 4e2c2e99..895b866a 100644 --- a/src/http/dune +++ b/src/http/dune @@ -9,11 +9,12 @@ dream.server dream-httpaf dream-httpaf.dream-gluten - dream-httpaf.dream-gluten-lwt-unix + dream-httpaf.dream-gluten-eio dream-httpaf.dream-h2 dream-httpaf.dream-h2-lwt-unix dream-httpaf.dream-httpaf_ dream-httpaf.dream-httpaf_-lwt-unix + dream-httpaf.dream-httpaf_-eio lwt.unix lwt_ssl ssl diff --git a/src/http/error_handler.mli b/src/http/error_handler.mli index 3645a689..eacaebd6 100644 --- a/src/http/error_handler.mli +++ b/src/http/error_handler.mli @@ -43,15 +43,15 @@ val app : val httpaf : Catch.error_handler -> - (Unix.sockaddr -> Httpaf.Server_connection.error_handler) + (Eio.Net.Sockaddr.stream -> Httpaf.Server_connection.error_handler) val h2 : Catch.error_handler -> - (Unix.sockaddr -> H2.Server_connection.error_handler) + (Eio.Net.Sockaddr.stream -> H2.Server_connection.error_handler) val tls : Catch.error_handler -> - (Unix.sockaddr -> exn -> unit) + (Eio.Net.Sockaddr.stream -> exn -> unit) val websocket : Catch.error_handler -> diff --git a/src/http/http.ml b/src/http/http.ml index 6d0537c8..54ad1461 100644 --- a/src/http/http.ml +++ b/src/http/http.ml @@ -7,9 +7,9 @@ open Eio.Std module Gluten = Dream_gluten.Gluten -module Gluten_lwt_unix = Dream_gluten_lwt_unix.Gluten_lwt_unix +module Gluten_eio = Dream_gluten_eio.Gluten_eio module Httpaf = Dream_httpaf_.Httpaf -module Httpaf_lwt_unix = Dream_httpaf__lwt_unix.Httpaf_lwt_unix +module Httpaf_eio = Dream_httpaf__eio.Httpaf_eio module H2 = Dream_h2.H2 module H2_lwt_unix = Dream_h2_lwt_unix.H2_lwt_unix module Websocketaf = Dream_websocketaf.Websocketaf @@ -282,8 +282,8 @@ type tls_library = { handler:Message.handler -> error_handler:Catch.error_handler -> sw:Switch.t -> - Unix.sockaddr -> - Lwt_unix.file_descr -> + Eio.Net.Sockaddr.stream -> + Eio.Flow.two_way -> unit; } @@ -295,8 +295,7 @@ let no_tls = { ~sw sockaddr fd -> - Lwt_eio.Promise.await_lwt @@ - Httpaf_lwt_unix.Server.create_connection_handler + Httpaf_eio.Server.create_connection_handler ?config:None ~request_handler:(wrap_handler ~sw false error_handler handler) ~error_handler:(Error_handler.httpaf error_handler) @@ -456,11 +455,8 @@ let serve_with_details coupling), or the upstream should be patched to distinguish the errors in some useful way. *) let httpaf_connection_handler ~sw flow client_address = - let client_address = to_unix_addr client_address in try - let fd = Eio_unix.FD.take_opt flow |> Option.get in - let socket = Lwt_unix.of_unix_file_descr fd in - httpaf_connection_handler ~sw client_address socket + httpaf_connection_handler ~sw client_address flow with exn -> tls_error_handler client_address exn in @@ -471,7 +467,6 @@ let serve_with_details let addresses = Lwt_eio.Promise.await_lwt @@ Lwt_unix.getaddrinfo interface (string_of_int port) [] in match addresses with | [] -> - Lwt_eio.Promise.await_lwt @@ Printf.ksprintf failwith "Dream.%s: no interface with address %s" caller_function_for_error_messages interface | address::_ -> diff --git a/src/vendor/dune b/src/vendor/dune index e951e762..ab2f2038 100644 --- a/src/vendor/dune +++ b/src/vendor/dune @@ -20,6 +20,15 @@ lwt ))) +(subdir gluten/eio + (library + (name dream_gluten_eio) + (public_name dream-httpaf.dream-gluten-eio) + (libraries + dream-httpaf.dream-gluten + unix eio bigstringaf + ))) + (subdir gluten/lwt-unix (library (name dream_gluten_lwt_unix) @@ -64,6 +73,18 @@ lwt ))) +(subdir httpaf/eio + (library + (name dream_httpaf__eio) + (public_name dream-httpaf.dream-httpaf_-eio) + (libraries + dream-httpaf.dream-httpaf_ + eio + dream-httpaf.dream-gluten + dream-httpaf.dream-gluten-eio + ))) + + (subdir httpaf/lwt-unix (library (name dream_httpaf__lwt_unix) @@ -223,7 +244,7 @@ (modules lE) (libraries tcpip - dream-httpaf.httpaf + dream-httpaf.dream-httpaf_ dream-mirage.dream-paf mirage-time duration From fc7ed9917bf3354c22eedb4595f97717ea3d65fc Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Sat, 8 Apr 2023 23:10:36 +0200 Subject: [PATCH 22/42] Expose backlog, remove more lwt from http/ --- src/dream.mli | 2 ++ src/http/dune | 5 ----- src/http/http.ml | 14 ++++++++++---- 3 files changed, 12 insertions(+), 9 deletions(-) diff --git a/src/dream.mli b/src/dream.mli index 1609c057..b3fe6663 100644 --- a/src/dream.mli +++ b/src/dream.mli @@ -2195,6 +2195,7 @@ val run : ?interface:string -> ?port:int -> ?error_handler:error_handler -> + ?backlog:int -> ?tls:bool -> ?certificate_file:string -> ?key_file:string -> @@ -2250,6 +2251,7 @@ val serve : ?interface:string -> ?port:int -> ?error_handler:error_handler -> + ?backlog:int -> ?tls:bool -> ?certificate_file:string -> ?key_file:string -> diff --git a/src/http/dune b/src/http/dune index 895b866a..7a2f49c1 100644 --- a/src/http/dune +++ b/src/http/dune @@ -13,14 +13,9 @@ dream-httpaf.dream-h2 dream-httpaf.dream-h2-lwt-unix dream-httpaf.dream-httpaf_ - dream-httpaf.dream-httpaf_-lwt-unix dream-httpaf.dream-httpaf_-eio - lwt.unix - lwt_ssl ssl dream-httpaf.dream-websocketaf - lwt_eio eio_main ) - (preprocess (pps lwt_ppx)) (instrumentation (backend bisect_ppx))) diff --git a/src/http/http.ml b/src/http/http.ml index 54ad1461..f91b0e10 100644 --- a/src/http/http.ml +++ b/src/http/http.ml @@ -412,6 +412,7 @@ let serve_with_details ~interface ~port ~error_handler + ~backlog ~certificate_file ~key_file ~builtins @@ -464,13 +465,13 @@ let serve_with_details let listen_address = (* Look up the low-level address corresponding to the interface. Hopefully, this is a local interface. *) - let addresses = Lwt_eio.Promise.await_lwt @@ Lwt_unix.getaddrinfo interface (string_of_int port) [] in + let addresses = Unix.getaddrinfo interface (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::_ -> - of_unix_addr Lwt_unix.(address.ai_addr) + of_unix_addr address.ai_addr in (* Bring up the HTTP server. *) @@ -478,7 +479,7 @@ let serve_with_details let socket = Eio.Net.listen ~sw net listen_address ~reuse_addr:true - ~backlog:(Lwt_unix.somaxconn () [@ocaml.warning "-3"]) + ~backlog in while true do Eio.Net.accept_fork ~sw socket (httpaf_connection_handler ~sw) @@ -495,6 +496,7 @@ let serve_with_maybe_https ~interface ~port ~error_handler + ~backlog ~tls ?certificate_file ?key_file ?certificate_string ?key_string @@ -522,6 +524,7 @@ let serve_with_maybe_https ~interface ~port ~error_handler + ~backlog ~certificate_file:"" ~key_file:"" ~builtins @@ -645,6 +648,7 @@ let serve ?(interface = default_interface) ?(port = default_port) ?(error_handler = Error_handler.default) + ?(backlog = 10) ?(tls = false) ?certificate_file ?key_file @@ -658,6 +662,7 @@ let serve ~interface ~port ~error_handler + ~backlog ~tls:(if tls then `OpenSSL else `No) ?certificate_file ?key_file @@ -672,6 +677,7 @@ let run ?(interface = default_interface) ?(port = default_port) ?(error_handler = Error_handler.default) + ?(backlog = 10) ?(tls = false) ?certificate_file ?key_file @@ -744,13 +750,13 @@ let run try begin - Lwt_eio.with_event_loop ~clock:env#clock @@ fun () -> serve_with_maybe_https "run" ~net:env#net ~interface ~port ~error_handler + ~backlog ~tls:(if tls then `OpenSSL else `No) ?certificate_file ?key_file ?certificate_string:None ?key_string:None From ceedc7039860f5aa392210681d4c2ba1b13755c4 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Sat, 8 Apr 2023 23:29:42 +0200 Subject: [PATCH 23/42] Disable SSL for the time being --- src/http/http.ml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/http/http.ml b/src/http/http.ml index f91b0e10..3a1dc500 100644 --- a/src/http/http.ml +++ b/src/http/http.ml @@ -304,6 +304,7 @@ let no_tls = { end; } +(* let openssl = { create_handler = begin fun ~certificate_file ~key_file @@ -385,6 +386,7 @@ let ocaml_tls = { sockaddr fd } +*) @@ -530,6 +532,7 @@ let serve_with_maybe_https ~builtins user's_dream_handler +(* | `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 @@ -627,6 +630,7 @@ let serve_with_maybe_https end end + *) with exn -> let backtrace = Printexc.get_backtrace () in @@ -663,7 +667,8 @@ let serve ~port ~error_handler ~backlog - ~tls:(if tls then `OpenSSL else `No) + (* ~tls:(if tls then `OpenSSL else `No) *) + ~tls:`No ?certificate_file ?key_file ?certificate_string:None @@ -757,7 +762,8 @@ let run ~port ~error_handler ~backlog - ~tls:(if tls then `OpenSSL else `No) + (* ~tls:(if tls then `OpenSSL else `No) *) + ~tls:`No ?certificate_file ?key_file ?certificate_string:None ?key_string:None ~builtins From f9f68d779b7345438c5909895838ba53aa5c8931 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Sun, 9 Apr 2023 00:08:38 +0200 Subject: [PATCH 24/42] Move static files to eio Using capabilities shouldn't be a big problem? Eio.Path.with_open_dir seems to work quite nicely if needed --- example/f-static/static.ml | 2 +- example/w-one-binary/one_binary.ml | 2 +- src/dream.mli | 6 +++--- src/unix/dune | 2 -- src/unix/static.ml | 14 ++++---------- 5 files changed, 9 insertions(+), 17 deletions(-) diff --git a/example/f-static/static.ml b/example/f-static/static.ml index acd50a2f..b3085472 100644 --- a/example/f-static/static.ml +++ b/example/f-static/static.ml @@ -3,5 +3,5 @@ let () = Dream.run env @@ Dream.logger @@ Dream.router [ - Dream.get "/static/**" (Dream.static ".") + Dream.get "/static/**" (Dream.static (Eio.Stdenv.cwd env)) ] diff --git a/example/w-one-binary/one_binary.ml b/example/w-one-binary/one_binary.ml index f96b2277..9975ecb6 100644 --- a/example/w-one-binary/one_binary.ml +++ b/example/w-one-binary/one_binary.ml @@ -8,5 +8,5 @@ let () = Dream.run env @@ Dream.logger @@ Dream.router [ - Dream.get "/assets/**" (Dream.static ~loader "") + Dream.get "/assets/**" (Dream.static ~loader (Eio.Stdenv.cwd env)) ] diff --git a/src/dream.mli b/src/dream.mli index b3fe6663..44ba54ff 100644 --- a/src/dream.mli +++ b/src/dream.mli @@ -1544,8 +1544,8 @@ val no_route : route (** {1 Static files} *) val static : - ?loader:(string -> string -> handler) -> - string -> handler + ?loader:('a Eio.Path.t -> string -> handler) -> + 'a 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]}. @@ -1575,7 +1575,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]. 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 06e8764a..5b6aa1bf 100644 --- a/src/unix/static.ml +++ b/src/unix/static.ml @@ -15,8 +15,6 @@ module Stream = Dream_pure.Stream (* TODO Not at all efficient; can at least stream the file, maybe even cache. *) (* TODO Also mind newlines on Windows. *) -(* TODO NOTE Using Lwt_io because it has a nice "read the whole thing" - function. *) let mime_lookup filename = let content_type = @@ -27,15 +25,11 @@ let mime_lookup filename = ["Content-Type", content_type] let from_filesystem local_root path _ = - let file = Filename.concat local_root path in + let file = Eio.Path.(local_root / path) in try - Lwt_eio.Promise.await_lwt ( - Lwt_io.(with_file ~mode:Input file) (fun channel -> - let%lwt content = Lwt_io.read channel in - Message.response - ~headers:(mime_lookup path) (Stream.string content) Stream.null - |> Lwt.return) - ) + let content = Eio.Path.load file in + Message.response + ~headers:(mime_lookup path) (Stream.string content) Stream.null with _exn -> Message.response ~status:`Not_Found Stream.empty Stream.null From 64bef1ba6b236756cdfc25b4af0f95c92bd48802 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Sun, 9 Apr 2023 11:57:05 +0200 Subject: [PATCH 25/42] Remove lwt async_exception_hook --- src/dream.mli | 1 - src/http/http.ml | 6 +----- src/mirage/mirage.mli | 1 - src/server/log.ml | 18 ------------------ 4 files changed, 1 insertion(+), 25 deletions(-) diff --git a/src/dream.mli b/src/dream.mli index 44ba54ff..551c54ce 100644 --- a/src/dream.mli +++ b/src/dream.mli @@ -1965,7 +1965,6 @@ val sub_log : ?level:[< log_level] -> string -> sub_log val initialize_log : ?backtraces:bool -> - ?async_exception_hook:bool -> ?level:[< log_level ] -> ?enable:bool -> unit -> unit diff --git a/src/http/http.ml b/src/http/http.ml index 3a1dc500..6a063846 100644 --- a/src/http/http.ml +++ b/src/http/http.ml @@ -64,8 +64,6 @@ let wrap_handler ~sw (user's_dream_handler : Message.handler) = let httpaf_request_handler = fun client_address (conn : _ Gluten.Reqd.t) -> - Log.set_up_exception_hook (); - let conn, upgrade = conn.reqd, conn.upgrade in (* Covert the http/af request to a Dream request. *) @@ -187,8 +185,6 @@ let wrap_handler_h2 ~sw (user's_dream_handler : Message.handler) = let httpaf_request_handler = fun client_address (conn : H2.Reqd.t) -> - Log.set_up_exception_hook (); - (* Covert the h2 request to a Dream request. *) let httpaf_request : H2.Request.t = H2.Reqd.request conn in @@ -485,7 +481,7 @@ let serve_with_details in while true do Eio.Net.accept_fork ~sw socket (httpaf_connection_handler ~sw) - ~on_error:(fun ex -> !Lwt.async_exception_hook ex) + ~on_error:(fun ex -> raise ex) done diff --git a/src/mirage/mirage.mli b/src/mirage/mirage.mli index 771dd258..2c250485 100644 --- a/src/mirage/mirage.mli +++ b/src/mirage/mirage.mli @@ -1624,7 +1624,6 @@ module Make val initialize_log : ?backtraces:bool -> - ?async_exception_hook:bool -> ?level:[< log_level] -> ?enable:bool -> unit -> diff --git a/src/server/log.ml b/src/server/log.ml index bd4064e6..f0cfd917 100644 --- a/src/server/log.ml +++ b/src/server/log.ml @@ -261,9 +261,6 @@ let sources : (string * Logs.src) list ref = let set_printexc = ref true -let set_async_exception_hook = - ref true - let _initialized = ref None let to_logs_level l = @@ -382,19 +379,8 @@ let log = -let set_up_exception_hook () = - if !set_async_exception_hook then begin - set_async_exception_hook := false; - Lwt.async_exception_hook := fun exn -> - let backtrace = Printexc.get_backtrace () in - log.error (fun log -> log "Async exception: %s" (Printexc.to_string exn)); - backtrace - |> iter_backtrace (fun line -> log.error (fun log -> log "%s" line)) - end - let initialize_log ?(backtraces = true) - ?(async_exception_hook = true) ?level:level_ ?enable:(enable_ = true) () = @@ -403,10 +389,6 @@ let initialize_log Printexc.record_backtrace true; set_printexc := false; - if async_exception_hook then - set_up_exception_hook (); - set_async_exception_hook := false; - let level_ = Option.map to_logs_level level_ |> Option.value ~default:Logs.Info in From d923711e93cbee4b0f8febc1a0e8c507d540730a Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Sun, 9 Apr 2023 11:59:04 +0200 Subject: [PATCH 26/42] Remove lwt id handling for logging --- src/http/dune | 2 +- src/http/http.ml | 2 +- src/server/log.ml | 53 +++++++++---------------- src/vendor/dune | 99 +++-------------------------------------------- 4 files changed, 25 insertions(+), 131 deletions(-) diff --git a/src/http/dune b/src/http/dune index 7a2f49c1..c703f980 100644 --- a/src/http/dune +++ b/src/http/dune @@ -11,7 +11,7 @@ dream-httpaf.dream-gluten dream-httpaf.dream-gluten-eio dream-httpaf.dream-h2 - dream-httpaf.dream-h2-lwt-unix + dream-httpaf.dream-h2-eio dream-httpaf.dream-httpaf_ dream-httpaf.dream-httpaf_-eio ssl diff --git a/src/http/http.ml b/src/http/http.ml index 6a063846..74e790fa 100644 --- a/src/http/http.ml +++ b/src/http/http.ml @@ -11,7 +11,7 @@ module Gluten_eio = Dream_gluten_eio.Gluten_eio module Httpaf = Dream_httpaf_.Httpaf module Httpaf_eio = Dream_httpaf__eio.Httpaf_eio module H2 = Dream_h2.H2 -module H2_lwt_unix = Dream_h2_lwt_unix.H2_lwt_unix +module H2_eio = Dream_h2_eio.H2_eio module Websocketaf = Dream_websocketaf.Websocketaf module Catch = Dream__server.Catch diff --git a/src/server/log.ml b/src/server/log.ml index f0cfd917..043b53c3 100644 --- a/src/server/log.ml +++ b/src/server/log.ml @@ -68,11 +68,6 @@ let logs_lib_tag : string Logs.Tag.def = request_id_label Format.pp_print_string -(* Lwt sequence-associated storage key used to pass request ids for use when - ~request is not provided. *) -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. *) let id_field = @@ -81,21 +76,23 @@ let id_field = ~show_value:(fun id -> id) () -(* Makes a best-effort attempt to retrieve the request id. *) -let get_request_id ?request () = - let request_id = - match request with - | None -> None - | Some request -> Message.field request id_field - in - match request_id with - | Some _ -> request_id - | None -> Lwt.get id_lwt_key - (* The current state of the request id sequence. *) let last_id = ref 0 +(* Makes a best-effort attempt to retrieve the request id. *) +let get_request_id ?request () = + match request with + | None -> "" + | Some request -> + match Message.field request id_field with + | Some id -> id + | None -> + (* Get the requwst's id or assign a new one. *) + last_id := !last_id + 1; + let id = string_of_int !last_id in + Message.set_field request id_field id; + id (* TODO Nice logging for multiline strings? *) @@ -211,14 +208,14 @@ let reporter ~now () = let request_id = match request_id_from_tags with - | Some _ -> request_id_from_tags + | Some id -> id | None -> get_request_id () in let request_id, request_style = match request_id with - | Some "" | None -> "", `White - | Some request_id -> + | "" -> "", `White + | request_id -> (* The last byte of the request id is basically always going to be a digit, growing incrementally, so we can use the parity of its ASCII code to stripe the requests in the log. *) @@ -318,10 +315,7 @@ let sub_log ?level:level_ name = match request with | None -> Logs.Tag.empty | Some request -> - match get_request_id ~request () with - | None -> Logs.Tag.empty - | Some request_id -> - Logs.Tag.add logs_lib_tag request_id Logs.Tag.empty + Logs.Tag.add logs_lib_tag (get_request_id ~request ()) Logs.Tag.empty in log ~tags format_and_arguments)) in @@ -450,17 +444,6 @@ struct set_printexc := false end; - (* Get the requwst's id or assign a new one. *) - let id = - match Message.field request id_field with - | Some id -> id - | None -> - last_id := !last_id + 1; - let id = string_of_int !last_id in - Message.set_field request id_field id; - id - in - (* Identify the request in the log. *) let user_agent = Message.headers request "User-Agent" @@ -475,7 +458,7 @@ struct user_agent); (* Call the rest of the app. *) - match Lwt.with_value id_lwt_key (Some id) (fun () -> next_handler request) with + match next_handler request with | response -> (* Log the elapsed time. If the response is a redirection, log the target. *) diff --git a/src/vendor/dune b/src/vendor/dune index ab2f2038..51f8ba70 100644 --- a/src/vendor/dune +++ b/src/vendor/dune @@ -11,15 +11,6 @@ ke ))) -(subdir gluten/lwt - (library - (name dream_gluten_lwt) - (public_name dream-httpaf.dream-gluten-lwt) - (libraries - dream-httpaf.dream-gluten - lwt - ))) - (subdir gluten/eio (library (name dream_gluten_eio) @@ -29,27 +20,6 @@ unix eio bigstringaf ))) -(subdir gluten/lwt-unix - (library - (name dream_gluten_lwt_unix) - (public_name dream-httpaf.dream-gluten-lwt-unix) - (libraries - faraday-lwt-unix - dream-httpaf.dream-gluten-lwt - lwt.unix - (select - ssl_io.ml - from - (lwt_ssl -> ssl_io.real.ml) - (-> ssl_io.dummy.ml)) - (select - tls_io.ml - from - (tls.lwt -> tls_io.real.ml) - (-> tls_io.dummy.ml)) - ) - (modules gluten_lwt_unix tls_io ssl_io))) - (subdir httpaf/lib @@ -62,17 +32,6 @@ faraday ))) -(subdir httpaf/lwt - (library - (name dream_httpaf__lwt) - (public_name dream-httpaf.dream-httpaf_-lwt) - (libraries - dream-httpaf.dream-gluten - dream-httpaf.dream-gluten-lwt - dream-httpaf.dream-httpaf_ - lwt - ))) - (subdir httpaf/eio (library (name dream_httpaf__eio) @@ -85,19 +44,6 @@ ))) -(subdir httpaf/lwt-unix - (library - (name dream_httpaf__lwt_unix) - (public_name dream-httpaf.dream-httpaf_-lwt-unix) - (libraries - faraday-lwt-unix - dream-httpaf.dream-gluten-lwt-unix - dream-httpaf.dream-httpaf_ - dream-httpaf.dream-httpaf_-lwt - lwt.unix - ))) - - (subdir websocketaf/lib (library @@ -113,29 +59,6 @@ result ))) -(subdir websocketaf/lwt - (library - (name dream_websocketaf_lwt) - (public_name dream-httpaf.dream-websocketaf-lwt) - (libraries - base64 - digestif.ocaml - dream-httpaf.dream-gluten-lwt - lwt - dream-httpaf.dream-websocketaf - ))) - -(subdir websocketaf/lwt-unix - (library - (name dream_websocketaf_lwt_unix) - (public_name dream-httpaf.dream-websocketaf-lwt-unix) - (libraries - faraday-lwt-unix - dream-httpaf.dream-gluten-lwt-unix - lwt.unix - dream-httpaf.dream-websocketaf-lwt - ))) - (subdir h2/hpack/util @@ -176,27 +99,15 @@ result ))) -(subdir h2/lwt +(subdir h2/eio (library - (name dream_h2_lwt) - (public_name dream-httpaf.dream-h2-lwt) + (name dream_h2_eio) + (public_name dream-httpaf.dream-h2-eio) (libraries dream-httpaf.dream-gluten - dream-httpaf.dream-gluten-lwt - lwt - dream-httpaf.dream-h2 - ))) - -(subdir h2/lwt-unix - (library - (name dream_h2_lwt_unix) - (public_name dream-httpaf.dream-h2-lwt-unix) - (libraries - faraday-lwt-unix - dream-httpaf.dream-gluten-lwt-unix + dream-httpaf.dream-gluten-eio + eio dream-httpaf.dream-h2 - dream-httpaf.dream-h2-lwt - lwt.unix ))) From 8bd26a8a312edd32cbf2f1546270c874f31d4532 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Sun, 9 Apr 2023 12:00:03 +0200 Subject: [PATCH 27/42] Switch to multipart_form-eio --- src/server/dune | 2 +- src/server/upload.ml | 35 ++++++++++++++++++----------------- 2 files changed, 19 insertions(+), 18 deletions(-) diff --git a/src/server/dune b/src/server/dune index 1e1afc1e..2fafb488 100644 --- a/src/server/dune +++ b/src/server/dune @@ -10,7 +10,7 @@ magic-mime mirage-clock multipart_form - multipart_form-lwt + multipart_form-eio ptime unstrctrd uri diff --git a/src/server/upload.ml b/src/server/upload.ml index 48ad3332..1a755cb4 100644 --- a/src/server/upload.ml +++ b/src/server/upload.ml @@ -19,14 +19,14 @@ type multipart_state = { mutable state_init : bool; mutable name : string option; mutable filename : string option; - mutable stream : (< > * Multipart_form.Header.t * string Lwt_stream.t) Lwt_stream.t; + mutable stream : (< > * Multipart_form.Header.t * string Eio.Stream.t) Eio.Stream.t; } let initial_multipart_state () = { state_init = true; name = None; filename = None; - stream = Lwt_stream.of_list []; + stream = Eio.Stream.create max_int; } (* TODO Dump the value of the multipart state somehow? *) @@ -62,14 +62,15 @@ let log = Log.sub_log "dream.upload" let upload_part (request : Message.request) = let state = multipart_state request in - match Lwt_eio.Promise.await_lwt @@ Lwt_stream.peek state.stream with + match Eio.Stream.take_nonblocking state.stream with | None -> None | Some (_uid, _header, stream) -> - match Lwt_eio.Promise.await_lwt @@ Lwt_stream.get stream with + match Eio.Stream.take_nonblocking stream with | Some _ as v -> v | None -> log.debug (fun m -> m "End of the part.") ; - Lwt_eio.Promise.await_lwt @@ Lwt_stream.junk state.stream; + (* TODO this doesn't look right? *) + Eio.Stream.take state.stream |> ignore; None (* XXX(dinosaure): delete the current part from the [stream]. *) @@ -80,9 +81,10 @@ type part = string option * string option * ((string * string) list) let rec state (request : Message.request) = let state' = multipart_state request in let stream = state'.stream in - match Lwt_eio.Promise.await_lwt @@ Lwt_stream.peek stream with + match Eio.Stream.take_nonblocking stream with | None -> - Lwt_eio.Promise.await_lwt @@ Lwt_stream.junk stream; + (* TODO this doesn't look right? *) + Eio.Stream.take stream |> ignore; None | Some (_, headers, _stream) -> let headers = @@ -117,12 +119,12 @@ and upload (request : Message.request) = failwith message | Some content_type -> - let body = - Lwt_stream.from_direct (fun () -> - Message.read (Message.server_stream request)) in - let `Parse th, stream = - Multipart_form_lwt.stream ~identify body content_type in - let _ = Lwt_eio.Promise.await_lwt th in + let body = Eio.Stream.create 1 in + Eio.Stream.add body (Message.read (Message.server_stream request)); + Eio.Switch.run @@ fun sw -> + let th, stream = + Multipart_form_eio.stream ~sw ~identify body content_type in + let _ = Eio.Promise.await th in state'.stream <- stream; state'.state_init <- false; state request @@ -139,10 +141,9 @@ let multipart ?(csrf=true) ~now request = match content_type with | None -> `Wrong_content_type | Some content_type -> - let body = - Lwt_stream.from_direct (fun () -> - Message.read (Message.server_stream request)) in - match Lwt_eio.Promise.await_lwt @@ Multipart_form_lwt.of_stream_to_list body content_type with + let body = Eio.Stream.create 1 in + Eio.Stream.add body (Message.read (Message.server_stream request)); + match Multipart_form_eio.of_stream_to_list body content_type with | Error (`Msg _err) -> `Wrong_content_type (* XXX(dinosaure): better error? *) | Ok (tree, assoc) -> From 531bb378774f3bf537390b49c8ba6b80c07461b9 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Sun, 9 Apr 2023 12:11:19 +0200 Subject: [PATCH 28/42] Switch to mirage_crypto_rng_eio Random.initialize isn't called any more. I think its unnecessary as any crypto calls will fail explicitly (due to performing an effect without a handler). I did not remove it as I'm not that familiar with mirage and didn't want to silently break crypto --- src/dream.ml | 5 ++--- src/dune | 4 +--- src/graphql/dune | 1 + src/server/dune | 1 - src/sql/dune | 1 + 5 files changed, 5 insertions(+), 7 deletions(-) diff --git a/src/dream.ml b/src/dream.ml index c186a326..33525ca6 100644 --- a/src/dream.ml +++ b/src/dream.ml @@ -53,9 +53,8 @@ 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)) +let mirage_crypto_run env = + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env module Session = struct diff --git a/src/dune b/src/dune index a82c981c..aecab597 100644 --- a/src/dune +++ b/src/dune @@ -14,8 +14,6 @@ fmt.tty graphql-lwt logs - lwt - lwt.unix - mirage-crypto-rng-lwt ptime.clock.os + mirage-crypto-rng-eio )) diff --git a/src/graphql/dune b/src/graphql/dune index f21f3cff..251a1fb1 100644 --- a/src/graphql/dune +++ b/src/graphql/dune @@ -7,6 +7,7 @@ dream.server graphql_parser graphql-lwt + lwt_eio str yojson ) diff --git a/src/server/dune b/src/server/dune index 2fafb488..90c7784f 100644 --- a/src/server/dune +++ b/src/server/dune @@ -15,7 +15,6 @@ unstrctrd uri yojson - lwt_eio ) (instrumentation (backend bisect_ppx))) diff --git a/src/sql/dune b/src/sql/dune index faeaef3c..6206b9fe 100644 --- a/src/sql/dune +++ b/src/sql/dune @@ -4,6 +4,7 @@ (libraries caqti caqti-lwt + lwt_eio dream.cipher dream-pure dream.server From b528ea4019466d14ec624479274b83cece919323 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Mon, 10 Apr 2023 21:26:17 +0200 Subject: [PATCH 29/42] Add Random.run to replace Random.initialize --- src/cipher/dune | 1 + src/cipher/random.ml | 11 ++--------- src/dream.ml | 3 --- src/dream.mli | 2 +- src/dune | 1 - src/http/http.ml | 2 ++ 6 files changed, 6 insertions(+), 14 deletions(-) diff --git a/src/cipher/dune b/src/cipher/dune index cc369878..7ff4764c 100644 --- a/src/cipher/dune +++ b/src/cipher/dune @@ -6,5 +6,6 @@ dream-pure mirage-crypto mirage-crypto-rng + mirage-crypto-rng-eio ) (instrumentation (backend bisect_ppx))) diff --git a/src/cipher/random.ml b/src/cipher/random.ml index 7d104e7a..357a01e2 100644 --- a/src/cipher/random.ml +++ b/src/cipher/random.ml @@ -8,17 +8,10 @@ (* 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 run env f = + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env 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 33525ca6..994ea86d 100644 --- a/src/dream.ml +++ b/src/dream.ml @@ -53,9 +53,6 @@ let () = let now () = Ptime.to_float_s (Ptime.v (Ptime_clock.now_d_ps ())) -let mirage_crypto_run env = - Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env - module Session = struct include Dream__server.Session diff --git a/src/dream.mli b/src/dream.mli index 551c54ce..fd7cee84 100644 --- a/src/dream.mli +++ b/src/dream.mli @@ -2201,7 +2201,7 @@ val run : ?builtins:bool -> ?greeting:bool -> ?adjust_terminal:bool -> - < clock:#Eio.Time.clock; net:#Eio.Net.t; ..> -> + < clock:Eio.Time.clock; net:#Eio.Net.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}. diff --git a/src/dune b/src/dune index aecab597..6dccbb7b 100644 --- a/src/dune +++ b/src/dune @@ -15,5 +15,4 @@ graphql-lwt logs ptime.clock.os - mirage-crypto-rng-eio )) diff --git a/src/http/http.ml b/src/http/http.ml index 74e790fa..fe6858bc 100644 --- a/src/http/http.ml +++ b/src/http/http.ml @@ -19,6 +19,7 @@ module Helpers = Dream__server.Helpers module Log = Dream__server.Log module Message = Dream_pure.Message module Method = Dream_pure.Method +module Random = Dream__cipher.Random module Status = Dream_pure.Status module Stream = Dream_pure.Stream @@ -687,6 +688,7 @@ let run ?(adjust_terminal = true) env user's_dream_handler = + Random.run env @@ fun () -> let () = if Sys.unix then Sys.(set_signal sigpipe Signal_ignore) From 1f7f9b95645c398389dba7ccff49716c55c29e8b Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Mon, 10 Apr 2023 21:26:52 +0200 Subject: [PATCH 30/42] Add mock for g-upload --- test/mock/g-upload/README.md | 129 +++++++++++++++++++++++++++++++ test/mock/g-upload/dune | 10 +++ test/mock/g-upload/dune-project | 1 + test/mock/g-upload/esy.json | 18 +++++ test/mock/g-upload/upload.eml.ml | 41 ++++++++++ 5 files changed, 199 insertions(+) create mode 100644 test/mock/g-upload/README.md create mode 100644 test/mock/g-upload/dune create mode 100644 test/mock/g-upload/dune-project create mode 100644 test/mock/g-upload/esy.json create mode 100644 test/mock/g-upload/upload.eml.ml diff --git a/test/mock/g-upload/README.md b/test/mock/g-upload/README.md new file mode 100644 index 00000000..ede8c0d7 --- /dev/null +++ b/test/mock/g-upload/README.md @@ -0,0 +1,129 @@ +# `g-upload` + +
+ +This example shows an upload form at +[http://localhost:8080](http://localhost:8080), which allows sending multiple +files. When they are sent, the example responds with a page listing their file +sizes: + +```ocaml +let home request = + + + + <%s! Dream.csrf_tag request %> + + + + + + +let report files = + + +% files |> List.iter begin fun (name, content) -> +% let name = +% match name with +% | None -> "None" +% | Some name -> name +% in +

<%s name %>, <%i String.length content %> bytes

+% end; + + + +let () = + Dream.run + @@ Dream.logger + @@ Dream.memory_sessions + @@ Dream.router [ + + Dream.get "/" (fun request -> + Dream.html (home request)); + + Dream.post "/" (fun request -> + match%lwt Dream.multipart request with + | `Ok ["files", files] -> Dream.html (report files) + | _ -> Dream.empty `Bad_Request); + + ] +``` + +
$ cd example/g-upload
+$ npm install esy && npx esy
+$ npx esy start
+ +
+ +The page shown after uploading looks like this +[[playground](http://dream.as/g-upload)]: + +``` +foo.png, 663959 bytes +bar.png, 1807 bytes +``` + +
+ +This example uses +[`Dream.multipart`](https://aantron.github.io/dream/#val-multipart) (named +after `Content-Type: multipart/form-data`). +[`Dream.multipart`](https://aantron.github.io/dream/#val-multipart) receives +entire files into strings. Size limits will be added in one of the early alphas. +However, this is only good for rare, small uploads, such as user avatars, or for +prototyping. + +For more heavy usage, see +[`Dream.upload`](https://aantron.github.io/dream/#type-upload_event) for +streaming file uploads. + +
+ +## Security + +[`Dream.multipart`](https://aantron.github.io/dream/#val-multipart) behaves just +like [`Dream.form`](https://aantron.github.io/dream/#val-form) when it comes to +[CSRF protection](https://cheatsheetseries.owasp.org/cheatsheets/Cross-Site_Request_Forgery_Prevention_Cheat_Sheet.html). +See example [**`d-form`**](../d-form#files). We use +[`Dream.csrf_tag`](https://aantron.github.io/dream/#val-csrf_tag) to generate +the CSRF token in the template, and pass the `enctype="multipart/form-data"` +attribute as needed for forms to upload files. The template output looks like +this: + +```html +
+ + + + + +
+``` + +See [OWASP File Upload Cheat +Sheet](https://cheatsheetseries.owasp.org/cheatsheets/File_Upload_Cheat_Sheet.html) +for a checklist of additional security precautions. + +
+
+ +**Next steps:** + +- [**`h-sql`**](../h-sql#files) runs SQL queries against a database. +- [**`i-graphql`**](../i-graphql#files) handles GraphQL queries and serves + GraphiQL. + +
+ +**See also:** + +- [**`w-upload-stream`**](../w-upload-stream#files) shows the streaming + interface for receiving file uploads. +- [**`w-multipart-dump`**](../w-multipart-dump#files) shows the request body + that is interpreted by + [`Dream.multipart`](https://aantron.github.io/dream/#val-multipart). + +
+ +[Up to the tutorial index](../#readme) diff --git a/test/mock/g-upload/dune b/test/mock/g-upload/dune new file mode 100644 index 00000000..7341933b --- /dev/null +++ b/test/mock/g-upload/dune @@ -0,0 +1,10 @@ +(test + (name upload) + (libraries dream)) + +(rule + (targets upload.ml) + (deps upload.eml.ml) + (action (run dream_eml %{deps} --workspace %{workspace_root}))) + +(data_only_dirs _esy esy.lock lib node_modules) diff --git a/test/mock/g-upload/dune-project b/test/mock/g-upload/dune-project new file mode 100644 index 00000000..929c696e --- /dev/null +++ b/test/mock/g-upload/dune-project @@ -0,0 +1 @@ +(lang dune 2.0) diff --git a/test/mock/g-upload/esy.json b/test/mock/g-upload/esy.json new file mode 100644 index 00000000..fb5ecc06 --- /dev/null +++ b/test/mock/g-upload/esy.json @@ -0,0 +1,18 @@ +{ + "dependencies": { + "@opam/conf-libssl": "3", + "@opam/dream": "1.0.0~alpha4", + "@opam/dune": "^2.0", + "ocaml": "4.12.x" + }, + "devDependencies": { + "@opam/ocaml-lsp-server": "*" + }, + "resolutions": { + "@opam/conf-libev": "esy-packages/libev:package.json#0b5eb6685b688649045aceac55dc559f6f21b829", + "esy-openssl": "esy-packages/esy-openssl#619ae2d46ca981ec26ab3287487ad98b157a01d1" + }, + "scripts": { + "start": "dune exec --root . ./upload.exe" + } +} diff --git a/test/mock/g-upload/upload.eml.ml b/test/mock/g-upload/upload.eml.ml new file mode 100644 index 00000000..c2b80cef --- /dev/null +++ b/test/mock/g-upload/upload.eml.ml @@ -0,0 +1,41 @@ +let home request = + + +
+ <%s! Dream.csrf_tag request %> + + +
+ + + +let report files = + + +% files |> List.iter begin fun (name, content) -> +% let name = +% match name with +% | None -> "None" +% | Some name -> name +% in +

<%s name %>, <%i String.length content %> bytes

+% end; + + + +let () = + Eio_main.run @@ fun env -> + Dream.run env + @@ Dream.logger + @@ Dream.memory_sessions + @@ Dream.router [ + + Dream.get "/" (fun request -> + Dream.html (home request)); + + Dream.post "/" (fun request -> + match Dream.multipart request with + | `Ok ["files", files] -> Dream.html (report files) + | _ -> Dream.empty `Bad_Request); + + ] From 334311e3b5f658899491bea8f657b804d4eb51bb Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Mon, 10 Apr 2023 23:38:01 +0200 Subject: [PATCH 31/42] Mock upload gets stuck --- test/mock/g-upload/dune | 2 +- test/mock/g-upload/upload.eml.ml | 54 ++++++++++++++++++++++++-------- 2 files changed, 42 insertions(+), 14 deletions(-) diff --git a/test/mock/g-upload/dune b/test/mock/g-upload/dune index 7341933b..70bf4b49 100644 --- a/test/mock/g-upload/dune +++ b/test/mock/g-upload/dune @@ -1,6 +1,6 @@ (test (name upload) - (libraries dream)) + (libraries dream dream.http eio eio.mock bigstringaf)) (rule (targets upload.ml) diff --git a/test/mock/g-upload/upload.eml.ml b/test/mock/g-upload/upload.eml.ml index c2b80cef..9673c628 100644 --- a/test/mock/g-upload/upload.eml.ml +++ b/test/mock/g-upload/upload.eml.ml @@ -1,3 +1,15 @@ +let post = + "POST / HTTP/1.1\r\n\ +Host: http://localhost:8080\r\n\ +User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:109.0) Gecko/20100101 Firefox/110.0\r\n\ +Accept: text/html,application/xhtml+xml,application/xml;q=0.9,image/avif,image/webp,*/*;q=0.8\r\n\ +Accept-Language: en,de;q=0.5\r\n\ +Accept-Encoding: gzip, deflate, br\r\n\ +Content-Type: multipart/form-data; boundary=---------------------------625375598897756021854574453\r\n\ +Content-Length: 49912627\r\n\ +\r\n\ +" + let home request = @@ -25,17 +37,33 @@ let report files = let () = Eio_main.run @@ fun env -> - Dream.run env - @@ Dream.logger - @@ Dream.memory_sessions - @@ Dream.router [ - - Dream.get "/" (fun request -> - Dream.html (home request)); - - Dream.post "/" (fun request -> - match Dream.multipart request with - | `Ok ["files", files] -> Dream.html (report files) - | _ -> Dream.empty `Bad_Request); + let net = Eio_mock.Net.make "Mocked network" in + let socket = Eio_mock.Net.listening_socket "Mocked socket" in + let flow = Eio_mock.Flow.make "Mocked flow" in + Eio_mock.Flow.on_read flow [ + `Return post; + `Return post; + `Return post; + ]; - ] + let unresolved, _ = Eio.Promise.create () in + let sockaddr_stream : Eio.Net.Sockaddr.stream = `Tcp (Eio.Net.Ipaddr.V4.loopback, 8080) in + Eio_mock.Handler.seq socket#on_accept [ + `Return (flow, sockaddr_stream); + (* No further connections are coming in but the socket is still open *) + `Await unresolved; + ]; + Eio_mock.Net.on_listen net [`Return socket]; + let env_mocked = object + method clock = env#clock + method secure_random = env#secure_random + method net = net + end in + let module Http = Dream__http.Http in + Eio.traceln "Running"; + Dream.serve ~net ~builtins:false + @@ fun request -> + Eio.traceln "Starting read"; + Dream_pure.Message.read (Dream_pure.Message.server_stream request) |> ignore; + Eio.traceln "Ending read"; + failwith "Success" From 0b53d91f756973daae97d51af26a4d527907188a Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Wed, 12 Apr 2023 19:07:13 +0200 Subject: [PATCH 32/42] Remove superfluous switch --- src/http/http.ml | 18 ++++++++---------- src/server/helpers.ml | 2 +- src/server/upload.ml | 4 ++-- 3 files changed, 11 insertions(+), 13 deletions(-) diff --git a/src/http/http.ml b/src/http/http.ml index fe6858bc..53b214a6 100644 --- a/src/http/http.ml +++ b/src/http/http.ml @@ -59,7 +59,7 @@ let websocket_log = that ordinarily shouldn't be relied on by the user - this is just our last chance to tell the user that something is wrong with their app. *) (* TODO Rename conn like in the body branch. *) -let wrap_handler ~sw +let wrap_handler tls (user's_error_handler : Catch.error_handler) (user's_dream_handler : Message.handler) = @@ -100,7 +100,7 @@ let wrap_handler ~sw Stream.stream body Stream.no_writer in let request : Message.request = - Helpers.request ~sw ~client ~method_ ~target ~tls ~headers body in + Helpers.request ~client ~method_ ~target ~tls ~headers 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 @@ -180,7 +180,7 @@ let wrap_handler ~sw (* TODO Factor out what is in common between the http/af and h2 handlers. *) -let wrap_handler_h2 ~sw +let wrap_handler_h2 tls (_user's_error_handler : Catch.error_handler) (user's_dream_handler : Message.handler) = @@ -215,7 +215,7 @@ let wrap_handler_h2 ~sw Stream.stream body Stream.no_writer in let request : Message.request = - Helpers.request ~sw ~client ~method_ ~target ~tls ~headers body in + Helpers.request ~client ~method_ ~target ~tls ~headers 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 @@ -278,7 +278,6 @@ type tls_library = { key_file:string -> handler:Message.handler -> error_handler:Catch.error_handler -> - sw:Switch.t -> Eio.Net.Sockaddr.stream -> Eio.Flow.two_way -> unit; @@ -289,12 +288,11 @@ let no_tls = { ~certificate_file:_ ~key_file:_ ~handler ~error_handler - ~sw sockaddr fd -> Httpaf_eio.Server.create_connection_handler ?config:None - ~request_handler:(wrap_handler ~sw false error_handler handler) + ~request_handler:(wrap_handler false error_handler handler) ~error_handler:(Error_handler.httpaf error_handler) sockaddr fd @@ -454,9 +452,9 @@ 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. *) - let httpaf_connection_handler ~sw flow client_address = + let httpaf_connection_handler flow client_address = try - httpaf_connection_handler ~sw client_address flow + httpaf_connection_handler client_address flow with exn -> tls_error_handler client_address exn in @@ -481,7 +479,7 @@ let serve_with_details ~backlog in while true do - Eio.Net.accept_fork ~sw socket (httpaf_connection_handler ~sw) + Eio.Net.accept_fork ~sw socket httpaf_connection_handler ~on_error:(fun ex -> raise ex) done diff --git a/src/server/helpers.ml b/src/server/helpers.ml index 6cccc6ad..0b314f5c 100644 --- a/src/server/helpers.ml +++ b/src/server/helpers.ml @@ -53,7 +53,7 @@ let switch_field = ~show_value:(Fmt.to_to_string Switch.dump) () -let request ~sw ~client ~method_ ~target ~tls ~headers server_stream = +let request ~client ~method_ ~target ~tls ~headers server_stream = let request = Message.request ~method_ ~target ~headers Stream.null server_stream in set_client request client; diff --git a/src/server/upload.ml b/src/server/upload.ml index 1a755cb4..16d13d1f 100644 --- a/src/server/upload.ml +++ b/src/server/upload.ml @@ -120,7 +120,7 @@ and upload (request : Message.request) = | Some content_type -> let body = Eio.Stream.create 1 in - Eio.Stream.add body (Message.read (Message.server_stream request)); + Eio.Stream.add body (Message.read (Message.server_stream request) |> Option.get); Eio.Switch.run @@ fun sw -> let th, stream = Multipart_form_eio.stream ~sw ~identify body content_type in @@ -142,7 +142,7 @@ let multipart ?(csrf=true) ~now request = | None -> `Wrong_content_type | Some content_type -> let body = Eio.Stream.create 1 in - Eio.Stream.add body (Message.read (Message.server_stream request)); + Eio.Stream.add body (Message.read (Message.server_stream request) |> Option.get); match Multipart_form_eio.of_stream_to_list body content_type with | Error (`Msg _err) -> `Wrong_content_type (* XXX(dinosaure): better error? *) From 4c3c38779fceecec088ad9729dcc9d70d36a7ede Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Wed, 19 Apr 2023 23:33:48 +0200 Subject: [PATCH 33/42] Replace await_lwt with run_lwt where applicable --- example/h-sql/sql.eml.ml | 8 ++++---- example/w-postgres/postgres.eml.ml | 8 ++++---- .../server_sent_events.eml.ml | 2 +- example/z-playground/server/playground.ml | 18 ++++++++--------- src/graphql/graphql.ml | 4 ++-- src/http/shared/websocket.ml | 2 +- src/sql/session.ml | 20 +++++++++---------- src/sql/sql.ml | 4 ++-- 8 files changed, 33 insertions(+), 33 deletions(-) diff --git a/example/h-sql/sql.eml.ml b/example/h-sql/sql.eml.ml index 5abec84e..1d391cd9 100644 --- a/example/h-sql/sql.eml.ml +++ b/example/h-sql/sql.eml.ml @@ -7,8 +7,8 @@ let list_comments = (T.unit ->* T.(tup2 int string)) "SELECT id, text FROM comment" in fun (module Db : DB) -> - let comments_or_error = Lwt_eio.Promise.await_lwt @@ Db.collect_list query () in - Lwt_eio.Promise.await_lwt @@ Caqti_lwt.or_fail comments_or_error + let comments_or_error = Lwt_eio.run_lwt @@ fun () -> Db.collect_list query () in + Lwt_eio.run_lwt @@ fun () -> Caqti_lwt.or_fail comments_or_error let add_comment = let query = @@ -16,8 +16,8 @@ let add_comment = (T.string ->. T.unit) "INSERT INTO comment (text) VALUES ($1)" in fun text (module Db : DB) -> - let unit_or_error = Lwt_eio.Promise.await_lwt @@ Db.exec query text in - Lwt_eio.Promise.await_lwt @@ Caqti_lwt.or_fail unit_or_error + let unit_or_error = Lwt_eio.run_lwt @@ fun () -> Db.exec query text in + Lwt_eio.run_lwt @@ fun () -> Caqti_lwt.or_fail unit_or_error let render comments request = diff --git a/example/w-postgres/postgres.eml.ml b/example/w-postgres/postgres.eml.ml index e7a3a558..376bef0e 100644 --- a/example/w-postgres/postgres.eml.ml +++ b/example/w-postgres/postgres.eml.ml @@ -8,9 +8,9 @@ let list_comments = (T.unit ->* T.(tup2 int string)) "SELECT id, text FROM comment" in fun (module Db : DB) -> - Lwt_eio.Promise.await_lwt ( + Lwt_eio.run_lwt @@ fun () -> let%lwt comments_or_error = Db.collect_list query () in - Caqti_lwt.or_fail comments_or_error) + Caqti_lwt.or_fail comments_or_error let add_comment = let query = @@ -18,9 +18,9 @@ let add_comment = (T.string ->. T.unit) "INSERT INTO comment (text) VALUES ($1)" in fun text (module Db : DB) -> - Lwt_eio.Promise.await_lwt ( + Lwt_eio.run_lwt @@ fun () -> let%lwt unit_or_error = Db.exec query text in - Caqti_lwt.or_fail unit_or_error) + Caqti_lwt.or_fail unit_or_error let render comments request = diff --git a/example/w-server-sent-events/server_sent_events.eml.ml b/example/w-server-sent-events/server_sent_events.eml.ml index d5d22047..6b6e8cdf 100644 --- a/example/w-server-sent-events/server_sent_events.eml.ml +++ b/example/w-server-sent-events/server_sent_events.eml.ml @@ -64,7 +64,7 @@ let rec forward_messages stream = let () = Dream.flush stream in forward_messages stream -let forward_messages response = Lwt_eio.Promise.await_lwt (forward_messages response) +let forward_messages response = Lwt_eio.run_lwt @@ fun () -> forward_messages response let () = Eio_main.run @@ fun env -> diff --git a/example/z-playground/server/playground.ml b/example/z-playground/server/playground.ml index 76bf72e3..896f84d7 100644 --- a/example/z-playground/server/playground.ml +++ b/example/z-playground/server/playground.ml @@ -58,7 +58,7 @@ COPY server.exe server.exe |} let exec format = - Printf.ksprintf (fun command -> Lwt_eio.Promise.await_lwt @@ Lwt_process.(exec (shell command))) format + Printf.ksprintf (fun command -> Lwt_eio.run_lwt @@ fun () -> Lwt_process.(exec (shell command))) format let create_sandboxes_directory () = match%lwt Lwt_unix.mkdir sandbox_root 0o755 with @@ -66,7 +66,7 @@ let create_sandboxes_directory () = | exception Unix.(Unix_error (EEXIST, _, _)) -> Lwt.return_unit let exists sandbox = - Lwt_eio.Promise.await_lwt @@ Lwt_unix.file_exists (sandbox_root // sandbox) + Lwt_eio.run_lwt @@ fun () -> Lwt_unix.file_exists (sandbox_root // sandbox) let write_file sandbox file content = Lwt_io.(with_file @@ -103,18 +103,18 @@ let rec create ?(attempts = 3) syntax eml code = let read sandbox = let no_eml_exists = - Lwt_eio.Promise.await_lwt @@ Lwt_unix.file_exists (sandbox_root // sandbox // "no-eml") in + Lwt_eio.run_lwt @@ fun () -> Lwt_unix.file_exists (sandbox_root // sandbox // "no-eml") in let eml = not no_eml_exists in let base = if eml then "server.eml" else "server" in let ocaml_promise = - Lwt_eio.Promise.await_lwt @@ Lwt_io.(with_file + Lwt_eio.run_lwt @@ fun () -> Lwt_io.(with_file ~mode:Input (sandbox_root // sandbox // base ^ ".ml") read) in match ocaml_promise with | content -> content, `OCaml, eml | exception _ -> let content = - Lwt_eio.Promise.await_lwt @@ Lwt_io.(with_file + Lwt_eio.run_lwt @@ fun () -> Lwt_io.(with_file ~mode:Input (sandbox_root // sandbox // base ^ ".re") read) in content, `Reason, eml @@ -340,7 +340,7 @@ let lock_sandbox sandbox f = decr sandbox_users; if !sandbox_users = 0 then !notify_gc ()) - (fun () -> Lwt_eio.Promise.await_lwt @@ Lwt_mutex.with_lock mutex f) + (fun () -> Lwt_eio.run_lwt @@ fun () -> Lwt_mutex.with_lock mutex f) let rec listen session = match Dream.receive session.socket with @@ -457,8 +457,8 @@ let rec gc ?(initial = true) () = () else begin let _, syntax, eml = read sandbox in - let _ = Lwt_eio.Promise.await_lwt @@ build_sandbox sandbox syntax eml in - Lwt_eio.Promise.await_lwt @@ image_sandbox sandbox + let _ = Lwt_eio.run_lwt @@ fun () -> build_sandbox sandbox syntax eml in + Lwt_eio.run_lwt @@ fun () -> image_sandbox sandbox end; Lwt.return_unit); Lwt.return_unit @@ -505,7 +505,7 @@ let () = let example = match sandbox.[1] with | '-' -> - if Lwt_eio.Promise.await_lwt @@ Lwt_unix.file_exists (sandbox_root // sandbox // "keep") then + if Lwt_eio.run_lwt @@ fun () -> Lwt_unix.file_exists (sandbox_root // sandbox // "keep") then Some sandbox else None diff --git a/src/graphql/graphql.ml b/src/graphql/graphql.ml index 0d86383c..97118b97 100644 --- a/src/graphql/graphql.ml +++ b/src/graphql/graphql.ml @@ -68,7 +68,7 @@ let run_query make_context schema request json = let context = make_context request in - Lwt_eio.Promise.await_lwt @@ Graphql_lwt.Schema.execute + Lwt_eio.run_lwt @@ fun () -> Graphql_lwt.Schema.execute ?variables ?operation_name schema context query @@ -211,7 +211,7 @@ let handle_over_websocket make_context schema subscriptions request websocket = Hashtbl.replace subscriptions id close; subscribed := true; - Lwt_eio.Promise.await_lwt (stream |> Lwt_stream.iter (function + Lwt_eio.run_lwt (fun () -> stream |> Lwt_stream.iter (function | Ok json -> Helpers.send websocket (data_message id json) | Error json -> diff --git a/src/http/shared/websocket.ml b/src/http/shared/websocket.ml index 93e85586..f43ad117 100644 --- a/src/http/shared/websocket.ml +++ b/src/http/shared/websocket.ml @@ -100,7 +100,7 @@ let websocket_handler stream socket = else match !current_payload with | None -> - begin match Lwt_eio.Promise.await_lwt (Lwt_stream.get frames) with + begin match Lwt_eio.run_lwt @@ fun () -> Lwt_stream.get frames with | None -> if not !closed then begin closed := true; diff --git a/src/sql/session.ml b/src/sql/session.ml index 5562173e..fbe118ea 100644 --- a/src/sql/session.ml +++ b/src/sql/session.ml @@ -36,9 +36,9 @@ let insert = fun (module Db : DB) (session : Session.session) -> let payload = serialize_payload session.payload in let result = - Lwt_eio.Promise.await_lwt @@ + Lwt_eio.run_lwt @@ fun () -> Db.exec query (session.id, session.label, session.expires_at, payload) in - Lwt_eio.Promise.await_lwt @@ Caqti_lwt.or_fail result + Lwt_eio.run_lwt @@ fun () -> Caqti_lwt.or_fail result let find_opt = let query = @@ -47,8 +47,8 @@ let find_opt = "SELECT label, expires_at, payload FROM dream_session WHERE id = $1" in fun (module Db : DB) id -> - let result = Lwt_eio.Promise.await_lwt @@ Db.find_opt query id in - match Lwt_eio.Promise.await_lwt @@ Caqti_lwt.or_fail result with + let result = Lwt_eio.run_lwt @@ fun () -> Db.find_opt query id in + match Lwt_eio.run_lwt @@ fun () -> Caqti_lwt.or_fail result with | None -> None | Some (label, expires_at, payload) -> (* TODO Mind exceptions! *) @@ -75,8 +75,8 @@ let refresh = "UPDATE dream_session SET expires_at = $1 WHERE id = $2" in fun (module Db : DB) (session : Session.session) -> - let result = Lwt_eio.Promise.await_lwt @@ Db.exec query (session.expires_at, session.id) in - Lwt_eio.Promise.await_lwt @@ Caqti_lwt.or_fail result + let result = Lwt_eio.run_lwt @@ fun () -> Db.exec query (session.expires_at, session.id) in + Lwt_eio.run_lwt @@ fun () -> Caqti_lwt.or_fail result let update = let query = @@ -86,8 +86,8 @@ let update = fun (module Db : DB) (session : Session.session) -> let payload = serialize_payload session.payload in - let result = Lwt_eio.Promise.await_lwt @@ Db.exec query (payload, session.id) in - Lwt_eio.Promise.await_lwt @@ Caqti_lwt.or_fail result + let result = Lwt_eio.run_lwt @@ fun () -> Db.exec query (payload, session.id) in + Lwt_eio.run_lwt @@ fun () -> Caqti_lwt.or_fail result let remove = let query = @@ -95,8 +95,8 @@ let remove = (T.string ->. T.unit) "DELETE FROM dream_session WHERE id = $1" in fun (module Db : DB) id -> - let result = Lwt_eio.Promise.await_lwt @@ Db.exec query id in - Lwt_eio.Promise.await_lwt @@ Caqti_lwt.or_fail result + let result = Lwt_eio.run_lwt @@ fun () -> Db.exec query id in + Lwt_eio.run_lwt @@ fun () -> Caqti_lwt.or_fail result (* TODO Session sharing is greatly complicated by the backing store; is it ok to just work with snapshots? All kinds of race conditions may be possible, diff --git a/src/sql/sql.ml b/src/sql/sql.ml index 4ed8115a..eb0ca83b 100644 --- a/src/sql/sql.ml +++ b/src/sql/sql.ml @@ -72,12 +72,12 @@ let sql request callback = failwith message | Some pool -> let result = + Lwt_eio.run_lwt @@ fun () -> pool |> Caqti_lwt.Pool.use (fun db -> (* The special exception handling is a workaround for https://github.com/paurkedal/ocaml-caqti/issues/68. *) match callback db with | result -> Lwt.return (Ok result) | exception exn -> raise exn) - |> Lwt_eio.Promise.await_lwt in - Lwt_eio.Promise.await_lwt @@ Caqti_lwt.or_fail result + Lwt_eio.run_lwt @@ fun () -> Caqti_lwt.or_fail result From b98ab6558070796defccc3be14683db5c5b94ebb Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Thu, 20 Apr 2023 00:06:07 +0200 Subject: [PATCH 34/42] Incorporate other feedback --- example/r-template-stream/template_stream.eml.re | 2 +- example/w-chat/chat.eml.ml | 5 ++--- src/dream.ml | 7 +------ src/dream.mli | 2 ++ src/http/http.ml | 11 +++++++---- 5 files changed, 13 insertions(+), 14 deletions(-) diff --git a/example/r-template-stream/template_stream.eml.re b/example/r-template-stream/template_stream.eml.re index 83f10e33..b37a25d6 100644 --- a/example/r-template-stream/template_stream.eml.re +++ b/example/r-template-stream/template_stream.eml.re @@ -1,4 +1,4 @@ -let render = clock => response => { +let render = response => { %% response diff --git a/example/w-chat/chat.eml.ml b/example/w-chat/chat.eml.ml index 8e21662e..34fa1645 100644 --- a/example/w-chat/chat.eml.ml +++ b/example/w-chat/chat.eml.ml @@ -49,9 +49,8 @@ let send message = Switch.run @@ fun sw -> Hashtbl.to_seq_values clients |> List.of_seq - |> List.iter (fun client -> - Fiber.fork ~sw (fun () -> Dream.send client message) - ) + |> Fiber.List.iter (fun client -> + Dream.send client message) let handle_client client = let client_id = track client in diff --git a/src/dream.ml b/src/dream.ml index 994ea86d..15dd6c0f 100644 --- a/src/dream.ml +++ b/src/dream.ml @@ -385,12 +385,7 @@ let test ?(prefix = "") handler request = Site_prefix.with_site_prefix prefix @@ handler in - - let result = ref None in - Eio_main.run (fun _env -> - result := Some (app request) - ); - Option.get !result + Eio_main.run (fun _env -> app request) let sort_headers = Message.sort_headers let echo = Echo.echo diff --git a/src/dream.mli b/src/dream.mli index fd7cee84..5cbc9f2a 100644 --- a/src/dream.mli +++ b/src/dream.mli @@ -2193,6 +2193,7 @@ val catch : (error -> response) -> middleware val run : ?interface:string -> ?port:int -> + ?stop:unit Eio.Promise.t -> ?error_handler:error_handler -> ?backlog:int -> ?tls:bool -> @@ -2249,6 +2250,7 @@ val run : val serve : ?interface:string -> ?port:int -> + ?stop:unit Eio.Promise.t -> ?error_handler:error_handler -> ?backlog:int -> ?tls:bool -> diff --git a/src/http/http.ml b/src/http/http.ml index 53b214a6..f55a2033 100644 --- a/src/http/http.ml +++ b/src/http/http.ml @@ -408,6 +408,7 @@ let serve_with_details ~net ~interface ~port + ?stop ~error_handler ~backlog ~certificate_file @@ -478,10 +479,7 @@ let serve_with_details ~reuse_addr:true ~backlog in - while true do - Eio.Net.accept_fork ~sw socket httpaf_connection_handler - ~on_error:(fun ex -> raise ex) - done + Eio.Net.run_server ?stop socket httpaf_connection_handler ~on_error:raise @@ -492,6 +490,7 @@ let serve_with_maybe_https caller_function_for_error_messages ~interface ~port + ?stop ~error_handler ~backlog ~tls @@ -520,6 +519,7 @@ let serve_with_maybe_https ~net ~interface ~port + ?stop ~error_handler ~backlog ~certificate_file:"" @@ -646,6 +646,7 @@ let default_port = 8080 let serve ?(interface = default_interface) ?(port = default_port) + ?stop ?(error_handler = Error_handler.default) ?(backlog = 10) ?(tls = false) @@ -660,6 +661,7 @@ let serve ~net ~interface ~port + ?stop ~error_handler ~backlog (* ~tls:(if tls then `OpenSSL else `No) *) @@ -676,6 +678,7 @@ let serve let run ?(interface = default_interface) ?(port = default_port) + ?stop ?(error_handler = Error_handler.default) ?(backlog = 10) ?(tls = false) From 306a49a7c58806296d6ff4129cbe3fb39721eef0 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Thu, 20 Apr 2023 00:06:19 +0200 Subject: [PATCH 35/42] Remove loader from static --- src/dream.mli | 1 - src/unix/static.ml | 4 ++-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/dream.mli b/src/dream.mli index 5cbc9f2a..55ddcef7 100644 --- a/src/dream.mli +++ b/src/dream.mli @@ -1544,7 +1544,6 @@ val no_route : route (** {1 Static files} *) val static : - ?loader:('a Eio.Path.t -> string -> handler) -> 'a Eio.Path.t -> handler (** Serves static files from a local directory. See example {{:https://github.com/aantron/dream/tree/master/example/f-static#files} diff --git a/src/unix/static.ml b/src/unix/static.ml index 5b6aa1bf..faa6367e 100644 --- a/src/unix/static.ml +++ b/src/unix/static.ml @@ -66,7 +66,7 @@ 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 @@ -77,7 +77,7 @@ let static ?(loader = from_filesystem) local_root = fun request -> Message.response ~status:`Not_Found Stream.empty Stream.null | Some path -> - let response = loader local_root path request in + 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 From 83a6137d6a2dc805c680c1e6847a9d30681f1e7f Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Thu, 20 Apr 2023 00:14:04 +0200 Subject: [PATCH 36/42] Fix forgotten example --- example/r-template-stream/dune | 3 +- .../r-template-stream/template_stream.eml.re | 29 +++++-------------- 2 files changed, 9 insertions(+), 23 deletions(-) diff --git a/example/r-template-stream/dune b/example/r-template-stream/dune index c2635dd9..b66f4af2 100644 --- a/example/r-template-stream/dune +++ b/example/r-template-stream/dune @@ -1,7 +1,6 @@ (executable (name template_stream) - (libraries dream) - (preprocess (pps lwt_ppx))) + (libraries dream)) (rule (targets template_stream.re) diff --git a/example/r-template-stream/template_stream.eml.re b/example/r-template-stream/template_stream.eml.re index b37a25d6..5bc1baec 100644 --- a/example/r-template-stream/template_stream.eml.re +++ b/example/r-template-stream/template_stream.eml.re @@ -3,26 +3,13 @@ let render = response => { -% let rec paragraphs = index => { -

<%i index %>

-% let%lwt () = Dream.flush(response); -% let%lwt () = Lwt_unix.sleep(1.); -% paragraphs(index + 1); -% }; -% let%lwt () = paragraphs(0); -# let render = response => { -# let () = { -# %% response -# -# - -# % let rec paragraphs = index => { -#

<%i index %>

-# % Dream.flush(response); -# % Eio_unix.sleep(1.); -# % if (index < 10) paragraphs(index + 1); -# % }; -# % paragraphs(0); +% let rec paragraphs = index => { +

<%i index %>

+% Dream.flush(response); +% Eio_unix.sleep(1.); +% if (index < 10) paragraphs(index + 1); +% }; +% paragraphs(0); @@ -32,4 +19,4 @@ let () = Eio_main.run @@ env => Dream.run(env) @@ Dream.logger - @@ request => Dream.stream(~headers=[("Content-Type", Dream.text_html)], request, render); + @@ _ => Dream.stream(~headers=[("Content-Type", Dream.text_html)], render); From b625e7228b5c266bfb15e227347a5b917a76f566 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Thu, 20 Apr 2023 14:42:05 +0200 Subject: [PATCH 37/42] Revert whitespace changes --- src/graphql/graphql.ml | 36 ++++---- src/http/http.ml | 158 ++++++++++++++++++------------------ src/mirage/error_handler.ml | 40 +++++---- 3 files changed, 121 insertions(+), 113 deletions(-) diff --git a/src/graphql/graphql.ml b/src/graphql/graphql.ml index 97118b97..95e035e7 100644 --- a/src/graphql/graphql.ml +++ b/src/graphql/graphql.ml @@ -279,24 +279,24 @@ let graphql make_context schema = fun request -> | `POST -> begin match Message.header request "Content-Type" with | Some "application/json" -> - let body = Message.body request in - (* TODO This almost certainly raises exceptions... *) - let json = Yojson.Basic.from_string body in - - begin match run_query make_context schema request json with - | Error json -> - Yojson.Basic.to_string json - |> Helpers.json - - | Ok (`Response json) -> - Yojson.Basic.to_string json - |> Helpers.json - - | Ok (`Stream _) -> - make_error "Subscriptions and streaming should use WebSocket transport" - |> Yojson.Basic.to_string - |> Helpers.json - end + let body = Message.body request in + (* TODO This almost certainly raises exceptions... *) + let json = Yojson.Basic.from_string body in + + begin match run_query make_context schema request json with + | Error json -> + Yojson.Basic.to_string json + |> Helpers.json + + | Ok (`Response json) -> + Yojson.Basic.to_string json + |> Helpers.json + + | Ok (`Stream _) -> + make_error "Subscriptions and streaming should use WebSocket transport" + |> Yojson.Basic.to_string + |> Helpers.json + end | _ -> log.warning (fun log -> log ~request diff --git a/src/http/http.ml b/src/http/http.ml index f55a2033..37474dc4 100644 --- a/src/http/http.ml +++ b/src/http/http.ml @@ -112,67 +112,69 @@ 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. *) - try - (* Do the big call. *) - let response = user's_dream_handler request in + begin + try + (* Do the big call. *) + let response = user's_dream_handler request in - (* Extract the Dream response's headers. *) + (* Extract the Dream response's headers. *) - (* This is the default function that translates the Dream response to an + (* This is the default function that translates the Dream response to an http/af response and sends it. We pre-define the function, however, because it is called from two places: 1. Upon a normal response, the function is called unconditionally. 2. Upon failure to establish a WebSocket, the function is called to transmit the resulting error response. *) - let forward_response response = - Message.set_content_length_headers response; - - let headers = - Httpaf.Headers.of_list (Message.all_headers response) in + let forward_response response = + Message.set_content_length_headers response; - let status = - to_httpaf_status (Message.status response) in + let headers = + Httpaf.Headers.of_list (Message.all_headers response) in - let httpaf_response = - Httpaf.Response.create ~headers status in - let body = - Httpaf.Reqd.respond_with_streaming conn httpaf_response in + let status = + to_httpaf_status (Message.status response) in - Adapt.forward_body response body - in + let httpaf_response = + Httpaf.Response.create ~headers status in + let body = + Httpaf.Reqd.respond_with_streaming conn httpaf_response in - match Message.get_websocket response with - | None -> - forward_response response - | Some (client_stream, _server_stream) -> - let error_handler = - Error_handler.websocket user's_error_handler request response in - - let proceed () = - Websocketaf.Server_connection.create_websocket - ~error_handler - (Dream_httpaf.Websocket.websocket_handler client_stream) - |> Gluten.make (module Websocketaf.Server_connection) - |> upgrade + Adapt.forward_body response body in - let headers = - Httpaf.Headers.of_list (Message.all_headers response) in - - Websocketaf.Handshake.respond_with_upgrade ~headers ~sha1 conn proceed - |> function - | Ok () -> () - | Error error_string -> - let response = - Error_handler.websocket_handshake - user's_error_handler request response error_string - in + match Message.get_websocket response with + | None -> forward_response response - with exn -> - (* TODO There was something in the fork changelogs about not requiring + | Some (client_stream, _server_stream) -> + let error_handler = + Error_handler.websocket user's_error_handler request response in + + let proceed () = + Websocketaf.Server_connection.create_websocket + ~error_handler + (Dream_httpaf.Websocket.websocket_handler client_stream) + |> Gluten.make (module Websocketaf.Server_connection) + |> upgrade + in + + let headers = + Httpaf.Headers.of_list (Message.all_headers response) in + + Websocketaf.Handshake.respond_with_upgrade ~headers ~sha1 conn proceed + |> function + | Ok () -> () + | Error error_string -> + let response = + Error_handler.websocket_handshake + user's_error_handler request response error_string + in + forward_response response + with exn -> + (* TODO There was something in the fork changelogs about not requiring report exn. Is it relevant to this? *) - Httpaf.Reqd.report_exn conn exn + Httpaf.Reqd.report_exn conn exn + end in httpaf_request_handler @@ -227,40 +229,42 @@ let wrap_handler_h2 customizable here. The handler itself is customizable (to catch all) exceptions, and the error callback that gets leaked exceptions is also customizable. *) - try - (* Do the big call. *) - let response = user's_dream_handler request in - - (* Extract the Dream response's headers. *) - - let forward_response response = - Message.drop_content_length_headers response; - Message.lowercase_headers response; - let headers = - H2.Headers.of_list (Message.all_headers response) in - let status = - to_h2_status (Message.status response) in - let h2_response = - H2.Response.create ~headers status in - let body = - H2.Reqd.respond_with_streaming conn h2_response in - - Adapt.forward_body_h2 response body - in + begin + try + (* Do the big call. *) + let response = user's_dream_handler request in + + (* Extract the Dream response's headers. *) + + let forward_response response = + Message.drop_content_length_headers response; + Message.lowercase_headers response; + let headers = + H2.Headers.of_list (Message.all_headers response) in + let status = + to_h2_status (Message.status response) in + let h2_response = + H2.Response.create ~headers status in + let body = + H2.Reqd.respond_with_streaming conn h2_response in + + Adapt.forward_body_h2 response body + in - match Message.get_websocket response with - | None -> - forward_response response - | Some _ -> - (* TODO DOC H2 appears not to support WebSocket upgrade at present. - RFC 8441. *) - (* TODO DOC Do we need a CONNECT method? Do users need to be informed of - this? *) - () - with exn -> - (* TODO LATER There was something in the fork changelogs about not + match Message.get_websocket response with + | None -> + forward_response response + | Some _ -> + (* TODO DOC H2 appears not to support WebSocket upgrade at present. + RFC 8441. *) + (* TODO DOC Do we need a CONNECT method? Do users need to be informed of + this? *) + () + with exn -> + (* TODO LATER There was something in the fork changelogs about not requiring report_exn. Is it relevant to this? *) - H2.Reqd.report_exn conn exn + H2.Reqd.report_exn conn exn + end in httpaf_request_handler diff --git a/src/mirage/error_handler.ml b/src/mirage/error_handler.ml index a60fe0a5..50896a47 100644 --- a/src/mirage/error_handler.ml +++ b/src/mirage/error_handler.ml @@ -215,26 +215,30 @@ let httpaf user's_error_handler = fun client_address ?request:_ error start_resp will_send_response = true; } in - double_faults begin fun () -> - let response = user's_error_handler error in - let response = match response with - | Some response -> response - | None -> default_response caused_by in - let headers = Httpaf.Headers.of_list (Message.all_headers response) in - let body = start_response headers in - Adapt.forward_body response body - end (fun () -> ()) + begin + double_faults begin fun () -> + let response = user's_error_handler error in + let response = match response with + | Some response -> response + | None -> default_response caused_by in + let headers = Httpaf.Headers.of_list (Message.all_headers response) in + let body = start_response headers in + Adapt.forward_body response body + end (fun () -> ()) + end let respond_with_option f = - double_faults - (fun () -> - match f () with - | Some response -> response - | None -> - Message.response - ~status:`Internal_Server_Error Stream.empty Stream.null) - (fun () -> - Message.response ~status:`Internal_Server_Error Stream.empty Stream.null) + begin + double_faults + (fun () -> + match f () with + | Some response -> response + | None -> + Message.response + ~status:`Internal_Server_Error Stream.empty Stream.null) + (fun () -> + Message.response ~status:`Internal_Server_Error Stream.empty Stream.null) + end let app user's_error_handler = fun error -> respond_with_option (fun () -> user's_error_handler error) From 3bb33d7adbc869eaf89eea1bc3d986c2bf1312f9 Mon Sep 17 00:00:00 2001 From: Anton Bachin Date: Wed, 19 Apr 2023 09:39:43 +0300 Subject: [PATCH 38/42] Remove unnecessary make default target It was picking up Mirage dependencies. The build target has been updated in master so as to be useful in a Dune workspace and in this PR, without picking up extra dependencies. --- Makefile | 4 ---- 1 file changed, 4 deletions(-) diff --git a/Makefile b/Makefile index 5ee05588..3010c0c9 100644 --- a/Makefile +++ b/Makefile @@ -1,10 +1,6 @@ PACKAGES := dream-pure,dream-httpaf,dream .PHONY : build - -default: - @dune build - build : @dune build --only-packages $(PACKAGES) --no-print-directory @install From 8757a12890e9aa69e5879d697fa5d8bc87fa0b35 Mon Sep 17 00:00:00 2001 From: Anton Bachin Date: Fri, 21 Apr 2023 07:01:27 +0300 Subject: [PATCH 39/42] Sync src/vendor/dune with gluten-eio dune --- src/vendor/dune | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/vendor/dune b/src/vendor/dune index 51f8ba70..cdb8c11a 100644 --- a/src/vendor/dune +++ b/src/vendor/dune @@ -17,7 +17,10 @@ (public_name dream-httpaf.dream-gluten-eio) (libraries dream-httpaf.dream-gluten - unix eio bigstringaf + unix + eio + eio.unix + bigstringaf ))) From 42f54bb81fb3e384bbcbb8fb57fa09172fa18133 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Fri, 21 Apr 2023 17:10:05 +0200 Subject: [PATCH 40/42] Make message body a promise again --- src/dream.mli | 2 +- src/graphql/graphql.ml | 2 +- src/pure/message.ml | 15 ++++++++++----- src/pure/message.mli | 2 +- src/pure/stream.ml | 2 +- src/pure/stream.mli | 2 +- src/server/form.ml | 2 +- 7 files changed, 16 insertions(+), 11 deletions(-) diff --git a/src/dream.mli b/src/dream.mli index 55ddcef7..45cebc54 100644 --- a/src/dream.mli +++ b/src/dream.mli @@ -695,7 +695,7 @@ val all_cookies : request -> (string * string) list (** {1 Bodies} *) -val body : 'a message -> string +val body : 'a message -> string Eio.Promise.or_exn (** Retrieves the entire body. See example {{:https://github.com/aantron/dream/tree/master/example/6-echo#files} [6-echo]}. *) diff --git a/src/graphql/graphql.ml b/src/graphql/graphql.ml index 95e035e7..9953df85 100644 --- a/src/graphql/graphql.ml +++ b/src/graphql/graphql.ml @@ -279,7 +279,7 @@ let graphql make_context schema = fun request -> | `POST -> begin match Message.header request "Content-Type" with | Some "application/json" -> - let body = Message.body request in + let body = Eio.Promise.await_exn @@ Message.body request in (* TODO This almost certainly raises exceptions... *) let json = Yojson.Basic.from_string body in diff --git a/src/pure/message.ml b/src/pure/message.ml index 963d6304..8a35bce4 100644 --- a/src/pure/message.ml +++ b/src/pure/message.ml @@ -36,7 +36,7 @@ type 'a message = { mutable headers : (string * string) list; mutable client_stream : Stream.stream; mutable server_stream : Stream.stream; - mutable body : string option; + mutable body : string Eio.Promise.or_exn option; mutable fields : Fields.t; } @@ -198,7 +198,7 @@ let body message = body_promise let set_body message body = - message.body <- Some 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 @@ -213,9 +213,14 @@ let set_content_length_headers message = match message.body with | None -> add_header message "Transfer-Encoding" "chunked" - | Some body -> - let length = string_of_int (String.length body) in - add_header message "Content-Length" length + | Some body_promise -> + match Eio.Promise.peek body_promise with + | None -> + add_header message "Transfer-Encoding" "chunked" + | Some (Error exn) -> raise exn + | Some (Ok body) -> + let length = string_of_int (String.length body) in + add_header message "Content-Length" length let drop_content_length_headers message = drop_header message "Content-Length"; diff --git a/src/pure/message.mli b/src/pure/message.mli index 18db684d..58589b9e 100644 --- a/src/pure/message.mli +++ b/src/pure/message.mli @@ -61,7 +61,7 @@ val lowercase_headers : 'a message -> unit -val body : 'a message -> string +val body : 'a message -> string Eio.Promise.or_exn val set_body : 'a message -> string -> unit val set_content_length_headers : 'a message -> unit val drop_content_length_headers : 'a message -> unit diff --git a/src/pure/stream.ml b/src/pure/stream.ml index abe93617..7b0931d4 100644 --- a/src/pure/stream.ml +++ b/src/pure/stream.ml @@ -466,4 +466,4 @@ let read_until_close stream = in loop (); - Eio.Promise.await_exn promise + promise diff --git a/src/pure/stream.mli b/src/pure/stream.mli index cfcb2230..0d3d6fea 100644 --- a/src/pure/stream.mli +++ b/src/pure/stream.mli @@ -81,7 +81,7 @@ val read_convenience : stream -> string option into [Some s], and [~close] into [None], and uses them to resolve a promise. [~flush] is ignored. *) -val read_until_close : stream -> string +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/form.ml b/src/server/form.ml index fd3d3596..cae4be6c 100644 --- a/src/server/form.ml +++ b/src/server/form.ml @@ -67,7 +67,7 @@ let form ?(csrf = true) ~now request = | Some content_type -> match String.split_on_char ';' content_type with | "application/x-www-form-urlencoded"::_ -> - let body = Message.body request in + let body = Eio.Promise.await_exn @@ 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 From ad543662ec5cc97bb69041afbb83edaedc4dd00c Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Fri, 21 Apr 2023 17:29:49 +0200 Subject: [PATCH 41/42] Fix mirage and echo example --- example/6-echo/echo.ml | 2 +- src/mirage/mirage.mli | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/example/6-echo/echo.ml b/example/6-echo/echo.ml index bfc29ade..3d42c204 100644 --- a/example/6-echo/echo.ml +++ b/example/6-echo/echo.ml @@ -8,6 +8,6 @@ let () = let body = Dream.body request in Dream.respond ~headers:["Content-Type", "application/octet-stream"] - body); + (Eio.Promise.await_exn body)); ] diff --git a/src/mirage/mirage.mli b/src/mirage/mirage.mli index 2c250485..f8e0c716 100644 --- a/src/mirage/mirage.mli +++ b/src/mirage/mirage.mli @@ -727,7 +727,7 @@ module Make (** {1 Bodies} *) - val body : 'a message -> string + val body : 'a message -> string Eio.Promise.or_exn (** Retrieves the entire body. See example {{:https://github.com/aantron/dream/tree/master/example/6-echo#files} [6-echo]}. *) From a9634bc7326e00912408b57bcf2f87daf7d87043 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Fri, 21 Apr 2023 17:40:01 +0200 Subject: [PATCH 42/42] Ignore unused vars --- src/http/http.ml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/http/http.ml b/src/http/http.ml index 37474dc4..a90ecf8d 100644 --- a/src/http/http.ml +++ b/src/http/http.ml @@ -503,6 +503,10 @@ let serve_with_maybe_https ~builtins ~net user's_dream_handler = + ignore certificate_file; + ignore key_file; + ignore certificate_string; + ignore key_string; try (* This check will at least catch secrets like "foo" when used on a public @@ -659,6 +663,7 @@ let serve ?(builtins = true) ~net user's_dream_handler = + ignore tls; serve_with_maybe_https "serve" @@ -763,6 +768,7 @@ let run ~net:env#net ~interface ~port + ?stop ~error_handler ~backlog (* ~tls:(if tls then `OpenSSL else `No) *)