From 63eeca57899e9033ba2c6e208664cf5b2692fe93 Mon Sep 17 00:00:00 2001 From: Marc Biedermann Date: Mon, 3 Feb 2025 12:21:34 +0100 Subject: [PATCH] update deprecated use of functions, use digestif for sha hashes (removed in mirage-crypto), update packages, update devcontainer, update CI --- .devcontainer/Dockerfile | 6 +- .devcontainer/postCreate.sh | 8 +- .github/workflows/ci.yml | 22 +++- .gitignore | 2 + dune-project | 10 +- sihl-cache.opam.locked | 126 ++++++++++++++++++++++- sihl-email.opam | 2 +- sihl-email.opam.locked | 153 +++++++++++++++++++--------- sihl-email/src/sihl_email.ml | 24 ++--- sihl-email/src/template.ml | 2 +- sihl-email/src/template_repo_sql.ml | 20 ++-- sihl-queue.opam.locked | 121 ++++++++++++++++++++-- sihl-queue/src/admin_ui.ml | 16 +-- sihl-queue/src/repo_inmemory.ml | 6 +- sihl-queue/src/repo_sql.ml | 27 +++-- sihl-queue/src/sihl_queue.ml | 38 +++---- sihl-queue/src/sihl_queue.mli | 3 +- sihl-queue/test/queue.ml | 20 ++-- sihl-storage.opam.locked | 126 ++++++++++++++++++++++- sihl-storage/src/sihl_storage.ml | 2 +- sihl-storage/test/storage.ml | 4 +- sihl-token.opam.locked | 126 ++++++++++++++++++++++- sihl-token/src/sihl_token.ml | 2 +- sihl-user.opam.locked | 127 ++++++++++++++++++++++- sihl-user/src/sihl_user.ml | 58 +++++------ sihl-user/src/user_repo.ml | 16 +-- sihl.opam | 8 +- sihl.opam.locked | 125 ++++++++++++++--------- sihl/src/contract_database.ml | 3 +- sihl/src/contract_email_template.ml | 14 +-- sihl/src/contract_migration.ml | 10 +- sihl/src/contract_queue.ml | 16 +-- sihl/src/contract_user.ml | 64 ++++++------ sihl/src/core_app.mli | 3 +- sihl/src/core_command.ml | 62 +++++------ sihl/src/core_configuration.ml | 43 ++++---- sihl/src/core_lifecycle.ml | 18 ++-- sihl/src/core_log.ml | 8 +- sihl/src/core_random.ml | 13 +++ sihl/src/core_schedule.ml | 12 +-- sihl/src/core_service.ml | 20 ++-- sihl/src/core_time.ml | 6 +- sihl/src/database.ml | 106 +++++++++---------- sihl/src/database_migration.ml | 116 ++++++++++----------- sihl/src/gen_core.ml | 24 ++--- sihl/src/gen_entity.ml | 2 +- sihl/src/gen_migration.ml | 6 +- sihl/src/gen_repo.ml | 6 +- sihl/src/sihl.mli | 23 ++++- sihl/src/web.ml | 4 +- sihl/src/web_csrf.ml | 82 ++++++++------- sihl/src/web_error.ml | 93 ++++++++--------- sihl/src/web_migration.ml | 7 +- sihl/src/web_rest.ml | 86 ++++++++-------- sihl/src/web_session.ml | 50 ++++----- sihl/src/web_trailing_slash.ml | 6 +- sihl/test/database.ml | 12 +-- sihl/test/web_csrf.ml | 18 ++-- sihl/test/web_flash.ml | 70 ++++++------- sihl/test/web_session.ml | 8 +- 60 files changed, 1489 insertions(+), 722 deletions(-) diff --git a/.devcontainer/Dockerfile b/.devcontainer/Dockerfile index fbb2f9004..9e21e27bb 100644 --- a/.devcontainer/Dockerfile +++ b/.devcontainer/Dockerfile @@ -1,5 +1,4 @@ FROM node:lts AS node -FROM hadolint/hadolint:latest-alpine AS hadolint FROM ocaml/opam:debian-10-ocaml-4.14 USER root @@ -15,7 +14,7 @@ RUN ln -s /usr/local/lib/node_modules/npm/bin/npm-cli.js /usr/local/bin/npm \ && ln -s /opt/yarn-v*/bin/yarnpkg /usr/local/bin/yarnpkg # copy hadolint -COPY --from=hadolint /bin/hadolint /bin/hadolint +COPY --from=hadolint/hadolint:latest-alpine /bin/hadolint /bin/hadolint # Avoid warnings by switching to noninteractive ENV DEBIAN_FRONTEND noninteractive @@ -51,6 +50,9 @@ RUN ln -fs /usr/share/zoneinfo/Europe/Zurich /etc/localtime RUN bash -c 'echo "http 80/tcp www # WorldWideWeb HTTP" >> /etc/services' \ && bash -c 'echo "https 443/tcp www # WorldWideWeb HTTPS" >> /etc/services' +# link opam version +RUN ln -fs /usr/bin/opam-2.2 /usr/bin/opam + USER opam # install oh-my-zsh diff --git a/.devcontainer/postCreate.sh b/.devcontainer/postCreate.sh index b0adc2929..9f7b47ba3 100644 --- a/.devcontainer/postCreate.sh +++ b/.devcontainer/postCreate.sh @@ -12,8 +12,12 @@ opam init -a --shell=zsh opam remote remove --all default opam remote add default https://opam.ocaml.org -opam pin add . --yes --no-action -opam depext sihl sihl-user sihl-storage sihl-email sihl-queue sihl-cache sihl-token --yes --with-doc --with-test +# TODO: remove pins when the packages are released +opam pin add -yn opium https://github.com/mabiede/opium.git#upgrade-packages +opam pin add -yn rock https://github.com/mabiede/opium.git#upgrade-packages + +# install dev dependencies +opam install --yes --with-doc --with-test --deps-only --working-dir . eval $(opam env) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index a06ba1684..e2dff87c1 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -29,15 +29,23 @@ jobs: os: - ubuntu-latest ocaml-compiler: - - 4.12.x + - 4.14 steps: - name: Checkout code - uses: actions/checkout@v2 + uses: actions/checkout@v4 + + - name: Retrieve opam cache + uses: actions/cache@v4 + if: runner.os != 'Windows' + id: cache-opam + with: + path: ~/.opam + key: v1-${{ runner.os }}-opam-${{ matrix.ocaml-compiler }}-${{ hashFiles('*.opam.locked') }} + - name: Use OCaml ${{ matrix.ocaml-version }} - uses: ocaml/setup-ocaml@v2 + uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: ${{ matrix.ocaml-compiler }} - dune-cache: true - name: Install system dependencies run: sudo apt-get update -y && sudo apt-get install -y libmariadb-dev @@ -45,6 +53,12 @@ jobs: - name: Install dependencies run: make deps + - name: Recover from an Opam broken state + if: steps.cache-opam.outputs.cache-hit == 'true' + run: | + opam install -y dune + opam upgrade --fixup + - name: Build run: make build diff --git a/.gitignore b/.gitignore index 518adf55c..a2a36b42d 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,5 @@ .merlin .devcontainer/data *.install +opium +.DS_Store diff --git a/dune-project b/dune-project index 864ec6cee..793acf66a 100644 --- a/dune-project +++ b/dune-project @@ -51,7 +51,7 @@ (ppx_deriving_yojson (>= 3.5.2)) (tls - (>= 0.11.1)) + (>= 1.0.4)) (ssl (>= 0.5.9)) (lwt_ssl @@ -67,15 +67,15 @@ (jwto (>= 0.3.0)) (uuidm - (>= 0.9.7)) + (>= 0.9.9)) (ppx_fields_conv (>= v0.13.0)) (ppx_sexp_conv (>= v0.13.0)) (mirage-crypto - (>= 0.11.2)) + (>= 1.1.0)) (mirage-crypto-rng - (>= 0.11.2)) + (>= 1.2.0)) (cstruct (>= 6.0.1)) (opium @@ -215,7 +215,7 @@ (ocaml (>= 4.08.0)) (letters - (>= 0.2.1)) + (>= 0.4.0)) (sihl (= :version)) (cohttp-lwt-unix diff --git a/sihl-cache.opam.locked b/sihl-cache.opam.locked index e5bb2c907..68acc2697 100644 --- a/sihl-cache.opam.locked +++ b/sihl-cache.opam.locked @@ -9,10 +9,128 @@ homepage: "https://github.com/oxidizing/sihl" doc: "https://oxidizing.github.io/sihl/" bug-reports: "https://github.com/oxidizing/sihl/issues" depends: [ + "alcotest" {= "1.8.0" & with-test} + "alcotest-lwt" {= "1.8.0" & with-test} + "angstrom" {= "0.16.1"} + "asn1-combinators" {= "0.3.2"} + "astring" {= "0.8.5"} + "base" {= "v0.16.3"} + "base-bigarray" {= "base"} + "base-bytes" {= "base"} "base-threads" {= "base"} "base-unix" {= "base"} - "dune" {= "3.11.1"} - "ocaml" {= "4.14.1"} + "base64" {= "3.5.1"} + "bigarray-compat" {= "1.1.0"} + "bigstringaf" {= "0.10.0"} + "bos" {= "0.2.1"} + "camlp-streams" {= "5.0.1" & with-doc} + "caqti" {= "2.1.2"} + "caqti-driver-mariadb" {= "2.1.1" & with-test} + "caqti-driver-postgresql" {= "2.1.2" & with-test} + "caqti-lwt" {= "2.1.1"} + "cmdliner" {= "1.3.0"} + "conf-bash" {= "1"} + "conf-gcc" {= "1.0"} + "conf-gmp" {= "4"} + "conf-gmp-powm-sec" {= "3"} + "conf-libssl" {= "4"} + "conf-mariadb" {= "2"} + "conf-pkg-config" {= "4"} + "conf-postgresql" {= "2" & with-test} + "conformist" {= "0.8.1"} + "containers" {= "3.15"} + "cppo" {= "1.8.0"} + "crunch" {= "3.3.1" & with-doc} + "csexp" {= "1.5.2"} + "cstruct" {= "6.2.0"} + "ctypes" {= "0.23.0"} + "digestif" {= "1.2.0"} + "domain-name" {= "0.4.0"} + "dune" {= "3.17.2"} + "dune-build-info" {= "3.17.2"} + "dune-configurator" {= "3.17.2"} + "dune-private-libs" {= "3.17.2"} + "dune-site" {= "3.17.2"} + "duration" {= "0.2.1"} + "dyn" {= "3.17.2"} + "either" {= "1.0.0"} + "eqaf" {= "0.10"} + "faraday" {= "0.8.2"} + "faraday-lwt" {= "0.8.2"} + "faraday-lwt-unix" {= "0.8.2"} + "fieldslib" {= "v0.16.0"} + "fmt" {= "0.9.0"} + "fpath" {= "0.7.3"} + "gmap" {= "0.3.0"} + "hmap" {= "0.8.1"} + "httpaf" {= "0.7.1"} + "httpaf-lwt-unix" {= "0.7.1"} + "integers" {= "0.7.0"} + "ipaddr" {= "5.6.0"} + "jwto" {= "0.4.0"} + "kdf" {= "1.0.0"} + "logs" {= "0.7.0"} + "lwt" {= "5.9.0"} + "lwt-dllist" {= "1.0.1"} + "lwt_ppx" {= "5.8.0"} + "lwt_ssl" {= "1.2.0"} + "macaddr" {= "5.6.0"} + "magic-mime" {= "1.3.1"} + "mariadb" {= "1.2.0"} + "mirage-crypto" {= "1.2.0"} + "mirage-crypto-ec" {= "1.2.0"} + "mirage-crypto-pk" {= "1.2.0"} + "mirage-crypto-rng" {= "1.2.0"} + "mtime" {= "2.1.0"} + "multipart-form-data" {= "0.3.0"} + "num" {= "1.5-1"} + "ocaml" {= "4.14.2"} + "ocaml-base-compiler" {= "4.14.2"} + "ocaml-compiler-libs" {= "v0.12.4"} + "ocaml-config" {= "2"} + "ocaml-options-vanilla" {= "1"} + "ocaml-syntax-shims" {= "1.0.0"} + "ocamlbuild" {= "0.15.0"} + "ocamlfind" {= "1.9.6"} + "ocplib-endian" {= "1.2"} + "odoc" {= "2.4.4" & with-doc} + "odoc-parser" {= "2.4.4" & with-doc} + "ohex" {= "0.2.0"} + "opium" {= "0.20.0"} + "ordering" {= "3.17.2"} + "parsexp" {= "v0.16.0"} + "postgresql" {= "5.1.3" & with-test} + "pp" {= "2.0.0"} + "ppx_derivers" {= "1.2.1"} + "ppx_deriving" {= "6.0.3"} + "ppx_deriving_yojson" {= "3.9.1"} + "ppx_fields_conv" {= "v0.16.0"} + "ppx_sexp_conv" {= "v0.16.0"} + "ppxlib" {= "0.34.0"} + "ptime" {= "1.2.0"} + "re" {= "1.12.0"} + "result" {= "1.5"} + "rock" {= "0.20.0"} + "rresult" {= "0.7.0"} + "safepass" {= "3.1"} + "seq" {= "base"} + "sexplib" {= "v0.16.0"} + "sexplib0" {= "v0.16.0"} + "sihl" {= "4.0.0"} + "ssl" {= "0.7.0"} + "stdlib-shims" {= "0.3.0"} + "stdune" {= "3.17.2"} + "stringext" {= "1.6.0"} + "tls" {= "1.0.4"} + "topkg" {= "1.0.7"} + "tsort" {= "2.1.0"} + "tyxml" {= "4.6.0"} + "uri" {= "4.4.0"} + "uuidm" {= "0.9.9"} + "uutf" {= "1.0.3"} + "x509" {= "1.0.5"} + "yojson" {= "2.2.2"} + "zarith" {= "1.14"} ] build: [ ["dune" "subst"] {dev} @@ -30,3 +148,7 @@ build: [ ] dev-repo: "git+https://github.com/oxidizing/sihl.git" name: "sihl-cache" +pin-depends: [ + ["opium.0.20.0" "git+https://github.com/mabiede/opium.git#upgrade-packages"] + ["rock.0.20.0" "git+https://github.com/mabiede/opium.git#upgrade-packages"] +] diff --git a/sihl-email.opam b/sihl-email.opam index e0666244b..d935b92da 100644 --- a/sihl-email.opam +++ b/sihl-email.opam @@ -12,7 +12,7 @@ bug-reports: "https://github.com/oxidizing/sihl/issues" depends: [ "dune" {>= "2.7"} "ocaml" {>= "4.08.0"} - "letters" {>= "0.2.1"} + "letters" {>= "0.4.0"} "sihl" {= version} "cohttp-lwt-unix" {>= "2.5.4"} "alcotest-lwt" {>= "1.4.0" & with-test} diff --git a/sihl-email.opam.locked b/sihl-email.opam.locked index c42e897de..bff9a7994 100644 --- a/sihl-email.opam.locked +++ b/sihl-email.opam.locked @@ -9,100 +9,155 @@ homepage: "https://github.com/oxidizing/sihl" doc: "https://oxidizing.github.io/sihl/" bug-reports: "https://github.com/oxidizing/sihl/issues" depends: [ - "angstrom" {= "0.15.0"} - "asn1-combinators" {= "0.2.6"} + "alcotest" {= "1.8.0" & with-test} + "alcotest-lwt" {= "1.8.0" & with-test} + "angstrom" {= "0.16.1"} + "asn1-combinators" {= "0.3.2"} "astring" {= "0.8.5"} "base" {= "v0.16.3"} + "base-bigarray" {= "base"} "base-bytes" {= "base"} "base-threads" {= "base"} "base-unix" {= "base"} "base64" {= "3.5.1"} "bigarray-compat" {= "1.1.0"} "bigarray-overlap" {= "0.2.1"} - "bigstringaf" {= "0.9.1"} + "bigstringaf" {= "0.10.0"} "bos" {= "0.2.1"} - "ca-certs" {= "0.2.3"} - "cmdliner" {= "1.2.0"} - "cohttp" {= "5.3.0"} - "cohttp-lwt" {= "5.3.0"} - "cohttp-lwt-unix" {= "5.3.0"} + "ca-certs" {= "1.0.0"} + "camlp-streams" {= "5.0.1" & with-doc} + "caqti" {= "2.1.2"} + "caqti-driver-mariadb" {= "2.1.1" & with-test} + "caqti-driver-postgresql" {= "2.1.2" & with-test} + "caqti-lwt" {= "2.1.1"} + "cmdliner" {= "1.3.0"} + "cohttp" {= "6.0.0"} + "cohttp-lwt" {= "6.0.0"} + "cohttp-lwt-unix" {= "6.0.0"} "coin" {= "0.1.4"} - "colombe" {= "0.8.0"} - "conduit" {= "6.2.0"} - "conduit-lwt" {= "6.2.0"} - "conduit-lwt-unix" {= "6.2.0"} + "colombe" {= "0.11.0"} + "conduit" {= "7.1.0"} + "conduit-lwt" {= "7.1.0"} + "conduit-lwt-unix" {= "7.1.0"} + "conf-bash" {= "1"} + "conf-gcc" {= "1.0"} "conf-gmp" {= "4"} "conf-gmp-powm-sec" {= "3"} - "conf-libev" {= "4-12"} "conf-libssl" {= "4"} - "conf-pkg-config" {= "3"} - "cppo" {= "1.6.9"} + "conf-mariadb" {= "2"} + "conf-pkg-config" {= "4"} + "conf-postgresql" {= "2" & with-test} + "conformist" {= "0.8.1"} + "containers" {= "3.15"} + "cppo" {= "1.8.0"} + "crunch" {= "3.3.1" & with-doc} "csexp" {= "1.5.2"} - "cstruct" {= "6.0.1"} + "cstruct" {= "6.2.0"} + "ctypes" {= "0.23.0"} + "digestif" {= "1.2.0"} "domain-name" {= "0.4.0"} - "dune" {= "3.11.1"} - "dune-configurator" {= "3.11.1"} + "dune" {= "3.17.2"} + "dune-build-info" {= "3.17.2"} + "dune-configurator" {= "3.17.2"} + "dune-private-libs" {= "3.17.2"} + "dune-site" {= "3.17.2"} "duration" {= "0.2.1"} + "dyn" {= "3.17.2"} + "either" {= "1.0.0"} "emile" {= "1.1"} - "eqaf" {= "0.9"} + "eqaf" {= "0.10"} + "faraday" {= "0.8.2"} + "faraday-lwt" {= "0.8.2"} + "faraday-lwt-unix" {= "0.8.2"} + "fieldslib" {= "v0.16.0"} "fmt" {= "0.9.0"} "fpath" {= "0.7.3"} "gmap" {= "0.3.0"} - "hkdf" {= "1.0.4"} - "ipaddr" {= "5.5.0"} - "ipaddr-sexp" {= "5.5.0"} - "jsonm" {= "1.0.2"} + "hmap" {= "0.8.1"} + "http" {= "6.0.0"} + "httpaf" {= "0.7.1"} + "httpaf-lwt-unix" {= "0.7.1"} + "hxd" {= "0.3.3"} + "integers" {= "0.7.0"} + "ipaddr" {= "5.6.0"} + "ipaddr-sexp" {= "5.6.0"} + "jwto" {= "0.4.0"} + "kdf" {= "1.0.0"} "ke" {= "0.6"} - "letters" {= "0.3.3"} + "letters" {= "0.4.0"} "logs" {= "0.7.0"} - "lwt" {= "5.7.0"} + "lwt" {= "5.9.0"} + "lwt-dllist" {= "1.0.1"} + "lwt_ppx" {= "5.8.0"} "lwt_ssl" {= "1.2.0"} - "macaddr" {= "5.5.0"} + "macaddr" {= "5.6.0"} "magic-mime" {= "1.3.1"} - "mirage-crypto" {= "0.11.2"} - "mirage-crypto-ec" {= "0.11.2"} - "mirage-crypto-pk" {= "0.11.2"} - "mirage-crypto-rng" {= "0.11.2"} - "mirage-crypto-rng-lwt" {= "0.11.2"} - "mrmime" {= "0.6.0"} - "mtime" {= "2.0.0"} - "num" {= "1.4"} - "ocaml" {= "4.14.1"} + "mariadb" {= "1.2.0"} + "mirage-crypto" {= "1.2.0"} + "mirage-crypto-ec" {= "1.2.0"} + "mirage-crypto-pk" {= "1.2.0"} + "mirage-crypto-rng" {= "1.2.0"} + "mirage-crypto-rng-lwt" {= "1.2.0"} + "mrmime" {= "0.6.1"} + "mtime" {= "2.1.0"} + "multipart-form-data" {= "0.3.0"} + "num" {= "1.5-1"} + "ocaml" {= "4.14.2"} + "ocaml-base-compiler" {= "4.14.2"} "ocaml-compiler-libs" {= "v0.12.4"} + "ocaml-config" {= "2"} + "ocaml-options-vanilla" {= "1"} "ocaml-syntax-shims" {= "1.0.0"} - "ocamlbuild" {= "0.14.2"} + "ocamlbuild" {= "0.15.0"} "ocamlfind" {= "1.9.6"} "ocplib-endian" {= "1.2"} + "odoc" {= "2.4.4" & with-doc} + "odoc-parser" {= "2.4.4" & with-doc} + "ohex" {= "0.2.0"} + "opium" {= "0.20.0"} + "ordering" {= "3.17.2"} "parsexp" {= "v0.16.0"} - "pbkdf" {= "1.2.0"} - "pecu" {= "0.6"} + "pecu" {= "0.7"} + "postgresql" {= "5.1.3" & with-test} + "pp" {= "2.0.0"} "ppx_derivers" {= "1.2.1"} + "ppx_deriving" {= "6.0.3"} + "ppx_deriving_yojson" {= "3.9.1"} + "ppx_fields_conv" {= "v0.16.0"} "ppx_sexp_conv" {= "v0.16.0"} - "ppxlib" {= "0.31.0"} + "ppxlib" {= "0.34.0"} "prettym" {= "0.0.3"} - "ptime" {= "1.1.0"} - "re" {= "1.11.0"} + "ptime" {= "1.2.0"} + "re" {= "1.12.0"} "result" {= "1.5"} + "rock" {= "0.20.0"} "rosetta" {= "0.3.0"} "rresult" {= "0.7.0"} - "sendmail" {= "0.8.0"} + "safepass" {= "3.1"} + "sendmail" {= "0.11.0"} "seq" {= "base"} "sexplib" {= "v0.16.0"} "sexplib0" {= "v0.16.0"} + "sihl" {= "4.0.0"} "ssl" {= "0.7.0"} "stdlib-shims" {= "0.3.0"} + "stdune" {= "3.17.2"} "stringext" {= "1.6.0"} - "tls" {= "0.17.1"} - "tls-lwt" {= "0.17.1"} + "tls" {= "1.0.4"} + "tls-lwt" {= "1.0.4"} "topkg" {= "1.0.7"} - "unstrctrd" {= "0.3"} + "tsort" {= "2.1.0"} + "tyxml" {= "4.6.0"} + "unstrctrd" {= "0.4"} "uri" {= "4.4.0"} "uri-sexp" {= "4.4.0"} + "uuidm" {= "0.9.9"} "uutf" {= "1.0.3"} "uuuu" {= "0.3.0"} - "x509" {= "0.16.5"} + "x509" {= "1.0.5"} + "yojson" {= "2.2.2"} "yuscii" {= "0.3.0"} - "zarith" {= "1.13"} + "zarith" {= "1.14"} ] build: [ ["dune" "subst"] {dev} @@ -120,3 +175,7 @@ build: [ ] dev-repo: "git+https://github.com/oxidizing/sihl.git" name: "sihl-email" +pin-depends: [ + ["opium.0.20.0" "git+https://github.com/mabiede/opium.git#upgrade-packages"] + ["rock.0.20.0" "git+https://github.com/mabiede/opium.git#upgrade-packages"] +] diff --git a/sihl-email/src/sihl_email.ml b/sihl-email/src/sihl_email.ml index e2ec92368..a33353af9 100644 --- a/sihl-email/src/sihl_email.ml +++ b/sihl-email/src/sihl_email.ml @@ -78,16 +78,16 @@ type smtp_config = } let smtp_config - sender - username - password - mechanism - hostname - port - start_tls - ca_path - ca_cert - console + sender + username + password + mechanism + hostname + port + start_tls + ca_path + ca_cert + console = { sender ; username @@ -389,8 +389,8 @@ module Queued Lwt.catch (fun () -> Email.send ?ctx email |> Lwt.map Result.ok) (fun exn -> - let exn_string = Printexc.to_string exn in - Lwt.return @@ Error exn_string) + let exn_string = Printexc.to_string exn in + Lwt.return @@ Error exn_string) ;; let job = diff --git a/sihl-email/src/template.ml b/sihl-email/src/template.ml index 5edc7800e..dfb0857ed 100644 --- a/sihl-email/src/template.ml +++ b/sihl-email/src/template.ml @@ -14,7 +14,7 @@ struct let create ?ctx ?id ?html ?language ~label text = let open Sihl.Contract.Email_template in let now = Ptime_clock.now () in - let id = Option.value id ~default:(Uuidm.v `V4 |> Uuidm.to_string) in + let id = Option.value id ~default:(Sihl.Random.Uuid.create ()) in let template = { id; label; language; html; text; created_at = now; updated_at = now } in diff --git a/sihl-email/src/template_repo_sql.ml b/sihl-email/src/template_repo_sql.ml index 7e2dc688b..8f83ec573 100644 --- a/sihl-email/src/template_repo_sql.ml +++ b/sihl-email/src/template_repo_sql.ml @@ -101,11 +101,11 @@ struct WHERE email_templates.label = ? |sql} |> (fun sql -> - if with_language - then - {sql| AND email_templates.language = ? |sql} - |> Format.asprintf "%s\n%s" sql - else sql) + if with_language + then + {sql| AND email_templates.language = ? |sql} + |> Format.asprintf "%s\n%s" sql + else sql) |> ctype ->? template ;; @@ -321,11 +321,11 @@ struct WHERE email_templates.label = ? |sql} |> (fun sql -> - if with_language - then - {sql| AND email_templates.language = ? |sql} - |> Format.asprintf "%s\n%s" sql - else sql) + if with_language + then + {sql| AND email_templates.language = ? |sql} + |> Format.asprintf "%s\n%s" sql + else sql) |> ctype ->? template ;; diff --git a/sihl-queue.opam.locked b/sihl-queue.opam.locked index c59890888..5f8b9a0b8 100644 --- a/sihl-queue.opam.locked +++ b/sihl-queue.opam.locked @@ -10,27 +10,132 @@ homepage: "https://github.com/oxidizing/sihl" doc: "https://oxidizing.github.io/sihl/" bug-reports: "https://github.com/oxidizing/sihl/issues" depends: [ + "alcotest" {= "1.8.0" & with-test} + "alcotest-lwt" {= "1.8.0" & with-test} + "angstrom" {= "0.16.1"} + "asn1-combinators" {= "0.3.2"} + "astring" {= "0.8.5"} + "base" {= "v0.16.3"} + "base-bigarray" {= "base"} + "base-bytes" {= "base"} "base-threads" {= "base"} "base-unix" {= "base"} - "cmdliner" {= "1.2.0"} - "dune" {= "3.11.1"} + "base64" {= "3.5.1"} + "bigarray-compat" {= "1.1.0"} + "bigstringaf" {= "0.10.0"} + "bos" {= "0.2.1"} + "camlp-streams" {= "5.0.1" & with-doc} + "caqti" {= "2.1.2"} + "caqti-driver-mariadb" {= "2.1.1" & with-test} + "caqti-driver-postgresql" {= "2.1.2" & with-test} + "caqti-lwt" {= "2.1.1"} + "cmdliner" {= "1.3.0"} + "conf-bash" {= "1"} + "conf-gcc" {= "1.0"} + "conf-gmp" {= "4"} + "conf-gmp-powm-sec" {= "3"} + "conf-libssl" {= "4"} + "conf-mariadb" {= "2"} + "conf-pkg-config" {= "4"} + "conf-postgresql" {= "2" & with-test} + "conformist" {= "0.8.1"} + "containers" {= "3.15"} + "cppo" {= "1.8.0"} + "crunch" {= "3.3.1" & with-doc} + "csexp" {= "1.5.2"} + "cstruct" {= "6.2.0"} + "ctypes" {= "0.23.0"} + "digestif" {= "1.2.0"} + "domain-name" {= "0.4.0"} + "dune" {= "3.17.2"} + "dune-build-info" {= "3.17.2"} + "dune-configurator" {= "3.17.2"} + "dune-private-libs" {= "3.17.2"} + "dune-site" {= "3.17.2"} + "duration" {= "0.2.1"} + "dyn" {= "3.17.2"} + "either" {= "1.0.0"} + "eqaf" {= "0.10"} + "faraday" {= "0.8.2"} + "faraday-lwt" {= "0.8.2"} + "faraday-lwt-unix" {= "0.8.2"} + "fieldslib" {= "v0.16.0"} + "fmt" {= "0.9.0"} + "fpath" {= "0.7.3"} + "gmap" {= "0.3.0"} + "hmap" {= "0.8.1"} + "httpaf" {= "0.7.1"} + "httpaf-lwt-unix" {= "0.7.1"} + "integers" {= "0.7.0"} + "ipaddr" {= "5.6.0"} + "jwto" {= "0.4.0"} + "kdf" {= "1.0.0"} + "logs" {= "0.7.0"} + "lwt" {= "5.9.0"} + "lwt-dllist" {= "1.0.1"} + "lwt_ppx" {= "5.8.0"} + "lwt_ssl" {= "1.2.0"} + "macaddr" {= "5.6.0"} + "magic-mime" {= "1.3.1"} + "mariadb" {= "1.2.0"} "markup" {= "1.0.3"} - "ocaml" {= "4.14.1"} + "mirage-crypto" {= "1.2.0"} + "mirage-crypto-ec" {= "1.2.0"} + "mirage-crypto-pk" {= "1.2.0"} + "mirage-crypto-rng" {= "1.2.0"} + "mtime" {= "2.1.0"} + "multipart-form-data" {= "0.3.0"} + "num" {= "1.5-1"} + "ocaml" {= "4.14.2"} + "ocaml-base-compiler" {= "4.14.2"} "ocaml-compiler-libs" {= "v0.12.4"} - "ocamlbuild" {= "0.14.2"} + "ocaml-config" {= "2"} + "ocaml-options-vanilla" {= "1"} + "ocaml-syntax-shims" {= "1.0.0"} + "ocamlbuild" {= "0.15.0"} "ocamlfind" {= "1.9.6"} + "ocplib-endian" {= "1.2"} + "odoc" {= "2.4.4" & with-doc} + "odoc-parser" {= "2.4.4" & with-doc} + "ohex" {= "0.2.0"} + "opium" {= "0.20.0"} + "ordering" {= "3.17.2"} + "parsexp" {= "v0.16.0"} + "postgresql" {= "5.1.3" & with-test} + "pp" {= "2.0.0"} "ppx_derivers" {= "1.2.1"} - "ppxlib" {= "0.31.0"} - "re" {= "1.11.0"} + "ppx_deriving" {= "6.0.3"} + "ppx_deriving_yojson" {= "3.9.1"} + "ppx_fields_conv" {= "v0.16.0"} + "ppx_sexp_conv" {= "v0.16.0"} + "ppxlib" {= "0.34.0"} + "ptime" {= "1.2.0"} + "re" {= "1.12.0"} + "result" {= "1.5"} + "rock" {= "0.20.0"} + "rresult" {= "0.7.0"} + "safepass" {= "3.1"} "seq" {= "base"} + "sexplib" {= "v0.16.0"} "sexplib0" {= "v0.16.0"} + "sihl" {= "4.0.0"} + "ssl" {= "0.7.0"} "stdlib-shims" {= "0.3.0"} + "stdune" {= "3.17.2"} + "stringext" {= "1.6.0"} + "tls" {= "1.0.4"} "topkg" {= "1.0.7"} + "tsort" {= "2.1.0"} "tyxml" {= "4.6.0"} "tyxml-ppx" {= "4.6.0"} "tyxml-syntax" {= "4.6.0"} "uchar" {= "0.0.2"} + "uri" {= "4.4.0"} + "uuidm" {= "0.9.9"} "uutf" {= "1.0.3"} + "x509" {= "1.0.5"} + "yojson" {= "2.2.2"} + "zarith" {= "1.14"} ] build: [ ["dune" "subst"] {dev} @@ -48,3 +153,7 @@ build: [ ] dev-repo: "git+https://github.com/oxidizing/sihl.git" name: "sihl-queue" +pin-depends: [ + ["opium.0.20.0" "git+https://github.com/mabiede/opium.git#upgrade-packages"] + ["rock.0.20.0" "git+https://github.com/mabiede/opium.git#upgrade-packages"] +] diff --git a/sihl-queue/src/admin_ui.ml b/sihl-queue/src/admin_ui.ml index 8a2277734..305b1ade9 100644 --- a/sihl-queue/src/admin_ui.ml +++ b/sihl-queue/src/admin_ui.ml @@ -414,14 +414,14 @@ let middlewares = ;; let router - search_jobs - find_job - cancel_job - requeue_job - ?back - ?theme - ?prefix - scope + search_jobs + find_job + cancel_job + requeue_job + ?back + ?theme + ?prefix + scope = Sihl.Web.choose ~middlewares diff --git a/sihl-queue/src/repo_inmemory.ml b/sihl-queue/src/repo_inmemory.ml index dff65f250..e77c0011f 100644 --- a/sihl-queue/src/repo_inmemory.ml +++ b/sihl-queue/src/repo_inmemory.ml @@ -69,7 +69,7 @@ let search ?ctx:_ (sort : [ `Desc | `Asc ]) filter ~limit ~offset = let filtered = Map.filter (fun _ (job : Sihl.Contract.Queue.instance) -> - Option.equal (fun t f -> CCString.find ~sub:f t > -1) job.tag filter) + Option.equal (fun t f -> CCString.find ~sub:f t > -1) job.tag filter) !state |> Map.to_seq |> List.of_seq @@ -79,8 +79,8 @@ let search ?ctx:_ (sort : [ `Desc | `Asc ]) filter ~limit ~offset = |> CCList.sort (fun (j1 : Sihl.Contract.Queue.instance) - (j2 : Sihl.Contract.Queue.instance) - -> Option.compare String.compare j1.tag j2.tag) + (j2 : Sihl.Contract.Queue.instance) + -> Option.compare String.compare j1.tag j2.tag) |> fun l -> if sort == `Desc then l else List.rev l in Lwt.return @@ (filtered, List.length filtered) diff --git a/sihl-queue/src/repo_sql.ml b/sihl-queue/src/repo_sql.ml index 7963452aa..60a533434 100644 --- a/sihl-queue/src/repo_sql.ml +++ b/sihl-queue/src/repo_sql.ml @@ -49,13 +49,14 @@ let job = ) ) ) ) ) in let decode - ( id - , ( name - , ( input - , ( tries - , ( next_run_at - , (max_tries, (status, (last_error, (last_error_at, (tag, ctx))))) - ) ) ) ) ) + ( id + , ( name + , ( input + , ( tries + , ( next_run_at + , ( max_tries + , (status, (last_error, (last_error_at, (tag, ctx)))) ) ) ) ) + ) ) = Ok { id @@ -143,8 +144,8 @@ module MakeMariaDb (MigrationService : Sihl.Contract.Migration.Sig) = struct Sihl.Contract.Queue. { j with id = - (match j.id |> Uuidm.of_string with - | Some uuid -> Uuidm.to_bytes uuid + (match j.id |> Sihl.Random.Uuid.of_string with + | Some uuid -> Sihl.Random.Uuid.to_binary_string uuid | None -> failwith "Invalid uuid provided") }) ;; @@ -311,9 +312,11 @@ module MakeMariaDb (MigrationService : Sihl.Contract.Migration.Sig) = struct let clean ?ctx () = Sihl.Database.exec ?ctx clean_request () - let filter_fragment = {sql| + let filter_fragment = + {sql| WHERE queue_jobs.tag LIKE $1 |sql} + ;; let search_query = {sql| @@ -626,9 +629,11 @@ module MakePostgreSql (MigrationService : Sihl.Contract.Migration.Sig) = struct let clean ?ctx () = Sihl.Database.exec ?ctx clean_request () - let filter_fragment = {sql| + let filter_fragment = + {sql| WHERE queue_jobs.tag LIKE $1 |sql} + ;; let search_query = {sql| diff --git a/sihl-queue/src/sihl_queue.ml b/sihl-queue/src/sihl_queue.ml index a3e91242f..8a4881466 100644 --- a/sihl-queue/src/sihl_queue.ml +++ b/sihl-queue/src/sihl_queue.ml @@ -13,7 +13,7 @@ let create_instance ?(ctx = []) input delay now (job : 'a job) = | None -> now in let max_tries = job.max_tries in - { id = Uuidm.v `V4 |> Uuidm.to_string + { id = Sihl.Random.Uuid.create () ; name ; input ; tries = 0 @@ -128,14 +128,14 @@ module Make (Repo : Repo.Sig) : Sihl.Contract.Queue.Sig = struct Lwt.catch (fun () -> job.handle ~ctx:job_instance.ctx input) (fun exn -> - let exn_string = Printexc.to_string exn in - Logs.err (fun m -> - m - "Exception caught while running job, this is a bug in your job \ - handler. Don't throw exceptions there, use Result.t instead. \ - '%s'" - exn_string); - Lwt.return @@ Error exn_string) + let exn_string = Printexc.to_string exn in + Logs.err (fun m -> + m + "Exception caught while running job, this is a bug in your job \ + handler. Don't throw exceptions there, use Result.t instead. \ + '%s'" + exn_string); + Lwt.return @@ Error exn_string) in match result with | Error msg -> @@ -147,17 +147,17 @@ module Make (Repo : Repo.Sig) : Sihl.Contract.Queue.Sig = struct msg); Lwt.catch (fun () -> - let%lwt () = job.failed ?ctx msg job_instance in - Lwt.return @@ Error msg) + let%lwt () = job.failed ?ctx msg job_instance in + Lwt.return @@ Error msg) (fun exn -> - let exn_string = Printexc.to_string exn in - Logs.err (fun m -> - m - "Exception caught while cleaning up job, this is a bug in your \ - job failure handler, make sure to not throw exceptions there \ - '%s" - exn_string); - Lwt.return @@ Error exn_string) + let exn_string = Printexc.to_string exn in + Logs.err (fun m -> + m + "Exception caught while cleaning up job, this is a bug in your \ + job failure handler, make sure to not throw exceptions there \ + '%s" + exn_string); + Lwt.return @@ Error exn_string) | Ok () -> Logs.debug (fun m -> m "Successfully ran job instance '%s'" job_instance_id); diff --git a/sihl-queue/src/sihl_queue.mli b/sihl-queue/src/sihl_queue.mli index 00d58feb6..19403c45a 100644 --- a/sihl-queue/src/sihl_queue.mli +++ b/sihl-queue/src/sihl_queue.mli @@ -119,6 +119,7 @@ module MariaDb : sig end module PostgreSql : sig - (** The PostgreSQL queue backend supports fully persistent queues and locking. *) + (** The PostgreSQL queue backend supports fully persistent queues and locking. + *) include Sihl.Contract.Queue.Sig end diff --git a/sihl-queue/test/queue.ml b/sihl-queue/test/queue.ml index 93681cc8a..2998d1c3a 100644 --- a/sihl-queue/test/queue.ml +++ b/sihl-queue/test/queue.ml @@ -10,7 +10,7 @@ let create_instance input delay now (job : 'a Sihl_queue.job) = | None -> now in let max_tries = job.max_tries in - { id = Uuidm.v `V4 |> Uuidm.to_string + { id = Sihl.Random.Uuid.create () ; name ; input ; tries = 0 @@ -25,8 +25,8 @@ let create_instance input delay now (job : 'a Sihl_queue.job) = ;; let update_next_run_at - (retry_delay : Ptime.Span.t) - (job_instance : Sihl_queue.instance) + (retry_delay : Ptime.Span.t) + (job_instance : Sihl_queue.instance) = let open Sihl_queue in let next_run_at = @@ -146,11 +146,11 @@ module Make (QueueService : Sihl.Contract.Queue.Sig) = struct ~max_tries:3 ~retry_delay:(Sihl.Time.Span.minutes 1) (fun ?(ctx = []) _ -> - (match ctx with - | [ ("pool", "test") ] -> () - | [] -> failwith "an empty ctx was provided, expected non-emtpy ctx" - | _ -> failwith "ctx is not passed to job correctly"); - Lwt_result.return (has_ran_job := true)) + (match ctx with + | [ ("pool", "test") ] -> () + | [] -> failwith "an empty ctx was provided, expected non-emtpy ctx" + | _ -> failwith "ctx is not passed to job correctly"); + Lwt_result.return (has_ran_job := true)) (fun () -> "") (fun _ -> Ok ()) "foo" @@ -174,8 +174,8 @@ module Make (QueueService : Sihl.Contract.Queue.Sig) = struct ~max_tries:3 ~retry_delay:(Sihl.Time.Span.minutes 1) (fun ?ctx:_ input -> - Lwt_result.return - (processed_inputs := List.cons input !processed_inputs)) + Lwt_result.return + (processed_inputs := List.cons input !processed_inputs)) (fun str -> str) (fun str -> Ok str) "foo" diff --git a/sihl-storage.opam.locked b/sihl-storage.opam.locked index aadae0b10..1444d91bd 100644 --- a/sihl-storage.opam.locked +++ b/sihl-storage.opam.locked @@ -10,10 +10,128 @@ homepage: "https://github.com/oxidizing/sihl" doc: "https://oxidizing.github.io/sihl/" bug-reports: "https://github.com/oxidizing/sihl/issues" depends: [ + "alcotest" {= "1.8.0" & with-test} + "alcotest-lwt" {= "1.8.0" & with-test} + "angstrom" {= "0.16.1"} + "asn1-combinators" {= "0.3.2"} + "astring" {= "0.8.5"} + "base" {= "v0.16.3"} + "base-bigarray" {= "base"} + "base-bytes" {= "base"} "base-threads" {= "base"} "base-unix" {= "base"} - "dune" {= "3.11.1"} - "ocaml" {= "4.14.1"} + "base64" {= "3.5.1"} + "bigarray-compat" {= "1.1.0"} + "bigstringaf" {= "0.10.0"} + "bos" {= "0.2.1"} + "camlp-streams" {= "5.0.1" & with-doc} + "caqti" {= "2.1.2"} + "caqti-driver-mariadb" {= "2.1.1" & with-test} + "caqti-driver-postgresql" {= "2.1.2" & with-test} + "caqti-lwt" {= "2.1.1"} + "cmdliner" {= "1.3.0"} + "conf-bash" {= "1"} + "conf-gcc" {= "1.0"} + "conf-gmp" {= "4"} + "conf-gmp-powm-sec" {= "3"} + "conf-libssl" {= "4"} + "conf-mariadb" {= "2"} + "conf-pkg-config" {= "4"} + "conf-postgresql" {= "2" & with-test} + "conformist" {= "0.8.1"} + "containers" {= "3.15"} + "cppo" {= "1.8.0"} + "crunch" {= "3.3.1" & with-doc} + "csexp" {= "1.5.2"} + "cstruct" {= "6.2.0"} + "ctypes" {= "0.23.0"} + "digestif" {= "1.2.0"} + "domain-name" {= "0.4.0"} + "dune" {= "3.17.2"} + "dune-build-info" {= "3.17.2"} + "dune-configurator" {= "3.17.2"} + "dune-private-libs" {= "3.17.2"} + "dune-site" {= "3.17.2"} + "duration" {= "0.2.1"} + "dyn" {= "3.17.2"} + "either" {= "1.0.0"} + "eqaf" {= "0.10"} + "faraday" {= "0.8.2"} + "faraday-lwt" {= "0.8.2"} + "faraday-lwt-unix" {= "0.8.2"} + "fieldslib" {= "v0.16.0"} + "fmt" {= "0.9.0"} + "fpath" {= "0.7.3"} + "gmap" {= "0.3.0"} + "hmap" {= "0.8.1"} + "httpaf" {= "0.7.1"} + "httpaf-lwt-unix" {= "0.7.1"} + "integers" {= "0.7.0"} + "ipaddr" {= "5.6.0"} + "jwto" {= "0.4.0"} + "kdf" {= "1.0.0"} + "logs" {= "0.7.0"} + "lwt" {= "5.9.0"} + "lwt-dllist" {= "1.0.1"} + "lwt_ppx" {= "5.8.0"} + "lwt_ssl" {= "1.2.0"} + "macaddr" {= "5.6.0"} + "magic-mime" {= "1.3.1"} + "mariadb" {= "1.2.0"} + "mirage-crypto" {= "1.2.0"} + "mirage-crypto-ec" {= "1.2.0"} + "mirage-crypto-pk" {= "1.2.0"} + "mirage-crypto-rng" {= "1.2.0"} + "mtime" {= "2.1.0"} + "multipart-form-data" {= "0.3.0"} + "num" {= "1.5-1"} + "ocaml" {= "4.14.2"} + "ocaml-base-compiler" {= "4.14.2"} + "ocaml-compiler-libs" {= "v0.12.4"} + "ocaml-config" {= "2"} + "ocaml-options-vanilla" {= "1"} + "ocaml-syntax-shims" {= "1.0.0"} + "ocamlbuild" {= "0.15.0"} + "ocamlfind" {= "1.9.6"} + "ocplib-endian" {= "1.2"} + "odoc" {= "2.4.4" & with-doc} + "odoc-parser" {= "2.4.4" & with-doc} + "ohex" {= "0.2.0"} + "opium" {= "0.20.0"} + "ordering" {= "3.17.2"} + "parsexp" {= "v0.16.0"} + "postgresql" {= "5.1.3" & with-test} + "pp" {= "2.0.0"} + "ppx_derivers" {= "1.2.1"} + "ppx_deriving" {= "6.0.3"} + "ppx_deriving_yojson" {= "3.9.1"} + "ppx_fields_conv" {= "v0.16.0"} + "ppx_sexp_conv" {= "v0.16.0"} + "ppxlib" {= "0.34.0"} + "ptime" {= "1.2.0"} + "re" {= "1.12.0"} + "result" {= "1.5"} + "rock" {= "0.20.0"} + "rresult" {= "0.7.0"} + "safepass" {= "3.1"} + "seq" {= "base"} + "sexplib" {= "v0.16.0"} + "sexplib0" {= "v0.16.0"} + "sihl" {= "4.0.0"} + "ssl" {= "0.7.0"} + "stdlib-shims" {= "0.3.0"} + "stdune" {= "3.17.2"} + "stringext" {= "1.6.0"} + "tls" {= "1.0.4"} + "topkg" {= "1.0.7"} + "tsort" {= "2.1.0"} + "tyxml" {= "4.6.0"} + "uri" {= "4.4.0"} + "uuidm" {= "0.9.9"} + "uutf" {= "1.0.3"} + "x509" {= "1.0.5"} + "yojson" {= "2.2.2"} + "zarith" {= "1.14"} ] build: [ ["dune" "subst"] {dev} @@ -31,3 +149,7 @@ build: [ ] dev-repo: "git+https://github.com/oxidizing/sihl.git" name: "sihl-storage" +pin-depends: [ + ["opium.0.20.0" "git+https://github.com/mabiede/opium.git#upgrade-packages"] + ["rock.0.20.0" "git+https://github.com/mabiede/opium.git#upgrade-packages"] +] diff --git a/sihl-storage/src/sihl_storage.ml b/sihl-storage/src/sihl_storage.ml index 47ec6bb73..7ae26ad5a 100644 --- a/sihl-storage/src/sihl_storage.ml +++ b/sihl-storage/src/sihl_storage.ml @@ -23,7 +23,7 @@ module Make (Repo : Repo.Sig) : Sihl.Contract.Storage.Sig = struct ;; let upload_base64 ?ctx ?id file base64 = - let blob_id = Option.value id ~default:(Uuidm.v `V4 |> Uuidm.to_string) in + let blob_id = Option.value id ~default:(Sihl.Random.Uuid.create ()) in let%lwt blob = match Base64.decode base64 with | Error (`Msg msg) -> diff --git a/sihl-storage/test/storage.ml b/sihl-storage/test/storage.ml index 5a219da9a..ef02f8f83 100644 --- a/sihl-storage/test/storage.ml +++ b/sihl-storage/test/storage.ml @@ -11,7 +11,7 @@ let alco_file = Alcotest.testable Sihl_storage.pp_file file_equal module Make (StorageService : Sihl.Contract.Storage.Sig) = struct let fetch_uploaded_file _ () = let%lwt () = Sihl.Cleaner.clean_all () in - let file_id = Uuidm.v `V4 |> Uuidm.to_string in + let file_id = Sihl.Random.Uuid.create () in let file = Sihl.Contract.Storage. { id = file_id @@ -31,7 +31,7 @@ module Make (StorageService : Sihl.Contract.Storage.Sig) = struct let update_uploaded_file _ () = let%lwt () = Sihl.Cleaner.clean_all () in - let file_id = Uuidm.v `V4 |> Uuidm.to_string in + let file_id = Sihl.Random.Uuid.create () in let file = Sihl.Contract.Storage. { id = file_id diff --git a/sihl-token.opam.locked b/sihl-token.opam.locked index 1734dfa00..3d736b044 100644 --- a/sihl-token.opam.locked +++ b/sihl-token.opam.locked @@ -10,10 +10,128 @@ homepage: "https://github.com/oxidizing/sihl" doc: "https://oxidizing.github.io/sihl/" bug-reports: "https://github.com/oxidizing/sihl/issues" depends: [ + "alcotest" {= "1.8.0" & with-test} + "alcotest-lwt" {= "1.8.0" & with-test} + "angstrom" {= "0.16.1"} + "asn1-combinators" {= "0.3.2"} + "astring" {= "0.8.5"} + "base" {= "v0.16.3"} + "base-bigarray" {= "base"} + "base-bytes" {= "base"} "base-threads" {= "base"} "base-unix" {= "base"} - "dune" {= "3.11.1"} - "ocaml" {= "4.14.1"} + "base64" {= "3.5.1"} + "bigarray-compat" {= "1.1.0"} + "bigstringaf" {= "0.10.0"} + "bos" {= "0.2.1"} + "camlp-streams" {= "5.0.1" & with-doc} + "caqti" {= "2.1.2"} + "caqti-driver-mariadb" {= "2.1.1" & with-test} + "caqti-driver-postgresql" {= "2.1.2" & with-test} + "caqti-lwt" {= "2.1.1"} + "cmdliner" {= "1.3.0"} + "conf-bash" {= "1"} + "conf-gcc" {= "1.0"} + "conf-gmp" {= "4"} + "conf-gmp-powm-sec" {= "3"} + "conf-libssl" {= "4"} + "conf-mariadb" {= "2"} + "conf-pkg-config" {= "4"} + "conf-postgresql" {= "2" & with-test} + "conformist" {= "0.8.1"} + "containers" {= "3.15"} + "cppo" {= "1.8.0"} + "crunch" {= "3.3.1" & with-doc} + "csexp" {= "1.5.2"} + "cstruct" {= "6.2.0"} + "ctypes" {= "0.23.0"} + "digestif" {= "1.2.0"} + "domain-name" {= "0.4.0"} + "dune" {= "3.17.2"} + "dune-build-info" {= "3.17.2"} + "dune-configurator" {= "3.17.2"} + "dune-private-libs" {= "3.17.2"} + "dune-site" {= "3.17.2"} + "duration" {= "0.2.1"} + "dyn" {= "3.17.2"} + "either" {= "1.0.0"} + "eqaf" {= "0.10"} + "faraday" {= "0.8.2"} + "faraday-lwt" {= "0.8.2"} + "faraday-lwt-unix" {= "0.8.2"} + "fieldslib" {= "v0.16.0"} + "fmt" {= "0.9.0"} + "fpath" {= "0.7.3"} + "gmap" {= "0.3.0"} + "hmap" {= "0.8.1"} + "httpaf" {= "0.7.1"} + "httpaf-lwt-unix" {= "0.7.1"} + "integers" {= "0.7.0"} + "ipaddr" {= "5.6.0"} + "jwto" {= "0.4.0"} + "kdf" {= "1.0.0"} + "logs" {= "0.7.0"} + "lwt" {= "5.9.0"} + "lwt-dllist" {= "1.0.1"} + "lwt_ppx" {= "5.8.0"} + "lwt_ssl" {= "1.2.0"} + "macaddr" {= "5.6.0"} + "magic-mime" {= "1.3.1"} + "mariadb" {= "1.2.0"} + "mirage-crypto" {= "1.2.0"} + "mirage-crypto-ec" {= "1.2.0"} + "mirage-crypto-pk" {= "1.2.0"} + "mirage-crypto-rng" {= "1.2.0"} + "mtime" {= "2.1.0"} + "multipart-form-data" {= "0.3.0"} + "num" {= "1.5-1"} + "ocaml" {= "4.14.2"} + "ocaml-base-compiler" {= "4.14.2"} + "ocaml-compiler-libs" {= "v0.12.4"} + "ocaml-config" {= "2"} + "ocaml-options-vanilla" {= "1"} + "ocaml-syntax-shims" {= "1.0.0"} + "ocamlbuild" {= "0.15.0"} + "ocamlfind" {= "1.9.6"} + "ocplib-endian" {= "1.2"} + "odoc" {= "2.4.4" & with-doc} + "odoc-parser" {= "2.4.4" & with-doc} + "ohex" {= "0.2.0"} + "opium" {= "0.20.0"} + "ordering" {= "3.17.2"} + "parsexp" {= "v0.16.0"} + "postgresql" {= "5.1.3" & with-test} + "pp" {= "2.0.0"} + "ppx_derivers" {= "1.2.1"} + "ppx_deriving" {= "6.0.3"} + "ppx_deriving_yojson" {= "3.9.1"} + "ppx_fields_conv" {= "v0.16.0"} + "ppx_sexp_conv" {= "v0.16.0"} + "ppxlib" {= "0.34.0"} + "ptime" {= "1.2.0"} + "re" {= "1.12.0"} + "result" {= "1.5"} + "rock" {= "0.20.0"} + "rresult" {= "0.7.0"} + "safepass" {= "3.1"} + "seq" {= "base"} + "sexplib" {= "v0.16.0"} + "sexplib0" {= "v0.16.0"} + "sihl" {= "4.0.0"} + "ssl" {= "0.7.0"} + "stdlib-shims" {= "0.3.0"} + "stdune" {= "3.17.2"} + "stringext" {= "1.6.0"} + "tls" {= "1.0.4"} + "topkg" {= "1.0.7"} + "tsort" {= "2.1.0"} + "tyxml" {= "4.6.0"} + "uri" {= "4.4.0"} + "uuidm" {= "0.9.9"} + "uutf" {= "1.0.3"} + "x509" {= "1.0.5"} + "yojson" {= "2.2.2"} + "zarith" {= "1.14"} ] build: [ ["dune" "subst"] {dev} @@ -31,3 +149,7 @@ build: [ ] dev-repo: "git+https://github.com/oxidizing/sihl.git" name: "sihl-token" +pin-depends: [ + ["opium.0.20.0" "git+https://github.com/mabiede/opium.git#upgrade-packages"] + ["rock.0.20.0" "git+https://github.com/mabiede/opium.git#upgrade-packages"] +] diff --git a/sihl-token/src/sihl_token.ml b/sihl-token/src/sihl_token.ml index d8d7aba64..6f8b22edb 100644 --- a/sihl-token/src/sihl_token.ml +++ b/sihl-token/src/sihl_token.ml @@ -37,7 +37,7 @@ module Make (Repo : Repo.Sig) : Sihl.Contract.Token.Sig = struct let create ?ctx ?secret:_ ?expires_in data = let open Repo.Model in - let id = Uuidm.v `V4 |> Uuidm.to_string in + let id = Sihl.Random.Uuid.create () in let length = Option.value ~default:30 (Sihl.Configuration.read schema).token_length in diff --git a/sihl-user.opam.locked b/sihl-user.opam.locked index 07c12e544..773a20750 100644 --- a/sihl-user.opam.locked +++ b/sihl-user.opam.locked @@ -10,10 +10,129 @@ homepage: "https://github.com/oxidizing/sihl" doc: "https://oxidizing.github.io/sihl/" bug-reports: "https://github.com/oxidizing/sihl/issues" depends: [ + "alcotest" {= "1.8.0" & with-test} + "alcotest-lwt" {= "1.8.0" & with-test} + "angstrom" {= "0.16.1"} + "asn1-combinators" {= "0.3.2"} + "astring" {= "0.8.5"} + "base" {= "v0.16.3"} + "base-bigarray" {= "base"} + "base-bytes" {= "base"} "base-threads" {= "base"} "base-unix" {= "base"} - "dune" {= "3.11.1"} - "ocaml" {= "4.14.1"} + "base64" {= "3.5.1"} + "bigarray-compat" {= "1.1.0"} + "bigstringaf" {= "0.10.0"} + "bos" {= "0.2.1"} + "camlp-streams" {= "5.0.1" & with-doc} + "caqti" {= "2.1.2"} + "caqti-driver-mariadb" {= "2.1.1" & with-test} + "caqti-driver-postgresql" {= "2.1.2" & with-test} + "caqti-lwt" {= "2.1.1"} + "cmdliner" {= "1.3.0"} + "conf-bash" {= "1"} + "conf-gcc" {= "1.0"} + "conf-gmp" {= "4"} + "conf-gmp-powm-sec" {= "3"} + "conf-libssl" {= "4"} + "conf-mariadb" {= "2"} + "conf-pkg-config" {= "4"} + "conf-postgresql" {= "2" & with-test} + "conformist" {= "0.8.1"} + "containers" {= "3.15"} + "cppo" {= "1.8.0"} + "crunch" {= "3.3.1" & with-doc} + "csexp" {= "1.5.2"} + "cstruct" {= "6.2.0"} + "ctypes" {= "0.23.0"} + "digestif" {= "1.2.0"} + "domain-name" {= "0.4.0"} + "dune" {= "3.17.2"} + "dune-build-info" {= "3.17.2"} + "dune-configurator" {= "3.17.2"} + "dune-private-libs" {= "3.17.2"} + "dune-site" {= "3.17.2"} + "duration" {= "0.2.1"} + "dyn" {= "3.17.2"} + "either" {= "1.0.0"} + "eqaf" {= "0.10"} + "faraday" {= "0.8.2"} + "faraday-lwt" {= "0.8.2"} + "faraday-lwt-unix" {= "0.8.2"} + "fieldslib" {= "v0.16.0"} + "fmt" {= "0.9.0"} + "fpath" {= "0.7.3"} + "gmap" {= "0.3.0"} + "hmap" {= "0.8.1"} + "httpaf" {= "0.7.1"} + "httpaf-lwt-unix" {= "0.7.1"} + "integers" {= "0.7.0"} + "ipaddr" {= "5.6.0"} + "jwto" {= "0.4.0"} + "kdf" {= "1.0.0"} + "logs" {= "0.7.0"} + "lwt" {= "5.9.0"} + "lwt-dllist" {= "1.0.1"} + "lwt_ppx" {= "5.8.0"} + "lwt_ssl" {= "1.2.0"} + "macaddr" {= "5.6.0"} + "magic-mime" {= "1.3.1"} + "mariadb" {= "1.2.0"} + "mirage-crypto" {= "1.2.0"} + "mirage-crypto-ec" {= "1.2.0"} + "mirage-crypto-pk" {= "1.2.0"} + "mirage-crypto-rng" {= "1.2.0"} + "mtime" {= "2.1.0"} + "multipart-form-data" {= "0.3.0"} + "num" {= "1.5-1"} + "ocaml" {= "4.14.2"} + "ocaml-base-compiler" {= "4.14.2"} + "ocaml-compiler-libs" {= "v0.12.4"} + "ocaml-config" {= "2"} + "ocaml-options-vanilla" {= "1"} + "ocaml-syntax-shims" {= "1.0.0"} + "ocamlbuild" {= "0.15.0"} + "ocamlfind" {= "1.9.6"} + "ocplib-endian" {= "1.2"} + "odoc" {= "2.4.4" & with-doc} + "odoc-parser" {= "2.4.4" & with-doc} + "ohex" {= "0.2.0"} + "opium" {= "0.20.0"} + "ordering" {= "3.17.2"} + "parsexp" {= "v0.16.0"} + "postgresql" {= "5.1.3" & with-test} + "pp" {= "2.0.0"} + "ppx_derivers" {= "1.2.1"} + "ppx_deriving" {= "6.0.3"} + "ppx_deriving_yojson" {= "3.9.1"} + "ppx_fields_conv" {= "v0.16.0"} + "ppx_sexp_conv" {= "v0.16.0"} + "ppxlib" {= "0.34.0"} + "ptime" {= "1.2.0"} + "re" {= "1.12.0"} + "result" {= "1.5"} + "rock" {= "0.20.0"} + "rresult" {= "0.7.0"} + "safepass" {= "3.1"} + "seq" {= "base"} + "sexplib" {= "v0.16.0"} + "sexplib0" {= "v0.16.0"} + "sihl" {= "4.0.0"} + "sihl-token" {= "4.0.0" & with-test} + "ssl" {= "0.7.0"} + "stdlib-shims" {= "0.3.0"} + "stdune" {= "3.17.2"} + "stringext" {= "1.6.0"} + "tls" {= "1.0.4"} + "topkg" {= "1.0.7"} + "tsort" {= "2.1.0"} + "tyxml" {= "4.6.0"} + "uri" {= "4.4.0"} + "uuidm" {= "0.9.9"} + "uutf" {= "1.0.3"} + "x509" {= "1.0.5"} + "yojson" {= "2.2.2"} + "zarith" {= "1.14"} ] build: [ ["dune" "subst"] {dev} @@ -31,3 +150,7 @@ build: [ ] dev-repo: "git+https://github.com/oxidizing/sihl.git" name: "sihl-user" +pin-depends: [ + ["opium.0.20.0" "git+https://github.com/mabiede/opium.git#upgrade-packages"] + ["rock.0.20.0" "git+https://github.com/mabiede/opium.git#upgrade-packages"] +] diff --git a/sihl-user/src/sihl_user.ml b/sihl-user/src/sihl_user.ml index 6183377db..55732f7db 100644 --- a/sihl-user/src/sihl_user.ml +++ b/sihl-user/src/sihl_user.ml @@ -57,12 +57,12 @@ module Make (Repo : User_repo.Sig) : Sihl.Contract.User.Sig = struct ;; let update_password - ?ctx - ?(password_policy = default_password_policy) - user - ~old_password - ~new_password - ~new_password_confirmation + ?ctx + ?(password_policy = default_password_policy) + user + ~old_password + ~new_password + ~new_password_confirmation = match validate_change_password @@ -87,11 +87,11 @@ module Make (Repo : User_repo.Sig) : Sihl.Contract.User.Sig = struct ;; let set_password - ?ctx - ?(password_policy = default_password_policy) - user - ~password - ~password_confirmation + ?ctx + ?(password_policy = default_password_policy) + user + ~password + ~password_confirmation = let%lwt result = validate_new_password ~password ~password_confirmation ~password_policy @@ -120,15 +120,15 @@ module Make (Repo : User_repo.Sig) : Sihl.Contract.User.Sig = struct ;; let create - ?ctx - ?id - ~email - ~password - ~username - ~name - ~given_name - ~admin - confirmed + ?ctx + ?id + ~email + ~password + ~username + ~name + ~given_name + ~admin + confirmed = let user = make ?id ~email ~password ~username ~name ~given_name ~admin confirmed @@ -189,15 +189,15 @@ module Make (Repo : User_repo.Sig) : Sihl.Contract.User.Sig = struct ;; let register_user - ?ctx - ?id - ?(password_policy = default_password_policy) - ?username - ?name - ?given_name - email - ~password - ~password_confirmation + ?ctx + ?id + ?(password_policy = default_password_policy) + ?username + ?name + ?given_name + email + ~password + ~password_confirmation = match validate_new_password ~password ~password_confirmation ~password_policy diff --git a/sihl-user/src/user_repo.ml b/sihl-user/src/user_repo.ml index c9cd28791..bfeab6e50 100644 --- a/sihl-user/src/user_repo.ml +++ b/sihl-user/src/user_repo.ml @@ -48,14 +48,14 @@ let user = ) ) ) ) ) in let decode - ( id - , ( email - , ( username - , ( name - , ( given_name - , ( password - , (status, (admin, (confirmed, (created_at, updated_at)))) ) ) ) - ) ) ) + ( id + , ( email + , ( username + , ( name + , ( given_name + , ( password + , (status, (admin, (confirmed, (created_at, updated_at)))) ) + ) ) ) ) ) = Ok { id diff --git a/sihl.opam b/sihl.opam index d954bdeff..d31978ced 100644 --- a/sihl.opam +++ b/sihl.opam @@ -25,7 +25,7 @@ depends: [ "sexplib" {>= "v0.13.0"} "yojson" {>= "1.7.0"} "ppx_deriving_yojson" {>= "3.5.2"} - "tls" {>= "0.11.1"} + "tls" {>= "1.0.4"} "ssl" {>= "0.5.9"} "lwt_ssl" {>= "1.1.3"} "lwt_ppx" {>= "2.0.1"} @@ -33,11 +33,11 @@ depends: [ "caqti-lwt" {>= "2.0.1"} "safepass" {>= "3.0"} "jwto" {>= "0.3.0"} - "uuidm" {>= "0.9.7"} + "uuidm" {>= "0.9.9"} "ppx_fields_conv" {>= "v0.13.0"} "ppx_sexp_conv" {>= "v0.13.0"} - "mirage-crypto" {>= "0.11.2"} - "mirage-crypto-rng" {>= "0.11.2"} + "mirage-crypto" {>= "1.1.0"} + "mirage-crypto-rng" {>= "1.2.0"} "cstruct" {>= "6.0.1"} "opium" {>= "0.20.0"} "cohttp-lwt-unix" {>= "2.5.4" & with-test} diff --git a/sihl.opam.locked b/sihl.opam.locked index bcf8fe6c3..095799ffa 100644 --- a/sihl.opam.locked +++ b/sihl.opam.locked @@ -12,40 +12,59 @@ homepage: "https://github.com/oxidizing/sihl" doc: "https://oxidizing.github.io/sihl/" bug-reports: "https://github.com/oxidizing/sihl/issues" depends: [ - "angstrom" {= "0.15.0"} - "asn1-combinators" {= "0.2.6"} + "alcotest" {= "1.8.0" & with-test} + "alcotest-lwt" {= "1.8.0" & with-test} + "angstrom" {= "0.16.1"} + "asn1-combinators" {= "0.3.2"} "astring" {= "0.8.5"} "base" {= "v0.16.3"} + "base-bigarray" {= "base"} "base-bytes" {= "base"} "base-threads" {= "base"} "base-unix" {= "base"} "base64" {= "3.5.1"} "bigarray-compat" {= "1.1.0"} - "bigstringaf" {= "0.9.1"} + "bigstringaf" {= "0.10.0"} "bos" {= "0.2.1"} - "caqti" {= "2.0.1"} - "caqti-lwt" {= "2.0.1"} - "cmdliner" {= "1.2.0"} + "ca-certs" {= "1.0.0" & with-test} + "camlp-streams" {= "5.0.1" & with-doc} + "caqti" {= "2.1.2"} + "caqti-driver-mariadb" {= "2.1.1" & with-test} + "caqti-driver-postgresql" {= "2.1.2" & with-test} + "caqti-lwt" {= "2.1.1"} + "cmdliner" {= "1.3.0"} + "cohttp" {= "6.0.0" & with-test} + "cohttp-lwt" {= "6.0.0" & with-test} + "cohttp-lwt-unix" {= "6.0.0" & with-test} + "conduit" {= "7.1.0" & with-test} + "conduit-lwt" {= "7.1.0" & with-test} + "conduit-lwt-unix" {= "7.1.0" & with-test} + "conf-bash" {= "1"} + "conf-gcc" {= "1.0"} "conf-gmp" {= "4"} "conf-gmp-powm-sec" {= "3"} - "conf-libev" {= "4-12"} "conf-libssl" {= "4"} - "conf-pkg-config" {= "3"} + "conf-mariadb" {= "2"} + "conf-pkg-config" {= "4"} + "conf-postgresql" {= "2" & with-test} "conformist" {= "0.8.1"} - "containers" {= "3.12"} - "cppo" {= "1.6.9"} - "cpuid" {= "0.1.2"} + "containers" {= "3.15"} + "cppo" {= "1.8.0"} + "crunch" {= "3.3.1" & with-doc} "csexp" {= "1.5.2"} - "cstruct" {= "6.0.1"} - "cstruct-lwt" {= "6.0.1"} - "digestif" {= "1.1.4"} + "cstruct" {= "6.2.0"} + "ctypes" {= "0.23.0"} + "digestif" {= "1.2.0"} "domain-name" {= "0.4.0"} - "dune" {= "3.11.1"} - "dune-build-info" {= "3.11.1"} - "dune-configurator" {= "3.11.1"} + "dune" {= "3.17.2"} + "dune-build-info" {= "3.17.2"} + "dune-configurator" {= "3.17.2"} + "dune-private-libs" {= "3.17.2"} + "dune-site" {= "3.17.2"} "duration" {= "0.2.1"} + "dyn" {= "3.17.2"} "either" {= "1.0.0"} - "eqaf" {= "0.9"} + "eqaf" {= "0.10"} "faraday" {= "0.8.2"} "faraday-lwt" {= "0.8.2"} "faraday-lwt-unix" {= "0.8.2"} @@ -53,47 +72,55 @@ depends: [ "fmt" {= "0.9.0"} "fpath" {= "0.7.3"} "gmap" {= "0.3.0"} - "hkdf" {= "1.0.4"} "hmap" {= "0.8.1"} + "http" {= "6.0.0" & with-test} "httpaf" {= "0.7.1"} "httpaf-lwt-unix" {= "0.7.1"} - "ipaddr" {= "5.5.0"} + "integers" {= "0.7.0"} + "ipaddr" {= "5.6.0"} + "ipaddr-sexp" {= "5.6.0" & with-test} "jwto" {= "0.4.0"} + "kdf" {= "1.0.0"} "logs" {= "0.7.0"} - "lwt" {= "5.7.0"} + "lwt" {= "5.9.0"} "lwt-dllist" {= "1.0.1"} - "lwt_ppx" {= "2.1.0"} + "lwt_ppx" {= "5.8.0"} "lwt_ssl" {= "1.2.0"} - "macaddr" {= "5.5.0"} + "macaddr" {= "5.6.0"} "magic-mime" {= "1.3.1"} - "mirage-crypto" {= "0.11.2"} - "mirage-crypto-ec" {= "0.11.2"} - "mirage-crypto-pk" {= "0.11.2"} - "mirage-crypto-rng" {= "0.11.2"} - "mirage-no-solo5" {= "1"} - "mirage-no-xen" {= "1"} - "mtime" {= "2.0.0"} + "mariadb" {= "1.2.0"} + "mirage-crypto" {= "1.2.0"} + "mirage-crypto-ec" {= "1.2.0"} + "mirage-crypto-pk" {= "1.2.0"} + "mirage-crypto-rng" {= "1.2.0"} + "mtime" {= "2.1.0"} "multipart-form-data" {= "0.3.0"} - "nocrypto" {= "0.5.4-2"} - "num" {= "1.4"} - "ocaml" {= "4.14.1"} + "num" {= "1.5-1"} + "ocaml" {= "4.14.2"} + "ocaml-base-compiler" {= "4.14.2"} "ocaml-compiler-libs" {= "v0.12.4"} + "ocaml-config" {= "2"} + "ocaml-options-vanilla" {= "1"} "ocaml-syntax-shims" {= "1.0.0"} - "ocamlbuild" {= "0.14.2"} + "ocamlbuild" {= "0.15.0"} "ocamlfind" {= "1.9.6"} - "ocb-stubblr" {= "0.1.1-1"} "ocplib-endian" {= "1.2"} + "odoc" {= "2.4.4" & with-doc} + "odoc-parser" {= "2.4.4" & with-doc} + "ohex" {= "0.2.0"} "opium" {= "0.20.0"} + "ordering" {= "3.17.2"} "parsexp" {= "v0.16.0"} - "pbkdf" {= "1.2.0"} + "postgresql" {= "5.1.3" & with-test} + "pp" {= "2.0.0"} "ppx_derivers" {= "1.2.1"} - "ppx_deriving" {= "5.2.1"} - "ppx_deriving_yojson" {= "3.7.0"} + "ppx_deriving" {= "6.0.3"} + "ppx_deriving_yojson" {= "3.9.1"} "ppx_fields_conv" {= "v0.16.0"} "ppx_sexp_conv" {= "v0.16.0"} - "ppxlib" {= "0.31.0"} - "ptime" {= "1.1.0"} - "re" {= "1.11.0"} + "ppxlib" {= "0.34.0"} + "ptime" {= "1.2.0"} + "re" {= "1.12.0"} "result" {= "1.5"} "rock" {= "0.20.0"} "rresult" {= "0.7.0"} @@ -103,17 +130,19 @@ depends: [ "sexplib0" {= "v0.16.0"} "ssl" {= "0.7.0"} "stdlib-shims" {= "0.3.0"} + "stdune" {= "3.17.2"} "stringext" {= "1.6.0"} - "tls" {= "0.17.1"} + "tls" {= "1.0.4"} "topkg" {= "1.0.7"} "tsort" {= "2.1.0"} "tyxml" {= "4.6.0"} "uri" {= "4.4.0"} - "uuidm" {= "0.9.8"} + "uri-sexp" {= "4.4.0" & with-test} + "uuidm" {= "0.9.9"} "uutf" {= "1.0.3"} - "x509" {= "0.16.5"} - "yojson" {= "2.1.1"} - "zarith" {= "1.13"} + "x509" {= "1.0.5"} + "yojson" {= "2.2.2"} + "zarith" {= "1.14"} ] build: [ ["dune" "subst"] {dev} @@ -131,3 +160,7 @@ build: [ ] dev-repo: "git+https://github.com/oxidizing/sihl.git" name: "sihl" +pin-depends: [ + ["opium.0.20.0" "git+https://github.com/mabiede/opium.git#upgrade-packages"] + ["rock.0.20.0" "git+https://github.com/mabiede/opium.git#upgrade-packages"] +] diff --git a/sihl/src/contract_database.ml b/sihl/src/contract_database.ml index b70b7d364..0f4338dd2 100644 --- a/sihl/src/contract_database.ml +++ b/sihl/src/contract_database.ml @@ -16,8 +16,7 @@ module type Sig = sig (* Deprecated in 0.6.0 *) [@@deprecated "Use prepare_search_request instead"] - (** [prepare_search_request ~search_query ~count_query ~filter_fragment - ?sort_by_field type] + (** [prepare_search_request ~search_query ~count_query ~filter_fragment ?sort_by_field type] returns a prepared SQL statement ['a prepared_search_request] by assembling the SQL query from the provided fragments. diff --git a/sihl/src/contract_email_template.ml b/sihl/src/contract_email_template.ml index b44594792..9d18e361b 100644 --- a/sihl/src/contract_email_template.ml +++ b/sihl/src/contract_email_template.ml @@ -139,13 +139,13 @@ let email_of_template ?template (email : Contract_email.t) data = (* [@@deprecated "Use Sihl_email.Template.render_email() instead"] *) let create_email_of_template - ?(cc = []) - ?(bcc = []) - ~sender - ~recipient - ~subject - template - data + ?(cc = []) + ?(bcc = []) + ~sender + ~recipient + ~subject + template + data = (* Create an empty mail, the content is rendered *) let email = Contract_email.create ~cc ~bcc ~sender ~recipient ~subject "" in diff --git a/sihl/src/contract_migration.ml b/sihl/src/contract_migration.ml index 7b76a2af3..cb39dccc0 100644 --- a/sihl/src/contract_migration.ml +++ b/sihl/src/contract_migration.ml @@ -81,11 +81,11 @@ let to_sexp (namespace, steps) = let steps = List.map (fun { label; statement; check_fk } -> - List - [ List [ Atom "label"; sexp_of_string label ] - ; List [ Atom "statement"; sexp_of_string statement ] - ; List [ Atom "check_fk"; sexp_of_bool check_fk ] - ]) + List + [ List [ Atom "label"; sexp_of_string label ] + ; List [ Atom "statement"; sexp_of_string statement ] + ; List [ Atom "check_fk"; sexp_of_bool check_fk ] + ]) steps in List (List.cons (List [ Atom "namespace"; sexp_of_string namespace ]) steps) diff --git a/sihl/src/contract_queue.ml b/sihl/src/contract_queue.ml index 6495fcbae..0fc844653 100644 --- a/sihl/src/contract_queue.ml +++ b/sihl/src/contract_queue.ml @@ -91,14 +91,14 @@ let default_error_handler ?(ctx = []) msg (instance : instance) = ;; let create_job - handle - ?(max_tries = default_tries) - ?(retry_delay = default_retry_delay) - ?(failed = default_error_handler) - ?tag - encode - decode - name + handle + ?(max_tries = default_tries) + ?(retry_delay = default_retry_delay) + ?(failed = default_error_handler) + ?tag + encode + decode + name = { name; handle; failed; max_tries; retry_delay; encode; decode; tag } ;; diff --git a/sihl/src/contract_user.ml b/sihl/src/contract_user.ml index 83f8d8a81..0119a8ca0 100644 --- a/sihl/src/contract_user.ml +++ b/sihl/src/contract_user.ml @@ -168,8 +168,7 @@ module type Sig = sig -> string -> t option Lwt.t - (** [update_password ?ctx ?password_policy user ~old_password ~new_password - ~new_password_confirmation] + (** [update_password ?ctx ?password_policy user ~old_password ~new_password ~new_password_confirmation] updates the password of a [user] to [new_password] and returns the user. The [old_password] is the current password that the user has to enter. [new_password] has to equal [new_password_confirmation]. @@ -249,8 +248,7 @@ module type Sig = sig -> string -> t Lwt.t - (** [register_user ?ctx ?id ?password_policy ?username ?name ?given_name email password - password_confirmation] + (** [register_user ?ctx ?id ?password_policy ?username ?name ?given_name email password password_confirmation] creates a new user if the password is valid and if the email address was not already registered. @@ -288,18 +286,18 @@ module type Sig = sig end let to_sexp - { id - ; email - ; username - ; name - ; given_name - ; status - ; admin - ; confirmed - ; created_at - ; updated_at - ; _ - } + { id + ; email + ; username + ; name + ; given_name + ; status + ; admin + ; confirmed + ; created_at + ; updated_at + ; _ + } = let open Sexplib0.Sexp_conv in let open Sexplib0.Sexp in @@ -369,11 +367,11 @@ let validate_new_password ~password ~password_confirmation ~password_policy = ;; let validate_change_password - user - ~old_password - ~new_password - ~new_password_confirmation - ~password_policy + user + ~old_password + ~new_password + ~new_password_confirmation + ~password_policy = let matches_old_password = match matches_password old_password user with @@ -397,17 +395,17 @@ let make ?id ~email ~password ~name ~given_name ~username ~admin confirmed = let now = Ptime_clock.now () in Result.map (fun hash -> - { id = Option.value id ~default:(Uuidm.v `V4 |> Uuidm.to_string) - ; email - ; password = hash - ; username - ; name - ; given_name - ; admin - ; confirmed - ; status = Active - ; created_at = now - ; updated_at = now - }) + { id = Option.value id ~default:(Core_random.Uuid.create ()) + ; email + ; password = hash + ; username + ; name + ; given_name + ; admin + ; confirmed + ; status = Active + ; created_at = now + ; updated_at = now + }) hash ;; diff --git a/sihl/src/core_app.mli b/sihl/src/core_app.mli index 929c3e5e2..7a08f71c9 100644 --- a/sihl/src/core_app.mli +++ b/sihl/src/core_app.mli @@ -1,7 +1,8 @@ (** A module to create Sihl apps. *) (** An app is a thin convenience layer on top of the service container. It - provides hooks that are executed at different stages in the app lifecycle. *) + provides hooks that are executed at different stages in the app lifecycle. +*) type t (** [empty] returns an app without any services. *) diff --git a/sihl/src/core_command.ml b/sihl/src/core_command.ml index 2431e2ba0..2ce7e2ce6 100644 --- a/sihl/src/core_command.ml +++ b/sihl/src/core_command.ml @@ -83,38 +83,38 @@ let run commands args = let start = Mtime_clock.now () in Lwt.catch (fun () -> - let%lwt _ = - Lwt_list.iter_s (fun (lifecycle : Core_lifecycle.lifecycle) -> - lifecycle.start ()) - @@ Core_lifecycle.top_sort_lifecycles command.dependencies - in - let%lwt result = command.fn rest_args in - match result with - | Some () -> - let stop = Mtime_clock.now () in - let span = Mtime.span start stop in - print_endline - (Format.asprintf - "Command '%s' ran successfully in %a" - command.name - Mtime.Span.pp - span); - Lwt.return () - | None -> Lwt.return @@ print_help command) + let%lwt _ = + Lwt_list.iter_s (fun (lifecycle : Core_lifecycle.lifecycle) -> + lifecycle.start ()) + @@ Core_lifecycle.top_sort_lifecycles command.dependencies + in + let%lwt result = command.fn rest_args in + match result with + | Some () -> + let stop = Mtime_clock.now () in + let span = Mtime.span start stop in + print_endline + (Format.asprintf + "Command '%s' ran successfully in %a" + command.name + Mtime.Span.pp + span); + Lwt.return () + | None -> Lwt.return @@ print_help command) (fun exn -> - let stop = Mtime_clock.now () in - let span = Mtime.span start stop in - let msg = Printexc.to_string exn in - let stack = Printexc.get_backtrace () in - print_endline - (Format.asprintf - "Command '%s' aborted after %a: '%s'" - command.name - Mtime.Span.pp - span - msg); - print_endline stack; - exit 1)) + let stop = Mtime_clock.now () in + let span = Mtime.span start stop in + let msg = Printexc.to_string exn in + let stack = Printexc.get_backtrace () in + print_endline + (Format.asprintf + "Command '%s' aborted after %a: '%s'" + command.name + Mtime.Span.pp + span + msg); + print_endline stack; + exit 1)) | None -> print_all commands; Lwt.return () diff --git a/sihl/src/core_configuration.ml b/sihl/src/core_configuration.ml index e7c3794d3..037dd3530 100644 --- a/sihl/src/core_configuration.ml +++ b/sihl/src/core_configuration.ml @@ -53,11 +53,11 @@ let memoize f arg = let store data = List.iter (fun (key, value) -> - if String.equal "" value - then () - else ( - Hashtbl.replace cache key (Some value); - Unix.putenv key value)) + if String.equal "" value + then () + else ( + Hashtbl.replace cache key (Some value); + Unix.putenv key value)) data ;; @@ -78,9 +78,10 @@ let root_path () = let markers = [ ".git"; ".hg"; ".svn"; ".bzr"; "_darcs" ] in let rec find_markers path_els = let path = String.concat "/" path_els in - if List.exists - (fun marker -> Sys.file_exists (path ^ "/" ^ marker)) - markers + if + List.exists + (fun marker -> Sys.file_exists (path ^ "/" ^ marker)) + markers then ( (* Path found => Write it into the env var to "memoize" it *) Unix.putenv "ROOT_PATH" path; @@ -153,15 +154,15 @@ let read schema = let errors = List.map (fun (field, input, msg) -> - match CCList.head_opt input with - | None -> - Format.sprintf "Failed to read configuration '%s': %s" field msg - | Some input -> - Format.sprintf - "Failed to read configuration '%s' for '%s': %s" - input - field - msg) + match CCList.head_opt input with + | None -> + Format.sprintf "Failed to read configuration '%s': %s" field msg + | Some input -> + Format.sprintf + "Failed to read configuration '%s' for '%s': %s" + input + field + msg) errors in List.iter (fun error -> Logs.err (fun m -> m "%s" error)) errors; @@ -256,12 +257,16 @@ Default: %s type_ default | None -> - Format.sprintf {| + Format.sprintf + {| %s %s Type: %s Required -|} name description type_) +|} + name + description + type_) |> String.concat "" ;; diff --git a/sihl/src/core_lifecycle.ml b/sihl/src/core_lifecycle.ml index 620eab510..0c33f545a 100644 --- a/sihl/src/core_lifecycle.ml +++ b/sihl/src/core_lifecycle.ml @@ -19,11 +19,11 @@ type lifecycle = let counter = ref 0 let create_lifecycle - ?(dependencies = fun () -> []) - ?(start = fun () -> Lwt.return ()) - ?(stop = fun () -> Lwt.return ()) - ?implementation_name - type_name + ?(dependencies = fun () -> []) + ?(start = fun () -> Lwt.return ()) + ?(stop = fun () -> Lwt.return ()) + ?implementation_name + type_name = (* Give all lifecycles unique names *) counter := !counter + 1; @@ -110,10 +110,10 @@ let top_sort_lifecycles lifecycles = let remaining_msg = Option.map (fun r -> - Format.asprintf - "%s These are the lifecycles after the cycle: %s" - msg - (String.concat ", " r)) + Format.asprintf + "%s These are the lifecycles after the cycle: %s" + msg + (String.concat ", " r)) remaining_names in Logs.err (fun m -> m "%s" @@ Option.value remaining_msg ~default:msg); diff --git a/sihl/src/core_log.ml b/sihl/src/core_log.ml index ac3263ee5..34e9d74f2 100644 --- a/sihl/src/core_log.ml +++ b/sihl/src/core_log.ml @@ -135,10 +135,10 @@ let pp_exec_header src = ;; let format_reporter - ?(pp_header = pp_exec_header) - ?(app = Format.std_formatter) - ?(dst = Format.err_formatter) - () + ?(pp_header = pp_exec_header) + ?(app = Format.std_formatter) + ?(dst = Format.err_formatter) + () = let report src level ~over k msgf = let k _ = diff --git a/sihl/src/core_random.ml b/sihl/src/core_random.ml index c54ef194d..7421e5df4 100644 --- a/sihl/src/core_random.ml +++ b/sihl/src/core_random.ml @@ -1,5 +1,18 @@ let () = Stdlib.Random.self_init () +module Uuid : sig + type t + + val create : unit -> string + val of_string : ?pos:int -> string -> t option + val to_binary_string : t -> string +end = struct + include Uuidm + + let random_state = Random.State.make_self_init () + let create () = Uuidm.v4_gen random_state () |> Uuidm.to_string +end + let rec chars result n = if n > 0 then chars (List.cons (Char.chr (Stdlib.Random.int 255)) result) (n - 1) diff --git a/sihl/src/core_schedule.ml b/sihl/src/core_schedule.ml index bc3dc894c..1c490c0e0 100644 --- a/sihl/src/core_schedule.ml +++ b/sihl/src/core_schedule.ml @@ -42,12 +42,12 @@ let schedule schedule = Lwt.catch (fun () -> scheduled_function ()) (fun exn -> - Logs.err (fun m -> - m - "Exception caught while running schedule, this is a bug in your \ - scheduled function. %s" - (Printexc.to_string exn)); - Lwt.return ()) + Logs.err (fun m -> + m + "Exception caught while running schedule, this is a bug in your \ + scheduled function. %s" + (Printexc.to_string exn)); + Lwt.return ()) in let%lwt () = Lwt_unix.sleep duration in if !should_stop diff --git a/sihl/src/core_service.ml b/sihl/src/core_service.ml index 7a01d404f..7e9f98381 100644 --- a/sihl/src/core_service.ml +++ b/sihl/src/core_service.ml @@ -14,10 +14,10 @@ let commands (service : t) = service.commands let configuration service = service.configuration let create - ?(commands = []) - ?(configuration = Core_configuration.empty) - ?(server = false) - lifecycle + ?(commands = []) + ?(configuration = Core_configuration.empty) + ?(server = false) + lifecycle = { lifecycle; configuration; commands; server } ;; @@ -35,9 +35,9 @@ let start_services services = let%lwt () = Lwt_list.iter_s (fun (lifecycle : Core_lifecycle.lifecycle) -> - Logs.debug (fun m -> - m "Starting service: %s" @@ Core_lifecycle.human_name lifecycle); - lifecycle.start ()) + Logs.debug (fun m -> + m "Starting service: %s" @@ Core_lifecycle.human_name lifecycle); + lifecycle.start ()) lifecycles in Logs.info (fun m -> m "All services started."); @@ -51,9 +51,9 @@ let stop_services services = let%lwt () = Lwt_list.iter_s (fun (lifecycle : Core_lifecycle.lifecycle) -> - Logs.debug (fun m -> - m "Stopping service: %s" @@ Core_lifecycle.human_name lifecycle); - lifecycle.stop ()) + Logs.debug (fun m -> + m "Stopping service: %s" @@ Core_lifecycle.human_name lifecycle); + lifecycle.stop ()) lifecycles in Logs.info (fun m -> m "Stopped, Good Bye!"); diff --git a/sihl/src/core_time.ml b/sihl/src/core_time.ml index d7693e9d5..ce5179478 100644 --- a/sihl/src/core_time.ml +++ b/sihl/src/core_time.ml @@ -57,9 +57,9 @@ let ptime_of_date_string date = date are ints") |> List.fold_left (fun result item -> - match item with - | Ok item -> Result.map (List.cons item) result - | Error msg -> Error msg) + match item with + | Ok item -> Result.map (List.cons item) result + | Error msg -> Error msg) (Ok []) |> Result.map List.rev in diff --git a/sihl/src/database.ml b/sihl/src/database.ml index 1a1abecd6..b1e8af2ca 100644 --- a/sihl/src/database.ml +++ b/sihl/src/database.ml @@ -34,11 +34,11 @@ let prepare_requests _ _ _ = failwith "prepare_requests deprecated" let default_format_filter keyword = "%" ^ keyword ^ "%" let prepare_search_request - ~search_query - ~filter_fragment - ?(sort_by_field = "id") - ?(format_filter = default_format_filter) - output_type + ~search_query + ~filter_fragment + ?(sort_by_field = "id") + ?(format_filter = default_format_filter) + output_type : 'a prepared_search_request = let open Caqti_request.Infix in @@ -167,9 +167,10 @@ let fetch_pool ?(ctx = []) () = Logs.debug (fun m -> m "Skipping pool creation, re-using existing pool"); pool | None, None -> - if Option.value - (Core_configuration.read schema).skip_default_pool_creation - ~default:false + if + Option.value + (Core_configuration.read schema).skip_default_pool_creation + ~default:false then Logs.warn (fun m -> m @@ -237,42 +238,45 @@ let transaction ?ctx f = let%lwt result = Caqti_lwt_unix.Pool.use (fun connection -> - Logs.debug (fun m -> m "Fetched connection from pool"); - let (module Connection : Caqti_lwt.CONNECTION) = connection in - let%lwt start_result = Connection.start () in - match start_result with - | Error msg -> - Logs.debug (fun m -> - m "Failed to start transaction: %s" (Caqti_error.show msg)); - Lwt.return @@ Error msg - | Ok () -> - Logs.debug (fun m -> m "Started transaction"); - Lwt.catch - (fun () -> - let%lwt result = f connection in - let%lwt commit_result = Connection.commit () in - match commit_result with - | Ok () -> - Logs.debug (fun m -> m "Successfully committed transaction"); - Lwt.return @@ Ok result - | Error error -> - Logs.err (fun m -> - m "Failed to commit transaction: %s" (Caqti_error.show error)); - Lwt.fail - @@ Contract_database.Exception "Failed to commit transaction") - (fun e -> - let%lwt rollback_result = Connection.rollback () in - match rollback_result with - | Ok () -> - Logs.debug (fun m -> m "Successfully rolled back transaction"); - Lwt.fail e - | Error error -> - Logs.err (fun m -> - m - "Failed to rollback transaction: %s" - (Caqti_error.show error)); - Lwt.fail - @@ Contract_database.Exception "Failed to rollback transaction")) + Logs.debug (fun m -> m "Fetched connection from pool"); + let (module Connection : Caqti_lwt.CONNECTION) = connection in + let%lwt start_result = Connection.start () in + match start_result with + | Error msg -> + Logs.debug (fun m -> + m "Failed to start transaction: %s" (Caqti_error.show msg)); + Lwt.return @@ Error msg + | Ok () -> + Logs.debug (fun m -> m "Started transaction"); + Lwt.catch + (fun () -> + let%lwt result = f connection in + let%lwt commit_result = Connection.commit () in + match commit_result with + | Ok () -> + Logs.debug (fun m -> m "Successfully committed transaction"); + Lwt.return @@ Ok result + | Error error -> + Logs.err (fun m -> + m + "Failed to commit transaction: %s" + (Caqti_error.show error)); + Lwt.fail + @@ Contract_database.Exception "Failed to commit transaction") + (fun e -> + let%lwt rollback_result = Connection.rollback () in + match rollback_result with + | Ok () -> + Logs.debug (fun m -> m "Successfully rolled back transaction"); + Lwt.fail e + | Error error -> + Logs.err (fun m -> + m + "Failed to rollback transaction: %s" + (Caqti_error.show error)); + Lwt.fail + @@ Contract_database.Exception + "Failed to rollback transaction")) pool in match result with @@ -286,12 +290,12 @@ let transaction ?ctx f = let transaction' ?ctx f = transaction ?ctx f |> Lwt.map raise_error let run_search_request - ?ctx - (r : 'a prepared_search_request) - (sort : [ `Asc | `Desc ]) - (filter : string option) - ~(limit : int) - ~(offset : int) + ?ctx + (r : 'a prepared_search_request) + (sort : [ `Asc | `Desc ]) + (filter : string option) + ~(limit : int) + ~(offset : int) = transaction' ?ctx (fun connection -> let module Connection = (val connection : Caqti_lwt.CONNECTION) in @@ -312,7 +316,7 @@ let run_search_request let total = Result.map (fun e -> - e |> List.map fst |> CCList.head_opt |> Option.value ~default:0) + e |> List.map fst |> CCList.head_opt |> Option.value ~default:0) result in CCResult.both things total |> Lwt.return) diff --git a/sihl/src/database_migration.ml b/sihl/src/database_migration.ml index 4d1ab988e..a4d3a07e8 100644 --- a/sihl/src/database_migration.ml +++ b/sihl/src/database_migration.ml @@ -101,8 +101,8 @@ struct Lwt.finalize (fun () -> f connection) (fun () -> - Connection.exec set_fk_check_request true - |> Lwt.map Database.raise_error)) + Connection.exec set_fk_check_request true + |> Lwt.map Database.raise_error)) ;; let execute_steps ?ctx migration = @@ -183,10 +183,10 @@ struct Lwt.catch (fun () -> execute_steps ?ctx migration_to_apply) (fun exn -> - let err = Printexc.to_string exn in - Logs.err (fun m -> - m "Error while running migration '%a': %s" pp migration err); - raise (Contract_migration.Exception err)) + let err = Printexc.to_string exn in + Logs.err (fun m -> + m "Error while running migration '%a': %s" pp migration err); + raise (Contract_migration.Exception err)) in let%lwt _ = mark_clean ?ctx namespace in Lwt.return () @@ -236,28 +236,28 @@ struct Lwt.return @@ List.map (fun namespace -> - let migrations = Map.find_opt namespace migrations_to_check in - let migration_state = - List.find_opt - (fun migration_state -> - String.equal - migration_state.Database_migration_repo.Migration.namespace - namespace) - migrations_states - in - match migrations, migration_state with - | None, None -> namespace, None - | None, Some migration_state -> - ( namespace - , Some (-migration_state.Database_migration_repo.Migration.version) - ) - | Some migrations, Some migration_state -> - let unapplied_migrations_count = - List.length migrations - - migration_state.Database_migration_repo.Migration.version - in - namespace, Some unapplied_migrations_count - | Some migrations, None -> namespace, Some (List.length migrations)) + let migrations = Map.find_opt namespace migrations_to_check in + let migration_state = + List.find_opt + (fun migration_state -> + String.equal + migration_state.Database_migration_repo.Migration.namespace + namespace) + migrations_states + in + match migrations, migration_state with + | None, None -> namespace, None + | None, Some migration_state -> + ( namespace + , Some + (-migration_state.Database_migration_repo.Migration.version) ) + | Some migrations, Some migration_state -> + let unapplied_migrations_count = + List.length migrations + - migration_state.Database_migration_repo.Migration.version + in + namespace, Some unapplied_migrations_count + | Some migrations, None -> namespace, Some (List.length migrations)) namespaces_to_check ;; @@ -280,36 +280,36 @@ struct let%lwt unapplied = migrations_status ?ctx ?migrations () in List.iter (fun (namespace, count) -> - match count with - | None -> - Logs.warn (fun m -> - m - "Could not find registered migrations for namespace '%s'. This \ - implies you removed all migrations of that namespace. \ - Migrations should be append-only. If you intended to remove \ - those migrations, make sure to remove the migration state in \ - your database/other persistence layer." - namespace) - | Some count -> - if count > 0 - then - Logs.info (fun m -> - m - "Unapplied migrations for namespace '%s' detected. Found %s \ - unapplied migrations, run command 'migrate'." - namespace - (Int.to_string count)) - else if count < 0 - then - Logs.warn (fun m -> - m - "Fewer registered migrations found than migration state \ - indicates for namespace '%s'. Current migration state version \ - is ahead of registered migrations by %s. This implies you \ - removed migrations, which should be append-only." - namespace - (Int.to_string @@ Int.abs count)) - else ()) + match count with + | None -> + Logs.warn (fun m -> + m + "Could not find registered migrations for namespace '%s'. This \ + implies you removed all migrations of that namespace. \ + Migrations should be append-only. If you intended to remove \ + those migrations, make sure to remove the migration state in \ + your database/other persistence layer." + namespace) + | Some count -> + if count > 0 + then + Logs.info (fun m -> + m + "Unapplied migrations for namespace '%s' detected. Found %s \ + unapplied migrations, run command 'migrate'." + namespace + (Int.to_string count)) + else if count < 0 + then + Logs.warn (fun m -> + m + "Fewer registered migrations found than migration state \ + indicates for namespace '%s'. Current migration state \ + version is ahead of registered migrations by %s. This \ + implies you removed migrations, which should be append-only." + namespace + (Int.to_string @@ Int.abs count)) + else ()) unapplied; Lwt.return () ;; diff --git a/sihl/src/gen_core.ml b/sihl/src/gen_core.ml index 9f9dd762b..387aa4368 100644 --- a/sihl/src/gen_core.ml +++ b/sihl/src/gen_core.ml @@ -59,13 +59,13 @@ let schema_of_string (s : string list) : (schema, string) result = Error (Format.sprintf "Invalid input provided '%s'" (String.concat ":" s))) |> List.fold_left (fun schema next -> - match schema, next with - | Ok schema, Ok (name, type_) -> - (match gen_type_of_string type_ with - | Ok gen_type -> Ok (List.cons (name, gen_type) schema) - | Error msg -> Error msg) - | Error msg, _ -> Error msg - | Ok _, Error msg -> Error msg) + match schema, next with + | Ok schema, Ok (name, type_) -> + (match gen_type_of_string type_ with + | Ok gen_type -> Ok (List.cons (name, gen_type) schema) + | Error msg -> Error msg) + | Error msg, _ -> Error msg + | Ok _, Error msg -> Error msg) (Result.ok []) |> Result.map List.rev ;; @@ -79,11 +79,11 @@ type file = let render { template; params; _ } = List.fold_left (fun res (name, value) -> - CCString.replace - ~which:`All - ~sub:(Format.sprintf "{{%s}}" name) - ~by:value - res) + CCString.replace + ~which:`All + ~sub:(Format.sprintf "{{%s}}" name) + ~by:value + res) template params ;; diff --git a/sihl/src/gen_entity.ml b/sihl/src/gen_entity.ml index 6b611640c..34bc2b804 100644 --- a/sihl/src/gen_entity.ml +++ b/sihl/src/gen_entity.ml @@ -10,7 +10,7 @@ type t = let create {{create_args}} = let now = Ptime_clock.now () in - let id = Uuidm.v `V4 |> Uuidm.to_string in + let id = Sihl.Random.Uuid.create () in { id; {{created_value}} created_at = now; updated_at = now } ;; diff --git a/sihl/src/gen_migration.ml b/sihl/src/gen_migration.ml index a070d77ab..6e8af2685 100644 --- a/sihl/src/gen_migration.ml +++ b/sihl/src/gen_migration.ml @@ -85,9 +85,9 @@ let migration_schema_mariadb (schema : Gen_core.schema) = ;; let write_migration_file - (database : Gen_core.database) - (name : string) - (schema : Gen_core.schema) + (database : Gen_core.database) + (name : string) + (schema : Gen_core.schema) = let open Gen_core in let file = diff --git a/sihl/src/gen_repo.ml b/sihl/src/gen_repo.ml index bd5bc67d8..abaf8fbaf 100644 --- a/sihl/src/gen_repo.ml +++ b/sihl/src/gen_repo.ml @@ -334,9 +334,9 @@ let filter_fragment (schema : Gen_core.schema) = ;; let file - (database : Gen_core.database) - (name : string) - (schema : Gen_core.schema) + (database : Gen_core.database) + (name : string) + (schema : Gen_core.schema) = let open Gen_core in let params = diff --git a/sihl/src/sihl.mli b/sihl/src/sihl.mli index 622b4c529..df3d36ef9 100644 --- a/sihl/src/sihl.mli +++ b/sihl/src/sihl.mli @@ -71,7 +71,8 @@ module Configuration : sig like SMTP_HOST and a value. *) type data = (string * string) list - (** The configuration contains configuration data and a configuration schema. *) + (** The configuration contains configuration data and a configuration schema. + *) type config = Core_configuration.config = { name : string ; description : string @@ -136,14 +137,16 @@ module Configuration : sig [None] is returned. If you just want to access configuration values, use the read functions - instead. Every time you call [read_env_file] the file is read from disk. *) + instead. Every time you call [read_env_file] the file is read from disk. + *) val read_env_file : unit -> data option (** [load_env_file ()] reads an [.env] file using {!read_env_file} and stores its contents into the environment variables. *) val load_env_file : unit -> unit - (** [load ()] calls {!load_env_file} and makes sure that [SIHL_ENV] was set. *) + (** [load ()] calls {!load_env_file} and makes sure that [SIHL_ENV] was set. + *) val load : unit -> unit (** [read schema] returns the decoded, statically typed version of @@ -376,7 +379,8 @@ module Web : sig ] (** A [query] describes the search terms of an [`Index] action and it - represents a partial view on a collection that is sorted and filtered. *) + represents a partial view on a collection that is sorted and filtered. + *) type query = Web_rest.Query.t = { filter : string option ; limit : int option @@ -917,7 +921,8 @@ module Web : sig The flash data is stored in a separate flash cookie. The usual limitations apply such as a maximum of 4KB. Note that the cookie is not - signed, don't put any data into the flash cookie that you have to trust. *) + signed, don't put any data into the flash cookie that you have to trust. + *) val flash : ?cookie_key:string -> unit -> Rock.Middleware.t (** [id ()] returns a middleware that reads the [X-Request-ID] headers and @@ -1088,6 +1093,14 @@ module Random : sig cases you want to use {!base64} to get a string that can be used safely in most web contexts.*) val bytes : int -> string + + module Uuid : sig + type t + + val create : unit -> string + val of_string : ?pos:int -> string -> t option + val to_binary_string : t -> string + end end (** This module contains various test utilities and can be used to test more diff --git a/sihl/src/web.ml b/sihl/src/web.ml index 60289a49d..88006b014 100644 --- a/sihl/src/web.ml +++ b/sihl/src/web.ml @@ -47,8 +47,8 @@ let prefix prefix ((meth, path, handler) : route) = ;; let apply_middleware_stack - (middleware_stack : Rock.Middleware.t list) - ((meth, path, handler) : route) + (middleware_stack : Rock.Middleware.t list) + ((meth, path, handler) : route) = (* The request goes through the middleware stack from top to bottom, so we have to reverse the middleware stack *) diff --git a/sihl/src/web_csrf.ml b/sihl/src/web_csrf.ml index 73cdd7c3b..4c87773d7 100644 --- a/sihl/src/web_csrf.ml +++ b/sihl/src/web_csrf.ml @@ -26,17 +26,18 @@ let set token req = (* TODO (https://docs.djangoproject.com/en/3.0/ref/csrf/#how-it-works) Check other Django specifics namely: - * Testing views with custom HTTP client - * Allow Sihl user to make views exempt - * Enable subdomain - * HTML caching token handling - *) + * Testing views with custom HTTP client + * Allow Sihl user to make views exempt + * Enable subdomain + * HTML caching token handling +*) module Crypto = struct - let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) + let () = Mirage_crypto_rng_unix.use_default () let block_size = 16 - (** [token_length] is the amount of bytes used in the unencrypted CSRF tokens. *) + (** [token_length] is the amount of bytes used in the unencrypted CSRF tokens. + *) let token_length = 4 * block_size module Secret : sig @@ -53,7 +54,10 @@ module Crypto = struct type t = Cstruct.t let make secret = - secret |> Cstruct.of_string |> Mirage_crypto.Hash.SHA256.digest + secret + |> Digestif.SHA256.digest_string + |> Digestif.SHA256.to_raw_string + |> Cstruct.of_string ;; let to_raw = CCFun.id @@ -108,16 +112,18 @@ module Crypto = struct let to_struct = CCFun.id let from_struct ~with_secret value = - let open Mirage_crypto.Cipher_block.AES.ECB in - let key = with_secret |> Secret.to_raw |> of_secret in - encrypt ~key value + let open Cstruct in + let open Mirage_crypto.AES.ECB in + let key = with_secret |> Secret.to_raw |> to_string |> of_secret in + encrypt ~key (to_string value) |> of_string ;; let from_struct_random ~with_secret value = - let open Mirage_crypto.Cipher_block.AES.CBC in - let key = with_secret |> Secret.to_raw |> of_secret in + let open Cstruct in + let open Mirage_crypto.AES.CBC in + let key = with_secret |> Secret.to_raw |> to_string |> of_secret in let iv = Mirage_crypto_rng.generate block_size in - Cstruct.append iv @@ encrypt ~key ~iv value + append (of_string iv) @@ (encrypt ~key ~iv (to_string value) |> of_string) ;; end @@ -159,21 +165,25 @@ module Crypto = struct let equal = Cstruct.equal let equal_struct = equal - let from_encrypted ~with_secret value = - let open Mirage_crypto.Cipher_block.AES.ECB in - let key = with_secret |> Secret.to_raw |> of_secret in - decrypt ~key (Encrypted_token.to_struct value) + let from_encrypted ~with_secret (value : Encrypted_token.t) : Cstruct.t = + let open Cstruct in + let open Mirage_crypto.AES.ECB in + let key = with_secret |> Secret.to_raw |> to_string |> of_secret in + decrypt ~key (Encrypted_token.to_struct value |> to_string) |> of_string ;; - let from_encrypted_random ~with_secret value = - let open Mirage_crypto.Cipher_block.AES.CBC in - let key = with_secret |> Secret.to_raw |> of_secret in + let from_encrypted_random ~with_secret (value : Encrypted_token.t) + : Cstruct.t + = + let open Cstruct in + let open Mirage_crypto.AES.CBC in + let key = with_secret |> Secret.to_raw |> to_string |> of_secret in let iv, value = value |> Encrypted_token.to_struct |> CCFun.flip Cstruct.split block_size in - decrypt ~key ~iv value + decrypt ~key ~iv:(to_string iv) (to_string value) |> of_string ;; let from_encrypted_to_encrypted_random ~with_secret value = @@ -188,13 +198,13 @@ let default_not_allowed_handler _ = ;; let middleware - ?(not_allowed_handler = default_not_allowed_handler) - ?(key = "_csrf") - ?(session_key = "_session") - ?(input_name = "_csrf") - ?(secret = Core_configuration.read_secret ()) - ?(expires : Opium.Cookie.expires option) - () + ?(not_allowed_handler = default_not_allowed_handler) + ?(key = "_csrf") + ?(session_key = "_session") + ?(input_name = "_csrf") + ?(secret = Core_configuration.read_secret ()) + ?(expires : Opium.Cookie.expires option) + () = let open Crypto in let block_secret = Secret.make secret in @@ -208,15 +218,17 @@ let middleware (* Set fake token since CSRF is disabled *) handler (set "development" req) else - let (* CSRF token might come from a multipart form *) - open CCOption.Infix in + let + (* CSRF token might come from a multipart form *) + open + CCOption.Infix in let%lwt multipart = Opium.Request.to_multipart_form_data req in let%lwt received_encrypted_token = multipart >>= List.assoc_opt input_name |> (function - | None -> Opium.Request.urlencoded input_name req - | tkn -> Lwt.return tkn) + | None -> Opium.Request.urlencoded input_name req + | tkn -> Lwt.return tkn) |> Lwt.map (CCOption.flat_map Encrypted_token.of_uri_safe_string) in let stored_encrypted_token = @@ -232,7 +244,9 @@ let middleware ~with_secret:block_secret tkn ) | None -> - let value = Mirage_crypto_rng.generate token_length in + let value = + Mirage_crypto_rng.generate token_length |> Cstruct.of_string + in ( Encrypted_token.from_struct ~with_secret:block_secret value , Encrypted_token.from_struct_random ~with_secret:block_secret value ) in diff --git a/sihl/src/web_error.ml b/sihl/src/web_error.ml index 371f03724..89918bf1a 100644 --- a/sihl/src/web_error.ml +++ b/sihl/src/web_error.ml @@ -95,59 +95,60 @@ let create_error_email (sender, recipient) error = ;; let middleware - ?email_config - ?(reporter = fun _ _ -> Lwt.return ()) - ?error_handler - () + ?email_config + ?(reporter = fun _ _ -> Lwt.return ()) + ?error_handler + () = let filter handler req = Lwt.catch (fun () -> handler req) (fun exn -> - let report = report exn req in - (* Make sure to Lwt.catch everything that might go wrong. *) - (* Log the error *) - let error = exn_to_string report in - Logs.err (fun m -> m "%s" error); - (* Report error via email, don't wait for it.*) - let _ = - match email_config with - | Some (sender, recipient, send_fn) -> - let email = create_error_email (sender, recipient) error in - Lwt.catch - (fun () -> send_fn email) - (fun exn -> + let report = report exn req in + (* Make sure to Lwt.catch everything that might go wrong. *) + (* Log the error *) + let error = exn_to_string report in + Logs.err (fun m -> m "%s" error); + (* Report error via email, don't wait for it.*) + let _ = + match email_config with + | Some (sender, recipient, send_fn) -> + let email = create_error_email (sender, recipient) error in + Lwt.catch + (fun () -> send_fn email) + (fun exn -> + let msg = Printexc.to_string exn in + Logs.err (fun m -> + m "Failed to report error per email: %s" msg); + Lwt.return ()) + | _ -> Lwt.return () + in + (* Use custom reporter to catch error, don't wait for it. *) + let _ = + Lwt.catch + (fun () -> reporter req report) + (fun exn -> let msg = Printexc.to_string exn in - Logs.err (fun m -> m "Failed to report error per email: %s" msg); + Logs.err (fun m -> + m "Failed to run custom error reporter: %s" msg); Lwt.return ()) - | _ -> Lwt.return () - in - (* Use custom reporter to catch error, don't wait for it. *) - let _ = - Lwt.catch - (fun () -> reporter req report) - (fun exn -> - let msg = Printexc.to_string exn in - Logs.err (fun m -> - m "Failed to run custom error reporter: %s" msg); - Lwt.return ()) - in - let content_type = - try - req - |> Opium.Request.header "Content-Type" - |> Option.map (String.split_on_char ';') - |> Option.map List.hd - with - | _ -> None - in - match error_handler with - | Some error_handler -> error_handler req - | None -> - (match content_type with - | Some "application/json" -> json_error_handler req - (* Default to text/html *) - | _ -> site_error_handler req)) + in + let content_type = + try + req + |> Opium.Request.header "Content-Type" + |> Option.map (String.split_on_char ';') + |> Option.map List.hd + with + | _ -> None + in + match error_handler with + | Some error_handler -> error_handler req + | None -> + (match content_type with + | Some "application/json" -> json_error_handler req + (* Default to text/html *) + | _ -> site_error_handler req)) in (* In a production setting we don't want to use the built in debugger middleware of opium. It is useful for development but it exposed too much diff --git a/sihl/src/web_migration.ml b/sihl/src/web_migration.ml index 0d4cb2fa8..9ff2c86c9 100644 --- a/sihl/src/web_migration.ml +++ b/sihl/src/web_migration.ml @@ -13,9 +13,10 @@ let middleware pending_migrations = m "There are %d pending migrations" (List.length migrations)); Logs.info (fun m -> m "Run 'sihl migrate' to apply the pending migrations"); - if Core_configuration.is_production () - (* We try to make it work, even if the application makes wrong - assumptions about the database schema. *) + if + Core_configuration.is_production () + (* We try to make it work, even if the application makes wrong + assumptions about the database schema. *) then handler req else raise Pending_migrations) else handler req diff --git a/sihl/src/web_rest.ml b/sihl/src/web_rest.ml index 85491c80b..6929f541a 100644 --- a/sihl/src/web_rest.ml +++ b/sihl/src/web_rest.ml @@ -9,19 +9,19 @@ module Form = struct [@@deriving yojson, show, eq] let set - ?(key = "_form") - (errors : Conformist.error list) - (urlencoded : (string * string list) list) - resp + ?(key = "_form") + (errors : Conformist.error list) + (urlencoded : (string * string list) list) + resp = let t = List.map (fun (k, v) -> - errors - |> List.find_opt (fun (field, _, _) -> String.equal field k) - |> Option.map (fun (field, input, value) -> - field, CCList.head_opt input, Some value) - |> Option.value ~default:(k, CCList.head_opt v, None)) + errors + |> List.find_opt (fun (field, _, _) -> String.equal field k) + |> Option.map (fun (field, input, value) -> + field, CCList.head_opt input, Some value) + |> Option.value ~default:(k, CCList.head_opt v, None)) urlencoded in let json = t |> to_yojson |> Yojson.Safe.to_string in @@ -126,23 +126,21 @@ module Query = struct let to_query_string (query : t) : string = Uri.empty |> (fun uri -> - match query.filter with - | Some filter -> Uri.add_query_param uri ("filter", [ filter ]) - | None -> uri) + match query.filter with + | Some filter -> Uri.add_query_param uri ("filter", [ filter ]) + | None -> uri) |> (fun uri -> - match query.limit with - | Some limit -> - Uri.add_query_param uri ("limit", [ string_of_int limit ]) - | None -> uri) + match query.limit with + | Some limit -> Uri.add_query_param uri ("limit", [ string_of_int limit ]) + | None -> uri) |> (fun uri -> - match query.offset with - | Some offset -> - Uri.add_query_param uri ("offset", [ string_of_int offset ]) - | None -> uri) + match query.offset with + | Some offset -> Uri.add_query_param uri ("offset", [ string_of_int offset ]) + | None -> uri) |> (fun uri -> - match query.sort with - | Some sort -> Uri.add_query_param uri ("sort", [ string_of_sort sort ]) - | None -> uri) + match query.sort with + | Some sort -> Uri.add_query_param uri ("sort", [ string_of_sort sort ]) + | None -> uri) |> Uri.to_string ;; @@ -397,11 +395,11 @@ type action = ] let router_of_action - (type a) - (module Controller : CONTROLLER with type t = a) - name - schema - (action : action) + (type a) + (module Controller : CONTROLLER with type t = a) + name + schema + (action : action) = match action with | `Index -> Web.get (Format.sprintf "/%s" name) (Controller.index name) @@ -417,21 +415,21 @@ let router_of_action ;; let routers_of_actions - (type a) - name - schema - (module Controller : CONTROLLER with type t = a) - (actions : action list) + (type a) + name + schema + (module Controller : CONTROLLER with type t = a) + (actions : action list) = List.map (router_of_action (module Controller) name schema) actions ;; let resource_of_controller - (type a) - ?only - name - schema - (module Controller : CONTROLLER with type t = a) + (type a) + ?only + name + schema + (module Controller : CONTROLLER with type t = a) = match only with | None -> @@ -444,12 +442,12 @@ let resource_of_controller ;; let resource_of_service - (type a) - ?only - name - schema - ~view:(module View : VIEW with type t = a) - (module Service : SERVICE with type t = a) + (type a) + ?only + name + schema + ~view:(module View : VIEW with type t = a) + (module Service : SERVICE with type t = a) = let module Controller = MakeController (Service) (View) in resource_of_controller ?only name schema (module Controller) diff --git a/sihl/src/web_session.ml b/sihl/src/web_session.ml index ee8725ce8..25c2ef0bc 100644 --- a/sihl/src/web_session.ml +++ b/sihl/src/web_session.ml @@ -35,10 +35,10 @@ let decode_session_resp cookie_key signed_with resp = ;; let find - ?(cookie_key = "_session") - ?(secret = Core_configuration.read_secret ()) - key - req + ?(cookie_key = "_session") + ?(secret = Core_configuration.read_secret ()) + key + req = let signed_with = Opium.Cookie.Signer.make secret in let session = @@ -48,9 +48,9 @@ let find ;; let get_all - ?(cookie_key = "_session") - ?(secret = Core_configuration.read_secret ()) - req + ?(cookie_key = "_session") + ?(secret = Core_configuration.read_secret ()) + req = let open CCOption.Infix in let signed_with = Opium.Cookie.Signer.make secret in @@ -61,10 +61,10 @@ let get_all ;; let set - ?(cookie_key = "_session") - ?(secret = Core_configuration.read_secret ()) - session - resp + ?(cookie_key = "_session") + ?(secret = Core_configuration.read_secret ()) + session + resp = let signed_with = Opium.Cookie.Signer.make secret in let session = session |> List.to_seq |> Session.StrMap.of_seq in @@ -78,13 +78,13 @@ let set ;; let update_or_set_value - ?(cookie_key = "_session") - ?(secret = Core_configuration.read_secret ()) - ?(expires : Opium.Cookie.expires option) - ~key - f - req - resp + ?(cookie_key = "_session") + ?(secret = Core_configuration.read_secret ()) + ?(expires : Opium.Cookie.expires option) + ~key + f + req + resp = let signed_with = Opium.Cookie.Signer.make secret in let mreq = @@ -113,13 +113,13 @@ let update_or_set_value (* TODO improve API, don't take req maybe *) let set_value - ?(cookie_key = "_session") - ?(secret = Core_configuration.read_secret ()) - ?expires - ~key - value - req - resp + ?(cookie_key = "_session") + ?(secret = Core_configuration.read_secret ()) + ?expires + ~key + value + req + resp = update_or_set_value ~cookie_key diff --git a/sihl/src/web_trailing_slash.ml b/sihl/src/web_trailing_slash.ml index 59c67f7d8..23ce97883 100644 --- a/sihl/src/web_trailing_slash.ml +++ b/sihl/src/web_trailing_slash.ml @@ -11,9 +11,9 @@ let middleware () = uri |> Uri.path |> (fun path -> - if Uri.equal root_uri uri - then path (* don't drop root *) - else path |> CCString.rdrop_while (Char.equal '/')) + if Uri.equal root_uri uri + then path (* don't drop root *) + else path |> CCString.rdrop_while (Char.equal '/')) |> Uri.with_path uri in let req = Opium.Request.{ req with target = Uri.to_string uri } in diff --git a/sihl/test/database.ml b/sihl/test/database.ml index 9bc935c1b..74ced65e9 100644 --- a/sihl/test/database.ml +++ b/sihl/test/database.ml @@ -86,9 +86,9 @@ let transaction_rolls_back _ () = let%lwt () = Lwt.catch (fun () -> - Sihl.Database.transaction (fun connection -> - let%lwt () = insert_username connection "foobar trx" in - failwith "Oh no, something went wrong during the transaction!")) + Sihl.Database.transaction (fun connection -> + let%lwt () = insert_username connection "foobar trx" in + failwith "Oh no, something went wrong during the transaction!")) (fun _ -> Lwt.return ()) in get_usernames connection) @@ -106,10 +106,10 @@ let invalid_request = let failing_query connection = Lwt.catch (fun () -> - let module Connection = (val connection : Caqti_lwt.CONNECTION) in - Connection.exec invalid_request () |> Lwt.map Sihl.Database.raise_error) + let module Connection = (val connection : Caqti_lwt.CONNECTION) in + Connection.exec invalid_request () |> Lwt.map Sihl.Database.raise_error) (* eat the exception silently *) - (fun _ -> Lwt.return ()) + (fun _ -> Lwt.return ()) ;; let query_does_not_exhaust_pool _ () = diff --git a/sihl/test/web_csrf.ml b/sihl/test/web_csrf.ml index 563f8d660..6f3b221f2 100644 --- a/sihl/test/web_csrf.ml +++ b/sihl/test/web_csrf.ml @@ -4,7 +4,7 @@ open Sihl.Web let can_parse_uri_safe _ () = let open Csrf.Crypto in let with_secret = Sihl.Configuration.read_secret () |> Secret.make in - let value = Mirage_crypto_rng.generate token_length in + let value = Mirage_crypto_rng.generate token_length |> Cstruct.of_string in let enc = Encrypted_token.from_struct ~with_secret value in let parsed = enc @@ -21,7 +21,7 @@ let can_parse_uri_safe _ () = let crypto_undo_helper encrypt decrypt = let open Csrf.Crypto in let with_secret = Sihl.Configuration.read_secret () |> Secret.make in - let value = Mirage_crypto_rng.generate token_length in + let value = Mirage_crypto_rng.generate token_length |> Cstruct.of_string in let dec = encrypt ~with_secret value |> decrypt ~with_secret in let open Alcotest in check bool "Same decrypted CSRF tokens" true @@ -45,7 +45,7 @@ let csrf_simulation _ () = let open Csrf.Crypto in let with_secret = Sihl.Configuration.read_secret () |> Secret.make in (* GET request generates value *) - let value = Mirage_crypto_rng.generate token_length in + let value = Mirage_crypto_rng.generate token_length |> Cstruct.of_string in (* Encrypt value for cookie token *) let enc = Encrypted_token.from_struct ~with_secret value in (* Encrypt value with randomness for body token (take already encrypted cookie @@ -296,8 +296,8 @@ let post_request_cookie_invalid_token_fails _ () = let reqs (token, _) = CCList.map (fun add_cookie -> - Request.of_urlencoded ~body:[ csrf_name, [ token ] ] route `POST - |> add_cookie) + Request.of_urlencoded ~body:[ csrf_name, [ token ] ] route `POST + |> add_cookie) [ CCFun.id; Sihl.Test.Session.set_value_req [ csrf_name, "garbage" ] ] in cookie_invalid_helper reqs @@ -308,8 +308,8 @@ let post_request_request_invalid_token_fails _ () = let reqs (_, cookie) = CCList.map (fun body -> - Request.of_urlencoded ~body route `POST - |> Request.add_cookie cookie.Cookie.value) + Request.of_urlencoded ~body route `POST + |> Request.add_cookie cookie.Cookie.value) [ []; [ csrf_name, [ "garbage" ] ] ] in cookie_invalid_helper reqs @@ -332,6 +332,7 @@ let post_request_with_nonmatching_token_fails _ () = (* Generate a random encrypted token *) let tkn = Mirage_crypto_rng.generate token_length + |> Cstruct.of_string |> Encrypted_token.from_struct_random ~with_secret |> Encrypted_token.to_uri_safe_string in @@ -362,6 +363,7 @@ let post_request_with_nonmatching_cookie_fails _ () = let with_secret = Sihl.Configuration.read_secret () |> Secret.make in let tkn = Mirage_crypto_rng.generate token_length + |> Cstruct.of_string |> Encrypted_token.from_struct ~with_secret |> Encrypted_token.to_uri_safe_string in @@ -452,7 +454,7 @@ let two_post_requests_succeed _ () = [ !token1; !token2; !token3 ]; CCList.iter (fun (tkn1, tkn2) -> - check bool "Different CSRF tokens" false (String.equal tkn1 tkn2)) + check bool "Different CSRF tokens" false (String.equal tkn1 tkn2)) [ !token1, !token2; !token1, !token3; !token2, !token3 ]; Lwt.return () ;; diff --git a/sihl/test/web_flash.ml b/sihl/test/web_flash.ml index 43aee8115..0cee537cc 100644 --- a/sihl/test/web_flash.ml +++ b/sihl/test/web_flash.ml @@ -56,10 +56,10 @@ let flash_is_cleared_after_request _ () = Rock.Middleware.apply (Sihl.Web.Middleware.flash ()) (fun _ -> - let res = - Opium.Response.of_plain_text "" |> Sihl.Web.Flash.set_alert "foobar" - in - Lwt.return res) + let res = + Opium.Response.of_plain_text "" |> Sihl.Web.Flash.set_alert "foobar" + in + Lwt.return res) req in (* Simulate the browser sending the last Set-Cookie *) @@ -71,9 +71,9 @@ let flash_is_cleared_after_request _ () = Rock.Middleware.apply (Sihl.Web.Middleware.flash ()) (fun req -> - let alert = Sihl.Web.Flash.find_alert req in - Alcotest.(check (option string) "has alert" (Some "foobar") alert); - Lwt.return @@ Opium.Response.of_plain_text "") + let alert = Sihl.Web.Flash.find_alert req in + Alcotest.(check (option string) "has alert" (Some "foobar") alert); + Lwt.return @@ Opium.Response.of_plain_text "") req in (* Simulate the browser sending the last Set-Cookie *) @@ -85,9 +85,9 @@ let flash_is_cleared_after_request _ () = Rock.Middleware.apply (Sihl.Web.Middleware.flash ()) (fun req -> - let alert = Sihl.Web.Flash.find_alert req in - Alcotest.(check (option string) "alert was cleared" None alert); - Lwt.return @@ Opium.Response.of_plain_text "") + let alert = Sihl.Web.Flash.find_alert req in + Alcotest.(check (option string) "alert was cleared" None alert); + Lwt.return @@ Opium.Response.of_plain_text "") req in assert_delete_cookie cookie; @@ -100,13 +100,13 @@ let set_and_read_flash_message _ () = Rock.Middleware.apply (Sihl.Web.Middleware.flash ()) (fun req -> - let alert = Sihl.Web.Flash.find_alert req in - let notice = Sihl.Web.Flash.find_notice req in - Alcotest.(check (option string) "has no alert" None alert); - Alcotest.(check (option string) "has no notice" None notice); - let res = Opium.Response.of_plain_text "" in - let res = Sihl.Web.Flash.set_alert "foobar" res in - Lwt.return res) + let alert = Sihl.Web.Flash.find_alert req in + let notice = Sihl.Web.Flash.find_notice req in + Alcotest.(check (option string) "has no alert" None alert); + Alcotest.(check (option string) "has no notice" None notice); + let res = Opium.Response.of_plain_text "" in + let res = Sihl.Web.Flash.set_alert "foobar" res in + Lwt.return res) req in (* Simulate the browser sending the last Set-Cookie *) @@ -118,14 +118,14 @@ let set_and_read_flash_message _ () = Rock.Middleware.apply (Sihl.Web.Middleware.flash ()) (fun req -> - let alert = Sihl.Web.Flash.find_alert req in - let notice = Sihl.Web.Flash.find_notice req in - Alcotest.(check (option string) "has alert" (Some "foobar") alert); - Alcotest.(check (option string) "has no notice" None notice); - let res = Opium.Response.of_plain_text "" in - let res = Sihl.Web.Flash.set_alert "nextfoo" res in - let res = Sihl.Web.Flash.set [ "hello", "other" ] res in - Lwt.return res) + let alert = Sihl.Web.Flash.find_alert req in + let notice = Sihl.Web.Flash.find_notice req in + Alcotest.(check (option string) "has alert" (Some "foobar") alert); + Alcotest.(check (option string) "has no notice" None notice); + let res = Opium.Response.of_plain_text "" in + let res = Sihl.Web.Flash.set_alert "nextfoo" res in + let res = Sihl.Web.Flash.set [ "hello", "other" ] res in + Lwt.return res) req in (* Simulate the browser sending the last Set-Cookie *) @@ -136,12 +136,12 @@ let set_and_read_flash_message _ () = Rock.Middleware.apply (Sihl.Web.Middleware.flash ()) (fun req -> - let alert = Sihl.Web.Flash.find_alert req in - let custom = Sihl.Web.Flash.find "hello" req in - Alcotest.(check (option string) "has alert" (Some "nextfoo") alert); - Alcotest.(check (option string) "has custom" (Some "other") custom); - let res = Opium.Response.of_plain_text "" in - Lwt.return res) + let alert = Sihl.Web.Flash.find_alert req in + let custom = Sihl.Web.Flash.find "hello" req in + Alcotest.(check (option string) "has alert" (Some "nextfoo") alert); + Alcotest.(check (option string) "has custom" (Some "other") custom); + let res = Opium.Response.of_plain_text "" in + Lwt.return res) req in (* Simulate the browser sending the last Set-Cookie *) @@ -153,10 +153,10 @@ let set_and_read_flash_message _ () = Rock.Middleware.apply (Sihl.Web.Middleware.flash ()) (fun req -> - let flash = Sihl.Web.Flash.find_alert req in - Alcotest.(check (option string) "has no alert" None flash); - let res = Opium.Response.of_plain_text "" in - Lwt.return res) + let flash = Sihl.Web.Flash.find_alert req in + Alcotest.(check (option string) "has no alert" None flash); + let res = Opium.Response.of_plain_text "" in + Lwt.return res) req in let cookie = Opium.Response.cookie "_flash" resp |> Option.get in diff --git a/sihl/test/web_session.ml b/sihl/test/web_session.ml index c6939deba..1e8888057 100644 --- a/sihl/test/web_session.ml +++ b/sihl/test/web_session.ml @@ -52,7 +52,7 @@ let invalid_session_cookie_value _ () = Opium.Request.get "" (* default empty session with default test secret *) |> Opium.Request.add_cookie - ("_session", "foobar.jE75kXj9sbZp6tP7oJLhrp9c/+w=") + ("_session", "foobar.AMemANOgnmTyWt8YIGmvZQ9GgZM=") in let handler req = let value = Sihl.Web.Session.find "foo" req in @@ -76,7 +76,7 @@ let cookie_set _ () = check (pair string string) "persists session values" - ("_session", {|{"foo":"bar"}.jE75kXj9sbZp6tP7oJLhrp9c/+w=|}) + ("_session", {|{"foo":"bar"}.AMemANOgnmTyWt8YIGmvZQ9GgZM=|}) cookie_value); Lwt.return () ;; @@ -97,7 +97,7 @@ let session_persisted_across_requests _ () = check (pair string string) "persists session values" - ("_session", {|{"foo":"bar"}.jE75kXj9sbZp6tP7oJLhrp9c/+w=|}) + ("_session", {|{"foo":"bar"}.AMemANOgnmTyWt8YIGmvZQ9GgZM=|}) cookie_value); let req = Opium.Request.get "" |> Opium.Request.add_cookie cookie.Opium.Cookie.value @@ -122,7 +122,7 @@ let session_persisted_across_requests _ () = check (pair string string) "persists session values" - ("_session", {|{"fooz":"other"}.VRJU0/vmwzPLrDU0zulQ7MojZUU=|}) + ("_session", {|{"fooz":"other"}.r96wRxmM2BrUBv3jOIovTWtu3aU=|}) cookie_value); let req = Opium.Request.get "" |> Opium.Request.add_cookie cookie.Opium.Cookie.value