diff --git a/.deepsource.toml b/.deepsource.toml deleted file mode 100644 index b2829b13..00000000 --- a/.deepsource.toml +++ /dev/null @@ -1,19 +0,0 @@ -version = 1 - -# The pinned upstream tree and its local copy are behavior references, not code -# maintained by this rewrite. Analyze the OCaml implementation and its support -# files instead. -exclude_patterns = [ - "path/to/tigerbeetle/**", - "ocam/src/**/*.zig", - "ocam/_build/**", - "ocam/zig/**", -] - -test_patterns = [ - "ocam/test/**", -] - -[[analyzers]] -name = "secrets" -enabled = true diff --git a/.github/workflows/tb_ocaml_ci.yml b/.github/workflows/tb_ocaml_ci.yml index a92cb153..e76dd715 100644 --- a/.github/workflows/tb_ocaml_ci.yml +++ b/.github/workflows/tb_ocaml_ci.yml @@ -27,22 +27,23 @@ jobs: - name: Set up OxCaml uses: ocaml/setup-ocaml@v3 with: - ocaml-compiler: oxcaml-compiler.5.2.0minus31 + ocaml-compiler: oxcaml-compiler.5.2.0minus39 + dune-cache: true opam-repositories: | ox: git+https://github.com/oxcaml/opam-repository.git default: git+https://github.com/ocaml/opam-repository.git - name: Install dependencies run: | - opam install . --deps-only --with-test --with-doc - opam install -y ocamlformat.0.26.2+ox1 + opam install . --deps-only --with-test + opam install -y ocamlformat.0.26.2+ox2 + + - name: Lint opam manifest + run: opam lint tigerbeetle_ocaml.opam - name: Build run: opam exec -- dune build - - name: Build docs - run: opam exec -- dune build @doc - - name: Run Dune runtest run: opam exec -- dune runtest @@ -50,6 +51,4 @@ jobs: run: opam exec -- dune build @bench - name: Check formatting - run: | - find . -name _build -prune -o \( -name '*.ml' -o -name '*.mli' \) -print0 \ - | xargs -0 opam exec -- ocamlformat --check + run: opam exec -- dune build @fmt diff --git a/.github/workflows/tb_ocaml_coverage.yml b/.github/workflows/tb_ocaml_coverage.yml index 1e195710..d29aa011 100644 --- a/.github/workflows/tb_ocaml_coverage.yml +++ b/.github/workflows/tb_ocaml_coverage.yml @@ -24,18 +24,19 @@ jobs: with: submodules: recursive - - name: Set up OxCaml + # bisect_ppx and odoc do not currently build on OxCaml's opam overlay, so + # coverage and docs run on the upstream compiler; the core is Stdlib-only. + - name: Set up OCaml uses: ocaml/setup-ocaml@v3 with: - ocaml-compiler: oxcaml-compiler.5.2.0minus31 - opam-repositories: | - ox: git+https://github.com/oxcaml/opam-repository.git - default: git+https://github.com/ocaml/opam-repository.git + ocaml-compiler: "5.2" + dune-cache: true - name: Install dependencies - run: | - opam install . --deps-only --with-test - opam install bisect_ppx + run: opam install -y qcheck bisect_ppx odoc + + - name: Build docs + run: opam exec -- dune build @doc - name: Run coverage-instrumented tests run: | @@ -44,8 +45,21 @@ jobs: BISECT_SILENT=YES BISECT_FILE="$PWD/_coverage/bisect" \ opam exec -- dune runtest --instrument-with bisect_ppx --force - - name: Generate coverage summary - run: opam exec -- bisect-ppx-report summary --coverage-path _coverage + - name: Enforce coverage threshold + env: + MINIMUM_COVERAGE: "75" + run: | + summary="$(opam exec -- bisect-ppx-report summary --coverage-path _coverage)" + echo "$summary" + percent="$(printf '%s\n' "$summary" | sed -n 's/.*(\([0-9.]*\)%).*/\1/p' | head -n1)" + if [ -z "$percent" ]; then + echo "could not parse coverage percentage" >&2 + exit 1 + fi + if awk -v p="$percent" -v m="$MINIMUM_COVERAGE" 'BEGIN { exit !(p + 0 < m + 0) }'; then + echo "coverage ${percent}% is below the ${MINIMUM_COVERAGE}% minimum" >&2 + exit 1 + fi - name: Generate HTML report run: opam exec -- bisect-ppx-report html --coverage-path _coverage diff --git a/BENCHMARK_COMPARISON.md b/BENCHMARK_COMPARISON.md index 6b13291c..2c650e97 100644 --- a/BENCHMARK_COMPARISON.md +++ b/BENCHMARK_COMPARISON.md @@ -1,9 +1,20 @@ # State-machine benchmark status -The OCaml workload creates two accounts before timing, then applies 30,000 -successful posted transfers in prebuilt batches of 30. Request construction is -outside the timed interval. A future valid native runner should use the same -transfer workload. +The OCaml benchmark runs several workloads over 100 accounts, each with +prebuilt requests in batches of 30 so request construction is outside the +timed interval: + +| Workload | Timed path | +| --- | --- | +| `posted_transfers` | 30,000 successful single-phase transfers. | +| `pending_then_post_or_void` | 30,000 pending transfers, then 30,000 posts/voids resolving them. | +| `linked_chains` | 30,000 transfers in successful 30-request linked chains, over a pre-populated ledger. | +| `failing_linked_chains` | 30,000 transfers in linked chains whose last request fails, exercising rollback. | +| `queries_over_populated_ledger` | Timestamp-bounded `query_*`, `get_account_transfers`, and `get_account_balances` over 30,000 transfers. | +| `pending_expiry` | Expiring 30,000 timed-out pending transfers. | + +A future valid native runner should use the `posted_transfers` workload for +the paired comparison. Only the OCaml runner is currently executable: @@ -38,4 +49,4 @@ modes. | Implementation | Operations/s | Mean batch latency (ms) | Allocation | | --- | ---: | ---: | --- | | TigerBeetle Zig | blocked | blocked | The standalone fixture needs TigerBeetle's internal commit sequencing completed before it can produce a valid run. | -| OCaml | 1,250,115 | 0.024 | 5,767,131 words total; 192.24 words/op | +| OCaml (`posted_transfers`, before indexing/journal work) | 1,250,115 | 0.024 | 192.24 words/op | diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 00000000..7bc59b56 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,86 @@ +# Contributing + +Read [`README.md`](README.md) and [`AGENTS.md`](AGENTS.md) first. The pinned +TigerBeetle tree at `path/to/tigerbeetle` is the behavior oracle; do not edit +or advance it as part of a change to the OCaml core. + +## Toolchain + +The OCaml code is built with the OxCaml compiler pinned in +`.github/workflows/tb_ocaml_ci.yml`. From `ocam/`: + +```sh +opam switch create tigerbeetle-oxcaml oxcaml-compiler.5.2.0minus39 \ + --repos ox=git+https://github.com/oxcaml/opam-repository.git,default +eval "$(opam env --switch tigerbeetle-oxcaml)" +opam install . --deps-only --with-test +opam install ocamlformat.0.26.2+ox2 +``` + +## Checks + +Run the same commands CI runs before opening a pull request, from `ocam/`: + +```sh +opam exec -- dune build +opam exec -- dune runtest +opam exec -- dune build @bench +opam exec -- dune build @fmt # or `dune fmt` to rewrite in place +``` + +`dune build @doc` needs `odoc`, which (like `bisect_ppx`) does not currently +build on the OxCaml opam overlay; CI builds docs on upstream OCaml 5.2 in the +coverage workflow. + +The coverage workflow instruments the tests with Bisect PPX and fails when +line coverage drops below the `MINIMUM_COVERAGE` set in +`.github/workflows/tb_ocaml_coverage.yml`. That workflow runs on upstream +OCaml 5.2 (the core is Stdlib-only). Reproduce it locally on a standard switch +with: + +```sh +opam install bisect_ppx +BISECT_FILE="$PWD/_coverage/bisect" \ + opam exec -- dune runtest --instrument-with bisect_ppx --force +opam exec -- bisect-ppx-report summary --coverage-path _coverage +``` + +## Layout of the OCaml core + +| Module | Role | +| --- | --- | +| `U128` | Unsigned 128-bit integers with explicit overflow/underflow results. | +| `Types` | Account, transfer, filter, and status records shared by every module. | +| `Result_code` | Numeric `CreateAccountsResult`/`CreateTransfersResult` codes. | +| `Timeline` | Append-only, timestamp-ordered index with binary-searched range reads. | +| `Ledger` | Storage, timestamp and per-account indexes, and the rollback journal. | +| `State_machine` | Validation, batch execution, and the public API. | + +Keep the core deterministic and synchronous: no Async, storage, clock, or +network dependency. New behavior should be compared against the pinned Zig +`src/state_machine.zig` and its tests, and covered by a scenario in +`ocam/test/state_machine_test.ml` or a property in +`ocam/test/state_machine_property_test.ml`. + +## Version control + +Contributors use [Jujutsu (`jj`)](https://github.com/jj-vcs/jj) on top of the +Git repository. Set it up once in an existing clone: + +```sh +jj git init --colocate +jj git fetch +``` + +With a colocated repository, Git and `jj` share the working copy, so CI and +GitHub continue to see ordinary Git branches. Inspect `jj status` and +`jj diff` before and after changes, and see the "Commit and push workflow" in +[`AGENTS.md`](AGENTS.md) for how bookmarks are moved and pushed. Plain Git +commands also work if you do not use `jj`; the requirement is that the history +you push consists of coherent commits that do not touch the pinned submodule. + +## License + +Contributions are accepted under the Apache License 2.0 in [`LICENSE`](LICENSE), +the same license as the upstream TigerBeetle sources this repository derives +from. diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..f433b1a5 --- /dev/null +++ b/LICENSE @@ -0,0 +1,177 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS diff --git a/README.md b/README.md index 2ab8ac70..67ed8238 100644 --- a/README.md +++ b/README.md @@ -10,23 +10,32 @@ reference; do not treat this repository as a replacement TigerBeetle server. - `ocam/` — a copy of that pinned revision (`97c7a8ef385270ebe0e1b75959d3d21d134629df`), with `src/state_machine.zig` replaced by the OCaml state machine and its interface. -- `ocam/src/` — deterministic ledger core, built with Dune and Base. -- `ocam/test/` and `ocam/bench/` — equivalence scenarios and a state-machine - benchmark. [`BENCHMARK_COMPARISON.md`](BENCHMARK_COMPARISON.md) records the - workload, the latest local OCaml result, and the current native-baseline - blocker. - -The build and CI use the pinned OxCaml compiler, Jane Street Base, and the -matching OxCaml-compatible formatter. The current core is synchronous and -keeps its state and wire/storage representations explicit; Async belongs at an + The copied Zig LSM/VSR sources, docs, and clients are kept verbatim so the + eventual C-ABI adapter can be developed in place; the copied upstream CI + workflows are not kept because they do not apply to this project. +- `ocam/src/` — deterministic ledger core, built with Dune on the OCaml + standard library: `U128`, `Types`, `Result_code`, `Ledger`, and the public + `State_machine` module. +- `ocam/test/` and `ocam/bench/` — equivalence scenarios, QCheck properties, + and a multi-workload state-machine benchmark. + [`BENCHMARK_COMPARISON.md`](BENCHMARK_COMPARISON.md) records the workloads + and the current native-baseline blocker. +- `doc/` — reader's guide and architecture notes for the OCaml core. + +The build and CI use the pinned OxCaml compiler and the matching +OxCaml-compatible formatter. The current core is synchronous and keeps its +state and wire/storage representations explicit; Async belongs at an integration boundary rather than in the ledger logic. +The submodule path `path/to/tigerbeetle` is historical; renaming it would +rewrite the submodule entry, so it is left in place and referenced by name. + ## Build, test, and benchmark From `ocam/`: ```sh -opam switch create tigerbeetle-oxcaml oxcaml-compiler.5.2.0minus31 \ +opam switch create tigerbeetle-oxcaml oxcaml-compiler.5.2.0minus39 \ --repos ox=git+https://github.com/oxcaml/opam-repository.git,default eval "$(opam env --switch tigerbeetle-oxcaml)" opam install . --deps-only --with-test @@ -42,13 +51,13 @@ the same pinned OxCaml compiler. The formatting check uses the matching OxCaml-compatible formatter: ```sh -opam install ocamlformat.0.26.2+ox1 -find . -name _build -prune -o \( -name '*.ml' -o -name '*.mli' \) -print0 \ - | xargs -0 opam exec -- ocamlformat --check +opam install ocamlformat.0.26.2+ox2 +opam exec -- dune build @fmt # `dune fmt` rewrites files in place ``` -The OCaml benchmark reports operations per second, per-batch latency, and -allocation figures. Run it from `ocam/`: +The OCaml benchmark reports operations per second and allocation per +operation for posted transfers, two-phase transfers, successful and failing +linked chains, indexed queries, and pending expiry. Run it from `ocam/`: ```sh opam exec -- dune exec bench/state_machine_bench.exe @@ -61,11 +70,14 @@ a comparison result. ## Code analysis -DeepSource is configured in [`.deepsource.toml`](.deepsource.toml) for secret -scanning. The pinned upstream source and its local Zig copy are excluded because -they are behavior references rather than maintained rewrite code. After merging -the configuration to the repository's default branch, activate Code Review in -the DeepSource repository settings. +CI runs `opam lint`, `dune build @fmt`, the test suite, and a Bisect PPX +coverage job with a minimum line-coverage threshold +(`.github/workflows/tb_ocaml_coverage.yml`). The coverage job also builds the +`odoc` API reference; it runs on upstream OCaml 5.2 because `bisect_ppx` and +`odoc` do not currently build on the OxCaml opam overlay. +CodeRabbit reviews pull requests +(`.coderabbit.yaml`). See [`CONTRIBUTING.md`](CONTRIBUTING.md) for the local +equivalents and the `jj` workflow. ## Documentation @@ -92,3 +104,10 @@ operations, linked rollback, lookups, and queries; full TigerBeetle equivalence still requires the complete Zig corpus and several protocol and edge-case areas. See [`ocam/OCAML_REWRITE.md`](ocam/OCAML_REWRITE.md) for the detailed coverage and remaining work. + +## License + +The OCaml code and documentation in this repository are licensed under the +Apache License 2.0 ([`LICENSE`](LICENSE)), matching the upstream TigerBeetle +sources copied under `ocam/` (`ocam/LICENSE`) and pinned at +`path/to/tigerbeetle`. diff --git a/doc/README.md b/doc/README.md index 4c1249ff..f6cacec9 100644 --- a/doc/README.md +++ b/doc/README.md @@ -1,7 +1,8 @@ # OCaml ledger core This is the reader's guide for the experimental OCaml rewrite in -[`ocam/src/state_machine.ml`](../ocam/src/state_machine.ml). It is a +[`ocam/src/`](../ocam/src/), whose public entry point is +[`state_machine.ml`](../ocam/src/state_machine.ml). It is a deterministic, in-memory implementation of a portion of TigerBeetle's ledger state-machine behavior. It is not a TigerBeetle server and it does not yet replace the pinned upstream Zig implementation. @@ -35,8 +36,10 @@ thread. There is deliberately no Async, storage, network, or clock dependency in this layer. Identifiers and amounts are `U128.t`. `U128` exposes construction, comparison, -addition, and subtraction explicitly so balance arithmetic can report overflow -or underflow rather than silently wrapping. +addition, subtraction, multiplication, division, shifts, and decimal/hex +conversion; the arithmetic returns explicit `Overflow`, `Underflow`, or +`Division_by_zero` results rather than silently wrapping. `Result_code` maps +every `create_*_status` to the numeric codes of the pinned TigerBeetle enums. An account has four monotonic balance fields: @@ -59,7 +62,7 @@ credits. | `create_transfers` | Validates and applies normal, pending, post-pending, and void-pending transfers. | | `expire_pending_transfers` | Removes balances for timed-out pending transfers and marks them expired. | | `lookup_accounts`, `lookup_transfers` | Looks up supplied IDs, keeping request order and omitting unknown IDs. | -| `query_accounts`, `query_transfers` | Filters by non-zero fields, sorts by timestamp, then applies `limit`. | +| `query_accounts`, `query_transfers` | Walks the timestamp index within `[timestamp_min, timestamp_max]`, filters by non-zero fields, then applies `limit`. | | `get_account_transfers` | Queries transfer history for the debit and/or credit side of one account. | | `get_account_balances` | Queries per-transfer balance snapshots for history-enabled accounts; timeout expiry does not append a snapshot. | diff --git a/doc/architecture.md b/doc/architecture.md index c65790e9..69c34b17 100644 --- a/doc/architecture.md +++ b/doc/architecture.md @@ -7,11 +7,18 @@ compatible. For the compatibility boundary, see ## State and determinism -`State_machine.t` holds three in-memory tables keyed by `U128` ID: +`State_machine.t` is a `Ledger.t`. It holds three in-memory tables keyed by +`U128` ID: - accounts; - transfers; and -- pending-transfer status (`Pending`, `Posted`, `Voided`, or `Expired`). +- pending-transfer status (`Pending`, `Posted`, `Voided`, or `Expired`); + +plus derived indexes that reads consult instead of scanning those tables: +accounts and transfers ordered by timestamp, each account's transfers and +balance-history snapshots ordered by timestamp, and pending transfers ordered +by expiry time. Every write goes through `Ledger` so the indexes stay +consistent with the tables. The only mutable state is inside `t`. Given the same initial state and the same operations in the same order, the core produces the same result records and @@ -66,10 +73,13 @@ later post or void. ## Linked batches The `linked` flag makes adjacent requests atomic. A run ends at the first -request whose `linked` flag is false. The core applies a linked run to a cloned -state and commits that clone only if every request succeeds. If a request -fails, that request keeps its actual error while all other requests in the run -receive `*_linked_event_failed`; no change from the run becomes visible. +request whose `linked` flag is false. The core applies a linked run inside +`Ledger.transact`, which records an undo entry for every table and index +write. If every request succeeds the journal is discarded; if any request +fails the journal is replayed in reverse, so rollback costs are proportional to +the chain rather than to the whole ledger. The failing request keeps its +actual error while all other requests in the run receive +`*_linked_event_failed`; no change from the run becomes visible. A batch whose final request is marked `linked` has an open trailing chain. Complete prefix chains remain committed. Earlier requests in the open suffix diff --git a/ocam/.github/ci/test_aof.sh b/ocam/.github/ci/test_aof.sh deleted file mode 100755 index aef32da4..00000000 --- a/ocam/.github/ci/test_aof.sh +++ /dev/null @@ -1,100 +0,0 @@ -#!/usr/bin/env bash -set -eEuo pipefail - -# Download Zig if it does not yet exist: -if [ ! -f "zig/zig" ]; then - ./zig/download.sh -fi - -./zig/zig build install -Drelease - -# Be careful to use a benchmark-specific filenames so that we don't erase a real data file: -cleanup() { - rm -f aof-test.tigerbeetle - rm -f aof-test.tigerbeetle.aof - rm -f aof.log - rm -f {a1,a2,b1,b2}/aof-test.tigerbeetle{,.aof} - rmdir {a1,a2,b1,b2} 2>/dev/null || true -} -cleanup - -function onerror { - if [ "$?" == "0" ]; then - cleanup - else - echo - echo "=============================================================" - echo "Error running aof test, here are more details (from aof.log):" - echo "=============================================================" - cat aof.log - fi - - kill $(jobs -p) 2> /dev/null || true - wait -} -trap onerror EXIT - -echo "Running benchmark to populate AOF..." -./tigerbeetle format --cluster=0 --replica=0 --replica-count=1 aof-test.tigerbeetle > aof.log 2>&1 -./tigerbeetle start --cache-grid=256MiB --addresses=3000 --aof --experimental aof-test.tigerbeetle >> aof.log 2>&1 & -./tigerbeetle benchmark --addresses=3000 --transfer-count=400000 >> aof.log 2>&1 -kill %1 - -echo "" -echo "Running 'zig build aof -- debug aof-test.tigerbeetle.aof' to check AOF..." -data_checksum_src=$(./zig/zig build aof -- debug aof-test.tigerbeetle.aof 2>&1 | tee -a aof.log | grep 'Data checksum chain:') -echo "${data_checksum_src}" - -mkdir a1 a2 b1 b2 - -echo '' -echo 'Testing recovery...' -./tigerbeetle format --cluster=0 --replica=0 --replica-count=2 a1/aof-test.tigerbeetle >> ./aof.log 2>&1 -./tigerbeetle start --aof-recovery --cache-grid=256MiB --addresses=3001,3002 --aof-file=a1/aof-test.tigerbeetle.aof --experimental a1/aof-test.tigerbeetle >> ./aof.log 2>&1 & -r1=$! -./tigerbeetle format --cluster=0 --replica=1 --replica-count=2 a2/aof-test.tigerbeetle >> ./aof.log 2>&1 -./tigerbeetle start --aof-recovery --cache-grid=256MiB --addresses=3001,3002 --aof --experimental a2/aof-test.tigerbeetle >> ./aof.log 2>&1 & -r2=$! - -sleep 1 -./zig/zig build aof -- recover --cluster=0 --addresses=3001,3002 aof-test.tigerbeetle.aof >> aof.log 2>&1 -sleep 10 # Give replicas time to settle. -kill $r1 $r2 - -echo "" -echo "Recovering a second time, to test determinism." - -./tigerbeetle format --cluster=0 --replica=0 --replica-count=2 b1/aof-test.tigerbeetle >> ./aof.log 2>&1 -./tigerbeetle start --aof-recovery --cache-grid=256MiB --addresses=3001,3002 --experimental b1/aof-test.tigerbeetle >> ./aof.log 2>&1 & -r1=$! -./tigerbeetle format --cluster=0 --replica=1 --replica-count=2 b2/aof-test.tigerbeetle >> ./aof.log 2>&1 -./tigerbeetle start --aof-recovery --cache-grid=256MiB --addresses=3001,3002 --experimental b2/aof-test.tigerbeetle >> ./aof.log 2>&1 & -r2=$! - -./zig/zig build aof -- recover --cluster=0 --addresses=3001,3002 aof-test.tigerbeetle.aof >> aof.log 2>&1 -sleep 10 # Give replicas time to settle. -kill $r1 $r2 - -echo "" -echo "Running 'zig build aof -- debug a{1,2}/aof-test.tigerbeetle.aof' to check recovered AOF..." -data_checksum_recovered_1=$(./zig/zig build aof -- debug a1/aof-test.tigerbeetle.aof 2>&1 | tee -a aof.log | grep 'Data checksum chain:') -echo "1: ${data_checksum_recovered_1}" -data_checksum_recovered_2=$(./zig/zig build aof -- debug a2/aof-test.tigerbeetle.aof 2>&1 | tee -a aof.log | grep 'Data checksum chain:') -echo "2: ${data_checksum_recovered_2}" - -if [ "${data_checksum_src}" != "${data_checksum_recovered_1}" ] || [ "${data_checksum_src}" != "${data_checksum_recovered_2}" ]; then - echo "Mismatch in data checksums!" - exit 1 -fi - -echo -echo 'Running "tigerbeetle inspect" to compare superblocks...' -superblock_a=$(./tigerbeetle inspect superblock ./a1/aof-test.tigerbeetle 2>/dev/null) -superblock_b=$(./tigerbeetle inspect superblock ./b1/aof-test.tigerbeetle 2>/dev/null) -if [ "$superblock_a" != "$superblock_b" ]; then - echo "Mismatch in recovery determinism." - exit 1 -fi - -echo -echo 'Success!' diff --git a/ocam/.github/workflows/ci.yml b/ocam/.github/workflows/ci.yml deleted file mode 100644 index d51e6fcb..00000000 --- a/ocam/.github/workflows/ci.yml +++ /dev/null @@ -1,228 +0,0 @@ -name: CI -permissions: {} - -concurrency: - group: core-${{ github.event.pull_request.number || github.ref }} - cancel-in-progress: ${{ github.ref != 'refs/heads/main' }} - -on: - merge_group: - pull_request: - push: - branches: ["main"] - -env: - GH_TOKEN: ${{ github.token }} - FORCE_JAVASCRIPT_ACTIONS_TO_NODE24: true # Remove once this is the default (June 2nd, 2026). - -jobs: - smoke: - runs-on: ubuntu-latest - steps: - - &checkout - uses: actions/checkout@de0fac2e4500dabe0009e67214ff5f5447ce83dd # v6.0.2 - with: { fetch-depth: 2147483647, fetch-tags: true } # Fetch history for "git tag" in build.zig. - - &cache - uses: actions/cache@27d5ce7f107fe9357f9df03efb73ab90386fccae # v5.0.5 - # actions/cache (as of v5.0.5) routinely flakes under windows -- it just prints - # "Cache hit for: Windows-X64-(hash)" and then exits with no other info. - continue-on-error: ${{ startsWith(runner.os, 'Windows') }} - with: - path: ./zig/cache - key: ${{ runner.os }}-${{ runner.arch }}-${{ hashFiles('./zig/download.sh') }} - - run: shellcheck ./zig/download.sh - - shell: pwsh - run: Invoke-ScriptAnalyzer -Path zig/download.win.ps1 -Severity Error,Warning,Information -EnableExit - - run: ./zig/download.ps1 && ./zig/zig build --summary all ci -- smoke - - test: - strategy: - matrix: - include: - - { os: 'ubuntu-latest' } - - { os: 'ubuntu-latest-arm64' } - - { os: 'windows-latest' } - - { os: 'macos-latest' } - - { os: 'macos-15-intel' } - runs-on: ${{ matrix.os }} - steps: - - run: git config --global core.autocrlf false - - if: matrix.os == 'ubuntu-latest' || matrix.os == 'ubuntu-latest-arm64' - run: | # Allow unshare for vortex. - sudo sysctl -w kernel.apparmor_restrict_unprivileged_unconfined=0 - sudo sysctl -w kernel.apparmor_restrict_unprivileged_userns=0 - - *checkout - - *cache - - &select_xcode - # TODO(Zig): Xcode >26.3 breaks linking with Zig 0.14.1. - # Pin to Xcode 26.3 when it's available. Remove once we upgrade Zig. - # See https://codeberg.org/ziglang/zig/issues/31658 - if: matrix.os == 'macos-latest' - run: | - if [ -d /Applications/Xcode_26.3.app ]; then - sudo xcode-select -s /Applications/Xcode_26.3.app - fi - xcodebuild -version - - run: ./zig/download.ps1 && ./zig/zig build --summary all ci -- test - - test_aof: - runs-on: ubuntu-latest - steps: - - *checkout - - *cache - - run: ./zig/download.ps1 && ./zig/zig build --summary all ci -- aof - - clients: - strategy: - matrix: - include: - - { os: 'ubuntu-latest', language: 'dotnet', language_version: '8.0.x' } - - { os: 'ubuntu-latest', language: 'go', language_version: '1.21' } - - { os: 'ubuntu-latest', language: 'rust', language_version: '1.71' } - - { os: 'ubuntu-latest', language: 'rust', language_version: 'stable' } - - { os: 'ubuntu-latest', language: 'java', language_version: '11' } - - { os: 'ubuntu-latest', language: 'java', language_version: '21' } - - { os: 'ubuntu-latest', language: 'node', language_version: '18.x' } - - { os: 'ubuntu-latest', language: 'node', language_version: '24.x' } - - { os: 'ubuntu-latest', language: 'ruby', language_version: '3.3' } - - { os: 'ubuntu-latest', language: 'ruby', language_version: '4.0' } - - # Support Python 3.7 explicitly, even though it's EOL. - - { os: 'ubuntu-22.04', language: 'python', language_version: '3.7' } - - { os: 'ubuntu-latest', language: 'python', language_version: '3.13' } - - - { os: 'windows-latest', language: 'dotnet', language_version: '8.0.x' } - - { os: 'windows-latest', language: 'go', language_version: '1.21' } - - { os: 'windows-latest', language: 'rust', language_version: '1.71' } - - { os: 'windows-latest', language: 'rust', language_version: 'stable' } - - { os: 'windows-latest', language: 'java', language_version: '11' } - - { os: 'windows-latest', language: 'java', language_version: '21' } - - { os: 'windows-latest', language: 'node', language_version: '18.x' } - - { os: 'windows-latest', language: 'node', language_version: '20.x' } - - { os: 'windows-latest', language: 'python', language_version: '3.7' } - - { os: 'windows-latest', language: 'python', language_version: '3.13' } - - { os: 'windows-latest', language: 'ruby', language_version: '3.3' } - - { os: 'windows-latest', language: 'ruby', language_version: '4.0' } - - # Limited matrix for macOS - runners are concurrency limited. - - { os: 'macos-latest', language: 'go', language_version: '1.21' } - - { os: 'macos-latest', language: 'node', language_version: '20.x' } - - { os: 'macos-latest', language: 'python', language_version: '3.13' } - - { os: 'macos-latest', language: 'ruby', language_version: '4.0' } - - - { os: 'macos-15-intel', language: 'go', language_version: '1.21' } - - { os: 'macos-15-intel', language: 'node', language_version: '20.x' } - - { os: 'macos-15-intel', language: 'python', language_version: '3.13' } - - { os: 'macos-15-intel', language: 'ruby', language_version: '4.0' } - - # Limited matrix for Ubuntu ARM - runners are paid and we're not sure of the cost yet. - - { os: 'ubuntu-latest-arm64', language: 'dotnet', language_version: '8.0.x' } - - { os: 'ubuntu-latest-arm64', language: 'go', language_version: '1.21' } - - { os: 'ubuntu-latest-arm64', language: 'java', language_version: '21' } - - { os: 'ubuntu-latest-arm64', language: 'node', language_version: '20.x' } - - { os: 'ubuntu-latest-arm64', language: 'python', language_version: '3.13' } - - { os: 'ubuntu-latest-arm64', language: 'ruby', language_version: '4.0' } - - runs-on: ${{ matrix.os }} - steps: - - run: git config --global core.autocrlf false - - *checkout - - *cache - - if: matrix.os == 'ubuntu-latest' || matrix.os == 'ubuntu-latest-arm64' - run: | # Allow unshare for vortex. - sudo sysctl -w kernel.apparmor_restrict_unprivileged_unconfined=0 - sudo sysctl -w kernel.apparmor_restrict_unprivileged_userns=0 - - *select_xcode - - if: matrix.language == 'dotnet' - uses: actions/setup-dotnet@c2fa09f4bde5ebb9d1777cf28262a3eb3db3ced7 # v5.2.0 - with: { dotnet-version: "${{ matrix.language_version }}" } - - - if: matrix.language == 'go' - uses: actions/setup-go@4a3601121dd01d1626a1e23e37211e3254c1c06c # v6.4.0 - with: { go-version: "${{ matrix.language_version }}" } - - - if: matrix.language == 'rust' - run: rustup default ${{ matrix.language_version }} && rustup component add clippy rustfmt - - - if: matrix.language == 'java' - uses: actions/setup-java@be666c2fcd27ec809703dec50e508c2fdc7f6654 # v5.2.0 - with: { java-version: "${{ matrix.language_version }}", distribution: 'temurin'} - - - if: matrix.language == 'java' - uses: actions/cache@27d5ce7f107fe9357f9df03efb73ab90386fccae # v5.0.5 - # actions/cache (as of v5.0.5) routinely flakes under windows -- it just prints - # "Cache hit for: Windows-X64-(hash)" and then exits with no other info. - continue-on-error: ${{ startsWith(runner.os, 'Windows') }} - with: - path: ~/.m2/repository - key: setup-java-${{ runner.os }}-${{ runner.arch }}-maven-${{ hashFiles('**/pom.xml') }} - - - if: matrix.language == 'node' - uses: actions/setup-node@48b55a011bda9f5d6aeb4c2d9c7362e8dae4041e # v6.4.0 - with: { node-version: "${{ matrix.language_version }}" } - - - if: matrix.language == 'python' - uses: actions/setup-python@a309ff8b426b58ec0e2a45f0f869d46889d02405 # v6.2.0 - with: { python-version: "${{ matrix.language_version }}" } - - if: matrix.language == 'python' - run: pip install pytest 'mypy<=1.18.2' - - - if: matrix.language == 'ruby' - uses: ruby/setup-ruby@97ecb7b512899eb71ab1bf2310a624c6f1589ac6 # v1.308.0 - with: { ruby-version: "${{ matrix.language_version }}" } - - - run: ./zig/download.ps1 && ./zig/zig build --summary all ci -- ${{ matrix.language }} - - devhub: - runs-on: ubuntu-22.04 - environment: ${{ github.ref == 'refs/heads/main' && 'devhub' || '' }} - permissions: - pages: write - id-token: write - - steps: - - *checkout - - *cache - - run: sudo apt-get update && sudo apt-get install -y kcov - - run: sudo rm -rf /usr/local/lib/android # Free up disk space for benchmarking. - - run: ./zig/download.ps1 - - # Dummy devhub run - checks that all the devhub tests pass in CI. They are run again, in main - # once merged. Kcov is skipped to avoid adding to the pipeline time. - - if: github.ref != 'refs/heads/main' - run: sudo -E ./zig/zig build --summary all ci -- devhub-dry-run - env: - GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - # Not providing DEVHUBDB_PAT and NYRKIO_TOKEN stops devhub from uploading its results, but - # it still runs everything. - - # Run under sudo to enable memory locking for accurate RSS stats. - - if: github.ref == 'refs/heads/main' - run: sudo -E ./zig/zig build --summary all ci -- devhub - env: - DEVHUBDB_PAT: ${{ secrets.DEVHUBDB_PAT }} - NYRKIO_TOKEN: ${{ secrets.NYRKIO_TOKEN }} - GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - - - if: github.ref == 'refs/heads/main' - uses: actions/upload-pages-artifact@fc324d3547104276b827a68afc52ff2a11cc49c9 # v5.0.0 - with: { path: ./src/devhub } - - - if: github.ref == 'refs/heads/main' - uses: actions/deploy-pages@cd2ce8fcbc39b97be8ca5fce6e763baed58fa128 # v5.0.0 - - - # Work around GitHub considering Skipped jobs success for "Require status checks before merging" - # See also: - # https://docs.github.com/en/repositories/configuring-branches-and-merges-in-your-repository/managing-protected-branches/about-protected-branches#require-status-checks-before-merging - # https://docs.github.com/en/pull-requests/collaborating-with-pull-requests/collaborating-on-repositories-with-code-quality-features/troubleshooting-required-status-checks#handling-skipped-but-required-checks - # https://stackoverflow.com/a/75250293 - core-pipeline: - if: always() && github.event_name == 'merge_group' - runs-on: ubuntu-latest - needs: [smoke, test, test_aof, clients, devhub] - steps: - - if: ${{ !(contains(needs.*.result, 'failure') || contains(needs.*.result, 'cancelled')) }} - run: exit 0 - - if: ${{ (contains(needs.*.result, 'failure') || contains(needs.*.result, 'cancelled')) }} - run: exit 1 diff --git a/ocam/.github/workflows/release.yml b/ocam/.github/workflows/release.yml deleted file mode 100644 index 5466e018..00000000 --- a/ocam/.github/workflows/release.yml +++ /dev/null @@ -1,96 +0,0 @@ -name: Release -permissions: {} - -on: - workflow_dispatch: - -# Don't run release and release_validate simultaneously, to avoid races. -concurrency: - group: release - cancel-in-progress: false - -jobs: - release: - runs-on: ubuntu-latest - environment: release - permissions: - packages: write - contents: write - # Required for OIDC. - # See: https://docs.npmjs.com/trusted-publishers - id-token: write - - steps: - - uses: actions/checkout@de0fac2e4500dabe0009e67214ff5f5447ce83dd # v6.0.2 - with: - fetch-depth: 2147483647 - fetch-tags: true # Fetch full history for tidy. - ref: release # Use the 'release' branch even if triggered manually - - - uses: actions/setup-dotnet@c2fa09f4bde5ebb9d1777cf28262a3eb3db3ced7 # v5.2.0 - with: - dotnet-version: - 8.0.x - - - uses: actions/setup-go@4a3601121dd01d1626a1e23e37211e3254c1c06c # v6.4.0 - with: - go-version: '1.21' - - - uses: actions/setup-java@be666c2fcd27ec809703dec50e508c2fdc7f6654 # v5.2.0 - with: - java-version: '11' - distribution: 'temurin' - server-id: central - server-username: MAVEN_USERNAME - server-password: MAVEN_CENTRAL_TOKEN - gpg-private-key: ${{ secrets.MAVEN_GPG_SECRET_KEY }} - gpg-passphrase: MAVEN_GPG_PASSPHRASE - - # No special setup for Go. - - # Rust: publish with the oldest supported release to ensure compatible lockfiles etc. - - run: rustup default 1.63 && rustup component add clippy rustfmt - - - uses: actions/setup-node@48b55a011bda9f5d6aeb4c2d9c7362e8dae4041e # v6.4.0 - with: - node-version: '24.x' - registry-url: 'https://registry.npmjs.org' - - - uses: actions/setup-python@a309ff8b426b58ec0e2a45f0f869d46889d02405 # v6.2.0 - with: - python-version: 3.13 - - run: pip install twine - - - uses: ruby/setup-ruby@97ecb7b512899eb71ab1bf2310a624c6f1589ac6 # v1.308.0 - with: - ruby-version: '4.0' - - - uses: actions/cache@27d5ce7f107fe9357f9df03efb73ab90386fccae # v5.0.5 - with: - path: ./zig/cache - key: ${{ runner.os }}-${{ runner.arch }}-${{ hashFiles('./zig/download.sh') }} - - run: ./zig/download.sh - - run: ./zig/zig build --summary all scripts -- release --build --publish --sha=${{ github.sha }} - env: - NUGET_KEY: ${{ secrets.NUGET_KEY }} - TIGERBEETLE_GO_PAT: ${{ secrets.TIGERBEETLE_GO_PAT }} - TIGERBEETLE_DOCS_PAT: ${{ secrets.TIGERBEETLE_DOCS_PAT }} - MAVEN_USERNAME: ${{ secrets.MAVEN_CENTRAL_USERNAME }} - MAVEN_CENTRAL_TOKEN: ${{ secrets.MAVEN_CENTRAL_TOKEN }} - MAVEN_GPG_PASSPHRASE: ${{ secrets.MAVEN_GPG_SECRET_KEY_PASSWORD }} - TWINE_USERNAME: ${{ secrets.TWINE_USERNAME }} - TWINE_PASSWORD: ${{ secrets.TWINE_PASSWORD }} - CRATES_IO_TOKEN: ${{ secrets.CRATES_IO_TOKEN }} - ACTIONS_ID_TOKEN_REQUEST_TOKEN: ${{ env.ACTIONS_ID_TOKEN_REQUEST_TOKEN }} - ACTIONS_ID_TOKEN_REQUEST_URL: ${{ env.ACTIONS_ID_TOKEN_REQUEST_URL }} - GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - - alert_failure: - runs-on: ubuntu-latest - needs: [release] - if: ${{ always() && contains(needs.*.result, 'failure') }} - steps: - - name: Alert if anything failed - run: | - export URL="${{ github.server_url }}/${{ github.repository }}/actions/runs/${{ github.run_id }}" && \ - curl -d "text=Release process for ${{ github.run_number }} failed! See ${URL} for more information." -d "channel=C04RWHT9EP5" -H "Authorization: Bearer ${{ secrets.SLACK_TOKEN }}" -X POST https://slack.com/api/chat.postMessage diff --git a/ocam/.github/workflows/release_validate.yml b/ocam/.github/workflows/release_validate.yml deleted file mode 100644 index 814e2cb8..00000000 --- a/ocam/.github/workflows/release_validate.yml +++ /dev/null @@ -1,72 +0,0 @@ -name: "Release (validate)" -permissions: {} - -on: - workflow_dispatch: # Manual triggering for debugging - workflow_run: - workflows: ["Release"] - types: - - completed - - schedule: - # Schedule a validation run every six hours to make sure we catch any bugs due to changes - # in systems we do not control. - - cron: 0 */6 * * * - -# Don't run release and release_validate simultaneously, to avoid races. -concurrency: - group: release - cancel-in-progress: false - -env: - FORCE_JAVASCRIPT_ACTIONS_TO_NODE24: true # Remove once this is the default (June 2nd, 2026). - -jobs: - validate: - runs-on: ubuntu-latest - if: ${{ !(github.event_name == 'workflow_run' && github.event.workflow_run.conclusion == 'failure') }} - steps: - - uses: actions/checkout@de0fac2e4500dabe0009e67214ff5f5447ce83dd # v6.0.2 - with: - fetch-depth: 2147483647 - fetch-tags: true # Fetch full history for tidy. - ref: main - - - uses: actions/cache@27d5ce7f107fe9357f9df03efb73ab90386fccae # v5.0.5 - with: - path: ./zig/cache - key: ${{ runner.os }}-${{ runner.arch }}-${{ hashFiles('./zig/download.sh') }} - - run: ./zig/download.sh - - - uses: actions/setup-dotnet@c2fa09f4bde5ebb9d1777cf28262a3eb3db3ced7 # v5.2.0 - with: - dotnet-version: - 8.0.x - - - uses: actions/setup-go@4a3601121dd01d1626a1e23e37211e3254c1c06c # v6.4.0 - with: - go-version: 'stable' - - - uses: actions/setup-java@be666c2fcd27ec809703dec50e508c2fdc7f6654 # v5.2.0 - with: - distribution: 'temurin' - java-version: '21' - - - uses: actions/setup-node@48b55a011bda9f5d6aeb4c2d9c7362e8dae4041e # v6.4.0 - with: - node-version: 'latest' - - - run: ./zig/zig build scripts -- ci --validate-release - env: - GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - - - alert_failure: - runs-on: ubuntu-latest - needs: [validate] - if: ${{ always() && contains(needs.*.result, 'failure') }} - steps: - - name: Alert if anything failed - run: | - export URL="${{ github.server_url }}/${{ github.repository }}/actions/runs/${{ github.run_id }}" && \ - curl -d "text=Release validation failed! See ${URL} for more information." -d "channel=C04RWHT9EP5" -H "Authorization: Bearer ${{ secrets.SLACK_TOKEN }}" -X POST https://slack.com/api/chat.postMessage diff --git a/ocam/OCAML_REWRITE.md b/ocam/OCAML_REWRITE.md index a0e0f67e..402e4c29 100644 --- a/ocam/OCAML_REWRITE.md +++ b/ocam/OCAML_REWRITE.md @@ -15,10 +15,11 @@ opam exec -- dune runtest opam exec -- dune build @bench ``` -The benchmark reports operations/second, per-batch latency, total allocated -words, and allocated words per operation. It uses 30,000 prebuilt successful -posted transfers in batches of 30 so that request construction is outside the -timed path. Run it with `opam exec -- dune exec bench/state_machine_bench.exe`. +The benchmark reports operations/second and allocated words per operation for +several prebuilt workloads (posted transfers, pending/post/void, successful and +failing linked chains, indexed queries over a populated ledger, and pending +expiry) in batches of 30, so that request construction is outside the timed +path. Run it with `opam exec -- dune exec bench/state_machine_bench.exe`. The native TigerBeetle baseline is currently blocked by its standalone fixture's commit sequencing, so this directory does not claim a paired performance result. See [`../BENCHMARK_COMPARISON.md`](../BENCHMARK_COMPARISON.md) for the exact @@ -35,7 +36,10 @@ Current scenarios cover validation precedence, account creation, single-phase and pending transfers, posting, voiding, balance changes, lookups, queries, and linked rollback. The Dune suite also runs deterministic QCheck properties for execution, conservation, idempotency, linked atomicity, pending resolution, -lookup/query ordering, and public U128 boundaries. Full differential -equivalence still requires the entire Zig test corpus, exact numeric result-code -encoding, CDC objects, additional imported edge cases, query validation, expiry +lookup/query ordering, and public U128 boundaries; `u128_test` and +`result_code_test` cover the arithmetic and the numeric status codes. Numeric +result codes follow the pinned `CreateAccountResult`/`CreateTransferResult` +enums, except that a few OCaml statuses are coarser than upstream and stand +for several codes (see `src/result_code.mli`). Full differential equivalence +still requires the entire Zig test corpus, CDC objects, additional imported edge cases, query validation, expiry batching, and deprecated operations. diff --git a/ocam/bench/dune b/ocam/bench/dune index 57877543..4a9434d3 100644 --- a/ocam/bench/dune +++ b/ocam/bench/dune @@ -4,4 +4,5 @@ (rule (alias bench) - (action (run ./state_machine_bench.exe))) + (action + (run ./state_machine_bench.exe))) diff --git a/ocam/bench/state_machine_bench.ml b/ocam/bench/state_machine_bench.ml index 6a5b5554..c77475fb 100644 --- a/ocam/bench/state_machine_bench.ml +++ b/ocam/bench/state_machine_bench.ml @@ -2,7 +2,7 @@ open Tigerbeetle_state_machine.State_machine let u128 = U128.of_int -let account id = +let account ?(history = false) id = { id = u128 id ; debits_pending = U128.zero ; debits_posted = U128.zero @@ -17,7 +17,7 @@ let account id = { linked = false ; debits_must_not_exceed_credits = false ; credits_must_not_exceed_debits = false - ; history = false + ; history ; imported = false ; closed = false } @@ -25,11 +25,17 @@ let account id = } ;; -let flags = - { linked = false - ; pending = false - ; post_pending_transfer = false - ; void_pending_transfer = false +let flags + ?(linked = false) + ?(pending = false) + ?(post_pending_transfer = false) + ?(void_pending_transfer = false) + () + = + { linked + ; pending + ; post_pending_transfer + ; void_pending_transfer ; balancing_debit = false ; balancing_credit = false ; closing_debit = false @@ -38,16 +44,23 @@ let flags = } ;; -let transfer id = +let transfer + ?(flags = flags ()) + ?(pending_id = U128.zero) + ?(timeout = 0l) + ?(debit = 1) + ?(credit = 2) + id + = { id = u128 id - ; debit_account_id = u128 1 - ; credit_account_id = u128 2 + ; debit_account_id = u128 debit + ; credit_account_id = u128 credit ; amount = u128 1 - ; pending_id = U128.zero + ; pending_id ; user_data_128 = U128.zero ; user_data_64 = 0L ; user_data_32 = 0l - ; timeout = 0l + ; timeout ; ledger = 1l ; code = 1 ; flags @@ -55,32 +68,42 @@ let transfer id = } ;; -let () = - let operations = 30_000 in - let batch_size = 30 in - let sanity_state = empty () in - ignore (create_accounts sanity_state ~timestamp:1L [ account 1; account 2 ]); - (match create_transfers sanity_state ~timestamp:3L [ transfer 10 ] with - | [ { status = Transfer_created; _ } ] -> () - | _ -> failwith "benchmark workload sanity check failed"); - let state = empty () in - ignore (create_accounts state ~timestamp:1L [ account 1; account 2 ]); - let batches = - Array.init (operations / batch_size) (fun batch -> - let first_id = (batch * batch_size) + 10 in - List.init batch_size (fun offset -> transfer (first_id + offset))) - in +let operations = 30_000 +let batch_size = 30 +let account_count = 100 + +let accounts_setup ?history state = + ignore + (create_accounts + state + ~timestamp:1L + (List.init account_count (fun i -> account ?history (i + 1)))) +;; + +let batches make = + Array.init (operations / batch_size) (fun batch -> + let first_id = (batch * batch_size) + 10 in + List.init batch_size (fun offset -> make (first_id + offset))) +;; + +let run_batches state ~first_timestamp requests f = + Array.iteri + (fun batch requests -> + f + state + ~timestamp:(Int64.add first_timestamp (Int64.of_int (batch * batch_size))) + requests) + requests +;; + +let spread id = (id mod account_count) + 1, ((id + 1) mod account_count) + 1 + +let measure name ~setup ~run = + let state = setup () in Gc.full_major (); let gc_before = Gc.quick_stat () in let started = Unix.gettimeofday () in - Array.iteri - (fun batch requests -> - ignore - (create_transfers - state - ~timestamp:(Int64.of_int ((batch * batch_size) + 3)) - requests)) - batches; + let count = run state in let elapsed = Unix.gettimeofday () -. started in let gc_after = Gc.quick_stat () in let allocated_words = @@ -89,15 +112,230 @@ let () = -. gc_before.minor_words -. gc_before.major_words in - Printf.printf "implementation=ocaml\n"; - Printf.printf "operations=%d\n" operations; - Printf.printf "batch_size=%d\n" batch_size; - Printf.printf "operations_per_second=%.0f\n" (float operations /. elapsed); - Printf.printf - "batch_latency_ms=%.3f\n" - (elapsed *. 1_000. /. float (operations / batch_size)); - Printf.printf "allocated_words=%.0f\n" allocated_words; - Printf.printf - "allocated_words_per_operation=%.2f\n" - (allocated_words /. float operations) + Printf.printf "workload=%s\n" name; + Printf.printf "operations=%d\n" count; + Printf.printf "operations_per_second=%.0f\n" (float count /. elapsed); + Printf.printf "allocated_words_per_operation=%.2f\n" (allocated_words /. float count); + print_newline () +;; + +let expect_created results context = + List.iter + (fun result -> + if result.status <> Transfer_created + then failwith (Printf.sprintf "%s: unexpected status" context)) + results +;; + +let posted_transfers () = + measure + "posted_transfers" + ~setup:(fun () -> + let state = empty () in + accounts_setup state; + state) + ~run:(fun state -> + let requests = + batches (fun id -> + let debit, credit = spread id in + transfer ~debit ~credit id) + in + run_batches state ~first_timestamp:1_000L requests (fun state ~timestamp requests -> + expect_created (create_transfers state ~timestamp requests) "posted"); + operations) +;; + +let two_phase () = + measure + "pending_then_post_or_void" + ~setup:(fun () -> + let state = empty () in + accounts_setup state; + state) + ~run:(fun state -> + let pending = + batches (fun id -> + let debit, credit = spread id in + transfer ~debit ~credit ~flags:(flags ~pending:true ()) id) + in + run_batches state ~first_timestamp:1_000L pending (fun state ~timestamp requests -> + expect_created (create_transfers state ~timestamp requests) "pending"); + let resolve = + batches (fun id -> + let pending_id = u128 id in + let debit, credit = spread id in + if id mod 2 = 0 + then + transfer + ~debit + ~credit + ~pending_id + ~flags:(flags ~post_pending_transfer:true ()) + (id + operations) + else + transfer + ~debit + ~credit + ~pending_id + ~flags:(flags ~void_pending_transfer:true ()) + (id + operations)) + in + run_batches + state + ~first_timestamp:100_000L + resolve + (fun state ~timestamp requests -> + expect_created (create_transfers state ~timestamp requests) "resolve"); + 2 * operations) +;; + +let linked_chains () = + measure + "linked_chains" + ~setup:(fun () -> + let state = empty () in + accounts_setup state; + ignore + (create_transfers + state + ~timestamp:500L + (List.init 1_000 (fun i -> transfer ~debit:1 ~credit:2 (1_000_000 + i)))); + state) + ~run:(fun state -> + let requests = + batches (fun id -> + let debit, credit = spread id in + let linked = id mod batch_size <> 9 in + transfer ~debit ~credit ~flags:(flags ~linked ()) id) + in + run_batches + state + ~first_timestamp:100_000L + requests + (fun state ~timestamp requests -> + expect_created (create_transfers state ~timestamp requests) "linked"); + operations) +;; + +let failing_linked_chains () = + measure + "failing_linked_chains" + ~setup:(fun () -> + let state = empty () in + accounts_setup state; + ignore + (create_transfers + state + ~timestamp:500L + (List.init 1_000 (fun i -> transfer ~debit:1 ~credit:2 (1_000_000 + i)))); + state) + ~run:(fun state -> + let requests = + batches (fun id -> + let debit, credit = spread id in + let last = id mod batch_size = 9 in + if last + then transfer ~debit ~credit:debit id + else transfer ~debit ~credit ~flags:(flags ~linked:true ()) id) + in + run_batches + state + ~first_timestamp:100_000L + requests + (fun state ~timestamp requests -> + let results = create_transfers state ~timestamp requests in + if List.exists (fun result -> result.status = Transfer_created) results + then failwith "failing chain unexpectedly succeeded"); + operations) +;; + +let queries () = + let filter = + { user_data_128 = U128.zero + ; user_data_64 = 0L + ; user_data_32 = 0l + ; ledger = 1l + ; code = 1 + ; timestamp_min = 0L + ; timestamp_max = 0L + ; limit = 100 + ; reversed = false + } + in + let account_filter = + { account_id = u128 1 + ; user_data_128 = U128.zero + ; user_data_64 = 0L + ; user_data_32 = 0l + ; code = 0 + ; timestamp_min = 0L + ; timestamp_max = 0L + ; limit = 100 + ; debits = true + ; credits = true + ; reversed = true + } + in + measure + "queries_over_populated_ledger" + ~setup:(fun () -> + let state = empty () in + accounts_setup ~history:true state; + let requests = + batches (fun id -> + let debit, credit = spread id in + transfer ~debit ~credit id) + in + run_batches state ~first_timestamp:1_000L requests (fun state ~timestamp requests -> + expect_created (create_transfers state ~timestamp requests) "populate"); + state) + ~run:(fun state -> + let iterations = 2_000 in + for i = 1 to iterations do + let timestamp_min = Int64.of_int (1_000 + (i * 10)) in + let window = + { filter with timestamp_min; timestamp_max = Int64.add timestamp_min 5_000L } + in + ignore (query_transfers state window); + ignore (query_accounts state { window with limit = 10; ledger = 1l }); + ignore (get_account_transfers state account_filter); + ignore (get_account_balances state { account_filter with limit = 10 }) + done; + 4 * iterations) +;; + +let expiry () = + measure + "pending_expiry" + ~setup:(fun () -> + let state = empty () in + accounts_setup state; + let requests = + batches (fun id -> + let debit, credit = spread id in + transfer ~debit ~credit ~timeout:1l ~flags:(flags ~pending:true ()) id) + in + run_batches state ~first_timestamp:1_000L requests (fun state ~timestamp requests -> + expect_created (create_transfers state ~timestamp requests) "pending"); + state) + ~run:(fun state -> + let step = 2_000_000_000L in + let expired = ref 0 in + for i = 1 to 60 do + expired + := !expired + + expire_pending_transfers state ~timestamp:(Int64.mul step (Int64.of_int i)) + done; + if !expired <> operations then failwith "expiry count mismatch"; + operations) +;; + +let () = + Printf.printf "implementation=ocaml\nbatch_size=%d\n\n" batch_size; + posted_transfers (); + two_phase (); + linked_chains (); + failing_linked_chains (); + queries (); + expiry () ;; diff --git a/ocam/dune-project b/ocam/dune-project index e6f7bcd1..0de4b9a6 100644 --- a/ocam/dune-project +++ b/ocam/dune-project @@ -1,12 +1,23 @@ (lang dune 3.11) + (name tigerbeetle_ocaml) + (generate_opam_files true) +(license Apache-2.0) + +(maintainers "gpu004") + +(authors "gpu004") + +(source + (github gpu004/6666)) + (package (name tigerbeetle_ocaml) (synopsis "OCaml ledger state machine for the pinned TigerBeetle source tree") (depends - (ocaml (>= 5.2)) + (ocaml + (>= 5.2)) oxcaml - base (qcheck :with-test))) diff --git a/ocam/src/dune b/ocam/src/dune index 428b5e42..e234f5a0 100644 --- a/ocam/src/dune +++ b/ocam/src/dune @@ -1,7 +1,5 @@ (library (name tigerbeetle_state_machine) (public_name tigerbeetle_ocaml.state_machine) - (modules state_machine) (instrumentation - (backend bisect_ppx)) - (libraries base)) + (backend bisect_ppx))) diff --git a/ocam/src/ledger.ml b/ocam/src/ledger.ml new file mode 100644 index 00000000..9f8aa70b --- /dev/null +++ b/ocam/src/ledger.ml @@ -0,0 +1,217 @@ +open Types + +module Id_table = Hashtbl.Make (struct + type t = U128.t + + let equal = U128.equal + let hash = U128.hash + end) + +module Timestamp_map = Map.Make (Int64) + +type history_entry = + { snapshot : account + ; transfer : transfer + } + +type t = + { accounts : account Id_table.t + ; transfers : transfer Id_table.t + ; pending : pending_status Id_table.t + ; failed_transfers : unit Id_table.t + ; account_transfers : transfer Timeline.t Id_table.t + ; account_history : history_entry Timeline.t Id_table.t + ; accounts_by_timestamp : U128.t Timeline.t + ; transfers_by_timestamp : transfer Timeline.t + ; mutable pending_by_expiry : U128.t list Timestamp_map.t + ; mutable commit_timestamp : int64 + ; mutable journal : (unit -> unit) list option + } + +let empty () = + { accounts = Id_table.create 1024 + ; transfers = Id_table.create 1024 + ; pending = Id_table.create 256 + ; failed_transfers = Id_table.create 256 + ; account_transfers = Id_table.create 1024 + ; account_history = Id_table.create 1024 + ; accounts_by_timestamp = Timeline.create () + ; transfers_by_timestamp = Timeline.create () + ; pending_by_expiry = Timestamp_map.empty + ; commit_timestamp = 0L + ; journal = None + } +;; + +let commit_timestamp state = state.commit_timestamp + +(* Journal *) + +let record state undo = + match state.journal with + | None -> () + | Some undos -> state.journal <- Some (undo :: undos) +;; + +let table_replace state table key value = + (match state.journal with + | None -> () + | Some _ -> + (match Id_table.find_opt table key with + | None -> record state (fun () -> Id_table.remove table key) + | Some previous -> record state (fun () -> Id_table.replace table key previous))); + Id_table.replace table key value +;; + +let table_remove state table key = + (match state.journal, Id_table.find_opt table key with + | None, _ | Some _, None -> () + | Some _, Some previous -> record state (fun () -> Id_table.replace table key previous)); + Id_table.remove table key +;; + +let set_commit_timestamp state timestamp = + let previous = state.commit_timestamp in + record state (fun () -> state.commit_timestamp <- previous); + state.commit_timestamp <- timestamp +;; + +let timeline_append state timeline timestamp value = + (match state.journal with + | None -> () + | Some _ -> + let previous = Timeline.length timeline in + record state (fun () -> Timeline.truncate timeline previous)); + Timeline.append timeline timestamp value +;; + +let account_timeline state table id = + match Id_table.find_opt table id with + | Some timeline -> timeline + | None -> + let timeline = Timeline.create () in + table_replace state table id timeline; + timeline +;; + +let set_pending_by_expiry state index = + let previous = state.pending_by_expiry in + record state (fun () -> state.pending_by_expiry <- previous); + state.pending_by_expiry <- index +;; + +let transact state f = + assert (Option.is_none state.journal); + state.journal <- Some []; + let finish () = + let undos = Option.value state.journal ~default:[] in + state.journal <- None; + fun () -> List.iter (fun undo -> undo ()) undos + in + match f () with + | result -> + let rollback = finish () in + result, rollback + | exception exn -> + let rollback = finish () in + rollback (); + raise exn +;; + +(* Reads *) + +let find_account state id = Id_table.find_opt state.accounts id +let find_transfer state id = Id_table.find_opt state.transfers id +let find_pending state id = Id_table.find_opt state.pending id +let transfer_failed state id = Id_table.mem state.failed_transfers id + +let account_transfers state id = + match Id_table.find_opt state.account_transfers id with + | Some timeline -> timeline + | None -> Timeline.create () +;; + +let account_history state id = + match Id_table.find_opt state.account_history id with + | Some timeline -> timeline + | None -> Timeline.create () +;; + +(* Writes *) + +let add_account state (account : account) = + table_replace state state.accounts account.id account; + timeline_append state state.accounts_by_timestamp account.timestamp account.id; + set_commit_timestamp state account.timestamp +;; + +let update_account state (account : account) = + table_replace state state.accounts account.id account +;; + +let index_account_transfer state account_id (transfer : transfer) = + timeline_append + state + (account_timeline state state.account_transfers account_id) + transfer.timestamp + transfer +;; + +let add_transfer state (transfer : transfer) = + table_replace state state.transfers transfer.id transfer; + timeline_append state state.transfers_by_timestamp transfer.timestamp transfer; + index_account_transfer state transfer.debit_account_id transfer; + index_account_transfer state transfer.credit_account_id transfer; + set_commit_timestamp state transfer.timestamp +;; + +let add_expiry state ~expires_at id = + let ids = + Option.value (Timestamp_map.find_opt expires_at state.pending_by_expiry) ~default:[] + in + set_pending_by_expiry + state + (Timestamp_map.add expires_at (id :: ids) state.pending_by_expiry) +;; + +let remove_expiry state ~expires_at id = + match Timestamp_map.find_opt expires_at state.pending_by_expiry with + | None -> () + | Some ids -> + let remaining = List.filter (fun other -> not (U128.equal other id)) ids in + set_pending_by_expiry + state + (if remaining = [] + then Timestamp_map.remove expires_at state.pending_by_expiry + else Timestamp_map.add expires_at remaining state.pending_by_expiry) +;; + +let set_pending state id status = table_replace state state.pending id status +let mark_failed state id = table_replace state state.failed_transfers id () + +let add_history state (snapshot : account) transfer = + timeline_append + state + (account_timeline state state.account_history snapshot.id) + snapshot.timestamp + { snapshot; transfer } +;; + +(* Ordered iteration *) + +let to_seq_in_range = Timeline.to_seq_in_range + +let expired_before state timestamp = + let due, at, _ = Timestamp_map.split timestamp state.pending_by_expiry in + let due = + match at with + | Some ids -> Timestamp_map.add timestamp ids due + | None -> due + in + Timestamp_map.fold + (fun expires_at ids acc -> + List.fold_left (fun acc id -> (expires_at, id) :: acc) acc ids) + due + [] + |> List.rev +;; diff --git a/ocam/src/result_code.ml b/ocam/src/result_code.ml new file mode 100644 index 00000000..c1d13579 --- /dev/null +++ b/ocam/src/result_code.ml @@ -0,0 +1,137 @@ +open Types + +let created_code = 0xffff_ffff + +type 'status mapping = + | Exact of 'status * int + | Coarse of 'status * int list + +let account_mappings : create_account_status mapping list = + [ Exact (Account_created, created_code) + ; Exact (Account_linked_event_failed, 1) + ; Exact (Account_linked_event_chain_open, 2) + ; Exact (Account_timestamp_must_be_zero, 3) + ; Exact (Account_id_must_not_be_zero, 6) + ; Exact (Account_id_must_not_be_int_max, 7) + ; Exact (Account_flags_are_mutually_exclusive, 8) + ; Exact (Account_debits_pending_must_be_zero, 9) + ; Exact (Account_debits_posted_must_be_zero, 10) + ; Exact (Account_credits_pending_must_be_zero, 11) + ; Exact (Account_credits_posted_must_be_zero, 12) + ; Exact (Account_ledger_must_not_be_zero, 13) + ; Exact (Account_code_must_not_be_zero, 14) + ; Exact (Account_exists_with_different_flags, 15) + ; Exact (Account_exists_with_different_user_data_128, 16) + ; Exact (Account_exists_with_different_user_data_64, 17) + ; Exact (Account_exists_with_different_user_data_32, 18) + ; Exact (Account_exists_with_different_ledger, 19) + ; Exact (Account_exists_with_different_code, 20) + ; Exact (Account_exists, 21) + ; Exact (Account_imported_event_expected, 22) + ; Exact (Account_imported_event_not_expected, 23) + ; Exact (Account_imported_timestamp_out_of_range, 24) + ; Exact (Account_imported_timestamp_must_not_advance, 25) + ; Exact (Account_imported_timestamp_must_not_regress, 26) + ] +;; + +let transfer_mappings : create_transfer_status mapping list = + [ Exact (Transfer_created, created_code) + ; Exact (Transfer_linked_event_failed, 1) + ; Exact (Transfer_linked_event_chain_open, 2) + ; Exact (Transfer_timestamp_must_be_zero, 3) + ; Exact (Transfer_id_must_not_be_zero, 5) + ; Exact (Transfer_id_must_not_be_int_max, 6) + ; Exact (Transfer_flags_are_mutually_exclusive, 7) + ; Exact (Transfer_debit_account_id_must_not_be_zero, 8) + ; Exact (Transfer_debit_account_id_must_not_be_int_max, 9) + ; Exact (Transfer_credit_account_id_must_not_be_zero, 10) + ; Exact (Transfer_credit_account_id_must_not_be_int_max, 11) + ; Exact (Transfer_accounts_must_be_different, 12) + ; Exact (Transfer_pending_id_must_be_zero, 13) + ; Exact (Transfer_pending_id_must_not_be_zero, 14) + ; Exact (Transfer_pending_id_must_not_be_int_max, 15) + ; Exact (Transfer_pending_id_must_be_different, 16) + ; Exact (Transfer_timeout_reserved_for_pending_transfer, 17) + ; Exact (Transfer_ledger_must_not_be_zero, 19) + ; Exact (Transfer_code_must_not_be_zero, 20) + ; Exact (Transfer_debit_account_not_found, 21) + ; Exact (Transfer_credit_account_not_found, 22) + ; Exact (Transfer_accounts_must_have_same_ledger, 23) + ; Exact (Transfer_must_have_same_ledger_as_accounts, 24) + ; Exact (Transfer_pending_transfer_not_found, 25) + ; Exact (Transfer_pending_transfer_not_pending, 26) + ; Coarse (Transfer_pending_transfer_has_different_accounts, [ 27; 28 ]) + ; Exact (Transfer_pending_transfer_has_different_ledger, 29) + ; Exact (Transfer_pending_transfer_has_different_code, 30) + ; Exact (Transfer_exceeds_pending_transfer_amount, 31) + ; Exact (Transfer_pending_transfer_has_different_amount, 32) + ; Exact (Transfer_pending_transfer_already_posted, 33) + ; Exact (Transfer_pending_transfer_already_voided, 34) + ; Exact (Transfer_pending_transfer_expired, 35) + ; Coarse (Transfer_exists_with_different_request, [ 36; 37; 38; 39; 40; 44; 45; 67 ]) + ; Exact (Transfer_exists, 46) + ; Coarse (Transfer_overflows_balance, [ 47; 48; 49; 50; 51; 52 ]) + ; Exact (Transfer_overflows_timeout, 53) + ; Exact (Transfer_exceeds_credits, 54) + ; Exact (Transfer_exceeds_debits, 55) + ; Exact (Transfer_imported_event_expected, 56) + ; Exact (Transfer_imported_event_not_expected, 57) + ; Exact (Transfer_imported_timestamp_out_of_range, 58) + ; Exact (Transfer_imported_timestamp_must_not_advance, 59) + ; Exact (Transfer_imported_timestamp_must_not_regress, 60) + ; Exact (Transfer_imported_timeout_must_be_zero, 63) + ; Exact (Transfer_closing_transfer_must_be_pending, 64) + ; Coarse (Transfer_account_already_closed, [ 65; 66 ]) + ; Exact (Transfer_id_already_failed, 68) + ] +;; + +let codes_of_mapping = function + | Exact (_, code) -> [ code ] + | Coarse (_, codes) -> codes +;; + +let status_of_mapping = function + | Exact (status, _) | Coarse (status, _) -> status +;; + +let lookup_status mappings status = + List.find (fun mapping -> status_of_mapping mapping = status) mappings +;; + +let to_code_of mappings status = + match lookup_status mappings status with + | Exact (_, code) -> Some code + | Coarse _ -> None +;; + +let codes_of mappings status = codes_of_mapping (lookup_status mappings status) + +let of_code_of mappings code = + List.find_map + (fun mapping -> + if List.mem code (codes_of_mapping mapping) + then Some (status_of_mapping mapping) + else None) + mappings +;; + +let account_to_code = to_code_of account_mappings +let account_codes = codes_of account_mappings +let account_of_code = of_code_of account_mappings +let transfer_to_code = to_code_of transfer_mappings +let transfer_codes = codes_of transfer_mappings +let transfer_of_code = of_code_of transfer_mappings +let account_statuses = List.map status_of_mapping account_mappings +let transfer_statuses = List.map status_of_mapping transfer_mappings + +let transfer_status_transient = function + | Transfer_debit_account_not_found + | Transfer_credit_account_not_found + | Transfer_pending_transfer_not_found + | Transfer_account_already_closed + | Transfer_exceeds_credits + | Transfer_exceeds_debits -> true + | _ -> false +;; diff --git a/ocam/src/result_code.mli b/ocam/src/result_code.mli new file mode 100644 index 00000000..9ee95b20 --- /dev/null +++ b/ocam/src/result_code.mli @@ -0,0 +1,34 @@ +(** Numeric encoding of create statuses. + + Codes follow the [CreateAccountStatus] and [CreateTransferStatus] enums of the pinned + TigerBeetle revision. Some OCaml statuses are coarser than upstream and stand for + several upstream codes; those have no single [to_code] value and are listed by + [*_codes] instead. Upstream codes with no OCaml counterpart ([deprecated_ok], + [reserved_field], [reserved_flag], [deprecated_18], + [imported_event_timestamp_must_postdate_*]) decode to [None]. *) + +open Types + +(** The [created] code, [maxInt(u32)]. *) +val created_code : int + +(** The exact upstream code for a status, or [None] for a coarse status. *) +val account_to_code : create_account_status -> int option + +(** Every upstream code an OCaml status stands for. *) +val account_codes : create_account_status -> int list + +(** The OCaml status for an upstream code. *) +val account_of_code : int -> create_account_status option + +val transfer_to_code : create_transfer_status -> int option +val transfer_codes : create_transfer_status -> int list +val transfer_of_code : int -> create_transfer_status option + +(** All statuses, in upstream declaration order. *) +val account_statuses : create_account_status list + +val transfer_statuses : create_transfer_status list + +(** Whether retrying an identical request can produce a different outcome. *) +val transfer_status_transient : create_transfer_status -> bool diff --git a/ocam/src/state_machine.ml b/ocam/src/state_machine.ml index 0e495f92..c66fe0ae 100644 --- a/ocam/src/state_machine.ml +++ b/ocam/src/state_machine.ml @@ -1,272 +1,13 @@ -module U128 = struct - type t = - { hi : int64 - ; lo : int64 - } +module U128 = U128 +include Types +module Result_code = Result_code - let zero = { hi = 0L; lo = 0L } - let max_value = { hi = -1L; lo = -1L } +type t = Ledger.t - let of_int value = - if value < 0 then invalid_arg "U128.of_int: negative value"; - { hi = 0L; lo = Int64.of_int value } - ;; - - let of_int64_pair ~hi ~lo = { hi; lo } - let to_int64_pair value = value.hi, value.lo - - let compare a b = - let high = Int64.unsigned_compare a.hi b.hi in - if high <> 0 then high else Int64.unsigned_compare a.lo b.lo - ;; - - let equal a b = compare a b = 0 - - let add a b = - let lo = Int64.add a.lo b.lo in - let carry = if Int64.unsigned_compare lo a.lo < 0 then 1L else 0L in - let hi_without_carry = Int64.add a.hi b.hi in - let hi = Int64.add hi_without_carry carry in - let overflow = - Int64.unsigned_compare hi_without_carry a.hi < 0 - || (Int64.equal carry 1L && Int64.unsigned_compare hi hi_without_carry < 0) - in - if overflow then Error `Overflow else Ok { hi; lo } - ;; - - let sub a b = - if compare a b < 0 - then Error `Underflow - else ( - let borrow = if Int64.unsigned_compare a.lo b.lo < 0 then 1L else 0L in - Ok { hi = Int64.sub (Int64.sub a.hi b.hi) borrow; lo = Int64.sub a.lo b.lo }) - ;; - - let min a b = if compare a b <= 0 then a else b - - let to_string value = - if Int64.equal value.hi 0L - then Printf.sprintf "%Lu" value.lo - else Printf.sprintf "0x%Lx%016Lx" value.hi value.lo - ;; -end - -type account_flags = - { linked : bool - ; debits_must_not_exceed_credits : bool - ; credits_must_not_exceed_debits : bool - ; history : bool - ; imported : bool - ; closed : bool - } - -type transfer_flags = - { linked : bool - ; pending : bool - ; post_pending_transfer : bool - ; void_pending_transfer : bool - ; balancing_debit : bool - ; balancing_credit : bool - ; closing_debit : bool - ; closing_credit : bool - ; imported : bool - } - -type account = - { id : U128.t - ; debits_pending : U128.t - ; debits_posted : U128.t - ; credits_pending : U128.t - ; credits_posted : U128.t - ; user_data_128 : U128.t - ; user_data_64 : int64 - ; user_data_32 : int32 - ; ledger : int32 - ; code : int - ; flags : account_flags - ; timestamp : int64 - } - -type transfer = - { id : U128.t - ; debit_account_id : U128.t - ; credit_account_id : U128.t - ; amount : U128.t - ; pending_id : U128.t - ; user_data_128 : U128.t - ; user_data_64 : int64 - ; user_data_32 : int32 - ; timeout : int32 - ; ledger : int32 - ; code : int - ; flags : transfer_flags - ; timestamp : int64 - } - -type pending_status = - | Pending - | Posted - | Voided - | Expired - -type create_account_status = - | Account_created - | Account_exists - | Account_linked_event_failed - | Account_linked_event_chain_open - | Account_imported_event_expected - | Account_imported_event_not_expected - | Account_timestamp_must_be_zero - | Account_id_must_not_be_zero - | Account_id_must_not_be_int_max - | Account_exists_with_different_flags - | Account_exists_with_different_user_data_128 - | Account_exists_with_different_user_data_64 - | Account_exists_with_different_user_data_32 - | Account_exists_with_different_ledger - | Account_exists_with_different_code - | Account_flags_are_mutually_exclusive - | Account_debits_pending_must_be_zero - | Account_debits_posted_must_be_zero - | Account_credits_pending_must_be_zero - | Account_credits_posted_must_be_zero - | Account_ledger_must_not_be_zero - | Account_code_must_not_be_zero - | Account_imported_timestamp_out_of_range - | Account_imported_timestamp_must_not_advance - | Account_imported_timestamp_must_not_regress - -type create_transfer_status = - | Transfer_created - | Transfer_exists - | Transfer_linked_event_failed - | Transfer_linked_event_chain_open - | Transfer_imported_event_expected - | Transfer_imported_event_not_expected - | Transfer_timestamp_must_be_zero - | Transfer_id_must_not_be_zero - | Transfer_id_must_not_be_int_max - | Transfer_id_already_failed - | Transfer_exists_with_different_request - | Transfer_flags_are_mutually_exclusive - | Transfer_debit_account_id_must_not_be_zero - | Transfer_debit_account_id_must_not_be_int_max - | Transfer_credit_account_id_must_not_be_zero - | Transfer_credit_account_id_must_not_be_int_max - | Transfer_accounts_must_be_different - | Transfer_pending_id_must_be_zero - | Transfer_pending_id_must_not_be_zero - | Transfer_pending_id_must_not_be_int_max - | Transfer_pending_id_must_be_different - | Transfer_timeout_reserved_for_pending_transfer - | Transfer_closing_transfer_must_be_pending - | Transfer_ledger_must_not_be_zero - | Transfer_code_must_not_be_zero - | Transfer_debit_account_not_found - | Transfer_credit_account_not_found - | Transfer_accounts_must_have_same_ledger - | Transfer_must_have_same_ledger_as_accounts - | Transfer_pending_transfer_not_found - | Transfer_pending_transfer_not_pending - | Transfer_pending_transfer_has_different_accounts - | Transfer_pending_transfer_has_different_ledger - | Transfer_pending_transfer_has_different_code - | Transfer_exceeds_pending_transfer_amount - | Transfer_pending_transfer_has_different_amount - | Transfer_pending_transfer_already_posted - | Transfer_pending_transfer_already_voided - | Transfer_pending_transfer_expired - | Transfer_account_already_closed - | Transfer_overflows_balance - | Transfer_overflows_timeout - | Transfer_exceeds_credits - | Transfer_exceeds_debits - | Transfer_imported_timestamp_out_of_range - | Transfer_imported_timestamp_must_not_advance - | Transfer_imported_timestamp_must_not_regress - | Transfer_imported_timeout_must_be_zero - -type 'status create_result = - { timestamp : int64 - ; status : 'status - } - -type query_filter = - { user_data_128 : U128.t - ; user_data_64 : int64 - ; user_data_32 : int32 - ; ledger : int32 - ; code : int - ; timestamp_min : int64 - ; timestamp_max : int64 - ; limit : int - ; reversed : bool - } - -type account_filter = - { account_id : U128.t - ; user_data_128 : U128.t - ; user_data_64 : int64 - ; user_data_32 : int32 - ; code : int - ; timestamp_min : int64 - ; timestamp_max : int64 - ; limit : int - ; debits : bool - ; credits : bool - ; reversed : bool - } - -module Id_table = Hashtbl.Make (struct - type t = U128.t - - let equal = U128.equal - let hash value = Hashtbl.hash (U128.to_int64_pair value) - end) - -type t = - { mutable accounts : account Id_table.t - ; mutable transfers : transfer Id_table.t - ; mutable pending : pending_status Id_table.t - ; mutable account_history : (account * transfer) list Id_table.t - ; mutable failed_transfers : unit Id_table.t - ; mutable commit_timestamp : int64 - } - -let empty () = - { accounts = Id_table.create 1024 - ; transfers = Id_table.create 1024 - ; pending = Id_table.create 256 - ; account_history = Id_table.create 1024 - ; failed_transfers = Id_table.create 256 - ; commit_timestamp = 0L - } -;; - -let commit_timestamp state = state.commit_timestamp -let is_zero = U128.equal U128.zero +let empty = Ledger.empty +let commit_timestamp = Ledger.commit_timestamp +let is_zero = U128.is_zero let is_max = U128.equal U128.max_value -let copy_table table = Id_table.copy table - -let clone state = - { accounts = copy_table state.accounts - ; transfers = copy_table state.transfers - ; pending = copy_table state.pending - ; account_history = copy_table state.account_history - ; failed_transfers = copy_table state.failed_transfers - ; commit_timestamp = state.commit_timestamp - } -;; - -let replace_state destination source = - destination.accounts <- source.accounts; - destination.transfers <- source.transfers; - destination.pending <- source.pending; - destination.account_history <- source.account_history; - destination.failed_transfers <- source.failed_transfers; - destination.commit_timestamp <- source.commit_timestamp -;; - let account_flags_equal (a : account_flags) (b : account_flags) = a = b let transfer_flags_equal (a : transfer_flags) (b : transfer_flags) = a = b @@ -290,7 +31,7 @@ let create_account_one state ~timestamp_event (request : account) = else if is_max request.id then error Account_id_must_not_be_int_max else ( - match Id_table.find_opt state.accounts request.id with + match Ledger.find_account state request.id with | Some existing -> let status = if not (account_flags_equal request.flags existing.flags) @@ -310,9 +51,8 @@ let create_account_one state ~timestamp_event (request : account) = { timestamp = (if status = Account_exists then existing.timestamp else 0L); status } | None -> let status = - if - request.flags.debits_must_not_exceed_credits - && request.flags.credits_must_not_exceed_debits + if request.flags.debits_must_not_exceed_credits + && request.flags.credits_must_not_exceed_debits then Some Account_flags_are_mutually_exclusive else if not (is_zero request.debits_pending) then Some Account_debits_pending_must_be_zero @@ -333,7 +73,7 @@ let create_account_one state ~timestamp_event (request : account) = | None -> (match validate_event_timestamp - ~commit_timestamp:state.commit_timestamp + ~commit_timestamp:(Ledger.commit_timestamp state) ~timestamp_event ~imported:request.flags.imported ~timestamp:request.timestamp @@ -342,14 +82,10 @@ let create_account_one state ~timestamp_event (request : account) = | Error `Out_of_range -> error Account_imported_timestamp_out_of_range | Error `Regressed -> error Account_imported_timestamp_must_not_regress | Ok timestamp -> - let account = { request with timestamp } in - Id_table.add state.accounts account.id account; - state.commit_timestamp <- timestamp; + Ledger.add_account state { request with timestamp }; { timestamp; status = Account_created }))) ;; -let sum_or_error a b = U128.add a b - let total_balance_overflows pending posted = match U128.add pending posted with | Ok _ -> false @@ -383,7 +119,7 @@ let credits_exceed_debits (account : account) amount = let transfer_request_equal state (request : transfer) (existing : transfer) = let pending = if request.flags.post_pending_transfer || request.flags.void_pending_transfer - then Id_table.find_opt state.transfers existing.pending_id + then Ledger.find_transfer state existing.pending_id else None in let optional_u128 request_value existing_value pending_value = @@ -449,6 +185,10 @@ let timeout_ns timeout = let timeout_nonzero timeout = not (Int32.equal timeout 0l) +let expires_at (transfer : transfer) = + Int64.add transfer.timestamp (timeout_ns transfer.timeout) +;; + let timeout_overflows ~timestamp ~timeout = let duration = timeout_ns timeout in Int64.compare timestamp (Int64.sub Int64.max_int duration) > 0 @@ -457,12 +197,7 @@ let timeout_overflows ~timestamp ~timeout = let record_account_history state (transfer : transfer) debit credit = let record (account : account) = if account.flags.history - then ( - let snapshot = { account with timestamp = transfer.timestamp } in - let history = - Option.value (Id_table.find_opt state.account_history account.id) ~default:[] - in - Id_table.replace state.account_history account.id ((snapshot, transfer) :: history)) + then Ledger.add_history state { account with timestamp = transfer.timestamp } transfer in record debit; record credit @@ -493,21 +228,21 @@ let effective_balancing_amount (request : transfer) (debit : account) (credit : if request.flags.balancing_credit then U128.min amount credit_room else amount ;; -let store_transfer state transfer = - Id_table.add state.transfers transfer.id transfer; - state.commit_timestamp <- transfer.timestamp +let find_account_exn state id = + match Ledger.find_account state id with + | Some account -> account + | None -> failwith "account referenced by stored transfer is missing" ;; let post_or_void state ~timestamp_event (request : transfer) = let error status = { timestamp = 0L; status } in let flags = request.flags in - if - (flags.post_pending_transfer && flags.void_pending_transfer) - || flags.pending - || flags.balancing_debit - || flags.balancing_credit - || flags.closing_debit - || flags.closing_credit + if (flags.post_pending_transfer && flags.void_pending_transfer) + || flags.pending + || flags.balancing_debit + || flags.balancing_credit + || flags.closing_debit + || flags.closing_credit then error Transfer_flags_are_mutually_exclusive else if is_zero request.pending_id then error Transfer_pending_id_must_not_be_zero @@ -518,32 +253,30 @@ let post_or_void state ~timestamp_event (request : transfer) = else if not (Int32.equal request.timeout 0l) then error Transfer_timeout_reserved_for_pending_transfer else ( - match Id_table.find_opt state.transfers request.pending_id with + match Ledger.find_transfer state request.pending_id with | None -> error Transfer_pending_transfer_not_found | Some pending_transfer -> if not pending_transfer.flags.pending then error Transfer_pending_transfer_not_pending else ( - match Id_table.find_opt state.pending pending_transfer.id with + match Ledger.find_pending state pending_transfer.id with | Some Posted -> error Transfer_pending_transfer_already_posted | Some Voided -> error Transfer_pending_transfer_already_voided | Some Expired -> error Transfer_pending_transfer_expired | None -> error Transfer_pending_transfer_not_pending | Some Pending -> - if - ((not (is_zero request.debit_account_id)) - && not - (U128.equal request.debit_account_id pending_transfer.debit_account_id) - ) - || ((not (is_zero request.credit_account_id)) - && not - (U128.equal - request.credit_account_id - pending_transfer.credit_account_id)) + if ((not (is_zero request.debit_account_id)) + && not + (U128.equal request.debit_account_id pending_transfer.debit_account_id) + ) + || ((not (is_zero request.credit_account_id)) + && not + (U128.equal + request.credit_account_id + pending_transfer.credit_account_id)) then error Transfer_pending_transfer_has_different_accounts - else if - (not (Int32.equal request.ledger 0l)) - && not (Int32.equal request.ledger pending_transfer.ledger) + else if (not (Int32.equal request.ledger 0l)) + && not (Int32.equal request.ledger pending_transfer.ledger) then error Transfer_pending_transfer_has_different_ledger else if request.code <> 0 && request.code <> pending_transfer.code then error Transfer_pending_transfer_has_different_code @@ -557,120 +290,105 @@ let post_or_void state ~timestamp_event (request : transfer) = in if U128.compare amount pending_transfer.amount > 0 then error Transfer_exceeds_pending_transfer_amount - else if - flags.void_pending_transfer - && not (U128.equal amount pending_transfer.amount) + else if flags.void_pending_transfer + && not (U128.equal amount pending_transfer.amount) then error Transfer_pending_transfer_has_different_amount + else if timeout_nonzero pending_transfer.timeout + && Int64.compare timestamp_event (expires_at pending_transfer) >= 0 + then error Transfer_pending_transfer_expired else ( - let expires_at = - Int64.add pending_transfer.timestamp (timeout_ns pending_transfer.timeout) - in - if - timeout_nonzero pending_transfer.timeout - && Int64.compare timestamp_event expires_at >= 0 - then error Transfer_pending_transfer_expired - else ( - match - validate_event_timestamp - ~commit_timestamp:state.commit_timestamp - ~timestamp_event - ~imported:flags.imported - ~timestamp:request.timestamp - with - | Error `Must_be_zero -> error Transfer_timestamp_must_be_zero - | Error `Out_of_range -> error Transfer_imported_timestamp_out_of_range - | Error `Regressed -> error Transfer_imported_timestamp_must_not_regress - | Ok timestamp -> - let debit = - Id_table.find state.accounts pending_transfer.debit_account_id - in - let credit = - Id_table.find state.accounts pending_transfer.credit_account_id - in - if - (debit.flags.closed || credit.flags.closed) - && not flags.void_pending_transfer - then error Transfer_account_already_closed - else ( - match - ( U128.sub debit.debits_pending pending_transfer.amount - , U128.sub credit.credits_pending pending_transfer.amount ) - with - | Error _, _ | _, Error _ -> error Transfer_overflows_balance - | Ok debits_pending, Ok credits_pending -> - let debit_result, credit_result = - if flags.post_pending_transfer - then - ( sum_or_error debit.debits_posted amount - , sum_or_error credit.credits_posted amount ) - else Ok debit.debits_posted, Ok credit.credits_posted - in - (match debit_result, credit_result with - | Error _, _ | _, Error _ -> error Transfer_overflows_balance - | Ok debits_posted, Ok credits_posted -> - let debit_flags = - if - flags.void_pending_transfer - && pending_transfer.flags.closing_debit - then { debit.flags with closed = false } - else debit.flags - in - let credit_flags = - if - flags.void_pending_transfer - && pending_transfer.flags.closing_credit - then { credit.flags with closed = false } - else credit.flags - in - Id_table.replace - state.accounts - debit.id - { debit with - debits_pending - ; debits_posted - ; flags = debit_flags - }; - Id_table.replace - state.accounts - credit.id - { credit with - credits_pending - ; credits_posted - ; flags = credit_flags - }; - Id_table.replace - state.pending - pending_transfer.id - (if flags.post_pending_transfer then Posted else Voided); - let transfer = - { request with - debit_account_id = pending_transfer.debit_account_id - ; credit_account_id = pending_transfer.credit_account_id - ; amount - ; user_data_128 = - (if is_zero request.user_data_128 - then pending_transfer.user_data_128 - else request.user_data_128) - ; user_data_64 = - (if Int64.equal request.user_data_64 0L - then pending_transfer.user_data_64 - else request.user_data_64) - ; user_data_32 = - (if Int32.equal request.user_data_32 0l - then pending_transfer.user_data_32 - else request.user_data_32) - ; ledger = pending_transfer.ledger - ; code = pending_transfer.code - ; timestamp - } - in - store_transfer state transfer; - record_account_history + match + validate_event_timestamp + ~commit_timestamp:(Ledger.commit_timestamp state) + ~timestamp_event + ~imported:flags.imported + ~timestamp:request.timestamp + with + | Error `Must_be_zero -> error Transfer_timestamp_must_be_zero + | Error `Out_of_range -> error Transfer_imported_timestamp_out_of_range + | Error `Regressed -> error Transfer_imported_timestamp_must_not_regress + | Ok timestamp -> + let debit = find_account_exn state pending_transfer.debit_account_id in + let credit = find_account_exn state pending_transfer.credit_account_id in + if (debit.flags.closed || credit.flags.closed) + && not flags.void_pending_transfer + then error Transfer_account_already_closed + else ( + match + ( U128.sub debit.debits_pending pending_transfer.amount + , U128.sub credit.credits_pending pending_transfer.amount ) + with + | Error _, _ | _, Error _ -> error Transfer_overflows_balance + | Ok debits_pending, Ok credits_pending -> + let debit_result, credit_result = + if flags.post_pending_transfer + then + ( U128.add debit.debits_posted amount + , U128.add credit.credits_posted amount ) + else Ok debit.debits_posted, Ok credit.credits_posted + in + (match debit_result, credit_result with + | Error _, _ | _, Error _ -> error Transfer_overflows_balance + | Ok debits_posted, Ok credits_posted -> + let debit_flags = + if flags.void_pending_transfer + && pending_transfer.flags.closing_debit + then { debit.flags with closed = false } + else debit.flags + in + let credit_flags = + if flags.void_pending_transfer + && pending_transfer.flags.closing_credit + then { credit.flags with closed = false } + else credit.flags + in + let debit = + { debit with debits_pending; debits_posted; flags = debit_flags } + in + let credit = + { credit with + credits_pending + ; credits_posted + ; flags = credit_flags + } + in + Ledger.update_account state debit; + Ledger.update_account state credit; + Ledger.set_pending + state + pending_transfer.id + (if flags.post_pending_transfer then Posted else Voided); + if timeout_nonzero pending_transfer.timeout + then + Ledger.remove_expiry state - transfer - (Id_table.find state.accounts debit.id) - (Id_table.find state.accounts credit.id); - { timestamp; status = Transfer_created }))))))) + ~expires_at:(expires_at pending_transfer) + pending_transfer.id; + let transfer = + { request with + debit_account_id = pending_transfer.debit_account_id + ; credit_account_id = pending_transfer.credit_account_id + ; amount + ; user_data_128 = + (if is_zero request.user_data_128 + then pending_transfer.user_data_128 + else request.user_data_128) + ; user_data_64 = + (if Int64.equal request.user_data_64 0L + then pending_transfer.user_data_64 + else request.user_data_64) + ; user_data_32 = + (if Int32.equal request.user_data_32 0l + then pending_transfer.user_data_32 + else request.user_data_32) + ; ledger = pending_transfer.ledger + ; code = pending_transfer.code + ; timestamp + } + in + Ledger.add_transfer state transfer; + record_account_history state transfer debit credit; + { timestamp; status = Transfer_created })))))) ;; let create_transfer_one_untracked state ~timestamp_event (request : transfer) = @@ -680,7 +398,7 @@ let create_transfer_one_untracked state ~timestamp_event (request : transfer) = else if is_max request.id then error Transfer_id_must_not_be_int_max else ( - match Id_table.find_opt state.transfers request.id with + match Ledger.find_transfer state request.id with | Some existing -> if transfer_request_equal state request existing then { timestamp = existing.timestamp; status = Transfer_exists } @@ -702,28 +420,27 @@ let create_transfer_one_untracked state ~timestamp_event (request : transfer) = then error Transfer_pending_id_must_be_zero else if (not request.flags.pending) && not (Int32.equal request.timeout 0l) then error Transfer_timeout_reserved_for_pending_transfer - else if - (request.flags.closing_debit || request.flags.closing_credit) - && not request.flags.pending + else if (request.flags.closing_debit || request.flags.closing_credit) + && not request.flags.pending then error Transfer_closing_transfer_must_be_pending else if Int32.equal request.ledger 0l then error Transfer_ledger_must_not_be_zero else if request.code = 0 then error Transfer_code_must_not_be_zero else ( - match Id_table.find_opt state.accounts request.debit_account_id with + match Ledger.find_account state request.debit_account_id with | None -> error Transfer_debit_account_not_found | Some debit -> - (match Id_table.find_opt state.accounts request.credit_account_id with + (match Ledger.find_account state request.credit_account_id with | None -> error Transfer_credit_account_not_found | Some credit -> if not (Int32.equal debit.ledger credit.ledger) then error Transfer_accounts_must_have_same_ledger else if not (Int32.equal request.ledger debit.ledger) then error Transfer_must_have_same_ledger_as_accounts - else if - request.flags.imported - && Int64.compare request.timestamp state.commit_timestamp <= 0 + else if request.flags.imported + && Int64.compare request.timestamp (Ledger.commit_timestamp state) + <= 0 then error Transfer_imported_timestamp_must_not_regress else if request.flags.imported && not (Int32.equal request.timeout 0l) then error Transfer_imported_timeout_must_be_zero @@ -733,7 +450,7 @@ let create_transfer_one_untracked state ~timestamp_event (request : transfer) = let amount = effective_balancing_amount request debit credit in match validate_event_timestamp - ~commit_timestamp:state.commit_timestamp + ~commit_timestamp:(Ledger.commit_timestamp state) ~timestamp_event ~imported:request.flags.imported ~timestamp:request.timestamp @@ -744,13 +461,13 @@ let create_transfer_one_untracked state ~timestamp_event (request : transfer) = | Ok timestamp -> let debit_balance = if request.flags.pending - then sum_or_error debit.debits_pending amount - else sum_or_error debit.debits_posted amount + then U128.add debit.debits_pending amount + else U128.add debit.debits_posted amount in let credit_balance = if request.flags.pending - then sum_or_error credit.credits_pending amount - else sum_or_error credit.credits_posted amount + then U128.add credit.credits_pending amount + else U128.add credit.credits_posted amount in (match debit_balance, credit_balance with | Error _, _ | _, Error _ -> error Transfer_overflows_balance @@ -765,69 +482,66 @@ let create_transfer_one_untracked state ~timestamp_event (request : transfer) = then credit_balance, credit.credits_posted else credit.credits_pending, credit_balance in - if - total_balance_overflows debits_pending debits_posted - || total_balance_overflows credits_pending credits_posted + if total_balance_overflows debits_pending debits_posted + || total_balance_overflows credits_pending credits_posted then error Transfer_overflows_balance - else if - request.flags.pending - && timeout_overflows ~timestamp ~timeout:request.timeout + else if request.flags.pending + && timeout_overflows ~timestamp ~timeout:request.timeout then error Transfer_overflows_timeout else if debits_exceed_credits debit amount then error Transfer_exceeds_credits else if credits_exceed_debits credit amount then error Transfer_exceeds_debits else ( - let debit = - if request.flags.pending - then { debit with debits_pending = debit_balance } - else { debit with debits_posted = debit_balance } + let debit_flags = + if request.flags.closing_debit + then { debit.flags with closed = true } + else debit.flags in - let credit = - if request.flags.pending - then { credit with credits_pending = credit_balance } - else { credit with credits_posted = credit_balance } + let credit_flags = + if request.flags.closing_credit + then { credit.flags with closed = true } + else credit.flags in let debit = - if request.flags.closing_debit - then { debit with flags = { debit.flags with closed = true } } - else debit + { debit with debits_pending; debits_posted; flags = debit_flags } in let credit = - if request.flags.closing_credit - then { credit with flags = { credit.flags with closed = true } } - else credit + { credit with + credits_pending + ; credits_posted + ; flags = credit_flags + } in - Id_table.replace state.accounts debit.id debit; - Id_table.replace state.accounts credit.id credit; + Ledger.update_account state debit; + Ledger.update_account state credit; let transfer = { request with amount; timestamp } in - store_transfer state transfer; + Ledger.add_transfer state transfer; if request.flags.pending - then Id_table.add state.pending transfer.id Pending; + then ( + Ledger.set_pending state transfer.id Pending; + if timeout_nonzero transfer.timeout + then + Ledger.add_expiry + state + ~expires_at:(expires_at transfer) + transfer.id); record_account_history state transfer debit credit; { timestamp; status = Transfer_created })))))) ;; -let transfer_status_transient = function - | Transfer_debit_account_not_found - | Transfer_credit_account_not_found - | Transfer_pending_transfer_not_found - | Transfer_account_already_closed - | Transfer_exceeds_credits - | Transfer_exceeds_debits -> true - | _ -> false -;; - let create_transfer_one state ~timestamp_event (request : transfer) = - if Id_table.mem state.failed_transfers request.id + if Ledger.transfer_failed state request.id then { timestamp = 0L; status = Transfer_id_already_failed } else ( let result = create_transfer_one_untracked state ~timestamp_event request in - if transfer_status_transient result.status - then Id_table.replace state.failed_transfers request.id (); + if Result_code.transfer_status_transient result.status + then Ledger.mark_failed state request.id; result) ;; +(* Batch execution shared by accounts and transfers. *) + let chains events linked = let rec loop current output = function | [] -> List.rev (if current = [] then output else List.rev current :: output) @@ -840,94 +554,23 @@ let chains events linked = loop [] [] events ;; -let create_accounts state ~timestamp (requests : account list) = - let timestamp_cursor = ref timestamp in - let batch_timestamp_high = - Int64.add timestamp (Int64.of_int (Int.max 0 (List.length requests - 1))) - in - let batch_imported = - match requests with - | [] -> false - | (first : account) :: _ -> first.flags.imported - in - let execute_one target (request : account) = - if request.flags.imported <> batch_imported - then - { timestamp = 0L - ; status = - (if request.flags.imported - then Account_imported_event_not_expected - else Account_imported_event_expected) - } - else if request.flags.imported && Int64.compare request.timestamp 0L <= 0 - then { timestamp = 0L; status = Account_imported_timestamp_out_of_range } - else if - request.flags.imported && Int64.compare request.timestamp batch_timestamp_high >= 0 - then { timestamp = 0L; status = Account_imported_timestamp_must_not_advance } - else if (not request.flags.imported) && not (Int64.equal request.timestamp 0L) - then { timestamp = 0L; status = Account_timestamp_must_be_zero } - else create_account_one target ~timestamp_event:!timestamp_cursor request - in - let execute_chain ~open_chain chain = - match chain with - | [ (request : account) ] when not request.flags.linked -> - let result = execute_one state request in - timestamp_cursor := Int64.succ !timestamp_cursor; - [ result ] - | _ -> - let trial = clone state in - let last_index = List.length chain - 1 in - let rec run index failure_index results = function - | [] -> List.rev results, failure_index - | request :: rest -> - let result, failure_index = - if open_chain && index = last_index - then - { timestamp = 0L; status = Account_linked_event_chain_open }, failure_index - else ( - match failure_index with - | Some _ -> - { timestamp = 0L; status = Account_linked_event_failed }, failure_index - | None -> - let result = execute_one trial request in - let failure_index = - if result.status = Account_created then None else Some index - in - result, failure_index) - in - timestamp_cursor := Int64.succ !timestamp_cursor; - run (index + 1) failure_index (result :: results) rest - in - let results, failure_index = run 0 None [] chain in - (match failure_index, open_chain with - | None, false -> - replace_state state trial; - results - | _ -> - List.mapi - (fun index result -> - if open_chain && index = last_index - then { timestamp = 0L; status = Account_linked_event_chain_open } - else if Some index = failure_index - then result - else { timestamp = 0L; status = Account_linked_event_failed }) - results) - in - let request_chains = - chains requests (fun (account : account) -> account.flags.linked) - in - List.concat_map - (fun chain -> - let open_chain = - match List.rev chain with - | (last : account) :: _ -> last.flags.linked - | [] -> false - in - execute_chain ~open_chain chain) - request_chains -;; +type ('request, 'status) batch_spec = + { linked : 'request -> bool + ; imported : 'request -> bool + ; request_timestamp : 'request -> int64 + ; success : 'status + ; linked_event_failed : 'status + ; linked_event_chain_open : 'status + ; imported_event_expected : 'status + ; imported_event_not_expected : 'status + ; imported_timestamp_out_of_range : 'status + ; imported_timestamp_must_not_advance : 'status + ; timestamp_must_be_zero : 'status + ; execute : t -> timestamp_event:int64 -> 'request -> 'status create_result + ; on_chain_failure : t -> 'request -> 'status -> unit + } -let create_transfers state ~timestamp (requests : transfer list) = +let execute_batch spec state ~timestamp requests = let timestamp_cursor = ref timestamp in let batch_timestamp_high = Int64.add timestamp (Int64.of_int (Int.max 0 (List.length requests - 1))) @@ -935,259 +578,298 @@ let create_transfers state ~timestamp (requests : transfer list) = let batch_imported = match requests with | [] -> false - | (first : transfer) :: _ -> first.flags.imported + | first :: _ -> spec.imported first in - let execute_one target (request : transfer) = - if request.flags.imported <> batch_imported - then - { timestamp = 0L - ; status = - (if request.flags.imported - then Transfer_imported_event_not_expected - else Transfer_imported_event_expected) - } - else if request.flags.imported && Int64.compare request.timestamp 0L <= 0 - then { timestamp = 0L; status = Transfer_imported_timestamp_out_of_range } - else if - request.flags.imported && Int64.compare request.timestamp batch_timestamp_high >= 0 - then { timestamp = 0L; status = Transfer_imported_timestamp_must_not_advance } - else if (not request.flags.imported) && not (Int64.equal request.timestamp 0L) - then { timestamp = 0L; status = Transfer_timestamp_must_be_zero } - else create_transfer_one target ~timestamp_event:!timestamp_cursor request + let error status = { timestamp = 0L; status } in + let execute_one request = + let imported = spec.imported request in + let request_timestamp = spec.request_timestamp request in + let result = + if imported <> batch_imported + then + error + (if imported + then spec.imported_event_not_expected + else spec.imported_event_expected) + else if imported && Int64.compare request_timestamp 0L <= 0 + then error spec.imported_timestamp_out_of_range + else if imported && Int64.compare request_timestamp batch_timestamp_high >= 0 + then error spec.imported_timestamp_must_not_advance + else if (not imported) && not (Int64.equal request_timestamp 0L) + then error spec.timestamp_must_be_zero + else spec.execute state ~timestamp_event:!timestamp_cursor request + in + result in - let execute_chain ~open_chain chain = + let advance () = timestamp_cursor := Int64.succ !timestamp_cursor in + let execute_chain chain = match chain with - | [ (request : transfer) ] when not request.flags.linked -> - let result = execute_one state request in - timestamp_cursor := Int64.succ !timestamp_cursor; + | [ request ] when not (spec.linked request) -> + let result = execute_one request in + advance (); [ result ] | _ -> - let trial = clone state in + let open_chain = + match List.rev chain with + | last :: _ -> spec.linked last + | [] -> false + in let last_index = List.length chain - 1 in - let rec run index failure_index results = function - | [] -> List.rev results, failure_index - | request :: rest -> - let result, failure_index = - if open_chain && index = last_index - then - { timestamp = 0L; status = Transfer_linked_event_chain_open }, failure_index - else ( - match failure_index with - | Some _ -> - { timestamp = 0L; status = Transfer_linked_event_failed }, failure_index - | None -> - let result = execute_one trial request in - let failure_index = - if result.status = Transfer_created then None else Some index - in - result, failure_index) - in - timestamp_cursor := Int64.succ !timestamp_cursor; - run (index + 1) failure_index (result :: results) rest + let run () = + let rec loop index failure results = function + | [] -> List.rev results, failure + | request :: rest -> + let result, failure = + if open_chain && index = last_index + then error spec.linked_event_chain_open, failure + else ( + match failure with + | Some _ -> error spec.linked_event_failed, failure + | None -> + let result = execute_one request in + let failure = + if result.status = spec.success + then None + else Some (index, request, result) + in + result, failure) + in + advance (); + loop (index + 1) failure (result :: results) rest + in + loop 0 None [] chain in - let results, failure_index = run 0 None [] chain in - (match failure_index, open_chain with - | None, false -> - replace_state state trial; - results + let (results, failure), rollback = Ledger.transact state run in + (match failure, open_chain with + | None, false -> results | _ -> + rollback (); Option.iter - (fun index -> - let result = List.nth results index in - if transfer_status_transient result.status - then ( - let request = List.nth chain index in - Id_table.replace state.failed_transfers request.id ())) - failure_index; + (fun (_, request, result) -> spec.on_chain_failure state request result.status) + failure; + let failure_index = Option.map (fun (index, _, _) -> index) failure in List.mapi (fun index result -> - if open_chain && index = last_index - then { timestamp = 0L; status = Transfer_linked_event_chain_open } - else if Some index = failure_index - then result - else { timestamp = 0L; status = Transfer_linked_event_failed }) + if open_chain && index = last_index + then error spec.linked_event_chain_open + else if Some index = failure_index + then result + else error spec.linked_event_failed) results) in - let request_chains = - chains requests (fun (transfer : transfer) -> transfer.flags.linked) - in - List.concat_map - (fun chain -> - let open_chain = - match List.rev chain with - | (last : transfer) :: _ -> last.flags.linked - | [] -> false - in - execute_chain ~open_chain chain) - request_chains + List.concat_map execute_chain (chains requests spec.linked) ;; -let lookup_accounts state ids = List.filter_map (Id_table.find_opt state.accounts) ids -let lookup_transfers state ids = List.filter_map (Id_table.find_opt state.transfers) ids +let account_batch : (account, create_account_status) batch_spec = + { linked = (fun (request : account) -> request.flags.linked) + ; imported = (fun (request : account) -> request.flags.imported) + ; request_timestamp = (fun (request : account) -> request.timestamp) + ; success = Account_created + ; linked_event_failed = Account_linked_event_failed + ; linked_event_chain_open = Account_linked_event_chain_open + ; imported_event_expected = Account_imported_event_expected + ; imported_event_not_expected = Account_imported_event_not_expected + ; imported_timestamp_out_of_range = Account_imported_timestamp_out_of_range + ; imported_timestamp_must_not_advance = Account_imported_timestamp_must_not_advance + ; timestamp_must_be_zero = Account_timestamp_must_be_zero + ; execute = create_account_one + ; on_chain_failure = (fun _ _ _ -> ()) + } +;; -let bounded_timestamp ~minimum ~maximum timestamp = - (Int64.equal minimum 0L || Int64.compare timestamp minimum >= 0) - && (Int64.equal maximum 0L || Int64.compare timestamp maximum <= 0) +let transfer_batch : (transfer, create_transfer_status) batch_spec = + { linked = (fun (request : transfer) -> request.flags.linked) + ; imported = (fun (request : transfer) -> request.flags.imported) + ; request_timestamp = (fun (request : transfer) -> request.timestamp) + ; success = Transfer_created + ; linked_event_failed = Transfer_linked_event_failed + ; linked_event_chain_open = Transfer_linked_event_chain_open + ; imported_event_expected = Transfer_imported_event_expected + ; imported_event_not_expected = Transfer_imported_event_not_expected + ; imported_timestamp_out_of_range = Transfer_imported_timestamp_out_of_range + ; imported_timestamp_must_not_advance = Transfer_imported_timestamp_must_not_advance + ; timestamp_must_be_zero = Transfer_timestamp_must_be_zero + ; execute = create_transfer_one + ; on_chain_failure = + (fun state (request : transfer) status -> + if Result_code.transfer_status_transient status + then Ledger.mark_failed state request.id) + } ;; -let take limit list = - let rec loop count acc = function - | _ when count = 0 -> List.rev acc - | [] -> List.rev acc - | head :: tail -> loop (count - 1) (head :: acc) tail - in - if limit <= 0 then [] else loop limit [] list +let create_accounts state ~timestamp requests = + execute_batch account_batch state ~timestamp requests ;; -let sorted_by_timestamp ~reversed timestamp values = - List.sort - (fun a b -> - let order = Int64.compare (timestamp a) (timestamp b) in - if reversed then -order else order) - values +let create_transfers state ~timestamp requests = + execute_batch transfer_batch state ~timestamp requests +;; + +(* Reads *) + +let lookup_accounts state ids = List.filter_map (Ledger.find_account state) ids +let lookup_transfers state ids = List.filter_map (Ledger.find_transfer state) ids + +let take_matching ~limit predicate sequence = + if limit <= 0 + then [] + else sequence |> Seq.filter predicate |> Seq.take limit |> List.of_seq +;; + +let metadata_matches + ~user_data_128 + ~user_data_64 + ~user_data_32 + ~code + ~(value_user_data_128 : U128.t) + ~value_user_data_64 + ~value_user_data_32 + ~value_code + = + (is_zero user_data_128 || U128.equal value_user_data_128 user_data_128) + && (Int64.equal user_data_64 0L || Int64.equal value_user_data_64 user_data_64) + && (Int32.equal user_data_32 0l || Int32.equal value_user_data_32 user_data_32) + && (code = 0 || value_code = code) +;; + +let query_matches + (filter : query_filter) + ~user_data_128 + ~user_data_64 + ~user_data_32 + ~ledger + ~code + = + metadata_matches + ~user_data_128:filter.user_data_128 + ~user_data_64:filter.user_data_64 + ~user_data_32:filter.user_data_32 + ~code:filter.code + ~value_user_data_128:user_data_128 + ~value_user_data_64:user_data_64 + ~value_user_data_32:user_data_32 + ~value_code:code + && (Int32.equal filter.ledger 0l || Int32.equal ledger filter.ledger) +;; + +let account_filter_matches (filter : account_filter) (transfer : transfer) = + ((filter.debits && U128.equal transfer.debit_account_id filter.account_id) + || (filter.credits && U128.equal transfer.credit_account_id filter.account_id)) + && metadata_matches + ~user_data_128:filter.user_data_128 + ~user_data_64:filter.user_data_64 + ~user_data_32:filter.user_data_32 + ~code:filter.code + ~value_user_data_128:transfer.user_data_128 + ~value_user_data_64:transfer.user_data_64 + ~value_user_data_32:transfer.user_data_32 + ~value_code:transfer.code ;; let query_accounts state (filter : query_filter) = - Id_table.to_seq_values state.accounts - |> List.of_seq - |> List.filter (fun (account : account) -> - (is_zero filter.user_data_128 || U128.equal account.user_data_128 filter.user_data_128) - && (Int64.equal filter.user_data_64 0L - || Int64.equal account.user_data_64 filter.user_data_64) - && (Int32.equal filter.user_data_32 0l - || Int32.equal account.user_data_32 filter.user_data_32) - && (Int32.equal filter.ledger 0l || Int32.equal account.ledger filter.ledger) - && (filter.code = 0 || account.code = filter.code) - && bounded_timestamp - ~minimum:filter.timestamp_min - ~maximum:filter.timestamp_max - account.timestamp) - |> sorted_by_timestamp ~reversed:filter.reversed (fun (account : account) -> - account.timestamp) - |> take filter.limit + Ledger.to_seq_in_range + state.Ledger.accounts_by_timestamp + ~minimum:filter.timestamp_min + ~maximum:filter.timestamp_max + ~reversed:filter.reversed + |> Seq.filter_map (fun (_, id) -> Ledger.find_account state id) + |> take_matching ~limit:filter.limit (fun (account : account) -> + query_matches + filter + ~user_data_128:account.user_data_128 + ~user_data_64:account.user_data_64 + ~user_data_32:account.user_data_32 + ~ledger:account.ledger + ~code:account.code) ;; let query_transfers state (filter : query_filter) = - Id_table.to_seq_values state.transfers - |> List.of_seq - |> List.filter (fun (transfer : transfer) -> - (is_zero filter.user_data_128 - || U128.equal transfer.user_data_128 filter.user_data_128) - && (Int64.equal filter.user_data_64 0L - || Int64.equal transfer.user_data_64 filter.user_data_64) - && (Int32.equal filter.user_data_32 0l - || Int32.equal transfer.user_data_32 filter.user_data_32) - && (Int32.equal filter.ledger 0l || Int32.equal transfer.ledger filter.ledger) - && (filter.code = 0 || transfer.code = filter.code) - && bounded_timestamp - ~minimum:filter.timestamp_min - ~maximum:filter.timestamp_max - transfer.timestamp) - |> sorted_by_timestamp ~reversed:filter.reversed (fun (transfer : transfer) -> - transfer.timestamp) - |> take filter.limit + Ledger.to_seq_in_range + state.Ledger.transfers_by_timestamp + ~minimum:filter.timestamp_min + ~maximum:filter.timestamp_max + ~reversed:filter.reversed + |> Seq.map snd + |> take_matching ~limit:filter.limit (fun (transfer : transfer) -> + query_matches + filter + ~user_data_128:transfer.user_data_128 + ~user_data_64:transfer.user_data_64 + ~user_data_32:transfer.user_data_32 + ~ledger:transfer.ledger + ~code:transfer.code) ;; let get_account_transfers state (filter : account_filter) = - Id_table.to_seq_values state.transfers - |> List.of_seq - |> List.filter (fun (transfer : transfer) -> - ((filter.debits && U128.equal transfer.debit_account_id filter.account_id) - || (filter.credits && U128.equal transfer.credit_account_id filter.account_id)) - && (is_zero filter.user_data_128 - || U128.equal transfer.user_data_128 filter.user_data_128) - && (Int64.equal filter.user_data_64 0L - || Int64.equal transfer.user_data_64 filter.user_data_64) - && (Int32.equal filter.user_data_32 0l - || Int32.equal transfer.user_data_32 filter.user_data_32) - && (filter.code = 0 || transfer.code = filter.code) - && bounded_timestamp - ~minimum:filter.timestamp_min - ~maximum:filter.timestamp_max - transfer.timestamp) - |> sorted_by_timestamp ~reversed:filter.reversed (fun (transfer : transfer) -> - transfer.timestamp) - |> take filter.limit + Ledger.to_seq_in_range + (Ledger.account_transfers state filter.account_id) + ~minimum:filter.timestamp_min + ~maximum:filter.timestamp_max + ~reversed:filter.reversed + |> Seq.map snd + |> take_matching ~limit:filter.limit (account_filter_matches filter) ;; let get_account_balances state (filter : account_filter) = - match Id_table.find_opt state.accounts filter.account_id with + match Ledger.find_account state filter.account_id with | None -> [] | Some account -> - if - (not account.flags.history) - || ((not filter.debits) && not filter.credits) - || filter.limit <= 0 - || ((not (Int64.equal filter.timestamp_min 0L)) - && (not (Int64.equal filter.timestamp_max 0L)) - && Int64.compare filter.timestamp_min filter.timestamp_max > 0) + if (not account.flags.history) + || ((not filter.debits) && not filter.credits) + || filter.limit <= 0 + || ((not (Int64.equal filter.timestamp_min 0L)) + && (not (Int64.equal filter.timestamp_max 0L)) + && Int64.compare filter.timestamp_min filter.timestamp_max > 0) then [] else - Option.value (Id_table.find_opt state.account_history filter.account_id) ~default:[] - |> List.filter (fun ((snapshot : account), transfer) -> - ((filter.debits && U128.equal transfer.debit_account_id filter.account_id) - || (filter.credits && U128.equal transfer.credit_account_id filter.account_id)) - && (is_zero filter.user_data_128 - || U128.equal transfer.user_data_128 filter.user_data_128) - && (Int64.equal filter.user_data_64 0L - || Int64.equal transfer.user_data_64 filter.user_data_64) - && (Int32.equal filter.user_data_32 0l - || Int32.equal transfer.user_data_32 filter.user_data_32) - && (filter.code = 0 || transfer.code = filter.code) - && bounded_timestamp - ~minimum:filter.timestamp_min - ~maximum:filter.timestamp_max - snapshot.timestamp) - |> List.map fst - |> sorted_by_timestamp ~reversed:filter.reversed (fun (snapshot : account) -> - snapshot.timestamp) - |> take filter.limit + Ledger.to_seq_in_range + (Ledger.account_history state filter.account_id) + ~minimum:filter.timestamp_min + ~maximum:filter.timestamp_max + ~reversed:filter.reversed + |> Seq.map snd + |> take_matching ~limit:filter.limit (fun (entry : Ledger.history_entry) -> + account_filter_matches filter entry.transfer) + |> List.map (fun (entry : Ledger.history_entry) -> entry.snapshot) ;; let expire_pending_transfers state ~timestamp = let expired = ref 0 in - let pending_entries = - Id_table.fold (fun id status entries -> (id, status) :: entries) state.pending [] - in List.iter - (fun (id, status) -> - match status, Id_table.find_opt state.transfers id with - | Pending, Some transfer when timeout_nonzero transfer.timeout -> - let expires_at = Int64.add transfer.timestamp (timeout_ns transfer.timeout) in - if Int64.compare expires_at timestamp <= 0 - then ( - let debit = Id_table.find state.accounts transfer.debit_account_id in - let credit = Id_table.find state.accounts transfer.credit_account_id in - match - ( U128.sub debit.debits_pending transfer.amount - , U128.sub credit.credits_pending transfer.amount ) - with - | Ok debits_pending, Ok credits_pending -> - let debit = - { debit with - debits_pending - ; flags = - (if transfer.flags.closing_debit - then { debit.flags with closed = false } - else debit.flags) - } - in - let credit = - { credit with - credits_pending - ; flags = - (if transfer.flags.closing_credit - then { credit.flags with closed = false } - else credit.flags) - } - in - Id_table.replace state.accounts debit.id debit; - Id_table.replace state.accounts credit.id credit; - Id_table.replace state.pending id Expired; - incr expired - | _ -> failwith "pending-balance invariant violated") - | _ -> ()) - pending_entries; - if !expired > 0 then state.commit_timestamp <- timestamp; + (fun (expires_at, id) -> + match Ledger.find_pending state id, Ledger.find_transfer state id with + | Some Pending, Some transfer -> + let debit = find_account_exn state transfer.debit_account_id in + let credit = find_account_exn state transfer.credit_account_id in + (match + ( U128.sub debit.debits_pending transfer.amount + , U128.sub credit.credits_pending transfer.amount ) + with + | Ok debits_pending, Ok credits_pending -> + Ledger.update_account + state + { debit with + debits_pending + ; flags = + (if transfer.flags.closing_debit + then { debit.flags with closed = false } + else debit.flags) + }; + Ledger.update_account + state + { credit with + credits_pending + ; flags = + (if transfer.flags.closing_credit + then { credit.flags with closed = false } + else credit.flags) + }; + Ledger.set_pending state id Expired; + Ledger.remove_expiry state ~expires_at id; + incr expired + | _ -> failwith "pending-balance invariant violated") + | _ -> Ledger.remove_expiry state ~expires_at id) + (Ledger.expired_before state timestamp); + if !expired > 0 then Ledger.set_commit_timestamp state timestamp; !expired ;; diff --git a/ocam/src/state_machine.mli b/ocam/src/state_machine.mli index f9ad3e08..369616e4 100644 --- a/ocam/src/state_machine.mli +++ b/ocam/src/state_machine.mli @@ -1,54 +1,22 @@ (** Deterministic TigerBeetle ledger core. The module deliberately has no Async or storage dependency. Replication assigns - timestamps and calls these functions in commit order; an adapter can then persist - the returned state through the unchanged Zig LSM/VSR implementation. *) + timestamps and calls these functions in commit order; an adapter can then persist the + returned state through the unchanged Zig LSM/VSR implementation. -module U128 : sig - (** An unsigned, fixed-width 128-bit value. + Commit order is a precondition, not a validated input: every [~timestamp] passed to a + mutating operation must exceed [commit_timestamp]. Stored objects are kept in + append-only timestamp indexes, and appending out of order raises [Invalid_argument]. *) - This is used for IDs and monetary amounts. Arithmetic reports overflow or - underflow rather than wrapping. *) - type t +module U128 = U128 - (** The value [0]. *) - val zero : t +(** Numeric result codes matching the pinned TigerBeetle enums. *) +module Result_code = Result_code - (** The largest representable unsigned 128-bit value. *) - val max_value : t - - (** [of_int n] converts non-negative [n], rejecting negative input. *) - val of_int : int -> t - - (** Builds a value from its unsigned high and low 64-bit words. *) - val of_int64_pair : hi:int64 -> lo:int64 -> t - - (** Returns the unsigned high and low 64-bit words. *) - val to_int64_pair : t -> int64 * int64 - - (** Unsigned numeric comparison. *) - val compare : t -> t -> int - - (** Unsigned numeric equality. *) - val equal : t -> t -> bool - - (** Adds two values, reporting [`Overflow] instead of wrapping. *) - val add : t -> t -> (t, [ `Overflow ]) result - - (** Subtracts two values, reporting [`Underflow] when the result is negative. *) - val sub : t -> t -> (t, [ `Underflow ]) result - - (** The smaller of two unsigned values. *) - val min : t -> t -> t - - (** Decimal output for values fitting in 64 bits, hexadecimal otherwise. *) - val to_string : t -> string -end - -(** Account behavior flags. [linked] controls atomic batches; [imported] - changes timestamp validation; [closed] is set by a successful closing - transfer and prevents later transfers involving the account. *) -type account_flags = +(** Account behavior flags. [linked] controls atomic batches; [imported] changes timestamp + validation; [closed] is set by a successful closing transfer and prevents later + transfers involving the account. *) +type account_flags = Types.account_flags = { linked : bool ; debits_must_not_exceed_credits : bool ; credits_must_not_exceed_debits : bool @@ -57,10 +25,9 @@ type account_flags = ; closed : bool } -(** Transfer behavior flags. [post_pending_transfer] and - [void_pending_transfer] cannot both be selected; each resolves an existing - pending transfer. *) -type transfer_flags = +(** Transfer behavior flags. [post_pending_transfer] and [void_pending_transfer] cannot + both be selected; each resolves an existing pending transfer. *) +type transfer_flags = Types.transfer_flags = { linked : bool ; pending : bool ; post_pending_transfer : bool @@ -72,9 +39,9 @@ type transfer_flags = ; imported : bool } -(** An account request and the stored account representation. Account creation - requires zero balance fields; successful transfers update those fields. *) -type account = +(** An account request and the stored account representation. Account creation requires + zero balance fields; successful transfers update those fields. *) +type account = Types.account = { id : U128.t ; debits_pending : U128.t ; debits_posted : U128.t @@ -89,9 +56,9 @@ type account = ; timestamp : int64 } -(** A transfer request and the stored transfer representation. Non-imported - requests must have [timestamp = 0L]; the create operation assigns it. *) -type transfer = +(** A transfer request and the stored transfer representation. Non-imported requests must + have [timestamp = 0L]; the create operation assigns it. *) +type transfer = Types.transfer = { id : U128.t ; debit_account_id : U128.t ; credit_account_id : U128.t @@ -108,13 +75,13 @@ type transfer = } (** Lifecycle state of a pending transfer. *) -type pending_status = +type pending_status = Types.pending_status = | Pending | Posted | Voided | Expired -type create_account_status = +type create_account_status = Types.create_account_status = | Account_created | Account_exists | Account_linked_event_failed @@ -141,7 +108,7 @@ type create_account_status = | Account_imported_timestamp_must_not_advance | Account_imported_timestamp_must_not_regress -type create_transfer_status = +type create_transfer_status = Types.create_transfer_status = | Transfer_created | Transfer_exists | Transfer_linked_event_failed @@ -191,16 +158,16 @@ type create_transfer_status = | Transfer_imported_timestamp_must_not_regress | Transfer_imported_timeout_must_be_zero -(** One result for one create request. Successful requests have their assigned - timestamp; failed requests normally have timestamp zero. *) -type 'status create_result = +(** One result for one create request. Successful requests have their assigned timestamp; + failed requests normally have timestamp zero. *) +type 'status create_result = 'status Types.create_result = { timestamp : int64 ; status : 'status } -(** Filters for account and transfer queries. Zero metadata, ledger, and code - fields are wildcards. A zero timestamp bound is unbounded. *) -type query_filter = +(** Filters for account and transfer queries. Zero metadata, ledger, and code fields are + wildcards. A zero timestamp bound is unbounded. *) +type query_filter = Types.query_filter = { user_data_128 : U128.t ; user_data_64 : int64 ; user_data_32 : int32 @@ -213,7 +180,7 @@ type query_filter = } (** Filters for transfer and balance reads scoped to an account. *) -type account_filter = +type account_filter = Types.account_filter = { account_id : U128.t ; user_data_128 : U128.t ; user_data_64 : int64 @@ -237,8 +204,9 @@ val commit_timestamp : t -> int64 (** Validates and stores account requests in batch order. - Consecutive linked requests are atomic. Each result corresponds to one - request in [account list]. *) + Consecutive linked requests are atomic: their writes are journaled and rolled back if + any request in the chain fails, so the cost of a chain is proportional to the chain, + not to the ledger. Each result corresponds to one request in [account list]. *) val create_accounts : t -> timestamp:int64 @@ -247,16 +215,16 @@ val create_accounts (** Validates and applies transfer requests in batch order. - Normal transfers update posted balances; pending transfers update pending - balances. Consecutive linked requests are atomic. *) + Normal transfers update posted balances; pending transfers update pending balances. + Consecutive linked requests are atomic. *) val create_transfers : t -> timestamp:int64 -> transfer list -> create_transfer_status create_result list -(** Expires pending transfers whose timeout has elapsed at [timestamp], returning - the number expired. *) +(** Expires pending transfers whose timeout has elapsed at [timestamp], returning the + number expired. *) val expire_pending_transfers : t -> timestamp:int64 -> int (** Returns found accounts in the order of requested IDs, omitting unknown IDs. *) @@ -265,13 +233,16 @@ val lookup_accounts : t -> U128.t list -> account list (** Returns found transfers in the order of requested IDs, omitting unknown IDs. *) val lookup_transfers : t -> U128.t list -> transfer list -(** Filters accounts, sorts them by timestamp, then applies [filter.limit]. *) +(** Returns accounts matching [filter] in timestamp order, up to [filter.limit]. Reads + walk a timestamp index, so cost is proportional to the scanned range rather than to + the whole ledger. *) val query_accounts : t -> query_filter -> account list -(** Filters transfers, sorts them by timestamp, then applies [filter.limit]. *) +(** Returns transfers matching [filter] in timestamp order, up to [filter.limit]. *) val query_transfers : t -> query_filter -> transfer list -(** Returns transfers for an account's requested debit and/or credit side. *) +(** Returns transfers for an account's requested debit and/or credit side, read from a + per-account timestamp index. *) val get_account_transfers : t -> account_filter -> transfer list (** Returns per-transfer balance snapshots for an account created with [flags.history]. diff --git a/ocam/src/timeline.ml b/ocam/src/timeline.ml new file mode 100644 index 00000000..5ccb7b9f --- /dev/null +++ b/ocam/src/timeline.ml @@ -0,0 +1,73 @@ +type 'a t = + { mutable entries : (int64 * 'a) array + ; mutable length : int + } + +let create () = { entries = [||]; length = 0 } +let length timeline = timeline.length + +let last_timestamp timeline = + if timeline.length = 0 then None else Some (fst timeline.entries.(timeline.length - 1)) +;; + +let append timeline timestamp value = + (match last_timestamp timeline with + | Some last when Int64.compare timestamp last <= 0 -> + invalid_arg "Timeline.append: timestamps must strictly increase" + | _ -> ()); + let capacity = Array.length timeline.entries in + if timeline.length = capacity + then ( + let grown = Array.make (max 8 (2 * capacity)) (timestamp, value) in + Array.blit timeline.entries 0 grown 0 timeline.length; + timeline.entries <- grown); + timeline.entries.(timeline.length) <- timestamp, value; + timeline.length <- timeline.length + 1 +;; + +let truncate timeline length = + if length < timeline.length + then + if length = 0 + then ( + timeline.entries <- [||]; + timeline.length <- 0) + else ( + Array.fill timeline.entries length (timeline.length - length) timeline.entries.(0); + timeline.length <- length) +;; + +(* Index of the first entry whose timestamp is [>= timestamp], or [length]. *) +let lower_bound timeline timestamp = + let rec search low high = + if low >= high + then low + else ( + let middle = (low + high) / 2 in + if Int64.compare (fst timeline.entries.(middle)) timestamp < 0 + then search (middle + 1) high + else search low middle) + in + search 0 timeline.length +;; + +let to_seq_in_range timeline ~minimum ~maximum ~reversed = + let first = if Int64.equal minimum 0L then 0 else lower_bound timeline minimum in + let stop = + if Int64.equal maximum 0L || Int64.equal maximum Int64.max_int + then timeline.length + else lower_bound timeline (Int64.succ maximum) + in + let entries = timeline.entries in + if reversed + then ( + let rec go index () = + if index < first then Seq.Nil else Seq.Cons (entries.(index), go (index - 1)) + in + go (stop - 1)) + else ( + let rec go index () = + if index >= stop then Seq.Nil else Seq.Cons (entries.(index), go (index + 1)) + in + go first) +;; diff --git a/ocam/src/types.ml b/ocam/src/types.ml new file mode 100644 index 00000000..754afe8b --- /dev/null +++ b/ocam/src/types.ml @@ -0,0 +1,167 @@ +(** Wire-level record and status types shared by the ledger core. *) + +type account_flags = + { linked : bool + ; debits_must_not_exceed_credits : bool + ; credits_must_not_exceed_debits : bool + ; history : bool + ; imported : bool + ; closed : bool + } + +type transfer_flags = + { linked : bool + ; pending : bool + ; post_pending_transfer : bool + ; void_pending_transfer : bool + ; balancing_debit : bool + ; balancing_credit : bool + ; closing_debit : bool + ; closing_credit : bool + ; imported : bool + } + +type account = + { id : U128.t + ; debits_pending : U128.t + ; debits_posted : U128.t + ; credits_pending : U128.t + ; credits_posted : U128.t + ; user_data_128 : U128.t + ; user_data_64 : int64 + ; user_data_32 : int32 + ; ledger : int32 + ; code : int + ; flags : account_flags + ; timestamp : int64 + } + +type transfer = + { id : U128.t + ; debit_account_id : U128.t + ; credit_account_id : U128.t + ; amount : U128.t + ; pending_id : U128.t + ; user_data_128 : U128.t + ; user_data_64 : int64 + ; user_data_32 : int32 + ; timeout : int32 + ; ledger : int32 + ; code : int + ; flags : transfer_flags + ; timestamp : int64 + } + +type pending_status = + | Pending + | Posted + | Voided + | Expired + +type create_account_status = + | Account_created + | Account_exists + | Account_linked_event_failed + | Account_linked_event_chain_open + | Account_imported_event_expected + | Account_imported_event_not_expected + | Account_timestamp_must_be_zero + | Account_id_must_not_be_zero + | Account_id_must_not_be_int_max + | Account_exists_with_different_flags + | Account_exists_with_different_user_data_128 + | Account_exists_with_different_user_data_64 + | Account_exists_with_different_user_data_32 + | Account_exists_with_different_ledger + | Account_exists_with_different_code + | Account_flags_are_mutually_exclusive + | Account_debits_pending_must_be_zero + | Account_debits_posted_must_be_zero + | Account_credits_pending_must_be_zero + | Account_credits_posted_must_be_zero + | Account_ledger_must_not_be_zero + | Account_code_must_not_be_zero + | Account_imported_timestamp_out_of_range + | Account_imported_timestamp_must_not_advance + | Account_imported_timestamp_must_not_regress + +type create_transfer_status = + | Transfer_created + | Transfer_exists + | Transfer_linked_event_failed + | Transfer_linked_event_chain_open + | Transfer_imported_event_expected + | Transfer_imported_event_not_expected + | Transfer_timestamp_must_be_zero + | Transfer_id_must_not_be_zero + | Transfer_id_must_not_be_int_max + | Transfer_id_already_failed + | Transfer_exists_with_different_request + | Transfer_flags_are_mutually_exclusive + | Transfer_debit_account_id_must_not_be_zero + | Transfer_debit_account_id_must_not_be_int_max + | Transfer_credit_account_id_must_not_be_zero + | Transfer_credit_account_id_must_not_be_int_max + | Transfer_accounts_must_be_different + | Transfer_pending_id_must_be_zero + | Transfer_pending_id_must_not_be_zero + | Transfer_pending_id_must_not_be_int_max + | Transfer_pending_id_must_be_different + | Transfer_timeout_reserved_for_pending_transfer + | Transfer_closing_transfer_must_be_pending + | Transfer_ledger_must_not_be_zero + | Transfer_code_must_not_be_zero + | Transfer_debit_account_not_found + | Transfer_credit_account_not_found + | Transfer_accounts_must_have_same_ledger + | Transfer_must_have_same_ledger_as_accounts + | Transfer_pending_transfer_not_found + | Transfer_pending_transfer_not_pending + | Transfer_pending_transfer_has_different_accounts + | Transfer_pending_transfer_has_different_ledger + | Transfer_pending_transfer_has_different_code + | Transfer_exceeds_pending_transfer_amount + | Transfer_pending_transfer_has_different_amount + | Transfer_pending_transfer_already_posted + | Transfer_pending_transfer_already_voided + | Transfer_pending_transfer_expired + | Transfer_account_already_closed + | Transfer_overflows_balance + | Transfer_overflows_timeout + | Transfer_exceeds_credits + | Transfer_exceeds_debits + | Transfer_imported_timestamp_out_of_range + | Transfer_imported_timestamp_must_not_advance + | Transfer_imported_timestamp_must_not_regress + | Transfer_imported_timeout_must_be_zero + +type 'status create_result = + { timestamp : int64 + ; status : 'status + } + +type query_filter = + { user_data_128 : U128.t + ; user_data_64 : int64 + ; user_data_32 : int32 + ; ledger : int32 + ; code : int + ; timestamp_min : int64 + ; timestamp_max : int64 + ; limit : int + ; reversed : bool + } + +type account_filter = + { account_id : U128.t + ; user_data_128 : U128.t + ; user_data_64 : int64 + ; user_data_32 : int32 + ; code : int + ; timestamp_min : int64 + ; timestamp_max : int64 + ; limit : int + ; debits : bool + ; credits : bool + ; reversed : bool + } diff --git a/ocam/src/u128.ml b/ocam/src/u128.ml new file mode 100644 index 00000000..b8f2d5f3 --- /dev/null +++ b/ocam/src/u128.ml @@ -0,0 +1,217 @@ +type t = + { hi : int64 + ; lo : int64 + } + +let zero = { hi = 0L; lo = 0L } +let one = { hi = 0L; lo = 1L } +let max_value = { hi = -1L; lo = -1L } + +let of_int value = + if value < 0 then invalid_arg "U128.of_int: negative value"; + { hi = 0L; lo = Int64.of_int value } +;; + +let of_int64 lo = { hi = 0L; lo } +let of_int64_pair ~hi ~lo = { hi; lo } +let to_int64_pair value = value.hi, value.lo +let to_int64_opt value = if Int64.equal value.hi 0L then Some value.lo else None + +let to_int_opt value = + if Int64.equal value.hi 0L + && Int64.compare value.lo 0L >= 0 + && Int64.compare value.lo (Int64.of_int max_int) <= 0 + then Some (Int64.to_int value.lo) + else None +;; + +let compare a b = + let high = Int64.unsigned_compare a.hi b.hi in + if high <> 0 then high else Int64.unsigned_compare a.lo b.lo +;; + +let equal a b = compare a b = 0 +let is_zero value = Int64.equal value.hi 0L && Int64.equal value.lo 0L +let min a b = if compare a b <= 0 then a else b +let max a b = if compare a b >= 0 then a else b + +let add a b = + let lo = Int64.add a.lo b.lo in + let carry = if Int64.unsigned_compare lo a.lo < 0 then 1L else 0L in + let hi_without_carry = Int64.add a.hi b.hi in + let hi = Int64.add hi_without_carry carry in + let overflow = + Int64.unsigned_compare hi_without_carry a.hi < 0 + || (Int64.equal carry 1L && Int64.unsigned_compare hi hi_without_carry < 0) + in + if overflow then Error `Overflow else Ok { hi; lo } +;; + +let sub a b = + if compare a b < 0 + then Error `Underflow + else ( + let borrow = if Int64.unsigned_compare a.lo b.lo < 0 then 1L else 0L in + Ok { hi = Int64.sub (Int64.sub a.hi b.hi) borrow; lo = Int64.sub a.lo b.lo }) +;; + +let shift_left value bits = + if bits <= 0 + then value + else if bits >= 128 + then zero + else if bits >= 64 + then { hi = Int64.shift_left value.lo (bits - 64); lo = 0L } + else + { hi = + Int64.logor + (Int64.shift_left value.hi bits) + (Int64.shift_right_logical value.lo (64 - bits)) + ; lo = Int64.shift_left value.lo bits + } +;; + +let shift_right value bits = + if bits <= 0 + then value + else if bits >= 128 + then zero + else if bits >= 64 + then { hi = 0L; lo = Int64.shift_right_logical value.hi (bits - 64) } + else + { hi = Int64.shift_right_logical value.hi bits + ; lo = + Int64.logor + (Int64.shift_right_logical value.lo bits) + (Int64.shift_left value.hi (64 - bits)) + } +;; + +let logor a b = { hi = Int64.logor a.hi b.hi; lo = Int64.logor a.lo b.lo } +let logand a b = { hi = Int64.logand a.hi b.hi; lo = Int64.logand a.lo b.lo } + +let bit value index = + if index < 64 + then Int64.equal (Int64.logand (Int64.shift_right_logical value.lo index) 1L) 1L + else Int64.equal (Int64.logand (Int64.shift_right_logical value.hi (index - 64)) 1L) 1L +;; + +let bit_length value = + let rec loop index = + if index < 0 then 0 else if bit value index then index + 1 else loop (index - 1) + in + loop 127 +;; + +(* Splits a 64-bit word into 32-bit halves so partial products fit in [int64]. *) +let low32 word = Int64.logand word 0xffff_ffffL +let high32 word = Int64.shift_right_logical word 32 + +(* Full 64x64 -> 128 product of two unsigned words. *) +let mul_words a b = + let a0 = low32 a + and a1 = high32 a in + let b0 = low32 b + and b1 = high32 b in + let p00 = Int64.mul a0 b0 in + let p01 = Int64.mul a0 b1 in + let p10 = Int64.mul a1 b0 in + let p11 = Int64.mul a1 b1 in + let middle = Int64.add (high32 p00) (low32 p01) in + let middle = Int64.add middle (low32 p10) in + let lo = Int64.logor (Int64.shift_left (low32 middle) 32) (low32 p00) in + let hi = + Int64.add (Int64.add (Int64.add p11 (high32 p01)) (high32 p10)) (high32 middle) + in + { hi; lo } +;; + +let mul a b = + if (not (Int64.equal a.hi 0L)) && not (Int64.equal b.hi 0L) + then Error `Overflow + else ( + let low = mul_words a.lo b.lo in + let cross_a = mul_words a.hi b.lo in + let cross_b = mul_words a.lo b.hi in + if not (Int64.equal cross_a.hi 0L && Int64.equal cross_b.hi 0L) + then Error `Overflow + else ( + match add low { hi = cross_a.lo; lo = 0L } with + | Error `Overflow -> Error `Overflow + | Ok partial -> add partial { hi = cross_b.lo; lo = 0L })) +;; + +let div_rem dividend divisor = + if is_zero divisor + then Error `Division_by_zero + else if compare dividend divisor < 0 + then Ok (zero, dividend) + else ( + let quotient = ref zero in + let remainder = ref zero in + for index = bit_length dividend - 1 downto 0 do + remainder := shift_left !remainder 1; + if bit dividend index then remainder := logor !remainder one; + if compare !remainder divisor >= 0 + then ( + (match sub !remainder divisor with + | Ok value -> remainder := value + | Error `Underflow -> assert false); + quotient := logor !quotient (shift_left one index)) + done; + Ok (!quotient, !remainder)) +;; + +let ten = of_int 10 + +let to_string value = + if Int64.equal value.hi 0L + then Printf.sprintf "%Lu" value.lo + else ( + let digits = Buffer.create 40 in + let rec loop value = + if not (is_zero value) + then ( + match div_rem value ten with + | Ok (quotient, remainder) -> + Buffer.add_char digits (Char.chr (Char.code '0' + Int64.to_int remainder.lo)); + loop quotient + | Error `Division_by_zero -> assert false) + in + loop value; + let length = Buffer.length digits in + String.init length (fun index -> Buffer.nth digits (length - 1 - index))) +;; + +let to_hex_string value = Printf.sprintf "0x%016Lx%016Lx" value.hi value.lo + +let of_string_opt text = + let length = String.length text in + if length = 0 + then None + else ( + let rec loop index accumulator = + if index = length + then Some accumulator + else ( + match text.[index] with + | '0' .. '9' as digit -> + let digit = of_int (Char.code digit - Char.code '0') in + (match mul accumulator ten with + | Error `Overflow -> None + | Ok scaled -> + (match add scaled digit with + | Error `Overflow -> None + | Ok next -> loop (index + 1) next)) + | _ -> None) + in + loop 0 zero) +;; + +let of_string text = + match of_string_opt text with + | Some value -> value + | None -> invalid_arg (Printf.sprintf "U128.of_string: %S" text) +;; + +let hash value = Hashtbl.hash (value.hi, value.lo) diff --git a/ocam/src/u128.mli b/ocam/src/u128.mli new file mode 100644 index 00000000..8c3a2ff3 --- /dev/null +++ b/ocam/src/u128.mli @@ -0,0 +1,84 @@ +(** An unsigned, fixed-width 128-bit value. + + Used for IDs and monetary amounts. Arithmetic reports overflow or underflow rather + than wrapping. *) + +type t + +(** The value [0]. *) +val zero : t + +(** The value [1]. *) +val one : t + +(** The largest representable unsigned 128-bit value, [2^128 - 1]. *) +val max_value : t + +(** [of_int n] converts non-negative [n], rejecting negative input. *) +val of_int : int -> t + +(** [of_int64 w] interprets [w] as an unsigned 64-bit word. *) +val of_int64 : int64 -> t + +(** Builds a value from its unsigned high and low 64-bit words. *) +val of_int64_pair : hi:int64 -> lo:int64 -> t + +(** Returns the unsigned high and low 64-bit words. *) +val to_int64_pair : t -> int64 * int64 + +(** The low word when the value fits in 64 bits (interpreted unsigned). *) +val to_int64_opt : t -> int64 option + +(** The value as a non-negative [int] when it fits. *) +val to_int_opt : t -> int option + +(** Unsigned numeric comparison. *) +val compare : t -> t -> int + +(** Unsigned numeric equality. *) +val equal : t -> t -> bool + +(** [is_zero v] is [equal v zero]. *) +val is_zero : t -> bool + +(** Hash consistent with [equal]. *) +val hash : t -> int + +(** Adds two values, reporting [`Overflow] instead of wrapping. *) +val add : t -> t -> (t, [ `Overflow ]) result + +(** Subtracts two values, reporting [`Underflow] when the result is negative. *) +val sub : t -> t -> (t, [ `Underflow ]) result + +(** Multiplies two values, reporting [`Overflow] instead of wrapping. *) +val mul : t -> t -> (t, [ `Overflow ]) result + +(** [div_rem a b] is [Ok (a / b, a mod b)], or [Error `Division_by_zero]. *) +val div_rem : t -> t -> (t * t, [ `Division_by_zero ]) result + +(** The smaller of two unsigned values. *) +val min : t -> t -> t + +(** The larger of two unsigned values. *) +val max : t -> t -> t + +(** Logical shift left; bits shifted past position 127 are discarded. *) +val shift_left : t -> int -> t + +(** Logical shift right. *) +val shift_right : t -> int -> t + +val logor : t -> t -> t +val logand : t -> t -> t + +(** Decimal representation. *) +val to_string : t -> string + +(** Zero-padded 32-digit hexadecimal representation with a [0x] prefix. *) +val to_hex_string : t -> string + +(** Parses a non-empty decimal string; [None] on malformed input or overflow. *) +val of_string_opt : string -> t option + +(** Like [of_string_opt], raising [Invalid_argument] on failure. *) +val of_string : string -> t diff --git a/ocam/test/dune b/ocam/test/dune index bd3ad0ef..bfb55bb1 100644 --- a/ocam/test/dune +++ b/ocam/test/dune @@ -1,7 +1,8 @@ -(test - (name state_machine_test) - (libraries tigerbeetle_state_machine)) - -(test - (name state_machine_property_test) +(tests + (names + state_machine_test + state_machine_property_test + u128_test + result_code_test + timeline_test) (libraries tigerbeetle_state_machine qcheck)) diff --git a/ocam/test/result_code_test.ml b/ocam/test/result_code_test.ml new file mode 100644 index 00000000..8c7ee9d3 --- /dev/null +++ b/ocam/test/result_code_test.ml @@ -0,0 +1,78 @@ +open Tigerbeetle_state_machine + +let require condition message = if not condition then failwith message + +let test_exact_codes () = + require (Result_code.created_code = 0xffff_ffff) "created code"; + require + (Result_code.account_to_code Account_created = Some Result_code.created_code) + "created"; + require + (Result_code.account_to_code Account_linked_event_failed = Some 1) + "linked failed"; + require (Result_code.account_to_code Account_exists = Some 21) "account exists"; + require + (Result_code.transfer_to_code Transfer_created = Some Result_code.created_code) + "transfer created"; + require (Result_code.transfer_to_code Transfer_exists = Some 46) "transfer exists"; + require + (Result_code.transfer_to_code Transfer_exceeds_credits = Some 54) + "exceeds credits"; + require + (Result_code.transfer_to_code Transfer_pending_transfer_already_posted = Some 33) + "already posted"; + require (Result_code.account_of_code 2 = Some Account_linked_event_chain_open) "decode"; + require + (Result_code.transfer_to_code Transfer_pending_id_must_be_zero = Some 13) + "pending id zero"; + require (Result_code.transfer_of_code 0xffff = None) "unknown decode" +;; + +let test_coarse_codes () = + require + (Result_code.transfer_to_code Transfer_overflows_balance = None) + "coarse status has no exact code"; + require + (List.length (Result_code.transfer_codes Transfer_overflows_balance) > 1) + "coarse status lists several codes"; + List.iter + (fun status -> + let codes = Result_code.transfer_codes status in + require (codes <> []) "every transfer status maps to a code"; + List.iter + (fun code -> + require + (Result_code.transfer_of_code code = Some status) + "transfer codes decode back") + codes) + Result_code.transfer_statuses; + List.iter + (fun status -> + let codes = Result_code.account_codes status in + require (codes <> []) "every account status maps to a code"; + List.iter + (fun code -> + require + (Result_code.account_of_code code = Some status) + "account codes decode back") + codes) + Result_code.account_statuses +;; + +let test_codes_unique () = + let all_codes statuses codes = List.concat_map codes statuses in + let unique codes = List.length (List.sort_uniq compare codes) = List.length codes in + require + (unique (all_codes Result_code.account_statuses Result_code.account_codes)) + "account codes are disjoint"; + require + (unique (all_codes Result_code.transfer_statuses Result_code.transfer_codes)) + "transfer codes are disjoint" +;; + +let () = + test_exact_codes (); + test_coarse_codes (); + test_codes_unique (); + print_endline "result code tests passed" +;; diff --git a/ocam/test/state_machine_property_test.ml b/ocam/test/state_machine_property_test.ml index 1218f308..9fc3dd2d 100644 --- a/ocam/test/state_machine_property_test.ml +++ b/ocam/test/state_machine_property_test.ml @@ -43,14 +43,14 @@ let account ?(user_data_64 = 0L) id = ;; let transfer - ?(debit_account_id = 1) - ?(credit_account_id = 2) - ?(user_data_64 = 0L) - ?(flags = transfer_flags ()) - ?(pending_id = U128.zero) - ?(timeout = 0l) - ~amount - id + ?(debit_account_id = 1) + ?(credit_account_id = 2) + ?(user_data_64 = 0L) + ?(flags = transfer_flags ()) + ?(pending_id = U128.zero) + ?(timeout = 0l) + ~amount + id = { id = u128 id ; debit_account_id = u128 debit_account_id @@ -108,32 +108,32 @@ let run_commands state commands = ignore (create_accounts state ~timestamp:1L [ account 1; account 2 ]); List.iteri (fun index command -> - let debit_to_credit, amount = command in - let debit_account_id, credit_account_id = if debit_to_credit then 1, 2 else 2, 1 in - ignore - (create_transfers - state - ~timestamp:(Int64.of_int (index + 3)) - [ transfer ~debit_account_id ~credit_account_id ~amount (index + 10) ])) + let debit_to_credit, amount = command in + let debit_account_id, credit_account_id = if debit_to_credit then 1, 2 else 2, 1 in + ignore + (create_transfers + state + ~timestamp:(Int64.of_int (index + 3)) + [ transfer ~debit_account_id ~credit_account_id ~amount (index + 10) ])) commands ;; let account_snapshot state = List.map (fun (account : account) -> - ( U128.to_string account.id - , U128.to_string account.debits_pending - , U128.to_string account.debits_posted - , U128.to_string account.credits_pending - , U128.to_string account.credits_posted - , account.timestamp )) + ( U128.to_string account.id + , U128.to_string account.debits_pending + , U128.to_string account.debits_posted + , U128.to_string account.credits_pending + , U128.to_string account.credits_posted + , account.timestamp )) (lookup_accounts state [ u128 1; u128 2 ]) ;; let transfer_snapshot state commands = List.map (fun (transfer : transfer) -> - U128.to_string transfer.id, U128.to_string transfer.amount, transfer.timestamp) + U128.to_string transfer.id, U128.to_string transfer.amount, transfer.timestamp) (lookup_transfers state (List.init (List.length commands) (fun index -> u128 (index + 10)))) @@ -228,73 +228,73 @@ let pending_post_void_and_expiry = (QCheck.int_range 0 1_000) (QCheck.int_range 0 1_000)) (fun (post_amount, void_amount, expire_amount) -> - let state = empty () in - ignore (create_accounts state ~timestamp:1L [ account 1; account 2 ]); - let pending id amount timeout = - transfer - ~flags:(transfer_flags ~pending:true ()) - ~timeout:(Int32.of_int timeout) - ~amount - id - in - let first = - exactly_one (create_transfers state ~timestamp:2L [ pending 10 post_amount 0 ]) - in - let second = - exactly_one (create_transfers state ~timestamp:3L [ pending 11 void_amount 0 ]) - in - let third = - exactly_one (create_transfers state ~timestamp:4L [ pending 12 expire_amount 1 ]) - in - let post = - exactly_one - (create_transfers - state - ~timestamp:5L - [ transfer - ~flags:(transfer_flags ~post:true ()) - ~pending_id:(u128 10) - ~amount:post_amount - 20 - ]) - in - let void = - exactly_one - (create_transfers - state - ~timestamp:6L - [ transfer - ~flags:(transfer_flags ~void:true ()) - ~pending_id:(u128 11) - ~amount:0 - 21 - ]) - in - let expired = expire_pending_transfers state ~timestamp:1_000_000_004L in - let post_expired = - exactly_one - (create_transfers - state - ~timestamp:1_000_000_005L - [ transfer - ~flags:(transfer_flags ~post:true ()) - ~pending_id:(u128 12) - ~amount:expire_amount - 22 - ]) - in - status_is Transfer_created first - && status_is Transfer_created second - && status_is Transfer_created third - && status_is Transfer_created post - && status_is Transfer_created void - && expired = 1 - && status_is Transfer_pending_transfer_expired post_expired - && U128.equal (account_of state 1).debits_pending U128.zero - && U128.equal (account_of state 2).credits_pending U128.zero - && U128.equal (account_of state 1).debits_posted (u128 post_amount) - && U128.equal (account_of state 2).credits_posted (u128 post_amount) - && balances_are_conserved state [ 1; 2 ]) + let state = empty () in + ignore (create_accounts state ~timestamp:1L [ account 1; account 2 ]); + let pending id amount timeout = + transfer + ~flags:(transfer_flags ~pending:true ()) + ~timeout:(Int32.of_int timeout) + ~amount + id + in + let first = + exactly_one (create_transfers state ~timestamp:2L [ pending 10 post_amount 0 ]) + in + let second = + exactly_one (create_transfers state ~timestamp:3L [ pending 11 void_amount 0 ]) + in + let third = + exactly_one (create_transfers state ~timestamp:4L [ pending 12 expire_amount 1 ]) + in + let post = + exactly_one + (create_transfers + state + ~timestamp:5L + [ transfer + ~flags:(transfer_flags ~post:true ()) + ~pending_id:(u128 10) + ~amount:post_amount + 20 + ]) + in + let void = + exactly_one + (create_transfers + state + ~timestamp:6L + [ transfer + ~flags:(transfer_flags ~void:true ()) + ~pending_id:(u128 11) + ~amount:0 + 21 + ]) + in + let expired = expire_pending_transfers state ~timestamp:1_000_000_004L in + let post_expired = + exactly_one + (create_transfers + state + ~timestamp:1_000_000_005L + [ transfer + ~flags:(transfer_flags ~post:true ()) + ~pending_id:(u128 12) + ~amount:expire_amount + 22 + ]) + in + status_is Transfer_created first + && status_is Transfer_created second + && status_is Transfer_created third + && status_is Transfer_created post + && status_is Transfer_created void + && expired = 1 + && status_is Transfer_pending_transfer_expired post_expired + && U128.equal (account_of state 1).debits_pending U128.zero + && U128.equal (account_of state 2).credits_pending U128.zero + && U128.equal (account_of state 1).debits_posted (u128 post_amount) + && U128.equal (account_of state 2).credits_posted (u128 post_amount) + && balances_are_conserved state [ 1; 2 ]) ;; let query_input = diff --git a/ocam/test/state_machine_test.ml b/ocam/test/state_machine_test.ml index 1c17f69e..cb73a5bf 100644 --- a/ocam/test/state_machine_test.ml +++ b/ocam/test/state_machine_test.ml @@ -13,14 +13,14 @@ let account_flags ?(linked = false) () = ;; let transfer_flags - ?(linked = false) - ?(pending = false) - ?(post_pending_transfer = false) - ?(void_pending_transfer = false) - ?(closing_debit = false) - ?(closing_credit = false) - ?(imported = false) - () + ?(linked = false) + ?(pending = false) + ?(post_pending_transfer = false) + ?(void_pending_transfer = false) + ?(closing_debit = false) + ?(closing_credit = false) + ?(imported = false) + () = { linked ; pending @@ -51,12 +51,12 @@ let account ?(linked = false) id = ;; let transfer - ?(flags = transfer_flags ()) - ?(pending_id = U128.zero) - ?(amount = 10) - ?(timeout = 0l) - ?(timestamp = 0L) - id + ?(flags = transfer_flags ()) + ?(pending_id = U128.zero) + ?(amount = 10) + ?(timeout = 0l) + ?(timestamp = 0L) + id = { id = u128 id ; debit_account_id = u128 1 @@ -527,6 +527,70 @@ let test_post_pending_retry_and_balance_history () = "credit-only filter should exclude debit events" ;; +let test_failed_chain_leaves_no_index_entries () = + let state = empty () in + ignore (create_accounts state ~timestamp:1L [ account 1; account 2 ]); + ignore (create_transfers state ~timestamp:3L [ transfer 10 ]); + let before_transfers = lookup_transfers state [ u128 10 ] in + let pending = transfer ~flags:(transfer_flags ~linked:true ~pending:true ()) 20 in + let bad = { (transfer ~flags:(transfer_flags ~linked:true ()) 21) with ledger = 0l } in + let results = create_transfers state ~timestamp:5L [ pending; bad; transfer 22 ] in + require + (List.map (fun result -> result.status) results + = [ Transfer_linked_event_failed + ; Transfer_ledger_must_not_be_zero + ; Transfer_linked_event_failed + ]) + "chain statuses"; + let query = + { user_data_128 = U128.zero + ; user_data_64 = 0L + ; user_data_32 = 0l + ; ledger = 0l + ; code = 0 + ; timestamp_min = 0L + ; timestamp_max = 0L + ; limit = 100 + ; reversed = false + } + in + let account_filter = + { account_id = u128 1 + ; user_data_128 = U128.zero + ; user_data_64 = 0L + ; user_data_32 = 0l + ; code = 0 + ; timestamp_min = 0L + ; timestamp_max = 0L + ; limit = 100 + ; debits = true + ; credits = true + ; reversed = false + } + in + require (query_transfers state query = before_transfers) "timestamp index rolled back"; + require + (get_account_transfers state account_filter = before_transfers) + "account index rolled back"; + require + (List.length (get_account_balances state account_filter) = 1) + "history index rolled back"; + require + (lookup_transfers state [ u128 20; u128 21; u128 22 ] = []) + "no stored transfers"; + require_u128 0 (account_of state 1).debits_pending "pending balance rolled back"; + require (commit_timestamp state = 3L) "commit timestamp rolled back"; + require + (expire_pending_transfers state ~timestamp:Int64.max_int = 0) + "no expiry entries"; + let after = create_transfers state ~timestamp:8L [ transfer 30 ] in + require ((List.hd after).status = Transfer_created) "state usable after rollback"; + require + (List.map (fun (t : transfer) -> t.timestamp) (query_transfers state query) + = [ 3L; 8L ]) + "index continues after rollback" +;; + let () = test_single_phase (); test_pending_post_and_void (); @@ -536,5 +600,6 @@ let () = test_batch_compatibility_and_linked_failure_ids (); test_timeout_validation_and_closing_expiry (); test_post_pending_retry_and_balance_history (); + test_failed_chain_leaves_no_index_entries (); print_endline "state_machine equivalence scenarios: ok" ;; diff --git a/ocam/test/timeline_test.ml b/ocam/test/timeline_test.ml new file mode 100644 index 00000000..4b0b5d77 --- /dev/null +++ b/ocam/test/timeline_test.ml @@ -0,0 +1,39 @@ +open Tigerbeetle_state_machine + +let require condition message = if not condition then failwith message + +let range timeline ?(reversed = false) minimum maximum = + Timeline.to_seq_in_range timeline ~minimum ~maximum ~reversed + |> List.of_seq + |> List.map snd +;; + +let () = + let timeline = Timeline.create () in + require (range timeline 0L 0L = []) "empty timeline"; + List.iter + (fun n -> Timeline.append timeline (Int64.of_int (n * 10)) n) + [ 1; 2; 3; 4; 5 ]; + require (Timeline.length timeline = 5) "length"; + require (range timeline 0L 0L = [ 1; 2; 3; 4; 5 ]) "unbounded"; + require (range timeline 20L 40L = [ 2; 3; 4 ]) "inclusive bounds"; + require (range timeline 21L 39L = [ 3 ]) "bounds between entries"; + require (range timeline ~reversed:true 20L 40L = [ 4; 3; 2 ]) "reversed"; + require (range timeline 60L 0L = []) "minimum past the end"; + require (range timeline 0L 5L = []) "maximum before the start"; + require (range timeline 0L Int64.max_int = [ 1; 2; 3; 4; 5 ]) "maximum at int64 max"; + require + (match Timeline.append timeline 50L 6 with + | () -> false + | exception Invalid_argument _ -> true) + "out-of-order append is rejected"; + Timeline.truncate timeline 2; + require (range timeline 0L 0L = [ 1; 2 ]) "truncate keeps the prefix"; + Timeline.append timeline 25L 7; + require (range timeline 0L 0L = [ 1; 2; 7 ]) "append after truncate"; + Timeline.truncate timeline 0; + require (Timeline.length timeline = 0 && range timeline 0L 0L = []) "truncate to empty"; + Timeline.append timeline 1L 8; + require (range timeline 1L 1L = [ 8 ]) "append after emptying"; + print_endline "timeline tests passed" +;; diff --git a/ocam/test/u128_test.ml b/ocam/test/u128_test.ml new file mode 100644 index 00000000..811942ec --- /dev/null +++ b/ocam/test/u128_test.ml @@ -0,0 +1,95 @@ +open Tigerbeetle_state_machine + +let require condition message = if not condition then failwith message +let max_decimal = "340282366920938463463374607431768211455" +let two_pow_64 = U128.of_int64_pair ~hi:1L ~lo:0L + +let test_constants () = + require (U128.to_string U128.max_value = max_decimal) "max_value decimal"; + require (U128.to_string U128.zero = "0") "zero decimal"; + require (U128.to_string two_pow_64 = "18446744073709551616") "2^64 decimal"; + require + (U128.to_hex_string U128.max_value = "0xffffffffffffffffffffffffffffffff") + "max_value hex"; + require (U128.equal (U128.of_string max_decimal) U128.max_value) "parse max"; + require (U128.of_string_opt "340282366920938463463374607431768211456" = None) "overflow"; + require (U128.of_string_opt "" = None) "empty"; + require (U128.of_string_opt "12a" = None) "malformed"; + require (U128.to_int_opt (U128.of_int 42) = Some 42) "to_int_opt small"; + require (U128.to_int_opt two_pow_64 = None) "to_int_opt large"; + require (U128.to_int64_opt (U128.of_int64 (-1L)) = Some (-1L)) "to_int64_opt unsigned" +;; + +let test_arithmetic_edges () = + require (U128.add U128.max_value U128.one = Error `Overflow) "add overflow"; + require (U128.sub U128.zero U128.one = Error `Underflow) "sub underflow"; + require + (U128.add (U128.of_int64 (-1L)) U128.one = Ok two_pow_64) + "carry into the high word"; + require (U128.sub two_pow_64 U128.one = Ok (U128.of_int64 (-1L))) "borrow from high"; + require (U128.mul two_pow_64 two_pow_64 = Error `Overflow) "mul overflow both high"; + require + (U128.mul (U128.of_int64 (-1L)) (U128.of_int64 (-1L)) + = Ok (U128.of_int64_pair ~hi:(-2L) ~lo:1L)) + "(2^64-1)^2"; + require (U128.mul U128.max_value U128.one = Ok U128.max_value) "mul identity"; + require (U128.mul U128.max_value (U128.of_int 2) = Error `Overflow) "mul max by two"; + require (U128.div_rem U128.one U128.zero = Error `Division_by_zero) "div by zero"; + require + (U128.div_rem U128.max_value two_pow_64 = Ok (U128.of_int64 (-1L), U128.of_int64 (-1L)) + ) + "max / 2^64"; + require (U128.shift_left U128.one 64 = two_pow_64) "shift_left 64"; + require (U128.shift_right two_pow_64 64 = U128.one) "shift_right 64"; + require (U128.shift_left U128.one 128 = U128.zero) "shift out"; + require (U128.compare U128.max_value U128.zero > 0) "unsigned compare"; + require (U128.max U128.max_value U128.zero = U128.max_value) "max" +;; + +let small = QCheck.Gen.(map (fun n -> abs n) (int_bound (1 lsl 30))) +let u128_small = QCheck.make ~print:string_of_int small + +let property name generator property = + QCheck.Test.make ~count:500 ~name generator property +;; + +let properties = + [ property "add matches int" (QCheck.pair u128_small u128_small) (fun (a, b) -> + U128.add (U128.of_int a) (U128.of_int b) = Ok (U128.of_int (a + b))) + ; property "mul matches int" (QCheck.pair u128_small u128_small) (fun (a, b) -> + U128.mul (U128.of_int a) (U128.of_int b) = Ok (U128.of_int (a * b))) + ; property "div_rem matches int" (QCheck.pair u128_small u128_small) (fun (a, b) -> + b = 0 + || U128.div_rem (U128.of_int a) (U128.of_int b) + = Ok (U128.of_int (a / b), U128.of_int (a mod b))) + ; property "decimal round trip" (QCheck.pair u128_small u128_small) (fun (hi, lo) -> + let value = U128.of_int64_pair ~hi:(Int64.of_int hi) ~lo:(Int64.of_int lo) in + U128.of_string_opt (U128.to_string value) = Some value) + ; property "div_rem reconstructs" (QCheck.pair u128_small u128_small) (fun (hi, b) -> + b = 0 + || + let a = U128.of_int64_pair ~hi:(Int64.of_int hi) ~lo:(Int64.of_int (hi * 7919)) in + let divisor = U128.of_int b in + match U128.div_rem a divisor with + | Error `Division_by_zero -> false + | Ok (quotient, remainder) -> + U128.compare remainder divisor < 0 + && + (match U128.mul quotient divisor with + | Error `Overflow -> false + | Ok product -> U128.add product remainder = Ok a)) + ] +;; + +let () = + test_constants (); + test_arithmetic_edges (); + let failures = + QCheck_runner.run_tests + ~verbose:true + ~rand:(Random.State.make [| 1; 2; 8 |]) + properties + in + if failures <> 0 then exit 1; + print_endline "u128 tests passed" +;; diff --git a/ocam/tigerbeetle_ocaml.opam b/ocam/tigerbeetle_ocaml.opam index 35fb0706..f5c2b7b0 100644 --- a/ocam/tigerbeetle_ocaml.opam +++ b/ocam/tigerbeetle_ocaml.opam @@ -1,11 +1,15 @@ # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "OCaml ledger state machine for the pinned TigerBeetle source tree" +maintainer: ["gpu004"] +authors: ["gpu004"] +license: "Apache-2.0" +homepage: "https://github.com/gpu004/6666" +bug-reports: "https://github.com/gpu004/6666/issues" depends: [ "dune" {>= "3.11"} "ocaml" {>= "5.2"} "oxcaml" - "base" "qcheck" {with-test} "odoc" {with-doc} ] @@ -23,3 +27,4 @@ build: [ "@doc" {with-doc} ] ] +dev-repo: "git+https://github.com/gpu004/6666.git" diff --git a/zoom-out.html b/zoom-out.html deleted file mode 100644 index d4a85e20..00000000 --- a/zoom-out.html +++ /dev/null @@ -1,90 +0,0 @@ - - - - - - OCaml ledger core: zoomed-out map - - - -
-

OCaml ledger core: zoomed-out map

-

A map of the experimental TigerBeetle-compatible ledger core, its callers, and its unimplemented integration boundary.

- -

Scope and boundary

-

This repository implements a deterministic, in-memory portion of TigerBeetle’s ledger state machine. It is not a TigerBeetle server. The pinned source at path/to/tigerbeetle/ remains the behavior oracle.

-

The public library is tigerbeetle_ocaml.state_machine, implemented by ocam/src/state_machine.ml. The core has no storage, network, clock, Async, C-ABI, or wire-codec dependency. A future adapter must supply replication commit timestamps, call it in commit order, and persist the result.

- -

Module and caller map

-
-
Scenario tests
QCheck property tests
Benchmark
-
↓ all call the public State_machine API ↓
-
Batch and linked-chain executor
Lookup and query reads
Pending-transfer expiry
-
↓ batch execution delegates to ↓
-
Account validation and storage
Transfer validation and balance updates
Pending lifecycle
-
↓ all operate on the in-memory ledger state ↓
-
Accounts table
Transfers table
Pending-status table and commit timestamp
-
-

The pinned Zig state machine is a behavior reference only. There are no production/server callers of the OCaml API yet.

- - - - - - - - - - - - -
AreaFileRole
Public model and APIocam/src/state_machine.mliDefines U128, ledger records, flags, statuses, filters, state, and operations.
Deterministic coreocam/src/state_machine.mlImplements accounting behavior and maintains the in-memory state.
Scenario callersocam/test/state_machine_test.mlCovers normal transfers, pending post/void, linked rollback, and validation precedence.
Property callersocam/test/state_machine_property_test.mlChecks determinism, conservation, idempotency, atomicity, lifecycle, ordering, and U128 boundaries.
Benchmark callerocam/bench/state_machine_bench.mlMeasures throughput, latency, and allocation for 30,000 prebuilt posted transfers in batches of 30.
Dune wiringocam/src/dune, ocam/test/dune, ocam/bench/duneBuilds the library, tests, and benchmark.
Behavior oraclepath/to/tigerbeetle/src/state_machine.zigUpstream LSM/VSR-integrated state machine; not called by the OCaml core.
- -

Domain model

-

State_machine.t owns accounts and transfers keyed by U128 ID, pending-transfer status (Pending, Posted, Voided, or Expired), balance history for history-enabled accounts, transiently failed transfer IDs, and the latest successful commit_timestamp. U128 arithmetic reports overflow or underflow rather than wrapping.

- - - -
Debit sideCredit side
debits_pendingcredits_pending
debits_postedcredits_posted
-

Normal transfers update posted balances; pending transfers update pending balances. Successful transfers conserve total debit and credit balances in both classes.

- -

Write path

-
    -
  1. chains groups adjacent linked requests.
    2. -
  2. Unlinked requests execute directly; linked chains execute against cloned state.
    3. -
  3. A successful chain replaces live state. On failure, the failing event keeps its status and all others become *_linked_event_failed.
    4. -
  4. An ending linked flag rejects only the open suffix; complete prefix chains remain committed.
    5. -
-

create_account_one validates account identity, initial balances, account constraints, idempotent retries, and timestamp semantics. create_transfer_one validates identity, accounts, ledger agreement, closure, balance constraints, timestamps, and arithmetic. post_or_void resolves a pending transfer; expire_pending_transfers expires timed-out transfers and removes their pending balances.

- -

Read path

- - - - - - - - -
OperationMeaning
lookup_accounts, lookup_transfersReturn found records in requested ID order and omit unknown IDs.
query_accounts, query_transfersFilter, timestamp-sort, optionally reverse, then limit.
get_account_transfersReturn debit-side and/or credit-side transfers for an account.
get_account_balancesReturn filtered per-transfer balance snapshots for a history-enabled account.
- -

Compatibility boundary

-

The upstream Zig state machine is integrated with TigerBeetle’s LSM forest, VSR replication, and wire/storage structures. The OCaml core is not linked into that path. Remaining work includes a C ABI, 128-byte wire-compatible codecs, full differential testing, exact result-code encoding, CDC objects, and additional imported/query/expiry edge cases. The maintained scope is in ocam/OCAML_REWRITE.md.

-
- - diff --git a/zoom-out.md b/zoom-out.md deleted file mode 100644 index a3c14c1d..00000000 --- a/zoom-out.md +++ /dev/null @@ -1,123 +0,0 @@ -# OCaml ledger core: zoomed-out map - -## Scope and boundary - -This repository experiments with an OCaml implementation of part of -TigerBeetle’s ledger state machine. The implementation is a deterministic, -in-memory core, not a TigerBeetle server. The pinned upstream source at -`path/to/tigerbeetle/` is the behavior oracle. - -The public library is `tigerbeetle_ocaml.state_machine`, implemented in -`ocam/src/state_machine.ml` and described by `ocam/src/state_machine.mli`. -The core has no storage, network, clock, Async, C-ABI, or wire-codec -dependency. A future adapter must receive replication commits, provide their -timestamps, invoke the core in commit order, and persist the result. - -## Module and caller map - -```mermaid -flowchart TD - Tests["Scenario and QCheck tests"] --> API["State_machine public API"] - Bench["State-machine benchmark"] --> API - API --> Batch["Batch and linked-chain executor"] - Batch --> Accounts["Account validation and storage"] - Batch --> Transfers["Transfer validation and balance updates"] - Transfers --> Pending["Pending lifecycle"] - API --> Reads["Lookup and query reads"] - API --> Expiry["Pending-transfer expiry"] - Accounts --> State["In-memory ledger state"] - Transfers --> State - Pending --> State - Oracle["Pinned Zig state machine"] -. "behavior reference only" .-> API -``` - -| Area | Relevant module or file | Role | -| --- | --- | --- | -| Public model and API | `ocam/src/state_machine.mli` | Defines `U128`, account and transfer records, flags, statuses, filters, state, and public operations. | -| Deterministic core | `ocam/src/state_machine.ml` | Implements all accounting behavior and maintains the in-memory state. | -| Scenario callers | `ocam/test/state_machine_test.ml` | Covers single-phase transfers, pending post/void, linked rollback, and validation precedence. | -| Property callers | `ocam/test/state_machine_property_test.ml` | Checks determinism, balance conservation, idempotency, linked atomicity, pending lifecycle, query ordering, and `U128` boundaries. | -| Benchmark caller | `ocam/bench/state_machine_bench.ml` | Applies 30,000 prebuilt posted transfers in batches of 30 and reports throughput, latency, and allocation. | -| Dune wiring | `ocam/src/dune`, `ocam/test/dune`, `ocam/bench/dune` | Builds the library, tests, and benchmark. | -| Behavior oracle | `path/to/tigerbeetle/src/state_machine.zig` | The upstream state machine coupled to TigerBeetle’s LSM, VSR, and wire-level components. It is not called by the OCaml core. | - -There are no production/server callers of the OCaml API yet. Dune currently -builds only the OCaml library and its test/benchmark consumers. - -## Domain model - -`State_machine.t` owns the ledger's mutable state: - -- accounts, keyed by `U128` account ID; -- transfers, keyed by `U128` transfer ID; -- pending-transfer status: `Pending`, `Posted`, `Voided`, or `Expired`; -- per-transfer balance history for history-enabled accounts; -- transfer IDs consumed by transient failures; and -- the most recent successful `commit_timestamp`. - -`U128` is an explicit unsigned 128-bit value used for account/transfer IDs and -amounts. Addition and subtraction report overflow or underflow; they never -silently wrap. - -An account has four monotonic balances: - -| Debit side | Credit side | -| --- | --- | -| `debits_pending` | `credits_pending` | -| `debits_posted` | `credits_posted` | - -Successful normal transfers update posted balances. Successful pending -transfers update pending balances. Across successful transfers, total debits -and credits remain equal for both balance classes. - -## Write path - -`create_accounts` and `create_transfers` are the public batch boundaries. - -1. `chains` groups adjacent requests marked `linked`. -2. A single unlinked request runs directly. A linked chain runs against a - cloned ledger state. -3. On success, `replace_state` commits the clone. On any failure, the failed - request retains its status and every other event in the chain becomes - `*_linked_event_failed`. -4. A final `linked` request leaves an open chain; complete prefix chains still - commit, while only the open suffix is rejected. - -### Account creation - -`create_account_one` validates non-zero IDs, ledger, and code; requires zero -initial balances; applies the mutually exclusive balance-constraint flags; -and handles exact idempotent retries. For ordinary accounts, the request -timestamp must be zero and the supplied commit timestamp is assigned. Imported -accounts carry their own timestamp, subject to ordering constraints. - -### Transfer creation and resolution - -`create_transfer_one` handles ordinary and pending transfers. It validates -transfer identity, account identity and existence, ledger agreement, account -closure, amount/balance constraints, timestamps, and arithmetic before it -updates state. - -`post_or_void` resolves an existing pending transfer. Posting removes the -original pending amount and adds the resolved amount to posted balances. -Voiding removes pending balances without adding posted balances. A pending -transfer may also be `Expired` by `expire_pending_transfers`, which removes -the pending balances and prevents later post or void requests. - -## Read path - -| Operation | Meaning | -| --- | --- | -| `lookup_accounts`, `lookup_transfers` | Return found records in requested ID order; omit unknown IDs. | -| `query_accounts`, `query_transfers` | Filter metadata, ledger, code, and timestamp; sort by timestamp; reverse if requested; apply the limit. | -| `get_account_transfers` | Return debit-side and/or credit-side transfers for one account. | -| `get_account_balances` | Return filtered per-transfer balance snapshots for a history-enabled account. | - -## Compatibility boundary - -The upstream Zig state machine uses explicit wire/storage structures and is -integrated with the LSM forest and VSR replication. The OCaml core is not yet -linked into that path. Remaining integration work includes a C ABI, -wire-compatible 128-byte codecs, a complete differential corpus, exact result -code encoding, CDC objects, and further imported/query/expiry edge -cases. See `ocam/OCAML_REWRITE.md` for the maintained compatibility scope.