2026-03-28 07:30.03: New job: test TheLortex/dream https://github.com/TheLortex/dream.git#refs/heads/mirage-alpha4 (8bd9b9aa0640d15a94b9610709bf9ee24d70e8f0) (linux-x86_64:(lint-fmt))
Base: ocaml/opam:debian-13-ocaml-4.08@sha256:048f41796adc21a1c591ba8a7027365f75adbd0cc47a89cb4ad5d856f4815f47
ocamlformat version: version 0.20.1 (from opam)
To reproduce locally:
git clone --recursive "https://github.com/TheLortex/dream.git" -b "mirage-alpha4" && cd "dream" && git reset --hard 8bd9b9aa
cat > Dockerfile <<'END-OF-DOCKERFILE'
FROM ocaml/opam:debian-13-ocaml-4.08@sha256:048f41796adc21a1c591ba8a7027365f75adbd0cc47a89cb4ad5d856f4815f47
USER 1000:1000
RUN cd ~/opam-repository && (git cat-file -e 9f189ca4f94fbb5f0045820bf3c4ffafb21145ef || git fetch origin master) && git reset -q --hard 9f189ca4f94fbb5f0045820bf3c4ffafb21145ef && git log --no-decorate -n1 --oneline && opam update -u
RUN opam depext -i dune
WORKDIR /src
RUN opam depext -i ocamlformat=0.20.1
COPY --chown=1000:1000 . /src/
RUN opam exec -- dune build @fmt --ignore-promoted-rules || (echo "dune build @fmt failed"; exit 2)
END-OF-DOCKERFILE
docker build .
END-REPRO-BLOCK
2026-03-28 07:30.03: Using cache hint "TheLortex/dream-ocaml/opam:debian-13-ocaml-4.08@sha256:048f41796adc21a1c591ba8a7027365f75adbd0cc47a89cb4ad5d856f4815f47-debian-13-4.08_opam-2.5-ocamlformat-9f189ca4f94fbb5f0045820bf3c4ffafb21145ef"
2026-03-28 07:30.03: Using OBuilder spec:
((from ocaml/opam:debian-13-ocaml-4.08@sha256:048f41796adc21a1c591ba8a7027365f75adbd0cc47a89cb4ad5d856f4815f47)
(user (uid 1000) (gid 1000))
(run (cache (opam-archives (target /home/opam/.opam/download-cache)))
(network host)
(shell "cd ~/opam-repository && (git cat-file -e 9f189ca4f94fbb5f0045820bf3c4ffafb21145ef || git fetch origin master) && git reset -q --hard 9f189ca4f94fbb5f0045820bf3c4ffafb21145ef && git log --no-decorate -n1 --oneline && opam update -u"))
(run (cache (opam-archives (target /home/opam/.opam/download-cache)))
(network host)
(shell "opam depext -i dune"))
(workdir /src)
(run (cache (opam-archives (target /home/opam/.opam/download-cache)))
(network host)
(shell "opam depext -i ocamlformat=0.20.1"))
(copy (src .) (dst /src/))
(run (shell "opam exec -- dune build @fmt --ignore-promoted-rules || (echo \"dune build @fmt failed\"; exit 2)"))
)
2026-03-28 07:30.03: Waiting for resource in pool OCluster
2026-03-28 07:51.59: Waiting for worker…
2026-03-28 07:54.17: Got resource from pool OCluster
Building on phoebe.caelum.ci.dev
hint: Using 'master' as the name for the initial branch. This default branch name
hint: is subject to change. To configure the initial branch name to use in all
hint: of your new repositories, which will suppress this warning, call:
hint:
hint: git config --global init.defaultBranch <name>
hint:
hint: Names commonly chosen instead of 'master' are 'main', 'trunk' and
hint: 'development'. The just-created branch can be renamed via this command:
hint:
hint: git branch -m <name>
Initialized empty Git repository in /var/cache/obuilder/ocluster/git/dream.git-0c16b45d275233918e7fd513ba7986511b232c2b/.git/
HEAD is now at 8bd9b9a CI: pass opam file lint
error: could not lock config file .git/modules/src/vendor/gluten/config: No such file or directory
warning: Could not unset core.worktree setting in submodule 'src/vendor/gluten'
Cleared directory 'src/vendor/gluten'
error: could not lock config file .git/modules/src/vendor/h2/config: No such file or directory
warning: Could not unset core.worktree setting in submodule 'src/vendor/h2'
Cleared directory 'src/vendor/h2'
error: could not lock config file .git/modules/src/vendor/httpaf/config: No such file or directory
warning: Could not unset core.worktree setting in submodule 'src/vendor/httpaf'
Cleared directory 'src/vendor/httpaf'
error: could not lock config file .git/modules/src/vendor/paf/config: No such file or directory
warning: Could not unset core.worktree setting in submodule 'src/vendor/paf'
Cleared directory 'src/vendor/paf'
error: could not lock config file .git/modules/src/vendor/websocketaf/config: No such file or directory
warning: Could not unset core.worktree setting in submodule 'src/vendor/websocketaf'
Cleared directory 'src/vendor/websocketaf'
Submodule 'src/vendor/gluten' (https://github.com/anmonteiro/gluten.git) registered for path 'src/vendor/gluten'
Submodule 'src/vendor/h2' (https://github.com/anmonteiro/ocaml-h2.git) registered for path 'src/vendor/h2'
Submodule 'src/vendor/httpaf' (https://github.com/anmonteiro/httpaf.git) registered for path 'src/vendor/httpaf'
Submodule 'src/vendor/paf' (https://github.com/TheLortex/paf-le-chien.git) registered for path 'src/vendor/paf'
Submodule 'src/vendor/websocketaf' (https://github.com/anmonteiro/websocketaf.git) registered for path 'src/vendor/websocketaf'
Cloning into '/var/cache/obuilder/ocluster/git/dream.git-0c16b45d275233918e7fd513ba7986511b232c2b/src/vendor/gluten'...
Cloning into '/var/cache/obuilder/ocluster/git/dream.git-0c16b45d275233918e7fd513ba7986511b232c2b/src/vendor/h2'...
Cloning into '/var/cache/obuilder/ocluster/git/dream.git-0c16b45d275233918e7fd513ba7986511b232c2b/src/vendor/httpaf'...
Cloning into '/var/cache/obuilder/ocluster/git/dream.git-0c16b45d275233918e7fd513ba7986511b232c2b/src/vendor/paf'...
Cloning into '/var/cache/obuilder/ocluster/git/dream.git-0c16b45d275233918e7fd513ba7986511b232c2b/src/vendor/websocketaf'...
Submodule path 'src/vendor/gluten': checked out 'f8b88c485beb473af97de7b39461fb60a56cff3f'
Submodule path 'src/vendor/h2': checked out '8ad7db35248e2d321b993fc60390ccfdd54cb096'
Submodule 'hpack/test/hpack-test-case' (https://github.com/http2jp/hpack-test-case.git) registered for path 'src/vendor/h2/hpack/test/hpack-test-case'
Submodule 'lib_test/http2-frame-test-case' (https://github.com/http2jp/http2-frame-test-case.git) registered for path 'src/vendor/h2/lib_test/http2-frame-test-case'
Cloning into '/var/cache/obuilder/ocluster/git/dream.git-0c16b45d275233918e7fd513ba7986511b232c2b/src/vendor/h2/hpack/test/hpack-test-case'...
Cloning into '/var/cache/obuilder/ocluster/git/dream.git-0c16b45d275233918e7fd513ba7986511b232c2b/src/vendor/h2/lib_test/http2-frame-test-case'...
Submodule path 'src/vendor/h2/hpack/test/hpack-test-case': checked out 'b2a1664b43dc520a4bbff2e7db1b7e7af4fb43f4'
Submodule path 'src/vendor/h2/lib_test/http2-frame-test-case': checked out '5c67db0d4d68e1fb7d3a241d6e01fc04d981f465'
Submodule path 'src/vendor/httpaf': checked out '7189cd28e21203117f0c8e2347ae9a2fe0e0c157'
Submodule path 'src/vendor/paf': checked out '873e7b3b00d60ac6d6b1a59c3e867f27f357369b'
Submodule path 'src/vendor/websocketaf': checked out '44c54291a09ec271b256cdce3b3999315131c750'
(from ocaml/opam:debian-13-ocaml-4.08@sha256:048f41796adc21a1c591ba8a7027365f75adbd0cc47a89cb4ad5d856f4815f47)
2026-03-28 07:54.44 ---> using "867303d7f04cee0d3e23016229d2a45a69516628a14dbff52754cd3cb283f66f" from cache
/: (user (uid 1000) (gid 1000))
/: (run (cache (opam-archives (target /home/opam/.opam/download-cache)))
(network host)
(shell "cd ~/opam-repository && (git cat-file -e 9f189ca4f94fbb5f0045820bf3c4ffafb21145ef || git fetch origin master) && git reset -q --hard 9f189ca4f94fbb5f0045820bf3c4ffafb21145ef && git log --no-decorate -n1 --oneline && opam update -u"))
From https://github.com/ocaml/opam-repository
* branch master -> FETCH_HEAD
ffb54b9bdd..65664dc5b2 master -> origin/master
9f189ca4f9 Merge pull request #29562 from shonfeder/release-dune-3.22.0
<><> Updating package repositories ><><><><><><><><><><><><><><><><><><><><><><>
[default] Initialised
default (at git+file:///home/opam/opam-repository):
[INFO] opam 2.1 and 2.2 include many performance and security improvements over 2.0; please consider upgrading (https://opam.ocaml.org/doc/Install.html)
The following actions will be performed:
- recompile ocaml-base-compiler 4.08.1* [upstream changes]
- recompile ocaml-config 1 [uses ocaml-base-compiler]
- recompile ocaml 4.08.1 [uses ocaml-base-compiler]
- recompile opam-depext 1.2.3 [uses ocaml]
===== 4 to recompile =====
<><> Gathering sources ><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
[opam-depext.1.2.3] found in cache
[ocaml-base-compiler.4.08.1] downloaded from cache at https://opam.ocaml.org/cache
[ocaml-base-compiler.4.08.1/alt-signal-stack.patch] downloaded from https://opam.ocaml.org/cache
[ocaml-base-compiler.4.08.1/fix-gcc10.patch] downloaded from https://opam.ocaml.org/cache
<><> Processing actions <><><><><><><><><><><><><><><><><><><><><><><><><><><><>
-> removed opam-depext.1.2.3
-> removed ocaml.4.08.1
-> removed ocaml-config.1
-> removed ocaml-base-compiler.4.08.1
-> installed ocaml-base-compiler.4.08.1
-> installed ocaml-config.1
-> installed ocaml.4.08.1
-> installed opam-depext.1.2.3
Done.
# Run eval $(opam env) to update the current shell environment
2026-03-28 07:54.44 ---> using "bd03cc4441029060715730bbe20714583acb80156da207cea184734d3ca4c8fd" from cache
/: (run (cache (opam-archives (target /home/opam/.opam/download-cache)))
(network host)
(shell "opam depext -i dune"))
# Detecting depexts using vars: arch=x86_64, os=linux, os-distribution=debian, os-family=debian
# No extra OS packages requirements found.
# All required OS packages found.
# Now letting opam install the packages
The following actions will be performed:
- install dune 3.22.0
<><> Gathering sources ><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
[dune.3.22.0] found in cache
<><> Processing actions <><><><><><><><><><><><><><><><><><><><><><><><><><><><>
-> installed dune.3.22.0
Done.
# Run eval $(opam env) to update the current shell environment
2026-03-28 07:54.44 ---> using "24c575bf3aac3d7a427c4c47e65104cf9b3bd148f71da215db9c7cb12c5e0582" from cache
/: (workdir /src)
/src: (run (cache (opam-archives (target /home/opam/.opam/download-cache)))
(network host)
(shell "opam depext -i ocamlformat=0.20.1"))
# Detecting depexts using vars: arch=x86_64, os=linux, os-distribution=debian, os-family=debian
# No extra OS packages requirements found.
# All required OS packages found.
# Now letting opam install the packages
The following actions will be performed:
- install ocaml-version 3.5.0 [required by ocamlformat]
- install sexplib0 v0.14.0 [required by base]
- install cmdliner 1.3.0 [required by ocamlformat]
- install ocamlbuild 0.16.1 [required by fpath, uuseg]
- install either 1.0.0 [required by ocamlformat]
- install menhirLib 20260209 [required by ocamlformat]
- install csexp 1.5.2 [required by dune-configurator]
- install menhirSdk 20260209 [required by ocamlformat]
- install menhirGLR 20260209 [required by menhir]
- install result 1.5 [required by odoc-parser]
- install camlp-streams 5.0.1 [required by odoc-parser]
- install seq base [required by re]
- install fix 20250919 [required by ocamlformat]
- install ocamlfind 1.9.8 [required by ocp-indent, fpath, uuseg]
- install menhirCST 20260209 [required by menhir]
- install dune-build-info 3.22.0 [required by ocamlformat]
- install dune-configurator 3.22.0 [required by base]
- install re 1.11.0 [required by ocamlformat]
- install topkg 1.1.1 [required by fpath, uuseg]
- install ocp-indent 1.9.0 [required by ocamlformat]
- install menhir 20260209 [required by ocamlformat]
- install base v0.14.3 [required by ocamlformat]
- install uutf 1.0.4 [required by ocamlformat]
- install astring 0.8.5 [required by fpath, odoc-parser]
- install stdio v0.14.0 [required by ocamlformat]
- install uucp 15.0.0 [required by uuseg]
- install odoc-parser 1.0.1 [required by ocamlformat]
- install fpath 0.7.3 [required by ocamlformat]
- install uuseg 15.0.0 [required by ocamlformat]
- install ocamlformat 0.20.1
===== 30 to install =====
<><> Gathering sources ><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
[astring.0.8.5] found in cache
[base.v0.14.3] found in cache
[camlp-streams.5.0.1] found in cache
[cmdliner.1.3.0] found in cache
[csexp.1.5.2] found in cache
[dune-build-info.3.22.0] found in cache
[dune-configurator.3.22.0] found in cache
[either.1.0.0] found in cache
[fix.20250919] found in cache
[fpath.0.7.3] found in cache
[menhir.20260209] found in cache
[menhirCST.20260209] found in cache
[menhirGLR.20260209] found in cache
[menhirLib.20260209] found in cache
[menhirSdk.20260209] found in cache
[ocaml-version.3.5.0] found in cache
[ocamlbuild.0.16.1] found in cache
[ocamlfind.1.9.8] found in cache
[ocamlformat.0.20.1] found in cache
[ocp-indent.1.9.0] found in cache
[re.1.11.0] found in cache
[result.1.5] found in cache
[sexplib0.v0.14.0] found in cache
[stdio.v0.14.0] found in cache
[topkg.1.1.1] found in cache
[uucp.15.0.0] found in cache
[odoc-parser.1.0.1] downloaded from cache at https://opam.ocaml.org/cache
[uuseg.15.0.0] found in cache
[uutf.1.0.4] found in cache
<><> Processing actions <><><><><><><><><><><><><><><><><><><><><><><><><><><><>
-> installed seq.base
-> installed camlp-streams.5.0.1
-> installed csexp.1.5.2
-> installed dune-build-info.3.22.0
-> installed either.1.0.0
-> installed fix.20250919
-> installed menhirCST.20260209
-> installed menhirGLR.20260209
-> installed cmdliner.1.3.0
-> installed menhirLib.20260209
-> installed menhirSdk.20260209
-> installed ocaml-version.3.5.0
-> installed re.1.11.0
-> installed result.1.5
-> installed sexplib0.v0.14.0
-> installed dune-configurator.3.22.0
-> installed ocamlfind.1.9.8
-> installed ocp-indent.1.9.0
-> installed ocamlbuild.0.16.1
-> installed base.v0.14.3
-> installed menhir.20260209
-> installed topkg.1.1.1
-> installed stdio.v0.14.0
-> installed uutf.1.0.4
-> installed astring.0.8.5
-> installed odoc-parser.1.0.1
-> installed fpath.0.7.3
-> installed uucp.15.0.0
-> installed uuseg.15.0.0
-> installed ocamlformat.0.20.1
Done.
<><> ocp-indent.1.9.0 installed successfully ><><><><><><><><><><><><><><><><><>
=> This package requires additional configuration for use in editors. Install package 'user-setup', or manually:
* for Emacs, add these lines to ~/.emacs:
(add-to-list 'load-path "/home/opam/.opam/4.08/share/emacs/site-lisp")
(require 'ocp-indent)
* for Vim, add this line to ~/.vimrc:
set rtp^="/home/opam/.opam/4.08/share/ocp-indent/vim"
# Run eval $(opam env) to update the current shell environment
2026-03-28 07:57.23 ---> saved as "b7c41531dce66d4d2598d1fed94c98d0eb5dc140993d49405697971b02109a7e"
/src: (copy (src .) (dst /src/))
2026-03-28 07:57.27 ---> saved as "3256c964feecda946ad6dcdb1a292170f4996df235e7e530ce220741b3f49994"
/src: (run (shell "opam exec -- dune build @fmt --ignore-promoted-rules || (echo \"dune build @fmt failed\"; exit 2)"))
File "src/vendor/dune", line 1, characters 0-0:
diff --git a/_build/default/src/vendor/dune b/_build/default/src/vendor/.formatted/dune
index 19a00e7..f7fa884 100644
--- a/_build/default/src/vendor/dune
+++ b/_build/default/src/vendor/.formatted/dune
@@ -1,57 +1,56 @@
(data_only_dirs *)
-
-
-(subdir paf/lib
+(subdir
+ paf/lib
(library
(name paf)
(public_name dream-mirage.paf)
(modules paf)
(libraries faraday bigstringaf ke mimic)))
-(subdir paf/lib
+(subdir
+ paf/lib
(library
(name alpn)
(public_name dream-mirage.paf.alpn)
(modules alpn)
(libraries dream-mirage.paf dream-httpaf.httpaf dream-httpaf.h2)))
-(subdir paf/lib
+(subdir
+ paf/lib
(library
(name paf_mirage)
(public_name dream-mirage.paf.mirage)
(modules paf_mirage)
- (libraries tcpip dream-mirage.paf tls-mirage mirage-time dream-mirage.paf.alpn)))
+ (libraries tcpip dream-mirage.paf tls-mirage mirage-time
+ dream-mirage.paf.alpn)))
-(subdir paf/lib
+(subdir
+ paf/lib
(library
(name le)
(wrapped false)
(public_name dream-mirage.paf.le)
(modules lE)
- (libraries tcpip dream-httpaf.httpaf dream-mirage.paf mirage-time duration tls-mirage emile
- letsencrypt)))
-
-
+ (libraries tcpip dream-httpaf.httpaf dream-mirage.paf mirage-time duration
+ tls-mirage emile letsencrypt)))
-(subdir gluten/lib
+(subdir
+ gluten/lib
(library
(name gluten)
(public_name dream-httpaf.gluten)
- (libraries
- bigstringaf
- faraday
- ke)))
+ (libraries bigstringaf faraday ke)))
-(subdir gluten/lwt
+(subdir
+ gluten/lwt
(library
(name gluten_lwt)
(public_name dream-httpaf.gluten-lwt)
- (libraries
- dream-httpaf.gluten
- lwt)))
+ (libraries dream-httpaf.gluten lwt)))
-(subdir gluten/lwt-unix
+(subdir
+ gluten/lwt-unix
(library
(name gluten_lwt_unix)
(public_name dream-httpaf.gluten-lwt-unix)
@@ -71,90 +70,65 @@
(-> tls_io.dummy.ml)))
(modules gluten_lwt_unix tls_io ssl_io)))
-
-
-(subdir websocketaf/lib
+(subdir
+ websocketaf/lib
(library
(name websocketaf)
(public_name dream-httpaf.websocketaf)
- (libraries
- angstrom
- base64
- bigstringaf
- faraday
- dream-httpaf.gluten
- httpaf
- result)))
+ (libraries angstrom base64 bigstringaf faraday dream-httpaf.gluten httpaf
+ result)))
-(subdir websocketaf/lwt
+(subdir
+ websocketaf/lwt
(library
(name websocketaf_lwt)
(public_name dream-httpaf.websocketaf-lwt)
- (libraries
- base64
- digestif.ocaml
- dream-httpaf.gluten-lwt
- lwt
- dream-httpaf.websocketaf)))
+ (libraries base64 digestif.ocaml dream-httpaf.gluten-lwt lwt
+ dream-httpaf.websocketaf)))
-(subdir websocketaf/lwt-unix
+(subdir
+ websocketaf/lwt-unix
(library
(name websocketaf_lwt_unix)
(public_name dream-httpaf.websocketaf-lwt-unix)
- (libraries
- faraday-lwt-unix
- dream-httpaf.gluten-lwt-unix
- lwt.unix
- dream-httpaf.websocketaf-lwt)))
-
+ (libraries faraday-lwt-unix dream-httpaf.gluten-lwt-unix lwt.unix
+ dream-httpaf.websocketaf-lwt)))
-
-(subdir httpaf/lib
+(subdir
+ httpaf/lib
(library
(name httpaf)
(public_name dream-httpaf.httpaf)
- (libraries
- angstrom
- bigstringaf
- faraday
- result)))
+ (libraries angstrom bigstringaf faraday result)))
-(subdir httpaf/lwt
+(subdir
+ httpaf/lwt
(library
(name httpaf_lwt)
(public_name dream-httpaf.httpaf-lwt)
- (libraries
- dream-httpaf.gluten
- dream-httpaf.gluten-lwt
- dream-httpaf.httpaf
- lwt)))
+ (libraries dream-httpaf.gluten dream-httpaf.gluten-lwt dream-httpaf.httpaf
+ lwt)))
-(subdir httpaf/lwt-unix
+(subdir
+ httpaf/lwt-unix
(library
(name httpaf_lwt_unix)
(public_name dream-httpaf.httpaf-lwt-unix)
- (libraries
- faraday-lwt-unix
- dream-httpaf.gluten-lwt-unix
- dream-httpaf.httpaf
- dream-httpaf.httpaf-lwt
- lwt.unix)))
-
-
+ (libraries faraday-lwt-unix dream-httpaf.gluten-lwt-unix
+ dream-httpaf.httpaf dream-httpaf.httpaf-lwt lwt.unix)))
-(subdir h2/hpack/util
+(subdir
+ h2/hpack/util
(executables
(names gen_huffman gen_static)
- (libraries
- compiler-libs.common)))
+ (libraries compiler-libs.common)))
-(subdir h2/hpack/src
+(subdir
+ h2/hpack/src
(library
(name hpack)
(public_name dream-httpaf.hpack)
- (libraries
- angstrom
- faraday))
+ (libraries angstrom faraday))
(rule
(targets huffman_table.ml)
(deps ../util/huffman_table.txt)
@@ -163,37 +137,25 @@
%{targets}
(run ../util/gen_huffman.exe %{deps})))))
-(subdir h2/lib
+(subdir
+ h2/lib
(library
(name h2)
(public_name dream-httpaf.h2)
- (libraries
- angstrom
- base64
- bigstringaf
- faraday
- dream-httpaf.hpack
- dream-httpaf.httpaf
- psq
- result)))
+ (libraries angstrom base64 bigstringaf faraday dream-httpaf.hpack
+ dream-httpaf.httpaf psq result)))
-(subdir h2/lwt
+(subdir
+ h2/lwt
(library
(name h2_lwt)
(public_name dream-httpaf.h2-lwt)
- (libraries
- dream-httpaf.gluten
- dream-httpaf.gluten-lwt
- lwt
- dream-httpaf.h2)))
+ (libraries dream-httpaf.gluten dream-httpaf.gluten-lwt lwt dream-httpaf.h2)))
-(subdir h2/lwt-unix
+(subdir
+ h2/lwt-unix
(library
(name h2_lwt_unix)
(public_name dream-httpaf.h2-lwt-unix)
- (libraries
- faraday-lwt-unix
- dream-httpaf.gluten-lwt-unix
- dream-httpaf.h2
- dream-httpaf.h2-lwt
- lwt.unix)))
+ (libraries faraday-lwt-unix dream-httpaf.gluten-lwt-unix dream-httpaf.h2
+ dream-httpaf.h2-lwt lwt.unix)))
File "src/certificate/dune", line 1, characters 0-0:
diff --git a/_build/default/src/certificate/dune b/_build/default/src/certificate/.formatted/dune
index 5b1642c..cc025ab 100644
--- a/_build/default/src/certificate/dune
+++ b/_build/default/src/certificate/.formatted/dune
@@ -16,5 +16,4 @@
(echo "|ssl}\n\n")
(echo "let localhost_certificate_key = {key|")
(cat %{key})
- (echo "|key}\n")
- ))))
+ (echo "|key}\n")))))
File "src/pure/dune", line 1, characters 0-0:
diff --git a/_build/default/src/pure/dune b/_build/default/src/pure/.formatted/dune
index 7641556..59e14c7 100644
--- a/_build/default/src/pure/dune
+++ b/_build/default/src/pure/.formatted/dune
@@ -1,13 +1,8 @@
(library
(public_name dream-pure)
(name dream_pure)
- (libraries
- base64
- bigstringaf
- hmap
- lwt
- uri
- ptime
- )
- (preprocess (pps lwt_ppx))
- (instrumentation (backend bisect_ppx)))
+ (libraries base64 bigstringaf hmap lwt uri ptime)
+ (preprocess
+ (pps lwt_ppx))
+ (instrumentation
+ (backend bisect_ppx)))
File "example/w-fullstack-jsoo/client/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-fullstack-jsoo/client/dune b/_build/default/example/w-fullstack-jsoo/client/.formatted/dune
index 45f19c4..7201445 100644
--- a/_build/default/example/w-fullstack-jsoo/client/dune
+++ b/_build/default/example/w-fullstack-jsoo/client/.formatted/dune
@@ -2,4 +2,5 @@
(name client)
(modes js)
(libraries common js_of_ocaml)
- (preprocess (pps js_of_ocaml-ppx)))
+ (preprocess
+ (pps js_of_ocaml-ppx)))
File "src/eml/dune", line 1, characters 0-0:
diff --git a/_build/default/src/eml/dune b/_build/default/src/eml/.formatted/dune
index 1c29e05..8a5ca6d 100644
--- a/_build/default/src/eml/dune
+++ b/_build/default/src/eml/.formatted/dune
@@ -4,10 +4,12 @@
(name main)
(modules main)
(libraries eml)
- (instrumentation (backend bisect_ppx)))
+ (instrumentation
+ (backend bisect_ppx)))
(library
(name eml)
(modules eml)
(libraries camlp-streams)
- (instrumentation (backend bisect_ppx)))
+ (instrumentation
+ (backend bisect_ppx)))
File "src/cipher/dune", line 1, characters 0-0:
diff --git a/_build/default/src/cipher/dune b/_build/default/src/cipher/.formatted/dune
index aedd14e..539f144 100644
--- a/_build/default/src/cipher/dune
+++ b/_build/default/src/cipher/.formatted/dune
@@ -1,11 +1,8 @@
(library
(public_name dream.cipher)
(name dream__cipher)
- (libraries
- cstruct
- dream-pure
- mirage-crypto
- mirage-crypto-rng
- )
- (preprocess (pps lwt_ppx))
- (instrumentation (backend bisect_ppx)))
+ (libraries cstruct dream-pure mirage-crypto mirage-crypto-rng)
+ (preprocess
+ (pps lwt_ppx))
+ (instrumentation
+ (backend bisect_ppx)))
Error: Program refmt not found in the tree or in PATH
(context: default)
-> required by
_build/default/example/r-fullstack-melange/client/.formatted/client.re
-> required by alias example/r-fullstack-melange/client/.formatted/fmt
-> required by alias example/r-fullstack-melange/client/fmt
Hint: opam install reason
File "src/http/shared/dune", line 1, characters 0-0:
diff --git a/_build/default/src/http/shared/dune b/_build/default/src/http/shared/.formatted/dune
index 0766872..8fbf142 100644
--- a/_build/default/src/http/shared/dune
+++ b/_build/default/src/http/shared/.formatted/dune
@@ -1,10 +1,8 @@
(library
(public_name dream-httpaf)
(name dream_httpaf)
- (libraries
- bigstringaf
- dream-pure
- dream-httpaf.websocketaf
- )
- (preprocess (pps lwt_ppx))
- (instrumentation (backend bisect_ppx)))
+ (libraries bigstringaf dream-pure dream-httpaf.websocketaf)
+ (preprocess
+ (pps lwt_ppx))
+ (instrumentation
+ (backend bisect_ppx)))
File "src/server/dune", line 1, characters 0-0:
diff --git a/_build/default/src/server/dune b/_build/default/src/server/.formatted/dune
index d7dd67b..0f85694 100644
--- a/_build/default/src/server/dune
+++ b/_build/default/src/server/.formatted/dune
@@ -1,24 +1,12 @@
(library
(public_name dream.server)
(name dream__server)
- (libraries
- digestif
- dream.cipher
- dream-pure
- fmt
- logs
- lwt
- magic-mime
- mirage-clock
- multipart_form
- multipart_form-lwt
- ptime
- unstrctrd
- uri
- yojson
- )
- (preprocess (pps lwt_ppx))
- (instrumentation (backend bisect_ppx)))
+ (libraries digestif dream.cipher dream-pure fmt logs lwt magic-mime
+ mirage-clock multipart_form multipart_form-lwt ptime unstrctrd uri yojson)
+ (preprocess
+ (pps lwt_ppx))
+ (instrumentation
+ (backend bisect_ppx)))
(rule
(targets error_template.ml)
@@ -29,4 +17,5 @@
(rule
(targets tag.ml)
(deps tag.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
File "src/unix/dune", line 1, characters 0-0:
diff --git a/_build/default/src/unix/dune b/_build/default/src/unix/.formatted/dune
index 170fa3a..e7f11b1 100644
--- a/_build/default/src/unix/dune
+++ b/_build/default/src/unix/.formatted/dune
@@ -1,12 +1,8 @@
(library
(public_name dream.unix)
(name dream__unix)
- (libraries
- digestif
- dream-pure
- dream.server
- lwt.unix
- magic-mime
- )
- (preprocess (pps lwt_ppx))
- (instrumentation (backend bisect_ppx)))
+ (libraries digestif dream-pure dream.server lwt.unix magic-mime)
+ (preprocess
+ (pps lwt_ppx))
+ (instrumentation
+ (backend bisect_ppx)))
File "src/sql/dune", line 1, characters 0-0:
diff --git a/_build/default/src/sql/dune b/_build/default/src/sql/.formatted/dune
index e4244f4..399d81c 100644
--- a/_build/default/src/sql/dune
+++ b/_build/default/src/sql/.formatted/dune
@@ -1,13 +1,8 @@
(library
(public_name dream.sql)
(name dream__sql)
- (libraries
- caqti
- caqti-lwt
- dream.cipher
- dream-pure
- dream.server
- uri
- yojson)
- (preprocess (pps lwt_ppx))
- (instrumentation (backend bisect_ppx)))
+ (libraries caqti caqti-lwt dream.cipher dream-pure dream.server uri yojson)
+ (preprocess
+ (pps lwt_ppx))
+ (instrumentation
+ (backend bisect_ppx)))
File "test/expect/eml/dune", line 1, characters 0-0:
diff --git a/_build/default/test/expect/eml/dune b/_build/default/test/expect/eml/.formatted/dune
index 73ef13b..430cc45 100644
--- a/_build/default/test/expect/eml/dune
+++ b/_build/default/test/expect/eml/.formatted/dune
@@ -1,11 +1,7 @@
(library
(name test_expect_eml)
- (libraries
- base
- eml
- ppx_expect.common
- ppx_inline_test.config
- ppx_expect.config_types
- )
+ (libraries base eml ppx_expect.common ppx_inline_test.config
+ ppx_expect.config_types)
(inline_tests)
- (preprocess (pps ppx_expect)))
+ (preprocess
+ (pps ppx_expect)))
File "src/http/dune", line 1, characters 0-0:
diff --git a/_build/default/src/http/dune b/_build/default/src/http/.formatted/dune
index cac581f..83a9752 100644
--- a/_build/default/src/http/dune
+++ b/_build/default/src/http/.formatted/dune
@@ -1,24 +1,12 @@
(library
(public_name dream.http)
(name dream__http)
- (libraries
- digestif
- dream.certificate
- dream.cipher
- dream-pure
- dream.server
- dream-httpaf
- dream-httpaf.gluten
- dream-httpaf.gluten-lwt-unix
- dream-httpaf.h2
- dream-httpaf.h2-lwt-unix
- dream-httpaf.httpaf
- dream-httpaf.httpaf-lwt-unix
- lwt
- lwt.unix
- lwt_ssl
- ssl
- dream-httpaf.websocketaf
- )
- (preprocess (pps lwt_ppx))
- (instrumentation (backend bisect_ppx)))
+ (libraries digestif dream.certificate dream.cipher dream-pure dream.server
+ dream-httpaf dream-httpaf.gluten dream-httpaf.gluten-lwt-unix
+ dream-httpaf.h2 dream-httpaf.h2-lwt-unix dream-httpaf.httpaf
+ dream-httpaf.httpaf-lwt-unix lwt lwt.unix lwt_ssl ssl
+ dream-httpaf.websocketaf)
+ (preprocess
+ (pps lwt_ppx))
+ (instrumentation
+ (backend bisect_ppx)))
File "src/graphql/dune", line 1, characters 0-0:
diff --git a/_build/default/src/graphql/dune b/_build/default/src/graphql/.formatted/dune
index 7397ce1..c23626a 100644
--- a/_build/default/src/graphql/dune
+++ b/_build/default/src/graphql/.formatted/dune
@@ -1,15 +1,9 @@
(library
(public_name dream.graphql)
(name dream__graphql)
- (libraries
- dream.graphiql
- dream-pure
- dream.server
- graphql_parser
- graphql-lwt
- lwt
- str
- yojson
- )
- (preprocess (pps lwt_ppx))
- (instrumentation (backend bisect_ppx)))
+ (libraries dream.graphiql dream-pure dream.server graphql_parser graphql-lwt
+ lwt str yojson)
+ (preprocess
+ (pps lwt_ppx))
+ (instrumentation
+ (backend bisect_ppx)))
File "src/mirage/dune", line 1, characters 0-0:
diff --git a/_build/default/src/mirage/dune b/_build/default/src/mirage/.formatted/dune
index 61f5ee3..fcbdfb2 100644
--- a/_build/default/src/mirage/dune
+++ b/_build/default/src/mirage/.formatted/dune
@@ -1,20 +1,10 @@
(library
(public_name dream-mirage)
(name dream__mirage)
- (libraries
- bigarray-compat
- bigstringaf
- digestif
- dream.cipher
- dream.server
- dream.certificate
- dream-pure
- dream-httpaf.h2
- lwt
- tcpip
- dream-mirage.paf
- dream-mirage.paf.alpn
- dream-mirage.paf.mirage
- )
- (preprocess (pps lwt_ppx))
- (instrumentation (backend bisect_ppx)))
+ (libraries bigarray-compat bigstringaf digestif dream.cipher dream.server
+ dream.certificate dream-pure dream-httpaf.h2 lwt tcpip dream-mirage.paf
+ dream-mirage.paf.alpn dream-mirage.paf.mirage)
+ (preprocess
+ (pps lwt_ppx))
+ (instrumentation
+ (backend bisect_ppx)))
File "src/dune", line 1, characters 0-0:
diff --git a/_build/default/src/dune b/_build/default/src/.formatted/dune
index a82c981..d6c09da 100644
--- a/_build/default/src/dune
+++ b/_build/default/src/.formatted/dune
@@ -2,20 +2,6 @@
(public_name dream)
(wrapped false)
(modules dream)
- (libraries
- caqti-lwt
- dream.cipher
- dream.graphql
- dream.http
- dream.server
- dream.unix
- dream-pure
- dream.sql
- fmt.tty
- graphql-lwt
- logs
- lwt
- lwt.unix
- mirage-crypto-rng-lwt
- ptime.clock.os
- ))
+ (libraries caqti-lwt dream.cipher dream.graphql dream.http dream.server
+ dream.unix dream-pure dream.sql fmt.tty graphql-lwt logs lwt lwt.unix
+ mirage-crypto-rng-lwt ptime.clock.os))
File "test/expect/pure/dune", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/dune b/_build/default/test/expect/pure/.formatted/dune
index 9e21856..6589c2b 100644
--- a/_build/default/test/expect/pure/dune
+++ b/_build/default/test/expect/pure/.formatted/dune
@@ -1,11 +1,4 @@
(library
(name test_expect_pure)
- (libraries
- base
- dream
- dream-pure
- lwt
- lwt.unix
- ppx_expect.common
- ppx_inline_test.config
- ppx_expect.config_types))
+ (libraries base dream dream-pure lwt lwt.unix ppx_expect.common
+ ppx_inline_test.config ppx_expect.config_types))
File "test/unit/dune", line 1, characters 0-0:
diff --git a/_build/default/test/unit/dune b/_build/default/test/unit/.formatted/dune
index c6d4080..66c26d6 100644
--- a/_build/default/test/unit/dune
+++ b/_build/default/test/unit/.formatted/dune
@@ -1,12 +1,8 @@
(executable
(name unit)
- (libraries
- alcotest
- dream
- lwt
- lwt.unix
- ))
+ (libraries alcotest dream lwt lwt.unix))
(rule
(alias runtest)
- (action (run %{exe:unit.exe})))
+ (action
+ (run %{exe:unit.exe})))
File "example/z-playground/client/dune", line 1, characters 0-0:
diff --git a/_build/default/example/z-playground/client/dune b/_build/default/example/z-playground/client/.formatted/dune
index 6c6dcf4..839147a 100644
--- a/_build/default/example/z-playground/client/dune
+++ b/_build/default/example/z-playground/client/.formatted/dune
@@ -5,4 +5,5 @@
(rule
(targets client.ml)
(deps client.eml.html)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
File "example/w-fullstack-jsoo/server/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-fullstack-jsoo/server/dune b/_build/default/example/w-fullstack-jsoo/server/.formatted/dune
index e167254..dec2d23 100644
--- a/_build/default/example/w-fullstack-jsoo/server/dune
+++ b/_build/default/example/w-fullstack-jsoo/server/.formatted/dune
@@ -5,4 +5,5 @@
(rule
(targets server.ml)
(deps server.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
File "example/z-playground/runtime/dune", line 1, characters 0-0:
diff --git a/_build/default/example/z-playground/runtime/dune b/_build/default/example/z-playground/runtime/.formatted/dune
index 0a30838..df29df6 100644
--- a/_build/default/example/z-playground/runtime/dune
+++ b/_build/default/example/z-playground/runtime/.formatted/dune
@@ -6,4 +6,5 @@
(rule
(targets playground.ml)
(deps playground.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
File "test/expect/server/dune", line 1, characters 0-0:
diff --git a/_build/default/test/expect/server/dune b/_build/default/test/expect/server/.formatted/dune
index cf73000..e3a5cef 100644
--- a/_build/default/test/expect/server/dune
+++ b/_build/default/test/expect/server/.formatted/dune
@@ -1,15 +1,7 @@
(library
(name test_expect_server)
- (libraries
- base
- dream
- dream-pure
- dream.server
- lwt
- lwt.unix
- ppx_expect.common
- ppx_inline_test.config
- ppx_expect.config_types
- )
+ (libraries base dream dream-pure dream.server lwt lwt.unix ppx_expect.common
+ ppx_inline_test.config ppx_expect.config_types)
(inline_tests)
- (preprocess (pps lwt_ppx ppx_expect)))
+ (preprocess
+ (pps lwt_ppx ppx_expect)))
File "test/expect/server/cipher/dune", line 1, characters 0-0:
diff --git a/_build/default/test/expect/server/cipher/dune b/_build/default/test/expect/server/cipher/.formatted/dune
index b34a9cc..e95c5b4 100644
--- a/_build/default/test/expect/server/cipher/dune
+++ b/_build/default/test/expect/server/cipher/.formatted/dune
@@ -2,4 +2,5 @@
(name test_expect_server_cipher)
(libraries test_expect_server)
(inline_tests)
- (preprocess (pps lwt_ppx ppx_expect)))
+ (preprocess
+ (pps lwt_ppx ppx_expect)))
File "example/5-promise/dune", line 1, characters 0-0:
diff --git a/_build/default/example/5-promise/dune b/_build/default/example/5-promise/.formatted/dune
index 438ffc0..34ef41f 100644
--- a/_build/default/example/5-promise/dune
+++ b/_build/default/example/5-promise/.formatted/dune
@@ -1,6 +1,7 @@
(executable
(name promise)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/6-echo/dune", line 1, characters 0-0:
diff --git a/_build/default/example/6-echo/dune b/_build/default/example/6-echo/.formatted/dune
index aeebe71..3d5951e 100644
--- a/_build/default/example/6-echo/dune
+++ b/_build/default/example/6-echo/.formatted/dune
@@ -1,6 +1,7 @@
(executable
(name echo)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/b-session/dune", line 1, characters 0-0:
diff --git a/_build/default/example/b-session/dune b/_build/default/example/b-session/.formatted/dune
index 0087f76..a36ed93 100644
--- a/_build/default/example/b-session/dune
+++ b/_build/default/example/b-session/.formatted/dune
@@ -1,6 +1,7 @@
(executable
(name session)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/d-form/dune", line 1, characters 0-0:
diff --git a/_build/default/example/d-form/dune b/_build/default/example/d-form/.formatted/dune
index 6918056..a050b6d 100644
--- a/_build/default/example/d-form/dune
+++ b/_build/default/example/d-form/.formatted/dune
@@ -1,11 +1,13 @@
(executable
(name form)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(rule
(targets form.ml)
(deps form.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/g-upload/dune", line 1, characters 0-0:
diff --git a/_build/default/example/g-upload/dune b/_build/default/example/g-upload/.formatted/dune
index 72f71e7..29ba863 100644
--- a/_build/default/example/g-upload/dune
+++ b/_build/default/example/g-upload/.formatted/dune
@@ -1,11 +1,13 @@
(executable
(name upload)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(rule
(targets upload.ml)
(deps upload.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/j-stream/dune", line 1, characters 0-0:
diff --git a/_build/default/example/j-stream/dune b/_build/default/example/j-stream/.formatted/dune
index 9cf4388..9600181 100644
--- a/_build/default/example/j-stream/dune
+++ b/_build/default/example/j-stream/.formatted/dune
@@ -1,6 +1,7 @@
(executable
(name stream)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/k-websocket/dune", line 1, characters 0-0:
diff --git a/_build/default/example/k-websocket/dune b/_build/default/example/k-websocket/.formatted/dune
index 2e18f03..3fb63ee 100644
--- a/_build/default/example/k-websocket/dune
+++ b/_build/default/example/k-websocket/.formatted/dune
@@ -1,11 +1,13 @@
(executable
(name websocket)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(rule
(targets websocket.ml)
(deps websocket.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/r-template-stream/dune", line 1, characters 0-0:
diff --git a/_build/default/example/r-template-stream/dune b/_build/default/example/r-template-stream/.formatted/dune
index c2635dd..7fafe97 100644
--- a/_build/default/example/r-template-stream/dune
+++ b/_build/default/example/r-template-stream/.formatted/dune
@@ -1,11 +1,13 @@
(executable
(name template_stream)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(rule
(targets template_stream.re)
(deps template_stream.eml.re)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/w-chat/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-chat/dune b/_build/default/example/w-chat/.formatted/dune
index f91be1e..4c35a99 100644
--- a/_build/default/example/w-chat/dune
+++ b/_build/default/example/w-chat/.formatted/dune
@@ -1,11 +1,13 @@
(executable
(name chat)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(rule
(targets chat.ml)
(deps chat.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/w-content-security-policy/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-content-security-policy/dune b/_build/default/example/w-content-security-policy/.formatted/dune
index 73794e6..1fc45e7 100644
--- a/_build/default/example/w-content-security-policy/dune
+++ b/_build/default/example/w-content-security-policy/.formatted/dune
@@ -1,11 +1,13 @@
(executable
(name content_security_policy)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(rule
(targets content_security_policy.ml)
(deps content_security_policy.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/w-flash/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-flash/dune b/_build/default/example/w-flash/.formatted/dune
index 52b1d84..b95502b 100644
--- a/_build/default/example/w-flash/dune
+++ b/_build/default/example/w-flash/.formatted/dune
@@ -1,11 +1,13 @@
(executable
(name flash)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(rule
(targets flash.ml)
(deps flash.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/w-graphql-subscription/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-graphql-subscription/dune b/_build/default/example/w-graphql-subscription/.formatted/dune
index 4473ef8..8ff65c5 100644
--- a/_build/default/example/w-graphql-subscription/dune
+++ b/_build/default/example/w-graphql-subscription/.formatted/dune
@@ -1,6 +1,7 @@
(executable
(name graphql_subscription)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/w-live-reload/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-live-reload/dune b/_build/default/example/w-live-reload/.formatted/dune
index 393a577..f4e6882 100644
--- a/_build/default/example/w-live-reload/dune
+++ b/_build/default/example/w-live-reload/.formatted/dune
@@ -1,6 +1,7 @@
(executable
(name live_reload)
(libraries dream lambdasoup)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/w-long-polling/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-long-polling/dune b/_build/default/example/w-long-polling/.formatted/dune
index 3763997..ea2228d 100644
--- a/_build/default/example/w-long-polling/dune
+++ b/_build/default/example/w-long-polling/.formatted/dune
@@ -1,11 +1,13 @@
(executable
(name long_polling)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(rule
(targets long_polling.ml)
(deps long_polling.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/w-multipart-dump/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-multipart-dump/dune b/_build/default/example/w-multipart-dump/.formatted/dune
index 87c0c59..893fefe 100644
--- a/_build/default/example/w-multipart-dump/dune
+++ b/_build/default/example/w-multipart-dump/.formatted/dune
@@ -1,11 +1,13 @@
(executable
(name multipart_dump)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(rule
(targets multipart_dump.ml)
(deps multipart_dump.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/w-nginx/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-nginx/dune b/_build/default/example/w-nginx/.formatted/dune
index 57619d0..a162201 100644
--- a/_build/default/example/w-nginx/dune
+++ b/_build/default/example/w-nginx/.formatted/dune
@@ -1,11 +1,13 @@
(executable
(name server)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(rule
(targets server.ml)
(deps server.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock)
File "example/w-one-binary/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-one-binary/dune b/_build/default/example/w-one-binary/.formatted/dune
index 049b3f7..417a650 100644
--- a/_build/default/example/w-one-binary/dune
+++ b/_build/default/example/w-one-binary/.formatted/dune
@@ -1,12 +1,16 @@
(executable
(name one_binary)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(rule
(target assets.ml)
- (deps (source_tree assets))
- (action (with-stdout-to %{null}
- (run ocaml-crunch -m plain assets -o %{target}))))
+ (deps
+ (source_tree assets))
+ (action
+ (with-stdout-to
+ %{null}
+ (run ocaml-crunch -m plain assets -o %{target}))))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/w-server-sent-events/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-server-sent-events/dune b/_build/default/example/w-server-sent-events/.formatted/dune
index 4f1a749..da868ec 100644
--- a/_build/default/example/w-server-sent-events/dune
+++ b/_build/default/example/w-server-sent-events/.formatted/dune
@@ -1,11 +1,13 @@
(executable
(name server_sent_events)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(rule
(targets server_sent_events.ml)
(deps server_sent_events.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/w-stress-response/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-stress-response/dune b/_build/default/example/w-stress-response/.formatted/dune
index bceb927..93a2def 100644
--- a/_build/default/example/w-stress-response/dune
+++ b/_build/default/example/w-stress-response/.formatted/dune
@@ -1,6 +1,7 @@
(executable
(name stress_response)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/w-stress-websocket-send/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-stress-websocket-send/dune b/_build/default/example/w-stress-websocket-send/.formatted/dune
index 8d28083..9f84bb0 100644
--- a/_build/default/example/w-stress-websocket-send/dune
+++ b/_build/default/example/w-stress-websocket-send/.formatted/dune
@@ -1,11 +1,13 @@
(executable
(name stress_websocket_send)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(rule
(targets stress_websocket_send.ml)
(deps stress_websocket_send.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/w-template-stream/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-template-stream/dune b/_build/default/example/w-template-stream/.formatted/dune
index 3bde4f8..15a7db6 100644
--- a/_build/default/example/w-template-stream/dune
+++ b/_build/default/example/w-template-stream/.formatted/dune
@@ -1,11 +1,13 @@
(executable
(name template_stream)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(rule
(targets template_stream.ml)
(deps template_stream.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/w-upload-stream/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-upload-stream/dune b/_build/default/example/w-upload-stream/.formatted/dune
index eeb5a4a..5e358ad 100644
--- a/_build/default/example/w-upload-stream/dune
+++ b/_build/default/example/w-upload-stream/.formatted/dune
@@ -1,11 +1,13 @@
(executable
(name upload_stream)
(libraries dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(rule
(targets upload_stream.ml)
(deps upload_stream.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/h-sql/dune", line 1, characters 0-0:
diff --git a/_build/default/example/h-sql/dune b/_build/default/example/h-sql/.formatted/dune
index 2dbe8fb..78b2c01 100644
--- a/_build/default/example/h-sql/dune
+++ b/_build/default/example/h-sql/.formatted/dune
@@ -1,11 +1,13 @@
(executable
(name sql)
(libraries caqti-driver-sqlite3 dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(rule
(targets sql.ml)
(deps sql.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/w-postgres/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-postgres/dune b/_build/default/example/w-postgres/.formatted/dune
index 4ac8531..f383bd6 100644
--- a/_build/default/example/w-postgres/dune
+++ b/_build/default/example/w-postgres/.formatted/dune
@@ -1,11 +1,13 @@
(executable
(name postgres)
(libraries caqti-driver-postgresql dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(rule
(targets postgres.ml)
(deps postgres.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock)
File "example/z-playground/server/dune", line 1, characters 0-0:
diff --git a/_build/default/example/z-playground/server/dune b/_build/default/example/z-playground/server/.formatted/dune
index ce57b96..74c511b 100644
--- a/_build/default/example/z-playground/server/dune
+++ b/_build/default/example/z-playground/server/.formatted/dune
@@ -1,4 +1,5 @@
(executable
(name playground)
(libraries client dream)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
File "test/expect/pure/message/dune", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/message/dune b/_build/default/test/expect/pure/message/.formatted/dune
index 3157b0c..5f7b85f 100644
--- a/_build/default/test/expect/pure/message/dune
+++ b/_build/default/test/expect/pure/message/.formatted/dune
@@ -2,4 +2,5 @@
(name test_expect_pure_message)
(libraries test_expect_pure)
(inline_tests)
- (preprocess (pps lwt_ppx ppx_expect)))
+ (preprocess
+ (pps lwt_ppx ppx_expect)))
File "example/7-template/dune", line 1, characters 0-0:
diff --git a/_build/default/example/7-template/dune b/_build/default/example/7-template/.formatted/dune
index a9ae8bb..54fa421 100644
--- a/_build/default/example/7-template/dune
+++ b/_build/default/example/7-template/.formatted/dune
@@ -5,6 +5,7 @@
(rule
(targets template.ml)
(deps template.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/9-error/dune", line 1, characters 0-0:
diff --git a/_build/default/example/9-error/dune b/_build/default/example/9-error/.formatted/dune
index 5efdc54..fe7ecac 100644
--- a/_build/default/example/9-error/dune
+++ b/_build/default/example/9-error/.formatted/dune
@@ -5,6 +5,7 @@
(rule
(targets error.ml)
(deps error.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/r-template/dune", line 1, characters 0-0:
diff --git a/_build/default/example/r-template/dune b/_build/default/example/r-template/.formatted/dune
index ec274c0..855f27f 100644
--- a/_build/default/example/r-template/dune
+++ b/_build/default/example/r-template/.formatted/dune
@@ -5,6 +5,7 @@
(rule
(targets template.re)
(deps template.eml.re)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/r-template-files/dune", line 1, characters 0-0:
diff --git a/_build/default/example/r-template-files/dune b/_build/default/example/r-template-files/.formatted/dune
index 1a0c545..11f08b6 100644
--- a/_build/default/example/r-template-files/dune
+++ b/_build/default/example/r-template-files/.formatted/dune
@@ -5,6 +5,7 @@
(rule
(targets template.re)
(deps template.eml.html)
- (action (run dream_eml %{deps} --workspace %{workspace_root} --emit-reason)))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root} --emit-reason)))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/r-template-logic/dune", line 1, characters 0-0:
diff --git a/_build/default/example/r-template-logic/dune b/_build/default/example/r-template-logic/.formatted/dune
index ec274c0..855f27f 100644
--- a/_build/default/example/r-template-logic/dune
+++ b/_build/default/example/r-template-logic/.formatted/dune
@@ -5,6 +5,7 @@
(rule
(targets template.re)
(deps template.eml.re)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/w-template-files/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-template-files/dune b/_build/default/example/w-template-files/.formatted/dune
index cb117b2..00d6342 100644
--- a/_build/default/example/w-template-files/dune
+++ b/_build/default/example/w-template-files/.formatted/dune
@@ -5,6 +5,7 @@
(rule
(targets template.ml)
(deps template.eml.html)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/w-template-logic/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-template-logic/dune b/_build/default/example/w-template-logic/.formatted/dune
index a9ae8bb..54fa421 100644
--- a/_build/default/example/w-template-logic/dune
+++ b/_build/default/example/w-template-logic/.formatted/dune
@@ -5,6 +5,7 @@
(rule
(targets template.ml)
(deps template.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/r-fullstack-melange/server/dune", line 1, characters 0-0:
diff --git a/_build/default/example/r-fullstack-melange/server/dune b/_build/default/example/r-fullstack-melange/server/.formatted/dune
index e1e9889..c7be532 100644
--- a/_build/default/example/r-fullstack-melange/server/dune
+++ b/_build/default/example/r-fullstack-melange/server/.formatted/dune
@@ -5,4 +5,5 @@
(rule
(targets server.re)
(deps server.eml.re)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
File "example/w-fullstack-rescript/server/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-fullstack-rescript/server/dune b/_build/default/example/w-fullstack-rescript/server/.formatted/dune
index e167254..dec2d23 100644
--- a/_build/default/example/w-fullstack-rescript/server/dune
+++ b/_build/default/example/w-fullstack-rescript/server/.formatted/dune
@@ -5,4 +5,5 @@
(rule
(targets server.ml)
(deps server.eml.ml)
- (action (run dream_eml %{deps} --workspace %{workspace_root})))
+ (action
+ (run dream_eml %{deps} --workspace %{workspace_root})))
File "example/e-json/dune", line 1, characters 0-0:
diff --git a/_build/default/example/e-json/dune b/_build/default/example/e-json/.formatted/dune
index 15568ce..d057705 100644
--- a/_build/default/example/e-json/dune
+++ b/_build/default/example/e-json/.formatted/dune
@@ -1,6 +1,7 @@
(executable
(name json)
(libraries dream)
- (preprocess (pps lwt_ppx ppx_yojson_conv)))
+ (preprocess
+ (pps lwt_ppx ppx_yojson_conv)))
(data_only_dirs _esy esy.lock lib node_modules)
File "example/w-tyxml/dune", line 1, characters 0-0:
diff --git a/_build/default/example/w-tyxml/dune b/_build/default/example/w-tyxml/.formatted/dune
index 986286d..45e7040 100644
--- a/_build/default/example/w-tyxml/dune
+++ b/_build/default/example/w-tyxml/.formatted/dune
@@ -1,6 +1,7 @@
(executable
(name tyxml)
(libraries dream tyxml)
- (preprocess (pps lwt_ppx)))
+ (preprocess
+ (pps lwt_ppx)))
(data_only_dirs _esy esy.lock lib node_modules)
File "test/expect/pure/method/dune", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/method/dune b/_build/default/test/expect/pure/method/.formatted/dune
index 2a6ab6c..4e5333d 100644
--- a/_build/default/test/expect/pure/method/dune
+++ b/_build/default/test/expect/pure/method/.formatted/dune
@@ -2,4 +2,5 @@
(name test_expect_pure_method)
(libraries test_expect_pure)
(inline_tests)
- (preprocess (pps lwt_ppx ppx_expect)))
+ (preprocess
+ (pps lwt_ppx ppx_expect)))
File "test/expect/pure/status/dune", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/status/dune b/_build/default/test/expect/pure/status/.formatted/dune
index 3b64cd2..932f173 100644
--- a/_build/default/test/expect/pure/status/dune
+++ b/_build/default/test/expect/pure/status/.formatted/dune
@@ -2,4 +2,5 @@
(name test_expect_pure_status)
(libraries test_expect_pure)
(inline_tests)
- (preprocess (pps lwt_ppx ppx_expect)))
+ (preprocess
+ (pps lwt_ppx ppx_expect)))
File "test/expect/pure/stream/dune", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/stream/dune b/_build/default/test/expect/pure/stream/.formatted/dune
index b012b02..557d493 100644
--- a/_build/default/test/expect/pure/stream/dune
+++ b/_build/default/test/expect/pure/stream/.formatted/dune
@@ -2,4 +2,5 @@
(name test_expect_pure_stream)
(libraries test_expect_pure)
(inline_tests)
- (preprocess (pps lwt_ppx ppx_expect)))
+ (preprocess
+ (pps lwt_ppx ppx_expect)))
File "test/expect/pure/formats/base64/dune", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/formats/base64/dune b/_build/default/test/expect/pure/formats/base64/.formatted/dune
index a582ff7..0dde1b5 100644
--- a/_build/default/test/expect/pure/formats/base64/dune
+++ b/_build/default/test/expect/pure/formats/base64/.formatted/dune
@@ -2,4 +2,5 @@
(name test_expect_pure_base64)
(libraries test_expect_pure)
(inline_tests)
- (preprocess (pps lwt_ppx ppx_expect)))
+ (preprocess
+ (pps lwt_ppx ppx_expect)))
File "example/r-tyxml/dune", line 1, characters 0-0:
diff --git a/_build/default/example/r-tyxml/dune b/_build/default/example/r-tyxml/.formatted/dune
index fef3113..19ad6bc 100644
--- a/_build/default/example/r-tyxml/dune
+++ b/_build/default/example/r-tyxml/.formatted/dune
@@ -1,6 +1,7 @@
(executable
(name tyxml)
(libraries dream tyxml)
- (preprocess (pps lwt_ppx tyxml-jsx)))
+ (preprocess
+ (pps lwt_ppx tyxml-jsx)))
(data_only_dirs _esy esy.lock lib node_modules)
File "test/expect/pure/formats/cookie/dune", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/formats/cookie/dune b/_build/default/test/expect/pure/formats/cookie/.formatted/dune
index b7bde4c..a1ee189 100644
--- a/_build/default/test/expect/pure/formats/cookie/dune
+++ b/_build/default/test/expect/pure/formats/cookie/.formatted/dune
@@ -2,4 +2,5 @@
(name test_expect_pure_cookie)
(libraries test_expect_pure)
(inline_tests)
- (preprocess (pps lwt_ppx ppx_expect)))
+ (preprocess
+ (pps lwt_ppx ppx_expect)))
File "test/expect/pure/formats/escape/dune", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/formats/escape/dune b/_build/default/test/expect/pure/formats/escape/.formatted/dune
index 869fce0..d57862a 100644
--- a/_build/default/test/expect/pure/formats/escape/dune
+++ b/_build/default/test/expect/pure/formats/escape/.formatted/dune
@@ -2,4 +2,5 @@
(name test_expect_pure_escape)
(libraries test_expect_pure)
(inline_tests)
- (preprocess (pps lwt_ppx ppx_expect)))
+ (preprocess
+ (pps lwt_ppx ppx_expect)))
File "test/expect/pure/formats/form_urlencoded/dune", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/formats/form_urlencoded/dune b/_build/default/test/expect/pure/formats/form_urlencoded/.formatted/dune
index 1f73858..71659f1 100644
--- a/_build/default/test/expect/pure/formats/form_urlencoded/dune
+++ b/_build/default/test/expect/pure/formats/form_urlencoded/.formatted/dune
@@ -2,4 +2,5 @@
(name test_expect_pure_form_urlencoded)
(libraries test_expect_pure)
(inline_tests)
- (preprocess (pps lwt_ppx ppx_expect)))
+ (preprocess
+ (pps lwt_ppx ppx_expect)))
File "test/expect/pure/formats/path/dune", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/formats/path/dune b/_build/default/test/expect/pure/formats/path/.formatted/dune
index 4ddcd51..41f136a 100644
--- a/_build/default/test/expect/pure/formats/path/dune
+++ b/_build/default/test/expect/pure/formats/path/.formatted/dune
@@ -2,4 +2,5 @@
(name test_expect_pure_path)
(libraries test_expect_pure)
(inline_tests)
- (preprocess (pps lwt_ppx ppx_expect)))
+ (preprocess
+ (pps lwt_ppx ppx_expect)))
File "test/expect/pure/formats/percent/dune", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/formats/percent/dune b/_build/default/test/expect/pure/formats/percent/.formatted/dune
index dfe1ec6..4fe4985 100644
--- a/_build/default/test/expect/pure/formats/percent/dune
+++ b/_build/default/test/expect/pure/formats/percent/.formatted/dune
@@ -2,4 +2,5 @@
(name test_expect_pure_percent)
(libraries test_expect_pure)
(inline_tests)
- (preprocess (pps lwt_ppx ppx_expect)))
+ (preprocess
+ (pps lwt_ppx ppx_expect)))
File "test/expect/pure/formats/query/dune", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/formats/query/dune b/_build/default/test/expect/pure/formats/query/.formatted/dune
index 985a864..6837c95 100644
--- a/_build/default/test/expect/pure/formats/query/dune
+++ b/_build/default/test/expect/pure/formats/query/.formatted/dune
@@ -2,4 +2,5 @@
(name test_expect_pure_query)
(libraries test_expect_pure)
(inline_tests)
- (preprocess (pps lwt_ppx ppx_expect)))
+ (preprocess
+ (pps lwt_ppx ppx_expect)))
File "test/expect/pure/formats/target/dune", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/formats/target/dune b/_build/default/test/expect/pure/formats/target/.formatted/dune
index 11356a5..8f33707 100644
--- a/_build/default/test/expect/pure/formats/target/dune
+++ b/_build/default/test/expect/pure/formats/target/.formatted/dune
@@ -2,4 +2,5 @@
(name test_expect_pure_target)
(libraries test_expect_pure)
(inline_tests)
- (preprocess (pps lwt_ppx ppx_expect)))
+ (preprocess
+ (pps lwt_ppx ppx_expect)))
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "src/server/error_template.eml.ml" (syntax error)
File "src/server/error_template.eml.ml", line 20, characters 2-4:
20 | <!DOCTYPE html>
^^
Error: Syntax error
-> required by _build/default/src/server/.formatted/error_template.eml.ml
-> required by alias src/server/.formatted/fmt
-> required by alias src/server/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "src/server/tag.eml.ml" (syntax error)
File "src/server/tag.eml.ml", line 21, characters 2-3:
21 | <input name="<%s! Csrf.field_name %>" type="hidden" value="<%s! token %>">
^
Error: Syntax error
-> required by _build/default/src/server/.formatted/tag.eml.ml
-> required by alias src/server/.formatted/fmt
-> required by alias src/server/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/w-fullstack-jsoo/server/server.eml.ml" (syntax error)
File "example/w-fullstack-jsoo/server/server.eml.ml", line 2, characters 2-3:
2 | <html>
^
Error: Syntax error
-> required by
_build/default/example/w-fullstack-jsoo/server/.formatted/server.eml.ml
-> required by alias example/w-fullstack-jsoo/server/.formatted/fmt
-> required by alias example/w-fullstack-jsoo/server/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/z-playground/runtime/playground.eml.ml" (syntax error)
File "example/z-playground/runtime/playground.eml.ml", line 9, characters 2-4:
9 | <!DOCTYPE html>
^^
Error: Syntax error
-> required by
_build/default/example/z-playground/runtime/.formatted/playground.eml.ml
-> required by alias example/z-playground/runtime/.formatted/fmt
-> required by alias example/z-playground/runtime/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/d-form/form.eml.ml" (syntax error)
File "example/d-form/form.eml.ml", line 2, characters 2-3:
2 | <html>
^
Error: Syntax error
-> required by _build/default/example/d-form/.formatted/form.eml.ml
-> required by alias example/d-form/.formatted/fmt
-> required by alias example/d-form/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/g-upload/upload.eml.ml" (syntax error)
File "example/g-upload/upload.eml.ml", line 2, characters 2-3:
2 | <html>
^
Error: Syntax error
-> required by _build/default/example/g-upload/.formatted/upload.eml.ml
-> required by alias example/g-upload/.formatted/fmt
-> required by alias example/g-upload/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/k-websocket/websocket.eml.ml" (syntax error)
File "example/k-websocket/websocket.eml.ml", line 2, characters 2-3:
2 | <html>
^
Error: Syntax error
-> required by _build/default/example/k-websocket/.formatted/websocket.eml.ml
-> required by alias example/k-websocket/.formatted/fmt
-> required by alias example/k-websocket/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/w-chat/chat.eml.ml" (syntax error)
File "example/w-chat/chat.eml.ml", line 2, characters 2-3:
2 | <html>
^
Error: Syntax error
-> required by _build/default/example/w-chat/.formatted/chat.eml.ml
-> required by alias example/w-chat/.formatted/fmt
-> required by alias example/w-chat/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/w-content-security-policy/content_security_policy.eml.ml" (syntax error)
File "example/w-content-security-policy/content_security_policy.eml.ml", line 2, characters 2-3:
2 | <html>
^
Error: Syntax error
-> required by
_build/default/example/w-content-security-policy/.formatted/content_security_policy.eml.ml
-> required by alias example/w-content-security-policy/.formatted/fmt
-> required by alias example/w-content-security-policy/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/w-flash/flash.eml.ml" (syntax error)
File "example/w-flash/flash.eml.ml", line 2, characters 2-3:
2 | <html>
^
Error: Syntax error
-> required by _build/default/example/w-flash/.formatted/flash.eml.ml
-> required by alias example/w-flash/.formatted/fmt
-> required by alias example/w-flash/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/w-long-polling/long_polling.eml.ml" (syntax error)
File "example/w-long-polling/long_polling.eml.ml", line 2, characters 2-3:
2 | <html>
^
Error: Syntax error
-> required by
_build/default/example/w-long-polling/.formatted/long_polling.eml.ml
-> required by alias example/w-long-polling/.formatted/fmt
-> required by alias example/w-long-polling/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/w-multipart-dump/multipart_dump.eml.ml" (syntax error)
File "example/w-multipart-dump/multipart_dump.eml.ml", line 2, characters 2-3:
2 | <html>
^
Error: Syntax error
-> required by
_build/default/example/w-multipart-dump/.formatted/multipart_dump.eml.ml
-> required by alias example/w-multipart-dump/.formatted/fmt
-> required by alias example/w-multipart-dump/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/w-nginx/server.eml.ml" (syntax error)
File "example/w-nginx/server.eml.ml", line 2, characters 2-3:
2 | <html>
^
Error: Syntax error
-> required by _build/default/example/w-nginx/.formatted/server.eml.ml
-> required by alias example/w-nginx/.formatted/fmt
-> required by alias example/w-nginx/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/w-server-sent-events/server_sent_events.eml.ml" (syntax error)
File "example/w-server-sent-events/server_sent_events.eml.ml", line 2, characters 2-3:
2 | <html>
^
Error: Syntax error
-> required by
_build/default/example/w-server-sent-events/.formatted/server_sent_events.eml.ml
-> required by alias example/w-server-sent-events/.formatted/fmt
-> required by alias example/w-server-sent-events/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/w-stress-websocket-send/stress_websocket_send.eml.ml" (syntax error)
File "example/w-stress-websocket-send/stress_websocket_send.eml.ml", line 4, characters 2-3:
4 | <html>
^
Error: Syntax error
-> required by
_build/default/example/w-stress-websocket-send/.formatted/stress_websocket_send.eml.ml
-> required by alias example/w-stress-websocket-send/.formatted/fmt
-> required by alias example/w-stress-websocket-send/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/w-template-stream/template_stream.eml.ml" (syntax error)
File "example/w-template-stream/template_stream.eml.ml", line 2, characters 2-4:
2 | %% response
^^
Error: Syntax error
-> required by
_build/default/example/w-template-stream/.formatted/template_stream.eml.ml
-> required by alias example/w-template-stream/.formatted/fmt
-> required by alias example/w-template-stream/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/w-upload-stream/upload_stream.eml.ml" (syntax error)
File "example/w-upload-stream/upload_stream.eml.ml", line 2, characters 2-3:
2 | <html>
^
Error: Syntax error
-> required by
_build/default/example/w-upload-stream/.formatted/upload_stream.eml.ml
-> required by alias example/w-upload-stream/.formatted/fmt
-> required by alias example/w-upload-stream/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/h-sql/sql.eml.ml" (syntax error)
File "example/h-sql/sql.eml.ml", line 25, characters 2-3:
25 | <html>
^
Error: Syntax error
-> required by _build/default/example/h-sql/.formatted/sql.eml.ml
-> required by alias example/h-sql/.formatted/fmt
-> required by alias example/h-sql/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/w-postgres/postgres.eml.ml" (syntax error)
File "example/w-postgres/postgres.eml.ml", line 24, characters 2-3:
24 | <html>
^
Error: Syntax error
-> required by _build/default/example/w-postgres/.formatted/postgres.eml.ml
-> required by alias example/w-postgres/.formatted/fmt
-> required by alias example/w-postgres/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/7-template/template.eml.ml" (syntax error)
File "example/7-template/template.eml.ml", line 2, characters 2-3:
2 | <html>
^
Error: Syntax error
-> required by _build/default/example/7-template/.formatted/template.eml.ml
-> required by alias example/7-template/.formatted/fmt
-> required by alias example/7-template/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/9-error/error.eml.ml" (syntax error)
File "example/9-error/error.eml.ml", line 8, characters 4-5:
8 | <html>
^
Error: Syntax error
-> required by _build/default/example/9-error/.formatted/error.eml.ml
-> required by alias example/9-error/.formatted/fmt
-> required by alias example/9-error/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/w-template-logic/template.eml.ml" (syntax error)
File "example/w-template-logic/template.eml.ml", line 2, characters 2-3:
2 | <html>
^
Error: Syntax error
-> required by
_build/default/example/w-template-logic/.formatted/template.eml.ml
-> required by alias example/w-template-logic/.formatted/fmt
-> required by alias example/w-template-logic/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
ocamlformat: ignoring "example/w-fullstack-rescript/server/server.eml.ml" (syntax error)
File "example/w-fullstack-rescript/server/server.eml.ml", line 2, characters 2-3:
2 | <html>
^
Error: Syntax error
-> required by
_build/default/example/w-fullstack-rescript/server/.formatted/server.eml.ml
-> required by alias example/w-fullstack-rescript/server/.formatted/fmt
-> required by alias example/w-fullstack-rescript/server/fmt
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0..
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
File "src/pure/formats.ml", line 1, characters 0-0:
diff --git a/_build/default/src/pure/formats.ml b/_build/default/src/pure/.formatted/formats.ml
index a90759a..2698eb3 100644
--- a/_build/default/src/pure/formats.ml
+++ b/_build/default/src/pure/.formatted/formats.ml
@@ -3,22 +3,18 @@
Copyright 2021 Anton Bachin *)
-
-
let html_escape s =
let buffer = Buffer.create (String.length s * 2) in
- s |> String.iter begin function
- | '&' -> Buffer.add_string buffer "&"
- | '<' -> Buffer.add_string buffer "<"
- | '>' -> Buffer.add_string buffer ">"
- | '"' -> Buffer.add_string buffer """
- | '\'' -> Buffer.add_string buffer "'"
- | c -> Buffer.add_char buffer c
- end;
+ s
+ |> String.iter (function
+ | '&' -> Buffer.add_string buffer "&"
+ | '<' -> Buffer.add_string buffer "<"
+ | '>' -> Buffer.add_string buffer ">"
+ | '"' -> Buffer.add_string buffer """
+ | '\'' -> Buffer.add_string buffer "'"
+ | c -> Buffer.add_char buffer c);
Buffer.contents buffer
-
-
let to_base64url string =
Base64.encode_string ~pad:false ~alphabet:Base64.uri_safe_alphabet string
@@ -27,18 +23,17 @@ let from_base64url string =
| Error _ -> None
| Ok result -> Some result
-
-
let from_cookie s =
let pairs =
- s
- |> String.split_on_char ';'
- |> List.map (String.split_on_char '=')
+ s |> String.split_on_char ';' |> List.map (String.split_on_char '=')
in
- pairs |> List.fold_left (fun pairs -> function
- | [name; value] -> (String.trim name, String.trim value)::pairs
- | _ -> pairs) []
+ pairs
+ |> List.fold_left
+ (fun pairs -> function
+ | [name; value] -> (String.trim name, String.trim value) :: pairs
+ | _ -> pairs)
+ []
(* Note: found ocaml-cookie and http-cookie libraries, but they appear to have
equivalent code for parsing Cookie: headers, so there is no point in using
them yet, especially as they have stringent OCaml version constraints for
@@ -48,24 +43,37 @@ let from_cookie s =
specially. This might not be important, however, if user agents treat cookies
as opaque, because then only Dream has to deal with its own cookies. *)
-let to_set_cookie
- ?expires ?max_age ?domain ?path ?secure ?http_only ?same_site name value =
-
+let to_set_cookie ?expires ?max_age ?domain ?path ?secure ?http_only ?same_site
+ name value =
let expires =
match Option.bind expires Ptime.of_float_s with
| None -> ""
| Some time ->
let weekday =
match Ptime.weekday time with
- | `Sun -> "Sun" | `Mon -> "Mon" | `Tue -> "Tue" | `Wed -> "Wed"
- | `Thu -> "Thu" | `Fri -> "Fri" | `Sat -> "Sat"
+ | `Sun -> "Sun"
+ | `Mon -> "Mon"
+ | `Tue -> "Tue"
+ | `Wed -> "Wed"
+ | `Thu -> "Thu"
+ | `Fri -> "Fri"
+ | `Sat -> "Sat"
in
- let ((y, m, d), ((hh, mm, ss), _tz_offset_s)) = Ptime.to_date_time time in
+ let (y, m, d), ((hh, mm, ss), _tz_offset_s) = Ptime.to_date_time time in
let month =
match m with
- | 1 -> "Jan" | 2 -> "Feb" | 3 -> "Mar" | 4 -> "Apr" | 5 -> "May"
- | 6 -> "Jun" | 7 -> "Jul" | 8 -> "Aug" | 9 -> "Sep" | 10 -> "Oct"
- | 11 -> "Nov" | 12 -> "Dec"
+ | 1 -> "Jan"
+ | 2 -> "Feb"
+ | 3 -> "Mar"
+ | 4 -> "Apr"
+ | 5 -> "May"
+ | 6 -> "Jun"
+ | 7 -> "Jul"
+ | 8 -> "Aug"
+ | 9 -> "Sep"
+ | 10 -> "Oct"
+ | 11 -> "Nov"
+ | 12 -> "Dec"
| _ -> assert false
in
(* [Ptime.to_date_time] docs give range 0..60 for [ss], accounting for
@@ -82,11 +90,9 @@ let to_set_cookie
Even though [Ptime.to_date_time] time does not return leap seconds, in
case I misunderstood the gmtime API, of system differences, or future
refactoring, make sure no leap seconds creep into the output. *)
- let seconds =
- if ss < 60 then ss else 59 [@coverage off]
- in
- Printf.sprintf "; Expires=%s, %02i %s %i %02i:%02i:%02i GMT"
- weekday d month y hh mm seconds
+ let seconds = if ss < 60 then ss else (59 [@coverage off]) in
+ Printf.sprintf "; Expires=%s, %02i %s %i %02i:%02i:%02i GMT" weekday d
+ month y hh mm seconds
in
let max_age =
@@ -127,32 +133,26 @@ let to_set_cookie
| Some `None -> "; SameSite=None"
in
- Printf.sprintf "%s=%s%s%s%s%s%s%s%s"
- name value expires max_age domain path secure http_only same_site
-
+ Printf.sprintf "%s=%s%s%s%s%s%s%s%s" name value expires max_age domain path
+ secure http_only same_site
-
-let iri_safe_octets =
- String.init 128 (fun i -> Char.chr (i + 128))
-
-let iri_generic =
- `Custom (`Generic, iri_safe_octets, "")
+let iri_safe_octets = String.init 128 (fun i -> Char.chr (i + 128))
+let iri_generic = `Custom (`Generic, iri_safe_octets, "")
let to_percent_encoded ?(international = true) string =
let component =
- if international then iri_generic
- else `Generic
+ if international then
+ iri_generic
+ else
+ `Generic
in
Uri.pct_encode ~component string
-let from_percent_encoded string =
- Uri.pct_decode string
-
-
+let from_percent_encoded string = Uri.pct_decode string
let to_form_urlencoded dictionary =
dictionary
- |> List.map (fun (name, value) -> name, [value])
+ |> List.map (fun (name, value) -> (name, [value]))
|> Uri.encoded_of_query
let from_form_urlencoded string =
@@ -161,9 +161,7 @@ let from_form_urlencoded string =
else
string
|> Uri.query_of_encoded
- |> List.map (fun (name, values) -> name, String.concat "," values)
-
-
+ |> List.map (fun (name, values) -> (name, String.concat "," values))
let split_target string =
let uri = Uri.of_string string in
@@ -172,15 +170,15 @@ let split_target string =
| Some query -> query
| None -> ""
in
- Uri.path uri, query
+ (Uri.path uri, query)
let from_path =
(* Not tail-recursive. *)
let rec filter_components = function
| [] -> []
| [""] as components -> components
- | ""::components -> filter_components components
- | component::components -> component::(filter_components components)
+ | "" :: components -> filter_components components
+ | component :: components -> component :: filter_components components
in
fun string ->
@@ -200,21 +198,20 @@ let from_path =
let rec drop_trailing_slash = function
| [] -> []
| [""] -> []
- | component::components ->
- component::(drop_trailing_slash components)
+ | component :: components -> component :: drop_trailing_slash components
let to_path ?(relative = false) ?(international = true) components =
let rec filter_empty_components = function
- | ""::(_::_ as path) -> filter_empty_components path
- | component::path -> component::(filter_empty_components path)
+ | "" :: (_ :: _ as path) -> filter_empty_components path
+ | component :: path -> component :: filter_empty_components path
| [] -> []
in
let components = filter_empty_components components in
let components =
- match relative, components with
+ match (relative, components) with
| false, [] -> [""; ""]
- | false, _ -> ""::components
+ | false, _ -> "" :: components
| true, _ -> components
in
@@ -222,10 +219,5 @@ let to_path ?(relative = false) ?(international = true) components =
|> List.map (to_percent_encoded ~international)
|> String.concat "/"
-
-
-let text_html =
- "text/html; charset=utf-8"
-
-let application_json =
- "application/json"
+let text_html = "text/html; charset=utf-8"
+let application_json = "application/json"
File "src/pure/formats.mli", line 1, characters 0-0:
diff --git a/_build/default/src/pure/formats.mli b/_build/default/src/pure/.formatted/formats.mli
index b06fa5e..9e813af 100644
--- a/_build/default/src/pure/formats.mli
+++ b/_build/default/src/pure/.formatted/formats.mli
@@ -3,12 +3,8 @@
Copyright 2021 Anton Bachin *)
-
-
(* Note: this is not a stable API! *)
-
-
val html_escape : string -> string
val to_base64url : string -> string
val from_base64url : string -> string option
@@ -31,5 +27,7 @@ val to_set_cookie :
?path:string ->
?secure:bool ->
?http_only:bool ->
- ?same_site:[ `Strict | `Lax | `None ] ->
- string -> string -> string
+ ?same_site:[`Strict | `Lax | `None] ->
+ string ->
+ string ->
+ string
File "src/pure/message.mli", line 1, characters 0-0:
diff --git a/_build/default/src/pure/message.mli b/_build/default/src/pure/.formatted/message.mli
index b05da05..3f33e6c 100644
--- a/_build/default/src/pure/message.mli
+++ b/_build/default/src/pure/.formatted/message.mli
@@ -3,52 +3,40 @@
Copyright 2021 Anton Bachin *)
-
-
(* Note: this is not a stable API! *)
-
-
type client
type server
type 'a message
type request = client message
type response = server message
-
type 'a promise = 'a Lwt.t
type handler = request -> response promise
type middleware = handler -> handler
-
-
val request :
- ?method_:[< Method.method_ ] ->
+ ?method_:[< Method.method_] ->
?target:string ->
?headers:(string * string) list ->
Stream.stream ->
Stream.stream ->
- request
+ request
val method_ : request -> Method.method_
val target : request -> string
-val set_method_ : request -> [< Method.method_ ] -> unit
+val set_method_ : request -> [< Method.method_] -> unit
val set_target : request -> string -> unit
-
-
val response :
- ?status:[< Status.status ] ->
+ ?status:[< Status.status] ->
?code:int ->
?headers:(string * string) list ->
Stream.stream ->
Stream.stream ->
- response
+ response
val status : response -> Status.status
val set_status : response -> Status.status -> unit
-
-
-
val header : 'a message -> string -> string option
val headers : 'a message -> string -> string list
val all_headers : 'a message -> (string * string) list
@@ -59,16 +47,10 @@ val set_header : 'a message -> string -> string -> unit
val set_all_headers : 'a message -> (string * string) list -> unit
val sort_headers : (string * string) list -> (string * string) list
val lowercase_headers : 'a message -> unit
-
-
-
val body : 'a message -> string promise
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
@@ -77,43 +59,36 @@ val client_stream : 'a message -> Stream.stream
val server_stream : 'a message -> Stream.stream
val set_client_stream : 'a message -> Stream.stream -> unit
val set_server_stream : 'a message -> Stream.stream -> unit
-
-
-
-val create_websocket : response -> (Stream.stream * Stream.stream)
+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
-type text_or_binary = [
- | `Text
- | `Binary
-]
+type text_or_binary =
+ [ `Text
+ | `Binary ]
-type end_of_message = [
- | `End_of_message
- | `Continues
-]
+type end_of_message =
+ [ `End_of_message
+ | `Continues ]
(* TODO This also needs message length limits. *)
-val receive :
- Stream.stream -> string option promise
+val receive : Stream.stream -> string option promise
+
val receive_fragment :
Stream.stream -> (string * text_or_binary * end_of_message) option promise
+
val send :
- ?text_or_binary:[< text_or_binary ] ->
- ?end_of_message:[< end_of_message ] ->
+ ?text_or_binary:[< text_or_binary] ->
+ ?end_of_message:[< end_of_message] ->
Stream.stream ->
string ->
- unit promise
-
-
+ unit promise
val no_middleware : middleware
val pipeline : middleware list -> middleware
-
-
type 'a field
+
val new_field : ?name:string -> ?show_value:('a -> string) -> unit -> 'a field
val field : 'b message -> 'a field -> 'a option
val set_field : 'b message -> 'a field -> 'a -> unit
File "src/pure/method.ml", line 1, characters 0-0:
diff --git a/_build/default/src/pure/method.ml b/_build/default/src/pure/.formatted/method.ml
index 38771e5..4ba4b5a 100644
--- a/_build/default/src/pure/method.ml
+++ b/_build/default/src/pure/.formatted/method.ml
@@ -3,16 +3,14 @@
Copyright 2021 Anton Bachin *)
-
-
(* See also:
- SEARCH, https://tools.ietf.org/html/draft-snell-search-method-02
- Other WebDAV methods: COPY, LOCK, MKCOL, MOVE, PROPFIND, PROPPATCH,
UNLOCK. *)
-type method_ = [
- | `GET
+type method_ =
+ [ `GET
| `POST
| `PUT
| `DELETE
@@ -21,8 +19,7 @@ type method_ = [
| `OPTIONS
| `TRACE
| `PATCH
- | `Method of string
-]
+ | `Method of string ]
let method_to_string = function
| `GET -> "GET"
File "src/pure/status.ml", line 1, characters 0-0:
diff --git a/_build/default/src/pure/status.ml b/_build/default/src/pure/.formatted/status.ml
index 677fc42..6300c64 100644
--- a/_build/default/src/pure/status.ml
+++ b/_build/default/src/pure/.formatted/status.ml
@@ -3,35 +3,30 @@
Copyright 2021 Anton Bachin *)
+type informational =
+ [ `Continue
+ | `Switching_Protocols ]
-
-type informational = [
- | `Continue
- | `Switching_Protocols
-]
-
-type successful = [
- | `OK
+type successful =
+ [ `OK
| `Created
| `Accepted
| `Non_Authoritative_Information
| `No_Content
| `Reset_Content
- | `Partial_Content
-]
+ | `Partial_Content ]
-type redirection = [
- | `Multiple_Choices
+type redirection =
+ [ `Multiple_Choices
| `Moved_Permanently
| `Found
| `See_Other
| `Not_Modified
| `Temporary_Redirect
- | `Permanent_Redirect
-]
+ | `Permanent_Redirect ]
-type client_error = [
- | `Bad_Request
+type client_error =
+ [ `Bad_Request
| `Unauthorized
| `Payment_Required
| `Forbidden
@@ -55,30 +50,26 @@ type client_error = [
| `Precondition_Required
| `Too_Many_Requests
| `Request_Header_Fields_Too_Large
- | `Unavailable_For_Legal_Reasons
-]
+ | `Unavailable_For_Legal_Reasons ]
-type server_error = [
- | `Internal_Server_Error
+type server_error =
+ [ `Internal_Server_Error
| `Not_Implemented
| `Bad_Gateway
| `Service_Unavailable
| `Gateway_Timeout
- | `HTTP_Version_Not_Supported
-]
+ | `HTTP_Version_Not_Supported ]
-type standard_status = [
- | informational
+type standard_status =
+ [ informational
| successful
| redirection
| client_error
- | server_error
-]
+ | server_error ]
-type status = [
- | standard_status
- | `Status of int
-]
+type status =
+ [ standard_status
+ | `Status of int ]
let is_informational = function
| #informational -> true
@@ -280,10 +271,11 @@ let status_to_reason status =
let status_to_string status =
let status = (status :> status) in
- match status_to_reason status, status with
+ match (status_to_reason status, status) with
| Some reason, _ -> reason
| None, `Status code -> string_of_int code
- | _ -> "Unknown" [@coverage off] (* Should be impossible. *)
+ | _ -> ("Unknown" [@coverage off])
+(* Should be impossible. *)
let normalize_status status =
match (status :> status) with
File "src/pure/stream.ml", line 1, characters 0-0:
diff --git a/_build/default/src/pure/stream.ml b/_build/default/src/pure/.formatted/stream.ml
index 72d121d..c16221c 100644
--- a/_build/default/src/pure/stream.ml
+++ b/_build/default/src/pure/.formatted/stream.ml
@@ -3,13 +3,10 @@
Copyright 2021 Anton Bachin *)
-
-
type buffer =
(char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
-type 'a promise =
- 'a Lwt.t
+type 'a promise = 'a Lwt.t
type read =
data:(buffer -> int -> int -> bool -> bool -> unit) ->
@@ -18,13 +15,9 @@ type read =
pong:(buffer -> int -> int -> unit) ->
close:(int -> unit) ->
exn:(exn -> unit) ->
- unit
+ unit
-type write =
- close:(int -> unit) ->
- exn:(exn -> unit) ->
- (unit -> unit) ->
- unit
+type write = close:(int -> unit) -> exn:(exn -> unit) -> (unit -> unit) -> unit
type reader = {
read : read;
@@ -46,59 +39,43 @@ type stream = {
writer : writer;
}
-let stream reader writer =
- {reader; writer}
-
-let no_reader = {
- read =
- (fun ~data:_ ~flush:_ ~ping:_ ~pong:_ ~close:_ ~exn:_ ->
- raise (Failure "read from a non-readable stream"));
- close =
- ignore;
- abort =
- ignore;
-}
+let stream reader writer = { reader; writer }
-let no_writer = {
- data =
- (fun _buffer _offset _length _binary _fin ~close:_ ~exn:_ _ok ->
- raise (Failure "write to a read-only stream"));
- flush =
- (fun ~close:_ ~exn:_ _ok ->
- raise (Failure "flush of a read-only stream"));
- ping =
- (fun _buffer _offset _length ~close:_ ~exn:_ _ok ->
- raise (Failure "ping on a read-only stream"));
- pong =
- (fun _buffer _offset _length ~close:_ ~exn:_ _ok ->
- raise (Failure "pong on a read-only stream"));
- close =
- ignore;
- abort =
- ignore;
-}
+let no_reader =
+ {
+ read =
+ (fun ~data:_ ~flush:_ ~ping:_ ~pong:_ ~close:_ ~exn:_ ->
+ raise (Failure "read from a non-readable stream"));
+ close = ignore;
+ abort = ignore;
+ }
-let reader ~read ~close ~abort = {
- read;
- close;
- abort;
-}
+let no_writer =
+ {
+ data =
+ (fun _buffer _offset _length _binary _fin ~close:_ ~exn:_ _ok ->
+ raise (Failure "write to a read-only stream"));
+ flush =
+ (fun ~close:_ ~exn:_ _ok -> raise (Failure "flush of a read-only stream"));
+ ping =
+ (fun _buffer _offset _length ~close:_ ~exn:_ _ok ->
+ raise (Failure "ping on a read-only stream"));
+ pong =
+ (fun _buffer _offset _length ~close:_ ~exn:_ _ok ->
+ raise (Failure "pong on a read-only stream"));
+ close = ignore;
+ abort = ignore;
+ }
-let null = {
- reader = no_reader;
- writer = no_writer;
-}
+let reader ~read ~close ~abort = { read; close; abort }
+let null = { reader = no_reader; writer = no_writer }
let empty_reader =
reader
~read:(fun ~data:_ ~flush:_ ~ping:_ ~pong:_ ~close ~exn:_ -> close 1000)
- ~close:ignore
- ~abort:ignore
+ ~close:ignore ~abort:ignore
-let empty = {
- reader = empty_reader;
- writer = no_writer;
-}
+let empty = { reader = empty_reader; writer = no_writer }
(* TODO This shows the awkwardness in string-to-string body reading. *)
let string_reader the_string =
@@ -109,9 +86,8 @@ let string_reader the_string =
let read ~data ~flush:_ ~ping:_ ~pong:_ ~close ~exn =
match !exn_ref with
- | Some the_exn ->
- exn the_exn
- | None ->
+ | Some the_exn -> exn the_exn
+ | None -> (
match !string_ref with
| Some stored_string ->
string_ref := None;
@@ -119,13 +95,10 @@ let string_reader the_string =
data
(Bigstringaf.of_string ~off:0 ~len:length stored_string)
0 length true true
- | None ->
- close 1000
+ | None -> close 1000)
in
- let close _code =
- string_ref := None
- in
+ let close _code = string_ref := None in
let abort exn =
string_ref := None;
@@ -138,10 +111,7 @@ let string the_string =
if String.length the_string = 0 then
empty
else
- {
- reader = string_reader the_string;
- writer = no_writer;
- }
+ { reader = string_reader the_string; writer = no_writer }
let read stream ~data ~flush ~ping ~pong ~close ~exn =
stream.reader.read ~data ~flush ~ping ~pong ~close ~exn
@@ -157,8 +127,7 @@ let abort stream exn =
let write stream buffer offset length binary fin ~close ~exn ok =
stream.writer.data buffer offset length binary fin ~close ~exn ok
-let flush stream ~close ~exn ok =
- stream.writer.flush ~close ~exn ok
+let flush stream ~close ~exn ok = stream.writer.flush ~close ~exn ok
let ping stream buffer offset length ~close ~exn ok =
stream.writer.ping buffer offset length ~close ~exn ok
@@ -170,30 +139,22 @@ let pong stream buffer offset length ~close ~exn ok =
is already queued, and add tests for this. This should be done after ping
and pong get their separate queues. *)
type pipe = {
- mutable state : [
- | `Idle
- | `Reader_waiting
- | `Closed of int
- | `Aborted of exn
- ];
-
+ mutable state : [`Idle | `Reader_waiting | `Closed of int | `Aborted of exn];
mutable read_data_callback : buffer -> int -> int -> bool -> bool -> unit;
mutable read_flush_callback : unit -> unit;
mutable read_ping_callback : buffer -> int -> int -> unit;
mutable read_pong_callback : buffer -> int -> int -> unit;
mutable read_close_callback : int -> unit;
mutable read_abort_callback : exn -> unit;
-
mutable write_ok_callback : unit -> unit;
mutable write_close_callback : int -> unit;
mutable write_abort_callback : exn -> unit;
}
let dummy_read_data_callback _buffer _offset _length _binary _fin =
- () [@coverage off]
+ (() [@coverage off])
-let dummy_ping_pong_callback _buffer _offset _length =
- () [@coverage off]
+let dummy_ping_pong_callback _buffer _offset _length = (() [@coverage off])
let clean_up_reader_fields pipe =
pipe.read_data_callback <- dummy_read_data_callback;
@@ -209,20 +170,20 @@ let clean_up_writer_fields pipe =
pipe.write_abort_callback <- ignore
let pipe () =
- let internal = {
- state = `Idle;
-
- read_data_callback = dummy_read_data_callback;
- read_flush_callback = ignore;
- read_ping_callback = dummy_ping_pong_callback;
- read_pong_callback = dummy_ping_pong_callback;
- read_close_callback = ignore;
- read_abort_callback = ignore;
-
- write_ok_callback = ignore;
- write_close_callback = ignore;
- write_abort_callback = ignore;
- } in
+ let internal =
+ {
+ state = `Idle;
+ read_data_callback = dummy_read_data_callback;
+ read_flush_callback = ignore;
+ read_ping_callback = dummy_ping_pong_callback;
+ read_pong_callback = dummy_ping_pong_callback;
+ read_close_callback = ignore;
+ read_abort_callback = ignore;
+ write_ok_callback = ignore;
+ write_close_callback = ignore;
+ write_abort_callback = ignore;
+ }
+ in
let read ~data ~flush ~ping ~pong ~close ~exn =
match internal.state with
@@ -239,17 +200,15 @@ let pipe () =
write_ok_callback ()
| `Reader_waiting ->
raise (Failure "stream read: the previous read has not completed")
- | `Closed code ->
- close code
- | `Aborted the_exn ->
- exn the_exn
+ | `Closed code -> close code
+ | `Aborted the_exn -> exn the_exn
in
let rec data buffer offset length binary fin ~close ~exn ok =
match internal.state with
| `Idle ->
- internal.write_ok_callback <- (fun () ->
- data buffer offset length binary fin ~close ~exn ok);
+ internal.write_ok_callback <-
+ (fun () -> data buffer offset length binary fin ~close ~exn ok);
internal.write_close_callback <- close;
internal.write_abort_callback <- exn
| `Reader_waiting ->
@@ -258,17 +217,14 @@ let pipe () =
clean_up_reader_fields internal;
read_data_callback buffer offset length binary fin;
ok ()
- | `Closed code ->
- close code
- | `Aborted the_exn ->
- exn the_exn
+ | `Closed code -> close code
+ | `Aborted the_exn -> exn the_exn
in
let rec flush ~close ~exn ok =
match internal.state with
| `Idle ->
- internal.write_ok_callback <- (fun () ->
- flush ~close ~exn ok);
+ internal.write_ok_callback <- (fun () -> flush ~close ~exn ok);
internal.write_close_callback <- close;
internal.write_abort_callback <- exn
| `Reader_waiting ->
@@ -277,17 +233,15 @@ let pipe () =
clean_up_reader_fields internal;
read_flush_callback ();
ok ()
- | `Closed code ->
- close code
- | `Aborted the_exn ->
- exn the_exn
+ | `Closed code -> close code
+ | `Aborted the_exn -> exn the_exn
in
let rec ping buffer offset length ~close ~exn ok =
match internal.state with
| `Idle ->
- internal.write_ok_callback <- (fun () ->
- ping buffer offset length ~close ~exn ok);
+ internal.write_ok_callback <-
+ (fun () -> ping buffer offset length ~close ~exn ok);
internal.write_close_callback <- close;
internal.write_abort_callback <- exn
| `Reader_waiting ->
@@ -296,17 +250,15 @@ let pipe () =
clean_up_reader_fields internal;
read_ping_callback buffer offset length;
ok ()
- | `Closed code ->
- close code
- | `Aborted the_exn ->
- exn the_exn
+ | `Closed code -> close code
+ | `Aborted the_exn -> exn the_exn
in
let rec pong buffer offset length ~close ~exn ok =
match internal.state with
| `Idle ->
- internal.write_ok_callback <- (fun () ->
- pong buffer offset length ~close ~exn ok);
+ internal.write_ok_callback <-
+ (fun () -> pong buffer offset length ~close ~exn ok);
internal.write_close_callback <- close;
internal.write_abort_callback <- exn
| `Reader_waiting ->
@@ -315,10 +267,8 @@ let pipe () =
clean_up_reader_fields internal;
read_pong_callback buffer offset length;
ok ()
- | `Closed code ->
- close code
- | `Aborted the_exn ->
- exn the_exn
+ | `Closed code -> close code
+ | `Aborted the_exn -> exn the_exn
in
let close code =
@@ -333,10 +283,8 @@ let pipe () =
let read_close_callback = internal.read_close_callback in
clean_up_reader_fields internal;
read_close_callback code
- | `Closed _code ->
- ()
- | `Aborted _the_exn ->
- ()
+ | `Closed _code -> ()
+ | `Aborted _the_exn -> ()
in
let abort exn =
@@ -351,25 +299,12 @@ let pipe () =
let read_abort_callback = internal.read_abort_callback in
clean_up_reader_fields internal;
read_abort_callback exn
- | `Closed _code ->
- ()
- | `Aborted _the_exn ->
- ()
+ | `Closed _code -> ()
+ | `Aborted _the_exn -> ()
in
- let reader = {
- read;
- close;
- abort;
- }
- and writer = {
- data;
- flush;
- ping;
- pong;
- close;
- abort;
- } in
+ let reader = { read; close; abort }
+ and writer = { data; flush; ping; pong; close; abort } in
(reader, writer)
@@ -377,21 +312,17 @@ let forward (reader : reader) stream =
let rec loop () =
reader.read
~data:(fun buffer offset length binary fin ->
- stream.writer.data
- buffer offset length
- binary fin
- ~close:reader.close ~exn:reader.abort
- loop)
+ stream.writer.data buffer offset length binary fin ~close:reader.close
+ ~exn:reader.abort loop)
~flush:(fun () ->
stream.writer.flush ~close:reader.close ~exn:reader.abort loop)
~ping:(fun buffer offset length ->
- stream.writer.ping
- buffer offset length ~close:reader.close ~exn:reader.abort loop)
+ stream.writer.ping buffer offset length ~close:reader.close
+ ~exn:reader.abort loop)
~pong:(fun buffer offset length ->
- stream.writer.pong
- buffer offset length ~close:reader.close ~exn:reader.abort loop)
- ~close:stream.writer.close
- ~exn:stream.writer.abort
+ stream.writer.pong buffer offset length ~close:reader.close
+ ~exn:reader.abort loop)
+ ~close:stream.writer.close ~exn:stream.writer.abort
in
loop ()
@@ -407,18 +338,11 @@ let read_convenience stream =
|> Bigstringaf.to_string
|> Option.some
|> Lwt.wakeup_later resolver)
-
~flush:loop
-
~ping:(fun buffer offset length ->
stream.writer.pong buffer offset length ~close ~exn:abort loop)
-
- ~pong:(fun _buffer _offset _length ->
- loop ())
-
- ~close
-
- ~exn:abort
+ ~pong:(fun _buffer _offset _length -> loop ())
+ ~close ~exn:abort
in
loop ();
@@ -444,28 +368,20 @@ let read_until_close stream =
if new_length > Bigstringaf.length !buffer then begin
let new_buffer = Bigstringaf.create (new_length * 2) in
- Bigstringaf.blit
- !buffer ~src_off:0 new_buffer ~dst_off:0 ~len:!length;
+ Bigstringaf.blit !buffer ~src_off:0 new_buffer ~dst_off:0 ~len:!length;
buffer := new_buffer
end;
- Bigstringaf.blit
- chunk ~src_off:offset !buffer ~dst_off:!length ~len:chunk_length;
+ Bigstringaf.blit chunk ~src_off:offset !buffer ~dst_off:!length
+ ~len:chunk_length;
length := new_length;
loop ())
-
~flush:loop
-
~ping:(fun buffer offset length ->
stream.writer.pong buffer offset length ~close ~exn:abort loop)
-
- ~pong:(fun _buffer _offset _length ->
- loop ())
-
- ~close
-
- ~exn:abort
+ ~pong:(fun _buffer _offset _length -> loop ())
+ ~close ~exn:abort
in
loop ();
File "src/pure/stream.mli", line 1, characters 0-0:
diff --git a/_build/default/src/pure/stream.mli b/_build/default/src/pure/.formatted/stream.mli
index fa4814e..df62ca5 100644
--- a/_build/default/src/pure/stream.mli
+++ b/_build/default/src/pure/.formatted/stream.mli
@@ -3,20 +3,16 @@
Copyright 2021 Anton Bachin *)
-
-
(* Note: this is not a stable API! *)
-
-
type reader
type writer
type stream
type buffer =
(char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
-type 'a promise =
- 'a Lwt.t
+
+type 'a promise = 'a Lwt.t
type read =
data:(buffer -> int -> int -> bool -> bool -> unit) ->
@@ -25,16 +21,12 @@ type read =
pong:(buffer -> int -> int -> unit) ->
close:(int -> unit) ->
exn:(exn -> unit) ->
- unit
+ unit
(** A reading function. Awaits the next event on the stream. For each call of a
reading function, one of the callbacks will eventually be called, according
to which event occurs next on the stream. *)
-type write =
- close:(int -> unit) ->
- exn:(exn -> unit) ->
- (unit -> unit) ->
- unit
+type write = close:(int -> unit) -> exn:(exn -> unit) -> (unit -> unit) -> unit
(** A writing function. Pushes an event into a stream. May take additional
arguments before [~ok]. *)
@@ -49,11 +41,8 @@ val pipe : unit -> reader * writer
the reader to call its [~flush] callback. *)
val forward : reader -> stream -> unit
-
val no_reader : reader
-
val no_writer : writer
-
val stream : reader -> writer -> stream
(* TODO Consider tupling the arguments, as that will make it easier to pass the
result of Stream.pipe. *)
File "docs/web/postprocess/common.ml", line 1, characters 0-0:
diff --git a/_build/default/docs/web/postprocess/common.ml b/_build/default/docs/web/postprocess/.formatted/common.ml
index ae90059..8468026 100644
--- a/_build/default/docs/web/postprocess/common.ml
+++ b/_build/default/docs/web/postprocess/.formatted/common.ml
@@ -3,8 +3,6 @@
Copyright 2021 Anton Bachin *)
-
-
open Soup.Infix
let if_expected expected test f =
@@ -19,11 +17,10 @@ let if_expected expected test f =
let add_backing_lines soup =
let add_backing_line element =
- Soup.create_element ~class_:"backing" "div"
- |> Soup.prepend_child element
+ Soup.create_element ~class_:"backing" "div" |> Soup.prepend_child element
in
soup $$ "h2" |> Soup.iter add_backing_line;
soup $$ "h3" |> Soup.iter add_backing_line;
soup $$ ".spec[id]" |> Soup.iter add_backing_line;
- Soup.prepend_child
- (soup $ ".odoc-content") (Soup.create_element ~class_:"background" "div")
+ Soup.prepend_child (soup $ ".odoc-content")
+ (Soup.create_element ~class_:"background" "div")
File "src/eml/main.ml", line 1, characters 0-0:
diff --git a/_build/default/src/eml/main.ml b/_build/default/src/eml/.formatted/main.ml
index 7f11a3a..39ad267 100644
--- a/_build/default/src/eml/main.ml
+++ b/_build/default/src/eml/.formatted/main.ml
@@ -3,38 +3,30 @@
Copyright 2021 Anton Bachin *)
-
-
-module Command_line :
-sig
- val parse : unit -> (string * string * [ `OCaml | `Reason ]) list
-end =
-struct
+module Command_line : sig
+ val parse : unit -> (string * string * [`OCaml | `Reason]) list
+end = struct
let usage = {|Usage:
eml FILE
|}
- let input_files =
- ref []
-
- let workspace_path =
- ref ""
-
- let emit_reason =
- ref false
+ let input_files = ref []
+ let workspace_path = ref ""
+ let emit_reason = ref false
- let options = Arg.align [
- "--workspace",
- Arg.Set_string workspace_path,
- "PATH Relative path to the Dune workspace for better locations";
- "--emit-reason",
- Arg.Set emit_reason,
- " Emit Reason syntax after preprocessing the template";
- ]
+ let options =
+ Arg.align
+ [
+ ( "--workspace",
+ Arg.Set_string workspace_path,
+ "PATH Relative path to the Dune workspace for better locations" );
+ ( "--emit-reason",
+ Arg.Set emit_reason,
+ " Emit Reason syntax after preprocessing the template" );
+ ]
- let set_file file =
- input_files := file::!input_files
+ let set_file file = input_files := file :: !input_files
let parse () =
Arg.parse options set_file usage;
@@ -53,8 +45,7 @@ struct
(Filename.dirname location)
(Filename.concat directory prefix)
(Filename.dirname path)
- | "" | "." ->
- prefix
+ | "" | "." -> prefix
| s ->
prerr_endline s;
Printf.ksprintf failwith
@@ -65,15 +56,16 @@ struct
input_files
|> List.map (fun file ->
- let syntax = if !emit_reason then `Reason else
- (* If there was no explicit command line argument, decide using file extension *)
- match Filename.extension file with
- | ".re" -> `Reason
- | _ -> `OCaml
- in
- file, Filename.concat prefix file, syntax)
+ let syntax =
+ if !emit_reason then
+ `Reason
+ else
+ (* If there was no explicit command line argument, decide using file extension *)
+ match Filename.extension file with
+ | ".re" -> `Reason
+ | _ -> `OCaml
+ in
+ (file, Filename.concat prefix file, syntax))
end
-let () =
- Command_line.parse ()
- |> List.iter Eml.process_file
+let () = Command_line.parse () |> List.iter Eml.process_file
File "src/cipher/cipher.ml", line 1, characters 0-0:
diff --git a/_build/default/src/cipher/cipher.ml b/_build/default/src/cipher/.formatted/cipher.ml
index 9eaaabc..dfc86bf 100644
--- a/_build/default/src/cipher/cipher.ml
+++ b/_build/default/src/cipher/.formatted/cipher.ml
@@ -3,27 +3,18 @@
Copyright 2021 Anton Bachin *)
-
-
(* TODO Review all | exception cases in all code and avoid them as much sa
possible. *)
(* TODO Support mixture of encryption and signing. *)
(* TODO LATER Switch to AEAD_AES_256_GCM_SIV. See
https://github.com/mirage/mirage-crypto/issues/111. *)
-
-
module Message = Dream_pure.Message
-
-
-module type Cipher =
-sig
+module type Cipher = sig
val prefix : char
val name : string
-
- val encrypt :
- ?associated_data:string -> secret:string -> string -> string
+ val encrypt : ?associated_data:string -> secret:string -> string -> string
val decrypt :
?associated_data:string -> secret:string -> string -> string option
@@ -35,20 +26,18 @@ end
let encrypt (module Cipher : Cipher) ?associated_data secret plaintext =
Cipher.encrypt ?associated_data ~secret plaintext
-let rec decrypt
- ((module Cipher : Cipher) as cipher) ?associated_data secrets ciphertext =
-
+let rec decrypt ((module Cipher : Cipher) as cipher) ?associated_data secrets
+ ciphertext =
match secrets with
| [] -> None
- | secret::secrets ->
+ | secret :: secrets -> (
match Cipher.decrypt ?associated_data ~secret ciphertext with
| Some _ as plaintext -> plaintext
- | None -> decrypt cipher secrets ciphertext
+ | None -> decrypt cipher secrets ciphertext)
(* Key is good for ~2.5 years if every request e.g. generates one new signed
cookie, and the installation is doing 1000 requests per second. *)
-module AEAD_AES_256_GCM =
-struct
+module AEAD_AES_256_GCM = struct
(* Enciphered messages are prefixed with a version. There is only one right
now, version 0, in which the rest of the message consists of:
@@ -61,12 +50,11 @@ struct
See https://tools.ietf.org/html/rfc5116. *)
(* TODO Move this check to the envelope loop. *)
- let prefix =
- '\x00'
+ let prefix = '\x00'
let name =
- "AEAD_AES_256_GCM, " ^
- "mirage-crypto, key: SHA-256, nonce: 96 bits mirage-crypto-rng"
+ "AEAD_AES_256_GCM, "
+ ^ "mirage-crypto, key: SHA-256, nonce: 96 bits mirage-crypto-rng"
let derive_key secret =
secret
@@ -79,48 +67,42 @@ struct
let key = derive_key secret in
let adata = Option.map Cstruct.of_string associated_data in
let ciphertext =
- Mirage_crypto.Cipher_block.AES.GCM.authenticate_encrypt
- ~key
- ~nonce
- ?adata
+ Mirage_crypto.Cipher_block.AES.GCM.authenticate_encrypt ~key ~nonce ?adata
(Cstruct.of_string plaintext)
|> Cstruct.to_string
in
- "\x00" ^ (Cstruct.to_string nonce) ^ ciphertext
+ "\x00" ^ Cstruct.to_string nonce ^ ciphertext
let encrypt ?associated_data ~secret plaintext =
- encrypt_with_nonce
- secret (Random.random_buffer 12) plaintext associated_data
+ encrypt_with_nonce secret (Random.random_buffer 12) plaintext
+ associated_data
let test_encrypt ?associated_data ~secret ~nonce plaintext =
- encrypt_with_nonce
- secret (Cstruct.of_string nonce) plaintext associated_data
+ encrypt_with_nonce secret (Cstruct.of_string nonce) plaintext
+ associated_data
let decrypt ?associated_data ~secret ciphertext =
let key = derive_key secret in
if String.length ciphertext < 14 then
None
+ else if ciphertext.[0] != prefix then
+ None
else
- if ciphertext.[0] != prefix then
- None
- else
- let adata = Option.map Cstruct.of_string associated_data in
- let plaintext =
- Mirage_crypto.Cipher_block.AES.GCM.authenticate_decrypt
- ~key
- ~nonce:(Cstruct.of_string ~off:1 ~len:12 ciphertext)
- ?adata
- (Cstruct.of_string ciphertext ~off:13)
- in
- match plaintext with
- | None -> None
- | Some plaintext -> Some (Cstruct.to_string plaintext)
+ let adata = Option.map Cstruct.of_string associated_data in
+ let plaintext =
+ Mirage_crypto.Cipher_block.AES.GCM.authenticate_decrypt ~key
+ ~nonce:(Cstruct.of_string ~off:1 ~len:12 ciphertext)
+ ?adata
+ (Cstruct.of_string ciphertext ~off:13)
+ in
+ match plaintext with
+ | None -> None
+ | Some plaintext -> Some (Cstruct.to_string plaintext)
end
let secrets_field =
- Message.new_field
- ~name:"dream.secret"
+ Message.new_field ~name:"dream.secret"
~show_value:(fun _secrets -> "[redacted]")
()
@@ -129,13 +111,12 @@ let secrets_field =
warnings might be pretty spammy. *)
(* TODO Update examples and docs. *)
let set_secret ?(old_secrets = []) secret =
- let value = secret::old_secrets in
+ let value = secret :: old_secrets in
fun next_handler request ->
Message.set_field request secrets_field value;
next_handler request
-let fallback_secrets =
- lazy [Random.random 32]
+let fallback_secrets = lazy [Random.random 32]
let encryption_secret request =
match Message.field request secrets_field with
File "src/cipher/random.ml", line 1, characters 0-0:
diff --git a/_build/default/src/cipher/random.ml b/_build/default/src/cipher/.formatted/random.ml
index 7d104e7..f4a09dd 100644
--- a/_build/default/src/cipher/random.ml
+++ b/_build/default/src/cipher/.formatted/random.ml
@@ -3,8 +3,6 @@
Copyright 2021 Anton Bachin *)
-
-
(* TODO LATER Is there something with lighter dependencies? Although perhaps
these are not so bad... *)
@@ -18,8 +16,7 @@ let initialized () =
let initialize f = _initialized := Some (Lazy.from_fun f)
let random_buffer n =
- initialized () ;
+ initialized ();
Mirage_crypto_rng.generate n
-let random n =
- Cstruct.to_string (random_buffer n)
+let random n = Cstruct.to_string (random_buffer n)
File "src/http/shared/websocket.ml", line 1, characters 0-0:
diff --git a/_build/default/src/http/shared/websocket.ml b/_build/default/src/http/shared/.formatted/websocket.ml
index 0d4f675..44597f4 100644
--- a/_build/default/src/http/shared/websocket.ml
+++ b/_build/default/src/http/shared/.formatted/websocket.ml
@@ -3,12 +3,8 @@
Copyright 2022 Anton Bachin *)
-
-
module Stream = Dream_pure.Stream
-
-
let websocket_handler stream socket =
(* Queue of received frames. There doesn't appear to be a nice way to achieve
backpressure with the current API of websocket/af, so that will have to be
@@ -22,14 +18,10 @@ let websocket_handler stream socket =
https://github.com/anmonteiro/websocketaf/issues/34. *)
let frame ~opcode ~is_fin ~len:_ payload =
match opcode with
- | `Connection_close ->
- push_frame (Some (`Close, payload))
- | `Ping ->
- push_frame (Some (`Ping, payload))
- | `Pong ->
- push_frame (Some (`Pong, payload))
- | `Other _ ->
- push_frame (Some (`Other, payload))
+ | `Connection_close -> push_frame (Some (`Close, payload))
+ | `Ping -> push_frame (Some (`Ping, payload))
+ | `Pong -> push_frame (Some (`Pong, payload))
+ | `Other _ -> push_frame (Some (`Other, payload))
| `Text ->
message_is_binary := `Text;
push_frame (Some (`Data (`Text, is_fin), payload))
@@ -40,8 +32,7 @@ let websocket_handler stream socket =
push_frame (Some (`Data (!message_is_binary, is_fin), payload))
in
- let eof () =
- push_frame None in
+ let eof () = push_frame None in
(* The reader retrieves the next frame. If it is a data frame, it keeps a
reference to the payload across multiple reader calls, until the payload is
@@ -54,6 +45,7 @@ let websocket_handler stream socket =
on the last chunk read. See
https://github.com/anmonteiro/websocketaf/issues/35. *)
let last_chunk = ref None in
+
(* TODO Review per-chunk allocations, including current_payload contents. *)
(* For control frames, the payload can be at most 125 bytes long. We assume
@@ -64,8 +56,7 @@ let websocket_handler stream socket =
let first_chunk_offset = ref 0 in
let first_chunk_length = ref 0 in
let rec drain_payload payload continuation =
- Websocketaf.Payload.schedule_read
- payload
+ Websocketaf.Payload.schedule_read payload
~on_read:(fun buffer ~off ~len ->
if not !first_chunk_received then begin
first_chunk := buffer;
@@ -76,7 +67,7 @@ let websocket_handler stream socket =
else
(* TODO How to integrate this thing with logging? *)
(* websocket_log.warning (fun log ->
- log "Received fragmented control frame"); *)
+ log "Received fragmented control frame"); *)
();
drain_payload payload continuation)
~on_eof:(fun () ->
@@ -98,46 +89,41 @@ let websocket_handler stream socket =
else
match !current_payload with
| None ->
- Lwt.on_success (Lwt_stream.get frames) begin function
- | None ->
- if not !closed then begin
- closed := true;
- close_code := 1005
- end;
- Websocketaf.Wsd.close socket;
- close !close_code
- | Some (`Close, payload) ->
- drain_payload payload @@ fun buffer offset length ->
- let code =
- if length < 2 then
- 1005
- else
- let high_byte = Char.code buffer.{offset}
- and low_byte = Char.code buffer.{offset + 1} in
- high_byte lsl 8 lor low_byte
- in
- if not !closed then
- close_code := code;
- close !close_code
- | Some (`Ping, payload) ->
- drain_payload payload @@
- ping
- | Some (`Pong, payload) ->
- drain_payload payload @@
- pong
- | Some (`Other, payload) ->
- drain_payload payload @@ fun _buffer _offset length ->
- ignore length; (* TODO log instead *)
- (* websocket_log.warning (fun log ->
- log "Unknown frame type with length %i" length); *)
- read ~data ~flush ~ping ~pong ~close ~exn
- | Some (`Data properties, payload) ->
- current_payload := Some (properties, payload);
- read ~data ~flush ~ping ~pong ~close ~exn
- end
+ Lwt.on_success (Lwt_stream.get frames) (function
+ | None ->
+ if not !closed then begin
+ closed := true;
+ close_code := 1005
+ end;
+ Websocketaf.Wsd.close socket;
+ close !close_code
+ | Some (`Close, payload) ->
+ drain_payload payload @@ fun buffer offset length ->
+ let code =
+ if length < 2 then
+ 1005
+ else
+ let high_byte = Char.code buffer.{offset}
+ and low_byte = Char.code buffer.{offset + 1} in
+ (high_byte lsl 8) lor low_byte
+ in
+ if not !closed then
+ close_code := code;
+ close !close_code
+ | Some (`Ping, payload) -> drain_payload payload @@ ping
+ | Some (`Pong, payload) -> drain_payload payload @@ pong
+ | Some (`Other, payload) ->
+ drain_payload payload @@ fun _buffer _offset length ->
+ ignore length;
+ (* TODO log instead *)
+ (* websocket_log.warning (fun log ->
+ log "Unknown frame type with length %i" length); *)
+ read ~data ~flush ~ping ~pong ~close ~exn
+ | Some (`Data properties, payload) ->
+ current_payload := Some (properties, payload);
+ read ~data ~flush ~ping ~pong ~close ~exn)
| Some ((binary, fin), payload) ->
- Websocketaf.Payload.schedule_read
- payload
+ Websocketaf.Payload.schedule_read payload
~on_read:(fun buffer ~off ~len ->
match !last_chunk with
| None ->
@@ -150,8 +136,7 @@ let websocket_handler stream socket =
~on_eof:(fun () ->
current_payload := None;
match !last_chunk with
- | None ->
- read ~data ~flush ~ping ~pong ~close ~exn
+ | None -> read ~data ~flush ~ping ~pong ~close ~exn
| Some (last_buffer, last_offset, last_length) ->
last_chunk := None;
let binary = binary = `Binary in
@@ -169,12 +154,11 @@ let websocket_handler stream socket =
in
let close code =
- if not !closed then begin
+ if not !closed then
(* TODO Really need to work out the "close handshake" and how it is
exposed in the Stream API. *)
(* closed := true; *)
Websocketaf.Wsd.close ~code:(`Other code) socket
- end
in
let abort _exn = close 1005 in
@@ -183,13 +167,12 @@ let websocket_handler stream socket =
Stream.forward reader stream;
let rec outgoing_loop () =
- Stream.read
- stream
+ Stream.read stream
~data:(fun buffer offset length binary _fin ->
(* Until https://github.com/anmonteiro/websocketaf/issues/33. *)
(* if not fin then
- websocket_log.error (fun log ->
- log "Non-FIN frames not yet supported"); *)
+ websocket_log.error (fun log ->
+ log "Non-FIN frames not yet supported"); *)
let kind = if binary then `Binary else `Text in
if !closed then
close !close_code
@@ -207,8 +190,8 @@ let websocket_handler stream socket =
raise (Failure "Ping payload cannot exceed 125 bytes");
(* See https://github.com/anmonteiro/websocketaf/issues/36. *)
(* if length > 0 then
- websocket_log.warning (fun log ->
- log "Ping with non-empty payload not yet supported"); *)
+ websocket_log.warning (fun log ->
+ log "Ping with non-empty payload not yet supported"); *)
if !closed then
close !close_code
else begin
@@ -222,24 +205,25 @@ let websocket_handler stream socket =
raise (Failure "Pong payload cannot exceed 125 bytes");
(* See https://github.com/anmonteiro/websocketaf/issues/36. *)
(* if length > 0 then
- websocket_log.warning (fun log ->
- log "Pong with non-empty payload not yet supported"); *)
+ websocket_log.warning (fun log ->
+ log "Pong with non-empty payload not yet supported"); *)
if !closed then
close !close_code
else begin
Websocketaf.Wsd.send_pong socket;
outgoing_loop ()
end)
- ~close
- ~exn:abort
+ ~close ~exn:abort
in
outgoing_loop ();
- Websocketaf.Websocket_connection.{frame; eof}
+ Websocketaf.Websocket_connection.{ frame; eof }
- (* TODO The equality between server and client input handlers is not
- exposed in the websocketaf API.
- https://github.com/anmonteiro/websocketaf/issues/39. *)
+(* TODO The equality between server and client input handlers is not
+ exposed in the websocketaf API.
+ https://github.com/anmonteiro/websocketaf/issues/39. *)
let client_websocket_handler :
- Stream.stream -> Websocketaf.Wsd.t ->
- Websocketaf.Websocket_connection.input_handlers = websocket_handler
+ Stream.stream ->
+ Websocketaf.Wsd.t ->
+ Websocketaf.Websocket_connection.input_handlers =
+ websocket_handler
File "src/server/catch.ml", line 1, characters 0-0:
diff --git a/_build/default/src/server/catch.ml b/_build/default/src/server/.formatted/catch.ml
index da550b7..98e35e7 100644
--- a/_build/default/src/server/catch.ml
+++ b/_build/default/src/server/.formatted/catch.ml
@@ -3,30 +3,13 @@
Copyright 2021 Anton Bachin *)
-
-
module Message = Dream_pure.Message
module Status = Dream_pure.Status
-
-
type error = {
- condition : [
- | `Response of Message.response
- | `String of string
- | `Exn of exn
- ];
- layer : [
- | `App
- | `HTTP
- | `HTTP2
- | `TLS
- | `WebSocket
- ];
- caused_by : [
- | `Server
- | `Client
- ];
+ condition : [`Response of Message.response | `String of string | `Exn of exn];
+ layer : [`App | `HTTP | `HTTP2 | `TLS | `WebSocket];
+ caused_by : [`Server | `Client];
request : Message.request option;
response : Message.response option;
client : string option;
@@ -42,54 +25,52 @@ 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 () -> next_handler request)
(fun response ->
let status = Message.status response in
(* TODO Overfull hbox. *)
- if Status.is_client_error status || Status.is_server_error status then begin
+ if Status.is_client_error status || Status.is_server_error status then
let caused_by, severity =
if Status.is_client_error status then
- `Client, `Warning
+ (`Client, `Warning)
else
- `Server, `Error
+ (`Server, `Error)
in
- let error = {
- condition = `Response response;
- layer = `App;
- caused_by;
- request = Some request;
- response = Some response;
- client = Some (Helpers.client request);
- severity = severity;
- will_send_response = true;
- } in
+ let error =
+ {
+ condition = `Response response;
+ layer = `App;
+ caused_by;
+ request = Some request;
+ response = Some response;
+ client = Some (Helpers.client request);
+ severity;
+ will_send_response = true;
+ }
+ in
error_handler error
- end
else
Lwt.return 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 ->
- let error = {
- condition = `Exn exn;
- layer = `App;
- caused_by = `Server;
- request = Some request;
- response = None;
- client = Some (Helpers.client request);
- severity = `Error;
- will_send_response = true;
- } in
+ (fun exn ->
+ let error =
+ {
+ condition = `Exn exn;
+ layer = `App;
+ caused_by = `Server;
+ request = Some request;
+ response = None;
+ client = Some (Helpers.client request);
+ severity = `Error;
+ will_send_response = true;
+ }
+ in
error_handler error)
File "src/server/cookie.ml", line 1, characters 0-0:
diff --git a/_build/default/src/server/cookie.ml b/_build/default/src/server/.formatted/cookie.ml
index 56e9b1e..8494d79 100644
--- a/_build/default/src/server/cookie.ml
+++ b/_build/default/src/server/.formatted/cookie.ml
@@ -3,14 +3,10 @@
Copyright 2021 Anton Bachin *)
-
-
module Cipher = Dream__cipher.Cipher
module Formats = Dream_pure.Formats
module Message = Dream_pure.Message
-
-
(* TODO LATER Optimize by caching the parsed cookies in a local key. *)
(* TODO LATER Can decide whether to accept multiple Cookie: headers based on
request version. But that would entail an actual middleware - is that worth
@@ -27,24 +23,17 @@ let all_cookies request =
|> List.flatten
let infer_cookie_prefix prefix domain path secure =
- match prefix, domain, path, secure with
- | Some (Some `Host), _, _, _ -> "__Host-"
- | Some (Some `Secure), _, _, _ -> "__Secure-"
- | Some None, _, _, _ -> ""
- | None, None, Some "/", true -> "__Host-"
- | None, _, _, true -> "__Secure-"
- | None, _, _, _ -> ""
+ match (prefix, domain, path, secure) with
+ | Some (Some `Host), _, _, _ -> "__Host-"
+ | Some (Some `Secure), _, _, _ -> "__Secure-"
+ | Some None, _, _, _ -> ""
+ | None, None, Some "/", true -> "__Host-"
+ | None, _, _, true -> "__Secure-"
+ | None, _, _, _ -> ""
(* TODO Some actual performance in the implementation. *)
-let cookie
- ?prefix:cookie_prefix
- ?decrypt:(decrypt_cookie = true)
- ?domain
- ?path
- ?secure
- request
- name =
-
+let cookie ?prefix:cookie_prefix ?decrypt:(decrypt_cookie = true) ?domain ?path
+ ?secure request name =
let path =
match path with
| Some path -> path
@@ -59,35 +48,22 @@ let cookie
let cookie_prefix = infer_cookie_prefix cookie_prefix domain path secure in
let name = cookie_prefix ^ name in
- let test = fun (name', _) -> name = name' in
+ let test (name', _) = name = name' in
match all_cookies request |> List.find_opt test with
| None -> None
- | Some (_, value) ->
+ | Some (_, value) -> (
if not decrypt_cookie then
Some value
else
match Formats.from_base64url value with
- | None ->
- None
+ | None -> None
| Some value ->
- Cipher.decrypt request value ~associated_data:("dream.cookie-" ^ name)
-
-let set_cookie
- ?prefix:cookie_prefix
- ?encrypt:(encrypt_cookie = true)
- ?expires
- ?max_age
- ?domain
- ?path
- ?secure
- ?(http_only = true)
- ?same_site
- response
- request
- name
- value =
+ Cipher.decrypt request value ~associated_data:("dream.cookie-" ^ name))
+let set_cookie ?prefix:cookie_prefix ?encrypt:(encrypt_cookie = true) ?expires
+ ?max_age ?domain ?path ?secure ?(http_only = true) ?same_site response
+ request name value =
(* TODO Need the site prefix, not the subsite prefix! *)
let path =
match path with
@@ -126,14 +102,13 @@ let set_cookie
in
let set_cookie =
- Formats.to_set_cookie
- ?expires ?max_age ?domain ?path ~secure ~http_only ?same_site name value
+ Formats.to_set_cookie ?expires ?max_age ?domain ?path ~secure ~http_only
+ ?same_site name value
in
Message.add_header response "Set-Cookie" set_cookie
-let drop_cookie
- ?prefix ?domain ?path ?secure ?http_only ?same_site response request name =
- set_cookie
- ?prefix ~encrypt:false ~expires:0. ?domain ?path ?secure ?http_only
+let drop_cookie ?prefix ?domain ?path ?secure ?http_only ?same_site response
+ request name =
+ set_cookie ?prefix ~encrypt:false ~expires:0. ?domain ?path ?secure ?http_only
?same_site response request name ""
File "src/server/csrf.ml", line 1, characters 0-0:
diff --git a/_build/default/src/server/csrf.ml b/_build/default/src/server/.formatted/csrf.ml
index 13da958..db404c5 100644
--- a/_build/default/src/server/csrf.ml
+++ b/_build/default/src/server/.formatted/csrf.ml
@@ -3,81 +3,72 @@
Copyright 2021 Anton Bachin *)
-
-
module Dream = Dream_pure
module Cipher = Dream__cipher.Cipher
-
-
-let field_name =
- "dream.csrf"
-
-let default_valid_for =
- 60. *. 60.
+let field_name = "dream.csrf"
+let default_valid_for = 60. *. 60.
let csrf_token ~now ?(valid_for = default_valid_for) request =
let now = now () in
- `Assoc [
- "session", `String (Session.session_label request);
- "expires_at", `Float (floor (now +. valid_for));
- ]
+ `Assoc
+ [
+ ("session", `String (Session.session_label request));
+ ("expires_at", `Float (floor (now +. valid_for)));
+ ]
|> Yojson.Basic.to_string
|> Cipher.encrypt ~associated_data:field_name request
|> Dream_pure.Formats.to_base64url
-let log =
- Log.sub_log field_name
+let log = Log.sub_log field_name
-type csrf_result = [
- | `Ok
+type csrf_result =
+ [ `Ok
| `Expired of float
| `Wrong_session
- | `Invalid
-]
+ | `Invalid ]
-let verify_csrf_token ~now request token = Lwt.return @@
+let verify_csrf_token ~now request token =
+ Lwt.return
+ @@
match Dream_pure.Formats.from_base64url token with
| None ->
log.warning (fun log -> log ~request "CSRF token not Base64-encoded");
`Invalid
- | Some token ->
-
- match Cipher.decrypt ~associated_data:field_name request token with
- | None ->
- log.warning (fun log -> log ~request "CSRF token could not be verified");
- `Invalid
- | Some token ->
-
- (* TODO Don't raise exceptions. *)
- match Yojson.Basic.from_string token with
- | `Assoc [
- "session", `String token_session_label;
- "expires_at", (`Float _ | `Int _ as expires_at);
- ] ->
-
- let expires_at =
- match expires_at with
- | `Float n -> n
- | `Int n -> float_of_int n
- in
-
- let real_session_label = Session.session_label request in
- if token_session_label <> real_session_label then begin
- log.warning (fun log -> log ~request
- "CSRF token not for this session");
- `Wrong_session
- end
- else
- let now = now () in
- if expires_at > now then
- `Ok
- else begin
- log.warning (fun log -> log ~request "CSRF token expired");
- `Expired expires_at
- end
-
- | _ | exception _ ->
- log.warning (fun log -> log ~request "CSRF token payload invalid");
- `Invalid
+ | Some token -> (
+ match Cipher.decrypt ~associated_data:field_name request token with
+ | None ->
+ log.warning (fun log -> log ~request "CSRF token could not be verified");
+ `Invalid
+ | Some token -> (
+ (* TODO Don't raise exceptions. *)
+ match Yojson.Basic.from_string token with
+ | `Assoc
+ [
+ ("session", `String token_session_label);
+ ("expires_at", ((`Float _ | `Int _) as expires_at));
+ ] ->
+ let expires_at =
+ match expires_at with
+ | `Float n -> n
+ | `Int n -> float_of_int n
+ in
+
+ let real_session_label = Session.session_label request in
+ if token_session_label <> real_session_label then begin
+ log.warning (fun log ->
+ log ~request "CSRF token not for this session");
+ `Wrong_session
+ end
+ else
+ let now = now () in
+ if expires_at > now then
+ `Ok
+ else begin
+ log.warning (fun log -> log ~request "CSRF token expired");
+ `Expired expires_at
+ end
+ | _ | (exception _) ->
+ log.warning (fun log -> log ~request "CSRF token payload invalid");
+ `Invalid))
File "src/server/echo.ml", line 1, characters 0-0:
diff --git a/_build/default/src/server/echo.ml b/_build/default/src/server/.formatted/echo.ml
index 093c652..e8134b6 100644
--- a/_build/default/src/server/echo.ml
+++ b/_build/default/src/server/.formatted/echo.ml
@@ -3,13 +3,8 @@
Copyright 2021 Anton Bachin *)
-
-
module Message = Dream_pure.Message
module Stream = Dream_pure.Stream
-
-
let echo request =
- Message.response (Message.server_stream request) Stream.null
- |> Lwt.return
+ Message.response (Message.server_stream request) Stream.null |> Lwt.return
File "src/server/form.ml", line 1, characters 0-0:
diff --git a/_build/default/src/server/form.ml b/_build/default/src/server/.formatted/form.ml
index 98f4299..910f490 100644
--- a/_build/default/src/server/form.ml
+++ b/_build/default/src/server/.formatted/form.ml
@@ -3,75 +3,59 @@
Copyright 2021 Anton Bachin *)
-
-
module Formats = Dream_pure.Formats
module Message = Dream_pure.Message
-
-
-let log =
- Log.sub_log "dream.form"
+let log = Log.sub_log "dream.form"
let sort form =
List.stable_sort (fun (key, _) (key', _) -> String.compare key key') form
-type 'a form_result = [
- | `Ok of 'a
- | `Expired of 'a * float
+type 'a form_result =
+ [ `Ok of 'a
+ | `Expired of 'a * float
| `Wrong_session of 'a
| `Invalid_token of 'a
| `Missing_token of 'a
- | `Many_tokens of 'a
- | `Wrong_content_type
-]
+ | `Many_tokens of 'a
+ | `Wrong_content_type ]
let sort_and_check_form ~now to_value form request =
let csrf_token, form =
- List.partition (fun (name, _) -> name = Csrf.field_name) form in
+ List.partition (fun (name, _) -> name = Csrf.field_name) form
+ in
let form = sort form in
match csrf_token with
- | [_, value] ->
- begin match%lwt Csrf.verify_csrf_token ~now request (to_value value) with
- | `Ok ->
- Lwt.return (`Ok form)
-
- | `Expired time ->
- Lwt.return (`Expired (form, time))
-
- | `Wrong_session ->
- Lwt.return (`Wrong_session form)
-
- | `Invalid ->
- Lwt.return (`Invalid_token form)
- end
-
+ | [(_, value)] -> begin
+ match%lwt Csrf.verify_csrf_token ~now request (to_value value) with
+ | `Ok -> Lwt.return (`Ok form)
+ | `Expired time -> Lwt.return (`Expired (form, time))
+ | `Wrong_session -> Lwt.return (`Wrong_session form)
+ | `Invalid -> Lwt.return (`Invalid_token form)
+ end
| [] ->
log.warning (fun log -> log ~request "CSRF token missing");
Lwt.return (`Missing_token form)
-
- | _::_::_ ->
+ | _ :: _ :: _ ->
log.warning (fun log -> log ~request "CSRF token duplicated");
Lwt.return (`Many_tokens form)
let wrong_content_type request =
- log.warning (fun log -> log ~request
- "Content-Type not 'application/x-www-form-urlencoded'");
+ log.warning (fun log ->
+ log ~request "Content-Type not 'application/x-www-form-urlencoded'");
Lwt.return `Wrong_content_type
let form ?(csrf = true) ~now request =
match Message.header request "Content-Type" with
- | None ->
- wrong_content_type request
- | Some content_type ->
+ | None -> wrong_content_type request
+ | Some content_type -> (
match String.split_on_char ';' content_type with
- | "application/x-www-form-urlencoded"::_ ->
+ | "application/x-www-form-urlencoded" :: _ ->
let%lwt 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))
- | _ ->
- wrong_content_type request
+ | _ -> wrong_content_type request)
File "src/server/helpers.ml", line 1, characters 0-0:
diff --git a/_build/default/src/server/helpers.ml b/_build/default/src/server/.formatted/helpers.ml
index 139a332..8431b43 100644
--- a/_build/default/src/server/helpers.ml
+++ b/_build/default/src/server/.formatted/helpers.ml
@@ -3,20 +3,13 @@
Copyright 2021 Anton Bachin *)
-
-
module Formats = Dream_pure.Formats
module Message = Dream_pure.Message
module Status = Dream_pure.Status
module Stream = Dream_pure.Stream
-
-
let client_field =
- Message.new_field
- ~name:"dream.client"
- ~show_value:(fun client -> client)
- ()
+ Message.new_field ~name:"dream.client" ~show_value:(fun client -> client) ()
(* TODO What should be reported when the client address is missing? This is a
sign of local testing. *)
@@ -25,30 +18,22 @@ let client request =
| None -> "127.0.0.1:0"
| Some client -> client
-let set_client request client =
- Message.set_field request client_field client
-
-
+let set_client request client = Message.set_field request client_field client
let tls_field =
- Message.new_field
- ~name:"dream.tls"
- ~show_value:string_of_bool
- ()
+ Message.new_field ~name:"dream.tls" ~show_value:string_of_bool ()
let tls request =
match Message.field request tls_field with
| Some true -> true
| _ -> false
-let set_tls request tls =
- Message.set_field request tls_field tls
-
-
+let set_tls request tls = Message.set_field request tls_field tls
let request ~client ~method_ ~target ~tls ~headers server_stream =
let request =
- Message.request ~method_ ~target ~headers Stream.null server_stream in
+ Message.request ~method_ ~target ~headers Stream.null server_stream
+ in
set_client request client;
set_tls request tls;
request
@@ -56,11 +41,10 @@ let request ~client ~method_ ~target ~tls ~headers server_stream =
let request_with_body ?method_ ?target ?headers body =
Message.request ?method_ ?target ?headers Stream.null (Stream.string body)
-
-
let response_with_body ?status ?code ?headers body =
let response =
- Message.response ?status ?code ?headers Stream.null Stream.null in
+ Message.response ?status ?code ?headers Stream.null Stream.null
+ in
Message.set_body response body;
response
@@ -81,8 +65,8 @@ let json ?status ?code ?headers body =
let redirect ?status ?code ?headers _request location =
let status = (status :> Status.redirection option) in
let status =
- match status, code with
- | None, None -> Some (`See_Other)
+ match (status, code) with
+ | None, None -> Some `See_Other
| _ -> status
in
let response = response_with_body ?status ?code ?headers "" in
@@ -94,55 +78,47 @@ let stream ?status ?code ?headers ?(close = true) callback =
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
+ Message.response ?status ?code ?headers client_stream server_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);
+ 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 empty ?headers status =
- respond ?headers ~status ""
-
-let not_found _ =
- respond ~status:`Not_Found ""
-
-
+let empty ?headers status = respond ?headers ~status ""
+let not_found _ = respond ~status:`Not_Found ""
let websocket ?headers ?(close = true) callback =
let response =
- Message.response
- ~status:`Switching_Protocols ?headers Stream.empty Stream.null in
+ Message.response ~status:`Switching_Protocols ?headers Stream.empty
+ Stream.null
+ in
let websocket = Message.create_websocket response in
(* TODO Make sure the request id is propagated to the callback. *)
Lwt.async (fun () ->
- if close then
- match%lwt callback websocket with
- | () ->
- Message.close_websocket websocket
- | exception exn ->
- let%lwt () = Message.close_websocket websocket ~code:1005 in
- raise exn
- else
- callback websocket);
+ if close then
+ match%lwt callback websocket with
+ | () -> Message.close_websocket websocket
+ | exception exn ->
+ let%lwt () = Message.close_websocket websocket ~code:1005 in
+ raise exn
+ else
+ callback websocket);
Lwt.return response
-let receive (_, server_stream) =
- Message.receive server_stream
-
-let receive_fragment (_, server_stream) =
- Message.receive_fragment server_stream
+let receive (_, server_stream) = Message.receive server_stream
+let receive_fragment (_, server_stream) = Message.receive_fragment server_stream
let send ?text_or_binary ?end_of_message (_, server_stream) data =
Message.send ?text_or_binary ?end_of_message server_stream data
File "src/server/origin_referrer_check.ml", line 1, characters 0-0:
diff --git a/_build/default/src/server/origin_referrer_check.ml b/_build/default/src/server/.formatted/origin_referrer_check.ml
index f517772..47304b5 100644
--- a/_build/default/src/server/origin_referrer_check.ml
+++ b/_build/default/src/server/.formatted/origin_referrer_check.ml
@@ -3,24 +3,16 @@
Copyright 2021 Anton Bachin *)
-
-
module Message = Dream_pure.Message
module Stream = Dream_pure.Stream
-
-
-let log =
- Log.sub_log "dream.origin"
+let log = Log.sub_log "dream.origin"
(* TODO Rename all next_handler to inner_handler. *)
let origin_referrer_check inner_handler request =
-
match Message.method_ request with
- | `GET | `HEAD ->
- inner_handler request
-
- | _ ->
+ | `GET | `HEAD -> inner_handler request
+ | _ -> (
let origin =
match Message.header request "Origin" with
| Some "null" | None -> Message.header request "Referer"
@@ -29,22 +21,18 @@ let origin_referrer_check inner_handler request =
match origin with
| None ->
- log.warning (fun log -> log ~request
- "Origin and Referer headers both missing");
+ 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 ->
-
+ | Some origin -> (
match Message.header request "Host" with
| None ->
log.warning (fun log -> log ~request "Host header missing");
Message.response ~status:`Bad_Request Stream.empty Stream.null
|> Lwt.return
-
| Some host ->
-
let origin_uri = Uri.of_string origin in
let schemes_match =
@@ -56,8 +44,8 @@ let origin_referrer_check inner_handler request =
let host_host, host_port =
match String.split_on_char ':' host with
- | [host; port] -> Some host, Some port
- | _ -> Some host, None
+ | [host; port] -> (Some host, Some port)
+ | _ -> (Some host, None)
in
let origin_port =
@@ -71,10 +59,9 @@ let origin_referrer_check inner_handler request =
if schemes_match && hosts_match && ports_match then
inner_handler request
-
else begin
- log.warning (fun log -> log ~request
- "Origin-Host mismatch: '%s' vs. '%s'" origin host);
+ 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
+ end))
File "src/server/query.ml", line 1, characters 0-0:
diff --git a/_build/default/src/server/query.ml b/_build/default/src/server/.formatted/query.ml
index 62b6734..67e0c9b 100644
--- a/_build/default/src/server/query.ml
+++ b/_build/default/src/server/.formatted/query.ml
@@ -3,24 +3,20 @@
Copyright 2021 Anton Bachin *)
-
-
(* TODO Long-term, query string handler is likely to become part of the
router. *)
module Formats = Dream_pure.Formats
module Message = Dream_pure.Message
-
-
(* TODO Actually cache the result of parsing the query string. *)
(* let query_variable : (string * string) list Dream.local =
- Dream.new_local
- ~name:"dream.query"
- ~show_value:(fun query ->
- query
- |> List.map (fun (name, value) -> Printf.sprintf "%s=%s" name value)
- |> String.concat ", ") *)
+ Dream.new_local
+ ~name:"dream.query"
+ ~show_value:(fun query ->
+ query
+ |> List.map (fun (name, value) -> Printf.sprintf "%s=%s" name value)
+ |> String.concat ", ") *)
let all_queries request =
Message.target request
@@ -28,15 +24,15 @@ let all_queries request =
|> snd
|> Formats.from_form_urlencoded
-let query request name =
- List.assoc_opt name (all_queries request)
+let query request name = List.assoc_opt name (all_queries request)
let queries request name =
all_queries request
- |> List.fold_left (fun accumulator (name', value) ->
- if name' = name then
- value::accumulator
- else
- accumulator)
- []
+ |> List.fold_left
+ (fun accumulator (name', value) ->
+ if name' = name then
+ value :: accumulator
+ else
+ accumulator)
+ []
|> List.rev
File "src/server/router.mli", line 1, characters 0-0:
diff --git a/_build/default/src/server/router.mli b/_build/default/src/server/.formatted/router.mli
index 6626261..66573c5 100644
--- a/_build/default/src/server/router.mli
+++ b/_build/default/src/server/.formatted/router.mli
@@ -3,8 +3,6 @@
Copyright 2021 Anton Bachin *)
-
-
module Message = Dream_pure.Message
type route
File "src/server/site_prefix.ml", line 1, characters 0-0:
diff --git a/_build/default/src/server/site_prefix.ml b/_build/default/src/server/.formatted/site_prefix.ml
index 6a41d2f..46bf9f4 100644
--- a/_build/default/src/server/site_prefix.ml
+++ b/_build/default/src/server/.formatted/site_prefix.ml
@@ -3,35 +3,23 @@
Copyright 2021 Anton Bachin *)
-
-
module Formats = Dream_pure.Formats
module Message = Dream_pure.Message
module Stream = Dream_pure.Stream
-
-
let rec match_site_prefix prefix path =
- match prefix, path with
- | prefix_crumb::prefix, path_crumb::path ->
+ match (prefix, path) with
+ | prefix_crumb :: prefix, path_crumb :: path ->
if path_crumb = prefix_crumb then
match_site_prefix prefix path
else
None
- | [], path ->
- Some path
- | _ ->
- None
-
-
+ | [], path -> Some path
+ | _ -> None
(* TODO The path and prefix representations and accessors need a cleanup. *)
let with_site_prefix prefix =
- let prefix =
- prefix
- |> Formats.from_path
- |> Formats.drop_trailing_slash
- in
+ let prefix = prefix |> Formats.from_path |> Formats.drop_trailing_slash in
fun next_handler request ->
match match_site_prefix prefix (Router.path request) with
| None ->
File "src/unix/static.ml", line 1, characters 0-0:
diff --git a/_build/default/src/unix/static.ml b/_build/default/src/unix/.formatted/static.ml
index c3c0470..e018666 100644
--- a/_build/default/src/unix/static.ml
+++ b/_build/default/src/unix/.formatted/static.ml
@@ -3,16 +3,12 @@
Copyright 2021 Anton Bachin *)
-
-
module Formats = Dream_pure.Formats
module Message = Dream_pure.Message
module Method = Dream_pure.Method
module Router = Dream__server.Router
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"
@@ -24,20 +20,19 @@ let mime_lookup filename =
| "text/html" -> Formats.text_html
| content_type -> content_type
in
- ["Content-Type", content_type]
+ [("Content-Type", content_type)]
let from_filesystem local_root path _ =
let file = Filename.concat local_root path in
Lwt.catch
(fun () ->
Lwt_io.(with_file ~mode:Input file) (fun channel ->
- let%lwt content = Lwt_io.read channel in
- Message.response
- ~headers:(mime_lookup path) (Stream.string content) 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))
(fun _exn ->
- Message.response ~status:`Not_Found Stream.empty Stream.null
- |> Lwt.return)
+ Message.response ~status:`Not_Found Stream.empty Stream.null |> Lwt.return)
(* TODO Add ETag handling. *)
(* TODO Add Content-Length handling? *)
@@ -52,19 +47,15 @@ let validate_path request =
let has_backslash component = String.contains component '\\' in
let has_slash = List.exists has_slash path in
let has_backslash = List.exists has_backslash path in
- let has_dot = List.exists ((=) Filename.current_dir_name) path in
- let has_dotdot = List.exists ((=) Filename.parent_dir_name) path in
- let has_empty = List.exists ((=) "") path in
+ let has_dot = List.exists (( = ) Filename.current_dir_name) path in
+ let has_dotdot = List.exists (( = ) Filename.parent_dir_name) path in
+ let has_empty = List.exists (( = ) "") path in
let is_empty = path = [] in
- if has_slash ||
- has_backslash ||
- has_dot ||
- has_dotdot ||
- has_empty ||
- is_empty then
+ if
+ has_slash || has_backslash || has_dot || has_dotdot || has_empty || is_empty
+ then
None
-
else
let path = String.concat Filename.dir_sep path in
if Filename.is_relative path then
@@ -72,29 +63,22 @@ let validate_path request =
else
None
-let static ?(loader = from_filesystem) local_root = fun request ->
-
+let static ?(loader = from_filesystem) local_root request =
if not @@ Method.methods_equal (Message.method_ request) `GET then
- Message.response ~status:`Not_Found Stream.empty Stream.null
- |> Lwt.return
-
+ 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
-
+ Message.response ~status:`Not_Found Stream.empty Stream.null |> Lwt.return
| Some path ->
let%lwt response = loader local_root path request in
- if not (Message.has_header response "Content-Type") then begin
- match Message.status response with
- | `OK
- | `Non_Authoritative_Information
- | `No_Content
- | `Reset_Content
- | `Partial_Content ->
- Message.add_header response "Content-Type" (Magic_mime.lookup path)
- | _ ->
- ()
- end;
+ (if not (Message.has_header response "Content-Type") then
+ match Message.status response with
+ | `OK
+ | `Non_Authoritative_Information
+ | `No_Content
+ | `Reset_Content
+ | `Partial_Content ->
+ Message.add_header response "Content-Type" (Magic_mime.lookup path)
+ | _ -> ());
Lwt.return response
File "src/sql/sql.ml", line 1, characters 0-0:
diff --git a/_build/default/src/sql/sql.ml b/_build/default/src/sql/.formatted/sql.ml
index 284b4e8..85bff65 100644
--- a/_build/default/src/sql/sql.ml
+++ b/_build/default/src/sql/.formatted/sql.ml
@@ -3,23 +3,18 @@
Copyright 2021 Anton Bachin *)
-
-
module Log = Dream__server.Log
module Message = Dream_pure.Message
-
-
-let log =
- Log.sub_log "dream.sql"
+let log = Log.sub_log "dream.sql"
(* TODO Debug metadata for the pools. *)
let pool_field : (_, Caqti_error.t) Caqti_lwt.Pool.t Message.field =
Message.new_field ()
let foreign_keys_on =
- Caqti_request.Infix.(->.) Caqti_type.unit
- Caqti_type.unit "PRAGMA foreign_keys = ON"
+ Caqti_request.Infix.( ->. ) Caqti_type.unit Caqti_type.unit
+ "PRAGMA foreign_keys = ON"
let post_connect (module Db : Caqti_lwt.CONNECTION) =
match Caqti_driver_info.dialect_tag Db.driver_info with
@@ -27,38 +22,39 @@ let post_connect (module Db : Caqti_lwt.CONNECTION) =
| _ -> Lwt.return (Ok ())
let sql_pool ?size uri =
- let pool_cell = ref None in
- fun inner_handler request ->
-
- begin match !pool_cell with
- | Some pool ->
- Message.set_field request pool_field pool;
- inner_handler request
- | None ->
- (* The correctness of this code is subtle. There is no race condition with
- two requests attempting to create a pool only because none of the code
- between checking pool_cell and setting it calls into Lwt. *)
- let parsed_uri = Uri.of_string uri in
- if Uri.scheme parsed_uri = Some "sqlite" then
- log.warning (fun log -> log ~request
- "Dream.sql_pool: \
- 'sqlite' is not a valid scheme; did you mean 'sqlite3'?");
- let pool =
- Caqti_lwt.connect_pool ?max_size:size ~post_connect parsed_uri in
- match pool with
- | Ok pool ->
- pool_cell := Some pool;
+ let pool_cell = ref None in
+ fun inner_handler request ->
+ match !pool_cell with
+ | Some pool ->
Message.set_field request pool_field pool;
inner_handler request
- | Error error ->
- (* Deliberately raise an exception so that it can be communicated to any
- debug handler. *)
- let message =
- Printf.sprintf "Dream.sql_pool: cannot create pool for '%s': %s"
- uri (Caqti_error.show error) in
- log.error (fun log -> log ~request "%s" message);
- failwith message
- end
+ | None -> (
+ (* The correctness of this code is subtle. There is no race condition with
+ two requests attempting to create a pool only because none of the code
+ between checking pool_cell and setting it calls into Lwt. *)
+ let parsed_uri = Uri.of_string uri in
+ if Uri.scheme parsed_uri = Some "sqlite" then
+ log.warning (fun log ->
+ log ~request
+ "Dream.sql_pool: 'sqlite' is not a valid scheme; did you mean \
+ 'sqlite3'?");
+ let pool =
+ Caqti_lwt.connect_pool ?max_size:size ~post_connect parsed_uri
+ in
+ match pool with
+ | Ok pool ->
+ pool_cell := Some pool;
+ Message.set_field request pool_field pool;
+ inner_handler request
+ | Error error ->
+ (* Deliberately raise an exception so that it can be communicated to any
+ debug handler. *)
+ let message =
+ Printf.sprintf "Dream.sql_pool: cannot create pool for '%s': %s" uri
+ (Caqti_error.show error)
+ in
+ log.error (fun log -> log ~request "%s" message);
+ failwith message)
let sql request callback =
match Message.field request pool_field with
@@ -68,11 +64,12 @@ let sql request callback =
failwith message
| Some pool ->
let%lwt 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
- | result -> Lwt.return (Ok result)
- | exception exn -> raise exn)
+ 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
+ | result -> Lwt.return (Ok result)
+ | exception exn -> raise exn)
in
Caqti_lwt.or_fail result
File "test/expect/eml/tokens.ml", line 1, characters 0-0:
diff --git a/_build/default/test/expect/eml/tokens.ml b/_build/default/test/expect/eml/.formatted/tokens.ml
index e4c33de..94a4507 100644
--- a/_build/default/test/expect/eml/tokens.ml
+++ b/_build/default/test/expect/eml/.formatted/tokens.ml
@@ -3,23 +3,21 @@
Copyright 2021 Anton Bachin *)
-
-
let show input =
Eml.Location.reset ();
let underlying = Stream.of_string input in
- let input_stream = Eml.Location.stream (fun () ->
- try Some (Stream.next underlying)
- with _ -> None) in
+ let input_stream =
+ Eml.Location.stream (fun () ->
+ try Some (Stream.next underlying) with _ -> None)
+ in
try
input_stream
|> Eml.Tokenizer.scan
|> List.map Eml.Token.show
|> List.iter print_endline
- with Failure message ->
- print_endline message
+ with Failure message -> print_endline message
let%expect_test _ =
show "";
@@ -46,7 +44,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo =\n< bar";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -55,7 +54,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo =\n < bar";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -64,7 +64,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo =\n < bar";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -73,7 +74,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo =\n < bar";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -82,7 +84,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo =\n <html>\n </html>";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -93,7 +96,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo =\n <html>\n plain";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -104,7 +108,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo =\n <html>\n </html>\nlet bar = ()\n";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -118,7 +123,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo =\n <% a %>\n";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -130,7 +136,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo =\n <% a % %>\n";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -142,7 +149,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo =\n <% a %%>\n";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -154,7 +162,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo =\n <%= a %>\n";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -166,7 +175,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo =\n <% a\nb %>\n";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -179,7 +189,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo =\n <%";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -190,7 +201,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo =\n <%\na %>";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -202,7 +214,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo =\n <% \n a";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -214,7 +227,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo =\n <html>\n\na";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -228,7 +242,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo =\n% abc";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -236,7 +251,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo =\n% abc\n";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -244,7 +260,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo =\n% abc\n% def";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -254,7 +271,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo =\n <html>\n% abc\n </html>";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -274,7 +292,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo=\n <html>\n % bar";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo=
@@ -286,7 +305,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo\n <html>\n\n% bar";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo
@@ -299,7 +319,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo\n <html>\n \n% bar";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo
@@ -312,7 +333,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo = \n <html>\nbar";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo =
@@ -324,7 +346,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo\n %% a = b\n bar";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo
@@ -333,7 +356,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo\n %% a = b\n bar\n %%\n baz";
- [%expect {xxx|
+ [%expect
+ {xxx|
(1, 0) Code_block
let foo
@@ -345,7 +369,8 @@ let%expect_test _ =
let%expect_test _ =
show "let foo\n %% a = b\n %%";
- [%expect {|
+ [%expect
+ {|
(1, 0) Code_block
let foo
File "src/http/error_handler.mli", line 1, characters 0-0:
diff --git a/_build/default/src/http/error_handler.mli b/_build/default/src/http/.formatted/error_handler.mli
index 285469b..0d0651a 100644
--- a/_build/default/src/http/error_handler.mli
+++ b/_build/default/src/http/.formatted/error_handler.mli
@@ -3,24 +3,19 @@
Copyright 2021 Anton Bachin *)
-
-
module Catch = Dream__server.Catch
module Log = Dream__server.Log
module Message = Dream_pure.Message
-
-
(* User's error handlers and defaults. These actually generate error response
templates and/or do logging. *)
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_handler
-
-
+ Catch.error_handler
(* Internal functions called by the framework to report errors. These translate
various libraries' errors into Error.error and call the user's error
@@ -29,38 +24,34 @@ val customize :
handler arguments. *)
(* val app :
- Dream.app ->
- Error.error_handler ->
- Dream.middleware *)
+ Dream.app ->
+ Error.error_handler ->
+ Dream.middleware *)
-val app :
- Catch.error_handler ->
- (Catch.error -> Message.response Lwt.t)
+val app : Catch.error_handler -> Catch.error -> Message.response Lwt.t
val httpaf :
- Catch.error_handler ->
- (Unix.sockaddr -> Httpaf.Server_connection.error_handler)
+ Catch.error_handler -> Unix.sockaddr -> Httpaf.Server_connection.error_handler
val h2 :
- Catch.error_handler ->
- (Unix.sockaddr -> H2.Server_connection.error_handler)
+ Catch.error_handler -> Unix.sockaddr -> H2.Server_connection.error_handler
-val tls :
- Catch.error_handler ->
- (Unix.sockaddr -> exn -> unit)
+val tls : Catch.error_handler -> Unix.sockaddr -> exn -> unit
val websocket :
Catch.error_handler ->
Message.request ->
Message.response ->
- (Websocketaf.Wsd.t -> [ `Exn of exn ] -> unit)
+ Websocketaf.Wsd.t ->
+ [`Exn of exn] ->
+ unit
val websocket_handshake :
Catch.error_handler ->
- (Message.request -> Message.response -> string -> Message.response Lwt.t)
-
-
-
+ Message.request ->
+ Message.response ->
+ string ->
+ Message.response Lwt.t
(* Logger also used by elsewhere in the HTTP integration. *)
val log : Log.sub_log
File "src/mirage/adapt.ml", line 1, characters 0-0:
diff --git a/_build/default/src/mirage/adapt.ml b/_build/default/src/mirage/.formatted/adapt.ml
index 499a9d5..88918a3 100644
--- a/_build/default/src/mirage/adapt.ml
+++ b/_build/default/src/mirage/.formatted/adapt.ml
@@ -13,27 +13,19 @@ module Stream = Dream_pure.Stream
server at some point. *)
(* TODO LATER Will also need to monitor buffer accumulation and use flush. *)
(* TODO Rewrite using Dream.next. *)
-let forward_body_general
- (response : Dream.Message.response)
+let forward_body_general (response : Dream.Message.response)
(_write_string : ?off:int -> ?len:int -> string -> unit)
- (write_buffer : ?off:int -> ?len:int -> Stream.buffer -> unit)
- http_flush
+ (write_buffer : ?off:int -> ?len:int -> Stream.buffer -> unit) http_flush
close =
let bytes_since_flush = ref 0 in
- let abort _exn = Printf.printf "ABORT\n%!"; close 1000 in
+ let abort _exn =
+ Printf.printf "ABORT\n%!";
+ close 1000
+ in
let rec send () =
- Dream.Message.client_stream response
- |> fun stream ->
- Stream.read
- stream
- ~data
- ~close
- ~flush
- ~ping
- ~pong
- ~exn:abort
-
+ Dream.Message.client_stream response |> fun stream ->
+ Stream.read stream ~data ~close ~flush ~ping ~pong ~exn:abort
and data chunk off len _binary _fin =
write_buffer ~off ~len chunk;
bytes_since_flush := !bytes_since_flush + len;
@@ -43,39 +35,22 @@ let forward_body_general
end
else
send ()
-
and flush () =
bytes_since_flush := 0;
http_flush send
-
- and ping _buffer _offset _length =
- send ()
-
- and pong _buffer _offset _length =
- send ()
-
- in
+ and ping _buffer _offset _length = send ()
+ and pong _buffer _offset _length = send () in
send ()
-let forward_body
- (response : Dream.Message.response)
+let forward_body (response : Dream.Message.response)
(body : Httpaf.Body.Writer.t) =
-
- forward_body_general
- response
- (Httpaf.Body.Writer.write_string body)
- (Httpaf.Body.Writer.write_bigstring body)
- (Httpaf.Body.Writer.flush body)
+ forward_body_general response (Httpaf.Body.Writer.write_string body)
+ (Httpaf.Body.Writer.write_bigstring body) (Httpaf.Body.Writer.flush body)
(fun _code -> Httpaf.Body.Writer.close body)
-let forward_body_h2
- (response : Dream.Message.response)
+let forward_body_h2 (response : Dream.Message.response)
(body : H2.Body.Writer.t) =
-
- forward_body_general
- response
- (H2.Body.Writer.write_string body)
- (H2.Body.Writer.write_bigstring body)
- (H2.Body.Writer.flush body)
+ forward_body_general response (H2.Body.Writer.write_string body)
+ (H2.Body.Writer.write_bigstring body) (H2.Body.Writer.flush body)
(fun _code -> H2.Body.Writer.close body)
File "test/unit/request.ml", line 1, characters 0-0:
diff --git a/_build/default/test/unit/request.ml b/_build/default/test/unit/.formatted/request.ml
index fdbc2e6..abfd633 100644
--- a/_build/default/test/unit/request.ml
+++ b/_build/default/test/unit/.formatted/request.ml
@@ -3,40 +3,29 @@
Copyright 2021 Anton Bachin *)
-
-
-let (-:) name f = Alcotest.test_case name `Quick f
-
-
-
-let tests = "request", [
-
- "with_client" -: begin fun () ->
- let request = Dream.request "" in
- Dream.set_client request "2.3.4.5:34567";
- Dream.client request
- |> Alcotest.(check string) "client" "2.3.4.5:34567"
- end;
-
- "method_" -: begin fun () ->
- Dream.request ~method_:`POST ""
- |> Dream.method_
- |> Dream.method_to_string
- |> Alcotest.(check string) "method_" "POST"
- end;
-
- "with_method_" -: begin fun () ->
- let request = Dream.request "" in
- Dream.set_method_ request `PUT;
- Dream.method_ request
- |> Dream.method_to_string
- |> Alcotest.(check string) "method_" "PUT";
- end;
-
- "target" -: begin fun () ->
- Dream.request ~target:"/foo" ""
- |> Dream.target
- |> Alcotest.(check string) "target" "/foo"
- end;
-
-]
+let ( -: ) name f = Alcotest.test_case name `Quick f
+
+let tests =
+ ( "request",
+ [
+ ( "with_client" -: fun () ->
+ let request = Dream.request "" in
+ Dream.set_client request "2.3.4.5:34567";
+ Dream.client request |> Alcotest.(check string) "client" "2.3.4.5:34567"
+ );
+ ( "method_" -: fun () ->
+ Dream.request ~method_:`POST ""
+ |> Dream.method_
+ |> Dream.method_to_string
+ |> Alcotest.(check string) "method_" "POST" );
+ ( "with_method_" -: fun () ->
+ let request = Dream.request "" in
+ Dream.set_method_ request `PUT;
+ Dream.method_ request
+ |> Dream.method_to_string
+ |> Alcotest.(check string) "method_" "PUT" );
+ ( "target" -: fun () ->
+ Dream.request ~target:"/foo" ""
+ |> Dream.target
+ |> Alcotest.(check string) "target" "/foo" );
+ ] )
File "example/5-promise/promise.ml", line 1, characters 0-0:
diff --git a/_build/default/example/5-promise/promise.ml b/_build/default/example/5-promise/.formatted/promise.ml
index ffa2790..a3bdc5e 100644
--- a/_build/default/example/5-promise/promise.ml
+++ b/_build/default/example/5-promise/.formatted/promise.ml
@@ -6,7 +6,6 @@ let count_requests inner_handler request =
let%lwt response = inner_handler request in
successful := !successful + 1;
Lwt.return response
-
with exn ->
failed := !failed + 1;
raise exn
@@ -15,15 +14,12 @@ let () =
Dream.run
@@ Dream.logger
@@ count_requests
- @@ Dream.router [
-
- Dream.get "/fail"
- (fun _ ->
- raise (Failure "The Web app failed!"));
-
- Dream.get "/" (fun _ ->
- Dream.html (Printf.sprintf
- "%3i request(s) successful<br>%3i request(s) failed"
- !successful !failed));
-
- ]
+ @@ Dream.router
+ [
+ Dream.get "/fail" (fun _ -> raise (Failure "The Web app failed!"));
+ Dream.get "/" (fun _ ->
+ Dream.html
+ (Printf.sprintf
+ "%3i request(s) successful<br>%3i request(s) failed"
+ !successful !failed));
+ ]
File "src/pure/message.ml", line 1, characters 0-0:
diff --git a/_build/default/src/pure/message.ml b/_build/default/src/pure/.formatted/message.ml
index e96da42..1b58c0a 100644
--- a/_build/default/src/pure/message.ml
+++ b/_build/default/src/pure/.formatted/message.ml
@@ -3,8 +3,6 @@
Copyright 2021 Anton Bachin *)
-
-
(* Type abbreviations and modules used in defining the primary types *)
type 'a promise = 'a Lwt.t
@@ -13,9 +11,10 @@ type 'a field_metadata = {
name : string option;
show_value : ('a -> string) option;
}
-module Fields = Hmap.Make (struct type 'a t = 'a field_metadata end)
-
+module Fields = Hmap.Make (struct
+ type 'a t = 'a field_metadata
+end)
(* Messages (requests and responses) *)
@@ -46,24 +45,15 @@ type 'a message = {
type request = client message
type response = server message
-
-
(* Functions of messages *)
type handler = request -> response Lwt.t
type middleware = handler -> handler
-
-
(* Requests *)
-let request
- ?method_
- ?(target = "/")
- ?(headers = [])
- client_stream
- server_stream =
-
+let request ?method_ ?(target = "/") ?(headers = []) client_stream server_stream
+ =
let method_ =
match (method_ :> Method.method_ option) with
| None -> `GET
@@ -71,10 +61,7 @@ let request
in
{
kind = Request;
- specific = {
- method_;
- target;
- };
+ specific = { method_; target };
headers;
client_stream;
server_stream;
@@ -82,35 +69,26 @@ let request
fields = Fields.empty;
}
-let method_ request =
- request.specific.method_
-
-let target request =
- request.specific.target
+let method_ request = request.specific.method_
+let target request = request.specific.target
let set_method_ request method_ =
request.specific.method_ <- (method_ :> Method.method_)
-let set_target request target =
- request.specific.target <- target
-
-
+let set_target request target = request.specific.target <- target
(* Responses *)
let response ?status ?code ?(headers = []) client_stream server_stream =
let status =
- match status, code with
+ match (status, code) with
| None, None -> `OK
| Some status, _ -> (status :> Status.status)
| None, Some code -> Status.int_to_status code
in
{
kind = Response;
- specific = {
- status;
- websocket = None;
- };
+ specific = { status; websocket = None };
headers;
client_stream;
server_stream;
@@ -118,13 +96,8 @@ let response ?status ?code ?(headers = []) client_stream server_stream =
fields = Fields.empty;
}
-let status response =
- response.specific.status
-
-let set_status response status =
- response.specific.status <- status
-
-
+let status response = response.specific.status
+let set_status response status = response.specific.status <- status
(* Headers *)
@@ -135,26 +108,27 @@ let header_basic name message =
|> snd
let header message name =
- try Some (header_basic name message)
- with Not_found -> None
+ try Some (header_basic name message) with Not_found -> None
let headers message name =
let name = String.lowercase_ascii name in
message.headers
- |> List.fold_left (fun matched (name', value) ->
- if String.lowercase_ascii name' = name then
- value::matched
- else
- matched)
- []
+ |> List.fold_left
+ (fun matched (name', value) ->
+ if String.lowercase_ascii name' = name then
+ value :: matched
+ else
+ matched)
+ []
|> List.rev
-let all_headers message =
- message.headers
+let all_headers message = message.headers
let has_header message name =
- try ignore (header_basic name message); true
+ try
+ ignore (header_basic name message);
+ true
with Not_found -> false
let add_header message name value =
@@ -170,8 +144,7 @@ let set_header message name value =
drop_header message name;
add_header message name value
-let set_all_headers message headers =
- message.headers <- headers
+let set_all_headers message headers = message.headers <- headers
let sort_headers headers =
List.stable_sort (fun (name, _) (name', _) -> compare name name') headers
@@ -179,12 +152,10 @@ let sort_headers headers =
let lowercase_headers message =
let headers =
message.headers
- |> List.map (fun (name, value) -> String.lowercase_ascii name, value)
+ |> List.map (fun (name, value) -> (String.lowercase_ascii name, value))
in
message.headers <- headers
-
-
(* Whole-body access *)
let body message =
@@ -209,39 +180,31 @@ let set_body message body =
let set_content_length_headers message =
if has_header message "Content-Length" then
()
+ else if has_header message "Transfer-Encoding" then
+ ()
else
- if has_header message "Transfer-Encoding" then
- ()
- else
- 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
+ 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)
let drop_content_length_headers message =
drop_header message "Content-Length";
drop_header message "Transfer-Encoding"
-
-
(* Streams *)
-let read stream =
- Stream.read_convenience stream
+let read stream = Stream.read_convenience stream
let write stream chunk =
let promise, resolver = Lwt.wait () 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
+ 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 ());
@@ -249,8 +212,7 @@ let write stream chunk =
let flush stream =
let promise, resolver = Lwt.wait () in
- Stream.flush
- stream
+ 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);
@@ -260,11 +222,8 @@ let close stream =
Stream.close stream 1000;
Lwt.return_unit
-let client_stream message =
- message.client_stream
-
-let server_stream message =
- message.server_stream
+let client_stream message = message.client_stream
+let server_stream message = message.server_stream
let set_client_stream message client_stream =
message.client_stream <- client_stream
@@ -272,8 +231,6 @@ let set_client_stream message client_stream =
let set_server_stream message server_stream =
message.server_stream <- server_stream
-
-
let create_websocket response =
let in_reader, in_writer = Stream.pipe ()
and out_reader, out_writer = Stream.pipe () in
@@ -283,23 +240,20 @@ let create_websocket response =
response.specific.websocket <- Some websocket;
websocket
-let get_websocket response =
- response.specific.websocket
+let get_websocket response = response.specific.websocket
let close_websocket ?(code = 1000) (client_stream, server_stream) =
Stream.close client_stream code;
Stream.close server_stream code;
Lwt.return_unit
-type text_or_binary = [
- | `Text
- | `Binary
-]
+type text_or_binary =
+ [ `Text
+ | `Binary ]
-type end_of_message = [
- | `End_of_message
- | `Continues
-]
+type end_of_message =
+ [ `End_of_message
+ | `Continues ]
let receive_fragment stream =
let promise, resolver = Lwt.wait () in
@@ -315,20 +269,13 @@ 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
- resolver (Some (string, text_or_binary, end_of_message)))
-
+ Lwt.wakeup_later resolver
+ (Some (string, text_or_binary, end_of_message)))
~flush:loop
-
~ping:(fun buffer offset length ->
Stream.pong stream buffer offset length ~close ~exn:abort loop)
-
- ~pong:(fun _buffer _offset _length ->
- loop ())
-
- ~close
-
- ~exn:abort
+ ~pong:(fun _buffer _offset _length -> loop ())
+ ~close ~exn:abort
in
loop ();
@@ -341,16 +288,14 @@ let receive_fragment stream =
let receive_full stream =
let rec receive_continuations text_or_binary acc =
match%lwt receive_fragment stream with
- | None ->
- Lwt.return (Some (acc, text_or_binary))
+ | None -> Lwt.return (Some (acc, text_or_binary))
| Some (fragment, _, `End_of_message) ->
Lwt.return (Some (acc ^ fragment, text_or_binary))
| Some (fragment, _, `Continues) ->
receive_continuations text_or_binary (acc ^ fragment)
in
match%lwt receive_fragment stream with
- | None ->
- Lwt.return_none
+ | None -> Lwt.return_none
| Some (fragment, text_or_binary, `End_of_message) ->
Lwt.return (Some (fragment, text_or_binary))
| Some (fragment, text_or_binary, `Continues) ->
@@ -377,45 +322,36 @@ let send ?text_or_binary ?end_of_message stream data =
in
let length = String.length data in
let buffer = Bigstringaf.of_string ~off:0 ~len:length data in
- Stream.write
- stream buffer 0 length binary fin
+ 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
-
-
(* Middleware *)
-let no_middleware handler request =
- handler request
+let no_middleware handler request = handler request
let rec pipeline middlewares handler =
match middlewares with
| [] -> handler
- | middleware::more -> middleware (pipeline more handler)
-
-
+ | middleware :: more -> middleware (pipeline more handler)
(* Custom fields *)
type 'a field = 'a Fields.key
-let new_field ?name ?show_value () =
- Fields.Key.create {name; show_value}
-
-let field message key =
- Fields.find key message.fields
+let new_field ?name ?show_value () = Fields.Key.create { name; show_value }
+let field message key = Fields.find key message.fields
let set_field message key value =
message.fields <- Fields.add key value message.fields
let fold_fields f initial message =
- Fields.fold (fun (B (key, value)) accumulator ->
- match Fields.Key.info key with
- | {name = Some name; show_value = Some show_value} ->
- f name (show_value value) accumulator
- | _ -> accumulator)
- message.fields
- initial
+ Fields.fold
+ (fun (B (key, value)) accumulator ->
+ match Fields.Key.info key with
+ | { name = Some name; show_value = Some show_value } ->
+ f name (show_value value) accumulator
+ | _ -> accumulator)
+ message.fields initial
File "docs/web/postprocess/index.ml", line 1, characters 0-0:
diff --git a/_build/default/docs/web/postprocess/index.ml b/_build/default/docs/web/postprocess/.formatted/index.ml
index 991d4bb..588b678 100644
--- a/_build/default/docs/web/postprocess/index.ml
+++ b/_build/default/docs/web/postprocess/.formatted/index.ml
@@ -3,13 +3,12 @@
Copyright 2021 Anton Bachin *)
-
-
let if_expected = Common.if_expected
open Soup
-let method_expected = {|<div class="spec type" id="type-method_">
+let method_expected =
+ {|<div class="spec type" id="type-method_">
<a href="#type-method_" class="anchor"></a><code><span><span class="keyword">type</span> method_</span><span> = </span><span>[ </span></code>
<table>
<tbody>
@@ -69,7 +68,8 @@ let method_expected = {|<div class="spec type" id="type-method_">
</div>
|}
-let method_replacement = {|
+let method_replacement =
+ {|
<pre class="compact"><span class="keyword">type</span> method_ = [
| `GET
| `POST
@@ -85,7 +85,8 @@ let method_replacement = {|
</pre>
|}
-let informational_expected = {|<div class="spec type" id="type-informational">
+let informational_expected =
+ {|<div class="spec type" id="type-informational">
<a href="#type-informational" class="anchor"></a><code><span><span class="keyword">type</span> informational</span><span> = </span><span>[ </span></code>
<table>
<tbody>
@@ -105,7 +106,8 @@ let informational_expected = {|<div class="spec type" id="type-informational">
</div>
|}
-let informational_replacement = {|
+let informational_replacement =
+ {|
<pre class="compact"><span class="keyword">type</span> informational = [
| `Continue
| `Switching_Protocols
@@ -113,7 +115,8 @@ let informational_replacement = {|
</pre>
|}
-let success_expected = {|<div class="spec type" id="type-successful">
+let success_expected =
+ {|<div class="spec type" id="type-successful">
<a href="#type-successful" class="anchor"></a><code><span><span class="keyword">type</span> successful</span><span> = </span><span>[ </span></code>
<table>
<tbody>
@@ -158,7 +161,8 @@ let success_expected = {|<div class="spec type" id="type-successful">
</div>
|}
-let success_replacement = {|
+let success_replacement =
+ {|
<pre class="compact"><span class="keyword">type</span> successful = [
| `OK
| `Created
@@ -170,7 +174,8 @@ let success_replacement = {|
]</pre>
|}
-let redirect_expected = {|<div class="spec type" id="type-redirection">
+let redirect_expected =
+ {|<div class="spec type" id="type-redirection">
<a href="#type-redirection" class="anchor"></a><code><span><span class="keyword">type</span> redirection</span><span> = </span><span>[ </span></code>
<table>
<tbody>
@@ -215,7 +220,8 @@ let redirect_expected = {|<div class="spec type" id="type-redirection">
</div>
|}
-let redirect_replacement = {|
+let redirect_replacement =
+ {|
<pre class="compact"><span class="keyword">type</span> redirection = [
| `Multiple_Choices
| `Moved_Permanently
@@ -227,7 +233,8 @@ let redirect_replacement = {|
]</pre>
|}
-let client_expected = {|<div class="spec type" id="type-client_error">
+let client_expected =
+ {|<div class="spec type" id="type-client_error">
<a href="#type-client_error" class="anchor"></a><code><span><span class="keyword">type</span> client_error</span><span> = </span><span>[ </span></code>
<table>
<tbody>
@@ -362,7 +369,8 @@ let client_expected = {|<div class="spec type" id="type-client_error">
</div>
|}
-let client_replacement = {|
+let client_replacement =
+ {|
<pre class="compact"><span class="keyword">type</span> client_error = [
| `Bad_Request
| `Unauthorized
@@ -392,7 +400,8 @@ let client_replacement = {|
]</pre>
|}
-let server_expected = {|<div class="spec type" id="type-server_error">
+let server_expected =
+ {|<div class="spec type" id="type-server_error">
<a href="#type-server_error" class="anchor"></a><code><span><span class="keyword">type</span> server_error</span><span> = </span><span>[ </span></code>
<table>
<tbody>
@@ -432,7 +441,8 @@ let server_expected = {|<div class="spec type" id="type-server_error">
</div>
|}
-let server_replacement = {|
+let server_replacement =
+ {|
<pre class="compact"><span class="keyword">type</span> server_error = [
| `Internal_Server_Error
| `Not_Implemented
@@ -443,7 +453,8 @@ let server_replacement = {|
]</pre>
|}
-let standard_expected = {|<div class="spec type" id="type-standard_status">
+let standard_expected =
+ {|<div class="spec type" id="type-standard_status">
<a href="#type-standard_status" class="anchor"></a><code><span><span class="keyword">type</span> standard_status</span><span> = </span><span>[ </span></code>
<table>
<tbody>
@@ -478,7 +489,8 @@ let standard_expected = {|<div class="spec type" id="type-standard_status">
</div>
|}
-let standard_replacement = {|
+let standard_replacement =
+ {|
<pre class="compact"><span class="keyword">type</span> standard_status = [
| <a href="#type-informational">informational</a>
| <a href="#type-successful">successful</a>
@@ -488,7 +500,8 @@ let standard_replacement = {|
]</pre>
|}
-let status_expected = {|<div class="spec type" id="type-status">
+let status_expected =
+ {|<div class="spec type" id="type-status">
<a href="#type-status" class="anchor"></a><code><span><span class="keyword">type</span> status</span><span> = </span><span>[ </span></code>
<table>
<tbody>
@@ -508,20 +521,23 @@ let status_expected = {|<div class="spec type" id="type-status">
</div>
|}
-let status_replacement = {|
+let status_replacement =
+ {|
<pre class="compact"><span class="keyword">type</span> status = [
| <a href="#type-standard_status">standard_status</a>
| `Status <span class="of">of</span> int
]</pre>
|}
-let response_expected = {|<div class="spec value" id="val-response">
+let response_expected =
+ {|<div class="spec value" id="val-response">
<a href="#val-response" class="anchor"></a><code><span><span class="keyword">val</span> response : <span>?status:<span>[< <a href="#type-status">status</a> ]</span> <span class="arrow">-></span></span> <span>?code:int <span class="arrow">-></span></span> <span>?headers:<span><span>(string * string)</span> list</span> <span class="arrow">-></span></span>
<span>string <span class="arrow">-></span></span> <a href="#type-response">response</a></span></code>
</div>
|}
-let response_replacement = {|
+let response_replacement =
+ {|
<pre><span class="keyword">val</span> response :
<span class="optional">?status:[< <a href="#type-status">status</a> ] ->
?code:int ->
@@ -530,13 +546,15 @@ let response_replacement = {|
</pre>
|}
-let respond_expected = {|<div class="spec value" id="val-respond">
+let respond_expected =
+ {|<div class="spec value" id="val-respond">
<a href="#val-respond" class="anchor"></a><code><span><span class="keyword">val</span> respond : <span>?status:<span>[< <a href="#type-status">status</a> ]</span> <span class="arrow">-></span></span> <span>?code:int <span class="arrow">-></span></span> <span>?headers:<span><span>(string * string)</span> list</span> <span class="arrow">-></span></span>
<span>string <span class="arrow">-></span></span> <span><a href="#type-response">response</a> <a href="#type-promise">promise</a></span></span></code>
</div>
|}
-let respond_replacement = {|
+let respond_replacement =
+ {|
<pre><span class="keyword">val</span> respond :
<span class="optional">?status:[< <a href="#type-status">status</a> ] ->
?code:int ->
@@ -545,13 +563,15 @@ let respond_replacement = {|
</pre>
|}
-let html_expected = {|<div class="spec value" id="val-html">
+let html_expected =
+ {|<div class="spec value" id="val-html">
<a href="#val-html" class="anchor"></a><code><span><span class="keyword">val</span> html : <span>?status:<span>[< <a href="#type-status">status</a> ]</span> <span class="arrow">-></span></span> <span>?code:int <span class="arrow">-></span></span> <span>?headers:<span><span>(string * string)</span> list</span> <span class="arrow">-></span></span>
<span>string <span class="arrow">-></span></span> <span><a href="#type-response">response</a> <a href="#type-promise">promise</a></span></span></code>
</div>
|}
-let html_replacement = {|
+let html_replacement =
+ {|
<pre><span class="keyword">val</span> html :
<span class="optional">?status:[< <a href="#type-status">status</a> ] ->
?code:int ->
@@ -560,13 +580,15 @@ let html_replacement = {|
</pre>
|}
-let json_expected = {|<div class="spec value" id="val-json">
+let json_expected =
+ {|<div class="spec value" id="val-json">
<a href="#val-json" class="anchor"></a><code><span><span class="keyword">val</span> json : <span>?status:<span>[< <a href="#type-status">status</a> ]</span> <span class="arrow">-></span></span> <span>?code:int <span class="arrow">-></span></span> <span>?headers:<span><span>(string * string)</span> list</span> <span class="arrow">-></span></span>
<span>string <span class="arrow">-></span></span> <span><a href="#type-response">response</a> <a href="#type-promise">promise</a></span></span></code>
</div>
|}
-let json_replacement = {|
+let json_replacement =
+ {|
<pre><span class="keyword">val</span> json :
<span class="optional">?status:[< <a href="#type-status">status</a> ] ->
?code:int ->
@@ -575,13 +597,15 @@ let json_replacement = {|
</pre>
|}
-let val_redirect_expected = {|<div class="spec value" id="val-redirect">
+let val_redirect_expected =
+ {|<div class="spec value" id="val-redirect">
<a href="#val-redirect" class="anchor"></a><code><span><span class="keyword">val</span> redirect : <span>?status:<span>[< <a href="#type-redirection">redirection</a> ]</span> <span class="arrow">-></span></span> <span>?code:int <span class="arrow">-></span></span> <span>?headers:<span><span>(string * string)</span> list</span> <span class="arrow">-></span></span>
<span><a href="#type-request">request</a> <span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> <span><a href="#type-response">response</a> <a href="#type-promise">promise</a></span></span></code>
</div>
|}
-let val_redirect_replacement = {|
+let val_redirect_replacement =
+ {|
<pre><span class="keyword">val</span> redirect :
<span class="optional">?status:[< <a href="#type-redirection">redirection</a> ] ->
?code:int ->
@@ -590,13 +614,15 @@ let val_redirect_replacement = {|
</pre>
|}
-let stream_expected = {|<div class="spec value" id="val-stream">
+let stream_expected =
+ {|<div class="spec value" id="val-stream">
<a href="#val-stream" class="anchor"></a><code><span><span class="keyword">val</span> stream : <span>?status:<span>[< <a href="#type-status">status</a> ]</span> <span class="arrow">-></span></span> <span>?code:int <span class="arrow">-></span></span> <span>?headers:<span><span>(string * string)</span> list</span> <span class="arrow">-></span></span>
<span>?close:bool <span class="arrow">-></span></span> <span><span>(<span><a href="#type-stream">stream</a> <span class="arrow">-></span></span> <span>unit <a href="#type-promise">promise</a></span>)</span> <span class="arrow">-></span></span> <span><a href="#type-response">response</a> <a href="#type-promise">promise</a></span></span></code>
</div>
|}
-let stream_replacement = {|
+let stream_replacement =
+ {|
<pre><span class="keyword">val</span> stream :
?status:[< <a href="#type-status">status</a> ] ->
?code:int ->
@@ -606,39 +632,46 @@ let stream_replacement = {|
</pre>
|}
-let empty_expected = {|<div class="spec value" id="val-empty">
+let empty_expected =
+ {|<div class="spec value" id="val-empty">
<a href="#val-empty" class="anchor"></a><code><span><span class="keyword">val</span> empty : <span>?headers:<span><span>(string * string)</span> list</span> <span class="arrow">-></span></span> <span><a href="#type-status">status</a> <span class="arrow">-></span></span> <span><a href="#type-response">response</a> <a href="#type-promise">promise</a></span></span></code>
</div>
|}
-let empty_replacement = {|
+let empty_replacement =
+ {|
<pre><span class="keyword">val</span> empty :
?headers:(string * string) list ->
<a href="#type-status">status</a> -> <a href="#type-response">response</a> <a href="#type-promise">promise</a>
</pre>
|}
-let add_header_expected = {|<div class="spec value" id="val-add_header">
+let add_header_expected =
+ {|<div class="spec value" id="val-add_header">
<a href="#val-add_header" class="anchor"></a><code><span><span class="keyword">val</span> add_header : <span><span><span class="type-var">'a</span> <a href="#type-message">message</a></span> <span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> unit</span></code>
</div>
|}
-let add_header_replacement = {|
+let add_header_replacement =
+ {|
<pre><span class="keyword">val</span> add_header :
'a <a href="#type-message">message</a> -> string -> string -> unit
|}
-let set_header_expected = {|<div class="spec value" id="val-set_header">
+let set_header_expected =
+ {|<div class="spec value" id="val-set_header">
<a href="#val-set_header" class="anchor"></a><code><span><span class="keyword">val</span> set_header : <span><span><span class="type-var">'a</span> <a href="#type-message">message</a></span> <span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> unit</span></code>
</div>
|}
-let set_header_replacement = {|
+let set_header_replacement =
+ {|
<pre><span class="keyword">val</span> set_header :
'a <a href="#type-message">message</a> -> string -> string -> unit
|}
-let add_set_cookie_expected = {|<div class="spec value" id="val-set_cookie">
+let add_set_cookie_expected =
+ {|<div class="spec value" id="val-set_cookie">
<a href="#val-set_cookie" class="anchor"></a><code><span><span class="keyword">val</span> set_cookie : <span>?prefix:<span><span>[< `Host <span>| `Secure</span> ]</span> option</span> <span class="arrow">-></span></span> <span>?encrypt:bool <span class="arrow">-></span></span>
<span>?expires:float <span class="arrow">-></span></span> <span>?max_age:float <span class="arrow">-></span></span> <span>?domain:string <span class="arrow">-></span></span> <span>?path:<span>string option</span> <span class="arrow">-></span></span>
<span>?secure:bool <span class="arrow">-></span></span> <span>?http_only:bool <span class="arrow">-></span></span> <span>?same_site:<span><span>[< `Strict <span>| `Lax</span> <span>| `None</span> ]</span> option</span> <span class="arrow">-></span></span>
@@ -646,7 +679,8 @@ let add_set_cookie_expected = {|<div class="spec value" id="val-set_cookie">
</div>
|}
-let add_set_cookie_replacement = {|
+let add_set_cookie_replacement =
+ {|
<pre><span class="keyword">val</span> set_cookie :
<span class="optional">?prefix:[< `Host | `Secure ] option ->
?encrypt:bool ->
@@ -660,14 +694,16 @@ let add_set_cookie_replacement = {|
<a href="#type-response">response</a> -> <a href="#type-request">request</a> -> string -> string -> unit
</pre>|}
-let drop_cookie_expected = {|<div class="spec value" id="val-drop_cookie">
+let drop_cookie_expected =
+ {|<div class="spec value" id="val-drop_cookie">
<a href="#val-drop_cookie" class="anchor"></a><code><span><span class="keyword">val</span> drop_cookie : <span>?prefix:<span><span>[< `Host <span>| `Secure</span> ]</span> option</span> <span class="arrow">-></span></span> <span>?domain:string <span class="arrow">-></span></span>
<span>?path:<span>string option</span> <span class="arrow">-></span></span> <span>?secure:bool <span class="arrow">-></span></span> <span>?http_only:bool <span class="arrow">-></span></span>
<span>?same_site:<span><span>[< `Strict <span>| `Lax</span> <span>| `None</span> ]</span> option</span> <span class="arrow">-></span></span> <span><a href="#type-response">response</a> <span class="arrow">-></span></span> <span><a href="#type-request">request</a> <span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> unit</span></code>
</div>
|}
-let drop_cookie_replacement = {|
+let drop_cookie_replacement =
+ {|
<pre><span class="keyword">val</span> drop_cookie :
<span class="optional">?prefix:[< `Host | `Secure ] option ->
?domain:string ->
@@ -678,13 +714,15 @@ let drop_cookie_replacement = {|
<a href="#type-response">response</a> -> <a href="#type-request">request</a> -> string -> unit
</pre>|}
-let cookie_expected = {|<div class="spec value" id="val-cookie">
+let cookie_expected =
+ {|<div class="spec value" id="val-cookie">
<a href="#val-cookie" class="anchor"></a><code><span><span class="keyword">val</span> cookie : <span>?prefix:<span><span>[< `Host <span>| `Secure</span> ]</span> option</span> <span class="arrow">-></span></span> <span>?decrypt:bool <span class="arrow">-></span></span>
<span>?domain:string <span class="arrow">-></span></span> <span>?path:<span>string option</span> <span class="arrow">-></span></span> <span>?secure:bool <span class="arrow">-></span></span> <span><a href="#type-request">request</a> <span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> <span>string option</span></span></code>
</div>
|}
-let cookie_replacement = {|
+let cookie_replacement =
+ {|
<pre><span class="keyword">val</span> cookie :
?prefix:[< `Host | `Secure ] option ->
?decrypt:bool ->
@@ -695,26 +733,30 @@ let cookie_replacement = {|
</pre>
|}
-let bigstring_expected = {|<div class="spec type" id="type-buffer">
+let bigstring_expected =
+ {|<div class="spec type" id="type-buffer">
<a href="#type-buffer" class="anchor"></a><code><span><span class="keyword">type</span> buffer</span><span> = <span><span>(char, <span class="xref-unresolved">Stdlib</span>.Bigarray.int8_unsigned_elt, <span class="xref-unresolved">Stdlib</span>.Bigarray.c_layout)</span> <span class="xref-unresolved">Stdlib</span>.Bigarray.Array1.t</span></span></code>
</div>
|}
-let bigstring_replacement = {|
+let bigstring_replacement =
+ {|
<pre><span class="keyword">type</span> buffer =
(char, Bigarray.int8_unsigned_elt, Bigarray.c_layout)
Bigarray.Array1.t
</pre>
|}
-let read_stream_expected = {|<div class="spec value" id="val-read_stream">
+let read_stream_expected =
+ {|<div class="spec value" id="val-read_stream">
<a href="#val-read_stream" class="anchor"></a><code><span><span class="keyword">val</span> read_stream : <span><a href="#type-stream">stream</a> <span class="arrow">-></span></span> <span>data:<span>(<span><a href="#type-buffer">buffer</a> <span class="arrow">-></span></span> <span>int <span class="arrow">-></span></span> <span>int <span class="arrow">-></span></span> <span>bool <span class="arrow">-></span></span> <span>bool <span class="arrow">-></span></span> unit)</span> <span class="arrow">-></span></span> <span>flush:<span>(<span>unit <span class="arrow">-></span></span> unit)</span> <span class="arrow">-></span></span>
<span>ping:<span>(<span><a href="#type-buffer">buffer</a> <span class="arrow">-></span></span> <span>int <span class="arrow">-></span></span> <span>int <span class="arrow">-></span></span> unit)</span> <span class="arrow">-></span></span> <span>pong:<span>(<span><a href="#type-buffer">buffer</a> <span class="arrow">-></span></span> <span>int <span class="arrow">-></span></span> <span>int <span class="arrow">-></span></span> unit)</span> <span class="arrow">-></span></span> <span>close:<span>(<span>int <span class="arrow">-></span></span> unit)</span> <span class="arrow">-></span></span>
<span>exn:<span>(<span>exn <span class="arrow">-></span></span> unit)</span> <span class="arrow">-></span></span> unit</span></code>
</div>
|}
-let read_stream_replacement = {|
+let read_stream_replacement =
+ {|
<pre><span class="keyword">val</span> read_stream :
<a href="#type-stream">stream</a> ->
data:(<a href="#type-buffer">buffer</a> -> int -> int -> bool -> bool -> unit) ->
@@ -727,13 +769,15 @@ let read_stream_replacement = {|
</pre>
|}
-let write_stream_expected = {|<div class="spec value" id="val-write_stream">
+let write_stream_expected =
+ {|<div class="spec value" id="val-write_stream">
<a href="#val-write_stream" class="anchor"></a><code><span><span class="keyword">val</span> write_stream : <span><a href="#type-stream">stream</a> <span class="arrow">-></span></span> <span><a href="#type-buffer">buffer</a> <span class="arrow">-></span></span> <span>int <span class="arrow">-></span></span> <span>int <span class="arrow">-></span></span> <span>bool <span class="arrow">-></span></span> <span>bool <span class="arrow">-></span></span> <span>close:<span>(<span>int <span class="arrow">-></span></span> unit)</span> <span class="arrow">-></span></span>
<span>exn:<span>(<span>exn <span class="arrow">-></span></span> unit)</span> <span class="arrow">-></span></span> <span><span>(<span>unit <span class="arrow">-></span></span> unit)</span> <span class="arrow">-></span></span> unit</span></code>
</div>
|}
-let write_stream_replacement = {|
+let write_stream_replacement =
+ {|
<pre><span class="keyword">val</span> write_stream :
<a href="#type-stream">stream</a> ->
<a href="#type-buffer">buffer</a> -> int -> int ->
@@ -744,12 +788,14 @@ let write_stream_replacement = {|
unit
</pre>|}
-let flush_stream_expected = {|<div class="spec value" id="val-flush_stream">
+let flush_stream_expected =
+ {|<div class="spec value" id="val-flush_stream">
<a href="#val-flush_stream" class="anchor"></a><code><span><span class="keyword">val</span> flush_stream : <span><a href="#type-stream">stream</a> <span class="arrow">-></span></span> <span>close:<span>(<span>int <span class="arrow">-></span></span> unit)</span> <span class="arrow">-></span></span> <span>exn:<span>(<span>exn <span class="arrow">-></span></span> unit)</span> <span class="arrow">-></span></span> <span><span>(<span>unit <span class="arrow">-></span></span> unit)</span> <span class="arrow">-></span></span> unit</span></code>
</div>
|}
-let flush_stream_replacement = {|
+let flush_stream_replacement =
+ {|
<pre><span class="keyword">val</span> flush_stream :
<a href="#type-stream">stream</a> ->
close:(int -> unit) ->
@@ -758,13 +804,15 @@ let flush_stream_replacement = {|
unit
</pre>|}
-let ping_stream_expected = {|<div class="spec value" id="val-ping_stream">
+let ping_stream_expected =
+ {|<div class="spec value" id="val-ping_stream">
<a href="#val-ping_stream" class="anchor"></a><code><span><span class="keyword">val</span> ping_stream : <span><a href="#type-stream">stream</a> <span class="arrow">-></span></span> <span><a href="#type-buffer">buffer</a> <span class="arrow">-></span></span> <span>int <span class="arrow">-></span></span> <span>int <span class="arrow">-></span></span> <span>close:<span>(<span>int <span class="arrow">-></span></span> unit)</span> <span class="arrow">-></span></span> <span>exn:<span>(<span>exn <span class="arrow">-></span></span> unit)</span> <span class="arrow">-></span></span>
<span><span>(<span>unit <span class="arrow">-></span></span> unit)</span> <span class="arrow">-></span></span> unit</span></code>
</div>
|}
-let ping_stream_replacement = {|
+let ping_stream_replacement =
+ {|
<pre>
<span class="keyword">val</span> ping_stream :
<a href="#type-stream">stream</a> ->
@@ -775,13 +823,15 @@ let ping_stream_replacement = {|
unit
</pre>|}
-let pong_stream_expected = {|<div class="spec value" id="val-pong_stream">
+let pong_stream_expected =
+ {|<div class="spec value" id="val-pong_stream">
<a href="#val-pong_stream" class="anchor"></a><code><span><span class="keyword">val</span> pong_stream : <span><a href="#type-stream">stream</a> <span class="arrow">-></span></span> <span><a href="#type-buffer">buffer</a> <span class="arrow">-></span></span> <span>int <span class="arrow">-></span></span> <span>int <span class="arrow">-></span></span> <span>close:<span>(<span>int <span class="arrow">-></span></span> unit)</span> <span class="arrow">-></span></span> <span>exn:<span>(<span>exn <span class="arrow">-></span></span> unit)</span> <span class="arrow">-></span></span>
<span><span>(<span>unit <span class="arrow">-></span></span> unit)</span> <span class="arrow">-></span></span> unit</span></code>
</div>
|}
-let pong_stream_replacement = {|
+let pong_stream_replacement =
+ {|
<pre>
<span class="keyword">val</span> pong_stream :
<a href="#type-stream">stream</a> ->
@@ -792,7 +842,8 @@ let pong_stream_replacement = {|
unit
</pre>|}
-let form_expected = {|<div class="spec type" id="type-form_result">
+let form_expected =
+ {|<div class="spec type" id="type-form_result">
<a href="#type-form_result" class="anchor"></a><code><span><span class="keyword">type</span> <span>'a form_result</span></span><span> = </span><span>[ </span></code>
<table>
<tbody>
@@ -837,7 +888,8 @@ let form_expected = {|<div class="spec type" id="type-form_result">
</div>
|}
-let form_replacement = {|
+let form_replacement =
+ {|
<pre class="compact"><span class="keyword">type</span> 'a form_result = [
| `Ok <span class="of">of</span> 'a
| `Expired <span class="of">of</span> 'a * float
@@ -849,53 +901,62 @@ let form_replacement = {|
]
|}
-let form'_expected = {|<div class="spec value" id="val-form">
+let form'_expected =
+ {|<div class="spec value" id="val-form">
<a href="#val-form" class="anchor"></a><code><span><span class="keyword">val</span> form : <span>?csrf:bool <span class="arrow">-></span></span> <span><a href="#type-request">request</a> <span class="arrow">-></span></span> <span><span><span><span>(string * string)</span> list</span> <a href="#type-form_result">form_result</a></span> <a href="#type-promise">promise</a></span></span></code>
</div>
|}
-let form'_replacement = {|
+let form'_replacement =
+ {|
<pre><span class="keyword">val</span> form :
?csrf:bool ->
<a href="#type-request">request</a> -> (string * string) list <a href="#type-form_result">form_result</a> <a href="#type-promise">promise</a>
</pre>
|}
-let multipart_form_expected = {|<div class="spec type" id="type-multipart_form">
+let multipart_form_expected =
+ {|<div class="spec type" id="type-multipart_form">
<a href="#type-multipart_form" class="anchor"></a><code><span><span class="keyword">type</span> multipart_form</span><span> = <span><span>(string * <span><span>(<span>string option</span> * string)</span> list</span>)</span> list</span></span></code>
</div>
|}
-let multipart_form_replacement = {|
+let multipart_form_replacement =
+ {|
<pre><span class="keyword">type</span> multipart_form =
(string * ((string option * string) list)) list
</pre>
|}
-let multipart_expected = {|<div class="spec value" id="val-multipart">
+let multipart_expected =
+ {|<div class="spec value" id="val-multipart">
<a href="#val-multipart" class="anchor"></a><code><span><span class="keyword">val</span> multipart : <span>?csrf:bool <span class="arrow">-></span></span> <span><a href="#type-request">request</a> <span class="arrow">-></span></span> <span><span><a href="#type-multipart_form">multipart_form</a> <a href="#type-form_result">form_result</a></span> <a href="#type-promise">promise</a></span></span></code>
</div>
|}
-let multipart_replacement = {|
+let multipart_replacement =
+ {|
<pre><span class="keyword">val</span> multipart :
?csrf:bool ->
<a href="#type-request">request</a> -> <a href="#type-multipart">multipart_form</a> <a href="#type-form_result">form_result</a> <a href="#type-promise">promise</a>
</pre>
|}
-let part_expected = {|<div class="spec type" id="type-part">
+let part_expected =
+ {|<div class="spec type" id="type-part">
<a href="#type-part" class="anchor"></a><code><span><span class="keyword">type</span> part</span><span> = <span>string option</span> * <span>string option</span> * <span><span>(string * string)</span> list</span></span></code>
</div>
|}
-let part_replacement = {|
+let part_replacement =
+ {|
<pre><span class="keyword">type</span> part =
string option * string option * ((string * string) list)
</pre>
|}
-let upload_event_expected = {|<div class="spec type" id="type-upload_event">
+let upload_event_expected =
+ {|<div class="spec type" id="type-upload_event">
<a href="#type-upload_event" class="anchor"></a><code><span><span class="keyword">type</span> upload_event</span><span> = </span><span>[ </span></code>
<table>
<tbody>
@@ -925,7 +986,8 @@ let upload_event_expected = {|<div class="spec type" id="type-upload_event">
</div>
|}
-let upload_event_replacement = {|
+let upload_event_replacement =
+ {|
<pre><span class="keyword">type</span> upload_event = [
| `File <span class="of">of</span> string * string
| `Field <span class="of">of</span> string * string
@@ -935,7 +997,8 @@ let upload_event_replacement = {|
</pre>
|}
-let csrf_result_expected = {|<div class="spec type" id="type-csrf_result">
+let csrf_result_expected =
+ {|<div class="spec type" id="type-csrf_result">
<a href="#type-csrf_result" class="anchor"></a><code><span><span class="keyword">type</span> csrf_result</span><span> = </span><span>[ </span></code>
<table>
<tbody>
@@ -965,7 +1028,8 @@ let csrf_result_expected = {|<div class="spec type" id="type-csrf_result">
</div>
|}
-let csrf_result_replacement = {|
+let csrf_result_replacement =
+ {|
<pre class="compact"><span class="keyword">type</span> csrf_result = [
| `Ok
| `Expired <span class="of">of</span> float
@@ -974,129 +1038,155 @@ let csrf_result_replacement = {|
]
|}
-let verify_csrf_token_expected = {|<div class="spec value" id="val-verify_csrf_token">
+let verify_csrf_token_expected =
+ {|<div class="spec value" id="val-verify_csrf_token">
<a href="#val-verify_csrf_token" class="anchor"></a><code><span><span class="keyword">val</span> verify_csrf_token : <span><a href="#type-request">request</a> <span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> <span><a href="#type-csrf_result">csrf_result</a> <a href="#type-promise">promise</a></span></span></code>
</div>
|}
-let verify_csrf_token_replacement = {|
+let verify_csrf_token_replacement =
+ {|
<pre><span class="keyword">val</span> verify_csrf_token :
<a href="#type-request">request</a> -> string -> <a href="#type-csrf_result">csrf_result</a> <a href="#type-promise">promise</a>
</pre>
|}
-let scope_expected = {|<div class="spec value" id="val-scope">
+let scope_expected =
+ {|<div class="spec value" id="val-scope">
<a href="#val-scope" class="anchor"></a><code><span><span class="keyword">val</span> scope : <span>string <span class="arrow">-></span></span> <span><span><a href="#type-middleware">middleware</a> list</span> <span class="arrow">-></span></span> <span><span><a href="#type-route">route</a> list</span> <span class="arrow">-></span></span> <a href="#type-route">route</a></span></code>
</div>
|}
-let scope_replacement = {|
+let scope_replacement =
+ {|
<pre><span class="keyword">val</span> scope :
string -> <a href="#type-middleware">middleware</a> list -> <a href="#type-route">route</a> list -> <a href="#type-route">route</a>
</pre>
|}
-let get_expected = {|<div class="spec value" id="val-get">
+let get_expected =
+ {|<div class="spec value" id="val-get">
<a href="#val-get" class="anchor"></a><code><span><span class="keyword">val</span> get : <span>string <span class="arrow">-></span></span> <span><a href="#type-handler">handler</a> <span class="arrow">-></span></span> <a href="#type-route">route</a></span></code>
</div>
|}
-let get_replacement = {|
+let get_replacement =
+ {|
<code><span><span class="keyword">val</span> get : <span>string <span class="arrow">-></span></span> <span><a href="#type-handler">handler</a> <span class="arrow">-></span></span> <a href="#type-route">route</a></span></code>
|}
-let post_expected = {|<div class="spec value" id="val-post">
+let post_expected =
+ {|<div class="spec value" id="val-post">
<a href="#val-post" class="anchor"></a><code><span><span class="keyword">val</span> post : <span>string <span class="arrow">-></span></span> <span><a href="#type-handler">handler</a> <span class="arrow">-></span></span> <a href="#type-route">route</a></span></code>
</div>
|}
-let post_replacement = {|
+let post_replacement =
+ {|
<code><span><span class="keyword">val</span> post : <span>string <span class="arrow">-></span></span> <span><a href="#type-handler">handler</a> <span class="arrow">-></span></span> <a href="#type-route">route</a></span></code>
|}
-let put_expected = {|<div class="spec value" id="val-put">
+let put_expected =
+ {|<div class="spec value" id="val-put">
<a href="#val-put" class="anchor"></a><code><span><span class="keyword">val</span> put : <span>string <span class="arrow">-></span></span> <span><a href="#type-handler">handler</a> <span class="arrow">-></span></span> <a href="#type-route">route</a></span></code>
</div>
|}
-let put_replacement = {|
+let put_replacement =
+ {|
<code><span><span class="keyword">val</span> put : <span>string <span class="arrow">-></span></span> <span><a href="#type-handler">handler</a> <span class="arrow">-></span></span> <a href="#type-route">route</a></span></code>
|}
-let delete_expected = {|<div class="spec value" id="val-delete">
+let delete_expected =
+ {|<div class="spec value" id="val-delete">
<a href="#val-delete" class="anchor"></a><code><span><span class="keyword">val</span> delete : <span>string <span class="arrow">-></span></span> <span><a href="#type-handler">handler</a> <span class="arrow">-></span></span> <a href="#type-route">route</a></span></code>
</div>
|}
-let delete_replacement = {|
+let delete_replacement =
+ {|
<code><span><span class="keyword">val</span> delete : <span>string <span class="arrow">-></span></span> <span><a href="#type-handler">handler</a> <span class="arrow">-></span></span> <a href="#type-route">route</a></span></code>
|}
-let head_expected = {|<div class="spec value" id="val-head">
+let head_expected =
+ {|<div class="spec value" id="val-head">
<a href="#val-head" class="anchor"></a><code><span><span class="keyword">val</span> head : <span>string <span class="arrow">-></span></span> <span><a href="#type-handler">handler</a> <span class="arrow">-></span></span> <a href="#type-route">route</a></span></code>
</div>
|}
-let head_replacement = {|
+let head_replacement =
+ {|
<code><span><span class="keyword">val</span> head : <span>string <span class="arrow">-></span></span> <span><a href="#type-handler">handler</a> <span class="arrow">-></span></span> <a href="#type-route">route</a></span></code>
|}
-let trace_expected = {|<div class="spec value" id="val-trace">
+let trace_expected =
+ {|<div class="spec value" id="val-trace">
<a href="#val-trace" class="anchor"></a><code><span><span class="keyword">val</span> trace : <span>string <span class="arrow">-></span></span> <span><a href="#type-handler">handler</a> <span class="arrow">-></span></span> <a href="#type-route">route</a></span></code>
</div>
|}
-let trace_replacement = {|
+let trace_replacement =
+ {|
<code><span><span class="keyword">val</span> trace : <span>string <span class="arrow">-></span></span> <span><a href="#type-handler">handler</a> <span class="arrow">-></span></span> <a href="#type-route">route</a></span></code>
|}
-let patch_expected = {|<div class="spec value" id="val-patch">
+let patch_expected =
+ {|<div class="spec value" id="val-patch">
<a href="#val-patch" class="anchor"></a><code><span><span class="keyword">val</span> patch : <span>string <span class="arrow">-></span></span> <span><a href="#type-handler">handler</a> <span class="arrow">-></span></span> <a href="#type-route">route</a></span></code>
</div>
|}
-let patch_replacement = {|
+let patch_replacement =
+ {|
<code><span><span class="keyword">val</span> patch : <span>string <span class="arrow">-></span></span> <span><a href="#type-handler">handler</a> <span class="arrow">-></span></span> <a href="#type-route">route</a></span></code>
|}
-let any_expected = {|<div class="spec value" id="val-any">
+let any_expected =
+ {|<div class="spec value" id="val-any">
<a href="#val-any" class="anchor"></a><code><span><span class="keyword">val</span> any : <span>string <span class="arrow">-></span></span> <span><a href="#type-handler">handler</a> <span class="arrow">-></span></span> <a href="#type-route">route</a></span></code>
</div>
|}
-let any_replacement = {|
+let any_replacement =
+ {|
<code><span><span class="keyword">val</span> any : <span>string <span class="arrow">-></span></span> <span><a href="#type-handler">handler</a> <span class="arrow">-></span></span> <a href="#type-route">route</a></span></code>
|}
-let static_expected = {|<div class="spec value" id="val-static">
+let static_expected =
+ {|<div class="spec value" id="val-static">
<a href="#val-static" class="anchor"></a><code><span><span class="keyword">val</span> static : <span>?loader:<span>(<span>string <span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> <a href="#type-handler">handler</a>)</span> <span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> <a href="#type-handler">handler</a></span></code>
</div>
|}
-let static_replacement = {|
+let static_replacement =
+ {|
<pre><span class="keyword">val</span> static :
?loader:(string -> string -> <a href="#type-handler">handler</a>) ->
string -> <a href="#type-handler">handler</a>
</pre>
|}
-let set_session_expected = {|<div class="spec value" id="val-set_session_field">
+let set_session_expected =
+ {|<div class="spec value" id="val-set_session_field">
<a href="#val-set_session_field" class="anchor"></a><code><span><span class="keyword">val</span> set_session_field : <span><a href="#type-request">request</a> <span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> <span>unit <a href="#type-promise">promise</a></span></span></code>
</div>
|}
-let set_session_replacement = {|
+let set_session_replacement =
+ {|
<pre><span class="keyword">val</span> set_session_field :
<a href="#type-request">request</a> -> string -> string -> unit <a href="#type-promise">promise</a>
</pre>
|}
-let websocket_expected = {|<div class="spec value" id="val-websocket">
+let websocket_expected =
+ {|<div class="spec value" id="val-websocket">
<a href="#val-websocket" class="anchor"></a><code><span><span class="keyword">val</span> websocket : <span>?headers:<span><span>(string * string)</span> list</span> <span class="arrow">-></span></span> <span>?close:bool <span class="arrow">-></span></span> <span><span>(<span><a href="#type-websocket">websocket</a> <span class="arrow">-></span></span> <span>unit <a href="#type-promise">promise</a></span>)</span> <span class="arrow">-></span></span> <span><a href="#type-response">response</a> <a href="#type-promise">promise</a></span></span></code>
</div>
|}
-let websocket_replacement = {|
+let websocket_replacement =
+ {|
<pre><span class="keyword">val</span> websocket :
?headers:(string * string) list ->
?close:bool ->
@@ -1104,7 +1194,8 @@ let websocket_replacement = {|
</pre>
|}
-let text_or_binary_expected = {|<div class="spec type" id="type-text_or_binary">
+let text_or_binary_expected =
+ {|<div class="spec type" id="type-text_or_binary">
<a href="#type-text_or_binary" class="anchor"></a><code><span><span class="keyword">type</span> text_or_binary</span><span> = </span><span>[ </span></code>
<table>
<tbody>
@@ -1124,11 +1215,13 @@ let text_or_binary_expected = {|<div class="spec type" id="type-text_or_binary">
</div>
|}
-let text_or_binary_replacement = {|
+let text_or_binary_replacement =
+ {|
<pre class="compact"><span class="keyword">type</span> text_or_binary = [ `Text | `Binary ]</pre>
|}
-let end_of_message_expected = {|<div class="spec type" id="type-end_of_message">
+let end_of_message_expected =
+ {|<div class="spec type" id="type-end_of_message">
<a href="#type-end_of_message" class="anchor"></a><code><span><span class="keyword">type</span> end_of_message</span><span> = </span><span>[ </span></code>
<table>
<tbody>
@@ -1148,16 +1241,19 @@ let end_of_message_expected = {|<div class="spec type" id="type-end_of_message">
</div>
|}
-let end_of_message_replacement = {|
+let end_of_message_replacement =
+ {|
<pre class="compact"><span class="keyword">type</span> end_of_message = [ `End_of_message | `Continues ]</pre>
|}
-let send_expected = {|<div class="spec value" id="val-send">
+let send_expected =
+ {|<div class="spec value" id="val-send">
<a href="#val-send" class="anchor"></a><code><span><span class="keyword">val</span> send : <span>?text_or_binary:<span>[< <a href="#type-text_or_binary">text_or_binary</a> ]</span> <span class="arrow">-></span></span> <span>?end_of_message:<span>[< <a href="#type-end_of_message">end_of_message</a> ]</span> <span class="arrow">-></span></span> <span><a href="#type-websocket">websocket</a> <span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> <span>unit <a href="#type-promise">promise</a></span></span></code>
</div>
|}
-let send_replacement = {|
+let send_replacement =
+ {|
<pre><span class="keyword">val</span> send :
?text_or_binary:[< <a href="#type-text_or_binary">text_or_binary</a> ] ->
?end_of_message:[< <a href="#type-end_of_message">end_of_message</a> ] ->
@@ -1165,35 +1261,41 @@ let send_replacement = {|
</pre>
|}
-let receive_fragment_expected = {|<div class="spec value" id="val-receive_fragment">
+let receive_fragment_expected =
+ {|<div class="spec value" id="val-receive_fragment">
<a href="#val-receive_fragment" class="anchor"></a><code><span><span class="keyword">val</span> receive_fragment : <span><a href="#type-websocket">websocket</a> <span class="arrow">-></span></span> <span><span><span>(string * <a href="#type-text_or_binary">text_or_binary</a> * <a href="#type-end_of_message">end_of_message</a>)</span> option</span> <a href="#type-promise">promise</a></span></span></code>
</div>
|}
-let receive_fragment_replacement = {|
+let receive_fragment_replacement =
+ {|
<pre><span class="keyword">val</span> receive_fragment :
<a href="#type-websocket">websocket</a> ->
(string * <a href="#type-text_or_binary">text_or_binary</a> * <a href="#type-end_of_message">end_of_message</a>) option <a href="#type-promise">promise</a>
</pre>
|}
-let close_websocket_expected = {|<div class="spec value" id="val-close_websocket">
+let close_websocket_expected =
+ {|<div class="spec value" id="val-close_websocket">
<a href="#val-close_websocket" class="anchor"></a><code><span><span class="keyword">val</span> close_websocket : <span>?code:int <span class="arrow">-></span></span> <span><a href="#type-websocket">websocket</a> <span class="arrow">-></span></span> <span>unit <a href="#type-promise">promise</a></span></span></code>
</div>
|}
-let close_websocket_replacement = {|
+let close_websocket_replacement =
+ {|
<pre><span class="keyword">val</span> close_websocket :
?code:int -> <a href="#type-websocket">websocket</a> -> unit <a href="#type-promise">promise</a>
</pre>
|}
-let graphql_expected = {|<div class="spec value" id="val-graphql">
+let graphql_expected =
+ {|<div class="spec value" id="val-graphql">
<a href="#val-graphql" class="anchor"></a><code><span><span class="keyword">val</span> graphql : <span><span>(<span><a href="#type-request">request</a> <span class="arrow">-></span></span> <span><span class="type-var">'a</span> <a href="#type-promise">promise</a></span>)</span> <span class="arrow">-></span></span> <span><span><span class="type-var">'a</span> <span class="xref-unresolved">Graphql_lwt</span>.Schema.schema</span> <span class="arrow">-></span></span> <a href="#type-handler">handler</a></span></code>
</div>
|}
-let graphql_replacement = {|
+let graphql_replacement =
+ {|
<pre><span class="keyword">val</span> graphql :
(<a href="#type-request">request</a> -> 'a <a href="#type-promise">promise</a>) ->
'a Graphql_lwt.Schema.schema ->
@@ -1201,24 +1303,28 @@ let graphql_replacement = {|
</pre>
|}
-let sql_expected = {|<div class="spec value" id="val-sql">
+let sql_expected =
+ {|<div class="spec value" id="val-sql">
<a href="#val-sql" class="anchor"></a><code><span><span class="keyword">val</span> sql : <span><a href="#type-request">request</a> <span class="arrow">-></span></span> <span><span>(<span><span class="xref-unresolved">Caqti_lwt</span>.connection <span class="arrow">-></span></span> <span><span class="type-var">'a</span> <a href="#type-promise">promise</a></span>)</span> <span class="arrow">-></span></span> <span><span class="type-var">'a</span> <a href="#type-promise">promise</a></span></span></code>
</div>
|}
-let sql_replacement = {|
+let sql_replacement =
+ {|
<pre><span class="keyword">val</span> sql :
<a href="#type-request">request</a> -> (Caqti_lwt.connection -> 'a <a href="#type-promise">promise</a>) ->
'a <a href="#type-promise">promise</a>
</pre>
|}
-let conditional_log_expected = {|<div class="spec type" id="type-conditional_log">
+let conditional_log_expected =
+ {|<div class="spec type" id="type-conditional_log">
<a href="#type-conditional_log" class="anchor"></a><code><span><span class="keyword">type</span> <span>('a, 'b) conditional_log</span></span><span> = <span><span>(<span><span>(<span>?request:<a href="#type-request">request</a> <span class="arrow">-></span></span> <span><span><span>(<span class="type-var">'a</span>, <span class="xref-unresolved">Stdlib</span>.Format.formatter, unit, <span class="type-var">'b</span>)</span> <span class="xref-unresolved">Stdlib</span>.format4</span> <span class="arrow">-></span></span> <span class="type-var">'a</span>)</span> <span class="arrow">-></span></span> <span class="type-var">'b</span>)</span> <span class="arrow">-></span></span> unit</span></code>
</div>
|}
-let conditional_log_replacement = {|
+let conditional_log_replacement =
+ {|
<pre class="compact"><span class="keyword">type</span> ('a, 'b) conditional_log =
((?request:<a href="#type-request">request</a> ->
('a, Format.formatter, unit, 'b) format4 -> 'a) -> 'b) ->
@@ -1226,7 +1332,8 @@ let conditional_log_replacement = {|
</pre>
|}
-let sub_log_expected = {|<div class="spec type" id="type-sub_log">
+let sub_log_expected =
+ {|<div class="spec type" id="type-sub_log">
<a href="#type-sub_log" class="anchor"></a><code><span><span class="keyword">type</span> sub_log</span><span> = </span><span>{</span></code>
<table>
<tbody>
@@ -1256,7 +1363,8 @@ let sub_log_expected = {|<div class="spec type" id="type-sub_log">
</div>
|}
-let sub_log_replacement = {|
+let sub_log_replacement =
+ {|
<pre class="compact"><span class="keyword">type</span> sub_log = {
error <span class="of">:</span> 'a. ('a, unit) <a href="#type-conditional_log">conditional_log</a>;
warning <span class="of">:</span> 'a. ('a, unit) <a href="#type-conditional_log">conditional_log</a>;
@@ -1265,7 +1373,8 @@ let sub_log_replacement = {|
}
</pre>|}
-let log_level_expected = {|<div class="spec type" id="type-log_level">
+let log_level_expected =
+ {|<div class="spec type" id="type-log_level">
<a href="#type-log_level" class="anchor"></a><code><span><span class="keyword">type</span> log_level</span><span> = </span><span>[ </span></code>
<table>
<tbody>
@@ -1295,53 +1404,64 @@ let log_level_expected = {|<div class="spec type" id="type-log_level">
</div>
|}
-let log_level_replacement = {|
+let log_level_replacement =
+ {|
<code><span class="keyword">type</span> log_level = [ `Error | `Warning | `Info | `Debug ]</code>
|}
-let val_error_expected = {|<div class="spec value" id="val-error">
+let val_error_expected =
+ {|<div class="spec value" id="val-error">
<a href="#val-error" class="anchor"></a><code><span><span class="keyword">val</span> error : <span><span>(<span class="type-var">'a</span>, unit)</span> <a href="#type-conditional_log">conditional_log</a></span></span></code>
</div>
|}
-let val_error_replacement = {|
+let val_error_replacement =
+ {|
<code><span><span class="keyword">val</span> error : <span><span>(<span class="type-var">'a</span>, unit)</span> <a href="#type-conditional_log">conditional_log</a></span></span></code>
|}
-let warning_expected = {|<div class="spec value" id="val-warning">
+let warning_expected =
+ {|<div class="spec value" id="val-warning">
<a href="#val-warning" class="anchor"></a><code><span><span class="keyword">val</span> warning : <span><span>(<span class="type-var">'a</span>, unit)</span> <a href="#type-conditional_log">conditional_log</a></span></span></code>
</div>
|}
-let warning_replacement = {|
+let warning_replacement =
+ {|
<code><span><span class="keyword">val</span> warning : <span><span>(<span class="type-var">'a</span>, unit)</span> <a href="#type-conditional_log">conditional_log</a></span></span></code>
|}
-let info_expected = {|<div class="spec value" id="val-info">
+let info_expected =
+ {|<div class="spec value" id="val-info">
<a href="#val-info" class="anchor"></a><code><span><span class="keyword">val</span> info : <span><span>(<span class="type-var">'a</span>, unit)</span> <a href="#type-conditional_log">conditional_log</a></span></span></code>
</div>
|}
-let info_replacement = {|
+let info_replacement =
+ {|
<code><span><span class="keyword">val</span> info : <span><span>(<span class="type-var">'a</span>, unit)</span> <a href="#type-conditional_log">conditional_log</a></span></span></code>
|}
-let debug_expected = {|<div class="spec value" id="val-debug">
+let debug_expected =
+ {|<div class="spec value" id="val-debug">
<a href="#val-debug" class="anchor"></a><code><span><span class="keyword">val</span> debug : <span><span>(<span class="type-var">'a</span>, unit)</span> <a href="#type-conditional_log">conditional_log</a></span></span></code>
</div>
|}
-let debug_replacement = {|
+let debug_replacement =
+ {|
<code><span><span class="keyword">val</span> debug : <span><span>(<span class="type-var">'a</span>, unit)</span> <a href="#type-conditional_log">conditional_log</a></span></span></code>
|}
-let initialize_log_expected = {|<div class="spec value" id="val-initialize_log">
+let initialize_log_expected =
+ {|<div class="spec value" id="val-initialize_log">
<a href="#val-initialize_log" class="anchor"></a><code><span><span class="keyword">val</span> initialize_log : <span>?backtraces:bool <span class="arrow">-></span></span> <span>?async_exception_hook:bool <span class="arrow">-></span></span>
<span>?level:<span>[< <a href="#type-log_level">log_level</a> ]</span> <span class="arrow">-></span></span> <span>?enable:bool <span class="arrow">-></span></span> <span>unit <span class="arrow">-></span></span> unit</span></code>
</div>
|}
-let initialize_log_replacement = {|
+let initialize_log_replacement =
+ {|
<pre><span class="keyword">val</span> initialize_log :
<span class="optional">?backtraces:bool ->
?async_exception_hook:bool ->
@@ -1350,19 +1470,22 @@ let initialize_log_replacement = {|
unit -> unit
</pre>|}
-let error_template_expected = {|<div class="spec value" id="val-error_template">
+let error_template_expected =
+ {|<div class="spec value" id="val-error_template">
<a href="#val-error_template" class="anchor"></a><code><span><span class="keyword">val</span> error_template : <span><span>(<span><a href="#type-error">error</a> <span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> <span><a href="#type-response">response</a> <span class="arrow">-></span></span> <span><a href="#type-response">response</a> <a href="#type-promise">promise</a></span>)</span> <span class="arrow">-></span></span> <a href="#type-error_handler">error_handler</a></span></code>
</div>
|}
-let error_template_replacement = {|
+let error_template_replacement =
+ {|
<pre><span class="keyword">val</span> error_template :
(<a href="#type-error">error</a> -> string -> <a href="#val-response">response</a> -> <a href="#val-response">response</a> <a href="#type-promise">promise</a>) ->
<a href="#type-error_handler">error_handler</a>
</pre>
|}
-let error_expected = {|<div class="spec type" id="type-error">
+let error_expected =
+ {|<div class="spec type" id="type-error">
<a href="#type-error" class="anchor"></a><code><span><span class="keyword">type</span> error</span><span> = </span><span>{</span></code>
<table>
<tbody>
@@ -1412,7 +1535,8 @@ let error_expected = {|<div class="spec type" id="type-error">
</div>
|}
-let error_replacement = {|
+let error_replacement =
+ {|
<pre class="compact"><span class="keyword">type</span> error = {
condition <span class="of">:</span> [
| `Response of <a href="#type-response">response</a>
@@ -1429,12 +1553,14 @@ let error_replacement = {|
}
</pre>|}
-let new_field_expected = {|<div class="spec value" id="val-new_field">
+let new_field_expected =
+ {|<div class="spec value" id="val-new_field">
<a href="#val-new_field" class="anchor"></a><code><span><span class="keyword">val</span> new_field : <span>?name:string <span class="arrow">-></span></span> <span>?show_value:<span>(<span><span class="type-var">'a</span> <span class="arrow">-></span></span> string)</span> <span class="arrow">-></span></span> <span>unit <span class="arrow">-></span></span> <span><span class="type-var">'a</span> <a href="#type-field">field</a></span></span></code>
</div>
|}
-let new_field_replacement = {|
+let new_field_replacement =
+ {|
<pre><span class="keyword">val</span> new_field :
?name:string ->
?show_value:('a -> string) ->
@@ -1442,26 +1568,30 @@ let new_field_replacement = {|
</pre>
|}
-let new_global_expected = {|<div class="spec value" id="val-new_global">
+let new_global_expected =
+ {|<div class="spec value" id="val-new_global">
<a href="#val-new_global" class="anchor"></a><code><span><span class="keyword">val</span> new_global : <span>?name:string <span class="arrow">-></span></span> <span>?show_value:<span>(<span><span class="type-var">'a</span> <span class="arrow">-></span></span> string)</span> <span class="arrow">-></span></span> <span><span>(<span>unit <span class="arrow">-></span></span> <span class="type-var">'a</span>)</span> <span class="arrow">-></span></span> <span><span class="type-var">'a</span> <a href="#type-global">global</a></span></span></code>
</div>
|}
-let new_global_replacement = {|
+let new_global_replacement =
+ {|
<pre><span class="keyword">val</span> new_global :
?name:string ->
?show_value:('a -> string) ->
(unit -> 'a) -> 'a <a href="#type-global">global</a>
|}
-let run_expected = {|<div class="spec value" id="val-run">
+let run_expected =
+ {|<div class="spec value" id="val-run">
<a href="#val-run" class="anchor"></a><code><span><span class="keyword">val</span> run : <span>?interface:string <span class="arrow">-></span></span> <span>?port:int <span class="arrow">-></span></span> <span>?stop:<span>unit <a href="#type-promise">promise</a></span> <span class="arrow">-></span></span> <span>?error_handler:<a href="#type-error_handler">error_handler</a> <span class="arrow">-></span></span>
<span>?tls:bool <span class="arrow">-></span></span> <span>?certificate_file:string <span class="arrow">-></span></span> <span>?key_file:string <span class="arrow">-></span></span> <span>?builtins:bool <span class="arrow">-></span></span>
<span>?greeting:bool <span class="arrow">-></span></span> <span>?adjust_terminal:bool <span class="arrow">-></span></span> <span><a href="#type-handler">handler</a> <span class="arrow">-></span></span> unit</span></code>
</div>
|}
-let run_replacement = {|
+let run_replacement =
+ {|
<pre><span class="keyword">val</span> run :
<span class="optional">?interface:string ->
?port:int ->
@@ -1479,14 +1609,16 @@ let run_replacement = {|
<a href="#type-handler">handler</a> -> unit
</pre>|}
-let serve_expected = {|<div class="spec value" id="val-serve">
+let serve_expected =
+ {|<div class="spec value" id="val-serve">
<a href="#val-serve" class="anchor"></a><code><span><span class="keyword">val</span> serve : <span>?interface:string <span class="arrow">-></span></span> <span>?port:int <span class="arrow">-></span></span> <span>?stop:<span>unit <a href="#type-promise">promise</a></span> <span class="arrow">-></span></span> <span>?error_handler:<a href="#type-error_handler">error_handler</a> <span class="arrow">-></span></span>
<span>?tls:bool <span class="arrow">-></span></span> <span>?certificate_file:string <span class="arrow">-></span></span> <span>?key_file:string <span class="arrow">-></span></span> <span>?builtins:bool <span class="arrow">-></span></span>
<span><a href="#type-handler">handler</a> <span class="arrow">-></span></span> <span>unit <a href="#type-promise">promise</a></span></span></code>
</div>
|}
-let serve_replacement = {|
+let serve_replacement =
+ {|
<pre><span class="keyword">val</span> serve :
<span class="optional">?interface:string ->
?port:int ->
@@ -1502,25 +1634,29 @@ let serve_replacement = {|
<a href="#type-handler">handler</a> -> unit <a href="#type-promise">promise</a>
</pre>|}
-let to_percent_encoded_expected = {|<div class="spec value" id="val-to_percent_encoded">
+let to_percent_encoded_expected =
+ {|<div class="spec value" id="val-to_percent_encoded">
<a href="#val-to_percent_encoded" class="anchor"></a><code><span><span class="keyword">val</span> to_percent_encoded : <span>?international:bool <span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> string</span></code>
</div>
|}
-let to_percent_encoded_replacement = {|
+let to_percent_encoded_replacement =
+ {|
<pre><span class="keyword">val</span> to_percent_encoded :
?international:bool -> string -> string
</pre>
|}
-let to_set_cookie_expected = {|<div class="spec value" id="val-to_set_cookie">
+let to_set_cookie_expected =
+ {|<div class="spec value" id="val-to_set_cookie">
<a href="#val-to_set_cookie" class="anchor"></a><code><span><span class="keyword">val</span> to_set_cookie : <span>?expires:float <span class="arrow">-></span></span> <span>?max_age:float <span class="arrow">-></span></span> <span>?domain:string <span class="arrow">-></span></span>
<span>?path:string <span class="arrow">-></span></span> <span>?secure:bool <span class="arrow">-></span></span> <span>?http_only:bool <span class="arrow">-></span></span>
<span>?same_site:<span>[ `Strict <span>| `Lax</span> <span>| `None</span> ]</span> <span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> string</span></code>
</div>
|}
-let to_set_cookie_replacement = {|
+let to_set_cookie_replacement =
+ {|
<pre><span class="keyword">val</span> to_set_cookie :
?expires:float ->
?max_age:float ->
@@ -1533,12 +1669,14 @@ let to_set_cookie_replacement = {|
</pre>
|}
-let to_path_expected = {|<div class="spec value" id="val-to_path">
+let to_path_expected =
+ {|<div class="spec value" id="val-to_path">
<a href="#val-to_path" class="anchor"></a><code><span><span class="keyword">val</span> to_path : <span>?relative:bool <span class="arrow">-></span></span> <span>?international:bool <span class="arrow">-></span></span> <span><span>string list</span> <span class="arrow">-></span></span> string</span></code>
</div>
|}
-let to_path_replacement = {|
+let to_path_replacement =
+ {|
<pre><span class="keyword">val</span> to_path :
?relative:bool ->
?international:bool ->
@@ -1546,37 +1684,43 @@ let to_path_replacement = {|
</pre>
|}
-let encrypt_expected = {|<div class="spec value" id="val-encrypt">
+let encrypt_expected =
+ {|<div class="spec value" id="val-encrypt">
<a href="#val-encrypt" class="anchor"></a><code><span><span class="keyword">val</span> encrypt : <span>?associated_data:string <span class="arrow">-></span></span> <span><a href="#type-request">request</a> <span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> string</span></code>
</div>
|}
-let encrypt_replacement = {|
+let encrypt_replacement =
+ {|
<pre><span class="keyword">val</span> encrypt :
?associated_data:string ->
<a href="#type-request">request</a> -> string -> string
</pre>
|}
-let decrypt_expected = {|<div class="spec value" id="val-decrypt">
+let decrypt_expected =
+ {|<div class="spec value" id="val-decrypt">
<a href="#val-decrypt" class="anchor"></a><code><span><span class="keyword">val</span> decrypt : <span>?associated_data:string <span class="arrow">-></span></span> <span><a href="#type-request">request</a> <span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> <span>string option</span></span></code>
</div>
|}
-let decrypt_replacement = {|
+let decrypt_replacement =
+ {|
<pre><span class="keyword">val</span> decrypt :
?associated_data:string ->
<a href="#type-request">request</a> -> string -> string option
</pre>
|}
-let request_expected = {|<div class="spec value" id="val-request">
+let request_expected =
+ {|<div class="spec value" id="val-request">
<a href="#val-request" class="anchor"></a><code><span><span class="keyword">val</span> request : <span>?method_:<span>[< <a href="#type-method_">method_</a> ]</span> <span class="arrow">-></span></span> <span>?target:string <span class="arrow">-></span></span> <span>?headers:<span><span>(string * string)</span> list</span>
<span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> <a href="#type-request">request</a></span></code>
</div>
|}
-let request_replacement = {|
+let request_replacement =
+ {|
<pre><span class="keyword">val</span> request :
<span class="optional">?method_:[< <a href="#type-method_">method_</a> ] ->
?target:string ->
@@ -1584,57 +1728,66 @@ let request_replacement = {|
string -> <a href="#type-request">request</a>
</pre>|}
-let sort_headers_expected = {|<div class="spec value" id="val-sort_headers">
+let sort_headers_expected =
+ {|<div class="spec value" id="val-sort_headers">
<a href="#val-sort_headers" class="anchor"></a><code><span><span class="keyword">val</span> sort_headers : <span><span><span>(string * string)</span> list</span> <span class="arrow">-></span></span> <span><span>(string * string)</span> list</span></span></code>
</div>
|}
-let sort_headers_replacement = {|
+let sort_headers_replacement =
+ {|
<pre><span class="keyword">val</span> sort_headers :
(string * string) list -> (string * string) list
</pre>|}
-let message_expected = {|<div class="spec type" id="type-message">
+let message_expected =
+ {|<div class="spec type" id="type-message">
<a href="#type-message" class="anchor"></a><code><span><span class="keyword">and</span> <span>'a message</span></span><span> = <span><span class="type-var">'a</span> <a href="../../dream-pure/Dream_pure/Message/index.html#type-message">Dream_pure.Message.message</a></span></span></code>
</div>
|}
-let message_replacement = {|
+let message_replacement =
+ {|
<code><span><span class="keyword">and</span> 'a message</span></code>
|}
-let client_expected' = {|<div class="spec type" id="type-client">
+let client_expected' =
+ {|<div class="spec type" id="type-client">
<a href="#type-client" class="anchor"></a><code><span><span class="keyword">and</span> client</span><span> = <a href="../../dream-pure/Dream_pure/Message/index.html#type-client">Dream_pure.Message.client</a></span></code>
</div>
|}
-let client_replacement' = {|
+let client_replacement' =
+ {|
<code><span><span class="keyword">and</span> client</span></code>
|}
-let server_expected' = {|<div class="spec type" id="type-server">
+let server_expected' =
+ {|<div class="spec type" id="type-server">
<a href="#type-server" class="anchor"></a><code><span><span class="keyword">and</span> server</span><span> = <a href="../../dream-pure/Dream_pure/Message/index.html#type-server">Dream_pure.Message.server</a></span></code>
</div>
|}
-let server_replacement' = {|
+let server_replacement' =
+ {|
<code><span><span class="keyword">and</span> server</span></code>
|}
-let set_secret_expected = {|<div class="spec value" id="val-set_secret">
+let set_secret_expected =
+ {|<div class="spec value" id="val-set_secret">
<a href="#val-set_secret" class="anchor"></a><code><span><span class="keyword">val</span> set_secret : <span>?old_secrets:<span>string list</span> <span class="arrow">-></span></span> <span>string <span class="arrow">-></span></span> <a href="#type-middleware">middleware</a></span></code>
</div>
|}
-let set_secret_replacement = {|
+let set_secret_replacement =
+ {|
<pre><span class="keyword">val</span> set_secret :
?old_secrets:string list -> string -> <a href="#type-middleware">middleware</a>
</pre>|}
let pretty_print_signatures soup =
let method_ = soup $ "#type-method_" in
- if_expected
- method_expected
+ if_expected method_expected
(fun () -> pretty_print method_)
(fun () ->
method_ $$ "> code" |> Soup.iter Soup.delete;
@@ -1643,8 +1796,7 @@ let pretty_print_signatures soup =
let rewrite_status_group ?(multiline = true) id expected replacement =
let group = soup $ id in
- if_expected
- expected
+ if_expected expected
(fun () -> pretty_print group)
(fun () ->
group $$ "> code" |> Soup.iter Soup.delete;
@@ -1653,39 +1805,23 @@ let pretty_print_signatures soup =
Soup.add_class "multiline" group)
in
- rewrite_status_group
- "#type-informational"
- informational_expected
+ rewrite_status_group "#type-informational" informational_expected
informational_replacement;
- rewrite_status_group
- "#type-successful"
- success_expected
- success_replacement;
+ rewrite_status_group "#type-successful" success_expected success_replacement;
- rewrite_status_group
- "#type-redirection"
- redirect_expected
+ rewrite_status_group "#type-redirection" redirect_expected
redirect_replacement;
- rewrite_status_group
- "#type-client_error"
- client_expected
- client_replacement;
+ rewrite_status_group "#type-client_error" client_expected client_replacement;
- rewrite_status_group
- "#type-server_error"
- server_expected
- server_replacement;
+ rewrite_status_group "#type-server_error" server_expected server_replacement;
- rewrite_status_group
- "#type-standard_status"
- standard_expected
+ rewrite_status_group "#type-standard_status" standard_expected
standard_replacement;
let status = soup $ "#type-status" in
- if_expected
- status_expected
+ if_expected status_expected
(fun () -> pretty_print status)
(fun () ->
status $$ "> code" |> Soup.iter Soup.delete;
@@ -1694,8 +1830,7 @@ let pretty_print_signatures soup =
let multiline selector expected replacement =
let element = soup $ selector in
- if_expected
- expected
+ if_expected expected
(fun () -> pretty_print element)
(fun () ->
Soup.replace (element $ "> code") (Soup.parse replacement);
@@ -1703,16 +1838,14 @@ let pretty_print_signatures soup =
in
let response = soup $ "#val-response" in
- if_expected
- response_expected
+ if_expected response_expected
(fun () -> pretty_print response)
(fun () ->
Soup.replace (response $ "> code") (Soup.parse response_replacement);
Soup.add_class "multiline" response);
let respond = soup $ "#val-respond" in
- if_expected
- respond_expected
+ if_expected respond_expected
(fun () -> pretty_print respond)
(fun () ->
Soup.replace (respond $ "> code") (Soup.parse respond_replacement);
@@ -1723,16 +1856,14 @@ let pretty_print_signatures soup =
multiline "#val-redirect" val_redirect_expected val_redirect_replacement;
let stream = soup $ "#val-stream" in
- if_expected
- stream_expected
+ if_expected stream_expected
(fun () -> pretty_print stream)
(fun () ->
Soup.replace (stream $ "> code") (Soup.parse stream_replacement);
Soup.add_class "multiline" stream);
let empty = soup $ "#val-empty" in
- if_expected
- empty_expected
+ if_expected empty_expected
(fun () -> pretty_print empty)
(fun () ->
Soup.replace (empty $ "> code") (Soup.parse empty_replacement);
@@ -1740,19 +1871,16 @@ let pretty_print_signatures soup =
let replace selector expected replacement =
let element = soup $ selector in
- if_expected
- expected
+ if_expected expected
(fun () -> pretty_print element)
- (fun () ->
- Soup.replace (element $ "> code") (Soup.parse replacement))
+ (fun () -> Soup.replace (element $ "> code") (Soup.parse replacement))
in
replace "#val-add_header" add_header_expected add_header_replacement;
multiline "#val-set_header" set_header_expected set_header_replacement;
let add_set_cookie = soup $ "#val-set_cookie" in
- if_expected
- add_set_cookie_expected
+ if_expected add_set_cookie_expected
(fun () -> pretty_print add_set_cookie)
(fun () ->
Soup.replace
@@ -1761,28 +1889,23 @@ let pretty_print_signatures soup =
Soup.add_class "multiline" add_set_cookie);
let drop_cookie = soup $ "#val-drop_cookie" in
- if_expected
- drop_cookie_expected
+ if_expected drop_cookie_expected
(fun () -> pretty_print drop_cookie)
(fun () ->
- Soup.replace
- (drop_cookie $ "> code")
- (Soup.parse drop_cookie_replacement);
+ Soup.replace (drop_cookie $ "> code") (Soup.parse drop_cookie_replacement);
Soup.add_class "multiline" drop_cookie);
multiline "#val-cookie" cookie_expected cookie_replacement;
let bigstring = soup $ "#type-buffer" in
- if_expected
- bigstring_expected
+ if_expected bigstring_expected
(fun () -> pretty_print bigstring)
(fun () ->
Soup.replace (bigstring $ "> code") (Soup.parse bigstring_replacement);
Soup.add_class "multiline" bigstring);
let form = soup $ "#type-form_result" in
- if_expected
- form_expected
+ if_expected form_expected
(fun () -> pretty_print form)
(fun () ->
form $$ "> code" |> Soup.iter Soup.delete;
@@ -1792,24 +1915,22 @@ let pretty_print_signatures soup =
multiline "#val-form" form'_expected form'_replacement;
(* let type_table selector expected replacement =
- let element = soup $ selector in
- if_expected
- expected
- (fun () -> pretty_print element)
- (fun () ->
- element $$ "> code" |> Soup.iter Soup.delete;
- Soup.replace (element $ "> table") (Soup.parse replacement);
- Soup.add_class "multiline" element)
- in *)
-
- multiline
- "#type-multipart_form" multipart_form_expected multipart_form_replacement;
+ let element = soup $ selector in
+ if_expected
+ expected
+ (fun () -> pretty_print element)
+ (fun () ->
+ element $$ "> code" |> Soup.iter Soup.delete;
+ Soup.replace (element $ "> table") (Soup.parse replacement);
+ Soup.add_class "multiline" element)
+ in *)
+ multiline "#type-multipart_form" multipart_form_expected
+ multipart_form_replacement;
multiline "#val-multipart" multipart_expected multipart_replacement;
multiline "#type-part" part_expected part_replacement;
let csrf_result = soup $ "#type-csrf_result" in
- if_expected
- csrf_result_expected
+ if_expected csrf_result_expected
(fun () -> pretty_print csrf_result)
(fun () ->
csrf_result $$ "> code" |> Soup.iter Soup.delete;
@@ -1817,9 +1938,7 @@ let pretty_print_signatures soup =
(Soup.parse csrf_result_replacement);
Soup.add_class "multiline" csrf_result);
- multiline
- "#val-verify_csrf_token"
- verify_csrf_token_expected
+ multiline "#val-verify_csrf_token" verify_csrf_token_expected
verify_csrf_token_replacement;
multiline "#val-scope" scope_expected scope_replacement;
@@ -1832,18 +1951,17 @@ let pretty_print_signatures soup =
replace "#val-patch" patch_expected patch_replacement;
replace "#val-any" any_expected any_replacement;
multiline "#val-static" static_expected static_replacement;
- multiline "#val-set_session_field"
- set_session_expected set_session_replacement;
+ multiline "#val-set_session_field" set_session_expected
+ set_session_replacement;
multiline "#val-websocket" websocket_expected websocket_replacement;
multiline "#val-send" send_expected send_replacement;
- multiline "#val-close_websocket"
- close_websocket_expected close_websocket_replacement;
+ multiline "#val-close_websocket" close_websocket_expected
+ close_websocket_replacement;
multiline "#val-graphql" graphql_expected graphql_replacement;
multiline "#val-sql" sql_expected sql_replacement;
let conditional_log = soup $ "#type-conditional_log" in
- if_expected
- conditional_log_expected
+ if_expected conditional_log_expected
(fun () -> pretty_print conditional_log)
(fun () ->
Soup.replace
@@ -1852,19 +1970,15 @@ let pretty_print_signatures soup =
Soup.add_class "multiline" conditional_log);
let sub_log = soup $ "#type-sub_log" in
- if_expected
- sub_log_expected
+ if_expected sub_log_expected
(fun () -> pretty_print sub_log)
(fun () ->
sub_log $$ "> code" |> Soup.iter Soup.delete;
- Soup.replace
- (sub_log $ "> table")
- (Soup.parse sub_log_replacement);
+ Soup.replace (sub_log $ "> table") (Soup.parse sub_log_replacement);
Soup.add_class "multiline" sub_log);
let log_level = soup $ "#type-log_level" in
- if_expected
- log_level_expected
+ if_expected log_level_expected
(fun () -> pretty_print log_level)
(fun () ->
log_level $$ "> code" |> Soup.iter Soup.delete;
@@ -1876,8 +1990,7 @@ let pretty_print_signatures soup =
replace "#val-debug" debug_expected debug_replacement;
let initialize_log = soup $ "#val-initialize_log" in
- if_expected
- initialize_log_expected
+ if_expected initialize_log_expected
(fun () -> pretty_print initialize_log)
(fun () ->
Soup.replace
@@ -1885,12 +1998,11 @@ let pretty_print_signatures soup =
(Soup.parse initialize_log_replacement);
Soup.add_class "multiline" initialize_log);
- multiline
- "#val-error_template" error_template_expected error_template_replacement;
+ multiline "#val-error_template" error_template_expected
+ error_template_replacement;
let error = soup $ "#type-error" in
- if_expected
- error_expected
+ if_expected error_expected
(fun () -> pretty_print error)
(fun () ->
error $$ "> code" |> Soup.iter Soup.delete;
@@ -1900,36 +2012,29 @@ let pretty_print_signatures soup =
multiline "#val-new_field" new_field_expected new_field_replacement;
let run = soup $ "#val-run" in
- if_expected
- run_expected
+ if_expected run_expected
(fun () -> pretty_print run)
(fun () ->
- Soup.replace
- (run $ "> code")
- (Soup.parse run_replacement);
+ Soup.replace (run $ "> code") (Soup.parse run_replacement);
Soup.add_class "multiline" run);
let serve = soup $ "#val-serve" in
- if_expected
- serve_expected
+ if_expected serve_expected
(fun () -> pretty_print serve)
(fun () ->
- Soup.replace
- (serve $ "> code")
- (Soup.parse serve_replacement);
+ Soup.replace (serve $ "> code") (Soup.parse serve_replacement);
Soup.add_class "multiline" serve);
- multiline "#val-to_percent_encoded"
- to_percent_encoded_expected to_percent_encoded_replacement;
- multiline
- "#val-to_set_cookie" to_set_cookie_expected to_set_cookie_replacement;
+ multiline "#val-to_percent_encoded" to_percent_encoded_expected
+ to_percent_encoded_replacement;
+ multiline "#val-to_set_cookie" to_set_cookie_expected
+ to_set_cookie_replacement;
multiline "#val-to_path" to_path_expected to_path_replacement;
multiline "#val-encrypt" encrypt_expected encrypt_replacement;
multiline "#val-decrypt" decrypt_expected decrypt_replacement;
let request = soup $ "#val-request" in
- if_expected
- request_expected
+ if_expected request_expected
(fun () -> pretty_print request)
(fun () ->
Soup.replace (request $ "> code") (Soup.parse request_replacement);
@@ -1947,46 +2052,51 @@ let pretty_print_signatures soup =
multiline "#val-ping_stream" ping_stream_expected ping_stream_replacement;
multiline "#val-pong_stream" pong_stream_expected pong_stream_replacement;
- rewrite_status_group ~multiline:false
- "#type-text_or_binary" text_or_binary_expected text_or_binary_replacement;
- rewrite_status_group ~multiline:false
- "#type-end_of_message" end_of_message_expected end_of_message_replacement;
+ rewrite_status_group ~multiline:false "#type-text_or_binary"
+ text_or_binary_expected text_or_binary_replacement;
+ rewrite_status_group ~multiline:false "#type-end_of_message"
+ end_of_message_expected end_of_message_replacement;
- multiline
- "#val-receive_fragment"
- receive_fragment_expected receive_fragment_replacement;
+ multiline "#val-receive_fragment" receive_fragment_expected
+ receive_fragment_replacement;
multiline "#val-set_secret" set_secret_expected set_secret_replacement
let remove_stdlib soup =
- soup $$ ".xref-unresolved:contains(\"Stdlib\")" |> Soup.iter (fun element ->
- begin match Soup.next_sibling element with
- | None -> ()
- | Some next ->
- match Soup.element next with
- | Some _ -> ()
- | None ->
- match Soup.leaf_text next with
- | None -> ()
- | Some s ->
- match s.[0] with
- | '.' ->
- String.sub s 1 (String.length s - 1)
- |> Soup.create_text
- |> Soup.replace next
- | _ | exception _ -> ()
- end;
- delete element)
+ soup
+ $$ ".xref-unresolved:contains(\"Stdlib\")"
+ |> Soup.iter (fun element ->
+ begin
+ match Soup.next_sibling element with
+ | None -> ()
+ | Some next -> (
+ match Soup.element next with
+ | Some _ -> ()
+ | None -> (
+ match Soup.leaf_text next with
+ | None -> ()
+ | Some s -> (
+ match s.[0] with
+ | '.' ->
+ String.sub s 1 (String.length s - 1)
+ |> Soup.create_text
+ |> Soup.replace next
+ | _ | (exception _) -> ())))
+ end;
+ delete element)
let retarget_status soup =
- soup $$ "a[href=#type-status]"
+ soup
+ $$ "a[href=#type-status]"
|> Soup.(iter (set_attribute "href" "#status_codes"))
let links_new_tabs soup =
- soup $$ "a[href^=http]"
- |> Soup.(iter (fun a ->
- set_attribute "target" "_blank" a;
- set_attribute "rel" "noreferrer noopener" a))
+ soup
+ $$ "a[href^=http]"
+ |> Soup.(
+ iter (fun a ->
+ set_attribute "target" "_blank" a;
+ set_attribute "rel" "noreferrer noopener" a))
let () =
let source = Sys.argv.(1) in
@@ -1996,13 +2106,11 @@ let () =
soup $$ "nav.odoc-toc li > ul" |> Soup.iter delete;
- soup
- $ "nav.odoc-toc"
- |> Soup.prepend_child content;
+ soup $ "nav.odoc-toc" |> Soup.prepend_child content;
pretty_print_signatures soup;
- (* remove_specs soup; *)
+ (* remove_specs soup; *)
let error_template = soup $ "#val-error_template" |> Soup.R.parent in
let error = soup $ "#type-error" |> Soup.R.parent in
Soup.prepend_child error error_template;
File "src/server/flash.ml", line 1, characters 0-0:
diff --git a/_build/default/src/server/flash.ml b/_build/default/src/server/.formatted/flash.ml
index dbec2ee..17541ec 100644
--- a/_build/default/src/server/flash.ml
+++ b/_build/default/src/server/.formatted/flash.ml
@@ -3,38 +3,22 @@
Copyright 2021 Joseph Thomas *)
-
-
module Message = Dream_pure.Message
-
-
-let log =
- Log.sub_log "dream.flash"
-
-let five_minutes =
- 5. *. 60.
-
-let storage_field =
- Message.new_field ~name:"dream.flash" ()
-
-let flash_cookie =
- "dream.flash"
+let log = Log.sub_log "dream.flash"
+let five_minutes = 5. *. 60.
+let storage_field = Message.new_field ~name:"dream.flash" ()
+let flash_cookie = "dream.flash"
(* This is a soft limit. Encryption and base64 encoding increase the
original size of the cookie text by ~4/3.*)
-let content_byte_size_limit =
- 3072
-
-let (|>?) =
- Option.bind
-
-
+let content_byte_size_limit = 3072
+let ( |>? ) = Option.bind
let flash request =
let rec group x =
match x with
- | x1::x2::rest -> (x1, x2)::(group rest)
+ | x1 :: x2 :: rest -> (x1, x2) :: group rest
| _ -> []
in
let unpack u =
@@ -43,8 +27,7 @@ let flash request =
| _ -> failwith "Bad flash message content"
in
let x =
- Cookie.cookie request flash_cookie
- |>? fun value ->
+ Cookie.cookie request flash_cookie |>? fun value ->
match Yojson.Basic.from_string value with
| `List y -> Some (group @@ List.map unpack y)
| _ -> None
@@ -60,46 +43,44 @@ let put_flash request category message =
log.error (fun log -> log ~request "%s" message);
failwith message
in
- outbox := (category, message)::!outbox
-
-
+ outbox := (category, message) :: !outbox
let flash_messages inner_handler request =
log.debug (fun log ->
- let current =
- flash request
- |> List.map (fun (p,q) -> p ^ ": " ^ q)
- |> String.concat ", " in
- if String.length current > 0 then
- log ~request "Flash messages: %s" current
- else
- log ~request "%s" "No flash messages.");
+ let current =
+ flash request
+ |> List.map (fun (p, q) -> p ^ ": " ^ q)
+ |> String.concat ", "
+ in
+ if String.length current > 0 then
+ log ~request "Flash messages: %s" current
+ else
+ log ~request "%s" "No flash messages.");
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 entries = List.rev !outbox in
let () =
- match existing, entries with
+ match (existing, entries) with
| None, [] -> ()
| Some _, [] ->
(* TODO Use drop_cookie? *)
Cookie.set_cookie response request flash_cookie "" ~expires:0.
| _, _ ->
let content =
- List.fold_right (fun (x,y) a -> `String x :: `String y :: a) entries []
+ List.fold_right (fun (x, y) a -> `String x :: `String y :: a) entries []
in
let value = `List content |> Yojson.Basic.to_string in
let () =
if String.length value >= content_byte_size_limit then
log.warning (fun log ->
- log ~request
- "Flash messages exceed soft size limit (%d bytes)"
- content_byte_size_limit)
+ log ~request "Flash messages exceed soft size limit (%d bytes)"
+ content_byte_size_limit)
else
()
in
- Cookie.set_cookie
- response request flash_cookie value ~max_age:five_minutes
+ Cookie.set_cookie response request flash_cookie value
+ ~max_age:five_minutes
in
Lwt.return response
File "src/server/router.ml", line 1, characters 0-0:
diff --git a/_build/default/src/server/router.ml b/_build/default/src/server/.formatted/router.ml
index 49d4622..3a90f53 100644
--- a/_build/default/src/server/router.ml
+++ b/_build/default/src/server/.formatted/router.ml
@@ -3,14 +3,10 @@
Copyright 2021 Anton Bachin *)
-
-
module Formats = Dream_pure.Formats
module Message = Dream_pure.Message
module Method = Dream_pure.Method
-
-
(* TODO Limit character set to permit future extensions. *)
(* TODO Document *. *)
(* TODO Forbid wildcard scopes. *)
@@ -27,58 +23,44 @@ type token =
| Wildcard of string
let rec validate route = function
- | (Param "")::_ ->
+ | Param "" :: _ ->
Printf.ksprintf failwith "Empty path parameter name in '%s'" route
- | [Wildcard "*"] ->
- ()
- | (Wildcard "*")::_ ->
- failwith "Path wildcard must be last"
- | (Wildcard _)::_ ->
- failwith "Path wildcard must be just '**'"
- | _::tokens ->
- validate route tokens
- | [] ->
- ()
+ | [Wildcard "*"] -> ()
+ | Wildcard "*" :: _ -> failwith "Path wildcard must be last"
+ | Wildcard _ :: _ -> failwith "Path wildcard must be just '**'"
+ | _ :: tokens -> validate route tokens
+ | [] -> ()
let make_star_or_wildcard = function
| "" -> Literal "*"
| s -> Wildcard s
let parse string =
-
let rec parse_separator tokens index =
match string.[index] with
- | '/' ->
- parse_component_start tokens (index + 1)
- | _ ->
- parse_component_start tokens index
- | exception Invalid_argument _ ->
- List.rev tokens
-
+ | '/' -> parse_component_start tokens (index + 1)
+ | _ -> parse_component_start tokens index
+ | exception Invalid_argument _ -> List.rev tokens
and parse_component_start tokens index =
match string.[index] with
- | '/' ->
- parse_component_start tokens (index + 1)
- | ':' ->
- parse_component tokens (fun s -> Param s) (index + 1) (index + 1)
- | '*' ->
- parse_component tokens make_star_or_wildcard (index + 1) (index + 1)
- | _ | exception Invalid_argument _ ->
+ | '/' -> parse_component_start tokens (index + 1)
+ | ':' -> parse_component tokens (fun s -> Param s) (index + 1) (index + 1)
+ | '*' -> parse_component tokens make_star_or_wildcard (index + 1) (index + 1)
+ | _ | (exception Invalid_argument _) ->
parse_component tokens (fun s -> Literal s) index index
-
and parse_component tokens constructor start_index index =
match string.[index] with
| exception Invalid_argument _ ->
let token =
- constructor (String.sub string start_index (index - start_index)) in
- List.rev (token::tokens)
+ constructor (String.sub string start_index (index - start_index))
+ in
+ List.rev (token :: tokens)
| '/' ->
let token =
- constructor (String.sub string start_index (index - start_index)) in
- parse_separator (token::tokens) index
- | _ ->
- parse_component tokens constructor start_index (index + 1)
-
+ constructor (String.sub string start_index (index - start_index))
+ in
+ parse_separator (token :: tokens) index
+ | _ -> parse_component tokens constructor start_index (index + 1)
in
let tokens = parse_separator [] 0 in
@@ -88,14 +70,11 @@ let parse string =
let rec strip_empty_trailing_token = function
| [] -> []
| [Literal ""] -> []
- | token::tokens -> token::(strip_empty_trailing_token tokens)
-
-
+ | token :: tokens -> token :: strip_empty_trailing_token tokens
-type method_set = [
- | Method.method_
- | `Any
-]
+type method_set =
+ [ Method.method_
+ | `Any ]
let method_matches method_set method_ =
match method_set with
@@ -108,66 +87,41 @@ type node =
and route = (token list * node) list
-let get pattern handler =
- [parse pattern, Handler (`GET, handler)]
-
-let post pattern handler =
- [parse pattern, Handler (`POST, handler)]
-
-let put pattern handler =
- [parse pattern, Handler (`PUT, handler)]
-
-let delete pattern handler =
- [parse pattern, Handler (`DELETE, handler)]
-
-let head pattern handler =
- [parse pattern, Handler (`HEAD, handler)]
-
-let connect pattern handler =
- [parse pattern, Handler (`CONNECT, handler)]
-
-let options pattern handler =
- [parse pattern, Handler (`OPTIONS, handler)]
-
-let trace pattern handler =
- [parse pattern, Handler (`TRACE, handler)]
-
-let patch pattern handler =
- [parse pattern, Handler (`PATCH, handler)]
-
-let any pattern handler =
- [parse pattern, Handler (`Any, handler)]
-
-let no_route =
- []
+let get pattern handler = [(parse pattern, Handler (`GET, handler))]
+let post pattern handler = [(parse pattern, Handler (`POST, handler))]
+let put pattern handler = [(parse pattern, Handler (`PUT, handler))]
+let delete pattern handler = [(parse pattern, Handler (`DELETE, handler))]
+let head pattern handler = [(parse pattern, Handler (`HEAD, handler))]
+let connect pattern handler = [(parse pattern, Handler (`CONNECT, handler))]
+let options pattern handler = [(parse pattern, Handler (`OPTIONS, handler))]
+let trace pattern handler = [(parse pattern, Handler (`TRACE, handler))]
+let patch pattern handler = [(parse pattern, Handler (`PATCH, handler))]
+let any pattern handler = [(parse pattern, Handler (`Any, handler))]
+let no_route = []
let rec apply middlewares routes =
let rec compose handler = function
| [] -> handler
- | middleware::more -> middleware @@ compose handler more
+ | middleware :: more -> middleware @@ compose handler more
in
routes
|> List.flatten
|> List.map (fun (pattern, node) ->
- let node =
- match node with
- | Handler (method_, handler) ->
- Handler (method_, compose handler middlewares)
- | Scope route -> Scope (apply middlewares [route])
- in
- pattern, node)
+ let node =
+ match node with
+ | Handler (method_, handler) ->
+ Handler (method_, compose handler middlewares)
+ | Scope route -> Scope (apply middlewares [route])
+ in
+ (pattern, node))
let under prefix routes =
- [strip_empty_trailing_token (parse prefix), Scope (List.flatten routes)]
-
-let scope prefix middlewares routes =
- under prefix [apply middlewares routes]
-
+ [(strip_empty_trailing_token (parse prefix), Scope (List.flatten routes))]
+let scope prefix middlewares routes = under prefix [apply middlewares routes]
let path_field : string list Message.field =
- Message.new_field
- ~name:"dream.path"
+ Message.new_field ~name:"dream.path"
~show_value:(fun path -> String.concat "/" path)
()
@@ -178,17 +132,15 @@ let path the_request =
match Message.field the_request path_field with
| Some path -> path
| None ->
- Message.(Formats.(
- the_request |> target |> split_target |> fst |> from_path))
+ Message.(
+ Formats.(the_request |> target |> split_target |> fst |> from_path))
(* TODO Move site_prefix into this file and remove with_path from the API. *)
-let set_path request path =
- Message.set_field request path_field path
+let set_path request path = Message.set_field request path_field path
(* Prefix is stored backwards. *)
let prefix_field : string list Messagefield =
- Message.new_field
- ~name:"dream.prefix"
+ Message.new_field ~name:"dream.prefix"
~show_value:(fun prefix -> String.concat "/" (List.rev prefix))
()
@@ -197,25 +149,18 @@ let internal_prefix request =
| Some prefix -> prefix
| None -> []
-let prefix request =
- Formats.to_path (List.rev (internal_prefix request))
-
-let set_prefix request prefix =
- Message.set_field request prefix_field prefix
+let prefix request = Formats.to_path (List.rev (internal_prefix request))
+let set_prefix request prefix = Message.set_field request prefix_field prefix
let params_field : (string * string) list Message.field =
- Message.new_field
- ~name:"dream.params"
+ Message.new_field ~name:"dream.params"
~show_value:(fun params ->
params
|> List.map (fun (param, value) -> Printf.sprintf "%s=%s" param value)
|> String.concat ", ")
()
-
-
-let log =
- Log.sub_log "dream.router"
+let log = Log.sub_log "dream.router"
let missing_param request name =
let message = Printf.sprintf "Dream.param: missing path parameter %S" name in
@@ -225,58 +170,48 @@ let missing_param request name =
let param request name =
match Message.field request params_field with
| None -> missing_param request name
- | Some params ->
- try List.assoc name params
- with _ -> missing_param request name
+ | Some params -> (
+ try List.assoc name params with _ -> missing_param request name)
let router routes =
let routes = List.flatten routes in
fun request ->
-
(* TODO Probably unnecessary (because it's better to just convert this to a
trie), but the method can be checked before descending down the route. *)
-
let rec try_routes bindings prefix path routes ok fail =
match routes with
| [] -> fail ()
- | (pattern, node)::routes ->
+ | (pattern, node) :: routes ->
try_route bindings prefix path pattern node ok (fun () ->
- try_routes bindings prefix path routes ok fail)
-
+ try_routes bindings prefix path routes ok fail)
and try_route bindings prefix path pattern node ok fail =
- match pattern, path with
- | [], _ ->
- try_node bindings prefix path node false ok fail
- | _, [] -> fail ()
- | Literal s :: pattern, s' :: path when s = s' ->
- try_route bindings (s'::prefix) path pattern node ok fail
- | Literal _ :: _, _ -> fail ()
- | Param _ :: _, s' :: _ when s' = "" -> fail ()
- | Param s :: pattern, s' :: path ->
- try_route ((s, s')::bindings) (s'::prefix) path pattern node ok fail
- | Wildcard _ :: _, _ ->
- try_node bindings prefix path node true ok fail
-
+ match (pattern, path) with
+ | [], _ -> try_node bindings prefix path node false ok fail
+ | _, [] -> fail ()
+ | Literal s :: pattern, s' :: path when s = s' ->
+ try_route bindings (s' :: prefix) path pattern node ok fail
+ | Literal _ :: _, _ -> fail ()
+ | Param _ :: _, s' :: _ when s' = "" -> fail ()
+ | Param s :: pattern, s' :: path ->
+ try_route ((s, s') :: bindings) (s' :: prefix) path pattern node ok fail
+ | Wildcard _ :: _, _ -> try_node bindings prefix path node true ok fail
and try_node bindings prefix path node is_wildcard ok fail =
match node with
| Handler (method_, handler)
- when method_matches method_ (Message.method_ request) ->
+ when method_matches method_ (Message.method_ request) ->
Message.set_field request params_field bindings;
if is_wildcard then begin
set_prefix request prefix;
set_path request path;
ok handler request
end
+ else if path = [] then
+ ok handler request
else
- if path = [] then
- ok handler request
- else
- fail ()
-
+ fail ()
| Handler _ -> fail ()
| Scope routes -> try_routes bindings prefix path routes ok fail
-
in
let params =
@@ -290,11 +225,10 @@ let router routes =
let path = path request in
(* match match_site_prefix next_prefix path with
- | None -> next_handler request
- | Some path -> *)
- (* TODO The initial bindings and prefix should be taken from the request
- context when there is indirect nested router support. *)
- try_routes
- params prefix path routes
+ | None -> next_handler request
+ | Some path -> *)
+ (* TODO The initial bindings and prefix should be taken from the request
+ context when there is indirect nested router support. *)
+ try_routes params prefix path routes
(fun handler request -> handler request)
(fun () -> Helpers.not_found request)
File "src/server/session.ml", line 1, characters 0-0:
diff --git a/_build/default/src/server/session.ml b/_build/default/src/server/.formatted/session.ml
index 57de3d7..0dfbee5 100644
--- a/_build/default/src/server/session.ml
+++ b/_build/default/src/server/.formatted/session.ml
@@ -3,23 +3,18 @@
Copyright 2021 Anton Bachin *)
-
-
(* https://cheatsheetseries.owasp.org/cheatsheets/Session_Management_Cheat_Sheet.html *)
module Message = Dream_pure.Message
-
-
-let log =
- Log.sub_log "dream.session"
+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;
}
-let middleware field back_end = fun inner_handler request ->
+let middleware field back_end inner_handler request =
let%lwt session = back_end.load request in
Message.set_field request field session;
let%lwt response = inner_handler request in
@@ -27,8 +22,7 @@ let middleware field back_end = fun inner_handler request ->
let getter field request =
match Message.field request field with
- | Some session ->
- session
+ | Some session -> session
| None ->
let message = "Missing session middleware" in
log.error (fun log -> log ~request "%s" message);
@@ -41,12 +35,7 @@ type 'a typed_middleware = {
let typed_middleware ?show_value () =
let field = Message.new_field ~name:"dream.session" ?show_value () in
- {
- middleware = middleware field;
- getter = getter field;
- }
-
-
+ { middleware = middleware field; getter = getter field }
type session = {
id : string;
@@ -61,11 +50,8 @@ type operations = {
mutable dirty : bool;
}
-let session_cookie =
- "dream.session"
-
-let (|>?) =
- Option.bind
+let session_cookie = "dream.session"
+let ( |>? ) = Option.bind
(* Session id length is based on
@@ -88,43 +74,33 @@ let new_id () =
let new_label () =
Dream__cipher.Random.random 9 |> Dream_pure.Formats.to_base64url
-let version_session_id id =
- "0" ^ id
+let version_session_id id = "0" ^ id
let read_session_id id =
- if String.length id < 1 then None
+ if String.length id < 1 then
+ None
+ else if id.[0] <> '0' then
+ None
else
- if id.[0] <> '0' then None
- else Some (String.sub id 1 (String.length id - 1))
-
-let version_value =
- version_session_id
+ Some (String.sub id 1 (String.length id - 1))
-let read_value =
- read_session_id
+let version_value = version_session_id
+let read_value = read_session_id
-module Memory =
-struct
+module Memory = struct
let rec create hash_table expires_at =
let id = new_id () in
if Hashtbl.mem hash_table id then
create hash_table expires_at
- else begin
- let session = {
- id;
- label = new_label ();
- expires_at;
- payload = [];
- } in
+ else
+ let session = { id; label = new_label (); expires_at; payload = [] } in
Hashtbl.replace hash_table id session;
session
- end
let put session name value =
- session.payload
- |> List.remove_assoc name
- |> fun dictionary -> (name, value)::dictionary
- |> fun dictionary -> session.payload <- dictionary;
+ session.payload |> List.remove_assoc name |> fun dictionary ->
+ (name, value) :: dictionary |> fun dictionary ->
+ session.payload <- dictionary;
Lwt.return_unit
let invalidate hash_table ~now lifetime operations session =
@@ -134,13 +110,14 @@ struct
Lwt.return_unit
let operations ~now hash_table lifetime session dirty =
- let rec operations = {
- put =
- (fun name value -> put !session name value);
- invalidate =
- (fun () -> invalidate ~now hash_table lifetime operations session);
- dirty;
- } in
+ let rec operations =
+ {
+ put = (fun name value -> put !session name value);
+ invalidate =
+ (fun () -> invalidate ~now hash_table lifetime operations session);
+ dirty;
+ }
+ in
operations
let load ~now:gettimeofday hash_table lifetime request =
@@ -151,68 +128,58 @@ struct
|>? read_session_id
|>? Hashtbl.find_opt hash_table
|>? fun session ->
- if session.expires_at > now then
- Some session
- else begin
- Hashtbl.remove hash_table session.id;
- None
- end
+ if session.expires_at > now then
+ Some session
+ else begin
+ Hashtbl.remove hash_table session.id;
+ None
+ end
in
let dirty, session =
match valid_session with
| Some session ->
- if session.expires_at -. now > (lifetime /. 2.) then
- false, session
+ if session.expires_at -. now > lifetime /. 2. then
+ (false, session)
else begin
session.expires_at <- now +. lifetime;
- true, session
+ (true, session)
end
- | None ->
- true, create hash_table (now +. lifetime)
+ | None -> (true, create hash_table (now +. lifetime))
in
let session = ref session in
- Lwt.return (operations ~now:gettimeofday hash_table lifetime session dirty, session)
+ Lwt.return
+ (operations ~now:gettimeofday hash_table lifetime session dirty, session)
let send ~now (operations, session) request response =
- if operations.dirty then begin
- let id = version_session_id !session.id in
- let max_age = !session.expires_at -. now () in
- Cookie.set_cookie
- response request session_cookie id ~encrypt:false ~max_age
- end;
+ (if operations.dirty then
+ let id = version_session_id !session.id in
+ let max_age = !session.expires_at -. now () in
+ Cookie.set_cookie response request session_cookie id ~encrypt:false
+ ~max_age);
Lwt.return response
let back_end ~now lifetime =
let hash_table = Hashtbl.create 256 in
- {
- load = load ~now hash_table lifetime;
- send = send ~now;
- }
+ { load = load ~now hash_table lifetime; send = send ~now }
end
(* TODO JSON is probably not a good choice for the contents. However, there
doesn't seem to be a good alternative in opam right now, so using JSON. *)
-module Cookie =
-struct
+module Cookie = struct
(* Cookie sessions still need keys, even though they are not used as indexes
(sic!) into a store:
- For revocation.
- For binding CSRF tokens to sessions. *)
- let create expires_at = {
- id = new_id ();
- label = new_label ();
- expires_at;
- payload = [];
- }
+ let create expires_at =
+ { id = new_id (); label = new_label (); expires_at; payload = [] }
let put operations session name value =
- session.payload
- |> List.remove_assoc name
- |> fun dictionary -> (name, value)::dictionary
- |> fun dictionary -> session.payload <- dictionary;
+ session.payload |> List.remove_assoc name |> fun dictionary ->
+ (name, value) :: dictionary |> fun dictionary ->
+ session.payload <- dictionary;
operations.dirty <- true;
Lwt.return_unit
@@ -222,104 +189,96 @@ struct
Lwt.return_unit
let operations ~now lifetime session dirty =
- let rec operations = {
- put = (fun name value -> put operations !session name value);
- invalidate = (fun () -> invalidate ~now lifetime operations session);
- dirty;
- } in
+ let rec operations =
+ {
+ put = (fun name value -> put operations !session name value);
+ invalidate = (fun () -> invalidate ~now lifetime operations session);
+ dirty;
+ }
+ in
operations
let load ~now:gettimeofday lifetime request =
let now = gettimeofday () in
let valid_session =
- Cookie.cookie request session_cookie
- |>? read_value
- |>? fun value ->
- (* TODO Is there a non-raising version of this? *)
- match Yojson.Basic.from_string value with
- | `Assoc [
- "id", `String id;
- "label", `String label;
- "expires_at", expires_at;
- "payload", `Assoc payload
+ Cookie.cookie request session_cookie |>? read_value |>? fun value ->
+ (* TODO Is there a non-raising version of this? *)
+ match Yojson.Basic.from_string value with
+ | `Assoc
+ [
+ ("id", `String id);
+ ("label", `String label);
+ ("expires_at", expires_at);
+ ("payload", `Assoc payload);
] ->
-
- begin match expires_at with
+ begin
+ match expires_at with
| `Float n -> Some n
| `Int n -> Some (Float.of_int n)
| _ -> None
- end
- |>? fun expires_at ->
- if expires_at <= now then
- None
- else
- let payload =
- (* TODO Don't raise. *)
- payload |> List.map (function
- | name, `String value -> name, value
- | _ -> failwith "Bad payload")
- in
- Some {
- id;
- label;
- expires_at;
- payload;
- }
-
- | _ -> None
+ end
+ |>? fun expires_at ->
+ if expires_at <= now then
+ None
+ else
+ let payload =
+ (* TODO Don't raise. *)
+ payload
+ |> List.map (function
+ | name, `String value -> (name, value)
+ | _ -> failwith "Bad payload")
+ in
+ Some { id; label; expires_at; payload }
+ | _ -> None
in
let dirty, session =
match valid_session with
| Some session ->
- if session.expires_at -. now > (lifetime /. 2.) then
- false, session
+ if session.expires_at -. now > lifetime /. 2. then
+ (false, session)
else begin
session.expires_at <- now +. lifetime;
- true, session
+ (true, session)
end
- | None ->
- true, create (now +. lifetime)
+ | None -> (true, create (now +. lifetime))
in
let session = ref session in
Lwt.return (operations ~now:gettimeofday lifetime session dirty, session)
let send ~now (operations, session) request response =
- if operations.dirty then begin
- let max_age = !session.expires_at -. now () in
- let value =
- `Assoc [
- "id", `String !session.id;
- "label", `String !session.label;
- "expires_at", `Float !session.expires_at;
- "payload", `Assoc (!session.payload |> List.map (fun (name, value) ->
- name, `String value))
- ]
- |> Yojson.Basic.to_string
- |> version_value
- in
- Cookie.set_cookie response request session_cookie value ~max_age
- end;
+ (if operations.dirty then
+ let max_age = !session.expires_at -. now () in
+ let value =
+ `Assoc
+ [
+ ("id", `String !session.id);
+ ("label", `String !session.label);
+ ("expires_at", `Float !session.expires_at);
+ ( "payload",
+ `Assoc
+ (!session.payload
+ |> List.map (fun (name, value) -> (name, `String value))) );
+ ]
+ |> Yojson.Basic.to_string
+ |> version_value
+ in
+ Cookie.set_cookie response request session_cookie value ~max_age);
Lwt.return response
- let back_end ~now lifetime = {
- load = load ~now lifetime;
- send = send ~now;
- }
+ let back_end ~now lifetime = { load = load ~now lifetime; send = send ~now }
end
-let {middleware; getter} =
- typed_middleware ()
- ~show_value:(fun (_, session) ->
+let { middleware; getter } =
+ typed_middleware () ~show_value:(fun (_, session) ->
!session.payload
|> List.map (fun (name, value) -> Printf.sprintf "%S: %S" name value)
|> String.concat ", "
|> Printf.sprintf "%s [%s]" !session.label)
-let two_weeks =
- 60. *. 60. *. 24. *. 7. *. 2.
+let two_weeks = 60. *. 60. *. 24. *. 7. *. 2.
module Make (Pclock : Mirage_clock.PCLOCK) = struct
let now () = Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ()))
@@ -331,23 +290,10 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
middleware (Cookie.back_end ~now lifetime)
end
-let session name request =
- List.assoc_opt name (!(snd (getter request)).payload)
-
-let put_session name value request =
- (fst (getter request)).put name value
-
-let all_session_values request =
- !(snd (getter request)).payload
-
-let invalidate_session request =
- (fst (getter request)).invalidate ()
-
-let session_id request =
- !(snd (getter request)).id
-
-let session_label request =
- !(snd (getter request)).label
-
-let session_expires_at request =
- !(snd (getter request)).expires_at
+let session name request = List.assoc_opt name !(snd (getter request)).payload
+let put_session name value request = (fst (getter request)).put name value
+let all_session_values request = !(snd (getter request)).payload
+let invalidate_session request = (fst (getter request)).invalidate ()
+let session_id request = !(snd (getter request)).id
+let session_label request = !(snd (getter request)).label
+let session_expires_at request = !(snd (getter request)).expires_at
File "src/server/upload.ml", line 1, characters 0-0:
diff --git a/_build/default/src/server/upload.ml b/_build/default/src/server/.formatted/upload.ml
index e296c8e..7c20186 100644
--- a/_build/default/src/server/upload.ml
+++ b/_build/default/src/server/.formatted/upload.ml
@@ -3,12 +3,8 @@
Copyright 2021 Anton Bachin *)
-
-
module Message = Dream_pure.Message
-
-
(* Used for converting the stream interface of [multipart_form] into the pull
interface of Dream.
@@ -19,21 +15,21 @@ 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 Lwt_stream.t) Lwt_stream.t;
}
-let initial_multipart_state () = {
- state_init = true;
- name = None;
- filename = None;
- stream = Lwt_stream.of_list [];
-}
+let initial_multipart_state () =
+ {
+ state_init = true;
+ name = None;
+ filename = None;
+ stream = Lwt_stream.of_list [];
+ }
(* TODO Dump the value of the multipart state somehow? *)
let multipart_state_field : multipart_state Message.field =
- Message.new_field
- ~name:"dream.multipart"
- ()
+ Message.new_field ~name:"dream.multipart" ()
let multipart_state request =
match Message.field request multipart_state_field with
@@ -47,16 +43,16 @@ let field_to_string (request : Message.request) field =
let open Multipart_form in
match field with
| Field.Field (field_name, Field.Content_type, v) ->
- (field_name :> string), Content_type.to_string v
+ ((field_name :> string), Content_type.to_string v)
| Field.Field (field_name, Field.Content_disposition, v) ->
let state = multipart_state request in
- state.filename <- Content_disposition.filename v ;
- state.name <- Content_disposition.name v ;
- (field_name :> string), Content_disposition.to_string v
+ state.filename <- Content_disposition.filename v;
+ state.name <- Content_disposition.name v;
+ ((field_name :> string), Content_disposition.to_string v)
| Field.Field (field_name, Field.Content_encoding, v) ->
- (field_name :> string), Content_encoding.to_string v
+ ((field_name :> string), Content_encoding.to_string v)
| Field.Field (field_name, Field.Field, v) ->
- (field_name :> string), Unstrctrd.to_utf_8_string v
+ ((field_name :> string), Unstrctrd.to_utf_8_string v)
let log = Log.sub_log "dream.upload"
@@ -64,92 +60,99 @@ let upload_part (request : Message.request) =
let state = multipart_state request in
match%lwt Lwt_stream.peek state.stream with
| None -> Lwt.return_none
- | Some (_uid, _header, stream) ->
+ | Some (_uid, _header, stream) -> (
match%lwt Lwt_stream.get stream with
| Some _ as v -> Lwt.return v
| None ->
- log.debug (fun m -> m "End of the part.") ;
+ log.debug (fun m -> m "End of the part.");
let%lwt () = Lwt_stream.junk state.stream in
(* XXX(dinosaure): delete the current part from the [stream]. *)
- Lwt.return_none
+ Lwt.return_none)
let identify _ = object end
-type part = string option * string option * ((string * string) list)
+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
+ | None ->
+ let%lwt () = Lwt_stream.junk stream in
+ Lwt.return_none
| Some (_, headers, _stream) ->
let headers =
headers
|> Multipart_form.Header.to_list
|> List.map (field_to_string request)
in
- let part =
- state'.name, state'.filename, headers in
+ let part = (state'.name, state'.filename, headers) in
Lwt.return (Some part)
and upload (request : Message.request) =
let state' = multipart_state request in
match state'.state_init with
- | false ->
- state request
-
- | true ->
- let content_type = match Message.header request "Content-Type" with
- | Some content_type ->
- Result.to_option
- (Multipart_form.Content_type.of_string (content_type ^ "\r\n"))
- | None ->
- None
+ | false -> state request
+ | true -> (
+ let content_type =
+ match Message.header request "Content-Type" with
+ | Some content_type ->
+ Result.to_option
+ (Multipart_form.Content_type.of_string (content_type ^ "\r\n"))
+ | None -> None
in
match content_type with
| None ->
let message =
- "The request does not have 'Content-Type: multipart/form_data; ...'" in
+ "The request does not have 'Content-Type: multipart/form_data; ...'"
+ in
log.error (fun log -> log "%s" message);
failwith message
-
| Some content_type ->
let body =
- Lwt_stream.from (fun () ->
- Message.read (Message.server_stream request)) in
+ Lwt_stream.from (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);
+ Multipart_form_lwt.stream ~identify body content_type
+ in
+ Lwt.async (fun () ->
+ let%lwt _ = th in
+ Lwt.return_unit);
state'.stream <- stream;
state'.state_init <- false;
- state request
+ state request)
+
+type multipart_form = (string * (string option * string) list) list
-type multipart_form =
- (string * ((string option * string) list)) list
module Map = Map.Make (String)
-let multipart ?(csrf=true) ~now request =
- let content_type = match Message.header request "Content-Type" with
+let multipart ?(csrf = true) ~now request =
+ let content_type =
+ match Message.header request "Content-Type" with
| Some content_type ->
- Result.to_option (Multipart_form.Content_type.of_string (content_type ^ "\r\n"))
- | None -> None in
+ 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
- | Some content_type ->
+ | Some content_type -> (
let body =
- Lwt_stream.from (fun () ->
- Message.read (Message.server_stream request)) in
+ Lwt_stream.from (fun () -> Message.read (Message.server_stream request))
+ in
match%lwt Multipart_form_lwt.of_stream_to_list body content_type with
| Error (`Msg _err) ->
Lwt.return `Wrong_content_type (* XXX(dinosaure): better error? *)
| Ok (tree, assoc) ->
let open Multipart_form in
let tree = flatten tree in
- let fold acc { Multipart_form.header; body= uid; } =
+ let fold acc { Multipart_form.header; body = uid } =
let contents = List.assoc uid assoc in
let content_disposition = Header.content_disposition header in
- let filename = Option.bind content_disposition Content_disposition.filename in
+ let filename =
+ Option.bind content_disposition Content_disposition.filename
+ in
match Option.bind content_disposition Content_disposition.name with
| None -> acc
| Some name ->
@@ -158,22 +161,22 @@ let multipart ?(csrf=true) ~now request =
| Some vs -> vs
| None -> []
in
- Map.add name ((filename, contents)::vs) acc
+ Map.add name ((filename, contents) :: vs) acc
in
let parts =
List.fold_left fold Map.empty tree
|> Map.bindings
|> List.map (fun (name, values) ->
- match values with
- | [Some "", ""] -> name, []
- | _ -> name, List.rev values)
+ match values with
+ | [(Some "", "")] -> (name, [])
+ | _ -> (name, List.rev values))
in
if csrf then
- Form.sort_and_check_form ~now
- (function
- | [None, value] -> value
- | _ -> "")
- parts request
+ Form.sort_and_check_form ~now
+ (function
+ | [(None, value)] -> value
+ | _ -> "")
+ parts request
else
- let form = Form.sort parts in
- Lwt.return (`Ok form)
+ let form = Form.sort parts in
+ Lwt.return (`Ok form))
File "src/sql/session.ml", line 1, characters 0-0:
diff --git a/_build/default/src/sql/session.ml b/_build/default/src/sql/.formatted/session.ml
index 8f639a6..6114742 100644
--- a/_build/default/src/sql/session.ml
+++ b/_build/default/src/sql/.formatted/session.ml
@@ -3,16 +3,11 @@
Copyright 2021 Anton Bachin *)
-
-
module Dream = Dream_pure
module Cookie = Dream__server.Cookie
module Session = Dream__server.Session
-
-
-let (|>?) =
- Option.bind
+let ( |>? ) = Option.bind
module type DB = Caqti_lwt.CONNECTION
@@ -20,30 +15,34 @@ module R = Caqti_request
module T = Caqti_type
let serialize_payload payload =
- payload
- |> List.map (fun (name, value) -> name, `String value)
- |> fun assoc -> `Assoc assoc
- |> Yojson.Basic.to_string
+ payload |> List.map (fun (name, value) -> (name, `String value))
+ |> fun assoc -> `Assoc assoc |> Yojson.Basic.to_string
let insert =
let query =
- R.Infix.(->.) T.(tup4 string string float string) T.unit
- (* R.exec T.(tup4 string string float string) *)
- {|
+ R.Infix.( ->. )
+ T.(tup4 string string float string)
+ T.unit
+ (* R.exec T.(tup4 string string float string) *)
+ {|
INSERT INTO dream_session (id, label, expires_at, payload)
VALUES ($1, $2, $3, $4)
- |} in
+ |}
+ in
fun (module Db : DB) (session : Session.session) ->
let payload = serialize_payload session.payload in
let%lwt result =
- Db.exec query (session.id, session.label, session.expires_at, payload) in
+ Db.exec query (session.id, session.label, session.expires_at, payload)
+ in
Caqti_lwt.or_fail result
let find_opt =
let query =
- R.Infix.(->?) T.string T.(tup3 string float string)
- "SELECT label, expires_at, payload FROM dream_session WHERE id = $1" in
+ R.Infix.( ->? ) T.string
+ T.(tup3 string float string)
+ "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
@@ -52,25 +51,22 @@ let find_opt =
| Some (label, expires_at, payload) ->
(* TODO Mind exceptions! *)
let payload =
- Yojson.Basic.from_string payload
- |> function
- | `Assoc payload ->
- payload |> List.map (function
- | name, `String value -> name, value
- | _ -> failwith "Bad payload")
- | _ -> failwith "Bad payload"
+ Yojson.Basic.from_string payload |> function
+ | `Assoc payload ->
+ payload
+ |> List.map (function
+ | name, `String value -> (name, value)
+ | _ -> failwith "Bad payload")
+ | _ -> failwith "Bad payload"
in
- Lwt.return_some Session.{
- id;
- label;
- expires_at;
- payload;
- }
+ Lwt.return_some Session.{ id; label; expires_at; payload }
let refresh =
let query =
- R.Infix.(->.) T.(tup2 float string) T.unit
- "UPDATE dream_session SET expires_at = $1 WHERE id = $2" in
+ R.Infix.( ->. )
+ T.(tup2 float string)
+ T.unit "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
@@ -78,8 +74,10 @@ let refresh =
let update =
let query =
- R.Infix.(->.) T.(tup2 string string) T.unit
- "UPDATE dream_session SET payload = $1 WHERE id = $2" in
+ R.Infix.( ->. )
+ T.(tup2 string string)
+ T.unit "UPDATE dream_session SET payload = $1 WHERE id = $2"
+ in
fun (module Db : DB) (session : Session.session) ->
let payload = serialize_payload session.payload in
@@ -88,9 +86,10 @@ let update =
let remove =
let query =
- R.Infix.(->.) T.string T.unit
+ R.Infix.( ->. ) T.string T.unit
(* R.exec T.string *)
- "DELETE FROM dream_session WHERE id = $1" in
+ "DELETE FROM dream_session WHERE id = $1"
+ in
fun (module Db : DB) id ->
let%lwt result = Db.exec query id in
@@ -105,103 +104,94 @@ let remove =
the cache, just with no persistent backing store. *)
let rec create db expires_at attempt =
- let session = Session.{
- id = Session.new_id ();
- label = Session.new_label ();
- expires_at;
- payload = [];
- } in
+ let session =
+ Session.
+ {
+ id = Session.new_id ();
+ label = Session.new_label ();
+ expires_at;
+ payload = [];
+ }
+ in
(* Assume that any exception is a PRIMARY KEY collision (extremely unlikely)
and try a couple more times. *)
match%lwt insert db session with
| exception Caqti_error.Exn _ when attempt <= 3 ->
create db expires_at (attempt + 1)
- | () ->
- Lwt.return session
+ | () -> Lwt.return 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;
+ session.payload |> List.remove_assoc name |> fun dictionary ->
+ (name, value) :: dictionary |> fun dictionary ->
+ session.payload <- dictionary;
Sql.sql request (fun db -> update db session)
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
- end
+ Sql.sql request (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)
let operations request lifetime (session : Session.session ref) dirty =
- let rec operations = {
- Session.put = (fun name value -> put request !session name value);
- invalidate = (fun () -> invalidate request lifetime operations session);
- dirty;
- } in
+ let rec operations =
+ {
+ Session.put = (fun name value -> put request !session name value);
+ invalidate = (fun () -> invalidate request lifetime operations session);
+ dirty;
+ }
+ in
operations
let load lifetime request =
- Sql.sql request begin fun db ->
- let now = Unix.gettimeofday () in
-
- let%lwt valid_session =
- match Cookie.cookie request ~decrypt:false Session.session_cookie with
- | None -> Lwt.return_none
- | Some id ->
- match Session.read_session_id id with
+ Sql.sql request (fun db ->
+ let now = Unix.gettimeofday () in
+
+ let%lwt valid_session =
+ match Cookie.cookie request ~decrypt:false Session.session_cookie with
| None -> Lwt.return_none
- | Some id ->
- match%lwt find_opt db id with
+ | Some id -> (
+ match Session.read_session_id id with
| None -> Lwt.return_none
- | Some session ->
- if session.expires_at > now then
- Lwt.return (Some session)
- else begin
- let%lwt () = remove db id in
- Lwt.return_none
- end
- in
+ | Some id -> (
+ match%lwt find_opt db id with
+ | None -> Lwt.return_none
+ | Some session ->
+ if session.expires_at > now then
+ Lwt.return (Some session)
+ else
+ let%lwt () = remove db id in
+ Lwt.return_none))
+ in
- let%lwt dirty, session =
- match valid_session with
- | Some session ->
- if session.expires_at -. now > (lifetime /. 2.) then
- Lwt.return (false, session)
- else begin
- session.expires_at <- now +. lifetime;
- let%lwt () = refresh db session in
+ let%lwt dirty, session =
+ match valid_session with
+ | Some session ->
+ if session.expires_at -. now > lifetime /. 2. then
+ Lwt.return (false, session)
+ else begin
+ session.expires_at <- now +. lifetime;
+ let%lwt () = refresh db session in
+ Lwt.return (true, session)
+ end
+ | None ->
+ let%lwt session = create db (now +. lifetime) 1 in
Lwt.return (true, session)
- end
- | None ->
- let%lwt session = create db (now +. lifetime) 1 in
- Lwt.return (true, session)
- in
+ in
- let session = ref session in
- Lwt.return (operations request lifetime session dirty, session)
- end
+ let session = ref session in
+ Lwt.return (operations request lifetime session dirty, session))
let send (operations, session) request response =
- if operations.Session.dirty then begin
- let id = Session.version_session_id !session.Session.id in
- let max_age = !session.Session.expires_at -. Unix.gettimeofday () in
- Cookie.set_cookie
- response
- request
- Session.session_cookie
- id
- ~encrypt:false
- ~max_age
- end;
+ (if operations.Session.dirty then
+ let id = Session.version_session_id !session.Session.id in
+ let max_age = !session.Session.expires_at -. Unix.gettimeofday () in
+ Cookie.set_cookie response request Session.session_cookie id ~encrypt:false
+ ~max_age);
Lwt.return response
-let back_end lifetime = {
- Session.load = load lifetime;
- send;
-}
+let back_end lifetime = { Session.load = load lifetime; send }
let sql_sessions ?(lifetime = Session.two_weeks) =
Session.middleware (back_end lifetime)
File "src/http/adapt.ml", line 1, characters 0-0:
diff --git a/_build/default/src/http/adapt.ml b/_build/default/src/http/.formatted/adapt.ml
index 34aeb6f..e50be02 100644
--- a/_build/default/src/http/adapt.ml
+++ b/_build/default/src/http/.formatted/adapt.ml
@@ -3,45 +3,27 @@
Copyright 2021 Anton Bachin *)
-
-
module Stream = Dream_pure.Stream
module Message = Dream_pure.Message
-
-
let address_to_string : Unix.sockaddr -> string = function
| ADDR_UNIX path -> path
| ADDR_INET (address, port) ->
Printf.sprintf "%s:%i" (Unix.string_of_inet_addr address) port
-
-
(* TODO Write a test simulating client exit during SSE; this was killing the
server at some point. *)
-let forward_body_general
- (response : Message.response)
+let forward_body_general (response : Message.response)
(_write_string : ?off:int -> ?len:int -> string -> unit)
- (write_buffer : ?off:int -> ?len:int -> Stream.buffer -> unit)
- http_flush
+ (write_buffer : ?off:int -> ?len:int -> Stream.buffer -> unit) http_flush
close =
-
let abort _exn = close 1000 in
let bytes_since_flush = ref 0 in
let rec send () =
- Message.client_stream response
- |> fun stream ->
- Stream.read
- stream
- ~data
- ~flush
- ~ping
- ~pong
- ~close
- ~exn:abort
-
+ Message.client_stream response |> fun stream ->
+ Stream.read stream ~data ~flush ~ping ~pong ~close ~exn:abort
and data chunk off len _binary _fin =
write_buffer ~off ~len chunk;
bytes_since_flush := !bytes_since_flush + len;
@@ -51,39 +33,20 @@ let forward_body_general
end
else
send ()
-
and flush () =
bytes_since_flush := 0;
http_flush send
-
- and ping _buffer _offset _length =
- send ()
-
- and pong _buffer _offset _length =
- send ()
-
- in
+ and ping _buffer _offset _length = send ()
+ and pong _buffer _offset _length = send () in
send ()
-let forward_body
- (response : Message.response)
- (body : Httpaf.Body.Writer.t) =
-
- forward_body_general
- response
- (Httpaf.Body.Writer.write_string body)
- (Httpaf.Body.Writer.write_bigstring body)
- (Httpaf.Body.Writer.flush body)
+let forward_body (response : Message.response) (body : Httpaf.Body.Writer.t) =
+ forward_body_general response (Httpaf.Body.Writer.write_string body)
+ (Httpaf.Body.Writer.write_bigstring body) (Httpaf.Body.Writer.flush body)
(fun _code -> Httpaf.Body.Writer.close body)
-let forward_body_h2
- (response : Message.response)
- (body : H2.Body.Writer.t) =
-
- forward_body_general
- response
- (H2.Body.Writer.write_string body)
- (H2.Body.Writer.write_bigstring body)
- (H2.Body.Writer.flush body)
+let forward_body_h2 (response : Message.response) (body : H2.Body.Writer.t) =
+ forward_body_general response (H2.Body.Writer.write_string body)
+ (H2.Body.Writer.write_bigstring body) (H2.Body.Writer.flush body)
(fun _code -> H2.Body.Writer.close body)
File "src/http/error_handler.ml", line 1, characters 0-0:
diff --git a/_build/default/src/http/error_handler.ml b/_build/default/src/http/.formatted/error_handler.ml
index e24c28a..dffa4f7 100644
--- a/_build/default/src/http/error_handler.ml
+++ b/_build/default/src/http/.formatted/error_handler.ml
@@ -3,8 +3,6 @@
Copyright 2021 Anton Bachin *)
-
-
module Catch = Dream__server.Catch
module Error_template = Dream__server.Error_template
module Method = Dream_pure.Method
@@ -14,15 +12,12 @@ module Message = Dream_pure.Message
module Status = Dream_pure.Status
module Stream = Dream_pure.Stream
-
-
(* TODO DOC The error handler is almost a middleware. But it needs to plug in to
the lower levels of the framework. Also, a benefit of it not being directly
a middleware is that it cannot wrongly appear composed into deeper levels of
an app. *)
-let log =
- Log.sub_log "dream.http"
+let log = Log.sub_log "dream.http"
let select_log = function
| `Error -> log.error
@@ -30,27 +25,21 @@ let select_log = function
| `Info -> log.info
| `Debug -> log.debug
-
-
let dump (error : Catch.error) =
let buffer = Buffer.create 4096 in
let p format = Printf.bprintf buffer format in
- begin match error.condition with
- | `Response response ->
- let status = Message.status response in
- p "%i %s\n" (Status.status_to_int status) (Status.status_to_string status)
-
- | `String "" ->
- p "(Library error without description payload)\n"
-
- | `String string ->
- p "%s\n" string
-
- | `Exn exn ->
- let backtrace = Printexc.get_backtrace () in
- p "%s\n" (Printexc.to_string exn);
- backtrace |> Log.iter_backtrace (p "%s\n")
+ begin
+ match error.condition with
+ | `Response response ->
+ let status = Message.status response in
+ p "%i %s\n" (Status.status_to_int status) (Status.status_to_string status)
+ | `String "" -> p "(Library error without description payload)\n"
+ | `String string -> p "%s\n" string
+ | `Exn exn ->
+ let backtrace = Printexc.get_backtrace () in
+ p "%s\n" (Printexc.to_string exn);
+ backtrace |> Log.iter_backtrace (p "%s\n")
end;
p "\n";
@@ -82,29 +71,31 @@ let dump (error : Catch.error) =
p "Blame: %s\n" blame;
p "Severity: %s" severity;
- begin match error.client with
- | None -> ()
- | Some client -> p "\n\nClient: %s" client
+ begin
+ match error.client with
+ | None -> ()
+ | Some client -> p "\n\nClient: %s" client
end;
- begin match error.request with
- | None -> ()
- | Some request ->
- p "\n\n%s %s"
- (Method.method_to_string (Message.method_ request))
- (Message.target request);
-
- Message.all_headers request
- |> List.iter (fun (name, value) -> p "\n%s: %s" name value);
-
- Message.fold_fields (fun name value first ->
- if first then
- p "\n";
- p "\n%s: %s" name value;
- false)
- true
- request
- |> ignore
+ begin
+ match error.request with
+ | None -> ()
+ | Some request ->
+ p "\n\n%s %s"
+ (Method.method_to_string (Message.method_ request))
+ (Message.target request);
+
+ Message.all_headers request
+ |> List.iter (fun (name, value) -> p "\n%s: %s" name value);
+
+ Message.fold_fields
+ (fun name value first ->
+ if first then
+ p "\n";
+ p "\n%s: %s" name value;
+ false)
+ true request
+ |> ignore
end;
Buffer.contents buffer
@@ -113,52 +104,49 @@ let dump (error : Catch.error) =
which are calling functions that use exceptions during parsing, which are
clobbering the backtrace. *)
let customize template (error : Catch.error) =
-
(* First, log the error. *)
+ begin
+ match error.condition with
+ | `Response _ -> ()
+ | (`String _ | `Exn _) as condition ->
+ let client =
+ match error.client with
+ | None -> ""
+ | Some client -> " (" ^ client ^ ")"
+ in
- begin match error.condition with
- | `Response _ -> ()
- | `String _ | `Exn _ as condition ->
-
- let client =
- match error.client with
- | None -> ""
- | Some client -> " (" ^ client ^ ")"
- in
-
- let layer =
- match error.layer with
- | `TLS -> ["TLS" ^ client]
- | `HTTP -> ["HTTP" ^ client]
- | `HTTP2 -> ["HTTP/2" ^ client]
- | `WebSocket -> ["WebSocket" ^ client]
- | `App -> []
- in
+ let layer =
+ match error.layer with
+ | `TLS -> ["TLS" ^ client]
+ | `HTTP -> ["HTTP" ^ client]
+ | `HTTP2 -> ["HTTP/2" ^ client]
+ | `WebSocket -> ["WebSocket" ^ client]
+ | `App -> []
+ in
- let description, backtrace =
- match condition with
- | `String string -> string, ""
- | `Exn exn ->
- let backtrace = Printexc.get_backtrace () in
- Printexc.to_string exn, backtrace
- in
+ let description, backtrace =
+ match condition with
+ | `String string -> (string, "")
+ | `Exn exn ->
+ let backtrace = Printexc.get_backtrace () in
+ (Printexc.to_string exn, backtrace)
+ in
- let message = String.concat ": " (layer @ [description]) in
+ let message = String.concat ": " (layer @ [description]) in
- select_log error.severity (fun log ->
- log ?request:error.request "%s" message);
- backtrace |> Log.iter_backtrace (fun line ->
select_log error.severity (fun log ->
- log ?request:error.request "%s" line))
+ log ?request:error.request "%s" message);
+ backtrace
+ |> Log.iter_backtrace (fun line ->
+ select_log error.severity (fun log ->
+ log ?request:error.request "%s" line))
end;
(* If Dream will not send a response for this error, we are done after
logging. Otherwise, if debugging is enabled, gather a bunch of information.
Then, call the template, and return the response. *)
-
if not error.will_send_response then
Lwt.return_none
-
else
let debug_dump = dump error in
@@ -180,10 +168,7 @@ let customize template (error : Catch.error) =
let%lwt response = template error debug_dump response in
Lwt.return (Some response)
-
-
-let default_template _error _debug_dump response =
- Lwt.return response
+let default_template _error _debug_dump response = Lwt.return response
let debug_template _error debug_dump response =
let status = Message.status response in
@@ -193,31 +178,22 @@ let debug_template _error debug_dump response =
Message.set_body response (Error_template.render ~debug_dump ~code ~reason);
Lwt.return response
-let default =
- customize default_template
-
-let debug_error_handler =
- customize debug_template
-
-
+let default = customize default_template
+let debug_error_handler = customize debug_template
(* Error reporters (called in various places by the framework). *)
-
-
let double_faults f default =
- Lwt.catch f begin fun exn ->
- let backtrace = Printexc.get_backtrace () in
+ Lwt.catch f (fun exn ->
+ let backtrace = Printexc.get_backtrace () in
- log.error (fun log ->
- log "Error handler raised: %s" (Printexc.to_string exn));
+ log.error (fun log ->
+ log "Error handler raised: %s" (Printexc.to_string exn));
- backtrace
- |> Log.iter_backtrace (fun line ->
- log.error (fun log -> log "%s" line));
+ backtrace
+ |> Log.iter_backtrace (fun line -> log.error (fun log -> log "%s" line));
- default ()
- end
+ default ())
(* 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,16 +206,14 @@ let respond_with_option f =
(fun () ->
f ()
|> Lwt.map (function
- | Some response -> response
- | None ->
- Message.response
- ~status:`Internal_Server_Error Stream.empty Stream.null))
+ | 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)
-
-
(* In the functions below, the first row or set of arguments comes from the
framework, by partial application, and the second row or set (after "fun")
comes from the state machine (http/af, h2, websocket/af, ocaml-tls, etc.) *)
@@ -248,208 +222,172 @@ let respond_with_option f =
reaching the centralized error handler provided by the user, so it is built
into the framework. *)
-let app
- user's_error_handler =
- fun error ->
-
+let app user's_error_handler error =
respond_with_option (fun () -> user's_error_handler error)
-
-
let default_response = function
| `Server ->
Message.response ~status:`Internal_Server_Error Stream.empty Stream.null
- | `Client ->
- Message.response ~status:`Bad_Request Stream.empty Stream.null
-
-let httpaf
- user's_error_handler =
- fun client_address ?request error start_response ->
+ | `Client -> Message.response ~status:`Bad_Request Stream.empty Stream.null
+let httpaf user's_error_handler client_address ?request error start_response =
ignore (request : Httpaf.Request.t option);
+
(* TODO LATER Should factor out the request translation function and use it to
partially recover the request info. *)
-
let condition, severity, caused_by =
match error with
- | `Exn exn ->
- `Exn exn,
- `Error,
- `Server
-
- | `Bad_request
- | `Bad_gateway ->
- `String "Bad request",
- `Warning,
- `Client
-
+ | `Exn exn -> (`Exn exn, `Error, `Server)
+ | `Bad_request | `Bad_gateway -> (`String "Bad request", `Warning, `Client)
| `Internal_server_error ->
- `String "Content-Length missing or negative",
- `Error,
- `Server
+ (`String "Content-Length missing or negative", `Error, `Server)
in
- let error = {
- Catch.condition;
- layer = `HTTP;
- caused_by;
- request = None;
- response = None;
- client = Some (Adapt.address_to_string client_address);
- severity;
- 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
+ let error =
+ {
+ Catch.condition;
+ layer = `HTTP;
+ caused_by;
+ request = None;
+ response = None;
+ client = Some (Adapt.address_to_string client_address);
+ severity;
+ will_send_response = true;
+ }
+ in
- Adapt.forward_body response body;
+ Lwt.async (fun () ->
+ double_faults
+ begin
+ fun () ->
+ let%lwt response = user's_error_handler error in
- Lwt.return_unit
- end
- Lwt.return
- end
+ 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;
-let h2
- user's_error_handler =
- fun client_address ?request error start_response ->
+ Lwt.return_unit
+ end
+ Lwt.return)
- ignore request; (* TODO Recover something from the request. *)
+let h2 user's_error_handler client_address ?request error start_response =
+ ignore request;
+ (* TODO Recover something from the request. *)
let condition, severity, caused_by =
match error with
- | `Exn exn ->
- `Exn exn,
- `Error,
- `Server
-
- | `Bad_request ->
- `String "Bad request",
- `Warning,
- `Client
-
+ | `Exn exn -> (`Exn exn, `Error, `Server)
+ | `Bad_request -> (`String "Bad request", `Warning, `Client)
| `Internal_server_error ->
- `String "Content-Length missing or negative",
- `Error,
- `Server
- (* TODO LATER When does H2 raise `Internal_server_error? *)
+ (`String "Content-Length missing or negative", `Error, `Server)
+ (* TODO LATER When does H2 raise `Internal_server_error? *)
in
- let error = {
- Catch.condition;
- layer = `HTTP2;
- caused_by;
- request = None;
- response = None;
- client = Some (Adapt.address_to_string client_address);
- severity;
- 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 error =
+ {
+ Catch.condition;
+ layer = `HTTP2;
+ caused_by;
+ request = None;
+ response = None;
+ client = Some (Adapt.address_to_string client_address);
+ severity;
+ will_send_response = true;
+ }
+ in
- let headers = H2.Headers.of_list (Message.all_headers response) in
- let body = start_response headers in
+ Lwt.async (fun () ->
+ double_faults
+ begin
+ fun () ->
+ let%lwt response = user's_error_handler error in
- Adapt.forward_body_h2 response body;
+ let response =
+ match response with
+ | Some response -> response
+ | None -> default_response caused_by
+ in
- Lwt.return_unit
- end
- Lwt.return
- end
+ 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
+ end
+ Lwt.return)
(* The protocol state machines (http/af, etc.) try to pass all errors generated
inside their request handlers to their own error handlers. In addition, all
user code run by Dream is wrapped in Lwt.catch to catch all user errors.
However, SSL protocol errors are not wrapped in any of these, so we add an
edditional top-level handler to catch them. *)
-let tls
- user's_error_handler client_address error =
-
- let error = {
- Catch.condition = `Exn error;
- layer = `TLS;
- caused_by = `Client;
- request = None;
- response = None;
- client = Some (Adapt.address_to_string client_address);
- severity = `Warning;
- will_send_response = false;
- } in
+let tls user's_error_handler client_address error =
+ let error =
+ {
+ Catch.condition = `Exn error;
+ layer = `TLS;
+ caused_by = `Client;
+ request = None;
+ response = None;
+ client = Some (Adapt.address_to_string client_address);
+ severity = `Warning;
+ will_send_response = false;
+ }
+ in
Lwt.async (fun () ->
- double_faults
- (fun () -> Lwt.map ignore (user's_error_handler error))
- Lwt.return)
-
-
-
-let websocket
- user's_error_handler request response =
- fun socket error ->
+ double_faults
+ (fun () -> Lwt.map ignore (user's_error_handler error))
+ Lwt.return)
+let websocket user's_error_handler request response socket error =
(* Note: in this function, request and response are from the original request
that negotiated the websocket. *)
-
Websocketaf.Wsd.close socket;
(* The only constructor of error is `Exn, so presumably these are server-side
errors. Not sure if any I/O errors are possible here. *)
- let `Exn exn = error in
-
- let error = {
- Catch.condition = `Exn exn;
- layer = `WebSocket;
- caused_by = `Server;
- request = Some request;
- response = Some response;
- client = Some (Helpers.client request);
- severity = `Warning; (* Not sure what these errors are, yet. *)
- will_send_response = false;
- } in
+ let (`Exn exn) = error in
+
+ let error =
+ {
+ Catch.condition = `Exn exn;
+ layer = `WebSocket;
+ caused_by = `Server;
+ request = Some request;
+ response = Some response;
+ client = Some (Helpers.client request);
+ severity = `Warning;
+ (* Not sure what these errors are, yet. *)
+ will_send_response = false;
+ }
+ in
Lwt.async (fun () ->
- double_faults
- (fun () -> Lwt.map ignore (user's_error_handler error))
- Lwt.return)
-
-
-
-let websocket_handshake
- user's_error_handler =
- fun request response error_string ->
-
- let error = {
- Catch.condition = `String error_string;
- layer = `WebSocket;
- caused_by = `Client;
- request = Some request;
- response = Some response;
- client = Some (Helpers.client request);
- severity = `Warning;
- will_send_response = true;
- } in
+ double_faults
+ (fun () -> Lwt.map ignore (user's_error_handler error))
+ Lwt.return)
+
+let websocket_handshake user's_error_handler request response error_string =
+ let error =
+ {
+ Catch.condition = `String error_string;
+ layer = `WebSocket;
+ caused_by = `Client;
+ request = Some request;
+ response = Some response;
+ client = Some (Helpers.client request);
+ severity = `Warning;
+ will_send_response = true;
+ }
+ in
respond_with_option (fun () -> user's_error_handler error)
File "src/http/http.ml", line 1, characters 0-0:
diff --git a/_build/default/src/http/http.ml b/_build/default/src/http/.formatted/http.ml
index 85414dc..9938c4d 100644
--- a/_build/default/src/http/http.ml
+++ b/_build/default/src/http/.formatted/http.ml
@@ -3,8 +3,6 @@
Copyright 2021 Anton Bachin *)
-
-
module Catch = Dream__server.Catch
module Helpers = Dream__server.Helpers
module Log = Dream__server.Log
@@ -13,30 +11,17 @@ module Method = Dream_pure.Method
module Status = Dream_pure.Status
module Stream = Dream_pure.Stream
-
-
(* TODO In serious need of refactoring because of all the different handlers. *)
-
-
let to_dream_method method_ =
Httpaf.Method.to_string method_ |> Method.string_to_method
let to_httpaf_status status =
Status.status_to_int status |> Httpaf.Status.of_code
-let to_h2_status status =
- Status.status_to_int status |> H2.Status.of_code
-
-let sha1 s =
- s
- |> Digestif.SHA1.digest_string
- |> Digestif.SHA1.to_raw_string
-
-let websocket_log =
- Log.sub_log "dream.websocket"
-
-
+let to_h2_status status = Status.status_to_int status |> H2.Status.of_code
+let sha1 s = s |> Digestif.SHA1.digest_string |> Digestif.SHA1.to_raw_string
+let websocket_log = Log.sub_log "dream.websocket"
(* Wraps the user's Dream handler in the kind of handler expected by http/af.
The scheme is simple: wait for http/af "Reqd.t"s (partially parsed
@@ -49,50 +34,38 @@ 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
- tls
- (user's_error_handler : Catch.error_handler)
+let wrap_handler tls (user's_error_handler : Catch.error_handler)
(user's_dream_handler : Message.handler) =
-
- let httpaf_request_handler = fun client_address (conn : _ Gluten.Reqd.t) ->
+ let httpaf_request_handler client_address (conn : _ Gluten.Reqd.t) =
Log.set_up_exception_hook ();
- let conn, upgrade = conn.reqd, conn.upgrade in
+ let conn, upgrade = (conn.reqd, conn.upgrade) in
(* Covert the http/af request to a Dream request. *)
- let httpaf_request : Httpaf.Request.t =
- Httpaf.Reqd.request conn in
-
- let client =
- Adapt.address_to_string client_address in
- let method_ =
- to_dream_method httpaf_request.meth in
- let target =
- httpaf_request.target in
- let headers =
- Httpaf.Headers.to_list httpaf_request.headers in
-
- let body =
- Httpaf.Reqd.request_body conn in
+ let httpaf_request : Httpaf.Request.t = Httpaf.Reqd.request conn in
+
+ let client = Adapt.address_to_string client_address in
+ let method_ = to_dream_method httpaf_request.meth in
+ let target = httpaf_request.target in
+ let headers = Httpaf.Headers.to_list httpaf_request.headers in
+
+ let body = Httpaf.Reqd.request_body conn in
(* TODO Review per-chunk allocations. *)
(* TODO Should the stream be auto-closed? It doesn't even have a closed
state. The whole thing is just a wrapper for whatever the http/af
behavior is. *)
let read ~data ~flush:_ ~ping:_ ~pong:_ ~close ~exn:_ =
- Httpaf.Body.Reader.schedule_read
- body
+ Httpaf.Body.Reader.schedule_read body
~on_eof:(fun () -> close 1000)
~on_read:(fun buffer ~off ~len -> data buffer off len true false)
in
- let close _code =
- Httpaf.Body.Reader.close body in
- let body =
- Stream.reader ~read ~close ~abort:close in
- let body =
- Stream.stream body Stream.no_writer in
+ let close _code = Httpaf.Body.Reader.close body in
+ let body = Stream.reader ~read ~close ~abort:close in
+ let body = Stream.stream body Stream.no_writer in
let request : Message.request =
- Helpers.request ~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
@@ -104,118 +77,103 @@ 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. *)
- Lwt.async begin fun () ->
- Lwt.catch begin fun () ->
- (* Do the big call. *)
- let%lwt response = user's_dream_handler request in
-
- (* Extract the Dream response's headers. *)
-
- (* 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:
+ Lwt.async (fun () ->
+ Lwt.catch (fun () ->
+ (* Do the big call. *)
+ let%lwt response = user's_dream_handler request in
- 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;
+ (* Extract the Dream response's headers. *)
- let headers =
- Httpaf.Headers.of_list (Message.all_headers response) in
+ (* 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:
- let status =
- to_httpaf_status (Message.status response) in
+ 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 httpaf_response =
- Httpaf.Response.create ~headers status in
- let body =
- Httpaf.Reqd.respond_with_streaming conn httpaf_response in
+ let headers =
+ Httpaf.Headers.of_list (Message.all_headers response)
+ in
- Adapt.forward_body response body;
+ let status = to_httpaf_status (Message.status response) in
- Lwt.return_unit
- 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 httpaf_response = Httpaf.Response.create ~headers status in
+ let body =
+ Httpaf.Reqd.respond_with_streaming conn httpaf_response
+ in
- let headers =
- Httpaf.Headers.of_list (Message.all_headers response) in
+ Adapt.forward_body response body;
- Websocketaf.Handshake.respond_with_upgrade ~headers ~sha1 conn proceed
- |> function
- | Ok () -> Lwt.return_unit
- | Error error_string ->
- let%lwt response =
- Error_handler.websocket_handshake
- user's_error_handler request response error_string
+ Lwt.return_unit
in
- forward_response response
- end
- @@ fun exn ->
+
+ 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
+
+ Websocketaf.Handshake.respond_with_upgrade ~headers ~sha1 conn
+ proceed
+ |> function
+ | Ok () -> Lwt.return_unit
+ | Error error_string ->
+ let%lwt response =
+ Error_handler.websocket_handshake user's_error_handler request
+ response error_string
+ in
+ forward_response response))
+ @@ fun 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
+ Lwt.return_unit)
in
httpaf_request_handler
-
-
(* TODO Factor out what is in common between the http/af and h2 handlers. *)
-let wrap_handler_h2
- tls
- (_user's_error_handler : Catch.error_handler)
+let wrap_handler_h2 tls (_user's_error_handler : Catch.error_handler)
(user's_dream_handler : Message.handler) =
-
- let httpaf_request_handler = fun client_address (conn : H2.Reqd.t) ->
+ let httpaf_request_handler 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
-
- let client =
- Adapt.address_to_string client_address in
- let method_ =
- to_dream_method httpaf_request.meth in
- let target =
- httpaf_request.target in
- let headers =
- H2.Headers.to_list httpaf_request.headers in
-
- let body =
- H2.Reqd.request_body conn in
+ let httpaf_request : H2.Request.t = H2.Reqd.request conn in
+
+ let client = Adapt.address_to_string client_address in
+ let method_ = to_dream_method httpaf_request.meth in
+ let target = httpaf_request.target in
+ let headers = H2.Headers.to_list httpaf_request.headers in
+
+ let body = H2.Reqd.request_body conn in
let read ~data ~flush:_ ~ping:_ ~pong:_ ~close ~exn:_ =
- H2.Body.Reader.schedule_read
- body
+ H2.Body.Reader.schedule_read body
~on_eof:(fun () -> close 1000)
~on_read:(fun buffer ~off ~len -> data buffer off len true false)
in
- let close _code =
- H2.Body.Reader.close body in
- let body =
- Stream.reader ~read ~close ~abort:close in
- let body =
- Stream.stream body Stream.no_writer in
+ let close _code = H2.Body.Reader.close body in
+ let body = Stream.reader ~read ~close ~abort:close in
+ let body = Stream.stream body Stream.no_writer in
let request : Message.request =
- Helpers.request ~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
@@ -227,56 +185,43 @@ 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. *)
- Lwt.async begin fun () ->
- Lwt.catch begin fun () ->
- (* Do the big call. *)
- let%lwt 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;
-
- Lwt.return_unit
- in
+ Lwt.async (fun () ->
+ Lwt.catch (fun () ->
+ (* Do the big call. *)
+ let%lwt 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;
+
+ Lwt.return_unit
+ 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? *)
- Lwt.return_unit
- end
- @@ fun exn ->
+ 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)
+ @@ fun 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
+ Lwt.return_unit)
in
httpaf_request_handler
-
-
-let log =
- Error_handler.log
-
-
+let log = Error_handler.log
type tls_library = {
create_handler :
@@ -284,118 +229,93 @@ type tls_library = {
key_file:string ->
handler:Message.handler ->
error_handler:Catch.error_handler ->
- Unix.sockaddr ->
- Lwt_unix.file_descr ->
- unit Lwt.t;
-}
-
-let no_tls = {
- 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)
- ~error_handler:(Error_handler.httpaf error_handler)
- end;
+ Unix.sockaddr ->
+ Lwt_unix.file_descr ->
+ unit Lwt.t;
}
-let openssl = {
- create_handler = begin fun
- ~certificate_file ~key_file
- ~handler
- ~error_handler ->
-
- 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)
- in
+let no_tls =
+ {
+ 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)
+ ~error_handler:(Error_handler.httpaf error_handler)
+ end;
+ }
+
+let openssl =
+ {
+ create_handler =
+ begin
+ fun ~certificate_file ~key_file ~handler ~error_handler ->
+ 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)
+ 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)
- 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)
+ in
- let perform_tls_handshake =
- Gluten_lwt_unix.Server.SSL.create_default
- ~alpn_protocols:["h2"; "http/1.1"]
- ~certfile:certificate_file
- ~keyfile:key_file
- in
+ let perform_tls_handshake =
+ Gluten_lwt_unix.Server.SSL.create_default
+ ~alpn_protocols:["h2"; "http/1.1"] ~certfile:certificate_file
+ ~keyfile:key_file
+ in
- fun client_address unix_socket ->
- let%lwt tls_endpoint = 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 *)
- match Lwt_ssl.ssl_socket tls_endpoint with
- | None ->
- assert false
- | Some tls_socket ->
- match Ssl.get_negotiated_alpn_protocol tls_socket with
- | None ->
- (* Not 100% confirmed, but it appears that at least Chromium does not
- send an ALPN protocol list when attempting to establish a secure
- WebSocket connection (presumably, it assumes HTTP/1.1; RFC 8441 is
- not implemented). This is partially good, because h2 does not seem
- to implement RFC 8441, either. So, to support wss:// in the
- presence of ALPN, handle ALPN failure by just continuing with
- HTTP/1.1. Once there is HTTP/2 WebSocket support, the web
- application will need to respond to the CONNECT method. *)
- (* TODO DOC User guidance on responding to both GET and CONNECT in
- WebSocket handlers. *)
- httpaf_handler client_address tls_endpoint
- | Some "http/1.1" ->
- httpaf_handler client_address tls_endpoint
- | Some "h2" ->
- h2_handler client_address tls_endpoint
- | Some _ ->
- assert false
- end;
-}
+ fun client_address unix_socket ->
+ let%lwt tls_endpoint =
+ 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 *)
+ match Lwt_ssl.ssl_socket tls_endpoint with
+ | None -> assert false
+ | Some tls_socket -> (
+ match Ssl.get_negotiated_alpn_protocol tls_socket with
+ | None ->
+ (* Not 100% confirmed, but it appears that at least Chromium does not
+ send an ALPN protocol list when attempting to establish a secure
+ WebSocket connection (presumably, it assumes HTTP/1.1; RFC 8441 is
+ not implemented). This is partially good, because h2 does not seem
+ to implement RFC 8441, either. So, to support wss:// in the
+ presence of ALPN, handle ALPN failure by just continuing with
+ HTTP/1.1. Once there is HTTP/2 WebSocket support, the web
+ application will need to respond to the CONNECT method. *)
+ (* TODO DOC User guidance on responding to both GET and CONNECT in
+ WebSocket handlers. *)
+ httpaf_handler client_address tls_endpoint
+ | Some "http/1.1" -> httpaf_handler client_address tls_endpoint
+ | Some "h2" -> h2_handler client_address tls_endpoint
+ | Some _ -> assert false)
+ end;
+ }
(* TODO LATER Add ALPN + HTTP/2.0 with ocaml-tls, too. *)
-let ocaml_tls = {
- create_handler = fun
- ~certificate_file ~key_file
- ~handler
- ~error_handler ->
- 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)
- ~error_handler:(Error_handler.httpaf error_handler)
-}
-
-
+let ocaml_tls =
+ {
+ create_handler =
+ (fun ~certificate_file ~key_file ~handler ~error_handler ->
+ 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)
+ ~error_handler:(Error_handler.httpaf error_handler));
+ }
let built_in_middleware error_handler =
- Message.pipeline [
- Catch.catch (Error_handler.app error_handler);
- ]
-
-
-
-let serve_with_details
- caller_function_for_error_messages
- tls_library
- ~interface
- ~port
- ~stop
- ~error_handler
- ~certificate_file
- ~key_file
- ~builtins
- user's_dream_handler =
+ Message.pipeline [Catch.catch (Error_handler.app error_handler)]
+let serve_with_details caller_function_for_error_messages tls_library ~interface
+ ~port ~stop ~error_handler ~certificate_file ~key_file ~builtins
+ user's_dream_handler =
(* TODO DOC *)
(* https://letsencrypt.org/docs/certificates-for-localhost/ *)
-
let user's_dream_handler =
if builtins then
built_in_middleware error_handler user's_dream_handler
@@ -405,11 +325,8 @@ let serve_with_details
(* Create the wrapped httpaf or h2 handler from the user's Dream handler. *)
let httpaf_connection_handler =
- tls_library.create_handler
- ~certificate_file
- ~key_file
- ~handler:user's_dream_handler
- ~error_handler
+ tls_library.create_handler ~certificate_file ~key_file
+ ~handler:user's_dream_handler ~error_handler
in
(* TODO Should probably move out to the TLS library options. *)
@@ -432,8 +349,7 @@ let serve_with_details
some useful way. *)
let httpaf_connection_handler client_address socket =
Lwt.catch
- (fun () ->
- httpaf_connection_handler client_address socket)
+ (fun () -> httpaf_connection_handler client_address socket)
(fun exn ->
tls_error_handler client_address exn;
Lwt.return_unit)
@@ -446,95 +362,69 @@ 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
-
-
- (* 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
-
-
+ | 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 is_localhost interface =
- interface = "localhost" || interface = "127.0.0.1"
+ let%lwt () = stop in
+ Lwt_io.shutdown_server server
-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
- user's_dream_handler =
+let is_localhost interface = interface = "localhost" || interface = "127.0.0.1"
+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 user's_dream_handler =
try%lwt
(* This check will at least catch secrets like "foo" when used on a public
interface. *)
(* if not (is_localhost interface) then
- if String.length secret < 32 then begin
- log.warning (fun log -> log "Using a short key on a public interface");
- log.warning (fun log ->
- log "Consider using Dream.to_base64url (Dream.random 32)");
- end; *)
+ if String.length secret < 32 then begin
+ log.warning (fun log -> log "Using a short key on a public interface");
+ log.warning (fun log ->
+ log "Consider using Dream.to_base64url (Dream.random 32)");
+ end; *)
(* TODO Make sure there is a similar check in cipher.ml now.Hpack *)
-
match tls with
| `No ->
- serve_with_details
- caller_function_for_error_messages
- no_tls
- ~interface
- ~port
- ~stop
- ~error_handler
- ~certificate_file:""
- ~key_file:""
- ~builtins
+ serve_with_details caller_function_for_error_messages no_tls ~interface
+ ~port ~stop ~error_handler ~certificate_file:"" ~key_file:"" ~builtins
user's_dream_handler
-
- | `OpenSSL | `OCaml_TLS as tls_library ->
+ | (`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
the SSL binding already supports in-memory certificates. Does TLS? In
any case, this would need upstream work. *)
let certificate_and_key =
- match certificate_file, key_file, certificate_string, key_string with
+ match (certificate_file, key_file, certificate_string, key_string) with
| None, None, None, None ->
(* Use the built-in development certificate. However, if the interface
- is not a loopback interface, write a warning. *)
+ is not a loopback interface, write a warning. *)
if not (is_localhost interface) then begin
log.warning (fun log ->
- log "Using a development SSL certificate on a public interface");
+ log "Using a development SSL certificate on a public interface");
log.warning (fun log ->
- log "See arguments ~certificate_file and ~key_file");
+ log "See arguments ~certificate_file and ~key_file")
end;
- `Memory (
- Dream__certificate.localhost_certificate,
- Dream__certificate.localhost_certificate_key,
- `Silent
- )
-
+ `Memory
+ ( Dream__certificate.localhost_certificate,
+ Dream__certificate.localhost_certificate_key,
+ `Silent )
| Some certificate_file, Some key_file, None, None ->
`File (certificate_file, key_file)
-
| None, None, Some certificate_string, Some key_string ->
(* This is likely a non-development in-memory certificate, and it
seems reasonable to warn that we are going to write it to a
temporary file, with security implications. *)
log.warning (fun log ->
- log "In-memory certificates will be written to temporary files");
+ log "In-memory certificates will be written to temporary files");
(* Show where the certificate is written so that the user can get rid
of it, if necessary. In particular, the key file should be removed
@@ -542,10 +432,10 @@ let serve_with_maybe_https
the server itself does not use an equivalent of srm to get rid of
the temporary file. Updstream support is really necessary here. *)
`Memory (certificate_string, key_string, `Verbose)
-
| _ ->
- raise (Invalid_argument
- "Must specify exactly one pair of certificate and key")
+ raise
+ (Invalid_argument
+ "Must specify exactly one pair of certificate and key")
in
let tls_library =
@@ -556,112 +446,61 @@ let serve_with_maybe_https
match certificate_and_key with
| `File (certificate_file, key_file) ->
- serve_with_details
- caller_function_for_error_messages
- tls_library
- ~interface
- ~port
- ~stop
- ~error_handler
- ~certificate_file
- ~key_file
- ~builtins
- user's_dream_handler
-
+ serve_with_details caller_function_for_error_messages tls_library
+ ~interface ~port ~stop ~error_handler ~certificate_file ~key_file
+ ~builtins user's_dream_handler
| `Memory (certificate_string, key_string, verbose_or_silent) ->
- Lwt_io.with_temp_file begin fun (certificate_file, certificate_stream) ->
- Lwt_io.with_temp_file begin fun (key_file, key_stream) ->
-
- if verbose_or_silent <> `Silent then begin
- log.warning (fun log ->
- log "Writing certificate to %s" certificate_file);
- log.warning (fun log ->
- log "Writing key to %s" key_file);
- end;
-
- let%lwt () = Lwt_io.write certificate_stream certificate_string in
- let%lwt () = Lwt_io.write key_stream key_string in
- let%lwt () = Lwt_io.close certificate_stream in
- let%lwt () = Lwt_io.close key_stream in
-
- serve_with_details
- caller_function_for_error_messages
- tls_library
- ~interface
- ~port
- ~stop
- ~error_handler
- ~certificate_file
- ~key_file
- ~builtins
- user's_dream_handler
-
- end
- end
-
+ Lwt_io.with_temp_file (fun (certificate_file, certificate_stream) ->
+ Lwt_io.with_temp_file (fun (key_file, key_stream) ->
+ if verbose_or_silent <> `Silent then begin
+ log.warning (fun log ->
+ log "Writing certificate to %s" certificate_file);
+ log.warning (fun log -> log "Writing key to %s" key_file)
+ end;
+
+ let%lwt () =
+ Lwt_io.write certificate_stream certificate_string
+ in
+ let%lwt () = Lwt_io.write key_stream key_string in
+ let%lwt () = Lwt_io.close certificate_stream in
+ let%lwt () = Lwt_io.close key_stream in
+
+ serve_with_details caller_function_for_error_messages
+ tls_library ~interface ~port ~stop ~error_handler
+ ~certificate_file ~key_file ~builtins user's_dream_handler)))
with exn ->
let backtrace = Printexc.get_backtrace () in
log.error (fun log ->
- log "Dream.%s: exception %s"
- caller_function_for_error_messages (Printexc.to_string exn));
- backtrace |> Log.iter_backtrace (fun line ->
- log.error (fun log -> log "%s" line));
+ log "Dream.%s: exception %s" caller_function_for_error_messages
+ (Printexc.to_string exn));
+ backtrace
+ |> Log.iter_backtrace (fun line -> log.error (fun log -> log "%s" line));
raise exn
-
-
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)
- user's_dream_handler =
-
- serve_with_maybe_https
- "serve"
- ~interface
- ~port
- ~stop
- ~error_handler
+let serve ?(interface = default_interface) ?(port = default_port)
+ ?(stop = never) ?(error_handler = Error_handler.default) ?(tls = false)
+ ?certificate_file ?key_file ?(builtins = true) user's_dream_handler =
+ serve_with_maybe_https "serve" ~interface ~port ~stop ~error_handler
~tls:(if tls then `OpenSSL else `No)
- ?certificate_file
- ?key_file
- ?certificate_string:None
- ?key_string:None
- ~builtins
- user's_dream_handler
-
-
-
-let run
- ?(interface = default_interface)
- ?(port = default_port)
- ?(stop = never)
- ?(error_handler = Error_handler.default)
- ?(tls = false)
- ?certificate_file
- ?key_file
- ?(builtins = true)
- ?(greeting = true)
- ?(adjust_terminal = true)
- user's_dream_handler =
+ ?certificate_file ?key_file ?certificate_string:None ?key_string:None
+ ~builtins user's_dream_handler
- let () = if Sys.unix then
- Sys.(set_signal sigpipe Signal_ignore)
+let run ?(interface = default_interface) ?(port = default_port) ?(stop = never)
+ ?(error_handler = Error_handler.default) ?(tls = false) ?certificate_file
+ ?key_file ?(builtins = true) ?(greeting = true) ?(adjust_terminal = true)
+ user's_dream_handler =
+ let () =
+ if Sys.unix then
+ Sys.(set_signal sigpipe Signal_ignore)
in
let adjust_terminal =
- adjust_terminal && Sys.os_type <> "Win32" && Unix.(isatty stderr) in
+ adjust_terminal && Sys.os_type <> "Win32" && Unix.(isatty stderr)
+ in
let restore_terminal =
if adjust_terminal then begin
@@ -685,14 +524,16 @@ let run
let create_handler signal =
let previous_signal_behavior = ref Sys.Signal_default in
previous_signal_behavior :=
- Sys.signal signal @@ Sys.Signal_handle (fun signal ->
- restore_terminal ();
- match !previous_signal_behavior with
- | Sys.Signal_handle f -> f signal
- | Sys.Signal_ignore -> ignore ()
- | Sys.Signal_default ->
- Sys.set_signal signal Sys.Signal_default;
- Unix.kill (Unix.getpid ()) signal)
+ Sys.signal signal
+ @@ Sys.Signal_handle
+ (fun signal ->
+ restore_terminal ();
+ match !previous_signal_behavior with
+ | Sys.Signal_handle f -> f signal
+ | Sys.Signal_ignore -> ignore ()
+ | Sys.Signal_default ->
+ Sys.set_signal signal Sys.Signal_default;
+ Unix.kill (Unix.getpid ()) signal)
in
create_handler Sys.sigint;
@@ -708,31 +549,23 @@ let run
"http"
in
- begin match interface with
- | "localhost" | "127.0.0.1" ->
- log "Running at %s://localhost:%i" scheme port
- | _ ->
- log "Running on %s:%i (%s://localhost:%i)" interface port scheme port
+ begin
+ match interface with
+ | "localhost" | "127.0.0.1" ->
+ log "Running at %s://localhost:%i" scheme port
+ | _ ->
+ log "Running on %s:%i (%s://localhost:%i)" interface port scheme port
end;
log "Type Ctrl+C to stop"
end;
try
- Lwt_main.run begin
- serve_with_maybe_https
- "run"
- ~interface
- ~port
- ~stop
- ~error_handler
- ~tls:(if tls then `OpenSSL else `No)
- ?certificate_file ?key_file
- ?certificate_string:None ?key_string:None
- ~builtins
- user's_dream_handler
- end;
+ Lwt_main.run
+ (serve_with_maybe_https "run" ~interface ~port ~stop ~error_handler
+ ~tls:(if tls then `OpenSSL else `No)
+ ?certificate_file ?key_file ?certificate_string:None ?key_string:None
+ ~builtins user's_dream_handler);
restore_terminal ()
-
with exn ->
restore_terminal ();
raise exn
File "src/graphql/graphql.ml", line 1, characters 0-0:
diff --git a/_build/default/src/graphql/graphql.ml b/_build/default/src/graphql/.formatted/graphql.ml
index 25c548b..0c72cfd 100644
--- a/_build/default/src/graphql/graphql.ml
+++ b/_build/default/src/graphql/.formatted/graphql.ml
@@ -3,16 +3,12 @@
Copyright 2021 Anton Bachin *)
-
-
module Helpers = Dream__server.Helpers
module Log = Dream__server.Log
module Message = Dream_pure.Message
module Method = Dream_pure.Method
module Stream = Dream_pure.Stream
-
-
(* This GraphQL handler supports two transports, i.e. two GraphQL "wire"
protocols:
@@ -24,54 +20,39 @@ module Stream = Dream_pure.Stream
https://github.com/enisdenjo/graphql-ws/blob/master/PROTOCOL.md *)
-let log =
- Log.sub_log "dream.graphql"
-
-
+let log = Log.sub_log "dream.graphql"
(* Shared between HTTP and WebSocket transport. *)
let make_error message =
- `Assoc [
- "errors", `List [
- `Assoc [
- "message", `String message
- ]
- ]
- ]
+ `Assoc [("errors", `List [`Assoc [("message", `String message)]])]
let run_query make_context schema request json =
let module Y = Yojson.Basic.Util in
-
- let query = json |> Y.member "query" |> Y.to_string_option
+ let query = json |> Y.member "query" |> Y.to_string_option
and operation_name = json |> Y.member "operationName" |> Y.to_string_option
- and variables = json |> Y.member "variables" |> Option.some in
+ and variables = json |> Y.member "variables" |> Option.some in
match query with
| None -> Lwt.return (Error (make_error "No query"))
- | Some query ->
-
- match Graphql_parser.parse query with
- | Error message -> Lwt.return (Error (make_error message))
- | Ok query ->
-
- (* TODO Consider being more strict here, allowing only `Assoc and `Null. *)
- let variables =
- match variables with
- | Some (`Assoc _ as json) ->
- (Yojson.Basic.Util.to_assoc json :>
- (string * Graphql_parser.const_value) list)
- |> Option.some
- | _ ->
- None
- in
-
- let%lwt context = make_context request in
-
- Graphql_lwt.Schema.execute
- ?variables ?operation_name schema context query
-
-
+ | Some query -> (
+ match Graphql_parser.parse query with
+ | Error message -> Lwt.return (Error (make_error message))
+ | Ok query ->
+ (* TODO Consider being more strict here, allowing only `Assoc and `Null. *)
+ let variables =
+ match variables with
+ | Some (`Assoc _ as json) ->
+ (Yojson.Basic.Util.to_assoc json
+ :> (string * Graphql_parser.const_value) list)
+ |> Option.some
+ | _ -> None
+ in
+
+ let%lwt context = make_context request in
+
+ Graphql_lwt.Schema.execute ?variables ?operation_name schema context query
+ )
(* WebSocket transport. *)
@@ -84,32 +65,23 @@ let close_and_clean ?code subscriptions websocket =
Lwt.return_unit
let ack_message =
- `Assoc [
- "type", `String "connection_ack";
- ]
- |> Yojson.Basic.to_string
+ `Assoc [("type", `String "connection_ack")] |> Yojson.Basic.to_string
let data_message id payload =
- `Assoc [
- "type", `String "next";
- "id", `String id;
- "payload", payload;
- ]
+ `Assoc [("type", `String "next"); ("id", `String id); ("payload", payload)]
|> Yojson.Basic.to_string
let error_message id json =
- `Assoc [
- "type", `String "error";
- "id", `String id;
- "payload", json |> Yojson.Basic.Util.member "errors";
- ]
+ `Assoc
+ [
+ ("type", `String "error");
+ ("id", `String id);
+ ("payload", json |> Yojson.Basic.Util.member "errors");
+ ]
|> Yojson.Basic.to_string
let complete_message id =
- `Assoc [
- "type", `String "complete";
- "id", `String id;
- ]
+ `Assoc [("type", `String "complete"); ("id", `String id)]
|> Yojson.Basic.to_string
(* TODO Take care to pass around the request Lwt.key in async, etc. *)
@@ -120,228 +92,210 @@ let handle_over_websocket make_context schema subscriptions request websocket =
| None ->
log.info (fun log -> log ~request "GraphQL WebSocket closed by client");
close_and_clean subscriptions websocket
- | Some message ->
-
- log.debug (fun log -> log ~request "Message '%s'" message);
-
- (* TODO Avoid using exceptions here. *)
- match Yojson.Basic.from_string message with
- | exception _ ->
- log.warning (fun log -> log ~request "GraphQL message is not JSON");
- close_and_clean subscriptions websocket ~code:4400
- | json ->
-
- match Yojson.Basic.Util.(json |> member "type" |> to_string_option) with
- | None ->
- log.warning (fun log -> log ~request "GraphQL message lacks a type");
- close_and_clean subscriptions websocket ~code:4400
- | Some message_type ->
-
- match message_type with
-
- | "connection_init" ->
- if inited then begin
- log.warning (fun log -> log ~request "Duplicate connection_init");
- close_and_clean subscriptions websocket ~code:4429
- end
- else begin
- let%lwt () = Helpers.send websocket ack_message in
- loop true
- end
-
- | "complete" ->
- if not inited then begin
- log.warning (fun log -> log ~request "complete before connection_init");
- close_and_clean subscriptions websocket ~code:4401
- end
- else begin
- match operation_id json with
- | None ->
- log.warning (fun log ->
- log ~request "client complete: operation id missing");
- close_and_clean subscriptions websocket ~code:4400
- | Some id ->
- begin match Hashtbl.find_opt subscriptions id with
- | None -> ()
- | Some close -> close ()
- end;
- loop inited
- end
-
- | "subscribe" ->
- if not inited then begin
- log.warning (fun log ->
- log ~request "subscribe before connection_init");
- close_and_clean subscriptions websocket ~code:4401
- end
- else begin
- match operation_id json with
+ | Some message -> (
+ log.debug (fun log -> log ~request "Message '%s'" message);
+
+ (* TODO Avoid using exceptions here. *)
+ match Yojson.Basic.from_string message with
+ | exception _ ->
+ log.warning (fun log -> log ~request "GraphQL message is not JSON");
+ close_and_clean subscriptions websocket ~code:4400
+ | json -> (
+ match Yojson.Basic.Util.(json |> member "type" |> to_string_option) with
| None ->
- log.warning (fun log ->
- log ~request "subscribe: operation id missing");
+ log.warning (fun log -> log ~request "GraphQL message lacks a type");
close_and_clean subscriptions websocket ~code:4400
- | Some id ->
-
- let payload = json |> Yojson.Basic.Util.member "payload" in
-
- Lwt.async begin fun () ->
- let subscribed = ref false in
-
- try%lwt
- match%lwt run_query make_context schema request payload with
- | Error json ->
+ | Some message_type -> (
+ match message_type with
+ | "connection_init" ->
+ if inited then begin
+ log.warning (fun log -> log ~request "Duplicate connection_init");
+ close_and_clean subscriptions websocket ~code:4429
+ end
+ else
+ let%lwt () = Helpers.send websocket ack_message in
+ loop true
+ | "complete" -> (
+ if not inited then begin
log.warning (fun log ->
- log ~request
- "subscribe: error %s" (Yojson.Basic.to_string json));
- Helpers.send websocket (error_message id json)
-
- (* 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
-
- | Ok (`Stream (stream, close)) ->
- match Hashtbl.mem subscriptions id with
- | true ->
+ log ~request "complete before connection_init");
+ close_and_clean subscriptions websocket ~code:4401
+ end
+ else
+ match operation_id json with
+ | None ->
log.warning (fun log ->
- log ~request "subscribe: duplicate operation id");
- close_and_clean subscriptions websocket ~code:4409
- | false ->
-
- Hashtbl.replace subscriptions id close;
- subscribed := true;
-
- let%lwt () =
- stream |> Lwt_stream.iter_s (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
-
- let%lwt () = Helpers.send websocket (complete_message id) in
- Hashtbl.remove subscriptions id;
- Lwt.return_unit
-
- with exn ->
- let backtrace = Printexc.get_backtrace () in
- log.error (fun log ->
- log ~request "Exception while handling WebSocket message:");
- log.error (fun log ->
- log ~request "%s" (Printexc.to_string exn));
- backtrace
- |> 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
- if !subscribed then
- Helpers.send websocket (complete_message id)
- else
- Lwt.return_unit
- with _ ->
- Lwt.return_unit
- end;
-
- loop inited
- end
-
- | message_type ->
- log.warning (fun log ->
- log ~request "Unknown WebSocket message type '%s'" message_type);
- close_and_clean subscriptions websocket ~code:4400
+ log ~request "client complete: operation id missing");
+ close_and_clean subscriptions websocket ~code:4400
+ | Some id ->
+ begin
+ match Hashtbl.find_opt subscriptions id with
+ | None -> ()
+ | Some close -> close ()
+ end;
+ loop inited)
+ | "subscribe" -> (
+ if not inited then begin
+ log.warning (fun log ->
+ log ~request "subscribe before connection_init");
+ close_and_clean subscriptions websocket ~code:4401
+ end
+ else
+ match operation_id json with
+ | None ->
+ log.warning (fun log ->
+ log ~request "subscribe: operation id missing");
+ close_and_clean subscriptions websocket ~code:4400
+ | Some id ->
+ let payload = json |> Yojson.Basic.Util.member "payload" in
+
+ Lwt.async (fun () ->
+ let subscribed = ref false in
+
+ try%lwt
+ match%lwt
+ run_query make_context schema request payload
+ with
+ | Error json ->
+ log.warning (fun log ->
+ log ~request "subscribe: error %s"
+ (Yojson.Basic.to_string json));
+ Helpers.send websocket (error_message id json)
+ (* 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
+ | Ok (`Stream (stream, close)) -> (
+ match Hashtbl.mem subscriptions id with
+ | true ->
+ log.warning (fun log ->
+ log ~request "subscribe: duplicate operation id");
+ close_and_clean subscriptions websocket ~code:4409
+ | false ->
+ Hashtbl.replace subscriptions id close;
+ subscribed := true;
+
+ let%lwt () =
+ stream
+ |> Lwt_stream.iter_s (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
+
+ let%lwt () =
+ Helpers.send websocket (complete_message id)
+ in
+ Hashtbl.remove subscriptions id;
+ Lwt.return_unit)
+ with exn -> (
+ let backtrace = Printexc.get_backtrace () in
+ log.error (fun log ->
+ log ~request
+ "Exception while handling WebSocket message:");
+ log.error (fun log ->
+ log ~request "%s" (Printexc.to_string exn));
+ backtrace
+ |> 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
+ if !subscribed then
+ Helpers.send websocket (complete_message id)
+ else
+ Lwt.return_unit
+ with _ -> Lwt.return_unit));
+
+ loop inited)
+ | message_type ->
+ log.warning (fun log ->
+ log ~request "Unknown WebSocket message type '%s'" message_type);
+ close_and_clean subscriptions websocket ~code:4400)))
in
loop false
-
-
(* HTTP transport.
Supports either POST requests carrying a GraphQL query, or GET requests
carrying WebSocket upgrade headers. *)
-let graphql make_context schema = fun request ->
+let graphql make_context schema request =
match Message.method_ request with
- | `GET ->
+ | `GET -> (
let upgrade = Message.header request "Upgrade"
and protocol = Message.header request "Sec-WebSocket-Protocol" in
- begin match upgrade, protocol with
+ match (upgrade, protocol) with
| Some "websocket", Some "graphql-transport-ws" ->
Helpers.websocket
- ~headers:["Sec-WebSocket-Protocol", "graphql-transport-ws"]
+ ~headers:[("Sec-WebSocket-Protocol", "graphql-transport-ws")]
(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" ->
+ Message.response ~status:`Not_Found Stream.empty Stream.null |> Lwt.return
+ )
+ | `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
-
+ 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
-
+ |> Helpers.json)
| _ ->
- log.warning (fun log -> log ~request
- "Content-Type not 'application/json'");
+ log.warning (fun log ->
+ log ~request "Content-Type not 'application/json'");
Message.response ~status:`Bad_Request Stream.empty Stream.null
|> Lwt.return
- end
-
+ 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
-
-
+ 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
let graphiql ?(default_query = "") graphql_endpoint =
- begin match String.index_opt graphql_endpoint '"' with
- | None -> ()
- | Some _ ->
- log.error (fun log ->
- log "GraphQL endpoint route '%s' contains '\"'" graphql_endpoint);
- log.error (fun log ->
- log "If intentional, please open an issue about supporting this");
- log.error (fun log ->
- log "https://github.com/aantron/dream/issues")
+ begin
+ match String.index_opt graphql_endpoint '"' with
+ | None -> ()
+ | Some _ ->
+ log.error (fun log ->
+ log "GraphQL endpoint route '%s' contains '\"'" graphql_endpoint);
+ log.error (fun log ->
+ log "If intentional, please open an issue about supporting this");
+ log.error (fun log -> log "https://github.com/aantron/dream/issues")
end;
let html =
- lazy begin
- Dream__graphiql.content
- |> Str.(global_replace (regexp (quote "%%ENDPOINT%%")) graphql_endpoint)
- |> Str.(global_replace (regexp (quote "%%DEFAULT_QUERY%%")) default_query)
- end
+ lazy
+ begin
+ Dream__graphiql.content
+ |> Str.(global_replace (regexp (quote "%%ENDPOINT%%")) graphql_endpoint)
+ |> Str.(
+ global_replace (regexp (quote "%%DEFAULT_QUERY%%")) default_query)
+ end
in
- fun _request ->
- Helpers.html (Lazy.force html)
+ fun _request -> Helpers.html (Lazy.force html)
File "src/mirage/error_handler.ml", line 1, characters 0-0:
diff --git a/_build/default/src/mirage/error_handler.ml b/_build/default/src/mirage/.formatted/error_handler.ml
index e8da12e..33782a2 100644
--- a/_build/default/src/mirage/error_handler.ml
+++ b/_build/default/src/mirage/.formatted/error_handler.ml
@@ -1,4 +1,3 @@
-
module Catch = Dream__server.Catch
module Error_template = Dream__server.Error_template
module Method = Dream_pure.Method
@@ -8,9 +7,7 @@ module Message = Dream_pure.Message
module Status = Dream_pure.Status
module Stream = Dream_pure.Stream
-
-let log =
- Dream__server.Log.sub_log "dream.mirage"
+let log = Dream__server.Log.sub_log "dream.mirage"
let select_log = function
| `Error -> log.error
@@ -18,97 +15,93 @@ let select_log = function
| `Info -> log.info
| `Debug -> log.debug
- let dump (error : Catch.error) =
- let buffer = Buffer.create 4096 in
- let p format = Printf.bprintf buffer format in
-
- begin match error.condition with
+let dump (error : Catch.error) =
+ let buffer = Buffer.create 4096 in
+ let p format = Printf.bprintf buffer format in
+
+ begin
+ match error.condition with
| `Response response ->
let status = Message.status response in
p "%i %s\n" (Status.status_to_int status) (Status.status_to_string status)
-
- | `String "" ->
- p "(Library error without description payload)\n"
-
- | `String string ->
- p "%s\n" string
-
+ | `String "" -> p "(Library error without description payload)\n"
+ | `String string -> p "%s\n" string
| `Exn exn ->
let backtrace = Printexc.get_backtrace () in
p "%s\n" (Printexc.to_string exn);
backtrace |> Log.iter_backtrace (p "%s\n")
- end;
-
- p "\n";
-
- let layer =
- match error.layer with
- | `TLS -> "TLS library"
- | `HTTP -> "HTTP library"
- | `HTTP2 -> "HTTP2 library"
- | `WebSocket -> "WebSocket library"
- | `App -> "Application"
- in
-
- let blame =
- match error.caused_by with
- | `Server -> "Server"
- | `Client -> "Client"
- in
-
- let severity =
- match error.severity with
- | `Error -> "Error"
- | `Warning -> "Warning"
- | `Info -> "Info"
- | `Debug -> "Debug"
- in
-
- p "From: %s\n" layer;
- p "Blame: %s\n" blame;
- p "Severity: %s" severity;
-
- begin match error.client with
+ end;
+
+ p "\n";
+
+ let layer =
+ match error.layer with
+ | `TLS -> "TLS library"
+ | `HTTP -> "HTTP library"
+ | `HTTP2 -> "HTTP2 library"
+ | `WebSocket -> "WebSocket library"
+ | `App -> "Application"
+ in
+
+ let blame =
+ match error.caused_by with
+ | `Server -> "Server"
+ | `Client -> "Client"
+ in
+
+ let severity =
+ match error.severity with
+ | `Error -> "Error"
+ | `Warning -> "Warning"
+ | `Info -> "Info"
+ | `Debug -> "Debug"
+ in
+
+ p "From: %s\n" layer;
+ p "Blame: %s\n" blame;
+ p "Severity: %s" severity;
+
+ begin
+ match error.client with
| None -> ()
| Some client -> p "\n\nClient: %s" client
- end;
-
- begin match error.request with
+ end;
+
+ begin
+ match error.request with
| None -> ()
| Some request ->
p "\n\n%s %s"
(Method.method_to_string (Message.method_ request))
(Message.target request);
-
+
Message.all_headers request
|> List.iter (fun (name, value) -> p "\n%s: %s" name value);
-
- Message.fold_fields (fun name value first ->
- if first then
- p "\n";
- p "\n%s: %s" name value;
- false)
- true
- request
+
+ Message.fold_fields
+ (fun name value first ->
+ if first then
+ p "\n";
+ p "\n%s: %s" name value;
+ false)
+ true request
|> ignore
- end;
-
- Buffer.contents buffer
+ end;
- let customize template (error : Catch.error) =
+ Buffer.contents buffer
- (* First, log the error. *)
-
- begin match error.condition with
+let customize template (error : Catch.error) =
+ (* First, log the error. *)
+ begin
+ match error.condition with
| `Response _ -> ()
- | `String _ | `Exn _ as condition ->
-
+ | (`String _ | `Exn _) as condition ->
let client =
match error.client with
| None -> ""
- | Some client -> " (" ^ client ^ ")"
+ | Some client -> " (" ^ client ^ ")"
in
-
+
let layer =
match error.layer with
| `TLS -> ["TLS" ^ client]
@@ -117,131 +110,121 @@ let select_log = function
| `WebSocket -> ["WebSocket" ^ client]
| `App -> []
in
-
+
let description, backtrace =
match condition with
- | `String string -> string, ""
+ | `String string -> (string, "")
| `Exn exn ->
let backtrace = Printexc.get_backtrace () in
- Printexc.to_string exn, backtrace
+ (Printexc.to_string exn, backtrace)
in
-
+
let message = String.concat ": " (layer @ [description]) in
-
+
select_log error.severity (fun log ->
- log ?request:error.request "%s" message);
- backtrace |> Log.iter_backtrace (fun line ->
- select_log error.severity (fun log ->
- log ?request:error.request "%s" line))
- end;
-
- (* If Dream will not send a response for this error, we are done after
- logging. Otherwise, if debugging is enabled, gather a bunch of information.
- Then, call the template, and return the response. *)
-
- if not error.will_send_response then
- Lwt.return_none
-
- else
- let debug_dump = dump error in
-
- let response =
- match error.condition with
- | `Response response -> response
- | _ ->
- let status =
- match error.caused_by with
- | `Server -> `Internal_Server_Error
- | `Client -> `Bad_Request
- in
- Message.response ~status Stream.empty Stream.null
- in
-
- (* 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 default_response = function
- | `Server ->
- Message.response ~status:`Internal_Server_Error Stream.empty Stream.null
- | `Client ->
- Message.response ~status:`Bad_Request Stream.empty Stream.null
-
-let default_template _error _debug_dump response =
- Lwt.return response
+ log ?request:error.request "%s" message);
+ backtrace
+ |> Log.iter_backtrace (fun line ->
+ select_log error.severity (fun log ->
+ log ?request:error.request "%s" line))
+ end;
+
+ (* If Dream will not send a response for this error, we are done after
+ logging. Otherwise, if debugging is enabled, gather a bunch of information.
+ Then, call the template, and return the response. *)
+ if not error.will_send_response then
+ Lwt.return_none
+ else
+ let debug_dump = dump error in
+
+ let response =
+ match error.condition with
+ | `Response response -> response
+ | _ ->
+ let status =
+ match error.caused_by with
+ | `Server -> `Internal_Server_Error
+ | `Client -> `Bad_Request
+ in
+ Message.response ~status Stream.empty Stream.null
+ in
-let default =
- customize default_template
+ (* 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 default_response = function
+ | `Server ->
+ Message.response ~status:`Internal_Server_Error Stream.empty Stream.null
+ | `Client -> Message.response ~status:`Bad_Request Stream.empty Stream.null
+
+let default_template _error _debug_dump response = Lwt.return response
+let default = customize default_template
let double_faults f default =
- Lwt.catch f begin fun exn ->
- let backtrace = Printexc.get_backtrace () in
+ Lwt.catch f (fun exn ->
+ let backtrace = Printexc.get_backtrace () in
- log.error (fun log ->
- log "Error handler raised: %s" (Printexc.to_string exn));
+ log.error (fun log ->
+ log "Error handler raised: %s" (Printexc.to_string exn));
- backtrace
- |> Log.iter_backtrace (fun line ->
- log.error (fun log -> log "%s" line));
+ backtrace
+ |> Log.iter_backtrace (fun line -> log.error (fun log -> log "%s" line));
- default ()
- end
+ default ())
-let httpaf user's_error_handler = fun client_address ?request:_ error start_response ->
- let condition, severity, caused_by = match error with
- | `Exn exn ->
- `Exn exn,
- `Error,
- `Server
- | `Bad_request
- | `Bad_gateway ->
- `String "Bad request",
- `Warning,
- `Client
+let httpaf user's_error_handler client_address ?request:_ error start_response =
+ let condition, severity, caused_by =
+ match error with
+ | `Exn exn -> (`Exn exn, `Error, `Server)
+ | `Bad_request | `Bad_gateway -> (`String "Bad request", `Warning, `Client)
| `Internal_server_error ->
- `String "Content-Length missing or negative",
- `Error,
- `Server in
- let error = {
- Catch.condition;
- layer = `HTTP;
- caused_by;
- request = None;
- response = None;
- client= Some client_address;
- severity;
- 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
+ (`String "Content-Length missing or negative", `Error, `Server)
+ in
+ let error =
+ {
+ Catch.condition;
+ layer = `HTTP;
+ caused_by;
+ request = None;
+ response = None;
+ client = Some client_address;
+ severity;
+ will_send_response = true;
+ }
+ in
+
+ Lwt.async (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)
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))
+ | 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)
-
-let app user's_error_handler = fun error ->
+let app user's_error_handler error =
respond_with_option (fun () -> user's_error_handler error)
File "src/mirage/mirage.ml", line 1, characters 0-0:
diff --git a/_build/default/src/mirage/mirage.ml b/_build/default/src/mirage/.formatted/mirage.ml
index f2c6bb9..0245075 100644
--- a/_build/default/src/mirage/mirage.ml
+++ b/_build/default/src/mirage/.formatted/mirage.ml
@@ -11,41 +11,43 @@ module Router = Dream__server.Router
module Query = Dream__server.Query
module Cookie = Dream__server.Cookie
module Tag = Dream__server.Tag
-
-
open Rresult
open Lwt.Infix
-let to_dream_method meth = Httpaf.Method.to_string meth |> Method.string_to_method
-let to_httpaf_status status = Status.status_to_int status |> Httpaf.Status.of_code
+let to_dream_method meth =
+ Httpaf.Method.to_string meth |> Method.string_to_method
+
+let to_httpaf_status status =
+ Status.status_to_int status |> Httpaf.Status.of_code
+
let ( >>? ) = Lwt_result.bind
let wrap_handler_httpaf _user's_error_handler user's_dream_handler =
- let httpaf_request_handler = fun _ reqd ->
+ let httpaf_request_handler _ reqd =
let httpaf_request = Httpaf.Reqd.request reqd in
let method_ = to_dream_method httpaf_request.meth in
- let target = httpaf_request.target in
- let _version = (httpaf_request.version.major, httpaf_request.version.minor) in
+ let target = httpaf_request.target in
+ let _version =
+ (httpaf_request.version.major, httpaf_request.version.minor)
+ in
let headers = Httpaf.Headers.to_list httpaf_request.headers in
- let body = Httpaf.Reqd.request_body reqd in
+ let body = Httpaf.Reqd.request_body reqd in
let read ~data ~flush:_ ~ping:_ ~pong:_ ~close ~exn:_ =
- Httpaf.Body.Reader.schedule_read
- body
+ Httpaf.Body.Reader.schedule_read body
~on_eof:(fun () -> close 1000)
~on_read:(fun buffer ~off ~len -> data buffer off len true false)
in
- let close _close =
- Httpaf.Body.Reader.close body in
- let abort _close =
- Httpaf.Body.Reader.close body in
- let body =
- Stream.reader ~read ~close ~abort in
+ let close _close = Httpaf.Body.Reader.close body in
+ let abort _close = Httpaf.Body.Reader.close body in
+ let body = Stream.reader ~read ~close ~abort in
let client_stream = Stream.(stream no_reader no_writer) in
let server_stream = Stream.(stream body no_writer) in
- let request = Message.request ~method_ ~target ~headers client_stream server_stream in
+ let request =
+ Message.request ~method_ ~target ~headers client_stream server_stream
+ 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
@@ -57,107 +59,116 @@ let wrap_handler_httpaf _user's_error_handler user's_dream_handler =
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 = user's_dream_handler request in
-
- (* Extract the Dream response's headers. *)
-
- (* 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 version =
- match Dream.version_override response with
- | None -> None
- | Some (major, minor) -> Some Httpaf.Version.{major; minor}
- in *)
- let status =
- to_httpaf_status (Message.status response) in
- (* let reason =
- Dream.reason_override response in *)
-
- let httpaf_response =
- Httpaf.Response.create ~headers status in
- let body =
- Httpaf.Reqd.respond_with_streaming reqd httpaf_response in
-
- Adapt.forward_body response body;
-
- Lwt.return_unit
- in
-
- forward_response response
- end
- @@ fun exn ->
+ Lwt.async (fun () ->
+ Lwt.catch (fun () ->
+ (* Do the big call. *)
+ let%lwt response = user's_dream_handler request in
+
+ (* Extract the Dream response's headers. *)
+
+ (* 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 version =
+ match Dream.version_override response with
+ | None -> None
+ | Some (major, minor) -> Some Httpaf.Version.{major; minor}
+ in *)
+ let status = to_httpaf_status (Message.status response) in
+
+ (* let reason =
+ Dream.reason_override response in *)
+ let httpaf_response = Httpaf.Response.create ~headers status in
+ let body =
+ Httpaf.Reqd.respond_with_streaming reqd httpaf_response
+ in
+
+ Adapt.forward_body response body;
+
+ Lwt.return_unit
+ in
+
+ forward_response response)
+ @@ fun exn ->
(* TODO LATER There was something in the fork changelogs about not
requiring report_exn. Is it relevant to this? *)
Httpaf.Reqd.report_exn reqd exn;
- Lwt.return_unit
- end
+ Lwt.return_unit)
in
httpaf_request_handler
-let request_handler
- : type reqd headers request response ro wo.
- Catch.error_handler -> Message.handler ->
- _ -> _ -> reqd ->
- (reqd, headers, request, response, ro, wo) Alpn.protocol -> unit
- = fun (user's_error_handler : Catch.error_handler)
- (user's_dream_handler : Message.handler) -> ();
- fun _ _ reqd -> function
+let request_handler :
+ type reqd headers request response ro wo.
+ Catch.error_handler ->
+ Message.handler ->
+ _ ->
+ _ ->
+ reqd ->
+ (reqd, headers, request, response, ro, wo) Alpn.protocol ->
+ unit =
+ fun (user's_error_handler : Catch.error_handler)
+ (user's_dream_handler : Message.handler) ->
+ ();
+ fun _ _ reqd -> function
| Alpn.HTTP_1_1 _ ->
wrap_handler_httpaf user's_error_handler user's_dream_handler () reqd
| _ -> assert false
-let error_handler
- : type reqd headers request response ro wo.
+let error_handler :
+ type reqd headers request response ro wo.
Catch.error_handler ->
- _ -> (reqd, headers, request, response, ro, wo) Alpn.protocol ->
- ?request:request -> _ -> (headers -> wo) -> unit
- = fun
- (user's_error_handler : Catch.error_handler) -> ();
- fun client protocol ?request error respond ->
+ _ ->
+ (reqd, headers, request, response, ro, wo) Alpn.protocol ->
+ ?request:request ->
+ _ ->
+ (headers -> wo) ->
+ unit =
+ fun (user's_error_handler : Catch.error_handler) ->
+ ();
+ fun client protocol ?request error respond ->
match protocol with
| Alpn.HTTP_1_1 _ ->
- let start_response hdrs : Httpaf.Body.Writer.t =
- respond hdrs
- in
- Error_handler.httpaf user's_error_handler client ?request:(Some request) error start_response
- | _ -> assert false (* TODO *)
+ let start_response hdrs : Httpaf.Body.Writer.t = respond hdrs in
+ Error_handler.httpaf user's_error_handler client ?request:(Some request)
+ error start_response
+ | _ -> assert false
+(* TODO *)
let handler user_err user_resp =
{
- Alpn.error=(fun edn protocol ?request error respond ->
- error_handler user_err edn protocol ?request error respond);
- request=(fun flow edn reqd protocol ->
- request_handler user_err user_resp flow edn reqd protocol)
+ Alpn.error =
+ (fun edn protocol ?request error respond ->
+ error_handler user_err edn protocol ?request error respond);
+ request =
+ (fun flow edn reqd protocol ->
+ request_handler user_err user_resp flow edn reqd protocol);
}
-
-module Make (Pclock : Mirage_clock.PCLOCK) (Time : Mirage_time.S) (Stack : Tcpip.Stack.V4V6) = struct
+module Make
+ (Pclock : Mirage_clock.PCLOCK)
+ (Time : Mirage_time.S)
+ (Stack : Tcpip.Stack.V4V6) =
+struct
include Dream_pure
include Method
include Status
-
include Log
include Log.Make (Pclock)
include Dream__server.Echo
- let default_log =
- Log.sub_log (Logs.Src.name Logs.default)
-
+ let default_log = Log.sub_log (Logs.Src.name Logs.default)
let error = default_log.error
let warning = default_log.warning
let info = default_log.info
@@ -167,21 +178,18 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Time : Mirage_time.S) (Stack : Tcpip
include Dream__server.Session
include Dream__server.Session.Make (Pclock)
end
- module Flash = Dream__server.Flash
-
+ module Flash = Dream__server.Flash
include Dream__server.Origin_referrer_check
include Dream__server.Form
include Dream__server.Upload
include Dream__server.Csrf
-
-
include Dream__server.Catch
include Dream__server.Site_prefix
- let error_template =
- Error_handler.customize
-(*
+ let error_template = Error_handler.customize
+
+ (*
let random =
Dream__cipher.Random.random
*)
@@ -194,16 +202,13 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Time : Mirage_time.S) (Stack : Tcpip
type handler = Message.handler
type middleware = Message.middleware
type route = Router.route
-
type 'a message = 'a Message.message
type client = Message.client
type server = Message.server
type 'a promise = 'a Message.promise
-
(* Requests *)
-
let body_stream = Message.server_stream
let client = Helpers.client
let method_ = Message.method_
@@ -230,7 +235,6 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Time : Mirage_time.S) (Stack : Tcpip
let write = Message.write
let flush = Message.flush
-
(* Headers *)
let header = Message.header
@@ -248,14 +252,15 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Time : Mirage_time.S) (Stack : Tcpip
let cookie = Cookie.cookie
let all_cookies = Cookie.all_cookies
-
(* Bodies *)
let body = Message.body
let set_body = Message.set_body
let close = Message.close
+
type buffer = Stream.buffer
type stream = Stream.stream
+
let client_stream = Message.client_stream
let server_stream = Message.server_stream
let set_client_stream = Message.set_client_stream
@@ -268,28 +273,33 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Time : Mirage_time.S) (Stack : Tcpip
let close_stream = Stream.close
let abort_stream = Stream.abort
-
(* websockets *)
type websocket = stream * stream
+
let websocket = Helpers.websocket
- type text_or_binary = [ `Text | `Binary ]
- type end_of_message = [ `End_of_message | `Continues ]
+
+ type text_or_binary =
+ [ `Text
+ | `Binary ]
+
+ type end_of_message =
+ [ `End_of_message
+ | `Continues ]
+
let send = Helpers.send
let receive = Helpers.receive
let receive_fragment = Helpers.receive_fragment
let close_websocket = Message.close_websocket
-
(* Middleware *)
let no_middleware = Message.no_middleware
let pipeline = Message.pipeline
-
(* Routing *)
- let router (r: route list): handler = Router.router r
+ let router (r : route list) : handler = Router.router r
let get = Router.get
let post = Router.post
let put = Router.put
@@ -317,22 +327,13 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Time : Mirage_time.S) (Stack : Tcpip
let session_label = Session.session_label
let session_expires_at = Session.session_expires_at
-
-
(* Flash messages *)
let flash_messages = Flash.flash_messages
let flash = Flash.flash
let put_flash = Flash.put_flash
-
-
-
- let log =
- Log.convenience_log
-
-
+ let log = Log.convenience_log
let now () = Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ()))
-
let form = form ~now
let multipart = multipart ~now
let csrf_token = csrf_token ~now
@@ -344,35 +345,23 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Time : Mirage_time.S) (Stack : Tcpip
let form_tag ?method_ ?target ?enctype ?csrf_token ~action request =
Tag.form_tag ~now ?method_ ?target ?enctype ?csrf_token ~action request
-
-
(* Errors *)
type error = Catch.error = {
- condition : [
- | `Response of Message.response
- | `String of string
- | `Exn of exn
- ];
- layer : [
- | `App
- | `HTTP
- | `HTTP2
- | `TLS
- | `WebSocket
- ];
- caused_by : [
- | `Server
- | `Client
- ];
+ condition :
+ [`Response of Message.response | `String of string | `Exn of exn];
+ layer : [`App | `HTTP | `HTTP2 | `TLS | `WebSocket];
+ caused_by : [`Server | `Client];
request : Message.request option;
response : Message.response option;
client : string option;
severity : Log.log_level;
will_send_response : bool;
}
+
type error_handler = Catch.error_handler
-(* let error_template = Error_handler.customize *)
+
+ (* let error_template = Error_handler.customize *)
let catch = Catch.catch
(* Cryptography *)
@@ -385,6 +374,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Time : Mirage_time.S) (Stack : Tcpip
(* Custom fields *)
type 'a field = 'a Message.field
+
let new_field = Message.new_field
let field = Message.field
let set_field = Message.set_field
@@ -393,70 +383,88 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Time : Mirage_time.S) (Stack : Tcpip
let alpn =
let module R = (val Mimic.repr tls_protocol) in
- let alpn (_, flow) = match TLS.epoch flow with
+ let alpn (_, flow) =
+ match TLS.epoch flow with
| Ok { Tls.Core.alpn_protocol; _ } -> alpn_protocol
- | Error _ -> None in
+ | Error _ -> None
+ in
let peer ((ipaddr, port), _) = Fmt.str "%a:%d" Ipaddr.pp ipaddr port in
let injection (_, flow) = R.T flow in
- { Alpn.alpn; peer; injection; }
+ { Alpn.alpn; peer; injection }
- let built_in_middleware prefix error_handler=
- Message.pipeline [
- Dream__server.Catch.catch (Error_handler.app error_handler);
- Dream__server.Site_prefix.with_site_prefix prefix;
- ]
+ let built_in_middleware prefix error_handler =
+ Message.pipeline
+ [
+ Dream__server.Catch.catch (Error_handler.app error_handler);
+ Dream__server.Site_prefix.with_site_prefix prefix;
+ ]
let localhost_certificate =
- let crts = Rresult.R.failwith_error_msg
- (X509.Certificate.decode_pem_multiple (Cstruct.of_string Dream__certificate.localhost_certificate)) in
- let key = Rresult.R.failwith_error_msg
- (X509.Private_key.decode_pem (Cstruct.of_string Dream__certificate.localhost_certificate_key)) in
+ let crts =
+ Rresult.R.failwith_error_msg
+ (X509.Certificate.decode_pem_multiple
+ (Cstruct.of_string Dream__certificate.localhost_certificate))
+ in
+ let key =
+ Rresult.R.failwith_error_msg
+ (X509.Private_key.decode_pem
+ (Cstruct.of_string Dream__certificate.localhost_certificate_key))
+ in
`Single (crts, key)
- let https ?stop ~port ?(prefix= "") stack
- ?(cfg= Tls.Config.server ~certificates:localhost_certificate ())
- ?error_handler:(user's_error_handler : error_handler = Error_handler.default) (user's_dream_handler : Message.handler) =
- initialize ~setup_outputs:ignore ;
+ let https ?stop ~port ?(prefix = "") stack
+ ?(cfg = Tls.Config.server ~certificates:localhost_certificate ())
+ ?error_handler:(user's_error_handler : error_handler =
+ Error_handler.default) (user's_dream_handler : Message.handler) =
+ initialize ~setup_outputs:ignore;
let connect flow =
let edn = TCP.dst flow in
- TLS.server_of_flow cfg flow
- >>= function
+ TLS.server_of_flow cfg flow >>= function
| Ok flow -> Lwt.return_ok (edn, flow)
| Error err ->
TCP.close flow >>= fun () ->
Lwt.return (R.error_msgf "%a" TLS.pp_write_error err)
in
let user's_dream_handler =
- built_in_middleware prefix user's_error_handler user's_dream_handler in
+ built_in_middleware prefix user's_error_handler user's_dream_handler
+ in
let handler = handler user's_error_handler user's_dream_handler in
let service = Alpn.service alpn handler connect accept close in
init ~port stack >>= fun t ->
- let `Initialized th = serve ?stop service t in th
+ let (`Initialized th) = serve ?stop service t in
+ th
let alpn protocol =
- let protocol = match protocol with
+ let protocol =
+ match protocol with
| `H2 -> "h2"
- | `HTTP_1_1 -> "http/1.1" in
+ | `HTTP_1_1 -> "http/1.1"
+ in
let module R = (val Mimic.repr tcp_protocol) in
let alpn _ = Some protocol in
let peer ((ipaddr, port), _) = Fmt.str "%a:%d" Ipaddr.pp ipaddr port in
let injection (_, flow) = R.T flow in
- { Alpn.alpn; peer; injection; }
-
- let http ?stop ~port ?(prefix= "") ?(protocol= `HTTP_1_1) stack
- ?error_handler:(user's_error_handler= Error_handler.default)
- user's_dream_handler =
- initialize ~setup_outputs:ignore ;
- let accept t = accept t >>? fun flow ->
+ { Alpn.alpn; peer; injection }
+
+ let http ?stop ~port ?(prefix = "") ?(protocol = `HTTP_1_1) stack
+ ?error_handler:(user's_error_handler = Error_handler.default)
+ user's_dream_handler =
+ initialize ~setup_outputs:ignore;
+ let accept t =
+ accept t >>? fun flow ->
let edn = TCP.dst flow in
- Lwt.return_ok (edn, flow) in
+ Lwt.return_ok (edn, flow)
+ in
let user's_dream_handler =
- built_in_middleware prefix user's_error_handler user's_dream_handler in
+ built_in_middleware prefix user's_error_handler user's_dream_handler
+ in
let handler = handler user's_error_handler user's_dream_handler in
- let service = Alpn.service (alpn protocol) handler Lwt.return_ok accept close in
+ let service =
+ Alpn.service (alpn protocol) handler Lwt.return_ok accept close
+ in
init ~port stack >>= fun t ->
- let `Initialized th = serve ?stop service t in th
-
+ let (`Initialized th) = serve ?stop service t in
+ th
let validate_path request =
let path = Dream__server.Router.path request in
@@ -465,19 +473,20 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Time : Mirage_time.S) (Stack : Tcpip
let has_backslash component = String.contains component '\\' in
let has_slash = List.exists has_slash path in
let has_backslash = List.exists has_backslash path in
- let has_dot = List.exists ((=) Filename.current_dir_name) path in
- let has_dotdot = List.exists ((=) Filename.parent_dir_name) path in
- let has_empty = List.exists ((=) "") path in
+ let has_dot = List.exists (( = ) Filename.current_dir_name) path in
+ let has_dotdot = List.exists (( = ) Filename.parent_dir_name) path in
+ let has_empty = List.exists (( = ) "") path in
let is_empty = path = [] in
- if has_slash ||
- has_backslash ||
- has_dot ||
- has_dotdot ||
- has_empty ||
- is_empty then
+ if
+ has_slash
+ || has_backslash
+ || has_dot
+ || has_dotdot
+ || has_empty
+ || is_empty
+ then
None
-
else
let path = String.concat Filename.dir_sep path in
if Filename.is_relative path then
@@ -493,35 +502,28 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Time : Mirage_time.S) (Stack : Tcpip
| "text/html" -> Formats.text_html
| content_type -> content_type
in
- ["Content-Type", content_type]
-
- let static ~loader local_root = fun request ->
+ [("Content-Type", content_type)]
+ let static ~loader local_root request =
if not @@ Method.methods_equal (Message.method_ request) `GET then
- Message.response ~status:`Not_Found Stream.empty Stream.null
- |> Lwt.return
-
+ 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
- if not (Message.has_header response "Content-Type") then begin
- match Message.status response with
- | `OK
- | `Non_Authoritative_Information
- | `No_Content
- | `Reset_Content
- | `Partial_Content ->
- Message.add_header response "Content-Type" (Magic_mime.lookup path)
- | _ ->
- ()
- end;
+ (if not (Message.has_header response "Content-Type") then
+ match Message.status response with
+ | `OK
+ | `Non_Authoritative_Information
+ | `No_Content
+ | `Reset_Content
+ | `Partial_Content ->
+ Message.add_header response "Content-Type" (Magic_mime.lookup path)
+ | _ -> ());
Lwt.return response
-
end
include Message
File "src/dream.ml", line 1, characters 0-0:
diff --git a/_build/default/src/dream.ml b/_build/default/src/.formatted/dream.ml
index c8db1f9..6295527 100644
--- a/_build/default/src/dream.ml
+++ b/_build/default/src/.formatted/dream.ml
@@ -3,8 +3,6 @@
Copyright 2021 Anton Bachin *)
-
-
module Catch = Dream__server.Catch
module Cipher = Dream__cipher.Cipher
module Cookie = Dream__server.Cookie
@@ -32,40 +30,28 @@ module Stream = Dream_pure.Stream
module Tag = Dream__server.Tag
module Upload = Dream__server.Upload
-
-
(* Initialize clock handling and random number generator. These are
platform-specific, differing between Unix and Mirage. This is the Unix
initialization. *)
-module Log =
-struct
+module Log = struct
include Dream__server.Log
include Dream__server.Log.Make (Ptime_clock)
end
-let default_log =
- Log.sub_log (Logs.Src.name Logs.default)
-
-let () =
- Log.initialize ~setup_outputs:Fmt_tty.setup_std_outputs
-
-let now () =
- Ptime.to_float_s (Ptime.v (Ptime_clock.now_d_ps ()))
+let default_log = Log.sub_log (Logs.Src.name Logs.default)
+let () = Log.initialize ~setup_outputs:Fmt_tty.setup_std_outputs
+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))
+ Random.initialize (fun () ->
+ Mirage_crypto_rng_lwt.initialize (module Mirage_crypto_rng.Fortuna))
-module Session =
-struct
+module Session = struct
include Dream__server.Session
include Dream__server.Session.Make (Ptime_clock)
end
-
-
(* Types *)
type request = Message.request
@@ -73,26 +59,19 @@ type response = Message.response
type handler = Message.handler
type middleware = Message.middleware
type route = Router.route
-
type 'a message = 'a Message.message
type client = Message.client
type server = Message.server
type 'a promise = 'a Message.promise
-
-
(* Methods *)
include Method
-
-
(* Status codes *)
include Status
-
-
(* Requests *)
let client = Helpers.client
@@ -107,8 +86,6 @@ let query = Query.query
let queries = Query.queries
let all_queries = Query.all_queries
-
-
(* Responses *)
let response = Helpers.response_with_body
@@ -120,8 +97,6 @@ let empty = Helpers.empty
let status = Message.status
let set_status = Message.set_status
-
-
(* Headers *)
let header = Message.header
@@ -132,8 +107,6 @@ let add_header = Message.add_header
let drop_header = Message.drop_header
let set_header = Message.set_header
-
-
(* Cookies *)
let set_cookie = Cookie.set_cookie
@@ -141,25 +114,24 @@ let drop_cookie = Cookie.drop_cookie
let cookie = Cookie.cookie
let all_cookies = Cookie.all_cookies
-
-
(* Bodies *)
let body = Message.body
let set_body = Message.set_body
-
-
(* Streams *)
type stream = Stream.stream
+
let body_stream = Message.server_stream
let stream = Helpers.stream
let read = Message.read
let write = Message.write
let flush = Message.flush
let close = Message.close
+
type buffer = Stream.buffer
+
let client_stream = Message.client_stream
let server_stream = Message.server_stream
let set_client_stream = Message.set_client_stream
@@ -172,42 +144,49 @@ let pong_stream = Stream.pong
let close_stream = Stream.close
let abort_stream = Stream.abort
-
-
(* WebSockets *)
type websocket = stream * stream
+
let websocket = Helpers.websocket
-type text_or_binary = [ `Text | `Binary ]
-type end_of_message = [ `End_of_message | `Continues ]
+
+type text_or_binary =
+ [ `Text
+ | `Binary ]
+
+type end_of_message =
+ [ `End_of_message
+ | `Continues ]
+
let send = Helpers.send
let receive = Helpers.receive
let receive_fragment = Helpers.receive_fragment
let close_websocket = Message.close_websocket
-
-
(* JSON *)
let origin_referrer_check = Origin_referrer_check.origin_referrer_check
-
-
(* Forms *)
type 'a form_result = 'a Form.form_result
+
let form = Form.form ~now
+
type multipart_form = Upload.multipart_form
+
let multipart = Upload.multipart ~now
+
type part = Upload.part
+
let upload = Upload.upload
let upload_part = Upload.upload_part
+
type csrf_result = Csrf.csrf_result
+
let csrf_token = Csrf.csrf_token ~now
let verify_csrf_token = Csrf.verify_csrf_token ~now
-
-
(* Templates *)
let form_tag ?method_ ?target ?enctype ?csrf_token ~action request =
@@ -215,14 +194,11 @@ let form_tag ?method_ ?target ?enctype ?csrf_token ~action request =
let csrf_tag = Tag.csrf_tag ~now
-
(* Middleware *)
let no_middleware = Message.no_middleware
let pipeline = Message.pipeline
-
-
(* Routing *)
let router = Router.router
@@ -241,16 +217,12 @@ let param = Router.param
let scope = Router.scope
let no_route = Router.no_route
-
-
(* Static files *)
let static = Static.static
let from_filesystem = Static.from_filesystem
let mime_lookup = Static.mime_lookup
-
-
(* Sessions *)
(* TODO Internalize argument order and name changes. *)
@@ -268,8 +240,6 @@ let session_id = Session.session_id
let session_label = Session.session_label
let session_expires_at = Session.session_expires_at
-
-
(* Flash messages *)
(* TODO Internalize argument order and name changes. *)
@@ -278,90 +248,69 @@ let flash_messages = Flash.flash
let put_flash = Flash.put_flash
let add_flash_message = Flash.put_flash
-
-
(* GraphQL *)
let graphql = Graphql.graphql
let graphiql = Graphql.graphiql
-
-
(* SQL *)
let sql_pool = Sql.sql_pool
let sql = Sql.sql
-
-
(* Logging *)
let logger = Log.logger
let log = Log.convenience_log
+
type ('a, 'b) conditional_log = ('a, 'b) Log.conditional_log
type log_level = Log.log_level
+
let error = default_log.error
let warning = default_log.warning
let info = default_log.info
let debug = default_log.debug
+
type sub_log = Log.sub_log = {
error : 'a. ('a, unit) conditional_log;
warning : 'a. ('a, unit) conditional_log;
info : 'a. ('a, unit) conditional_log;
debug : 'a. ('a, unit) conditional_log;
}
+
let sub_log = Log.sub_log
let initialize_log = Log.initialize_log
let set_log_level = Log.set_log_level
-
-
(* Errors *)
type error = Catch.error = {
- condition : [
- | `Response of Message.response
- | `String of string
- | `Exn of exn
- ];
- layer : [
- | `App
- | `HTTP
- | `HTTP2
- | `TLS
- | `WebSocket
- ];
- caused_by : [
- | `Server
- | `Client
- ];
+ condition : [`Response of Message.response | `String of string | `Exn of exn];
+ layer : [`App | `HTTP | `HTTP2 | `TLS | `WebSocket];
+ caused_by : [`Server | `Client];
request : Message.request option;
response : Message.response option;
client : string option;
severity : Log.log_level;
will_send_response : bool;
}
+
type error_handler = Catch.error_handler
+
let error_template = Error_handler.customize
let debug_error_handler = Error_handler.debug_error_handler
let catch = Catch.catch
-
-
(* Servers *)
let run = Http.run
let serve = Http.serve
let with_site_prefix = Site_prefix.with_site_prefix
-
-
(* Web formats *)
include Formats
-
-
(* Cryptography *)
let set_secret = Cipher.set_secret
@@ -369,17 +318,14 @@ let random = Random.random
let encrypt = Cipher.encrypt
let decrypt = Cipher.decrypt
-
-
(* Custom fields *)
type 'a field = 'a Message.field
+
let new_field = Message.new_field
let field = Message.field
let set_field = Message.set_field
-
-
(* Testing. *)
let request = Helpers.request_with_body
@@ -387,18 +333,13 @@ let request = Helpers.request_with_body
(* TODO Restore the ability to test with a prefix and re-enable the
corresponding tests. *)
let test ?(prefix = "") handler request =
- let app =
- Site_prefix.with_site_prefix prefix
- @@ handler
- in
+ let app = Site_prefix.with_site_prefix prefix @@ handler in
Lwt_main.run (app request)
let sort_headers = Message.sort_headers
let echo = Echo.echo
-
-
(* Deprecated helpers. *)
let with_client client message =
@@ -421,8 +362,7 @@ let with_body body message =
Message.set_body message body;
message
-let with_stream message =
- message
+let with_stream message = message
let write_buffer ?(offset = 0) ?length message chunk =
let length =
@@ -434,6 +374,7 @@ let write_buffer ?(offset = 0) ?length message chunk =
write (Message.server_stream message) string
type 'a local = 'a Message.field
+
let new_local = Message.new_field
let local = Message.field
@@ -441,8 +382,5 @@ let with_local key value message =
Message.set_field message key value;
message
-let first message =
- message
-
-let last message =
- message
+let first message = message
+let last message = message
File "test/unit/headers.ml", line 1, characters 0-0:
diff --git a/_build/default/test/unit/headers.ml b/_build/default/test/unit/.formatted/headers.ml
index 03988eb..691ab4d 100644
--- a/_build/default/test/unit/headers.ml
+++ b/_build/default/test/unit/.formatted/headers.ml
@@ -3,115 +3,104 @@
Copyright 2021 Anton Bachin *)
-
-
-let (-:) name f = Alcotest.test_case name `Quick f
-
-
-
-let tests = "headers", [
-
- "header" -: begin fun () ->
- let request = Dream.request ~headers:["A", "b"; "C", "d"] "" in
- Dream.header request "C"
- |> Alcotest.(check (option string)) "header" (Some "d")
- end;
-
- "header none" -: begin fun () ->
- let request = Dream.request ~headers:["A", "b"; "C", "d"] "" in
- Dream.header request "E"
- |> Alcotest.(check (option string)) "header" None
- end;
-
- "headers" -: begin fun () ->
- let request = Dream.request ~headers:["A", "b"; "C", "d"; "C", "e"] "" in
- Dream.headers request "C"
- |> Alcotest.(check (list string)) "headers" ["d"; "e"]
- end;
-
- "headers empty" -: begin fun () ->
- let request = Dream.request ~headers:["A", "b"; "C", "d"; "C", "e"] "" in
- Dream.headers request "F"
- |> Alcotest.(check (list string)) "headers" []
- end;
-
- "has_header" -: begin fun () ->
- let request = Dream.request ~headers:["A", "b"; "C", "d"] "" in
- Dream.has_header request "C"
- |> Alcotest.(check bool) "has_header" true
- end;
-
- "has_header false" -: begin fun () ->
- let request = Dream.request ~headers:["A", "b"; "C", "d"] "" in
- Dream.has_header request "E"
- |> Alcotest.(check bool) "has_header" false
- end;
-
- "all_headers" -: begin fun () ->
- let request = Dream.request ~headers:["A", "b"; "C", "d"; "C", "e"] "" in
- Dream.all_headers request
- |> Dream.sort_headers
- |> Alcotest.(check (list (pair string string))) "all_headers"
- ["A", "b"; "C", "d"; "C", "e"]
- end;
-
- "add_header" -: begin fun () ->
- let request = Dream.request ~headers:["A", "b"] "" in
- Dream.add_header request "C" "d";
- Dream.all_headers request
- |> Dream.sort_headers
- |> Alcotest.(check (list (pair string string))) "all_headers"
- ["A", "b"; "C", "d"]
- end;
-
- "add_header duplicate" -: begin fun () ->
- let request = Dream.request ~headers:["A", "b"; "C", "d"] "" in
- Dream.add_header request "A" "e";
- Dream.all_headers request
- |> Dream.sort_headers
- |> Alcotest.(check (list (pair string string))) "all_headers"
- ["A", "b"; "A", "e"; "C", "d"]
- end;
-
- "add_header compares less" -: begin fun () ->
- let request = Dream.request ~headers:["A", "b"; "C", "d"] "" in
- Dream.add_header request "A" "a";
- Dream.all_headers request
- |> Dream.sort_headers
- |> Alcotest.(check (list (pair string string))) "all_headers"
- ["A", "b"; "A", "a"; "C", "d"]
- end;
-
- "drop_header" -: begin fun () ->
- let request = Dream.request ~headers:["A", "b"; "C", "d"; "C", "e"] "" in
- Dream.drop_header request "C";
- Dream.all_headers request
- |> Alcotest.(check (list (pair string string))) "all_headers" ["A", "b"]
- end;
-
- "drop_header absent" -: begin fun () ->
- let request = Dream.request ~headers:["C", "d"] "" in
- Dream.drop_header request "A";
- Dream.all_headers request
- |> Alcotest.(check (list (pair string string))) "all_headers" ["C", "d"]
- end;
-
- "with_header" -: begin fun () ->
- let request = Dream.request ~headers:["C", "d"] "" in
- Dream.set_header request "A" "b";
- Dream.all_headers request
- |> Dream.sort_headers
- |> Alcotest.(check (list (pair string string))) "all_headers"
- ["A", "b"; "C", "d"]
- end;
-
- "with_header present" -: begin fun () ->
- let request = Dream.request ~headers:["A", "b"; "A", "c"; "D", "e"] "" in
- Dream.set_header request "A" "f";
- Dream.all_headers request
- |> Dream.sort_headers
- |> Alcotest.(check (list (pair string string))) "all_headers"
- ["A", "f"; "D", "e"]
- end;
-
-]
+let ( -: ) name f = Alcotest.test_case name `Quick f
+
+let tests =
+ ( "headers",
+ [
+ ( "header" -: fun () ->
+ let request = Dream.request ~headers:[("A", "b"); ("C", "d")] "" in
+ Dream.header request "C"
+ |> Alcotest.(check (option string)) "header" (Some "d") );
+ ( "header none" -: fun () ->
+ let request = Dream.request ~headers:[("A", "b"); ("C", "d")] "" in
+ Dream.header request "E"
+ |> Alcotest.(check (option string)) "header" None );
+ ( "headers" -: fun () ->
+ let request =
+ Dream.request ~headers:[("A", "b"); ("C", "d"); ("C", "e")] ""
+ in
+ Dream.headers request "C"
+ |> Alcotest.(check (list string)) "headers" ["d"; "e"] );
+ ( "headers empty" -: fun () ->
+ let request =
+ Dream.request ~headers:[("A", "b"); ("C", "d"); ("C", "e")] ""
+ in
+ Dream.headers request "F" |> Alcotest.(check (list string)) "headers" []
+ );
+ ( "has_header" -: fun () ->
+ let request = Dream.request ~headers:[("A", "b"); ("C", "d")] "" in
+ Dream.has_header request "C" |> Alcotest.(check bool) "has_header" true
+ );
+ ( "has_header false" -: fun () ->
+ let request = Dream.request ~headers:[("A", "b"); ("C", "d")] "" in
+ Dream.has_header request "E" |> Alcotest.(check bool) "has_header" false
+ );
+ ( "all_headers" -: fun () ->
+ let request =
+ Dream.request ~headers:[("A", "b"); ("C", "d"); ("C", "e")] ""
+ in
+ Dream.all_headers request
+ |> Dream.sort_headers
+ |> Alcotest.(check (list (pair string string)))
+ "all_headers"
+ [("A", "b"); ("C", "d"); ("C", "e")] );
+ ( "add_header" -: fun () ->
+ let request = Dream.request ~headers:[("A", "b")] "" in
+ Dream.add_header request "C" "d";
+ Dream.all_headers request
+ |> Dream.sort_headers
+ |> Alcotest.(check (list (pair string string)))
+ "all_headers"
+ [("A", "b"); ("C", "d")] );
+ ( "add_header duplicate" -: fun () ->
+ let request = Dream.request ~headers:[("A", "b"); ("C", "d")] "" in
+ Dream.add_header request "A" "e";
+ Dream.all_headers request
+ |> Dream.sort_headers
+ |> Alcotest.(check (list (pair string string)))
+ "all_headers"
+ [("A", "b"); ("A", "e"); ("C", "d")] );
+ ( "add_header compares less" -: fun () ->
+ let request = Dream.request ~headers:[("A", "b"); ("C", "d")] "" in
+ Dream.add_header request "A" "a";
+ Dream.all_headers request
+ |> Dream.sort_headers
+ |> Alcotest.(check (list (pair string string)))
+ "all_headers"
+ [("A", "b"); ("A", "a"); ("C", "d")] );
+ ( "drop_header" -: fun () ->
+ let request =
+ Dream.request ~headers:[("A", "b"); ("C", "d"); ("C", "e")] ""
+ in
+ Dream.drop_header request "C";
+ Dream.all_headers request
+ |> Alcotest.(check (list (pair string string)))
+ "all_headers"
+ [("A", "b")] );
+ ( "drop_header absent" -: fun () ->
+ let request = Dream.request ~headers:[("C", "d")] "" in
+ Dream.drop_header request "A";
+ Dream.all_headers request
+ |> Alcotest.(check (list (pair string string)))
+ "all_headers"
+ [("C", "d")] );
+ ( "with_header" -: fun () ->
+ let request = Dream.request ~headers:[("C", "d")] "" in
+ Dream.set_header request "A" "b";
+ Dream.all_headers request
+ |> Dream.sort_headers
+ |> Alcotest.(check (list (pair string string)))
+ "all_headers"
+ [("A", "b"); ("C", "d")] );
+ ( "with_header present" -: fun () ->
+ let request =
+ Dream.request ~headers:[("A", "b"); ("A", "c"); ("D", "e")] ""
+ in
+ Dream.set_header request "A" "f";
+ Dream.all_headers request
+ |> Dream.sort_headers
+ |> Alcotest.(check (list (pair string string)))
+ "all_headers"
+ [("A", "f"); ("D", "e")] );
+ ] )
File "test/unit/unit.ml", line 1, characters 0-0:
diff --git a/_build/default/test/unit/unit.ml b/_build/default/test/unit/.formatted/unit.ml
index dfba2ab..f3d4faa 100644
--- a/_build/default/test/unit/unit.ml
+++ b/_build/default/test/unit/.formatted/unit.ml
@@ -3,10 +3,4 @@
Copyright 2021 Anton Bachin *)
-
-
-let () =
- Alcotest.run "Dream" [
- Request.tests;
- Headers.tests;
- ]
+let () = Alcotest.run "Dream" [Request.tests; Headers.tests]
File "test/expect/server/initialize.ml", line 1, characters 0-0:
diff --git a/_build/default/test/expect/server/initialize.ml b/_build/default/test/expect/server/.formatted/initialize.ml
index 3900781..bad6adc 100644
--- a/_build/default/test/expect/server/initialize.ml
+++ b/_build/default/test/expect/server/.formatted/initialize.ml
@@ -3,7 +3,4 @@
Copyright 2021 Anton Bachin *)
-
-
-let require : unit =
- Dream.initialize_log ~enable:false ()
+let require : unit = Dream.initialize_log ~enable:false ()
File "test/expect/server/cipher/cipher.ml", line 1, characters 0-0:
diff --git a/_build/default/test/expect/server/cipher/cipher.ml b/_build/default/test/expect/server/cipher/.formatted/cipher.ml
index 2d59d6b..48e7fe7 100644
--- a/_build/default/test/expect/server/cipher/cipher.ml
+++ b/_build/default/test/expect/server/cipher/.formatted/cipher.ml
@@ -3,23 +3,14 @@
Copyright 2021 Anton Bachin *)
-
-
-let secret_1 =
- "abc"
-
-let secret_2 =
- "def"
-
-let nonce_1 =
- "abcdefghijkl"
-
-let nonce_2 =
- "opqrstuvwxyz"
+let secret_1 = "abc"
+let secret_2 = "def"
+let nonce_1 = "abcdefghijkl"
+let nonce_2 = "opqrstuvwxyz"
let encrypt secret nonce plaintext associated_data =
- Dream__cipher.Cipher.AEAD_AES_256_GCM.test_encrypt
- ~associated_data ~secret ~nonce plaintext
+ Dream__cipher.Cipher.AEAD_AES_256_GCM.test_encrypt ~associated_data ~secret
+ ~nonce plaintext
|> Dream.to_base64url
|> print_endline
@@ -40,7 +31,8 @@ let%expect_test _ =
encrypt secret_2 nonce_1 "fon" "bar";
encrypt secret_2 nonce_2 "foo" "bar";
encrypt secret_2 nonce_2 "fon" "bar";
- [%expect {|
+ [%expect
+ {|
AGFiY2RlZmdoaWprbAzPcSEY4l7tSiDwIkk8ZfrFQQk
AGFiY2RlZmdoaWprbAzPcCTJ-mJdrOKmcXtgqKJjGrI
AG9wcXJzdHV2d3h5eqAJLHQ4dESlArPNBNiZza-USfI
@@ -58,8 +50,6 @@ let%expect_test _ =
AG9wcXJzdHV2d3h5etiGF4BcHGzW5HQAYUATKQ5cqtk
AG9wcXJzdHV2d3h5etiGFmE7Cep91IW7jS5u345BrY0 |}]
-
-
let encrypt secret plaintext =
Dream__cipher.Cipher.AEAD_AES_256_GCM.encrypt ~secret plaintext
|> Dream.to_base64url
@@ -68,19 +58,18 @@ let%expect_test _ =
Printf.printf "%B\n%!" (encrypt secret_1 "foo" = encrypt secret_1 "foo");
[%expect {| false |}]
-
-
let decrypt secret associated_data ciphertext =
let result =
- Dream__cipher.Cipher.AEAD_AES_256_GCM.decrypt
- ~associated_data ~secret ciphertext in
+ Dream__cipher.Cipher.AEAD_AES_256_GCM.decrypt ~associated_data ~secret
+ ciphertext
+ in
match result with
| None -> print_endline "None"
| Some plaintext -> Printf.printf "%S\n" plaintext
let encrypt secret nonce plaintext associated_data =
- Dream__cipher.Cipher.AEAD_AES_256_GCM.test_encrypt
- ~associated_data ~secret ~nonce plaintext
+ Dream__cipher.Cipher.AEAD_AES_256_GCM.test_encrypt ~associated_data ~secret
+ ~nonce plaintext
let%expect_test _ =
decrypt secret_1 "" (encrypt secret_1 nonce_1 "foo" "");
@@ -95,7 +84,8 @@ let%expect_test _ =
decrypt secret_1 "" "ab";
decrypt secret_1 "" "\x00abcdefghijklmnopqrstuvwxyz";
decrypt secret_1 "" "\x01abcdefghijklmnopqrstuvwxyz";
- [%expect {|
+ [%expect
+ {|
"foo"
"foo"
None
File "example/6-echo/echo.ml", line 1, characters 0-0:
diff --git a/_build/default/example/6-echo/echo.ml b/_build/default/example/6-echo/.formatted/echo.ml
index 4f63612..dfefdf7 100644
--- a/_build/default/example/6-echo/echo.ml
+++ b/_build/default/example/6-echo/.formatted/echo.ml
@@ -1,12 +1,11 @@
let () =
Dream.run
@@ Dream.logger
- @@ Dream.router [
-
- Dream.post "/echo" (fun request ->
- let%lwt body = Dream.body request in
- Dream.respond
- ~headers:["Content-Type", "application/octet-stream"]
- body);
-
- ]
+ @@ Dream.router
+ [
+ Dream.post "/echo" (fun request ->
+ let%lwt body = Dream.body request in
+ Dream.respond
+ ~headers:[("Content-Type", "application/octet-stream")]
+ body);
+ ]
File "example/b-session/session.ml", line 1, characters 0-0:
diff --git a/_build/default/example/b-session/session.ml b/_build/default/example/b-session/.formatted/session.ml
index 8a0c045..97daa9b 100644
--- a/_build/default/example/b-session/session.ml
+++ b/_build/default/example/b-session/.formatted/session.ml
@@ -3,13 +3,10 @@ let () =
@@ 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.html "You weren't logged in; but now you are!"
-
- | Some username ->
- Printf.ksprintf
- Dream.html "Welcome back, %s!" (Dream.html_escape username)
+ 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.html "You weren't logged in; but now you are!"
+ | Some username ->
+ Printf.ksprintf Dream.html "Welcome back, %s!" (Dream.html_escape username)
File "example/j-stream/stream.ml", line 1, characters 0-0:
diff --git a/_build/default/example/j-stream/stream.ml b/_build/default/example/j-stream/.formatted/stream.ml
index 08a222c..1872d97 100644
--- a/_build/default/example/j-stream/stream.ml
+++ b/_build/default/example/j-stream/.formatted/stream.ml
@@ -1,23 +1,21 @@
let () =
Dream.run
@@ Dream.logger
- @@ Dream.router [
+ @@ Dream.router
+ [
+ Dream.post "/echo" (fun request ->
+ let request_stream = Dream.body_stream request in
- Dream.post "/echo" (fun request ->
- let request_stream = Dream.body_stream request in
-
- Dream.stream
- ~headers:["Content-Type", "application/octet-stream"]
- (fun response_stream ->
- let rec loop () =
- match%lwt Dream.read request_stream with
- | None ->
- Dream.close response_stream
- | Some chunk ->
- let%lwt () = Dream.write response_stream chunk in
- let%lwt () = Dream.flush response_stream in
- loop ()
- in
- loop ()));
-
- ]
+ Dream.stream
+ ~headers:[("Content-Type", "application/octet-stream")]
+ (fun response_stream ->
+ let rec loop () =
+ match%lwt Dream.read request_stream with
+ | None -> Dream.close response_stream
+ | Some chunk ->
+ let%lwt () = Dream.write response_stream chunk in
+ let%lwt () = Dream.flush response_stream in
+ loop ()
+ in
+ loop ()));
+ ]
File "example/w-graphql-subscription/graphql_subscription.ml", line 1, characters 0-0:
diff --git a/_build/default/example/w-graphql-subscription/graphql_subscription.ml b/_build/default/example/w-graphql-subscription/.formatted/graphql_subscription.ml
index b30457f..8b9cabb 100644
--- a/_build/default/example/w-graphql-subscription/graphql_subscription.ml
+++ b/_build/default/example/w-graphql-subscription/.formatted/graphql_subscription.ml
@@ -2,37 +2,38 @@ let count until =
let stream, push = Lwt_stream.create () in
let close () = push None in
- Lwt.async begin fun () ->
- let rec loop n =
- let%lwt () = Lwt_unix.sleep 0.5 in
- if n > until
- then (close (); Lwt.return_unit)
- else (push (Some n); loop (n + 1))
- in
- loop 1
- end;
+ Lwt.async (fun () ->
+ let rec loop n =
+ let%lwt () = Lwt_unix.sleep 0.5 in
+ if n > until then (
+ close ();
+ Lwt.return_unit)
+ else (
+ push (Some n);
+ loop (n + 1))
+ in
+ loop 1);
- stream, close
+ (stream, close)
let schema =
let open Graphql_lwt.Schema in
schema []
- ~subscriptions:[
- subscription_field "count"
- ~typ:(non_null int)
- ~args:Arg.[arg "until" ~typ:(non_null int)]
- ~resolve:(fun _info until ->
- Lwt.return (Ok (count until)))
- ]
+ ~subscriptions:
+ [
+ subscription_field "count" ~typ:(non_null int)
+ ~args:Arg.[arg "until" ~typ:(non_null int)]
+ ~resolve:(fun _info until -> Lwt.return (Ok (count until)));
+ ]
-let default_query =
- "subscription {\\n count(until: 3)\\n}\\n"
+let default_query = "subscription {\\n count(until: 3)\\n}\\n"
let () =
Dream.run
@@ Dream.logger
@@ Dream.origin_referrer_check
- @@ Dream.router [
- Dream.any "/graphql" (Dream.graphql Lwt.return schema);
- Dream.get "/" (Dream.graphiql ~default_query "/graphql");
- ]
+ @@ Dream.router
+ [
+ Dream.any "/graphql" (Dream.graphql Lwt.return schema);
+ Dream.get "/" (Dream.graphiql ~default_query "/graphql");
+ ]
File "example/w-live-reload/live_reload.ml", line 1, characters 0-0:
diff --git a/_build/default/example/w-live-reload/live_reload.ml b/_build/default/example/w-live-reload/.formatted/live_reload.ml
index 999c53b..4a05843 100644
--- a/_build/default/example/w-live-reload/live_reload.ml
+++ b/_build/default/example/w-live-reload/.formatted/live_reload.ml
@@ -1,4 +1,5 @@
-let live_reload_script = {js|
+let live_reload_script =
+ {js|
var socketUrl = "ws://" + location.host + "/_live-reload"
var socket = new WebSocket(socketUrl);
@@ -36,7 +37,7 @@ let inject_live_reload_script inner_handler request =
let%lwt response = inner_handler request in
match Dream.header response "Content-Type" with
- | Some "text/html; charset=utf-8" ->
+ | Some "text/html; charset=utf-8" -> (
let%lwt body = Dream.body response in
let soup =
Markup.string body
@@ -45,34 +46,28 @@ let inject_live_reload_script inner_handler request =
|> Soup.from_signals
in
- begin match Soup.Infix.(soup $? "head") with
- | None ->
- Lwt.return response
+ match Soup.Infix.(soup $? "head") with
+ | None -> Lwt.return 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
- end
-
- | _ ->
- Lwt.return response
+ Lwt.return response)
+ | _ -> Lwt.return response
let () =
Dream.run
@@ Dream.logger
@@ inject_live_reload_script
- @@ Dream.router [
-
- Dream.get "/" (fun _ ->
- Dream.random 3
- |> Dream.to_base64url
- |> 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.close_websocket socket));
-
- ]
+ @@ Dream.router
+ [
+ Dream.get "/" (fun _ ->
+ Dream.random 3
+ |> Dream.to_base64url
+ |> 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.close_websocket socket));
+ ]
File "example/w-one-binary/one_binary.ml", line 1, characters 0-0:
diff --git a/_build/default/example/w-one-binary/one_binary.ml b/_build/default/example/w-one-binary/.formatted/one_binary.ml
index 3fae42e..0a26f89 100644
--- a/_build/default/example/w-one-binary/one_binary.ml
+++ b/_build/default/example/w-one-binary/.formatted/one_binary.ml
@@ -6,6 +6,4 @@ let loader _root path _request =
let () =
Dream.run
@@ Dream.logger
- @@ Dream.router [
- Dream.get "/assets/**" (Dream.static ~loader "")
- ]
+ @@ Dream.router [Dream.get "/assets/**" (Dream.static ~loader "")]
File "example/w-stress-response/stress_response.ml", line 1, characters 0-0:
diff --git a/_build/default/example/w-stress-response/stress_response.ml b/_build/default/example/w-stress-response/.formatted/stress_response.ml
index dcfefed..231863f 100644
--- a/_build/default/example/w-stress-response/stress_response.ml
+++ b/_build/default/example/w-stress-response/.formatted/stress_response.ml
@@ -1,8 +1,6 @@
let show_heap_size () =
- Gc.((quick_stat ()).heap_words) * 8
- |> float_of_int
- |> fun bytes -> bytes /. 1024. /. 1024.
- |> Dream.log "Heap size: %.0f MB"
+ Gc.((quick_stat ()).heap_words) * 8 |> float_of_int |> fun bytes ->
+ bytes /. 1024. /. 1024. |> Dream.log "Heap size: %.0f MB"
let stress ?(megabytes = 1024) ?(chunk = 64) stream =
let limit = megabytes * 1024 * 1024 in
@@ -26,8 +24,7 @@ let stress ?(megabytes = 1024) ?(chunk = 64) stream =
in
let%lwt elapsed = loop 0 in
- Dream.log "%.0f MB/s over %.1f s"
- ((float_of_int megabytes) /. elapsed) elapsed;
+ Dream.log "%.0f MB/s over %.1f s" (float_of_int megabytes /. elapsed) elapsed;
show_heap_size ();
Lwt.return_unit
@@ -40,13 +37,11 @@ let () =
Dream.run
@@ Dream.logger
- @@ Dream.router [
-
- Dream.get "/" (fun request ->
- Dream.stream
- ~headers:["Content-Type", "application/octet-stream"]
- (stress
- ?megabytes:(query_int request "mb")
- ?chunk:(query_int request "chunk")));
-
- ]
+ @@ Dream.router
+ [
+ Dream.get "/" (fun request ->
+ Dream.stream
+ ~headers:[("Content-Type", "application/octet-stream")]
+ (stress ?megabytes:(query_int request "mb")
+ ?chunk:(query_int request "chunk")));
+ ]
File "example/1-hello/hello.ml", line 1, characters 0-0:
diff --git a/_build/default/example/1-hello/hello.ml b/_build/default/example/1-hello/.formatted/hello.ml
index 5411c9e..424075c 100644
--- a/_build/default/example/1-hello/hello.ml
+++ b/_build/default/example/1-hello/.formatted/hello.ml
@@ -1,3 +1 @@
-let () =
- Dream.run (fun _ ->
- Dream.html "Good morning, world!")
+let () = Dream.run (fun _ -> Dream.html "Good morning, world!")
File "example/2-middleware/middleware.ml", line 1, characters 0-0:
diff --git a/_build/default/example/2-middleware/middleware.ml b/_build/default/example/2-middleware/.formatted/middleware.ml
index a35eb21..8e04071 100644
--- a/_build/default/example/2-middleware/middleware.ml
+++ b/_build/default/example/2-middleware/.formatted/middleware.ml
@@ -1,4 +1 @@
-let () =
- Dream.run
- @@ Dream.logger
- @@ fun _ -> Dream.html "Good morning, world!"
+let () = Dream.run @@ Dream.logger @@ fun _ -> Dream.html "Good morning, world!"
File "example/3-router/router.ml", line 1, characters 0-0:
diff --git a/_build/default/example/3-router/router.ml b/_build/default/example/3-router/.formatted/router.ml
index fb1a9da..59e7311 100644
--- a/_build/default/example/3-router/router.ml
+++ b/_build/default/example/3-router/.formatted/router.ml
@@ -1,14 +1,9 @@
let () =
Dream.run
@@ Dream.logger
- @@ Dream.router [
-
- Dream.get "/"
- (fun _ ->
- Dream.html "Good morning, world!");
-
- Dream.get "/echo/:word"
- (fun request ->
- Dream.html (Dream.param request "word"));
-
- ]
+ @@ Dream.router
+ [
+ Dream.get "/" (fun _ -> Dream.html "Good morning, world!");
+ Dream.get "/echo/:word" (fun request ->
+ Dream.html (Dream.param request "word"));
+ ]
File "example/4-counter/counter.ml", line 1, characters 0-0:
diff --git a/_build/default/example/4-counter/counter.ml b/_build/default/example/4-counter/.formatted/counter.ml
index 2a1d10a..0b4b603 100644
--- a/_build/default/example/4-counter/counter.ml
+++ b/_build/default/example/4-counter/.formatted/counter.ml
@@ -8,7 +8,8 @@ let () =
Dream.run
@@ Dream.logger
@@ count_requests
- @@ Dream.router [
- Dream.get "/" (fun _ ->
- Dream.html (Printf.sprintf "Saw %i request(s)!" !count));
- ]
+ @@ Dream.router
+ [
+ Dream.get "/" (fun _ ->
+ Dream.html (Printf.sprintf "Saw %i request(s)!" !count));
+ ]
File "example/8-debug/debug.ml", line 1, characters 0-0:
diff --git a/_build/default/example/8-debug/debug.ml b/_build/default/example/8-debug/.formatted/debug.ml
index f7548a3..56f82b2 100644
--- a/_build/default/example/8-debug/debug.ml
+++ b/_build/default/example/8-debug/.formatted/debug.ml
@@ -1,14 +1,8 @@
let () =
Dream.run ~error_handler:Dream.debug_error_handler
@@ Dream.logger
- @@ Dream.router [
-
- Dream.get "/bad"
- (fun _ ->
- Dream.empty `Bad_Request);
-
- Dream.get "/fail"
- (fun _ ->
- raise (Failure "The Web app failed!"));
-
- ]
+ @@ Dream.router
+ [
+ Dream.get "/bad" (fun _ -> Dream.empty `Bad_Request);
+ Dream.get "/fail" (fun _ -> raise (Failure "The Web app failed!"));
+ ]
File "example/c-cookie/cookie.ml", line 1, characters 0-0:
diff --git a/_build/default/example/c-cookie/cookie.ml b/_build/default/example/c-cookie/.formatted/cookie.ml
index e145e5e..4f13a3e 100644
--- a/_build/default/example/c-cookie/cookie.ml
+++ b/_build/default/example/c-cookie/.formatted/cookie.ml
@@ -3,14 +3,12 @@ let () =
@@ Dream.set_secret "foo"
@@ Dream.logger
@@ fun request ->
-
- match Dream.cookie request "ui.language" with
- | Some value ->
- Printf.ksprintf
- Dream.html "Your preferred language is %s!" (Dream.html_escape value)
-
- | None ->
- 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
+ match Dream.cookie request "ui.language" with
+ | Some value ->
+ Printf.ksprintf Dream.html "Your preferred language is %s!"
+ (Dream.html_escape value)
+ | None ->
+ 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
File "example/f-static/static.ml", line 1, characters 0-0:
diff --git a/_build/default/example/f-static/static.ml b/_build/default/example/f-static/.formatted/static.ml
index daf1c77..cb11279 100644
--- a/_build/default/example/f-static/static.ml
+++ b/_build/default/example/f-static/.formatted/static.ml
@@ -1,6 +1,4 @@
let () =
Dream.run
@@ Dream.logger
- @@ Dream.router [
- Dream.get "/static/**" (Dream.static ".")
- ]
+ @@ Dream.router [Dream.get "/static/**" (Dream.static ".")]
File "example/w-esy/hello.ml", line 1, characters 0-0:
diff --git a/_build/default/example/w-esy/hello.ml b/_build/default/example/w-esy/.formatted/hello.ml
index a35eb21..8e04071 100644
--- a/_build/default/example/w-esy/hello.ml
+++ b/_build/default/example/w-esy/.formatted/hello.ml
@@ -1,4 +1 @@
-let () =
- Dream.run
- @@ Dream.logger
- @@ fun _ -> Dream.html "Good morning, world!"
+let () = Dream.run @@ Dream.logger @@ fun _ -> Dream.html "Good morning, world!"
File "example/w-fswatch/hello.ml", line 1, characters 0-0:
diff --git a/_build/default/example/w-fswatch/hello.ml b/_build/default/example/w-fswatch/.formatted/hello.ml
index a35eb21..8e04071 100644
--- a/_build/default/example/w-fswatch/hello.ml
+++ b/_build/default/example/w-fswatch/.formatted/hello.ml
@@ -1,4 +1 @@
-let () =
- Dream.run
- @@ Dream.logger
- @@ fun _ -> Dream.html "Good morning, world!"
+let () = Dream.run @@ Dream.logger @@ fun _ -> Dream.html "Good morning, world!"
File "src/eml/eml.ml", line 1, characters 0-0:
diff --git a/_build/default/src/eml/eml.ml b/_build/default/src/eml/.formatted/eml.ml
index 64c714f..d0616f0 100644
--- a/_build/default/src/eml/eml.ml
+++ b/_build/default/src/eml/.formatted/eml.ml
@@ -3,31 +3,20 @@
Copyright 2021 Anton Bachin *)
-
-
(* Location handling is done by updating a reference with the location of the
last character read. This is pretty fragile, and depends on the tokenizer
never looking so far forward as to invalidate the locations that it cares
about. Locations are 0-based. *)
-module Location :
-sig
+module Location : sig
val current : unit -> int * int
val adjust : int -> unit
val reset : unit -> unit
val stream : (unit -> char option) -> char Stream.t
-end =
-struct
- let line =
- ref 0
-
- let column =
- ref 0
-
- let current () =
- !line, !column
-
- let adjust by =
- column := !column + by
+end = struct
+ let line = ref 0
+ let column = ref 0
+ let current () = (!line, !column)
+ let adjust by = column := !column + by
let reset () =
line := 0;
@@ -36,26 +25,23 @@ struct
let stream underlying =
let ended = ref false in
- Stream.from begin fun _index ->
- if !ended then
- None
- else
- match underlying () with
- | None ->
- ended := true;
+ Stream.from (fun _index ->
+ if !ended then
None
- | Some '\n' as c ->
- incr line;
- column := 0;
- c
- | c ->
- incr column;
- c
- end
+ else
+ match underlying () with
+ | None ->
+ ended := true;
+ None
+ | Some '\n' as c ->
+ incr line;
+ column := 0;
+ c
+ | c ->
+ incr column;
+ c)
end
-
-
(* We need to retain the locations of code tokens, so we can emit the proper
#line directives for good error messages from the compiler. *)
type 'a with_location = {
@@ -64,80 +50,68 @@ type 'a with_location = {
what : 'a;
}
-type code_block_token = [
- (* A block of OCaml code. These start at the beginning of the input file, and
- continue until a line that starts with '<'. They occur again whenever the
- template text ends. Template text ends on a line with less indentation than
- the first template line, or at a %% terminator. *)
- | `Code_block of string with_location
-]
-
-type options_token = [
- (* Passes template-wide options to the template code generator phase. The
- string is any options text found after %%. The int is the indentation level
- of the token beginning the template, whether %% or an implicit start. *)
- | `Options of string * int
-]
-
-type newline_token = [
- (* A newline character within template text. The tokenizer notes these for
- future passes that un-indent the template and remove lines containing only
- embedded code. *)
- | `Newline
-]
-
-type template_token = [
- (* Once the template starts, text, by default, is accumulated into these
- tokens. These strings contain no newlines. *)
- | `Text of string
-
- (* Code found within the template text, i.e. in <% ... %> and its variants.
- The variant indicates what to do with the code - but this is irrelevant at
- the token level; the tokenizer just needs to note it for the later
- transformers to process. *)
- | `Embedded of (string * string) with_location
-]
-
-type token = [
- | code_block_token
+type code_block_token =
+ [ (* A block of OCaml code. These start at the beginning of the input file, and
+ continue until a line that starts with '<'. They occur again whenever the
+ template text ends. Template text ends on a line with less indentation than
+ the first template line, or at a %% terminator. *)
+ `Code_block of
+ string with_location ]
+
+type options_token =
+ [ (* Passes template-wide options to the template code generator phase. The
+ string is any options text found after %%. The int is the indentation level
+ of the token beginning the template, whether %% or an implicit start. *)
+ `Options of
+ string * int ]
+
+type newline_token =
+ [ (* A newline character within template text. The tokenizer notes these for
+ future passes that un-indent the template and remove lines containing only
+ embedded code. *)
+ `Newline ]
+
+type template_token =
+ [ (* Once the template starts, text, by default, is accumulated into these
+ tokens. These strings contain no newlines. *)
+ `Text of
+ string
+ | (* Code found within the template text, i.e. in <% ... %> and its variants.
+ The variant indicates what to do with the code - but this is irrelevant at
+ the token level; the tokenizer just needs to note it for the later
+ transformers to process. *)
+ `Embedded of
+ (string * string) with_location ]
+
+type token =
+ [ code_block_token
| options_token
| newline_token
- | template_token
-]
+ | template_token ]
-module Token :
-sig
+module Token : sig
val show : token -> string
-end =
-struct
+end = struct
let show = function
- | `Code_block {line; column; what = code} ->
+ | `Code_block { line; column; what = code } ->
Printf.sprintf "(%i, %i) Code_block\n%s" (line + 1) column code
| `Options (options, indent) ->
Printf.sprintf "Options %s, %i" options indent
- | `Text payload ->
- Printf.sprintf "Text {|%s|}" payload
- | `Newline ->
- "Newline"
- | `Embedded {line; column; what = options, code} ->
+ | `Text payload -> Printf.sprintf "Text {|%s|}" payload
+ | `Newline -> "Newline"
+ | `Embedded { line; column; what = options, code } ->
Printf.sprintf "(%i, %i) Embedded (%s) %s" (line + 1) column options code
end
(* The tokenizer responds to some ASCII characters, and passes everything else
through unchanged. So, it is UTF-8-safe. *)
-module Tokenizer :
-sig
+module Tokenizer : sig
val scan : char Stream.t -> token list
-end =
-struct
-
+end = struct
(* Individual token type scanners. *)
- let token_buffer =
- Buffer.create 4096
-
- let lookahead_buffer =
- Buffer.create 128
+ let token_buffer = Buffer.create 4096
+ let lookahead_buffer = Buffer.create 128
let finish buffer =
let result = Buffer.contents buffer in
@@ -150,9 +124,7 @@ struct
Buffer.add_char lookahead_buffer ' ';
Stream.junk stream;
scan_whitespace stream (columns + 1)
- | _ ->
- finish lookahead_buffer
-
+ | _ -> finish lookahead_buffer
(* Consumes all characters line-by-line, until a line begins with at least two
spaces followed by <. At the end of this scan, the stream is at the first
@@ -160,27 +132,23 @@ struct
of input. The string contains the whitespace characters from the beginning
of the line that terminated the code block. *)
let scan_code_block : string -> char Stream.t -> token * string =
-
let is_template_line leading_whitespace stream =
- match leading_whitespace, Stream.peek stream with
- | (None | Some ""), Some '%' ->
- true, ""
- | _ ->
+ match (leading_whitespace, Stream.peek stream) with
+ | (None | Some ""), Some '%' -> (true, "")
+ | _ -> (
let more_whitespace = scan_whitespace stream 0 in
match Stream.npeek 2 stream with
- | '<'::_ ->
- true, more_whitespace
- | ['%'; '%'] ->
- true, more_whitespace
- | _ ->
- false, more_whitespace
+ | '<' :: _ -> (true, more_whitespace)
+ | ['%'; '%'] -> (true, more_whitespace)
+ | _ -> (false, more_whitespace))
in
let rec scan_lines leading_whitespace stream =
let is_template, whitespace =
- is_template_line leading_whitespace stream in
+ is_template_line leading_whitespace stream
+ in
if is_template then
- finish token_buffer, whitespace
+ (finish token_buffer, whitespace)
else begin
Buffer.add_string token_buffer whitespace;
let rec finish_line stream =
@@ -193,8 +161,7 @@ struct
Buffer.add_char token_buffer c;
Stream.junk stream;
finish_line stream
- | None ->
- finish token_buffer, ""
+ | None -> (finish token_buffer, "")
in
finish_line stream
end
@@ -203,31 +170,25 @@ struct
fun leading_whitespace stream ->
let line, _column = Location.current () in
let code, leftover_whitespace =
- scan_lines (Some leading_whitespace) stream in
- `Code_block {
- line;
- column = 0;
- what = (leading_whitespace ^ code);
- },
- leftover_whitespace
+ scan_lines (Some leading_whitespace) stream
+ in
+ ( `Code_block { line; column = 0; what = leading_whitespace ^ code },
+ leftover_whitespace )
(* Consumes up to one line of input that may contain text. Stops on newlines,
<%, and end of input. *)
let scan_text : string -> char Stream.t -> token =
-
let rec finish_line stream =
match Stream.peek stream with
- | Some '\n' | None ->
- finish token_buffer
- | Some '<' ->
- begin match Stream.npeek 2 stream with
- | ['<'; '%'] ->
- finish token_buffer
+ | Some '\n' | None -> finish token_buffer
+ | Some '<' -> begin
+ match Stream.npeek 2 stream with
+ | ['<'; '%'] -> finish token_buffer
| _ ->
Buffer.add_char token_buffer '<';
Stream.junk stream;
finish_line stream
- end
+ end
| Some c ->
Buffer.add_char token_buffer c;
Stream.junk stream;
@@ -241,11 +202,9 @@ struct
(* This is called when <% is found in template text; the stream front is <%.
Matches options until the first space, then scans for %>. *)
let scan_embedded : char Stream.t -> token =
-
let rec scan_options stream =
match Stream.peek stream with
- | None ->
- finish token_buffer
+ | None -> finish token_buffer
| Some ' ' ->
Stream.junk stream;
finish token_buffer
@@ -257,10 +216,9 @@ struct
let rec scan_code stream =
match Stream.peek stream with
- | None ->
- finish token_buffer
- | Some '%' ->
- begin match Stream.npeek 2 stream with
+ | None -> finish token_buffer
+ | Some '%' -> begin
+ match Stream.npeek 2 stream with
| [_; '>'] ->
Stream.junk stream;
Stream.junk stream;
@@ -269,7 +227,7 @@ struct
Buffer.add_char token_buffer '%';
Stream.junk stream;
scan_code stream
- end
+ end
| Some c ->
Buffer.add_char token_buffer c;
Stream.junk stream;
@@ -284,19 +242,13 @@ struct
(* Note the current location, read the code, and emit the token. *)
let line, column = Location.current () in
- `Embedded {
- line;
- column;
- what = options, scan_code stream;
- }
+ `Embedded { line; column; what = (options, scan_code stream) }
(* Called at the beginning of line when the first character is '%'. *)
let scan_embedded_line : char Stream.t -> token =
-
let rec scan_code stream =
match Stream.peek stream with
- | None ->
- finish token_buffer
+ | None -> finish token_buffer
| Some '\n' ->
Buffer.add_char token_buffer '\n';
Stream.junk stream;
@@ -310,19 +262,13 @@ struct
fun stream ->
Stream.junk stream;
let line, column = Location.current () in
- `Embedded {
- line;
- column;
- what = "", scan_code stream;
- }
+ `Embedded { line; column; what = ("", scan_code stream) }
(* Called at '%%' when a template terminator is encountered. *)
let scan_terminator_options : char Stream.t -> string =
-
let rec scan stream =
match Stream.peek stream with
- | None ->
- finish token_buffer
+ | None -> finish token_buffer
| Some '\n' ->
Stream.junk stream;
finish token_buffer
@@ -337,14 +283,13 @@ struct
Stream.junk stream;
scan stream
-
-
(* Tokenizer state machine. *)
let rec at_code_block tokens leading_whitespace stream =
let token, leftover_whitespace =
- scan_code_block leading_whitespace stream in
- let tokens = token::tokens in
+ scan_code_block leading_whitespace stream
+ in
+ let tokens = token :: tokens in
(* A code block can only be terminated by template text or end of input. *)
match Stream.peek stream with
| None -> tokens
@@ -356,42 +301,39 @@ struct
and at_text_line tokens first indent leading_whitespace stream =
match Stream.peek stream with
- | None ->
- tokens
+ | None -> tokens
| Some '%' when leading_whitespace = "" ->
- let tokens = (scan_embedded_line stream)::tokens in
+ let tokens = scan_embedded_line stream :: tokens in
at_text_line tokens false indent "" stream
- | _ ->
+ | _ -> (
let more_whitespace = scan_whitespace stream 0 in
match Stream.npeek 2 stream with
| ['%'; '%'] ->
let line, _ = Location.current () in
- let options = scan_terminator_options stream, indent in
+ let options = (scan_terminator_options stream, indent) in
if first then
- at_text_line ((`Options options)::tokens) false indent "" stream
+ at_text_line (`Options options :: tokens) false indent "" stream
+ else if String.trim (fst options) <> "" then
+ Printf.ksprintf failwith "Line %i: text following closing '%%%%'" line
else
- if String.trim (fst options) <> "" then
- Printf.ksprintf failwith
- "Line %i: text following closing '%%%%'" line
- else
- at_code_block tokens "" stream
+ at_code_block tokens "" stream
| _ ->
let all_whitespace = leading_whitespace ^ more_whitespace in
let next = Stream.peek stream in
if String.length all_whitespace >= indent || next = Some '\n' then
let tokens =
if first then
- (`Options ("", indent))::tokens
+ `Options ("", indent) :: tokens
else
tokens
in
at_text tokens indent all_whitespace stream
else
- at_code_block tokens all_whitespace stream
+ at_code_block tokens all_whitespace stream)
and at_text tokens indent leading_whitespace stream =
let token = scan_text leading_whitespace stream in
- let tokens = token::tokens in
+ let tokens = token :: tokens in
(* Template text could have been terminated by embedded code, a newline, or
end of input. In case it was terminated by a newline, check if the next
line begins with text in the first column. If so, that is another code
@@ -401,41 +343,33 @@ struct
| Some '\n' ->
Stream.junk stream;
(* let tokens = `Newline::tokens in *)
- at_text_line (`Newline::tokens) false indent "" stream
- (* begin match Stream.peek stream with
- | None -> tokens
- | Some ' ' -> at_text_line tokens false indent "" stream
- | Some '\n' -> at_text tokens indent "" stream
- | Some '%' -> at_text_line tokens false indent "" stream
- | Some _ -> Location.adjust (-1); at_code_block tokens "" stream *)
- (* TODO Is this last case redundant at this point? Should continue with
- at_text_line; it will detect the un-indentation of the template. *)
- (* end; *)
+ at_text_line (`Newline :: tokens) false indent "" stream
+ (* begin match Stream.peek stream with
+ | None -> tokens
+ | Some ' ' -> at_text_line tokens false indent "" stream
+ | Some '\n' -> at_text tokens indent "" stream
+ | Some '%' -> at_text_line tokens false indent "" stream
+ | Some _ -> Location.adjust (-1); at_code_block tokens "" stream *)
+ (* TODO Is this last case redundant at this point? Should continue with
+ at_text_line; it will detect the un-indentation of the template. *)
+ (* end; *)
(* If the text scanner stopped at <, it is actually <% and this is an
embedded code block. *)
| Some '<' ->
- let tokens = (scan_embedded stream)::tokens in
+ let tokens = scan_embedded stream :: tokens in
at_text tokens indent "" stream
(* This case should be impossible, because the text parser would have
consumed any other character. *)
- | Some _ ->
- assert false
+ | Some _ -> assert false
- let scan stream =
- stream
- |> at_code_block [] ""
- |> List.rev
+ let scan stream = stream |> at_code_block [] "" |> List.rev
end
+type template =
+ [ code_block_token
+ | `Template of (string * int) * template_token list list ]
-
-type template = [
- | code_block_token
- | `Template of (string * int) * template_token list list
-]
-
-module Transform :
-sig
+module Transform : sig
(* Groups text chunks into templates. A template begins at the first chunk
following a code block, and ends at the last chunk before the next code
block or end of input. *)
@@ -454,62 +388,53 @@ sig
(* Filters out empty text. *)
val trim : template list -> template list
-end =
-struct
+end = struct
let delimit tokens =
-
(* During this function, we unconditionally insert Begin before the first
Text, Newline, or Embedded, because we have already seen a code block,
and are looking for the beginning of the template. It will practically
always be the next token, but be careful in case a future pass allows
consecutive Code_blocks. *)
let rec top_level (accumulator : template list) = function
- | (`Options options)::tokens ->
+ | `Options options :: tokens ->
template_level options accumulator [] [] tokens
- | (#template_token | `Newline)::_ as tokens ->
+ | (#template_token | `Newline) :: _ as tokens ->
(* This case should be impossible due to the addition of `Option tokens
at the start of every template, carrying indentation information. So,
it should be removed at the next opportunity. *)
template_level ("", 0) accumulator [] [] tokens
- | (`Code_block _ as token)::tokens ->
- top_level (token::accumulator) tokens
- | [] ->
- List.rev accumulator
-
+ | (`Code_block _ as token) :: tokens ->
+ top_level (token :: accumulator) tokens
+ | [] -> List.rev accumulator
(* This function runs when in a template. It scans for Code_block or end of
input; upon finding either, it appends End, and returns to the
insert_begin state. *)
and template_level options accumulator template line = function
- | (`Code_block _ | `Options _)::_ | [] as tokens ->
- let template = (List.rev line)::template in
- top_level ((`Template (options, List.rev template))::accumulator) tokens
- | `Newline::tokens ->
- template_level options accumulator ((List.rev line)::template) [] tokens
- | (#template_token as token)::tokens ->
- template_level options accumulator template (token::line) tokens
-
+ | ((`Code_block _ | `Options _) :: _ | []) as tokens ->
+ let template = List.rev line :: template in
+ top_level (`Template (options, List.rev template) :: accumulator) tokens
+ | `Newline :: tokens ->
+ template_level options accumulator (List.rev line :: template) [] tokens
+ | (#template_token as token) :: tokens ->
+ template_level options accumulator template (token :: line) tokens
in
top_level [] tokens
-
-
let map_templates f templates =
templates
|> List.map (function
- | `Template (options, template) -> `Template (options, f options template)
- | `Code_block _ as token -> token)
-
-
+ | `Template (options, template) ->
+ `Template (options, f options template)
+ | `Code_block _ as token -> token)
let rec whitespace_prefix index s =
if index >= String.length s then
max_int
+ else if s.[index] != ' ' then
+ index
else
- if s.[index] != ' ' then
- index
- else
- whitespace_prefix (index + 1) s
+ whitespace_prefix (index + 1) s
(* This function is dead code at this point, because the templater now uses
indentation information from the tokenizer, rather than detecting common
@@ -517,123 +442,119 @@ struct
detection is proven robust. *)
let _common_whitespace template =
template
- |> List.fold_left begin fun amount line ->
- match line with
- | (`Text text)::_ -> min amount (whitespace_prefix 0 text)
- | _ -> amount
- end max_int
+ |> List.fold_left
+ begin
+fun amount line ->
+ match line with
+ | `Text text :: _ -> min amount (whitespace_prefix 0 text)
+ | _ -> amount
+ end
+ max_int
|> fun amount ->
- if amount = max_int then 0
- else amount
+ if amount = max_int then
+ 0
+ else
+ amount
let unindent_template amount template =
template
- |> List.map begin function
- | (`Text text)::line ->
- let text =
- if amount >= String.length text then ""
- else String.sub text amount (String.length text - amount)
- in
- (`Text text)::line
- | line -> line
- end
+ |> List.map (function
+ | `Text text :: line ->
+ let text =
+ if amount >= String.length text then
+ ""
+ else
+ String.sub text amount (String.length text - amount)
+ in
+ `Text text :: line
+ | line -> line)
let unindent templates =
- templates |> map_templates (fun (_, indent) template ->
- unindent_template indent template)
-
-
+ templates
+ |> map_templates (fun (_, indent) template ->
+ unindent_template indent template)
(* Empty lines filtering is dead code at this point. It can be removed once
using % to filter empty lines is shown to be practical. *)
let is_empty line =
- line |> List.for_all (function
- | `Text text -> String.trim text = ""
- | `Embedded {what = options, _; _} -> options = "")
+ line
+ |> List.for_all (function
+ | `Text text -> String.trim text = ""
+ | `Embedded { what = options, _; _ } -> options = "")
let leave_embdedded line =
- line |> List.filter (function
- | `Embedded _ -> true
- | _ -> false)
+ line
+ |> List.filter (function
+ | `Embedded _ -> true
+ | _ -> false)
let rec append_embeddeds accumulator = function
- | (`True line)::(`Embeddeds orphans)::lines ->
- append_embeddeds accumulator ((`True (line @ orphans))::lines)
- | line::lines ->
- append_embeddeds (line::accumulator) lines
- | [] ->
- List.rev accumulator
+ | `True line :: `Embeddeds orphans :: lines ->
+ append_embeddeds accumulator (`True (line @ orphans) :: lines)
+ | line :: lines -> append_embeddeds (line :: accumulator) lines
+ | [] -> List.rev accumulator
let rec prepend_embeddeds accumulator = function
- | (`Embeddeds orphans)::(`Embeddeds more)::lines ->
- prepend_embeddeds accumulator ((`Embeddeds (orphans @ more))::lines)
- | (`Embeddeds orphans)::(`True line)::lines ->
- prepend_embeddeds ((`True (orphans @ line))::accumulator) lines
- | line::lines ->
- prepend_embeddeds (line::accumulator) lines
- | [] ->
- List.rev accumulator
+ | `Embeddeds orphans :: `Embeddeds more :: lines ->
+ prepend_embeddeds accumulator (`Embeddeds (orphans @ more) :: lines)
+ | `Embeddeds orphans :: `True line :: lines ->
+ prepend_embeddeds (`True (orphans @ line) :: accumulator) lines
+ | line :: lines -> prepend_embeddeds (line :: accumulator) lines
+ | [] -> List.rev accumulator
let empty_lines_from_template _ template =
template
|> List.map (fun line ->
- if is_empty line then
- `Embeddeds (leave_embdedded line)
- else
- `True line)
+ if is_empty line then
+ `Embeddeds (leave_embdedded line)
+ else
+ `True line)
|> append_embeddeds []
|> prepend_embeddeds []
|> function
- | [`Embeddeds tokens] -> [tokens]
- | true_lines ->
- true_lines |> List.map (function
- | `True line -> line
- | `Embeddeds _ -> assert false)
+ | [`Embeddeds tokens] -> [tokens]
+ | true_lines ->
+ true_lines
+ |> List.map (function
+ | `True line -> line
+ | `Embeddeds _ -> assert false)
let empty_lines templates =
templates |> map_templates empty_lines_from_template
-
-
let rec coalesce_tokens accumulator = function
- | (`Text text)::(`Text text')::tokens ->
- coalesce_tokens accumulator ((`Text (text ^ text'))::tokens)
- | token::tokens ->
- coalesce_tokens (token::accumulator) tokens
- | [] ->
- List.rev accumulator
+ | `Text text :: `Text text' :: tokens ->
+ coalesce_tokens accumulator (`Text (text ^ text') :: tokens)
+ | token :: tokens -> coalesce_tokens (token :: accumulator) tokens
+ | [] -> List.rev accumulator
let coalesce_template _ template =
template
- |> List.map (fun line -> (`Text "\n")::line)
+ |> List.map (fun line -> `Text "\n" :: line)
|> List.flatten
|> (function
- | [] -> []
- | _newline::tokens -> tokens)
+ | [] -> []
+ | _newline :: tokens -> tokens)
|> coalesce_tokens []
|> fun tokens -> [tokens]
- let coalesce templates =
- templates |> map_templates coalesce_template
-
-
+ let coalesce templates = templates |> map_templates coalesce_template
let trim templates =
- templates |> map_templates (fun _ lines ->
- lines |> List.map (fun line ->
- line |> List.filter (function
- | `Text "" -> false
- | _ -> true)))
+ templates
+ |> map_templates (fun _ lines ->
+ lines
+ |> List.map (fun line ->
+ line
+ |> List.filter (function
+ | `Text "" -> false
+ | _ -> true)))
end
-
-
-module Generate :
-sig
+module Generate : sig
val generate :
reason:bool -> string -> (string -> unit) -> template list -> unit
-end =
-struct
+end = struct
type output = {
print : string -> unit;
init : unit -> unit;
@@ -643,149 +564,113 @@ struct
format_end : unit -> unit;
}
- let string print = {
- print;
-
- init = (fun () ->
- print "let ___eml_buffer = Buffer.create 4096 in\n");
-
- finish = (fun () ->
- print "(Buffer.contents ___eml_buffer)\n");
-
- text =
- Printf.ksprintf print "(Buffer.add_string ___eml_buffer %S);\n";
-
- format =
- Printf.ksprintf print "(Printf.bprintf ___eml_buffer %S ";
-
- format_end = (fun () ->
- print ");\n");
- }
-
- let string_reason print = {
- print;
-
- init = (fun () ->
- print "let ___eml_buffer = Buffer.create(4096);\n");
-
- finish = (fun () ->
- print "Buffer.contents(___eml_buffer)\n");
-
- text =
- Printf.ksprintf print "Buffer.add_string(___eml_buffer, %S);\n";
-
- format =
- Printf.ksprintf print "Printf.bprintf(___eml_buffer, %S)";
-
- format_end = (fun () ->
- print ";\n");
- }
+ let string print =
+ {
+ print;
+ init = (fun () -> print "let ___eml_buffer = Buffer.create 4096 in\n");
+ finish = (fun () -> print "(Buffer.contents ___eml_buffer)\n");
+ text = Printf.ksprintf print "(Buffer.add_string ___eml_buffer %S);\n";
+ format = Printf.ksprintf print "(Printf.bprintf ___eml_buffer %S ";
+ format_end = (fun () -> print ");\n");
+ }
+
+ let string_reason print =
+ {
+ print;
+ init = (fun () -> print "let ___eml_buffer = Buffer.create(4096);\n");
+ finish = (fun () -> print "Buffer.contents(___eml_buffer)\n");
+ text = Printf.ksprintf print "Buffer.add_string(___eml_buffer, %S);\n";
+ format = Printf.ksprintf print "Printf.bprintf(___eml_buffer, %S)";
+ format_end = (fun () -> print ";\n");
+ }
(* TODO Test in unit tests. *)
- let stream print = {
- print;
-
- init = (fun () ->
- print "let ___eml_write string = Dream.write response string in\n");
-
- finish = (fun () ->
- print "Lwt.return_unit\n");
-
- text =
- Printf.ksprintf print "let%%lwt () = ___eml_write %S in\n";
-
- format =
- Printf.ksprintf print "let%%lwt () = Printf.ksprintf ___eml_write %S ";
-
- format_end = (fun () ->
- print " in\n");
- }
-
- let stream_reason print = {
- print;
-
- init = (fun () ->
- print "let ___eml_write = string => Dream.write(response, string);\n");
-
- finish = (fun () ->
- print "Lwt.return_unit\n");
-
- text =
- Printf.ksprintf print "let%%lwt () = ___eml_write(%S);\n";
-
- format =
- Printf.ksprintf print "let%%lwt () = Printf.ksprintf(___eml_write, %S)";
-
- format_end = (fun () ->
- print ";\n");
- }
+ let stream print =
+ {
+ print;
+ init =
+ (fun () ->
+ print "let ___eml_write string = Dream.write response string in\n");
+ finish = (fun () -> print "Lwt.return_unit\n");
+ text = Printf.ksprintf print "let%%lwt () = ___eml_write %S in\n";
+ format =
+ Printf.ksprintf print "let%%lwt () = Printf.ksprintf ___eml_write %S ";
+ format_end = (fun () -> print " in\n");
+ }
+
+ let stream_reason print =
+ {
+ print;
+ init =
+ (fun () ->
+ print "let ___eml_write = string => Dream.write(response, string);\n");
+ finish = (fun () -> print "Lwt.return_unit\n");
+ text = Printf.ksprintf print "let%%lwt () = ___eml_write(%S);\n";
+ format =
+ Printf.ksprintf print "let%%lwt () = Printf.ksprintf(___eml_write, %S)";
+ format_end = (fun () -> print ";\n");
+ }
let generate_template_body location output tokens =
- tokens |> List.iter begin function
- | `Text text ->
- (* Printf.ksprintf output.print "(Buffer.add_string ___eml_buffer %S);\n" text *)
- output.text text
-
- | `Embedded {line; column; what = "", code} ->
- Printf.ksprintf output.print "#%i \"%s\"\n" (line + 1) location;
- Printf.ksprintf output.print "%s%s\n" (String.make column ' ') code
-
- (* TODO Really need tests for this. *)
- | `Embedded {line; column; what = format, code} ->
- let format, needs_escape =
- match format.[String.length format - 1] with
- | '!' ->
- String.sub format 0 (String.length format - 1), false
- | 's' | 'S' | 'c' | 'C' | 'a' | 't' ->
- format, true
- | _ ->
- format, false
- in
-
- output.format ("%" ^ format);
- if needs_escape then
- output.print "(Dream_pure.Formats.html_escape ";
- output.print "(\n";
-
- Printf.ksprintf output.print "#%i \"%s\"\n" (line + 1) location;
- Printf.ksprintf output.print "%s%s\n" (String.make column ' ') code;
-
- if needs_escape then
- output.print ")";
- output.print ")";
- output.format_end ();
- end
+ tokens
+ |> List.iter (function
+ | `Text text ->
+ (* Printf.ksprintf output.print "(Buffer.add_string ___eml_buffer %S);\n" text *)
+ output.text text
+ | `Embedded { line; column; what = "", code } ->
+ Printf.ksprintf output.print "#%i \"%s\"\n" (line + 1) location;
+ Printf.ksprintf output.print "%s%s\n" (String.make column ' ') code
+ (* TODO Really need tests for this. *)
+ | `Embedded { line; column; what = format, code } ->
+ let format, needs_escape =
+ match format.[String.length format - 1] with
+ | '!' -> (String.sub format 0 (String.length format - 1), false)
+ | 's' | 'S' | 'c' | 'C' | 'a' | 't' -> (format, true)
+ | _ -> (format, false)
+ in
+
+ output.format ("%" ^ format);
+ if needs_escape then
+ output.print "(Dream_pure.Formats.html_escape ";
+ output.print "(\n";
+
+ Printf.ksprintf output.print "#%i \"%s\"\n" (line + 1) location;
+ Printf.ksprintf output.print "%s%s\n" (String.make column ' ') code;
+
+ if needs_escape then
+ output.print ")";
+ output.print ")";
+ output.format_end ())
let generate ~reason location print templates =
- templates |> List.iter begin function
- | `Code_block {line; what; _} ->
- Printf.ksprintf print "#%i \"%s\"\n" (line + 1) location;
- print what
-
- | `Template ((options, _), lines) ->
- let output =
- match reason, String.trim options with
- | false, "" -> string print
- | true, "" -> string_reason print
- | false, "response" -> stream print
- | true, "response" -> stream_reason print
- | _, s -> Printf.ksprintf failwith "Unknown template options '%s'" s
- in
- (* By this point, the template should be only one "line," with all the
- newlines built into the strings. We still flatten it, just in
- case. *)
- output.init ();
- generate_template_body location output (List.flatten lines);
- output.finish ()
- end
+ templates
+ |> List.iter (function
+ | `Code_block { line; what; _ } ->
+ Printf.ksprintf print "#%i \"%s\"\n" (line + 1) location;
+ print what
+ | `Template ((options, _), lines) ->
+ let output =
+ match (reason, String.trim options) with
+ | false, "" -> string print
+ | true, "" -> string_reason print
+ | false, "response" -> stream print
+ | true, "response" -> stream_reason print
+ | _, s ->
+ Printf.ksprintf failwith "Unknown template options '%s'" s
+ in
+ (* By this point, the template should be only one "line," with all the
+ newlines built into the strings. We still flatten it, just in
+ case. *)
+ output.init ();
+ generate_template_body location output (List.flatten lines);
+ output.finish ())
end
-
-
let process_file (input_file, location, syntax) =
- let reason, extension = match syntax with
- | `OCaml -> (false, ".ml")
- | `Reason -> (true, ".re")
+ let reason, extension =
+ match syntax with
+ | `OCaml -> (false, ".ml")
+ | `Reason -> (true, ".re")
in
let output_file =
@@ -802,9 +687,9 @@ let process_file (input_file, location, syntax) =
let input_channel = open_in input_file in
let output_channel = open_out output_file in
- let input_stream = Location.stream (fun () ->
- try Some (input_char input_channel)
- with End_of_file -> None)
+ let input_stream =
+ Location.stream (fun () ->
+ try Some (input_char input_channel) with End_of_file -> None)
in
Location.reset ();
File "src/mirage/mirage.mli", line 1, characters 0-0:
diff --git a/_build/default/src/mirage/mirage.mli b/_build/default/src/mirage/.formatted/mirage.mli
index 177860e..25976f9 100644
--- a/_build/default/src/mirage/mirage.mli
+++ b/_build/default/src/mirage/.formatted/mirage.mli
@@ -368,19 +368,21 @@ module Make
(**/**)
(**/**)
+
val path : request -> string list
- [@@ocaml.deprecated
- "Router path access is being removed from the API. Comment at
- https://github.com/aantron/dream/issues
- "]
+ [@@ocaml.deprecated
+ "Router path access is being removed from the API. Comment at\n\
+ \ https://github.com/aantron/dream/issues\n\
+ \ "]
(** Parsed request path. For example, ["foo"; "bar"]. *)
+
(* TODO If not removing this, move it to section Routing. *)
(**/**)
val set_client : request -> string -> unit
(** Replaces the client. See {!Dream.val-client}. *)
- val set_method_ : request -> [< method_ ] -> unit
+ val set_method_ : request -> [< method_] -> unit
(** Replaces the method. See {!Dream.type-method_}. *)
val query : request -> string -> string option
File "example/a-log/log.ml", line 1, characters 0-0:
diff --git a/_build/default/example/a-log/log.ml b/_build/default/example/a-log/.formatted/log.ml
index 457bf79..74c600a 100644
--- a/_build/default/example/a-log/log.ml
+++ b/_build/default/example/a-log/.formatted/log.ml
@@ -1,16 +1,12 @@
let () =
Dream.run
@@ Dream.logger
- @@ Dream.router [
-
- Dream.get "/"
- (fun request ->
- Dream.log "Sending greeting to %s!" (Dream.client request);
- Dream.html "Good morning, world!");
-
- Dream.get "/fail"
- (fun _ ->
- Dream.warning (fun log -> log "Raising an exception!");
- raise (Failure "The Web app failed!"));
-
- ]
+ @@ Dream.router
+ [
+ Dream.get "/" (fun request ->
+ Dream.log "Sending greeting to %s!" (Dream.client request);
+ Dream.html "Good morning, world!");
+ Dream.get "/fail" (fun _ ->
+ Dream.warning (fun log -> log "Raising an exception!");
+ raise (Failure "The Web app failed!"));
+ ]
File "example/w-template-files/server.ml", line 1, characters 0-0:
diff --git a/_build/default/example/w-template-files/server.ml b/_build/default/example/w-template-files/.formatted/server.ml
index fac4106..183d346 100644
--- a/_build/default/example/w-template-files/server.ml
+++ b/_build/default/example/w-template-files/.formatted/server.ml
@@ -1,12 +1,8 @@
let () =
Dream.run
@@ Dream.logger
- @@ Dream.router [
-
- Dream.get "/:word"
- (fun request ->
- Dream.param request "word"
- |> Template.render
- |> Dream.html);
-
- ]
+ @@ Dream.router
+ [
+ Dream.get "/:word" (fun request ->
+ Dream.param request "word" |> Template.render |> Dream.html);
+ ]
File "example/z-docker-esy/app.ml", line 1, characters 0-0:
diff --git a/_build/default/example/z-docker-esy/app.ml b/_build/default/example/z-docker-esy/.formatted/app.ml
index fe07cf9..ee2a472 100644
--- a/_build/default/example/z-docker-esy/app.ml
+++ b/_build/default/example/z-docker-esy/.formatted/app.ml
@@ -1,7 +1,8 @@
let () =
Dream.run ~interface:"0.0.0.0"
@@ Dream.logger
- @@ Dream.router [
- Dream.get "/" (fun _ ->
- Dream.html "Dream started by Docker Compose, built with esy!");
- ]
+ @@ Dream.router
+ [
+ Dream.get "/" (fun _ ->
+ Dream.html "Dream started by Docker Compose, built with esy!");
+ ]
File "example/z-fly/app.ml", line 1, characters 0-0:
diff --git a/_build/default/example/z-fly/app.ml b/_build/default/example/z-fly/.formatted/app.ml
index 698d758..7f8c42d 100644
--- a/_build/default/example/z-fly/app.ml
+++ b/_build/default/example/z-fly/.formatted/app.ml
@@ -1,6 +1,5 @@
let () =
Dream.run ~interface:"0.0.0.0"
@@ Dream.logger
- @@ Dream.router [
- Dream.get "/" (fun _ -> Dream.html "Dream deployed on Fly.io!");
- ]
+ @@ Dream.router
+ [Dream.get "/" (fun _ -> Dream.html "Dream deployed on Fly.io!")]
File "example/z-heroku/app.ml", line 1, characters 0-0:
diff --git a/_build/default/example/z-heroku/app.ml b/_build/default/example/z-heroku/.formatted/app.ml
index 232682e..97ee484 100644
--- a/_build/default/example/z-heroku/app.ml
+++ b/_build/default/example/z-heroku/.formatted/app.ml
@@ -1,6 +1,5 @@
let () =
Dream.run ~interface:"0.0.0.0" ~port:(int_of_string (Sys.getenv "PORT"))
@@ Dream.logger
- @@ Dream.router [
- Dream.get "/" (fun _ -> Dream.html "Dream running in Heroku!");
- ]
+ @@ Dream.router
+ [Dream.get "/" (fun _ -> Dream.html "Dream running in Heroku!")]
File "example/z-systemd/app.ml", line 1, characters 0-0:
diff --git a/_build/default/example/z-systemd/app.ml b/_build/default/example/z-systemd/.formatted/app.ml
index 87703ff..6e017cc 100644
--- a/_build/default/example/z-systemd/app.ml
+++ b/_build/default/example/z-systemd/.formatted/app.ml
@@ -1,6 +1,5 @@
let () =
Dream.run ~interface:"0.0.0.0" ~port:80
@@ Dream.logger
- @@ Dream.router [
- Dream.get "/" (fun _ -> Dream.html "Dream started by systemd!");
- ]
+ @@ Dream.router
+ [Dream.get "/" (fun _ -> Dream.html "Dream started by systemd!")]
File "example/e-json/json.ml", line 1, characters 0-0:
diff --git a/_build/default/example/e-json/json.ml b/_build/default/example/e-json/.formatted/json.ml
index 6fde960..2d88ca2 100644
--- a/_build/default/example/e-json/json.ml
+++ b/_build/default/example/e-json/.formatted/json.ml
@@ -1,25 +1,19 @@
-type message_object = {
- message : string;
-} [@@deriving yojson]
+type message_object = { message : string } [@@deriving yojson]
let () =
Dream.run
@@ Dream.logger
@@ Dream.origin_referrer_check
- @@ Dream.router [
+ @@ Dream.router
+ [
+ Dream.post "/" (fun request ->
+ let%lwt body = Dream.body request in
- Dream.post "/"
- (fun request ->
- let%lwt body = Dream.body request in
+ let message_object =
+ body |> Yojson.Safe.from_string |> message_object_of_yojson
+ in
- let message_object =
- body
- |> Yojson.Safe.from_string
- |> message_object_of_yojson
- in
-
- `String message_object.message
- |> Yojson.Safe.to_string
- |> Dream.json);
-
- ]
+ `String message_object.message
+ |> Yojson.Safe.to_string
+ |> Dream.json);
+ ]
File "example/w-mirage/config.ml", line 1, characters 0-0:
diff --git a/_build/default/example/w-mirage/config.ml b/_build/default/example/w-mirage/.formatted/config.ml
index 6554522..3e5966c 100644
--- a/_build/default/example/w-mirage/config.ml
+++ b/_build/default/example/w-mirage/.formatted/config.ml
@@ -1,52 +1,64 @@
open Mirage
let port =
- let doc = Key.Arg.info ~doc:"Listening port." [ "port" ] in
+ let doc = Key.Arg.info ~doc:"Listening port." ["port"] in
Key.(create "port" Arg.(opt int 443 doc))
let hostname =
- let doc = Key.Arg.info ~doc:"Hostname." [ "hostname" ] in
+ let doc = Key.Arg.info ~doc:"Hostname." ["hostname"] in
Key.(create "hostname" Arg.(opt string "localhost" doc))
let production =
- let doc = Key.Arg.info ~doc:"Let's encrypt production environment." [ "production" ] in
+ let doc =
+ Key.Arg.info ~doc:"Let's encrypt production environment." ["production"]
+ in
Key.(create "production" Arg.(opt bool false doc))
let cert_seed =
- let doc = Key.Arg.info ~doc:"Let's encrypt certificate seed." [ "cert-seed" ] in
+ let doc = Key.Arg.info ~doc:"Let's encrypt certificate seed." ["cert-seed"] in
Key.(create "cert_seed" Arg.(opt (some string) None doc))
let account_seed =
- let doc = Key.Arg.info ~doc:"Let's encrypt account seed." [ "account-seed" ] in
+ let doc = Key.Arg.info ~doc:"Let's encrypt account seed." ["account-seed"] in
Key.(create "account_seed" Arg.(opt (some string) None doc))
let email =
- let doc = Key.Arg.info ~doc:"Let's encrypt E-Mail." [ "email" ] in
+ let doc = Key.Arg.info ~doc:"Let's encrypt E-Mail." ["email"] in
Key.(create "email" Arg.(opt (some string) None doc))
let tls =
- let doc = Key.Arg.info ~doc:"HTTP server with TLS." [ "tls" ] in
+ let doc = Key.Arg.info ~doc:"HTTP server with TLS." ["tls"] in
Key.(create "tls" Arg.(opt bool false doc))
let letsencrypt =
- let doc = Key.Arg.info ~doc:"Retrieve the TLS certificate from Let's encrypt." [ "letsencrypt" ] in
+ let doc =
+ Key.Arg.info ~doc:"Retrieve the TLS certificate from Let's encrypt."
+ ["letsencrypt"]
+ in
Key.(create "letsencrypt" Arg.(opt bool false doc))
let dream =
foreign "Unikernel.Make"
- ~packages:[ package "ca-certs-nss"
- ; package "dns-client" ~sublibs:[ "mirage" ]
- ; package "dream-mirage" ~sublibs:[ "paf.le" ]
- ; package "checkseum" ~sublibs:[ "c" ]
- ; package "dream-mirage" ]
- ~keys:Key.([ abstract port
- ; abstract hostname
- ; abstract production
- ; abstract cert_seed
- ; abstract account_seed
- ; abstract email
- ; abstract tls
- ; abstract letsencrypt ])
+ ~packages:
+ [
+ package "ca-certs-nss";
+ package "dns-client" ~sublibs:["mirage"];
+ package "dream-mirage" ~sublibs:["paf.le"];
+ package "checkseum" ~sublibs:["c"];
+ package "dream-mirage";
+ ]
+ ~keys:
+ Key.
+ [
+ abstract port;
+ abstract hostname;
+ abstract production;
+ abstract cert_seed;
+ abstract account_seed;
+ abstract email;
+ abstract tls;
+ abstract letsencrypt;
+ ]
(console @-> random @-> time @-> mclock @-> pclock @-> stackv4v6 @-> job)
let random = default_random
@@ -56,5 +68,6 @@ let pclock = default_posix_clock
let mclock = default_monotonic_clock
let stackv4v6 = generic_stackv4v6 default_network
-let () = register "dream"
- [ dream $ console $ random $ time $ mclock $ pclock $ stackv4v6 ]
+let () =
+ register "dream"
+ [dream $ console $ random $ time $ mclock $ pclock $ stackv4v6]
File "example/z-playground/sandbox/ocaml/server.eml.ml", line 1, characters 0-0:
diff --git a/_build/default/example/z-playground/sandbox/ocaml/server.eml.ml b/_build/default/example/z-playground/sandbox/ocaml/.formatted/server.eml.ml
index b346a09..096f687 100644
--- a/_build/default/example/z-playground/sandbox/ocaml/server.eml.ml
+++ b/_build/default/example/z-playground/sandbox/ocaml/.formatted/server.eml.ml
@@ -1,6 +1,4 @@
let () =
Dream.run ~interface:"0.0.0.0"
@@ Dream.logger
- @@ Dream.router [
- Dream.get "/" (fun _ -> Dream.html Playground.welcome);
- ]
+ @@ Dream.router [Dream.get "/" (fun _ -> Dream.html Playground.welcome)]
File "src/server/log.ml", line 1, characters 0-0:
diff --git a/_build/default/src/server/log.ml b/_build/default/src/server/.formatted/log.ml
index f2a664f..3f53ef1 100644
--- a/_build/default/src/server/log.ml
+++ b/_build/default/src/server/.formatted/log.ml
@@ -3,8 +3,6 @@
Copyright 2021 Anton Bachin *)
-
-
(* Among other things, this module wraps the Logs library so as to prepend
request ids to log messages.
@@ -31,16 +29,11 @@ module Message = Dream_pure.Message
module Method = Dream_pure.Method
module Status = Dream_pure.Status
-
-
-type log_level = [
- | `Error
+type log_level =
+ [ `Error
| `Warning
| `Info
- | `Debug
-]
-
-
+ | `Debug ]
(* The logging middleware assigns request ids to requests, and tries to show
them in the logs. The scheme works as follows:
@@ -64,22 +57,16 @@ let request_id_label = "dream.request_id"
(* Logs library tag uesd to pass an id from a request provided through
~request. *)
let logs_lib_tag : string Logs.Tag.def =
- Logs.Tag.def
- request_id_label
- Format.pp_print_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 ()
+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 =
- Message.new_field
- ~name:request_id_label
- ~show_value:(fun id -> id)
- ()
+ Message.new_field ~name:request_id_label ~show_value:(fun id -> id) ()
(* Makes a best-effort attempt to retrieve the request id. *)
let get_request_id ?request () =
@@ -93,10 +80,7 @@ let get_request_id ?request () =
| None -> Lwt.get id_lwt_key
(* The current state of the request id sequence. *)
-let last_id =
- ref 0
-
-
+let last_id = ref 0
(* TODO Nice logging for multiline strings? *)
(* The "back end." I inlined several examples from the Logs, Logs_lwt, and Fmt
@@ -108,7 +92,6 @@ let last_id =
until needed. Setting up the reporter before TTY checking will cause it to
not output color. *)
let reporter ~now () =
-
(* Format into an internal buffer. *)
let buffer = Buffer.create 512 in
let formatter = Fmt.with_buffer ~like:Fmt.stderr buffer in
@@ -130,14 +113,13 @@ let reporter ~now () =
callback that got wrapped in function source (the "front end") below. That
wrapper is the actual user's callback, and it calls user's_callback. *)
let report src level ~over k user's_callback =
-
let level_style, level =
match level with
- | Logs.App -> `White, " "
- | Logs.Error -> `Red, "ERROR"
- | Logs.Warning -> `Yellow, " WARN"
- | Logs.Info -> `Green, " INFO"
- | Logs.Debug -> `Blue, "DEBUG"
+ | Logs.App -> (`White, " ")
+ | Logs.Error -> (`Red, "ERROR")
+ | Logs.Warning -> (`Yellow, " WARN")
+ | Logs.Info -> (`Green, " INFO")
+ | Logs.Debug -> (`Blue, "DEBUG")
in
let write _ =
@@ -156,114 +138,101 @@ let reporter ~now () =
formatting, and, eventually, writing. The wrappers don't use the ?header
argument, so we ignore it. *)
user's_callback @@ fun ?header ?tags format_and_arguments ->
- ignore header;
-
- (* Format the current local time. For the millisecond fraction, be careful
- of rounding 999.5+ to 1000 on output. *)
- let time =
- let unix_time = now () in
- let time = Option.get (Ptime.of_float_s unix_time) in
- let fraction =
- fst (modf unix_time) *. 1000. in
- let clamped_fraction =
- if fraction > 999. then 999.
- else fraction
- in
- let ((y, m, d), ((hh, mm, ss), _tz_offset_s)) =
- Ptime.to_date_time time in
- Printf.sprintf "%02i.%02i.%02i %02i:%02i:%02i.%03.0f"
- d m (y mod 100)
- hh mm ss clamped_fraction
+ ignore header;
+
+ (* Format the current local time. For the millisecond fraction, be careful
+ of rounding 999.5+ to 1000 on output. *)
+ let time =
+ let unix_time = now () in
+ let time = Option.get (Ptime.of_float_s unix_time) in
+ let fraction = fst (modf unix_time) *. 1000. in
+ let clamped_fraction =
+ if fraction > 999. then
+ 999.
+ else
+ fraction
in
+ let (y, m, d), ((hh, mm, ss), _tz_offset_s) = Ptime.to_date_time time in
+ Printf.sprintf "%02i.%02i.%02i %02i:%02i:%02i.%03.0f" d m (y mod 100) hh
+ mm ss clamped_fraction
+ in
- (* Format the source name column. It is the right-aligned log source name,
- clipped to the column width. If the source is the default application
- source, leave the column empty. *)
- let source =
- let width = 15 in
- if Logs.Src.name src = Logs.Src.name Logs.default then
- String.make width ' '
+ (* Format the source name column. It is the right-aligned log source name,
+ clipped to the column width. If the source is the default application
+ source, leave the column empty. *)
+ let source =
+ let width = 15 in
+ if Logs.Src.name src = Logs.Src.name Logs.default then
+ String.make width ' '
+ else
+ let name = Logs.Src.name src in
+ if String.length name > width then
+ String.sub name (String.length name - width) width
else
- let name = Logs.Src.name src in
- if String.length name > width then
- String.sub name (String.length name - width) width
- else
- (String.make (width - String.length name) ' ') ^ name
- in
- let source_prefix, source =
- try
- let dot_index = String.rindex source '.' + 1 in
- String.sub source 0 dot_index,
- String.sub source dot_index (String.length source - dot_index)
- with Not_found ->
- "", source
- in
+ String.make (width - String.length name) ' ' ^ name
+ in
+ let source_prefix, source =
+ try
+ let dot_index = String.rindex source '.' + 1 in
+ ( String.sub source 0 dot_index,
+ String.sub source dot_index (String.length source - dot_index) )
+ with Not_found -> ("", source)
+ in
- (* Check if a request id is available in the tags passed from the front
- end. If not, try to get it from the promise-chain-local storage. If
- we end up with a request id, format it. *)
- let request_id_from_tags =
- match tags with
- | None -> None
- | Some tags ->
- Logs.Tag.find logs_lib_tag tags
- in
+ (* Check if a request id is available in the tags passed from the front
+ end. If not, try to get it from the promise-chain-local storage. If
+ we end up with a request id, format it. *)
+ let request_id_from_tags =
+ match tags with
+ | None -> None
+ | Some tags -> Logs.Tag.find logs_lib_tag tags
+ in
- let request_id =
- match request_id_from_tags with
- | Some _ -> request_id_from_tags
- | None -> get_request_id ()
- in
+ let request_id =
+ match request_id_from_tags with
+ | Some _ -> request_id_from_tags
+ | None -> get_request_id ()
+ in
- let request_id, request_style =
- match request_id with
- | Some "" | None -> "", `White
- | Some 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. *)
- let last_byte = request_id.[String.length request_id - 1] in
- let color =
- if (Char.code last_byte) land 1 = 0 then
- `Cyan
- else
- `Magenta
- in
- " REQ " ^ request_id, color
- in
+ let request_id, request_style =
+ match request_id with
+ | Some "" | None -> ("", `White)
+ | Some 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. *)
+ let last_byte = request_id.[String.length request_id - 1] in
+ let color =
+ if Char.code last_byte land 1 = 0 then
+ `Cyan
+ else
+ `Magenta
+ in
+ (" REQ " ^ request_id, color)
+ in
- (* The formatting proper. *)
- Format.kfprintf write formatter
- ("%a %a%s %a%a @[" ^^ format_and_arguments ^^ "@]@.")
- Fmt.(styled `Faint string) time
- Fmt.(styled `White string) source_prefix source
- Fmt.(styled level_style string) level
- Fmt.(styled request_style (styled `Italic string)) request_id
+ (* The formatting proper. *)
+ Format.kfprintf write formatter
+ ("%a %a%s %a%a @[" ^^ format_and_arguments ^^ "@]@.")
+ Fmt.(styled `Faint string)
+ time
+ Fmt.(styled `White string)
+ source_prefix source
+ Fmt.(styled level_style string)
+ level
+ Fmt.(styled request_style (styled `Italic string))
+ request_id
in
- {Logs.report}
-
-
+ { Logs.report }
(* Lazy initialization upon first use or call to initialize. *)
-let enable =
- ref true
-
-let level =
- ref Logs.Info
-
-let custom_log_levels : (string * Logs.level) list ref =
- ref []
-
-let sources : (string * Logs.src) list ref =
- ref []
-
-let set_printexc =
- ref true
-
-let set_async_exception_hook =
- ref true
-
+let enable = ref true
+let level = ref Logs.Info
+let custom_log_levels : (string * Logs.level) list ref = ref []
+let sources : (string * Logs.src) list ref = ref []
+let set_printexc = ref true
+let set_async_exception_hook = ref true
let _initialized = ref None
let to_logs_level l =
@@ -276,18 +245,21 @@ let to_logs_level l =
exception Logs_are_not_initialized
let setup_logs =
- "\nTo initialize logs with a default reporter, and set up Dream, \
- do the following:\
- \n If you are using MirageOS, use the Dream device in config.ml
- \n If you are using Lwt/Unix, execute `Dream.log_initialize ()`
- \n"
-
-let () = Printexc.register_printer @@ function
+ "\n\
+ To initialize logs with a default reporter, and set up Dream, do the \
+ following:\n\
+ \ If you are using MirageOS, use the Dream device in config.ml\n\
+ \ \n\
+ \ If you are using Lwt/Unix, execute `Dream.log_initialize ()`\n\
+ \ \n"
+
+let () =
+ Printexc.register_printer @@ function
| Logs_are_not_initialized ->
Some ("The default logger is not yet initialized. " ^ setup_logs)
| _ -> None
-let initialized () : [ `Initialized ] =
+let initialized () : [`Initialized] =
match !_initialized with
| None -> raise Logs_are_not_initialized
| Some v -> Lazy.force v
@@ -295,8 +267,10 @@ let initialized () : [ `Initialized ] =
(* The "front end." *)
type ('a, 'b) conditional_log =
((?request:Message.request ->
- ('a, Stdlib.Format.formatter, unit, 'b) Stdlib.format4 -> 'a) -> 'b) ->
- unit
+ ('a, Stdlib.Format.formatter, unit, 'b) Stdlib.format4 ->
+ 'a) ->
+ 'b) ->
+ unit
type sub_log = {
error : 'a. ('a, unit) conditional_log;
@@ -316,25 +290,27 @@ let sub_log ?level:level_ name =
let `Initialized = initialized () in
destination_log (fun log ->
- user's_k (fun ?request format_and_arguments ->
- let tags =
- 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
- in
- log ~tags format_and_arguments))
+ user's_k (fun ?request format_and_arguments ->
+ let tags =
+ 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)
+ in
+ log ~tags format_and_arguments))
in
let level =
- List.find Option.is_some [
- Option.map to_logs_level level_;
- List.assoc_opt name !custom_log_levels;
- Some !level
- ] in
+ List.find Option.is_some
+ [
+ Option.map to_logs_level level_;
+ List.assoc_opt name !custom_log_levels;
+ Some !level;
+ ]
+ in
(* Create the actual Logs source, and then wrap all the interesting
functions. *)
@@ -342,29 +318,26 @@ let sub_log ?level:level_ name =
let (module Log) = Logs.src_log src in
Logs.Src.set_level src level;
custom_log_levels :=
- (name, Option.get level)::(List.remove_assoc name !custom_log_levels);
- sources := (name, src) :: (List.remove_assoc name !sources);
+ (name, Option.get level) :: List.remove_assoc name !custom_log_levels;
+ sources := (name, src) :: List.remove_assoc name !sources;
{
- error = (fun k -> forward ~destination_log:Log.err k);
- warning = (fun k -> forward ~destination_log:Log.warn k);
- info = (fun k -> forward ~destination_log:Log.info k);
- debug = (fun k -> forward ~destination_log:Log.debug k);
+ error = (fun k -> forward ~destination_log:Log.err k);
+ warning = (fun k -> forward ~destination_log:Log.warn k);
+ info = (fun k -> forward ~destination_log:Log.info k);
+ debug = (fun k -> forward ~destination_log:Log.debug k);
}
-
-
let convenience_log format_and_arguments =
Fmt.kstr
(fun message ->
let `Initialized = initialized () in
Logs.app (fun log -> log "%s" message))
format_and_arguments
- (* Logs.app (fun log -> log format_and_arguments) *)
- (* let report = Logs.((reporter ()).report) in
- report Logs.default Logs.App ~over:ignore ignore format_and_arguments *)
-
+(* Logs.app (fun log -> log format_and_arguments) *)
+(* let report = Logs.((reporter ()).report) in
+ report Logs.default Logs.App ~over:ignore ignore format_and_arguments *)
(* A helper used in several places. *)
let iter_backtrace f backtrace =
@@ -373,32 +346,24 @@ let iter_backtrace f backtrace =
|> List.filter (fun line -> line <> "")
|> List.iter f
-
-
(* Use the above function to create a log source for Log's own middleware, the
same way any other middleware would. *)
-let log =
- sub_log "dream.log"
-
-
+let log = sub_log "dream.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))
+ 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)
- () =
-
+let initialize_log ?(backtraces = true) ?(async_exception_hook = true)
+ ?level:level_ ?enable:(enable_ = true) () =
if backtraces then
Printexc.record_backtrace true;
set_printexc := false;
@@ -408,8 +373,8 @@ let initialize_log
set_async_exception_hook := false;
let level_ =
- Option.map to_logs_level level_
- |> Option.value ~default:Logs.Info in
+ Option.map to_logs_level level_ |> Option.value ~default:Logs.Info
+ in
enable := enable_;
level := level_;
@@ -422,44 +387,44 @@ let set_log_level name level =
let `Initialized = initialized () in
let level = to_logs_level level in
custom_log_levels :=
- (name, level)::(List.remove_assoc name !custom_log_levels);
+ (name, level) :: List.remove_assoc name !custom_log_levels;
let src = List.assoc_opt name !sources in
Option.iter (fun s -> Logs.Src.set_level s (Some level)) src
-module Make (Pclock : Mirage_clock.PCLOCK) =
-struct
- let now () =
- Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ()))
-
- let initializer_ ~setup_outputs = lazy begin
- if !enable then begin
- setup_outputs () ;
- Logs.set_level ~all:true (Some !level);
- Logs.set_reporter (reporter ~now ())
- end ;
- `Initialized
- end
+module Make (Pclock : Mirage_clock.PCLOCK) = struct
+ let now () = Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ()))
+
+ let initializer_ ~setup_outputs =
+ lazy
+ begin
+ if !enable then begin
+ setup_outputs ();
+ Logs.set_level ~all:true (Some !level);
+ Logs.set_reporter (reporter ~now ())
+ end;
+ `Initialized
+ end
let set = ref false
let initialize ~setup_outputs =
- if !set then Logs.debug (fun log -> log
- "Dream__log.initialize has already been called, ignoring this call.")
+ if !set then
+ Logs.debug (fun log ->
+ log
+ "Dream__log.initialize has already been called, ignoring this call.")
else begin
(try
- let `Initialized = initialized () in
- Format.eprintf
- "Dream__log.initialized has already been set, check that this call \
- is intentional";
- with
- Logs_are_not_initialized -> ());
+ let `Initialized = initialized () in
+ Format.eprintf
+ "Dream__log.initialized has already been set, check that this call \
+ is intentional"
+ with Logs_are_not_initialized -> ());
set := true;
_initialized := Some (initializer_ ~setup_outputs)
end
(* The request logging middleware. *)
let logger next_handler request =
-
let start = now () in
(* Turn on backtrace recording. *)
@@ -481,22 +446,18 @@ struct
(* Identify the request in the log. *)
let user_agent =
- Message.headers request "User-Agent"
- |> String.concat " "
+ Message.headers request "User-Agent" |> String.concat " "
in
log.info (fun log ->
- log ~request "%s %s %s %s"
- (Method.method_to_string (Message.method_ request))
- (Message.target request)
- (Helpers.client request)
- user_agent);
+ log ~request "%s %s %s %s"
+ (Method.method_to_string (Message.method_ request))
+ (Message.target request) (Helpers.client request) user_agent);
(* Call the rest of the app. *)
Lwt.try_bind
(fun () ->
- Lwt.with_value id_lwt_key (Some id) (fun () ->
- next_handler request))
+ Lwt.with_value id_lwt_key (Some id) (fun () -> next_handler request))
(fun response ->
(* Log the elapsed time. If the response is a redirection, log the
target. *)
@@ -505,34 +466,32 @@ struct
match Message.header response "Location" with
| Some location -> " " ^ location
| None -> ""
- else ""
+ else
+ ""
in
let status = Message.status response in
let report :
- (?request:Message.request ->
- ('a, Format.formatter, unit, 'b) format4 -> 'a) -> 'b =
- fun log ->
+ (?request:Message.request ->
+ ('a, Format.formatter, unit, 'b) format4 ->
+ 'a) ->
+ 'b =
+ fun log ->
let elapsed = now () -. start in
log ~request "%i%s in %.0f μs"
(Status.status_to_int status)
- location
- (elapsed *. 1e6)
+ location (elapsed *. 1e6)
in
- begin
- if Status.is_server_error status then
- log.error report
- else
- if Status.is_client_error status then
- log.warning report
- else
- log.info report
- end;
+ if Status.is_server_error status then
+ log.error report
+ else if Status.is_client_error status then
+ log.warning report
+ else
+ log.info report;
Lwt.return response)
-
(fun exn ->
let backtrace = Printexc.get_backtrace () in
(* In case of exception, log the exception. We alsp log the backtrace
@@ -540,7 +499,7 @@ struct
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));
+ log ~request "Aborted by: %s" (Printexc.to_string exn));
backtrace
|> iter_backtrace (fun line -> log.warning (fun log -> log "%s" line));
@@ -548,8 +507,6 @@ struct
Lwt.fail exn)
end
-
-
(* TODO DOC Include logging itself in the timing. Or? Isn't that pointless?
End-to -end timing should include the HTTP parser as well. The logger
provides much more useful information if it helps the user optimize the app.
File "example/i-graphql/graphql.ml", line 1, characters 0-0:
diff --git a/_build/default/example/i-graphql/graphql.ml b/_build/default/example/i-graphql/.formatted/graphql.ml
index db6004d..caf74a1 100644
--- a/_build/default/example/i-graphql/graphql.ml
+++ b/_build/default/example/i-graphql/.formatted/graphql.ml
@@ -1,45 +1,49 @@
-type user = {id : int; name : string}
+type user = {
+ id : int;
+ name : string;
+}
-let hardcoded_users = [
- {id = 1; name = "alice"};
- {id = 2; name = "bob"};
-]
+let hardcoded_users = [{ id = 1; name = "alice" }; { id = 2; name = "bob" }]
let user =
- Graphql_lwt.Schema.(obj "user"
- ~fields:([
- field "id"
- ~typ:(non_null int)
- ~args:Arg.[]
- ~resolve:(fun _info user -> user.id);
- field "name"
- ~typ:(non_null string)
- ~args:Arg.[]
- ~resolve:(fun _info user -> user.name);
- ]))
+ Graphql_lwt.Schema.(
+ obj "user"
+ ~fields:
+ [
+ field "id" ~typ:(non_null int)
+ ~args:Arg.[]
+ ~resolve:(fun _info user -> user.id);
+ field "name" ~typ:(non_null string)
+ ~args:Arg.[]
+ ~resolve:(fun _info user -> user.name);
+ ])
let schema =
- Graphql_lwt.Schema.(schema [
- field "users"
- ~typ:(non_null (list (non_null user)))
- ~args:Arg.[arg "id" ~typ:int]
- ~resolve:(fun _info () id ->
- match id with
- | None -> hardcoded_users
- | Some id' ->
- match List.find_opt (fun {id; _} -> id = id') hardcoded_users with
- | None -> []
- | Some user -> [user]);
- ])
+ Graphql_lwt.Schema.(
+ schema
+ [
+ field "users"
+ ~typ:(non_null (list (non_null user)))
+ ~args:Arg.[arg "id" ~typ:int]
+ ~resolve:(fun _info () id ->
+ match id with
+ | None -> hardcoded_users
+ | Some id' -> (
+ match
+ List.find_opt (fun { id; _ } -> id = id') hardcoded_users
+ with
+ | None -> []
+ | Some user -> [user]));
+ ])
-let default_query =
- "{\\n users {\\n name\\n id\\n }\\n}\\n"
+let default_query = "{\\n users {\\n name\\n id\\n }\\n}\\n"
let () =
Dream.run
@@ Dream.logger
@@ Dream.origin_referrer_check
- @@ Dream.router [
- Dream.any "/graphql" (Dream.graphql Lwt.return schema);
- Dream.get "/" (Dream.graphiql ~default_query "/graphql");
- ]
+ @@ Dream.router
+ [
+ Dream.any "/graphql" (Dream.graphql Lwt.return schema);
+ Dream.get "/" (Dream.graphiql ~default_query "/graphql");
+ ]
File "example/w-query/query.ml", line 1, characters 0-0:
diff --git a/_build/default/example/w-query/query.ml b/_build/default/example/w-query/.formatted/query.ml
index 3d9b70c..e532c3f 100644
--- a/_build/default/example/w-query/query.ml
+++ b/_build/default/example/w-query/.formatted/query.ml
@@ -1,7 +1,5 @@
let () =
Dream.run (fun request ->
- match Dream.query request "echo" with
- | None ->
- Dream.html "Use ?echo=foo to give a message to echo!"
- | Some message ->
- Dream.html (Dream.html_escape message))
+ match Dream.query request "echo" with
+ | None -> Dream.html "Use ?echo=foo to give a message to echo!"
+ | Some message -> Dream.html (Dream.html_escape message))
File "example/w-tyxml/tyxml.ml", line 1, characters 0-0:
diff --git a/_build/default/example/w-tyxml/tyxml.ml b/_build/default/example/w-tyxml/.formatted/tyxml.ml
index 132996d..6bc41a4 100644
--- a/_build/default/example/w-tyxml/tyxml.ml
+++ b/_build/default/example/w-tyxml/.formatted/tyxml.ml
@@ -2,21 +2,12 @@ let greet who =
let open Tyxml.Html in
html
(head (title (txt "Greeting")) [])
- (body [
- h1 [
- txt "Good morning, "; txt who; txt "!";
- ]
- ])
+ (body [h1 [txt "Good morning, "; txt who; txt "!"]])
-let html_to_string html =
- Format.asprintf "%a" (Tyxml.Html.pp ()) html
+let html_to_string html = Format.asprintf "%a" (Tyxml.Html.pp ()) html
let () =
Dream.run
@@ Dream.logger
- @@ Dream.router [
-
- Dream.get "/"
- (fun _ -> Dream.html (html_to_string (greet "world")));
-
- ]
+ @@ Dream.router
+ [Dream.get "/" (fun _ -> Dream.html (html_to_string (greet "world")))]
File "test/expect/pure/message/message.ml", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/message/message.ml b/_build/default/test/expect/pure/message/.formatted/message.ml
index bbeae94..2994f24 100644
--- a/_build/default/test/expect/pure/message/message.ml
+++ b/_build/default/test/expect/pure/message/.formatted/message.ml
@@ -3,8 +3,6 @@
Copyright 2022 Anton Bachin *)
-
-
let%expect_test _ =
let handler _ =
print_endline "handler";
@@ -22,15 +20,10 @@ let%expect_test _ =
print_endline "outer middleware: response";
Lwt.return response
in
- let server =
- Dream.pipeline [
- outer_middleware;
- inner_middleware
- ]
- @@ handler
- in
+ let server = Dream.pipeline [outer_middleware; inner_middleware] @@ handler in
ignore (Lwt_main.run (server (Dream.request "")));
- [%expect {|
+ [%expect
+ {|
outer middleware: request
inner middleware: request
handler
File "test/expect/pure/method/method.ml", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/method/method.ml b/_build/default/test/expect/pure/method/.formatted/method.ml
index 15adce9..9ab20cf 100644
--- a/_build/default/test/expect/pure/method/method.ml
+++ b/_build/default/test/expect/pure/method/.formatted/method.ml
@@ -3,10 +3,7 @@
Copyright 2021 Anton Bachin *)
-
-
-let show method_ =
- Printf.printf "%S\n" (Dream.method_to_string method_)
+let show method_ = Printf.printf "%S\n" (Dream.method_to_string method_)
let%expect_test _ =
show `GET;
@@ -20,7 +17,8 @@ let%expect_test _ =
show `PATCH;
show (`Method "FOO");
show (`Method "");
- [%expect {|
+ [%expect
+ {|
"GET"
"POST"
"PUT"
@@ -51,7 +49,8 @@ let%expect_test _ =
of_string "";
of_string "get";
of_string "FOO";
- [%expect {|
+ [%expect
+ {|
"GET"
"POST"
"PUT"
@@ -68,10 +67,8 @@ let%expect_test _ =
let normalize method_ =
let result = Dream.normalize_method method_ in
match result with
- | `Method method_ ->
- Printf.printf "%S\n" method_
- | _ ->
- Printf.printf "`%s\n" (Dream.method_to_string result)
+ | `Method method_ -> Printf.printf "%S\n" method_
+ | _ -> Printf.printf "`%s\n" (Dream.method_to_string result)
let%expect_test _ =
normalize `GET;
@@ -93,7 +90,8 @@ let%expect_test _ =
normalize (`Method "TRACE");
normalize `PATCH;
normalize (`Method "PATCH");
- [%expect {|
+ [%expect
+ {|
`GET
`GET
"get"
@@ -125,7 +123,8 @@ let%expect_test _ =
equal `GET (`Method "GET");
equal (`Method "GET") `GET;
equal `GET (`Method "get");
- [%expect {|
+ [%expect
+ {|
true
true
false
File "example/w-mirage/unikernel.ml", line 1, characters 0-0:
diff --git a/_build/default/example/w-mirage/unikernel.ml b/_build/default/example/w-mirage/.formatted/unikernel.ml
index 6185164..3338596 100644
--- a/_build/default/example/w-mirage/unikernel.ml
+++ b/_build/default/example/w-mirage/.formatted/unikernel.ml
@@ -1,25 +1,29 @@
open Rresult
open Lwt.Infix
-let ( <.> ) f g = fun x -> f (g x)
+let ( <.> ) f g x = f (g x)
module Make
- (_ : Mirage_console.S)
- (Random : Mirage_random.S)
- (Time : Mirage_time.S)
- (Mclock : Mirage_clock.MCLOCK)
- (Pclock : Mirage_clock.PCLOCK)
- (Stack : Mirage_stack.V4V6) = struct
+ (_ : Mirage_console.S)
+ (Random : Mirage_random.S)
+ (Time : Mirage_time.S)
+ (Mclock : Mirage_clock.MCLOCK)
+ (Pclock : Mirage_clock.PCLOCK)
+ (Stack : Mirage_stack.V4V6) =
+struct
module Dream = Dream__mirage.Mirage.Make (Pclock) (Time) (Stack)
-
+
let echo request = Dream.html (Dream.param "word" request)
let ( >>? ) = Lwt_result.bind
-
+
let dream =
Dream.logger
@@ Dream.router
- [ Dream.get "/" (fun _ -> Dream.html "Good morning, world! (from MirageOS)")
- ; Dream.get "/echo/:word" echo ]
+ [
+ Dream.get "/" (fun _ ->
+ Dream.html "Good morning, world! (from MirageOS)");
+ Dream.get "/echo/:word" echo;
+ ]
module DNS = Dns_client_mirage.Make (Random) (Time) (Mclock) (Pclock) (Stack)
module Let = LE.Make (Time) (Stack)
@@ -28,35 +32,45 @@ module Make
let authenticator = R.failwith_error_msg (Nss.authenticator ())
- let gethostbyname dns domain_name = DNS.gethostbyname dns domain_name >>? fun ipv4 ->
+ let gethostbyname dns domain_name =
+ DNS.gethostbyname dns domain_name >>? fun ipv4 ->
Lwt.return_ok (Ipaddr.V4 ipv4)
let error_handler _ ?request:_ _ _ = ()
- let get_certificates ?(production= false) cfg stackv4v6 =
+ let get_certificates ?(production = false) cfg stackv4v6 =
Paf.init ~port:80 (Stack.tcp stackv4v6) >>= fun t ->
let service = Paf.http_service ~error_handler Let.request_handler in
Lwt_switch.with_switch @@ fun stop ->
- let `Initialized th = Paf.serve ~stop service t in
- let ctx = Let.ctx ~gethostbyname ~authenticator (DNS.create stackv4v6) stackv4v6 in
+ let (`Initialized th) = Paf.serve ~stop service t in
+ let ctx =
+ Let.ctx ~gethostbyname ~authenticator (DNS.create stackv4v6) stackv4v6
+ in
let fiber =
Let.provision_certificate ~production cfg ctx >>= fun certificates ->
- Lwt_switch.turn_off stop >>= fun () -> Lwt.return certificates in
+ Lwt_switch.turn_off stop >>= fun () -> Lwt.return certificates
+ in
Lwt.both th fiber >>= function
- | ((), Ok certificates) -> Lwt.return certificates
- | ((), Error (`Msg err)) -> failwith err
+ | (), Ok certificates -> Lwt.return certificates
+ | (), Error (`Msg err) -> failwith err
let https_with_letsencrypt stackv4v6 =
let cfg =
- { LE.certificate_seed= Key_gen.cert_seed ()
- ; LE.certificate_key_type= `ED25519
- ; LE.certificate_key_bits= None
- ; LE.email= Option.bind (Key_gen.email ()) (R.to_option <.> Emile.of_string)
- ; LE.account_seed= Key_gen.account_seed ()
- ; LE.account_key_type= `ED25519
- ; LE.account_key_bits= None
- ; LE.hostname= Domain_name.(host_exn <.> of_string_exn) (Key_gen.hostname ()) } in
- get_certificates ~production:(Key_gen.production ()) cfg stackv4v6 >>= fun certificates ->
+ {
+ LE.certificate_seed = Key_gen.cert_seed ();
+ LE.certificate_key_type = `ED25519;
+ LE.certificate_key_bits = None;
+ LE.email =
+ Option.bind (Key_gen.email ()) (R.to_option <.> Emile.of_string);
+ LE.account_seed = Key_gen.account_seed ();
+ LE.account_key_type = `ED25519;
+ LE.account_key_bits = None;
+ LE.hostname =
+ Domain_name.(host_exn <.> of_string_exn) (Key_gen.hostname ());
+ }
+ in
+ get_certificates ~production:(Key_gen.production ()) cfg stackv4v6
+ >>= fun certificates ->
let tls = Tls.Config.server ~certificates () in
Dream.https ~port:(Key_gen.port ()) (Stack.tcp stackv4v6) ~cfg:tls dream
@@ -67,7 +81,7 @@ module Make
Dream.http ~port:(Key_gen.port ()) (Stack.tcp stackv4v6) dream
let start _console () () () () stackv4v6 =
- match Key_gen.tls (), Key_gen.letsencrypt () with
+ match (Key_gen.tls (), Key_gen.letsencrypt ()) with
| true, true -> https_with_letsencrypt stackv4v6
| true, false -> https stackv4v6
| false, _ -> http stackv4v6
File "test/ocamlformat/test.ml", line 1, characters 0-0:
diff --git a/_build/default/test/ocamlformat/test.ml b/_build/default/test/ocamlformat/.formatted/test.ml
index 45ccba5..306d701 100644
--- a/_build/default/test/ocamlformat/test.ml
+++ b/_build/default/test/ocamlformat/.formatted/test.ml
@@ -5,11 +5,12 @@ type t = {
c : string;
}
-let t = {
- a = "a_pretty_long_string_to_force_separate_line";
- b = "a_pretty_long_string_to_force_separate_line";
- c = "a_pretty_long_string_to_force_separate_line";
-}
+let t =
+ {
+ a = "a_pretty_long_string_to_force_separate_line";
+ b = "a_pretty_long_string_to_force_separate_line";
+ c = "a_pretty_long_string_to_force_separate_line";
+ }
type t =
| A of int
@@ -18,23 +19,19 @@ type t =
(* Failure: the bracket is set on the first line rather than having unifrom
lines. *)
-type t = [
- | `A of int
+type t =
+ [ `A of int
| `B of string
- | `C of unit
-]
+ | `C of unit ]
-let list = [
- a;
- b;
- c;
-]
+let list = [a; b; c]
-let list = [
- a_very_long_identifier_or_expression_one;
- a_very_long_identifier_or_expression_two;
- a_very_long_identifier_or_expression_three;
-]
+let list =
+ [
+ a_very_long_identifier_or_expression_one;
+ a_very_long_identifier_or_expression_two;
+ a_very_long_identifier_or_expression_three;
+ ]
let bool =
match true with
@@ -50,12 +47,12 @@ let () =
(* Failure: begin...end indented strangely. *)
let () =
match true with
- | true ->
- begin match () with
+ | true -> begin
+ match () with
| () ->
print_endline "foo";
print_endline "bar"
- end
+ end
| () ->
print_endline "foo";
print_endline "bar"
File "src/dream.mli", line 1, characters 0-0:
diff --git a/_build/default/src/dream.mli b/_build/default/src/.formatted/dream.mli
index ca9e083..415b3f1 100644
--- a/_build/default/src/dream.mli
+++ b/_build/default/src/.formatted/dream.mli
@@ -3,8 +3,6 @@
Copyright 2021 Anton Bachin *)
-
-
(** {1 Types}
Dream is built on just five types. The first two are the data types of
@@ -97,7 +95,6 @@ and route
{!Dream.scope} implements a left distributive law, making Dream a ring-like
structure. *)
-
(** {2 Helpers} *)
and 'a message = 'a Dream_pure.Message.message
@@ -110,6 +107,7 @@ and 'a message = 'a Dream_pure.Message.message
]} *)
and client = Dream_pure.Message.client
+
and server = Dream_pure.Message.server
(** Type parameters for {!message} for {!type-request} and {!type-response},
respectively. These are “phantom” types. They have no meaning other than
@@ -132,12 +130,10 @@ and 'a promise = 'a Lwt.t
exception backtrace — though, in most cases, you should still extend it with
[raise] and [let%lwt], instead. *)
-
-
(** {1 Methods} *)
-type method_ = [
- | `GET
+type method_ =
+ [ `GET
| `POST
| `PUT
| `DELETE
@@ -146,14 +142,13 @@ type method_ = [
| `OPTIONS
| `TRACE
| `PATCH
- | `Method of string
-]
+ | `Method of string ]
(** HTTP request methods. See
{{:https://tools.ietf.org/html/rfc7231#section-4.3} RFC 7231 §4.2},
{{:https://tools.ietf.org/html/rfc5789#page-2} RFC 5789 §2}, and
{{:https://developer.mozilla.org/en-US/docs/Web/HTTP/Methods} MDN}. *)
-val method_to_string : [< method_ ] -> string
+val method_to_string : [< method_] -> string
(** Evaluates to a string representation of the given method. For example,
[`GET] is converted to ["GET"]. *)
@@ -161,7 +156,7 @@ val string_to_method : string -> method_
(** Evaluates to the {!type-method_} corresponding to the given method
string. *)
-val methods_equal : [< method_ ] -> [< method_ ] -> bool
+val methods_equal : [< method_] -> [< method_] -> bool
(** Compares two methods, such that equal methods are detected even if one is
represented as a string. For example,
@@ -169,7 +164,7 @@ val methods_equal : [< method_ ] -> [< method_ ] -> bool
Dream.methods_equal `GET (`Method "GET") = true
]} *)
-val normalize_method : [< method_ ] -> method_
+val normalize_method : [< method_] -> method_
(** Converts methods represented as strings to variants. Methods generated by
Dream are always normalized.
@@ -177,44 +172,39 @@ val normalize_method : [< method_ ] -> method_
Dream.normalize_method (`Method "GET") = `GET
]} *)
-
-
(** {1:status_codes Status codes} *)
-type informational = [
- | `Continue
- | `Switching_Protocols
-]
+type informational =
+ [ `Continue
+ | `Switching_Protocols ]
(** Informational ([1xx]) status codes. See
{{:https://tools.ietf.org/html/rfc7231#section-6.2} RFC 7231 §6.2} and
{{:https://developer.mozilla.org/en-US/docs/Web/HTTP/Status#information_responses}
MDN}. [101 Switching Protocols] is generated internally by
{!Dream.val-websocket}. It is usually not necessary to use it directly. *)
-type successful = [
- | `OK
+type successful =
+ [ `OK
| `Created
| `Accepted
| `Non_Authoritative_Information
| `No_Content
| `Reset_Content
- | `Partial_Content
-]
+ | `Partial_Content ]
(** Successful ([2xx]) status codes. See
{{:https://tools.ietf.org/html/rfc7231#section-6.3} RFC 7231 §6.3},
{{:https://tools.ietf.org/html/rfc7233#section-4.1} RFC 7233 §4.1} and
{{:https://developer.mozilla.org/en-US/docs/Web/HTTP/Status#successful_responses}
MDN}. The most common is [200 OK]. *)
-type redirection = [
- | `Multiple_Choices
+type redirection =
+ [ `Multiple_Choices
| `Moved_Permanently
| `Found
| `See_Other
| `Not_Modified
| `Temporary_Redirect
- | `Permanent_Redirect
-]
+ | `Permanent_Redirect ]
(** Redirection ([3xx]) status codes. See
{{:https://tools.ietf.org/html/rfc7231#section-6.4} RFC 7231 §6.4} and
{{:https://tools.ietf.org/html/rfc7538#section-3} RFC 7538 §3}, and
@@ -223,8 +213,8 @@ type redirection = [
request, especially after a form submission. Use [301 Moved Permanently]
for permanent redirections. *)
-type client_error = [
- | `Bad_Request
+type client_error =
+ [ `Bad_Request
| `Unauthorized
| `Payment_Required
| `Forbidden
@@ -248,8 +238,7 @@ type client_error = [
| `Precondition_Required
| `Too_Many_Requests
| `Request_Header_Fields_Too_Large
- | `Unavailable_For_Legal_Reasons
-]
+ | `Unavailable_For_Legal_Reasons ]
(** Client error ([4xx]) status codes. The most common are [400 Bad Request],
[401 Unauthorized], [403 Forbidden], and, of course, [404 Not Found].
@@ -271,73 +260,70 @@ type client_error = [
- {{:https://tools.ietf.org/html/rfc7725} RFC 7725} for
[451 Unavailable For Legal Reasons]. *)
-type server_error = [
- | `Internal_Server_Error
+type server_error =
+ [ `Internal_Server_Error
| `Not_Implemented
| `Bad_Gateway
| `Service_Unavailable
| `Gateway_Timeout
- | `HTTP_Version_Not_Supported
-]
+ | `HTTP_Version_Not_Supported ]
(** Server error ([5xx]) status codes. See
{{:https://tools.ietf.org/html/rfc7231#section-6.6} RFC 7231 §6.6} and
{{:https://developer.mozilla.org/en-US/docs/Web/HTTP/Status#server_error_responses}
MDN}. The most common of these is [500 Internal Server Error]. *)
-type standard_status = [
- | informational
+type standard_status =
+ [ informational
| successful
| redirection
| client_error
- | server_error
-]
+ | server_error ]
(** Sum of all the status codes declared above. *)
-type status = [
- | standard_status
- | `Status of int
-]
+type status =
+ [ standard_status
+ | `Status of int ]
(** Status codes, including codes directly represented as integers. See the
types above for the full list and references. *)
-val status_to_string : [< status ] -> string
+val status_to_string : [< status] -> string
(** Evaluates to a string representation of the given status. For example,
[`Not_Found] and [`Status 404] are both converted to ["Not Found"]. Numbers
are used for unknown status codes. For example, [`Status 567] is converted
to ["567"]. *)
-val status_to_reason : [< status ] -> string option
+val status_to_reason : [< status] -> string option
(** Converts known status codes to their string representations. Evaluates to
[None] for unknown status codes. *)
-val status_to_int : [< status ] -> int
+val status_to_int : [< status] -> int
(** Evaluates to the numeric value of the given status code. *)
val int_to_status : int -> status
(** Evaluates to the symbolic representation of the status code with the given
number. *)
-val is_informational : [< status ] -> bool
+val is_informational : [< status] -> bool
(** Evaluates to [true] if the given status is either from type
{!Dream.informational}, or is in the range [`Status 100] — [`Status 199]. *)
-val is_successful : [< status ] -> bool
+val is_successful : [< status] -> bool
(** Like {!Dream.is_informational}, but for type {!Dream.successful} and numeric
codes [2xx]. *)
-val is_redirection : [< status ] -> bool
+val is_redirection : [< status] -> bool
(** Like {!Dream.is_informational}, but for type {!Dream.redirection} and
numeric codes [3xx]. *)
-val is_client_error : [< status ] -> bool
+val is_client_error : [< status] -> bool
(** Like {!Dream.is_informational}, but for type {!Dream.client_error} and
numeric codes [4xx]. *)
-val is_server_error : [< status ] -> bool
+val is_server_error : [< status] -> bool
(** Like {!Dream.is_informational}, but for type {!Dream.server_error} and
numeric codes [5xx]. *)
-val status_codes_equal : [< status ] -> [< status ] -> bool
+val status_codes_equal : [< status] -> [< status] -> bool
(** Compares two status codes, such that equal codes are detected even if one is
represented as a number. For example,
@@ -345,7 +331,7 @@ val status_codes_equal : [< status ] -> [< status ] -> bool
Dream.status_codes_equal `Not_Found (`Status 404) = true
]} *)
-val normalize_status : [< status ] -> status
+val normalize_status : [< status] -> status
(** Converts status codes represented as numbers to variants. Status codes
generated by Dream are always normalized.
@@ -353,8 +339,6 @@ val normalize_status : [< status ] -> status
Dream.normalize_status (`Status 404) = `Not_Found
]} *)
-
-
(** {1 Requests} *)
val client : request -> string
@@ -370,16 +354,19 @@ val target : request -> string
(** Request target. For example, ["/foo/bar"]. *)
(**/**)
+
val prefix : request -> string
+
(**/**)
(**/**)
+
val path : request -> string list
-[@@ocaml.deprecated
-"Router path access is being removed from the API. Comment at
-https://github.com/aantron/dream/issues
-"]
+ [@@ocaml.deprecated
+ "Router path access is being removed from the API. Comment at\n\
+ https://github.com/aantron/dream/issues\n"]
(** Parsed request path. For example, ["foo"; "bar"]. *)
+
(* TODO If not removing this, move it to section Routing. *)
(**/**)
@@ -387,31 +374,34 @@ val set_client : request -> string -> unit
(** Replaces the client. See {!Dream.val-client}. *)
(**/**)
+
val with_client : string -> request -> request
-[@@ocaml.deprecated
-"Use Dream.set_client. See
-https://aantron.github.io/dream/#val-set_client
-"]
+ [@@ocaml.deprecated
+ "Use Dream.set_client. See\n\
+ https://aantron.github.io/dream/#val-set_client\n"]
+
(**/**)
-val set_method_ : request -> [< method_ ] -> unit
+val set_method_ : request -> [< method_] -> unit
(** Replaces the method. See {!Dream.type-method_}. *)
(**/**)
-val with_method_ : [< method_ ] -> request -> request
-[@@ocaml.deprecated
-"Use Dream.set_method_. See
-https://aantron.github.io/dream/#val-set_method_
-"]
+
+val with_method_ : [< method_] -> request -> request
+ [@@ocaml.deprecated
+ "Use Dream.set_method_. See\n\
+ https://aantron.github.io/dream/#val-set_method_\n"]
+
(**/**)
(**/**)
+
val with_path : string list -> request -> request
-[@@ocaml.deprecated
-"Router path access is being removed from the API. Comment at
-https://github.com/aantron/dream/issues
-"]
+ [@@ocaml.deprecated
+ "Router path access is being removed from the API. Comment at\n\
+ https://github.com/aantron/dream/issues\n"]
(** Replaces the path. See {!Dream.val-path}. *)
+
(**/**)
val query : request -> string -> string option
@@ -427,15 +417,14 @@ val queries : request -> string -> string list
val all_queries : request -> (string * string) list
(** Entire query string as a name-value list. *)
-
-
(** {1 Responses} *)
val response :
- ?status:[< status ] ->
+ ?status:[< status] ->
?code:int ->
?headers:(string * string) list ->
- string -> response
+ string ->
+ response
(** Creates a new {!type-response} with the given string as body. [~code] and
[~status] are two ways to specify the {!type-status} code, which is [200 OK]
by default. The headers are empty by default.
@@ -448,18 +437,20 @@ val response :
[text/html; charset=utf-8]. See {!Dream.text_html}. *)
val respond :
- ?status:[< status ] ->
+ ?status:[< status] ->
?code:int ->
?headers:(string * string) list ->
- string -> response promise
+ string ->
+ response promise
(** Same as {!Dream.val-response}, but the new {!type-response} is wrapped in a
{!type-promise}. *)
val html :
- ?status:[< status ] ->
+ ?status:[< status] ->
?code:int ->
?headers:(string * string) list ->
- string -> response promise
+ string ->
+ response promise
(** Same as {!Dream.respond}, but adds [Content-Type: text/html; charset=utf-8].
See {!Dream.text_html}.
@@ -470,18 +461,21 @@ val html :
they can provide an extra layer of defense for a mature app. *)
val json :
- ?status:[< status ] ->
+ ?status:[< status] ->
?code:int ->
?headers:(string * string) list ->
- string -> response promise
+ string ->
+ response promise
(** Same as {!Dream.respond}, but adds [Content-Type: application/json]. See
{!Dream.application_json}. *)
val redirect :
- ?status:[< redirection ] ->
+ ?status:[< redirection] ->
?code:int ->
?headers:(string * string) list ->
- request -> string -> response promise
+ request ->
+ string ->
+ response promise
(** 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
@@ -493,9 +487,7 @@ val redirect :
The {!type-request} is used for retrieving the site prefix, if the string is
an absolute path. Most applications don't have a site prefix. *)
-val empty :
- ?headers:(string * string) list ->
- status -> response promise
+val empty : ?headers:(string * string) list -> status -> response promise
(** Same as {!Dream.val-response} with the empty string for a body. *)
val status : response -> status
@@ -504,8 +496,6 @@ val status : response -> status
val set_status : response -> status -> unit
(** Sets the response status. *)
-
-
(** {1 Headers} *)
val header : 'a message -> string -> string option
@@ -534,14 +524,13 @@ val set_header : 'a message -> string -> string -> unit
(** Equivalent to {!Dream.drop_header} followed by {!Dream.add_header}. *)
(**/**)
-val with_header : string -> string -> 'a message -> 'a message
-[@@ocaml.deprecated
-"Use Dream.set_header. See
-https://aantron.github.io/dream/#val-with_header
-"]
-(**/**)
+val with_header : string -> string -> 'a message -> 'a message
+ [@@ocaml.deprecated
+ "Use Dream.set_header. See\n\
+ https://aantron.github.io/dream/#val-with_header\n"]
+(**/**)
(** {1 Cookies}
@@ -569,7 +558,7 @@ __Host-my.cookie=AL7NLA8-so3e47uy0R5E2MpEQ0TtTWztdhq5pTEUT7KSFg; \
{!Dream.cookie} to automatically undo the result. *)
val set_cookie :
- ?prefix:[< `Host | `Secure ] option ->
+ ?prefix:[< `Host | `Secure] option ->
?encrypt:bool ->
?expires:float ->
?max_age:float ->
@@ -577,8 +566,12 @@ val set_cookie :
?path:string option ->
?secure:bool ->
?http_only:bool ->
- ?same_site:[< `Strict | `Lax | `None ] option ->
- response -> request -> string -> string -> unit
+ ?same_site:[< `Strict | `Lax | `None] option ->
+ response ->
+ request ->
+ string ->
+ string ->
+ unit
(** Appends a [Set-Cookie:] header to the {!type-response}. Infers the most
secure defaults from the {!type-request}.
@@ -655,14 +648,17 @@ val set_cookie :
{!Dream.to_set_cookie} is a “raw” version of this function that does not do
any inference. *)
- val drop_cookie :
- ?prefix:[< `Host | `Secure ] option ->
- ?domain:string ->
- ?path:string option ->
- ?secure:bool ->
- ?http_only:bool ->
- ?same_site:[< `Strict | `Lax | `None ] option ->
- response -> request -> string -> unit
+val drop_cookie :
+ ?prefix:[< `Host | `Secure] option ->
+ ?domain:string ->
+ ?path:string option ->
+ ?secure:bool ->
+ ?http_only:bool ->
+ ?same_site:[< `Strict | `Lax | `None] option ->
+ response ->
+ request ->
+ string ->
+ unit
(** Deletes the given cookie.
This function works by calling {!Dream.set_cookie}, and setting the cookie
@@ -670,12 +666,14 @@ val set_cookie :
to {!Dream.set_cookie} to make sure that the same cookie is deleted. *)
val cookie :
- ?prefix:[< `Host | `Secure ] option ->
+ ?prefix:[< `Host | `Secure] option ->
?decrypt:bool ->
?domain:string ->
?path:string option ->
?secure:bool ->
- request -> string -> string option
+ request ->
+ string ->
+ string option
(** First cookie with the given name. See example
{{:https://github.com/aantron/dream/tree/master/example/c-cookie#files}
[c-cookie]}.
@@ -692,8 +690,6 @@ val cookie :
val all_cookies : request -> (string * string) list
(** All cookies, with raw names and values. *)
-
-
(** {1 Bodies} *)
val body : 'a message -> string promise
@@ -705,14 +701,12 @@ val set_body : 'a message -> string -> unit
(** Replaces the body. *)
(**/**)
-val with_body : string -> response -> response
-[@@ocaml.deprecated
-"Use Dream.set_body. See
-https://aantron.github.io/dream/#val-set_body
-"]
-(**/**)
+val with_body : string -> response -> response
+ [@@ocaml.deprecated
+ "Use Dream.set_body. See\nhttps://aantron.github.io/dream/#val-set_body\n"]
+(**/**)
(** {1 Streams} *)
@@ -723,11 +717,12 @@ val body_stream : request -> stream
(** A stream that can be used to gradually read the request's body. *)
val stream :
- ?status:[< status ] ->
+ ?status:[< status] ->
?code:int ->
?headers:(string * string) list ->
?close:bool ->
- (stream -> unit promise) -> response promise
+ (stream -> unit promise) ->
+ response promise
(** 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}
@@ -750,11 +745,12 @@ val read : stream -> string option promise
WebSocket. *)
(**/**)
+
val with_stream : response -> response
-[@@ocaml.deprecated
-"Use Dream.stream instead. See
-https://aantron.github.io/dream/#val-set_stream
-"]
+ [@@ocaml.deprecated
+ "Use Dream.stream instead. See\n\
+ https://aantron.github.io/dream/#val-set_stream\n"]
+
(**/**)
val write : stream -> string -> unit promise
@@ -795,7 +791,7 @@ val read_stream :
pong:(buffer -> int -> int -> unit) ->
close:(int -> unit) ->
exn:(exn -> unit) ->
- unit
+ unit
(** Waits for the next stream event, and calls:
- [~data] with an offset and length, if a {!type-buffer} is received,
@@ -807,12 +803,15 @@ val read_stream :
val write_stream :
stream ->
- buffer -> int -> int ->
- bool -> bool ->
+ buffer ->
+ int ->
+ int ->
+ bool ->
+ bool ->
close:(int -> unit) ->
exn:(exn -> unit) ->
(unit -> unit) ->
- unit
+ unit
(** Writes a {!type-buffer} into the stream:
{[
@@ -833,31 +832,31 @@ val write_stream :
streams. *)
val flush_stream :
- stream ->
- close:(int -> unit) ->
- exn:(exn -> unit) ->
- (unit -> unit) ->
- unit
+ stream -> close:(int -> unit) -> exn:(exn -> unit) -> (unit -> unit) -> unit
(** Requests the stream be flushed. The callbacks have the same meaning as in
{!write_stream}. *)
val ping_stream :
stream ->
- buffer -> int -> int ->
+ buffer ->
+ int ->
+ int ->
close:(int -> unit) ->
exn:(exn -> unit) ->
(unit -> unit) ->
- unit
+ unit
(** Sends a ping frame on the WebSocket stream. The buffer is typically empty,
but may contain up to 125 bytes of data. *)
val pong_stream :
stream ->
- buffer -> int -> int ->
+ buffer ->
+ int ->
+ int ->
close:(int -> unit) ->
exn:(exn -> unit) ->
(unit -> unit) ->
- unit
+ unit
(** Like {!ping_stream}, but sends a pong event. *)
val close_stream : stream -> int -> unit
@@ -869,18 +868,17 @@ val abort_stream : stream -> exn -> unit
exception. *)
(**/**)
+
val write_buffer :
?offset:int -> ?length:int -> response -> buffer -> unit promise
-[@@ocaml.deprecated
-"Use Dream.write_stream. See
-https://aantron.github.io/dream/#val-write_stream
-"]
+ [@@ocaml.deprecated
+ "Use Dream.write_stream. See\n\
+ https://aantron.github.io/dream/#val-write_stream\n"]
+
(**/**)
(* TODO Ergonomics of this stream surface API. *)
-
-
(** {1 WebSockets} *)
type websocket
@@ -891,7 +889,8 @@ type websocket
val websocket :
?headers:(string * string) list ->
?close:bool ->
- (websocket -> unit promise) -> response promise
+ (websocket -> unit promise) ->
+ response promise
(** 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
@@ -908,16 +907,22 @@ val websocket :
returns or raises an exception. Pass [~close:false] to suppress this
behavior. *)
-type text_or_binary = [ `Text | `Binary ]
+type text_or_binary =
+ [ `Text
+ | `Binary ]
(** See {!send} and {!receive_fragment}. *)
-type end_of_message = [ `End_of_message | `Continues ]
+type end_of_message =
+ [ `End_of_message
+ | `Continues ]
(** See {!send} and {!receive_fragment}. *)
val send :
- ?text_or_binary:[< text_or_binary ] ->
- ?end_of_message:[< end_of_message ] ->
- websocket -> string -> unit promise
+ ?text_or_binary:[< text_or_binary] ->
+ ?end_of_message:[< end_of_message] ->
+ websocket ->
+ string ->
+ unit promise
(** Sends a single WebSocket message. The WebSocket is ready another message
when the promise resolves.
@@ -946,8 +951,6 @@ val close_websocket : ?code:int -> websocket -> unit promise
some protocols based on WebSockets. See
{{:https://tools.ietf.org/html/rfc6455#section-7.4} RFC 6455 §7.4}. *)
-
-
(** {1 JSON}
Dream presently recommends using
@@ -984,8 +987,6 @@ val origin_referrer_check : middleware
send them to the client (for instance, in [<meta>] tags of a single-page
application), and require their presence in an [X-CSRF-Token:] header. *)
-
-
(** {1 Forms}
{!Dream.csrf_tag} and {!Dream.val-form} round-trip secure forms.
@@ -1011,15 +1012,14 @@ val origin_referrer_check : middleware
{{:https://github.com/aantron/dream/tree/master/example/d-form#files}
[d-form]} \[{{:http://dream.as/d-form} playground}\]. *)
-type 'a form_result = [
- | `Ok of 'a
- | `Expired of 'a * float
+type 'a form_result =
+ [ `Ok of 'a
+ | `Expired of 'a * float
| `Wrong_session of 'a
| `Invalid_token of 'a
| `Missing_token of 'a
- | `Many_tokens of 'a
- | `Wrong_content_type
-]
+ | `Many_tokens of 'a
+ | `Wrong_content_type ]
(** Form CSRF checking results, in order from least to most severe. See
{!Dream.val-form} and example
{{:https://github.com/aantron/dream/tree/master/example/d-form#files}
@@ -1077,8 +1077,7 @@ val form : ?csrf:bool -> request -> (string * string) list form_result promise
(** {2 Upload} *)
-type multipart_form =
- (string * ((string option * string) list)) list
+type multipart_form = (string * (string option * string) list) list
(** Submitted file upload forms, [<form enctype="multipart/form-data">]. For
example, if a form
@@ -1146,7 +1145,7 @@ val multipart : ?csrf:bool -> request -> multipart_form form_result promise
(** {2 Streaming uploads} *)
-type part = string option * string option * ((string * string) list)
+type part = string option * string option * (string * string) list
(** Upload form parts.
A value [Some (name, filename, headers)] received by {!Dream.val-upload}
@@ -1192,12 +1191,11 @@ val upload_part : request -> string option promise
{{:https://cheatsheetseries.owasp.org/cheatsheets/Cross-Site_Request_Forgery_Prevention_Cheat_Sheet.html}
OWASP {i Cross-Site Request Forgery Prevention Cheat Sheet}}. *)
-type csrf_result = [
- | `Ok
+type csrf_result =
+ [ `Ok
| `Expired of float
| `Wrong_session
- | `Invalid
-]
+ | `Invalid ]
(** CSRF token verification outcomes.
[`Expired] and [`Wrong_session] can occur in normal usage, when a user's
@@ -1220,8 +1218,6 @@ val csrf_token : ?valid_for:float -> request -> string
val verify_csrf_token : request -> string -> csrf_result promise
(** Checks that the CSRF token is valid for the {!type-request}'s session. *)
-
-
(** {1 Templates}
Dream includes a template preprocessor that allows interleaving OCaml and
@@ -1333,16 +1329,17 @@ val csrf_tag : request -> string
tag, to prevent certain kinds of DOM manipulation-based attacks. *)
(**/**)
+
val form_tag :
- ?method_:[< method_ ] ->
- ?target:string ->
- ?enctype:[< `Multipart_form_data ] ->
- ?csrf_token:bool ->
- action:string -> request -> string
-[@ocaml.deprecated
-"Use Dream.csrf_tag. See
-https://aantron.github.io/dream/#val-csrf_tag
-"]
+ (?method_:[< method_] ->
+ ?target:string ->
+ ?enctype:[< `Multipart_form_data] ->
+ ?csrf_token:bool ->
+ action:string ->
+ request ->
+ string
+ [@ocaml.deprecated
+ "Use Dream.csrf_tag. See\nhttps://aantron.github.io/dream/#val-csrf_tag\n"])
(** Generates a [<form>] tag and an [<input>] tag with a CSRF token, suitable
for use with {!Dream.val-form} and {!Dream.val-multipart}. For example, in
a template,
@@ -1370,9 +1367,8 @@ https://aantron.github.io/dream/#val-csrf_tag
Pass [~enctype:`Multipart_form_data] for a file upload form.
[~csrf_token:false] suppresses generation of the [dream.csrf] field. *)
-(**/**)
-
+(**/**)
(** {1 Middleware}
@@ -1427,8 +1423,6 @@ val set_server_stream : request -> stream -> unit
(** Replaces the stream that the server will use when it receives the
request. *)
-
-
(** {1 Routing} *)
val router : route list -> handler
@@ -1468,24 +1462,25 @@ val router : route list -> handler
because, in the future, it may be possible to query routes for site
structure metadata. *)
-val get : string -> handler -> route
+val get : string -> handler -> route
(** Forwards [`GET] requests for the given path to the handler.
{[
Dream.get "/home" home_template
]} *)
-val post : string -> handler -> route
-val put : string -> handler -> route
-val delete : string -> handler -> route
-val head : string -> handler -> route
+val post : string -> handler -> route
+val put : string -> handler -> route
+val delete : string -> handler -> route
+val head : string -> handler -> route
val connect : string -> handler -> route
val options : string -> handler -> route
-val trace : string -> handler -> route
-val patch : string -> handler -> route
+val trace : string -> handler -> route
+
+val patch : string -> handler -> route
(** Like {!Dream.get}, but for each of the other {{!type-method_} methods}. *)
-val any : string -> handler -> route
+val any : string -> handler -> route
(** Like {!Dream.get}, but does not check the method. *)
val not_found : handler
@@ -1538,13 +1533,9 @@ val no_route : route
]
]} *)
-
-
(** {1 Static files} *)
-val static :
- ?loader:(string -> string -> handler) ->
- string -> handler
+val static : ?loader:(string -> string -> handler) -> string -> handler
(** Serves static files from a local directory. See example
{{:https://github.com/aantron/dream/tree/master/example/f-static#files}
[f-static]}.
@@ -1595,8 +1586,6 @@ val mime_lookup : string -> (string * string) list
However, if the result is [text/html], {!Dream.mime_lookup} replaces it with
[text/html; charset=utf-8], so as to match {!Dream.html}. *)
-
-
(** {1 Sessions}
Dream's default sessions contain string-to-string dictionaries for
@@ -1635,11 +1624,13 @@ val session_field : request -> string -> string option
(** Value from the request's session. *)
(**/**)
-val session : string -> request -> string option
-[@ocaml.deprecated
-"Renamed to Dream.session_field. See
-https://aantron.github.io/dream/#val-session_field
-"]
+
+val session :
+ (string -> request -> string option
+ [@ocaml.deprecated
+ "Renamed to Dream.session_field. See\n\
+ https://aantron.github.io/dream/#val-session_field\n"])
+
(**/**)
val set_session_field : request -> string -> string -> unit promise
@@ -1647,22 +1638,26 @@ val set_session_field : request -> string -> string -> unit promise
to storage immediately, so this function returns a promise. *)
(**/**)
-val put_session : string -> string -> request -> unit promise
-[@ocaml.deprecated
-"Renamed to Dream.set_session_field. See
-https://aantron.github.io/dream/#val-set_session_field
-"]
+
+val put_session :
+ (string -> string -> request -> unit promise
+ [@ocaml.deprecated
+ "Renamed to Dream.set_session_field. See\n\
+ https://aantron.github.io/dream/#val-set_session_field\n"])
+
(**/**)
val all_session_fields : request -> (string * string) list
(** Full session dictionary. *)
(**/**)
-val all_session_values : request -> (string * string) list
-[@ocaml.deprecated
-"Renamed to Dream.all_session_fields. See
-https://aantron.github.io/dream/#val-all_session_fields
-"]
+
+val all_session_values :
+ (request -> (string * string) list
+ [@ocaml.deprecated
+ "Renamed to Dream.all_session_fields. See\n\
+ https://aantron.github.io/dream/#val-all_session_fields\n"])
+
(**/**)
val invalidate_session : request -> unit promise
@@ -1703,8 +1698,6 @@ val session_label : request -> string
val session_expires_at : request -> float
(** Time at which the session will expire. *)
-
-
(** {1 Flash messages}
Flash messages are short strings which are stored in cookies during one
@@ -1723,14 +1716,13 @@ val add_flash_message : request -> string -> string -> unit
(** Adds a flash message to the request. *)
(**/**)
-val put_flash : request -> string -> string -> unit
-[@@ocaml.deprecated
-"Renamed to Dream.add_flash_message. See
-https://aantron.github.io/dream/#val-add_flash_message
-"]
-(**/**)
+val put_flash : request -> string -> string -> unit
+ [@@ocaml.deprecated
+ "Renamed to Dream.add_flash_message. See\n\
+ https://aantron.github.io/dream/#val-add_flash_message\n"]
+(**/**)
(** {1 GraphQL}
@@ -1807,8 +1799,6 @@ val graphiql : ?default_query:string -> string -> handler
Use {!Dream.no_route} to disable GraphiQL conditionally outside of
development. *)
-
-
(** {1 SQL}
Dream provides thin convenience functions over
@@ -1858,8 +1848,6 @@ val sql : request -> (Caqti_lwt.connection -> 'a promise) -> 'a promise
(* ... *) |> Dream.html)
]} *)
-
-
(** {1 Logging}
Dream uses the {{:https://erratique.ch/software/logs/doc/Logs/index.html}
@@ -1896,21 +1884,19 @@ val log : ('a, Format.formatter, unit, unit) format4 -> 'a
]} *)
type ('a, 'b) conditional_log =
- ((?request:request ->
- ('a, Format.formatter, unit, 'b) format4 -> 'a) -> 'b) ->
- unit
+ ((?request:request -> ('a, Format.formatter, unit, 'b) format4 -> 'a) -> 'b) ->
+ unit
(** Loggers. This type is difficult to read — instead, see {!Dream.val-error} for
usage. *)
-type log_level = [
- | `Error
+type log_level =
+ [ `Error
| `Warning
| `Info
- | `Debug
-]
+ | `Debug ]
(** Log levels, in order from most urgent to least. *)
-val error : ('a, unit) conditional_log
+val error : ('a, unit) conditional_log
(** Formats a message and writes it to the log at level [`Error]. The inner
formatting function is called only if the {{!initialize_log} current log
level} is [`Error] or higher. See example
@@ -1926,17 +1912,18 @@ val error : ('a, unit) conditional_log
message with a specific request. If not passed, {!Dream.val-error} will try
to guess the request. This usually works, but not always. *)
-val warning : ('a, unit) conditional_log
-val info : ('a, unit) conditional_log
-val debug : ('a, unit) conditional_log
+val warning : ('a, unit) conditional_log
+val info : ('a, unit) conditional_log
+
+val debug : ('a, unit) conditional_log
(** Like {!Dream.val-error}, but for each of the other {{!log_level} log
levels}. *)
type sub_log = {
- error : 'a. ('a, unit) conditional_log;
+ error : 'a. ('a, unit) conditional_log;
warning : 'a. ('a, unit) conditional_log;
- info : 'a. ('a, unit) conditional_log;
- debug : 'a. ('a, unit) conditional_log;
+ info : 'a. ('a, unit) conditional_log;
+ debug : 'a. ('a, unit) conditional_log;
}
(** Sub-logs. See {!Dream.val-sub_log} right below. *)
@@ -1965,9 +1952,10 @@ val sub_log : ?level:[< log_level] -> string -> sub_log
val initialize_log :
?backtraces:bool ->
?async_exception_hook:bool ->
- ?level:[< log_level ] ->
+ ?level:[< log_level] ->
?enable:bool ->
- unit -> unit
+ unit ->
+ unit
(** Initializes Dream's log with the given settings.
Dream initializes its logging back end lazily. This is so that if a Dream
@@ -1992,11 +1980,9 @@ val initialize_log :
- [~enable:false] disables Dream logging completely. This can help sanitize
output during testing. *)
-val set_log_level : string -> [< log_level ] -> unit
+val set_log_level : string -> [< log_level] -> unit
(** Set the log level threshold of the given sub-log. *)
-
-
(** {1 Errors}
Dream passes all errors to a single error handler, including...
@@ -2023,22 +2009,9 @@ val set_log_level : string -> [< log_level ] -> unit
{!type-error_handler} directly. *)
type error = {
- condition : [
- | `Response of response
- | `String of string
- | `Exn of exn
- ];
- layer : [
- | `App
- | `HTTP
- | `HTTP2
- | `TLS
- | `WebSocket
- ];
- caused_by : [
- | `Server
- | `Client
- ];
+ condition : [`Response of response | `String of string | `Exn of exn];
+ layer : [`App | `HTTP | `HTTP2 | `TLS | `WebSocket];
+ caused_by : [`Server | `Client];
request : request option;
response : response option;
client : string option;
@@ -2186,8 +2159,6 @@ val catch : (error -> response promise) -> middleware
(* TODO Error handler should not return an option, and then the type can be
used here. *)
-
-
(** {1 Servers} *)
val run :
@@ -2201,7 +2172,8 @@ val run :
?builtins:bool ->
?greeting:bool ->
?adjust_terminal:bool ->
- handler -> unit
+ handler ->
+ unit
(** Runs the Web application represented by the {!handler}, by default at
{{:http://localhost:8080} http://localhost:8080}.
@@ -2258,7 +2230,8 @@ val serve :
?certificate_file:string ->
?key_file:string ->
?builtins:bool ->
- handler -> unit promise
+ handler ->
+ unit promise
(** 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]}.
@@ -2304,8 +2277,6 @@ val with_site_prefix : string -> middleware
(* TODO Clarify that this isn't included with the built-ins, but is something on
topic that one might want to use. *)
-
-
(** {1:web_formats Web formats} *)
val html_escape : string -> string
@@ -2370,8 +2341,10 @@ val to_set_cookie :
?path:string ->
?secure:bool ->
?http_only:bool ->
- ?same_site:[ `Strict | `Lax | `None ] ->
- string -> string -> string
+ ?same_site:[`Strict | `Lax | `None] ->
+ string ->
+ string ->
+ string
(** [Dream.to_set_cookie name value] formats a [Set-Cookie:] header value. The
optional arguments correspond to the attributes specified in
{{:https://tools.ietf.org/html/draft-ietf-httpbis-rfc6265bis-07#section-5.3}
@@ -2420,8 +2393,6 @@ val text_html : string
val application_json : string
(** The string ["application/json"] for [Content-Type:] headers. *)
-
-
(** {1 Cryptography} *)
val set_secret : ?old_secrets:string list -> string -> middleware
@@ -2452,9 +2423,7 @@ val random : int -> string
{{:https://github.com/mirage/mirage-crypto} cryptographically secure random
number generator}. *)
-val encrypt :
- ?associated_data:string ->
- request -> string -> string
+val encrypt : ?associated_data:string -> request -> string -> string
(** Signs and encrypts the string using the secret set by {!Dream.set_secret}.
[~associated_data] is included when computing the signature, but not
@@ -2484,17 +2453,13 @@ val encrypt :
{{:https://cheatsheetseries.owasp.org/cheatsheets/Password_Storage_Cheat_Sheet.html}
OWASP {i Password Storage Cheat Sheet}}. *)
-val decrypt :
- ?associated_data:string ->
- request -> string -> string option
+val decrypt : ?associated_data:string -> request -> string -> string option
(** Reverses {!Dream.encrypt}.
To support secret rotation, this function first tries to decrypt the string
using the main secret set by {!Dream.set_secret}, and then each of the old
secrets passed to {!Dream.set_secret} in [~old_secrets]. *)
-
-
(** {1 Variables}
Dream supports user-defined per-message variables for use by middlewares. *)
@@ -2503,11 +2468,12 @@ type 'a field
(** Per-message variable. *)
(**/**)
+
type 'a local = 'a field
[@@ocaml.deprecated
-"Renamed to type Dream.field. See
-https://aantron.github.io/dream/#type-field
-"]
+ "Renamed to type Dream.field. See\n\
+ https://aantron.github.io/dream/#type-field\n"]
+
(**/**)
val new_field : ?name:string -> ?show_value:('a -> string) -> unit -> 'a field
@@ -2516,49 +2482,50 @@ val new_field : ?name:string -> ?show_value:('a -> string) -> unit -> 'a field
{!Dream.run} [~debug] to show the variable in debug dumps. *)
(**/**)
+
val new_local : ?name:string -> ?show_value:('a -> string) -> unit -> 'a field
-[@@ocaml.deprecated
-"Renamed to Dream.new_field. See
-https://aantron.github.io/dream/#val-new_field
-"]
+ [@@ocaml.deprecated
+ "Renamed to Dream.new_field. See\n\
+ https://aantron.github.io/dream/#val-new_field\n"]
+
(**/**)
val field : 'b message -> 'a field -> 'a option
(** Retrieves the value of the per-message variable. *)
(**/**)
+
val local : 'b message -> 'a field -> 'a option
-[@@ocaml.deprecated
-"Renamed to Dream.field. See
-https://aantron.github.io/dream/#val-field
-"]
+ [@@ocaml.deprecated
+ "Renamed to Dream.field. See\nhttps://aantron.github.io/dream/#val-field\n"]
+
(**/**)
val set_field : 'b message -> 'a field -> 'a -> unit
(** Sets the per-message variable to the value. *)
(**/**)
-val with_local : 'a field -> 'a -> 'b message -> 'b message
-[@@ocaml.deprecated
-"Use Dream.set_field instead. See
-https://aantron.github.io/dream/#val-set_field
-"]
-(**/**)
+val with_local : 'a field -> 'a -> 'b message -> 'b message
+ [@@ocaml.deprecated
+ "Use Dream.set_field instead. See\n\
+ https://aantron.github.io/dream/#val-set_field\n"]
+(**/**)
(** {1 Testing} *)
val request :
- ?method_:[< method_ ] ->
+ ?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}. *)
-val test : ?prefix:string -> handler -> (request -> response)
+val test : ?prefix:string -> handler -> request -> response
(** [Dream.test handler] runs a handler the same way the HTTP server
({!Dream.run}) would — assigning it a request id and noting the site root
prefix, which is used by routers. [Dream.test] calls
@@ -2568,19 +2535,21 @@ val test : ?prefix:string -> handler -> (request -> response)
you can test [handler] by calling it directly with a request. *)
(**/**)
+
val first : 'a message -> 'a message
-[@@ocaml.deprecated "Simply returns its own argument."]
+ [@@ocaml.deprecated "Simply returns its own argument."]
(** [Dream.first message] evaluates to the original request or response that
[message] is immutably derived from. This is useful for getting the original
state of requests especially, when they were first created inside the HTTP
server ({!Dream.run}). *)
val last : 'a message -> 'a message
-[@@ocaml.deprecated "Simply returns its own argument."]
+ [@@ocaml.deprecated "Simply returns its own argument."]
(** [Dream.last message] evaluates to the latest request or response that was
derived from [message]. This is most useful for obtaining the state of
requests at the time an exception was raised, without having to instrument
the latest version of the request before the exception. *)
+
(**/**)
val sort_headers : (string * string) list -> (string * string) list
File "test/expect/server/router.ml", line 1, characters 0-0:
diff --git a/_build/default/test/expect/server/router.ml b/_build/default/test/expect/server/.formatted/router.ml
index ff38d93..46392f6 100644
--- a/_build/default/test/expect/server/router.ml
+++ b/_build/default/test/expect/server/.formatted/router.ml
@@ -3,38 +3,28 @@
Copyright 2021 Anton Bachin *)
-
-
(* TODO Decide what to do this based on the deprecation (or not) of val path. *)
-module Dream =
-struct
+module Dream = struct
include Dream
- let path = path [@ocaml.warning "-3"]
-end
-
+ let path = (path [@ocaml.warning "-3"])
+end
-let () =
- ignore Initialize.require
+let () = ignore Initialize.require
let path request =
- Dream.path request
- |> String.concat "/"
- |> fun path -> "/" ^ path
-
-
+ Dream.path request |> String.concat "/" |> fun path -> "/" ^ path
let show_tokens route =
try
Dream__server.Router.parse route
|> List.map (function
- | Dream__server.Router.Literal s -> Printf.sprintf "%S" s
- | Dream__server.Router.Param s -> Printf.sprintf ":%S" s
- | Dream__server.Router.Wildcard s -> Printf.sprintf "*%S" s)
+ | Dream__server.Router.Literal s -> Printf.sprintf "%S" s
+ | Dream__server.Router.Param s -> Printf.sprintf ":%S" s
+ | Dream__server.Router.Wildcard s -> Printf.sprintf "*%S" s)
|> String.concat "; "
|> Printf.printf "[%s]\n"
- with Failure message ->
- print_endline message
+ with Failure message -> print_endline message
let%expect_test _ =
show_tokens "";
@@ -52,7 +42,8 @@ let%expect_test _ =
show_tokens "/abc/:";
show_tokens "/abc/:/";
show_tokens "/abc/de:f/";
- [%expect {|
+ [%expect
+ {|
[]
["abc"]
[""]
@@ -78,7 +69,8 @@ let%expect_test _ =
show_tokens "/abc/*def/ghi";
show_tokens "/abc/**def/";
show_tokens "/abc/**def/ghi";
- [%expect {|
+ [%expect
+ {|
[*"*"]
["abc"; *"*"]
Path wildcard must be last
@@ -88,29 +80,27 @@ let%expect_test _ =
Path wildcard must be just '**'
Path wildcard must be just '**' |}]
-
-
let show ?(prefix = "/") ?(method_ = `GET) target router =
try
- Dream.request ~method_ ~target ""
- |> Dream.test ~prefix router
+ Dream.request ~method_ ~target "" |> Dream.test ~prefix router
|> fun response ->
- let body =
- 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"
- (Dream.status_to_int status) (Dream.status_to_string status);
- if body <> "" then
- Printf.printf "%s\n" body
- else
- ()
- with Failure message ->
- print_endline message
+ let body =
+ 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"
+ (Dream.status_to_int status)
+ (Dream.status_to_string status);
+ if body <> "" then
+ Printf.printf "%s\n" body
+ else
+ ()
+ with Failure message -> print_endline message
(* Basic router tests. *)
@@ -119,58 +109,53 @@ let%expect_test _ =
[%expect {| Response: 404 Not Found |}]
let%expect_test _ =
- show "/" @@ Dream.router [
- Dream.get "/" (fun _ -> Dream.respond "foo");
- ];
+ show "/" @@ Dream.router [Dream.get "/" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 200 OK
foo |}]
let%expect_test _ =
- show "/abc" @@ Dream.router [
- Dream.get "/" (fun _ -> Dream.respond "foo");
- ];
+ show "/abc" @@ Dream.router [Dream.get "/" (fun _ -> Dream.respond "foo")];
[%expect {| Response: 404 Not Found |}]
let%expect_test _ =
- show "/abc" @@ Dream.router [
- Dream.get "/abc" (fun _ -> Dream.respond "foo");
- ];
+ show "/abc" @@ Dream.router [Dream.get "/abc" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 200 OK
foo |}]
let%expect_test _ =
- show "/abc/" @@ Dream.router [
- Dream.get "/abc/" (fun _ -> Dream.respond "foo");
- ];
+ show "/abc/"
+ @@ Dream.router [Dream.get "/abc/" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 200 OK
foo |}]
let%expect_test _ =
- show "/abc" @@ Dream.router [
- Dream.get "/abc" (fun _ -> Dream.respond "foo");
- Dream.get "/def" (fun _ -> Dream.respond "bar");
- ];
+ show "/abc"
+ @@ Dream.router
+ [
+ Dream.get "/abc" (fun _ -> Dream.respond "foo");
+ Dream.get "/def" (fun _ -> Dream.respond "bar");
+ ];
[%expect {|
Response: 200 OK
foo |}]
let%expect_test _ =
- show "/def" @@ Dream.router [
- Dream.get "/abc" (fun _ -> Dream.respond "foo");
- Dream.get "/def" (fun _ -> Dream.respond "bar");
- ];
+ show "/def"
+ @@ Dream.router
+ [
+ Dream.get "/abc" (fun _ -> Dream.respond "foo");
+ Dream.get "/def" (fun _ -> Dream.respond "bar");
+ ];
[%expect {|
Response: 200 OK
bar |}]
(* Router matches IRIs. *)
let%expect_test _ =
- show "/λ" @@ Dream.router [
- Dream.get "/λ" (fun _ -> Dream.respond "foo");
- ];
+ show "/λ" @@ Dream.router [Dream.get "/λ" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 200 OK
foo |}]
@@ -178,122 +163,104 @@ let%expect_test _ =
(* Router matches long paths, does not match prefixes, etc. *)
let%expect_test _ =
- show "/abc/def" @@ Dream.router [
- Dream.get "/abc/def" (fun _ -> Dream.respond "foo");
- ];
+ show "/abc/def"
+ @@ Dream.router [Dream.get "/abc/def" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 200 OK
foo |}]
let%expect_test _ =
- show "/abc" @@ Dream.router [
- Dream.get "/abc/def" (fun _ -> Dream.respond "foo");
- ];
+ show "/abc"
+ @@ Dream.router [Dream.get "/abc/def" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 404 Not Found |}]
(* Router distinguishes resources and directories. *)
let%expect_test _ =
- show "/abc" @@ Dream.router [
- Dream.get "/abc/" (fun _ -> Dream.respond "foo");
- ];
+ show "/abc" @@ Dream.router [Dream.get "/abc/" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 404 Not Found |}]
let%expect_test _ =
- show "/abc/" @@ Dream.router [
- Dream.get "/abc" (fun _ -> Dream.respond "foo");
- ];
+ show "/abc/" @@ Dream.router [Dream.get "/abc" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 404 Not Found |}]
(* Router respects methods. *)
let%expect_test _ =
- show ~method_:`POST "/abc" @@ Dream.router [
- Dream.post "/abc" (fun _ -> Dream.respond "foo");
- ];
+ show ~method_:`POST "/abc"
+ @@ Dream.router [Dream.post "/abc" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 200 OK
foo |}]
let%expect_test _ =
- show ~method_:(`Method "POST") "/abc" @@ Dream.router [
- Dream.post "/abc" (fun _ -> Dream.respond "foo");
- ];
+ show ~method_:(`Method "POST") "/abc"
+ @@ Dream.router [Dream.post "/abc" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 200 OK
foo |}]
let%expect_test _ =
- show ~method_:`POST "/abc" @@ Dream.router [
- Dream.get "/abc" (fun _ -> Dream.respond "foo");
- ];
+ show ~method_:`POST "/abc"
+ @@ Dream.router [Dream.get "/abc" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 404 Not Found |}]
let%expect_test _ =
- show "/abc" @@ Dream.router [
- Dream.post "/abc" (fun _ -> Dream.respond "foo");
- ];
+ show "/abc" @@ Dream.router [Dream.post "/abc" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 404 Not Found |}]
(* Briefly test all the other methods. *)
let%expect_test _ =
- show ~method_:`PUT "/abc" @@ Dream.router [
- Dream.put "/abc" (fun _ -> Dream.respond "foo");
- ];
+ show ~method_:`PUT "/abc"
+ @@ Dream.router [Dream.put "/abc" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 200 OK
foo |}]
let%expect_test _ =
- show ~method_:`DELETE "/abc" @@ Dream.router [
- Dream.delete "/abc" (fun _ -> Dream.respond "foo");
- ];
+ show ~method_:`DELETE "/abc"
+ @@ Dream.router [Dream.delete "/abc" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 200 OK
foo |}]
let%expect_test _ =
- show ~method_:`HEAD "/abc" @@ Dream.router [
- Dream.head "/abc" (fun _ -> Dream.respond "foo");
- ];
+ show ~method_:`HEAD "/abc"
+ @@ Dream.router [Dream.head "/abc" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 200 OK
foo |}]
let%expect_test _ =
- show ~method_:`CONNECT "/abc" @@ Dream.router [
- Dream.connect "/abc" (fun _ -> Dream.respond "foo");
- ];
+ show ~method_:`CONNECT "/abc"
+ @@ Dream.router [Dream.connect "/abc" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 200 OK
foo |}]
let%expect_test _ =
- show ~method_:`OPTIONS "/abc" @@ Dream.router [
- Dream.options "/abc" (fun _ -> Dream.respond "foo");
- ];
+ show ~method_:`OPTIONS "/abc"
+ @@ Dream.router [Dream.options "/abc" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 200 OK
foo |}]
let%expect_test _ =
- show ~method_:`TRACE "/abc" @@ Dream.router [
- Dream.trace "/abc" (fun _ -> Dream.respond "foo");
- ];
+ show ~method_:`TRACE "/abc"
+ @@ Dream.router [Dream.trace "/abc" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 200 OK
foo |}]
let%expect_test _ =
- show ~method_:`PATCH "/abc" @@ Dream.router [
- Dream.patch "/abc" (fun _ -> Dream.respond "foo");
- ];
+ show ~method_:`PATCH "/abc"
+ @@ Dream.router [Dream.patch "/abc" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 200 OK
foo |}]
@@ -301,57 +268,60 @@ let%expect_test _ =
(* Router matches and sets variables. *)
let%expect_test _ =
- show "/abc/def" @@ Dream.router [
- Dream.get "/abc/:x" (fun _ -> Dream.respond "foo");
- ];
+ show "/abc/def"
+ @@ Dream.router [Dream.get "/abc/:x" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 200 OK
foo |}]
let%expect_test _ =
- show "/abc/" @@ Dream.router [
- Dream.get "/abc/:x" (fun _ -> Dream.respond "foo");
- ];
+ show "/abc/"
+ @@ Dream.router [Dream.get "/abc/:x" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 404 Not Found |}]
let%expect_test _ =
- show "/abc/def" @@ Dream.router [
- Dream.get "/abc/:x" (fun request ->
- Dream.respond (Dream.param request "x"));
- ];
+ show "/abc/def"
+ @@ Dream.router
+ [
+ Dream.get "/abc/:x" (fun request ->
+ Dream.respond (Dream.param request "x"));
+ ];
[%expect {|
Response: 200 OK
def |}]
let%expect_test _ =
- show "/abc/def/ghi" @@ Dream.router [
- Dream.get "/abc/:x/:y" (fun request ->
- Dream.respond (Dream.param request "x" ^ Dream.param request "y"));
- ];
+ show "/abc/def/ghi"
+ @@ Dream.router
+ [
+ Dream.get "/abc/:x/:y" (fun request ->
+ Dream.respond (Dream.param request "x" ^ Dream.param request "y"));
+ ];
[%expect {|
Response: 200 OK
defghi |}]
let%expect_test _ =
- show "/abc/def/ghi" @@ Dream.router [
- Dream.get "/abc/:x" (fun _ -> Dream.respond "foo");
- ];
+ show "/abc/def/ghi"
+ @@ Dream.router [Dream.get "/abc/:x" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 404 Not Found |}]
let%expect_test _ =
- show "/abc/def" @@ Dream.router [
- Dream.get "/abc/def" (fun request ->
- Dream.respond (Dream.param request "x"));
- ];
+ show "/abc/def"
+ @@ Dream.router
+ [
+ Dream.get "/abc/def" (fun request ->
+ Dream.respond (Dream.param request "x"));
+ ];
[%expect {|
Dream.param: missing path parameter "x" |}]
let%expect_test _ =
- show "/" @@ (fun request ->
+ ( show "/" @@ fun request ->
ignore (Dream.param request "x");
- Dream.empty `Not_Found);
+ Dream.empty `Not_Found );
[%expect {| Dream.param: missing path parameter "x" |}]
(* Router respects site prefix. *)
@@ -394,71 +364,94 @@ let%expect_test _ =
(* Direct subsites work. *)
let%expect_test _ =
- show "/abc/def" @@ Dream.router [
- Dream.scope "/abc" [] [
- Dream.get "/def" (fun request ->
- Dream.respond (Dream.prefix request ^ " " ^ path request));
- ];
- ];
+ show "/abc/def"
+ @@ Dream.router
+ [
+ Dream.scope "/abc" []
+ [
+ Dream.get "/def" (fun request ->
+ Dream.respond (Dream.prefix request ^ " " ^ path request));
+ ];
+ ];
[%expect {|
Response: 200 OK
/ /abc/def |}]
let%expect_test _ =
- show "/def/abc" @@ Dream.router [
- Dream.scope "/abc" [] [
- Dream.get "/def" (fun request ->
- Dream.respond (Dream.prefix request ^ " " ^ path request));
- ];
- ];
+ show "/def/abc"
+ @@ Dream.router
+ [
+ Dream.scope "/abc" []
+ [
+ Dream.get "/def" (fun request ->
+ Dream.respond (Dream.prefix request ^ " " ^ path request));
+ ];
+ ];
[%expect {|
Response: 404 Not Found |}]
let%expect_test _ =
- show "/abc/ghi" @@ Dream.router [
- Dream.scope "/abc" [] [
- Dream.get "/def" (fun request ->
- Dream.respond (Dream.prefix request ^ " " ^ path request));
- ];
- Dream.get "/abc/ghi" (fun request ->
- Dream.respond (Dream.prefix request ^ " " ^ path request));
- ];
+ show "/abc/ghi"
+ @@ Dream.router
+ [
+ Dream.scope "/abc" []
+ [
+ Dream.get "/def" (fun request ->
+ Dream.respond (Dream.prefix request ^ " " ^ path request));
+ ];
+ Dream.get "/abc/ghi" (fun request ->
+ Dream.respond (Dream.prefix request ^ " " ^ path request));
+ ];
[%expect {|
Response: 200 OK
/ /abc/ghi |}]
let%expect_test _ =
- show "/abc/def" @@ Dream.router [
- Dream.scope "/:x" [] [
- Dream.get "/def" (fun request ->
- Dream.respond (Dream.param request "x"));
- ];
- ];
+ show "/abc/def"
+ @@ Dream.router
+ [
+ Dream.scope "/:x" []
+ [
+ Dream.get "/def" (fun request ->
+ Dream.respond (Dream.param request "x"));
+ ];
+ ];
[%expect {|
Response: 200 OK
abc |}]
let%expect_test _ =
- show "/abc/def" @@ Dream.router [
- Dream.scope "/:x" [] [
- Dream.get "/:x" (fun request ->
- Dream.respond (Dream.param request "x"));
- ];
- ];
+ show "/abc/def"
+ @@ Dream.router
+ [
+ Dream.scope "/:x" []
+ [
+ Dream.get "/:x" (fun request ->
+ Dream.respond (Dream.param request "x"));
+ ];
+ ];
[%expect {|
Response: 200 OK
def |}]
let%expect_test _ =
- show "/abc/def" @@ Dream.router [
- Dream.scope "/abc" [
- (fun next_handler request -> print_endline "foo"; next_handler request);
- (fun next_handler request -> print_endline "bar"; next_handler request);
- ] [
- Dream.get "/def" (fun request ->
- Dream.respond (Dream.prefix request ^ " " ^ path request));
- ];
- ];
+ show "/abc/def"
+ @@ Dream.router
+ [
+ Dream.scope "/abc"
+ [
+ (fun next_handler request ->
+ print_endline "foo";
+ next_handler request);
+ (fun next_handler request ->
+ print_endline "bar";
+ next_handler request);
+ ]
+ [
+ Dream.get "/def" (fun request ->
+ Dream.respond (Dream.prefix request ^ " " ^ path request));
+ ];
+ ];
[%expect {|
foo
bar
@@ -466,23 +459,39 @@ let%expect_test _ =
/ /abc/def |}]
let%expect_test _ =
- let pipeline_1 = Dream.pipeline [
- (fun next_handler request -> print_endline "foo"; next_handler request);
- (fun next_handler request -> print_endline "bar"; next_handler request);
- ] in
-
- let pipeline_2 = Dream.pipeline [
- (fun next_handler request -> print_endline "baz"; next_handler request);
- (fun next_handler request -> print_endline "lel"; next_handler request);
- ] in
-
- show "/abc/def" @@ Dream.router [
- Dream.scope "/abc" [pipeline_1] [
- Dream.scope "/def" [pipeline_2] [
- Dream.get "" (fun _ -> Dream.respond "wat");
- ];
- ];
- ];
+ let pipeline_1 =
+ Dream.pipeline
+ [
+ (fun next_handler request ->
+ print_endline "foo";
+ next_handler request);
+ (fun next_handler request ->
+ print_endline "bar";
+ next_handler request);
+ ]
+ in
+
+ let pipeline_2 =
+ Dream.pipeline
+ [
+ (fun next_handler request ->
+ print_endline "baz";
+ next_handler request);
+ (fun next_handler request ->
+ print_endline "lel";
+ next_handler request);
+ ]
+ in
+
+ show "/abc/def"
+ @@ Dream.router
+ [
+ Dream.scope "/abc" [pipeline_1]
+ [
+ Dream.scope "/def" [pipeline_2]
+ [Dream.get "" (fun _ -> Dream.respond "wat")];
+ ];
+ ];
[%expect {|
foo
bar
@@ -494,17 +503,24 @@ let%expect_test _ =
(* Router applies middlewares. *)
let%expect_test _ =
-
- let pipeline = Dream.pipeline [
- (fun next_handler request -> print_endline "foo"; next_handler request);
- (fun next_handler request -> print_endline "bar"; next_handler request);
- ] in
-
- show "/abc" @@ Dream.router [
- Dream.scope "/" [pipeline] [
- Dream.get "/abc" (fun _ -> Dream.respond "baz");
- ];
- ];
+ let pipeline =
+ Dream.pipeline
+ [
+ (fun next_handler request ->
+ print_endline "foo";
+ next_handler request);
+ (fun next_handler request ->
+ print_endline "bar";
+ next_handler request);
+ ]
+ in
+
+ show "/abc"
+ @@ Dream.router
+ [
+ Dream.scope "/" [pipeline]
+ [Dream.get "/abc" (fun _ -> Dream.respond "baz")];
+ ];
[%expect {|
foo
bar
@@ -512,142 +528,176 @@ let%expect_test _ =
baz |}]
let%expect_test _ =
- show "/" @@ Dream.router [
- Dream.scope "/" [
- (fun next_handler request -> print_endline "foo"; next_handler request);
- (fun next_handler request -> print_endline "bar"; next_handler request);
- ] [
- Dream.get "/abc" (fun _ -> Dream.respond "baz");
- ];
- ];
+ show "/"
+ @@ Dream.router
+ [
+ Dream.scope "/"
+ [
+ (fun next_handler request ->
+ print_endline "foo";
+ next_handler request);
+ (fun next_handler request ->
+ print_endline "bar";
+ next_handler request);
+ ]
+ [Dream.get "/abc" (fun _ -> Dream.respond "baz")];
+ ];
[%expect {|
Response: 404 Not Found |}]
(* Router sequence works. *)
(* let%expect_test _ =
- show "/abc/def" @@ Dream.pipeline [
- Dream.router [
- Dream.get "/abc/ghi" (fun _ -> Dream.respond "first");
- ];
- Dream.router [
- Dream.get "/abc/def" (fun _ -> Dream.respond "second");
- ];
- ];
- [%expect {|
- Response: 200 OK
- second |}] *)
+ show "/abc/def" @@ Dream.pipeline [
+ Dream.router [
+ Dream.get "/abc/ghi" (fun _ -> Dream.respond "first");
+ ];
+ Dream.router [
+ Dream.get "/abc/def" (fun _ -> Dream.respond "second");
+ ];
+ ];
+ [%expect {|
+ Response: 200 OK
+ second |}] *)
(* Wildcard routes. *)
let%expect_test _ =
- show "/abc/def" @@ Dream.router [
- Dream.get "/abc/**" (fun request ->
- Dream.respond (Dream.prefix request ^ " " ^ path request));
- ];
+ show "/abc/def"
+ @@ Dream.router
+ [
+ Dream.get "/abc/**" (fun request ->
+ Dream.respond (Dream.prefix request ^ " " ^ path request));
+ ];
[%expect {|
Response: 200 OK
/abc /def |}]
let%expect_test _ =
- show "/abc/def" @@ Dream.router [
- Dream.get "**" (fun request ->
- Dream.respond (Dream.prefix request ^ " " ^ path request));
- ];
+ show "/abc/def"
+ @@ Dream.router
+ [
+ Dream.get "**" (fun request ->
+ Dream.respond (Dream.prefix request ^ " " ^ path request));
+ ];
[%expect {|
Response: 200 OK
/ /abc/def |}]
let%expect_test _ =
- show "/abc/def" @@ Dream.router [
- Dream.get "/**" (fun request ->
- Dream.respond (Dream.prefix request ^ " " ^ path request));
- ];
+ show "/abc/def"
+ @@ Dream.router
+ [
+ Dream.get "/**" (fun request ->
+ Dream.respond (Dream.prefix request ^ " " ^ path request));
+ ];
[%expect {|
Response: 200 OK
/ /abc/def |}]
let%expect_test _ =
- show "/abc/def" @@ Dream.router [
- Dream.get "/abc/def/**" (fun request ->
- Dream.respond (Dream.prefix request ^ " " ^ path request));
- ];
+ show "/abc/def"
+ @@ Dream.router
+ [
+ Dream.get "/abc/def/**" (fun request ->
+ Dream.respond (Dream.prefix request ^ " " ^ path request));
+ ];
[%expect {| Response: 404 Not Found |}]
let%expect_test _ =
- show "/abc/def/" @@ Dream.router [
- Dream.get "/abc/def/**" (fun request ->
- Dream.respond (Dream.prefix request ^ " " ^ path request));
- ];
+ show "/abc/def/"
+ @@ Dream.router
+ [
+ Dream.get "/abc/def/**" (fun request ->
+ Dream.respond (Dream.prefix request ^ " " ^ path request));
+ ];
[%expect {|
Response: 200 OK
/abc/def / |}]
let%expect_test _ =
- show "/abc/def/ghi" @@ Dream.router [
- Dream.get "/abc/def/**" (fun request ->
- Dream.respond (Dream.prefix request ^ " " ^ path request));
- ];
+ show "/abc/def/ghi"
+ @@ Dream.router
+ [
+ Dream.get "/abc/def/**" (fun request ->
+ Dream.respond (Dream.prefix request ^ " " ^ path request));
+ ];
[%expect {|
Response: 200 OK
/abc/def /ghi |}]
let%expect_test _ =
- show "/abc/def" @@ Dream.router [
- Dream.post "/abc/**" (fun request ->
- Dream.respond (Dream.prefix request ^ " " ^ path request));
- ];
+ show "/abc/def"
+ @@ Dream.router
+ [
+ Dream.post "/abc/**" (fun request ->
+ Dream.respond (Dream.prefix request ^ " " ^ path request));
+ ];
[%expect {| Response: 404 Not Found |}]
let%expect_test _ =
- show ~method_:`POST "/abc/def" @@ Dream.router [
- Dream.post "/abc/**" (fun request ->
- Dream.respond (Dream.prefix request ^ " " ^ path request));
- ];
+ show ~method_:`POST "/abc/def"
+ @@ Dream.router
+ [
+ Dream.post "/abc/**" (fun request ->
+ Dream.respond (Dream.prefix request ^ " " ^ path request));
+ ];
[%expect {|
Response: 200 OK
/abc /def |}]
let%expect_test _ =
- show "/abc/def/ghi" @@ Dream.router [
- Dream.scope "/abc" [] [
- Dream.get "/def/**" (fun request ->
- Dream.respond (Dream.prefix request ^ " " ^ path request));
- ];
- ];
+ show "/abc/def/ghi"
+ @@ Dream.router
+ [
+ Dream.scope "/abc" []
+ [
+ Dream.get "/def/**" (fun request ->
+ Dream.respond (Dream.prefix request ^ " " ^ path request));
+ ];
+ ];
[%expect {|
Response: 200 OK
/abc/def /ghi |}]
let%expect_test _ =
- show "/abc/def/ghi" @@ Dream.router [
- Dream.scope "/abc" [] [
- Dream.get "/**" (fun request ->
- Dream.respond (Dream.prefix request ^ " " ^ path request));
- ];
- ];
+ show "/abc/def/ghi"
+ @@ Dream.router
+ [
+ Dream.scope "/abc" []
+ [
+ Dream.get "/**" (fun request ->
+ Dream.respond (Dream.prefix request ^ " " ^ path request));
+ ];
+ ];
[%expect {|
Response: 200 OK
/abc /def/ghi |}]
let%expect_test _ =
- show "/abc/def/ghi" @@ Dream.router [
- Dream.scope "/abc" [] [
- Dream.get "**" (fun request ->
- Dream.respond (Dream.prefix request ^ " " ^ path request));
- ];
- ];
+ show "/abc/def/ghi"
+ @@ Dream.router
+ [
+ Dream.scope "/abc" []
+ [
+ Dream.get "**" (fun request ->
+ Dream.respond (Dream.prefix request ^ " " ^ path request));
+ ];
+ ];
[%expect {|
Response: 200 OK
/abc /def/ghi |}]
let%expect_test _ =
- show "/abc/def/ghi" @@ Dream.router [
- Dream.scope "/abc/def" [] [
- Dream.get "**" (fun request ->
- Dream.respond (Dream.prefix request ^ " " ^ path request));
- ];
- ];
+ show "/abc/def/ghi"
+ @@ Dream.router
+ [
+ Dream.scope "/abc/def" []
+ [
+ Dream.get "**" (fun request ->
+ Dream.respond (Dream.prefix request ^ " " ^ path request));
+ ];
+ ];
[%expect {|
Response: 200 OK
/abc/def /ghi |}]
@@ -655,39 +705,40 @@ let%expect_test _ =
(* Wildcard works with params. *)
let%expect_test _ =
- show "/abc/def/ghi" @@ Dream.router [
- Dream.get "/:x/**" (fun request ->
- Printf.ksprintf Dream.respond "%s %s %s"
- (Dream.prefix request)
- (Dream.param request "x")
- (path request));
- ];
+ show "/abc/def/ghi"
+ @@ Dream.router
+ [
+ Dream.get "/:x/**" (fun request ->
+ Printf.ksprintf Dream.respond "%s %s %s" (Dream.prefix request)
+ (Dream.param request "x") (path request));
+ ];
[%expect {|
Response: 200 OK
/abc abc /def/ghi |}]
let%expect_test _ =
- show "/abc/def/ghi" @@ Dream.router [
- Dream.get "/abc/:x/**" (fun request ->
- Printf.ksprintf Dream.respond "%s %s %s"
- (Dream.prefix request)
- (Dream.param request "x")
- (path request));
- ];
+ show "/abc/def/ghi"
+ @@ Dream.router
+ [
+ Dream.get "/abc/:x/**" (fun request ->
+ Printf.ksprintf Dream.respond "%s %s %s" (Dream.prefix request)
+ (Dream.param request "x") (path request));
+ ];
[%expect {|
Response: 200 OK
/abc/def def /ghi |}]
let%expect_test _ =
- show "/abc/def/ghi" @@ Dream.router [
- Dream.scope "/abc" [] [
- Dream.get "/:x/**" (fun request ->
- Printf.ksprintf Dream.respond "%s %s %s"
- (Dream.prefix request)
- (Dream.param request "x")
- (path request));
- ];
- ];
+ show "/abc/def/ghi"
+ @@ Dream.router
+ [
+ Dream.scope "/abc" []
+ [
+ Dream.get "/:x/**" (fun request ->
+ Printf.ksprintf Dream.respond "%s %s %s" (Dream.prefix request)
+ (Dream.param request "x") (path request));
+ ];
+ ];
[%expect {|
Response: 200 OK
/abc/def def /ghi |}]
@@ -695,47 +746,53 @@ let%expect_test _ =
(* Routers can be nested indirectly. *)
let%expect_test _ =
- show "/abc/def" @@ Dream.router [
- Dream.get "/abc/**" (fun request ->
- request
- |> Dream.router [
- Dream.get "/def" (fun request ->
- Dream.respond (Dream.prefix request ^ " " ^ path request));
- ])
- ];
+ show "/abc/def"
+ @@ Dream.router
+ [
+ Dream.get "/abc/**" (fun request ->
+ request
+ |> Dream.router
+ [
+ Dream.get "/def" (fun request ->
+ Dream.respond (Dream.prefix request ^ " " ^ path request));
+ ]);
+ ];
[%expect {|
Response: 200 OK
/abc /def |}]
let%expect_test _ =
- show "/abc/def" @@ Dream.router [
- Dream.get "/:x/**" (fun request ->
- request
- |> Dream.router [
- Dream.get "/:y" (fun request ->
- Printf.ksprintf Dream.respond "%s %s %s %s"
- (Dream.prefix request)
- (Dream.param request "x")
- (Dream.param request "y")
- (path request));
- ])
- ];
+ show "/abc/def"
+ @@ Dream.router
+ [
+ Dream.get "/:x/**" (fun request ->
+ request
+ |> Dream.router
+ [
+ Dream.get "/:y" (fun request ->
+ Printf.ksprintf Dream.respond "%s %s %s %s"
+ (Dream.prefix request) (Dream.param request "x")
+ (Dream.param request "y") (path request));
+ ]);
+ ];
[%expect {|
Response: 200 OK
/abc abc def /def |}]
let%expect_test _ =
- show "/abc/def" @@ Dream.router [
- Dream.get "/:x/**" (fun request ->
- request
- |> Dream.router [
- Dream.get "/:x" (fun request ->
- Printf.ksprintf Dream.respond "%s %s %s"
- (Dream.prefix request)
- (Dream.param request "x")
- (path request));
- ])
- ];
+ show "/abc/def"
+ @@ Dream.router
+ [
+ Dream.get "/:x/**" (fun request ->
+ request
+ |> Dream.router
+ [
+ Dream.get "/:x" (fun request ->
+ Printf.ksprintf Dream.respond "%s %s %s"
+ (Dream.prefix request) (Dream.param request "x")
+ (path request));
+ ]);
+ ];
[%expect {|
Response: 200 OK
/abc def /def |}]
@@ -743,9 +800,8 @@ let%expect_test _ =
(* It's possible to match OPTIONS *. *)
let%expect_test _ =
- show ~method_:`OPTIONS "*" @@ Dream.router [
- Dream.options "*" (fun _ -> Dream.respond "matched");
- ];
+ show ~method_:`OPTIONS "*"
+ @@ Dream.router [Dream.options "*" (fun _ -> Dream.respond "matched")];
[%expect {|
Response: 200 OK
matched |}]
@@ -753,25 +809,19 @@ let%expect_test _ =
(* no_route. *)
let%expect_test _ =
- show "/" @@ Dream.router [
- Dream.no_route;
- ];
+ show "/" @@ Dream.router [Dream.no_route];
[%expect {| Response: 404 Not Found |}]
let%expect_test _ =
- show "/" @@ Dream.router [
- Dream.no_route;
- Dream.get "/" (fun _ -> Dream.respond "foo");
- ];
+ show "/"
+ @@ Dream.router [Dream.no_route; Dream.get "/" (fun _ -> Dream.respond "foo")];
[%expect {|
Response: 200 OK
foo |}]
let%expect_test _ =
- show "/" @@ Dream.router [
- Dream.get "/" (fun _ -> Dream.respond "foo");
- Dream.no_route;
- ];
+ show "/"
+ @@ Dream.router [Dream.get "/" (fun _ -> Dream.respond "foo"); Dream.no_route];
[%expect {|
Response: 200 OK
foo |}]
File "example/z-playground/server/playground.ml", line 1, characters 0-0:
diff --git a/_build/default/example/z-playground/server/playground.ml b/_build/default/example/z-playground/server/.formatted/playground.ml
index 52a7e66..66481a8 100644
--- a/_build/default/example/z-playground/server/playground.ml
+++ b/_build/default/example/z-playground/server/.formatted/playground.ml
@@ -3,17 +3,17 @@
Copyright 2021 Anton Bachin *)
-
-
(* Sandboxes. *)
-type syntax = [ `OCaml | `Reason ]
-
-let (//) = Filename.concat
+type syntax =
+ [ `OCaml
+ | `Reason ]
+let ( // ) = Filename.concat
let sandbox_root = "sandbox"
-let sandbox_dune = {|(executable
+let sandbox_dune =
+ {|(executable
(name server)
(libraries caqti caqti-driver-sqlite3 dream runtime tyxml)
(preprocess (pps lwt_ppx ppx_yojson_conv)))
@@ -24,7 +24,8 @@ let sandbox_dune = {|(executable
(action (run dream_eml %{deps} --workspace %{workspace_root})))
|}
-let sandbox_dune_re = {|(executable
+let sandbox_dune_re =
+ {|(executable
(name server)
(libraries caqti caqti-driver-sqlite3 dream runtime tyxml)
(preprocess (pps lwt_ppx ppx_yojson_conv)))
@@ -35,13 +36,15 @@ let sandbox_dune_re = {|(executable
(action (run dream_eml %{deps} --workspace %{workspace_root})))
|}
-let sandbox_dune_no_eml = {|(executable
+let sandbox_dune_no_eml =
+ {|(executable
(name server)
(libraries caqti caqti-driver-sqlite3 dream runtime tyxml)
(preprocess (pps lwt_ppx ppx_yojson_conv tyxml-jsx tyxml-ppx)))
|}
-let base_dockerfile = {|FROM ubuntu:focal-20210416
+let base_dockerfile =
+ {|FROM ubuntu:focal-20210416
RUN apt update && apt install -y openssl libev4 libsqlite3-0
WORKDIR /www
COPY db.sqlite db.sqlite
@@ -65,22 +68,21 @@ let create_sandboxes_directory () =
| () -> Lwt.return_unit
| exception Unix.(Unix_error (EEXIST, _, _)) -> Lwt.return_unit
-let exists sandbox =
- Lwt_unix.file_exists (sandbox_root // sandbox)
+let exists sandbox = Lwt_unix.file_exists (sandbox_root // sandbox)
let write_file sandbox file content =
- Lwt_io.(with_file
- ~mode:Output (sandbox_root // sandbox // file) (fun channel ->
- write channel content))
+ Lwt_io.(
+ with_file ~mode:Output
+ (sandbox_root // sandbox // file)
+ (fun channel -> write channel content))
let create_named sandbox syntax eml code =
Dream.info (fun log -> log "Sandbox %s: creating" sandbox);
- begin match%lwt Lwt_unix.mkdir (sandbox_root // sandbox) 0o755 with
+ (match%lwt Lwt_unix.mkdir (sandbox_root // sandbox) 0o755 with
| () -> Lwt.return_unit
- | exception Unix.(Unix_error (EEXIST, _, _)) -> Lwt.return_unit
- end;%lwt
+ | exception Unix.(Unix_error (EEXIST, _, _)) -> Lwt.return_unit);%lwt
let filename =
- match syntax, eml with
+ match (syntax, eml) with
| `OCaml, false -> "server.ml"
| `Reason, false -> "server.re"
| `OCaml, true -> "server.eml.ml"
@@ -92,46 +94,42 @@ let create_named sandbox syntax eml code =
let rec create ?(attempts = 3) syntax eml code =
match attempts with
| 0 -> failwith "Unable to create sandbox directory"
- | attempts ->
+ | attempts -> (
let sandbox = Dream.random 9 |> Dream.to_base64url in
match sandbox.[0] with
| '_' | '-' -> create ~attempts syntax eml code
- | _ ->
+ | _ -> (
match%lwt exists sandbox with
| true -> create ~attempts:(attempts - 1) syntax eml code
- | false -> create_named sandbox 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
+ 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
- ~mode:Input (sandbox_root // sandbox // base ^ ".ml") read)
+ Lwt_io.(
+ with_file ~mode:Input ((sandbox_root // sandbox // base) ^ ".ml") read)
in
match%lwt ocaml_promise with
| content -> Lwt.return (content, `OCaml, eml)
| exception _ ->
let%lwt content =
- Lwt_io.(with_file
- ~mode:Input (sandbox_root // sandbox // base ^ ".re") read)
+ Lwt_io.(
+ with_file ~mode:Input ((sandbox_root // sandbox // base) ^ ".re") read)
in
Lwt.return (content, `Reason, eml)
let init_client socket content =
- `Assoc [
- "kind", `String "content";
- "payload", `String content;
- ]
+ `Assoc [("kind", `String "content"); ("payload", `String content)]
|> Yojson.Basic.to_string
|> Dream.send socket
let validate_id sandbox =
String.length sandbox > 0 && Dream.from_base64url sandbox <> None
-
-
(* Session state transitions. *)
type container = {
@@ -147,26 +145,24 @@ type session = {
socket : Dream.websocket;
}
-let allocated_ports =
- Hashtbl.create 1024
+let allocated_ports = Hashtbl.create 1024
let kill_container session =
match session.container with
| None -> Lwt.return_unit
- | Some {container_id; port} ->
+ | Some { container_id; port } ->
session.container <- None;
Dream.info (fun log ->
- log "Sandbox %s: killing container %s" session.sandbox container_id);
+ log "Sandbox %s: killing container %s" session.sandbox container_id);
let%lwt _status =
- exec "docker kill %s > /dev/null 2> /dev/null" container_id in
+ exec "docker kill %s > /dev/null 2> /dev/null" container_id
+ in
Hashtbl.remove allocated_ports port;
Lwt.return_unit
let min_port = 9000
let max_port = 9999
-
-let next_port =
- ref min_port
+let next_port = ref min_port
(* This can fail if there is a huge number of sandboxes, or very large spikes in
sandbox creation. However, the failure is not catastrophic. *)
@@ -190,48 +186,43 @@ let rec allocate_port () =
let client_log ?(add_newline = false) session message =
let message =
- if add_newline then message ^ "\n"
- else message
+ if add_newline then
+ message ^ "\n"
+ else
+ message
in
- `Assoc [
- "kind", `String "log";
- "payload", `String message;
- ]
+ `Assoc [("kind", `String "log"); ("payload", `String message)]
|> Yojson.Basic.to_string
|> Dream.send session.socket
let build_sandbox sandbox syntax eml =
let dune =
- match syntax, eml with
+ match (syntax, eml) with
| _, false -> sandbox_dune_no_eml
| `OCaml, true -> sandbox_dune
| `Reason, true -> sandbox_dune_re
in
write_file sandbox "dune" dune;%lwt
- begin
- if eml then
- Lwt.return_unit
- else
- write_file sandbox "no-eml" ""
- end;%lwt
+ if eml then
+ Lwt.return_unit
+ else
+ write_file sandbox "no-eml" "";%lwt
let%lwt _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"
+ Printf.sprintf "cd %s && opam exec %s -- dune build %s ./server.exe 2>&1"
(sandbox_root // sandbox) "--color=always" "--no-print-directory"
|> Lwt_process.shell
- |> new Lwt_process.process_in in
+ |> new Lwt_process.process_in
+ in
let%lwt output = Lwt_io.read process#stdout in
match%lwt process#close with
| Unix.WEXITED 0 ->
let%lwt _status =
- exec
- "cp ../../_build/default/example/z-playground/%s/server.exe %s"
+ exec "cp ../../_build/default/example/z-playground/%s/server.exe %s"
(sandbox_root // sandbox) (sandbox_root // sandbox)
in
Lwt.return None
- | _ ->
- Lwt.return (Some output)
+ | _ -> Lwt.return (Some output)
let build session =
match%lwt build_sandbox session.sandbox session.syntax session.eml with
@@ -240,7 +231,7 @@ let build session =
Lwt.return_true
| Some output ->
Dream.info (fun log ->
- log "Sandbox %s: sending build output" session.sandbox);
+ log "Sandbox %s: sending build output" session.sandbox);
client_log session output;%lwt
Lwt.return_false
@@ -252,8 +243,9 @@ let image_exists sandbox =
let image_sandbox sandbox =
write_file sandbox "Dockerfile" sandbox_dockerfile;%lwt
let%lwt _status =
- exec "cd %s && docker build -t sandbox:%s . 2>&1"
- (sandbox_root // sandbox) sandbox in
+ exec "cd %s && docker build -t sandbox:%s . 2>&1" (sandbox_root // sandbox)
+ sandbox
+ in
Lwt.return_unit
let image session =
@@ -262,11 +254,12 @@ let image session =
Lwt.return_unit
let started session port =
- `Assoc [
- "kind", `String "started";
- "sandbox", `String session.sandbox;
- "port", `Int port;
- ]
+ `Assoc
+ [
+ ("kind", `String "started");
+ ("sandbox", `String session.sandbox);
+ ("port", `Int port);
+ ]
|> Yojson.Basic.to_string
|> Dream.send session.socket
@@ -289,47 +282,37 @@ let run session =
in
let%lwt port = allocate_port () in
let container_id = make_container_id () in
- session.container <- Some {container_id; port};
- Lwt.async begin fun () ->
- Printf.sprintf
- "docker run -p %i:8080 --name %s --rm -t sandbox:%s 2>&1"
- port container_id session.sandbox
- |> Lwt_process.shell
- |> Lwt_process.pread_lines
- |> Lwt_stream.iter_s (fun line ->
- signal_alive ();
- client_log ~add_newline:true session line)
- end;
+ session.container <- Some { container_id; port };
+ Lwt.async (fun () ->
+ Printf.sprintf "docker run -p %i:8080 --name %s --rm -t sandbox:%s 2>&1"
+ port container_id session.sandbox
+ |> Lwt_process.shell
+ |> Lwt_process.pread_lines
+ |> Lwt_stream.iter_s (fun line ->
+ signal_alive ();
+ client_log ~add_newline:true session line));
alive;%lwt
started session port;%lwt
Dream.info (fun log ->
- log "Sandbox %s: started %s on port %i" session.sandbox container_id port);
+ 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
Dream.close_websocket session.socket
-
-
(* Main loop for each connected client WebSocket. *)
-let gc_running =
- ref None
-
-let notify_gc =
- ref ignore
-
-let sandbox_users =
- ref 0
-
-let sandbox_locks =
- Hashtbl.create 256
+let gc_running = ref None
+let notify_gc = ref ignore
+let sandbox_users = ref 0
+let sandbox_locks = Hashtbl.create 256
let lock_sandbox sandbox f =
- begin match !gc_running with
- | None -> Lwt.return_unit
- | Some finished -> finished
+ begin
+ match !gc_running with
+ | None -> Lwt.return_unit
+ | Some finished -> finished
end;%lwt
incr sandbox_users;
@@ -355,49 +338,43 @@ let rec listen session =
Dream.info (fun log -> log "WebSocket closed by client");
kill session
| Some code ->
+ Dream.info (fun log -> log "Sandbox %s: code update" session.sandbox);
+ ignore (kill_container session);
- Dream.info (fun log -> log "Sandbox %s: code update" session.sandbox);
- ignore (kill_container session);
-
- lock_sandbox session.sandbox begin fun () ->
-
- let%lwt current_code, _, _ = read session.sandbox in
- if code = current_code then
- Lwt.return_unit
- else begin
- let%lwt sandbox = create session.syntax session.eml code in
- session.sandbox <- sandbox;
- Lwt.return_unit
- end;%lwt
-
- match%lwt image_exists session.sandbox with
- | true -> run session
- | false ->
- match%lwt build session with
- | false -> Lwt.return_unit
- | true ->
- image session;%lwt
- run session
- end;%lwt
+ lock_sandbox session.sandbox (fun () ->
+ let%lwt current_code, _, _ = read session.sandbox in
+ (if code = current_code then
+ Lwt.return_unit
+ else
+ let%lwt sandbox = create session.syntax session.eml code in
+ session.sandbox <- sandbox;
+ Lwt.return_unit);%lwt
+
+ match%lwt image_exists session.sandbox with
+ | true -> run session
+ | false -> (
+ match%lwt build session with
+ | false -> Lwt.return_unit
+ | true ->
+ image session;%lwt
+ run session));%lwt
- listen session
+ listen session
let listen session =
- try%lwt
- listen session
+ try%lwt listen session
with exn ->
kill session;%lwt
raise exn
-
-
let rec gc ?(initial = true) () =
let next = Lwt_unix.sleep 3600. in
let%lwt keep =
Lwt_process.shell "ls sandbox/*/keep | awk -F / '{print $2}'"
|> Lwt_process.pread_lines
- |> Lwt_stream.to_list in
+ |> Lwt_stream.to_list
+ in
let can_start, signal_can_start = Lwt.wait () in
let finished, signal_finished = Lwt.wait () in
@@ -407,47 +384,50 @@ let rec gc ?(initial = true) () =
if !sandbox_users = 0 then
Lwt.return_unit
else begin
- notify_gc :=
- (fun () -> Lwt.wakeup_later signal_can_start (); notify_gc := ignore);
+ (notify_gc :=
+ fun () ->
+ Lwt.wakeup_later signal_can_start ();
+ notify_gc := ignore);
can_start
end;%lwt
- Lwt.finalize begin fun () ->
- Dream.log "Running playground GC";
-
- let%lwt images =
- Lwt_process.shell "docker images | awk '{print $1, $2, $3}'"
- |> Lwt_process.pread_lines
- |> Lwt_stream.to_list
- in
-
- let images =
- images
- |> List.tl
- |> List.map (String.split_on_char ' ')
- |> List.filter_map (function
- | ["base"; _; _] -> None
- | ["ubuntu"; _; ] -> None
- | ["sandbox"; tag; _] when List.mem tag keep -> None
- | [_; _; id] -> Some id
- | _ -> None)
- in
-
- let%lwt _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
- Lwt.return_unit
- end;%lwt
-
- Hashtbl.reset sandbox_locks;
+ Lwt.finalize
+ begin
+ fun () ->
+ Dream.log "Running playground GC";
+
+ let%lwt images =
+ Lwt_process.shell "docker images | awk '{print $1, $2, $3}'"
+ |> Lwt_process.pread_lines
+ |> Lwt_stream.to_list
+ in
+
+ let images =
+ images
+ |> List.tl
+ |> List.map (String.split_on_char ' ')
+ |> List.filter_map (function
+ | ["base"; _; _] -> None
+ | ["ubuntu"; _] -> None
+ | ["sandbox"; tag; _] when List.mem tag keep -> None
+ | [_; _; id] -> Some id
+ | _ -> None)
+ in
+
+ let%lwt _status = exec "docker rmi %s" (String.concat " " images) in
+
+ Lwt_unix.files_of_directory "sandbox"
+ |> Lwt_stream.iter_n ~max_concurrency:16 (fun sandbox ->
+ if List.mem sandbox keep then
+ Lwt.return_unit
+ else
+ let%lwt _status = exec "rm -rf sandbox/%s/_build" sandbox in
+ Lwt.return_unit);%lwt
+
+ Hashtbl.reset sandbox_locks;
- Lwt.return_unit
- end
+ Lwt.return_unit
+ end
(fun () ->
gc_running := None;
Lwt.wakeup_later signal_finished ();
@@ -455,25 +435,22 @@ let rec gc ?(initial = true) () =
Dream.log "Warming caches";
- keep |> Lwt_list.iteri_s begin fun index sandbox ->
- Lwt_unix.sleep 1.;%lwt
- 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
- else begin
- let%lwt _, syntax, eml = read sandbox in
- let%lwt _ = build_sandbox sandbox syntax eml in
- image_sandbox sandbox
- end)
- end;%lwt
+ keep
+ |> Lwt_list.iteri_s (fun index sandbox ->
+ Lwt_unix.sleep 1.;%lwt
+ 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
+ else
+ let%lwt _, syntax, eml = read sandbox in
+ let%lwt _ = build_sandbox sandbox syntax eml in
+ image_sandbox sandbox));%lwt
next;%lwt
gc ~initial:false ()
-
-
(* Entry point. *)
let () =
@@ -482,18 +459,21 @@ let () =
(* Stop when systemd sends SIGTERM. *)
let stop, signal_stop = Lwt.wait () in
Lwt_unix.on_signal Sys.sigterm (fun _signal ->
- Lwt.wakeup_later signal_stop ())
+ Lwt.wakeup_later signal_stop ())
|> ignore;
(* Build the base image. *)
- Lwt_main.run begin
- Lwt_io.(with_file ~mode:Output "Dockerfile" (fun channel ->
- 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
- Lwt.return_unit
- end;
+ Lwt_main.run
+ begin
+ Lwt_io.(
+ with_file ~mode:Output "Dockerfile" (fun channel ->
+ 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
+ Lwt.return_unit
+ end;
(* Start the sandbox gc. *)
Lwt.async gc;
@@ -503,59 +483,54 @@ let () =
let sandbox = Dream.param request "id" in
match validate_id sandbox with
| false -> Dream.empty `Not_Found
- | true ->
- match%lwt exists sandbox with
- | false -> Dream.empty `Not_Found
- | true ->
- let%lwt example =
- match sandbox.[1] with
- | '-' ->
- if%lwt Lwt_unix.file_exists (sandbox_root // sandbox // "keep") then
- Lwt.return (Some sandbox)
- else
- Lwt.return_none
- | _ -> Lwt.return_none
- | exception _ -> Lwt.return_none
- in
- Dream.html (Client.html example)
+ | true -> (
+ match%lwt exists sandbox with
+ | false -> Dream.empty `Not_Found
+ | true ->
+ let%lwt example =
+ match sandbox.[1] with
+ | '-' ->
+ if%lwt Lwt_unix.file_exists (sandbox_root // sandbox // "keep") then
+ Lwt.return (Some sandbox)
+ else
+ Lwt.return_none
+ | _ -> Lwt.return_none
+ | exception _ -> Lwt.return_none
+ in
+ Dream.html (Client.html example))
in
Dream.run ~interface:"0.0.0.0" ~port:80 ~stop ~adjust_terminal:false
@@ Dream.logger
- @@ Dream.router [
-
- (* The client will send a default sandbox id in this case. *)
- Dream.get "/" (fun _ ->
- Dream.html (Client.html None));
-
- (* Upon request for /socket?sandbox=id, send the code in the sandbox to the
- client, and then enter the "REPL." Not bothering with nice replies or
- nice error handling here, because a valid client won't trigger them. If
- they occur, they are harmless to the server. *)
- Dream.get "/socket" (fun request ->
- match Dream.query request "sandbox" with
- | None -> Dream.empty `Bad_Request
- | Some sandbox ->
- match validate_id sandbox with
- | false -> Dream.empty `Bad_Request
- | 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
- Dream.websocket (fun socket ->
- init_client socket content;%lwt
- Dream.info (fun log ->
- log "Sandbox %s: content sent to client" sandbox);
- listen {container = None; sandbox; syntax; eml; socket}));
-
- (* Serve scripts and CSS. *)
- Dream.get "/static/**" (Dream.static "./static");
-
- (* For sandbox ids, respond with the sandbox page. *)
- Dream.get "/:id" playground_handler;
- Dream.get "/:id/**" playground_handler;
-
- ];
+ @@ Dream.router
+ [
+ (* The client will send a default sandbox id in this case. *)
+ Dream.get "/" (fun _ -> Dream.html (Client.html None));
+ (* Upon request for /socket?sandbox=id, send the code in the sandbox to the
+ client, and then enter the "REPL." Not bothering with nice replies or
+ nice error handling here, because a valid client won't trigger them. If
+ they occur, they are harmless to the server. *)
+ Dream.get "/socket" (fun request ->
+ match Dream.query request "sandbox" with
+ | None -> Dream.empty `Bad_Request
+ | Some sandbox -> (
+ match validate_id sandbox with
+ | false -> Dream.empty `Bad_Request
+ | 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
+ Dream.websocket (fun socket ->
+ init_client socket content;%lwt
+ Dream.info (fun log ->
+ log "Sandbox %s: content sent to client" sandbox);
+ listen { container = None; sandbox; syntax; eml; socket })));
+ (* Serve scripts and CSS. *)
+ Dream.get "/static/**" (Dream.static "./static");
+ (* For sandbox ids, respond with the sandbox page. *)
+ Dream.get "/:id" playground_handler;
+ Dream.get "/:id/**" playground_handler;
+ ];
Dream.log "Killing all containers";
Sys.command "docker kill $(docker ps -q)" |> ignore;
File "test/expect/pure/status/status.ml", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/status/status.ml b/_build/default/test/expect/pure/status/.formatted/status.ml
index 51c0254..c7cb890 100644
--- a/_build/default/test/expect/pure/status/status.ml
+++ b/_build/default/test/expect/pure/status/.formatted/status.ml
@@ -3,78 +3,73 @@
Copyright 2021 Anton Bachin *)
-
-
let or_none f value =
match f value with
- Some string -> string
+ | Some string -> string
| None -> "None"
-
-
-let informational = [
- `Continue;
- `Switching_Protocols;
-]
-
-let successful = [
- `OK;
- `Created;
- `Accepted;
- `Non_Authoritative_Information;
- `No_Content;
- `Reset_Content;
- `Partial_Content;
-]
-
-let redirection = [
- `Multiple_Choices;
- `Moved_Permanently;
- `Found;
- `See_Other;
- `Not_Modified;
- `Temporary_Redirect;
- `Permanent_Redirect;
-]
-
-let client_error = [
- `Bad_Request;
- `Unauthorized;
- `Payment_Required;
- `Forbidden;
- `Not_Found;
- `Method_Not_Allowed;
- `Not_Acceptable;
- `Proxy_Authentication_Required;
- `Request_Timeout;
- `Conflict;
- `Gone;
- `Length_Required;
- `Precondition_Failed;
- `Payload_Too_Large;
- `URI_Too_Long;
- `Unsupported_Media_Type;
- `Range_Not_Satisfiable;
- `Expectation_Failed;
- `Misdirected_Request;
- `Too_Early;
- `Upgrade_Required;
- `Precondition_Required;
- `Too_Many_Requests;
- `Request_Header_Fields_Too_Large;
- `Unavailable_For_Legal_Reasons;
-]
-
-let server_error = [
- `Internal_Server_Error;
- `Not_Implemented;
- `Bad_Gateway;
- `Service_Unavailable;
- `Gateway_Timeout;
- `HTTP_Version_Not_Supported;
-]
-
-
+let informational = [`Continue; `Switching_Protocols]
+
+let successful =
+ [
+ `OK;
+ `Created;
+ `Accepted;
+ `Non_Authoritative_Information;
+ `No_Content;
+ `Reset_Content;
+ `Partial_Content;
+ ]
+
+let redirection =
+ [
+ `Multiple_Choices;
+ `Moved_Permanently;
+ `Found;
+ `See_Other;
+ `Not_Modified;
+ `Temporary_Redirect;
+ `Permanent_Redirect;
+ ]
+
+let client_error =
+ [
+ `Bad_Request;
+ `Unauthorized;
+ `Payment_Required;
+ `Forbidden;
+ `Not_Found;
+ `Method_Not_Allowed;
+ `Not_Acceptable;
+ `Proxy_Authentication_Required;
+ `Request_Timeout;
+ `Conflict;
+ `Gone;
+ `Length_Required;
+ `Precondition_Failed;
+ `Payload_Too_Large;
+ `URI_Too_Long;
+ `Unsupported_Media_Type;
+ `Range_Not_Satisfiable;
+ `Expectation_Failed;
+ `Misdirected_Request;
+ `Too_Early;
+ `Upgrade_Required;
+ `Precondition_Required;
+ `Too_Many_Requests;
+ `Request_Header_Fields_Too_Large;
+ `Unavailable_For_Legal_Reasons;
+ ]
+
+let server_error =
+ [
+ `Internal_Server_Error;
+ `Not_Implemented;
+ `Bad_Gateway;
+ `Service_Unavailable;
+ `Gateway_Timeout;
+ `HTTP_Version_Not_Supported;
+ ]
(* Variand codes. *)
@@ -91,7 +86,8 @@ let show_status status =
let%expect_test _ =
informational |> List.iter show_status;
- [%expect {|
+ [%expect
+ {|
100 true false false false false
Continue
Continue
@@ -101,7 +97,8 @@ let%expect_test _ =
let%expect_test _ =
successful |> List.iter show_status;
- [%expect {|
+ [%expect
+ {|
200 false true false false false
OK
OK
@@ -126,7 +123,8 @@ let%expect_test _ =
let%expect_test _ =
redirection |> List.iter show_status;
- [%expect {|
+ [%expect
+ {|
300 false false true false false
Multiple Choices
Multiple Choices
@@ -151,7 +149,8 @@ let%expect_test _ =
let%expect_test _ =
client_error |> List.iter show_status;
- [%expect {|
+ [%expect
+ {|
400 false false false true false
Bad Request
Bad Request
@@ -230,7 +229,8 @@ let%expect_test _ =
let%expect_test _ =
server_error |> List.iter show_status;
- [%expect {|
+ [%expect
+ {|
500 false false false false true
Internal Server Error
Internal Server Error
@@ -250,8 +250,6 @@ let%expect_test _ =
HTTP Version Not Supported
HTTP Version Not Supported |}]
-
-
(* Numeric codes. *)
let show_status_code code =
@@ -268,7 +266,8 @@ let show_status_code code =
let%expect_test _ =
informational |> List.map Dream.status_to_int |> List.iter show_status_code;
- [%expect {|
+ [%expect
+ {|
100 true false false false false
Continue
Continue
@@ -278,7 +277,8 @@ let%expect_test _ =
let%expect_test _ =
successful |> List.map Dream.status_to_int |> List.iter show_status_code;
- [%expect {|
+ [%expect
+ {|
200 false true false false false
OK
OK
@@ -303,7 +303,8 @@ let%expect_test _ =
let%expect_test _ =
redirection |> List.map Dream.status_to_int |> List.iter show_status_code;
- [%expect {|
+ [%expect
+ {|
300 false false true false false
Multiple Choices
Multiple Choices
@@ -328,7 +329,8 @@ let%expect_test _ =
let%expect_test _ =
client_error |> List.map Dream.status_to_int |> List.iter show_status_code;
- [%expect {|
+ [%expect
+ {|
400 false false false true false
Bad Request
Bad Request
@@ -407,7 +409,8 @@ let%expect_test _ =
let%expect_test _ =
server_error |> List.map Dream.status_to_int |> List.iter show_status_code;
- [%expect {|
+ [%expect
+ {|
500 false false false false true
Internal Server Error
Internal Server Error
@@ -430,14 +433,15 @@ let%expect_test _ =
(* Some numeric codes that don't correspond to any variands. *)
let%expect_test _ =
- show_status_code 98;
+ show_status_code 98;
show_status_code 198;
show_status_code 298;
show_status_code 398;
show_status_code 498;
show_status_code 598;
show_status_code 698;
- [%expect {|
+ [%expect
+ {|
98 false false false false false
None
98
@@ -479,7 +483,8 @@ let%expect_test _ =
show_status_code 508;
show_status_code 510;
show_status_code 511;
- [%expect {|
+ [%expect
+ {|
102 true false false false false
Processing
Processing
@@ -540,7 +545,8 @@ let%expect_test _ =
equal `OK (`Status 200);
equal (`Status 200) `OK;
equal `OK (`Status 404);
- [%expect {|
+ [%expect
+ {|
true
false
false
File "test/expect/pure/stream/stream.ml", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/stream/stream.ml b/_build/default/test/expect/pure/stream/.formatted/stream.ml
index 68a1a38..77517b7 100644
--- a/_build/default/test/expect/pure/stream/stream.ml
+++ b/_build/default/test/expect/pure/stream/.formatted/stream.ml
@@ -3,69 +3,52 @@
Copyright 2021 Anton Bachin *)
-
-
module Stream = Dream_pure.Stream
-
-
let read_and_dump stream =
Stream.read stream
~data:(fun buffer offset length binary fin ->
- Printf.printf "read: data: BINARY=%b FIN=%b %s\n"
- binary fin (Bigstringaf.substring buffer ~off:offset ~len:length))
- ~flush:(fun () ->
- print_endline "read: flush")
+ Printf.printf "read: data: BINARY=%b FIN=%b %s\n" binary fin
+ (Bigstringaf.substring buffer ~off:offset ~len:length))
+ ~flush:(fun () -> print_endline "read: flush")
~ping:(fun buffer offset length ->
Printf.printf "read: ping: %s\n"
(Bigstringaf.substring buffer ~off:offset ~len:length))
~pong:(fun buffer offset length ->
Printf.printf "read: pong: %s\n"
(Bigstringaf.substring buffer ~off:offset ~len:length))
- ~close:(fun code ->
- Printf.printf "read: close: CODE=%i\n" code)
- ~exn:(fun exn ->
- Printf.printf "read: exn: %s\n" (Printexc.to_string exn))
+ ~close:(fun code -> Printf.printf "read: close: CODE=%i\n" code)
+ ~exn:(fun exn -> Printf.printf "read: exn: %s\n" (Printexc.to_string exn))
let flush_and_dump stream =
Stream.flush stream
- ~close:(fun code ->
- Printf.printf "flush: close: CODE=%i\n" code)
- ~exn:(fun exn ->
- Printf.printf "flush: exn: %s\n" (Printexc.to_string exn))
- (fun () ->
- print_endline "flush: ok")
+ ~close:(fun code -> Printf.printf "flush: close: CODE=%i\n" code)
+ ~exn:(fun exn -> Printf.printf "flush: exn: %s\n" (Printexc.to_string exn))
+ (fun () -> print_endline "flush: ok")
let write_and_dump stream buffer offset length binary fin =
Stream.write stream buffer offset length binary fin
- ~close:(fun code ->
- Printf.printf "write: close: CODE=%i\n" code)
- ~exn:(fun exn ->
- Printf.printf "write: exn: %s\n" (Printexc.to_string exn))
- (fun () ->
- print_endline "write: ok")
+ ~close:(fun code -> Printf.printf "write: close: CODE=%i\n" code)
+ ~exn:(fun exn -> Printf.printf "write: exn: %s\n" (Printexc.to_string exn))
+ (fun () -> print_endline "write: ok")
let ping_and_dump payload stream =
let length = String.length payload in
- Stream.ping stream (Bigstringaf.of_string ~off:0 ~len:length payload) 0 length
- ~close:(fun code ->
- Printf.printf "ping: close: CODE=%i\n" code)
- ~exn:(fun exn ->
- Printf.printf "ping: exn: %s\n" (Printexc.to_string exn))
- (fun () ->
- print_endline "ping: ok")
+ Stream.ping stream
+ (Bigstringaf.of_string ~off:0 ~len:length payload)
+ 0 length
+ ~close:(fun code -> Printf.printf "ping: close: CODE=%i\n" code)
+ ~exn:(fun exn -> Printf.printf "ping: exn: %s\n" (Printexc.to_string exn))
+ (fun () -> print_endline "ping: ok")
let pong_and_dump payload stream =
let length = String.length payload in
- Stream.pong stream (Bigstringaf.of_string ~off:0 ~len:length payload) 0 length
- ~close:(fun code ->
- Printf.printf "pong: close: CODE=%i\n" code)
- ~exn:(fun exn ->
- Printf.printf "pong: exn: %s\n" (Printexc.to_string exn))
- (fun () ->
- print_endline "pong: ok")
-
-
+ Stream.pong stream
+ (Bigstringaf.of_string ~off:0 ~len:length payload)
+ 0 length
+ ~close:(fun code -> Printf.printf "pong: close: CODE=%i\n" code)
+ ~exn:(fun exn -> Printf.printf "pong: exn: %s\n" (Printexc.to_string exn))
+ (fun () -> print_endline "pong: ok")
(* Read-only streams. *)
@@ -75,7 +58,8 @@ let%expect_test _ =
read_and_dump stream;
Stream.close stream 1005;
read_and_dump stream;
- [%expect {|
+ [%expect
+ {|
read: close: CODE=1000
read: close: CODE=1000
read: close: CODE=1000 |}]
@@ -93,7 +77,8 @@ let%expect_test _ =
read_and_dump stream;
Stream.close stream 1005;
read_and_dump stream;
- [%expect {|
+ [%expect
+ {|
read: data: BINARY=true FIN=true foo
read: close: CODE=1000
read: close: CODE=1000
@@ -116,21 +101,20 @@ let%expect_test _ =
let%expect_test _ =
let stream = Stream.empty in
(try write_and_dump stream Bigstringaf.empty 0 0 false false
- with Failure _ as exn -> print_endline (Printexc.to_string exn));
+ with Failure _ as exn -> print_endline (Printexc.to_string exn));
(try flush_and_dump stream
- with Failure _ as exn -> print_endline (Printexc.to_string exn));
+ with Failure _ as exn -> print_endline (Printexc.to_string exn));
(try ping_and_dump "foo" stream
- with Failure _ as exn -> print_endline (Printexc.to_string exn));
+ with Failure _ as exn -> print_endline (Printexc.to_string exn));
(try pong_and_dump "bar" stream
- with Failure _ as exn -> print_endline (Printexc.to_string exn));
- [%expect {|
+ with Failure _ as exn -> print_endline (Printexc.to_string exn));
+ [%expect
+ {|
Failure("write to a read-only stream")
Failure("flush of a read-only stream")
Failure("ping on a read-only stream")
Failure("pong on a read-only stream") |}]
-
-
(* Pipe: double read. *)
let%expect_test _ =
@@ -138,10 +122,9 @@ let%expect_test _ =
let stream = Stream.stream reader writer in
read_and_dump stream;
try read_and_dump stream
- with Failure _ as exn -> print_endline (Printexc.to_string exn);
- [%expect {| Failure("stream read: the previous read has not completed") |}]
-
-
+ with Failure _ as exn ->
+ print_endline (Printexc.to_string exn);
+ [%expect {| Failure("stream read: the previous read has not completed") |}]
(* Pipe: interactions between read and close. *)
@@ -155,7 +138,8 @@ let%expect_test _ =
read_and_dump stream;
print_endline "checkpoint 3";
Stream.close stream 1000;
- [%expect {|
+ [%expect
+ {|
checkpoint 1
read: close: CODE=1005
checkpoint 2
@@ -172,8 +156,6 @@ let%expect_test _ =
read: close: CODE=1005
read: close: CODE=1005 |}]
-
-
(* Pipe: interactions between read and flush. *)
let%expect_test _ =
@@ -184,19 +166,17 @@ let%expect_test _ =
flush_and_dump stream;
flush_and_dump stream;
read_and_dump stream;
- [%expect {|
+ [%expect
+ {|
checkpoint 1
read: flush
flush: ok
read: flush
flush: ok |}]
-
-
(* Pipe: interactions between read and write. *)
-let buffer =
- Bigstringaf.of_string ~off:0 ~len:3 "foo"
+let buffer = Bigstringaf.of_string ~off:0 ~len:3 "foo"
let%expect_test _ =
let reader, writer = Stream.pipe () in
@@ -206,15 +186,14 @@ let%expect_test _ =
write_and_dump stream buffer 0 3 false true;
write_and_dump stream buffer 1 1 true false;
read_and_dump stream;
- [%expect {|
+ [%expect
+ {|
checkpoint 1
read: data: BINARY=false FIN=true foo
write: ok
read: data: BINARY=true FIN=false o
write: ok |}]
-
-
(* Pipe: interactions between read and ping. *)
let%expect_test _ =
@@ -225,15 +204,14 @@ let%expect_test _ =
ping_and_dump "foo" stream;
ping_and_dump "bar" stream;
read_and_dump stream;
- [%expect {|
+ [%expect
+ {|
checkpoint 1
read: ping: foo
ping: ok
read: ping: bar
ping: ok |}]
-
-
(* Pipe: interactions between read and pong. *)
let%expect_test _ =
@@ -244,15 +222,14 @@ let%expect_test _ =
pong_and_dump "foo" stream;
pong_and_dump "bar" stream;
read_and_dump stream;
- [%expect {|
+ [%expect
+ {|
checkpoint 1
read: pong: foo
pong: ok
read: pong: bar
pong: ok |}]
-
-
(* Pipe: interactions between flush and close. *)
let%expect_test _ =
@@ -263,8 +240,6 @@ let%expect_test _ =
[%expect {|
flush: close: CODE=1005 |}]
-
-
(* Pipe: interactions between write and close. *)
let%expect_test _ =
@@ -275,8 +250,6 @@ let%expect_test _ =
[%expect {|
write: close: CODE=1005 |}]
-
-
(* Pipe: interactions between ping and close. *)
let%expect_test _ =
@@ -287,8 +260,6 @@ let%expect_test _ =
[%expect {|
ping: close: CODE=1005 |}]
-
-
(* Pipe: interactions between pong and close. *)
let%expect_test _ =
File "test/expect/pure/formats/base64/base64.ml", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/formats/base64/base64.ml b/_build/default/test/expect/pure/formats/base64/.formatted/base64.ml
index ec6d0b3..561a8fa 100644
--- a/_build/default/test/expect/pure/formats/base64/base64.ml
+++ b/_build/default/test/expect/pure/formats/base64/.formatted/base64.ml
@@ -3,10 +3,7 @@
Copyright 2021 Anton Bachin *)
-
-
-let encode string =
- Printf.printf "%S\n" (Dream.to_base64url string)
+let encode string = Printf.printf "%S\n" (Dream.to_base64url string)
let%expect_test _ =
encode "a";
@@ -17,7 +14,8 @@ let%expect_test _ =
encode "abcdef";
encode "abcde";
encode "";
- [%expect {|
+ [%expect
+ {|
"YQ"
"Yg"
"_w"
File "test/expect/pure/formats/cookie/cookie.ml", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/formats/cookie/cookie.ml b/_build/default/test/expect/pure/formats/cookie/.formatted/cookie.ml
index 4870f95..b0d3e73 100644
--- a/_build/default/test/expect/pure/formats/cookie/cookie.ml
+++ b/_build/default/test/expect/pure/formats/cookie/.formatted/cookie.ml
@@ -3,8 +3,6 @@
Copyright 2021 Anton Bachin *)
-
-
let parse string =
string
|> Dream.from_cookie
@@ -18,13 +16,15 @@ let%expect_test _ =
parse " a ";
parse "a=b";
parse " a = b ";
- parse "a=\"b\""; (* TODO This appears to parse incorrectly w.r.t RFC. *)
+ parse "a=\"b\"";
+ (* TODO This appears to parse incorrectly w.r.t RFC. *)
parse "a=b;c=d";
parse "a=b; c=d";
parse "a=b ; c=d";
parse "a=b;c";
parse "a;c=d";
- [%expect {|
+ [%expect
+ {|
[]
[]
[]
@@ -37,8 +37,7 @@ let%expect_test _ =
["a"="b"]
["c"="d"] |}]
-let show =
- Printf.printf "%S\n"
+let show = Printf.printf "%S\n"
let%expect_test _ =
show @@ Dream.to_set_cookie "a" "b";
@@ -62,23 +61,24 @@ let%expect_test _ =
show @@ Dream.to_set_cookie "a" "b" ~expires:1616431310.;
show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. -. day);
show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. day);
- show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. 2. *. day);
- show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. 3. *. day);
- show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. 4. *. day);
- show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. 5. *. day);
- show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. 6. *. day);
+ show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. (2. *. day));
+ show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. (3. *. day));
+ show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. (4. *. day));
+ show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. (5. *. day));
+ show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. (6. *. day));
show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. -. month);
- show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. -. 2. *. month);
+ show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. -. (2. *. month));
show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. month);
- show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. 2. *. month);
- show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. 3. *. month);
- show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. 4. *. month);
- show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. 5. *. month);
- show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. 6. *. month);
- show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. 7. *. month);
- show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. 8. *. month);
- show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. 9. *. month);
- [%expect {|
+ show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. (2. *. month));
+ show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. (3. *. month));
+ show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. (4. *. month));
+ show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. (5. *. month));
+ show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. (6. *. month));
+ show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. (7. *. month));
+ show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. (8. *. month));
+ show @@ Dream.to_set_cookie "a" "b" ~expires:(1616431310. +. (9. *. month));
+ [%expect
+ {|
"a=b; Expires=Mon, 22 Mar 2021 16:41:50 GMT"
"a=b; Expires=Sun, 21 Mar 2021 16:41:50 GMT"
"a=b; Expires=Tue, 23 Mar 2021 16:41:50 GMT"
@@ -108,7 +108,8 @@ let%expect_test _ =
show @@ Dream.to_set_cookie "a" "b" ~max_age:1.6;
show @@ Dream.to_set_cookie "a" "b" ~max_age:(-1.4);
show @@ Dream.to_set_cookie "a" "b" ~max_age:(-1.6);
- [%expect {|
+ [%expect
+ {|
"a=b; Max-Age=1"
"a=b; Max-Age=42"
"a=b; Max-Age=-1"
@@ -143,7 +144,8 @@ let%expect_test _ =
show @@ Dream.to_set_cookie "a" "b" ~same_site:`Strict;
show @@ Dream.to_set_cookie "a" "b" ~same_site:`Lax;
show @@ Dream.to_set_cookie "a" "b" ~same_site:`None;
- [%expect {|
+ [%expect
+ {|
"a=b; SameSite=Strict"
"a=b; SameSite=Lax"
"a=b; SameSite=None" |}]
File "test/expect/pure/formats/escape/escape.ml", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/formats/escape/escape.ml b/_build/default/test/expect/pure/formats/escape/.formatted/escape.ml
index 12e981b..8076a31 100644
--- a/_build/default/test/expect/pure/formats/escape/escape.ml
+++ b/_build/default/test/expect/pure/formats/escape/.formatted/escape.ml
@@ -3,10 +3,7 @@
Copyright 2021 Anton Bachin *)
-
-
-let escape string =
- Printf.printf "%S\n" (Dream.html_escape string)
+let escape string = Printf.printf "%S\n" (Dream.html_escape string)
let%expect_test _ =
escape "";
@@ -15,7 +12,8 @@ let%expect_test _ =
escape "&";
escape "<foo bar=\"baz\">";
escape "<foo bar=\'baz\'>";
- [%expect {|
+ [%expect
+ {|
""
"foo"
"<foo>"
File "test/expect/pure/formats/form_urlencoded/form_urlencoded.ml", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/formats/form_urlencoded/form_urlencoded.ml b/_build/default/test/expect/pure/formats/form_urlencoded/.formatted/form_urlencoded.ml
index 0a6ecd3..f66267e 100644
--- a/_build/default/test/expect/pure/formats/form_urlencoded/form_urlencoded.ml
+++ b/_build/default/test/expect/pure/formats/form_urlencoded/.formatted/form_urlencoded.ml
@@ -3,25 +3,22 @@
Copyright 2021 Anton Bachin *)
-
-
let encode dictionary =
- dictionary
- |> Dream.to_form_urlencoded
- |> Printf.printf "%S\n"
+ dictionary |> Dream.to_form_urlencoded |> Printf.printf "%S\n"
let%expect_test _ =
encode [];
- encode ["a", ""];
- encode ["", "a"];
- encode ["", ""];
- encode ["a", "b"];
- encode ["a b", "c d"];
- encode ["a+=&", "b+=&"];
- encode ["λ", "Λ"];
- encode ["a", "b"; "a", "c"];
- encode ["a", "b,c"];
- [%expect {|
+ encode [("a", "")];
+ encode [("", "a")];
+ encode [("", "")];
+ encode [("a", "b")];
+ encode [("a b", "c d")];
+ encode [("a+=&", "b+=&")];
+ encode [("λ", "Λ")];
+ encode [("a", "b"); ("a", "c")];
+ encode [("a", "b,c")];
+ [%expect
+ {|
""
"a="
"=a"
@@ -33,8 +30,6 @@ let%expect_test _ =
"a=b&a=c"
"a=b%2Cc" |}]
-
-
let decode string =
string
|> Dream.from_form_urlencoded
File "test/expect/pure/formats/path/path.ml", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/formats/path/path.ml b/_build/default/test/expect/pure/formats/path/.formatted/path.ml
index 7db3c8c..bc755e2 100644
--- a/_build/default/test/expect/pure/formats/path/path.ml
+++ b/_build/default/test/expect/pure/formats/path/.formatted/path.ml
@@ -3,8 +3,6 @@
Copyright 2021 Anton Bachin *)
-
-
let decode string =
string
|> Dream.from_path
@@ -30,7 +28,8 @@ let%expect_test _ =
decode "/%cg";
decode "/%";
decode "/%/";
- [%expect {|
+ [%expect
+ {|
[]
[""]
["abc"]
@@ -68,8 +67,7 @@ let%expect_test _ =
["a" "b"] |}]
let encode ?relative ?international components =
- Dream.to_path ?relative ?international components
- |> Printf.printf "%S\n"
+ Dream.to_path ?relative ?international components |> Printf.printf "%S\n"
let%expect_test _ =
encode [];
@@ -86,7 +84,8 @@ let%expect_test _ =
encode ~relative:true ["a"; ""];
encode ~relative:true [""; "a"];
encode ~international:false ["λ"];
- [%expect {|
+ [%expect
+ {|
"/"
"/"
"/a"
File "test/expect/pure/formats/percent/percent.ml", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/formats/percent/percent.ml b/_build/default/test/expect/pure/formats/percent/.formatted/percent.ml
index edc9292..232d424 100644
--- a/_build/default/test/expect/pure/formats/percent/percent.ml
+++ b/_build/default/test/expect/pure/formats/percent/.formatted/percent.ml
@@ -3,8 +3,6 @@
Copyright 2021 Anton Bachin *)
-
-
let encode ?international s =
Printf.printf "%S\n" (Dream.to_percent_encoded ?international s)
@@ -17,8 +15,7 @@ let%expect_test _ =
"a%2F%20\206\187"
"a%2F%20%CE%BB" |}]
-let decode s =
- Printf.printf "%S\n" (Dream.from_percent_encoded s)
+let decode s = Printf.printf "%S\n" (Dream.from_percent_encoded s)
let%expect_test _ =
decode "";
@@ -30,7 +27,8 @@ let%expect_test _ =
decode "%zz";
decode "%1A";
decode "λ%CE%BB";
- [%expect {|
+ [%expect
+ {|
""
"%"
"%2"
File "test/expect/pure/formats/query/query.ml", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/formats/query/query.ml b/_build/default/test/expect/pure/formats/query/.formatted/query.ml
index 8abcc16..2e2b613 100644
--- a/_build/default/test/expect/pure/formats/query/query.ml
+++ b/_build/default/test/expect/pure/formats/query/.formatted/query.ml
@@ -3,13 +3,10 @@
Copyright 2021 Anton Bachin *)
-
-
let query name string =
- Dream.query (Dream.request ~target:("/?" ^ string) "") name
- |> function
- | Some value -> Printf.printf "%S\n" value
- | None -> print_endline "None"
+ Dream.query (Dream.request ~target:("/?" ^ string) "") name |> function
+ | Some value -> Printf.printf "%S\n" value
+ | None -> print_endline "None"
let%expect_test _ =
query "a" "a=b";
@@ -21,7 +18,8 @@ let%expect_test _ =
query "a" "a=b&a=c";
query "c" "a=b&c=d";
query "a b" "a+b=c";
- [%expect {|
+ [%expect
+ {|
"b"
None
None
@@ -32,8 +30,6 @@ let%expect_test _ =
"d"
"c" |}]
-
-
let queries name string =
Dream.queries (Dream.request ~target:("/?" ^ string) "") name
|> List.map (Printf.sprintf "%S")
@@ -50,7 +46,8 @@ let%expect_test _ =
queries "a" "a=b&a=c";
queries "c" "a=b&c=d";
queries "a b" "a+b=c";
- [%expect {|
+ [%expect
+ {|
["b"]
[]
[]
@@ -61,8 +58,6 @@ let%expect_test _ =
["d"]
["c"] |}]
-
-
let all_queries string =
Dream.request ~target:("/?" ^ string) ""
|> Dream.all_queries
@@ -76,7 +71,8 @@ let%expect_test _ =
all_queries "";
all_queries "=";
all_queries "a+b=c+d";
- [%expect {|
+ [%expect
+ {|
["a"="b"]
["a"="b" "a"="c"]
[]
File "test/expect/pure/formats/target/target.ml", line 1, characters 0-0:
diff --git a/_build/default/test/expect/pure/formats/target/target.ml b/_build/default/test/expect/pure/formats/target/.formatted/target.ml
index 4ee17a7..20bab6e 100644
--- a/_build/default/test/expect/pure/formats/target/target.ml
+++ b/_build/default/test/expect/pure/formats/target/.formatted/target.ml
@@ -3,12 +3,9 @@
Copyright 2021 Anton Bachin *)
-
-
let decode string =
- string
- |> Dream.split_target
- |> fun (path, query) -> Printf.printf "%S %S\n" path query
+ string |> Dream.split_target |> fun (path, query) ->
+ Printf.printf "%S %S\n" path query
let%expect_test _ =
decode "";
@@ -28,7 +25,8 @@ let%expect_test _ =
decode "/abc%2F%26def?a=b&c=d%2B";
decode "/abc/#foo";
decode "/abc/?de=f#foo";
- [%expect {|
+ [%expect
+ {|
"" ""
"" ""
"/" ""
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
Warning: option `if-then-else`: value `fit-or-vertical` is deprecated since version 0.20.0. It will be removed by version 1.0.0.
File "example/z-docker-opam/app.ml", line 1, characters 0-0:
diff --git a/_build/default/example/z-docker-opam/app.ml b/_build/default/example/z-docker-opam/.formatted/app.ml
index df30015..c5fe969 100644
--- a/_build/default/example/z-docker-opam/app.ml
+++ b/_build/default/example/z-docker-opam/.formatted/app.ml
@@ -1,7 +1,8 @@
let () =
Dream.run ~interface:"0.0.0.0"
@@ Dream.logger
- @@ Dream.router [
- Dream.get "/" (fun _ ->
- Dream.html "Dream started by Docker Compose, built with opam!");
- ]
+ @@ Dream.router
+ [
+ Dream.get "/" (fun _ ->
+ Dream.html "Dream started by Docker Compose, built with opam!");
+ ]
dune build @fmt failed
"/usr/bin/env" "bash" "-c" "opam exec -- dune build @fmt --ignore-promoted-rules || (echo "dune build @fmt failed"; exit 2)" failed with exit status 2
2026-03-28 07:57.44: Job failed: Failed: Build failed