diff options
66 files changed, 701 insertions, 2765 deletions
diff --git a/docs/join-strategies.md b/docs/join-strategies.md deleted file mode 100644 index 049aad7..0000000 --- a/docs/join-strategies.md +++ /dev/null @@ -1,305 +0,0 @@ -# Join Strategies in the Tarski FOL Runtime - -This document covers the join operators available or planned for the Tarski -Volcano engine, their memory and I/O characteristics, and the role that backend -indexes play in making large-relation joins practical. - ---- - -## Current implementation: nested-loop join - -The current `JOIN` node is a classic nested-loop join. - -``` -for each outer (left) tuple L: - reset inner (right) cursor to offset 0 - for each inner tuple R: - if join condition holds: emit merge(L, R) -``` - -**Memory**: O(1). The left cursor holds one page (one tuple at `PAGE_SIZE = 1`). -The right cursor also holds one page at a time; `ResetInner` clears the page and -resets `fetch_offset` to 0 so the backend re-reads from the start for each outer -tuple. Neither side is ever materialized in full. - -**I/O**: O(n × m) backend reads. The right relation is scanned once per outer -tuple, so a billion-row right side costs a billion backend reads per outer tuple. - -**Best case**: ephemeral relations (builtins like `eq`, `lt`, etc.) on the right -side. These run the generator function in O(1) with no backend I/O. The join -degenerates into a streamed filter. - -**Worst case**: two large stored relations with no index. Acceptable only when -one side is small, or when the right side fits in the OS page cache. - ---- - -## Index nested-loop join - -The most practical improvement. If Sakura exposes a B+ tree index on the join -attribute of the right relation, the inner loop becomes a point lookup instead -of a full scan. - -``` -for each outer tuple L: - key = L[join_attr] - R = backend.Lookup(right_relation, join_attr, key) // O(log m) - if R exists: emit merge(L, R) -``` - -**Memory**: O(1). Same as nested-loop — no buffering on either side. - -**I/O**: O(n log m). Each outer tuple triggers one B+ tree traversal on the right. - -**Backend requirement**: `IStorageBackend` would need a new method: - -```cpp -virtual std::vector<std::string> TupleHashesByKey( - const std::vector<std::string>& relation_path, - const std::string& attribute, - const std::string& value, - std::size_t offset, - std::size_t limit) = 0; -``` - -Sakura already maintains a per-relation B+ tree of tuple hashes. An additional -B+ tree keyed by attribute value is the natural extension and mirrors how most -production storage engines implement secondary indexes. - -This is the correct long-term default join strategy for stored × stored joins. - ---- - -## Sort-merge join - -Both inputs are scanned once in sorted order, advancing a cursor on each side -in lock-step. - -``` -L = Next(left) -R = Next(right) -while L and R: - if L[key] == R[key]: emit merge(L, R); advance both - if L[key] < R[key]: L = Next(left) - if L[key] > R[key]: R = Next(right) -``` - -**Memory**: O(1) if both inputs arrive pre-sorted. The Volcano model handles -page boundaries transparently — each `Next()` call fetches the next page from -the backend when the current page is exhausted, independent of the other cursor. -There is no synchronization problem at the page level; the operator logic only -ever holds two tuples at a time. - -**I/O**: O(n + m). Each relation is scanned exactly once. - -**Requirement**: both inputs must be sorted on the join attribute before the -merge step. This means either: -- The backend returns tuples in sorted attribute order (sorted scan support), or -- A `SORT` operator precedes each input in the plan tree. - -Sorting an unsorted relation requires O(n log n) time and — unless done via an -external merge sort that stays within a fixed memory budget — O(n) memory. -Sakura's B+ tree already imposes an ordering on stored tuple hashes; whether -that ordering corresponds to an attribute value ordering depends on the index -structure. - ---- - -## Hash join - -Build a hash table from the smaller relation, probe with the larger. - -``` -phase 1 — build: for each R: insert R into hash_table[R[key]] -phase 2 — probe: for each L: for each match in hash_table[L[key]]: emit merge(L, R) -``` - -**Memory**: O(min(n, m)). The build side must fit entirely in memory. Fails -under memory pressure for large relations. - -**I/O**: O(n + m) — each relation scanned once. - -This is the right choice when the build side is small and fits in RAM. Not -suitable as a general-purpose operator in a constant-memory runtime. - ---- - -## Grace hash join (partitioned hash join) - -An extension of hash join that handles larger-than-memory relations by -partitioning both sides into buckets that individually fit in memory. - -``` -phase 1 — partition: hash each side into k buckets written to temporary storage -phase 2 — join: for each bucket pair (left_i, right_i): in-memory hash join -``` - -**Memory**: O(√(n + m)) with optimal bucket count. Bounded but not O(1). - -**I/O**: O(3(n + m)) — three full passes over the data. - -Requires a writable temporary storage area (spill buffer). Relevant only if -memory pressure prevents a standard hash join and sort-merge is not available. -Not planned for the near term. - ---- - -## Symmetric hash join - -Builds hash tables for both sides simultaneously as tuples arrive from either -input. Suitable for streaming or pipelined inputs where one side may block -before producing all its tuples. - -**Memory**: O(n + m) in the worst case — both hash tables may grow to full size. - -Not planned. Mentioned because Sakura streams tuples lazily; if the OCaml side -ever introduces back-pressure on one relation while the other produces freely, -symmetric hashing becomes relevant. - ---- - -## LeapFrog TrieJoin - -LeapFrog TrieJoin (Veldhuizen, 2012) is the state of the art for multi-way -joins in logic programming and Datalog engines. It is **worst-case optimal**: -it runs in time proportional to the AGM bound — the tight theoretical upper -bound on the output size of a conjunctive query given the sizes of its input -relations. Traditional pairwise binary joins applied sequentially can produce -intermediate results that exceed this bound, making them suboptimal for cyclic -or highly connected queries. - -### How it works - -Rather than joining two relations at a time, LeapFrog TrieJoin joins all -relations in a query **simultaneously**. Each relation is represented as a -trie — a sorted, prefix-keyed index over its attribute values. One cursor per -relation is maintained, all pointing into their respective tries at the same -attribute depth. - -The algorithm iterates over one shared variable at a time. At each step: - -1. Find the relation whose cursor currently points to the **maximum** value - among all cursors. -2. **Seek** all other cursors forward to that maximum (or the next value ≥ it). -3. If all cursors agree on the same value: emit the binding and descend to the - next variable. -4. If a cursor cannot find a value ≥ the maximum: backtrack and advance the - previous variable. - -The seek operation is what makes this efficient. Instead of scanning linearly -through values that cannot match, a cursor jumps directly to the next candidate -using the sorted order of the trie. No intermediate results are materialized. - -**Memory**: O(k) where k is the number of relations — one cursor per relation, -plus one tuple per active binding level. Constant with respect to relation size. - -**I/O**: O(n^τ\*) where τ\* is the fractional edge cover of the query -hypergraph. For acyclic joins this matches the Yannakakis bound; for cyclic -joins it beats any binary join plan. - -### Why this fits the Tarski/Karuta model - -Karuta is WAM-based. The WAM already operates on term tries during unification, -advancing through sorted clause indexes when resolving goals. LeapFrog TrieJoin -is the relational analogue: the trie structure and the seek-based iteration -pattern are the same. When Sakura emits a plan to Tarski, the multi-way join -over several relations maps directly onto a LeapFrog node whose cursors are -driven by the same pull model as every other Volcano operator. - -### Current state of Sakura - -Reading `lib/algebra.ml`, the current join implementation materializes the -entire right-hand relation into memory before beginning the left-hand scan: - -```ocaml -let right_tuples = drain right_gen in (* ← full materialization *) -List.filter_map (fun rt -> ...) right_tuples (* ← linear scan per left tuple *) -``` - -This is a documented TODO in the codebase. Beyond the memory cost, it is a -strictly binary join — three or more relations require multiple sequential -passes with growing intermediate materialization. - -The generator type (`int option -> result`) is forward-only and position-counted. -It has no seek primitive: you cannot ask a generator to jump to the next value -≥ a target without scanning every value in between. - -Sakura does have a B+ tree binding (`lib/bplustree.ml`, FFI to a C library) but -it is currently wired only to the KV storage layer for tuple hash persistence, -not to any per-attribute ordered index. - -### What would need to change in Sakura - -**1. Per-attribute sorted indexes** - -Each stored relation needs a secondary index mapping attribute values to tuple -hashes, maintained in sorted order. The existing B+ tree binding is the natural -substrate for this — it already supports ordered key storage and would expose -range traversal and seek as cursor operations. - -The index structure per relation would be: - -``` -relation_path / attribute_name → B+ tree of (value, tuple_hash_set) -``` - -**2. A seek-capable cursor type** - -The generator type needs to be extended (or complemented) with a cursor -abstraction that supports: - -- `current()` — the value at the current position -- `seek(target)` — advance to the first value ≥ target; return whether one exists -- `next()` — advance by one step - -A generator that only supports `next()` cannot implement LeapFrog without -scanning every skipped value. The seek operation is the essential primitive. - -**3. A multi-way join operator in `algebra.ml`** - -The current `equijoin` function is binary. LeapFrog TrieJoin takes an arbitrary -list of relations and a variable ordering. A new `leapfrog_join` function would -replace the sequential application of `equijoin` for multi-relation conjunctive -queries. - -### What would need to change in Tarski (this codebase) - -On the C++ side, the `CursorManager` would need a `Seek` operation alongside -`Next`: - -```cpp -/** Advances the cursor to the first tuple whose join-attribute value is ≥ target. - * Returns nullptr if no such tuple exists (relation exhausted). */ -Tuple* Seek(cursor* c, const std::string& attribute, const std::string& target); -``` - -The plan tree would gain a `LEAPFROG` node holding N child SCAN cursors and a -variable ordering list. `VM::Next` on a `LEAPFROG` node drives the seek loop -across all cursors rather than delegating to nested-loop iteration. - ---- - -## Summary - -| Strategy | Memory | I/O | Requires | -|---|---|---|---| -| Nested-loop (current) | O(1) | O(n × m) | Nothing | -| Index nested-loop | O(1) | O(n log m) | Per-attribute B+ tree index | -| Sort-merge | O(1)* | O(n + m) | Pre-sorted inputs | -| Hash join | O(min(n,m)) | O(n + m) | Build side fits in RAM | -| Grace hash join | O(√(n+m)) | O(3(n+m)) | Spill storage | -| LeapFrog TrieJoin | O(k) | O(n^τ\*) | Seek-capable trie cursors | - -\* O(1) only if both inputs arrive sorted. Sorting in-place requires O(n) memory. - -The practical roadmap for this runtime: - -1. **Now**: nested-loop covers all ephemeral-relation joins in O(1) memory. -2. **Next**: index nested-loop once Sakura exposes per-attribute B+ tree reads — - covers the large stored × stored binary join case without buffering. -3. **Target**: LeapFrog TrieJoin once Sakura adds seek-capable cursors and - per-attribute sorted indexes. This replaces both index nested-loop and - sort-merge for multi-relation conjunctive queries and is the correct - long-term join primitive for a Datalog/WAM-oriented engine. -4. **Only if needed**: hash join with an explicit memory budget, for ad-hoc - joins where no usable index exists. diff --git a/docs/mainpage.dox b/docs/mainpage.dox deleted file mode 100644 index 8cef183..0000000 --- a/docs/mainpage.dox +++ /dev/null @@ -1,90 +0,0 @@ -/** - * @mainpage RNT - * - * @image html logo.png - * <p><a href="https://www.gnu.org/licenses/agpl-3.0.html"><img src="https://www.gnu.org/graphics/agplv3-with-text-162x68.png" alt="GNU AGPLv3" /></a></p> - * - * RNT is an experimental database kernel inspired by the - * object-management model of the Windows NT kernel. The project applies - * explicit object management to database state: relations, tuples, - * transactions, namespaces, permissions, cursors, and handles are - * runtime-managed objects rather than isolated subsystems. - * - * @section motivation Motivation - * - * The NT kernel is a good model for a dedicated database kernel for three - * reasons. - * - * **The object manager.** NT's OB gives every kernel resource a named path, - * a security descriptor, and a uniform open/close lifecycle enforced through - * handles. A database kernel has the same requirements. Rather than building - * those mechanisms independently for each database concept, this project - * borrows the NT object manager's shape directly. - * - * **Physical backends as drivers.** NT device drivers expose a narrow - * dispatch table. The kernel routes I/O through it without knowing whether - * the device is a local disk or a network adapter. Storage backends here - * follow the same pattern. A remote backend like etcd is just another - * driver, but brings its own concerns: network latency, connection - * management, and the possibility of partial failure. The driver boundary - * keeps those concerns inside the backend module. - * - * **Clients as environment subsystems.** NT supports Win32, POSIX, and OS/2 - * as environment subsystems layered above a common native API. A database - * client works the same way: a PostgreSQL wire adapter, a MySQL wire - * adapter, or an HTTP/JSON interface each translates its protocol into - * kernel-level operations. The kernel never sees SQL syntax or protocol - * framing. - * - * @section architecture Architecture - * - * - ObjectManager registers, locates, and references database objects by - * logical path. - * - PermissionsManager keeps capability checks separate from object lookup. - * - IdentityManager decides whether an object supports a requested lifecycle - * operation. - * - LifecycleManager models monitoring, pinning, cleanup, and contention. - * - HandlerManager orchestrates the full open/close workflow and owns handle - * allocation. - * - CursorManager provides a pull-based iterator over storage, abstracting - * pagination, snapshot pinning, and scan boundaries. - * - VM separates terminating first-order relational retrieval (Tarski) from - * higher-order logic execution (Karuta). - * - NamespaceReferenceManager handles logical path mapping and namespace - * isolation, including private branch shadowing and atomic multi-reference - * updates. - * - * @section building Building - * - * Requires the Nix development shell on GNU/Linux. The flake provides GCC, - * CMake, Ninja, SQLite, PicoSHA2 headers, Catch2, Doxygen, and Graphviz. - * - * @code{.sh} - * nix develop - * cmake --preset gnu-debug - * cmake --build out/build/gnu-debug - * @endcode - * - * A release build uses @c --preset @c gnu-release. - * - * @section docs Generating Documentation - * - * @code{.sh} - * doxygen Doxyfile - * @endcode - * - * Generated HTML is written to @c docs/generated/html. - * - * @section license License - * - * RNT is free software licensed under the GNU Affero General Public License - * v3.0. See the repository @c LICENSE file for the full terms. - * - * Copyright (C) 2026 Marcos Magueta, RNT contributors, and Don't Rely on - * Nulls. Maintainer: Marcos Magueta. - */ - -/** - * @namespace nt - * @brief Contains the Relational NT runtime managers and API facade. - */ diff --git a/docs/nt-architecture-mapping.md b/docs/nt-architecture-mapping.md deleted file mode 100644 index 3510f82..0000000 --- a/docs/nt-architecture-mapping.md +++ /dev/null @@ -1,489 +0,0 @@ -# NT Kernel Architecture — Holistic Mapping to a Database Kernel - -A full-system view of the ReactOS NT kernel (`ntoskrnl/`) mapped onto the -architecture of a database kernel. The object manager comparison is covered -separately in `reactos-ob-comparison.md`; this document covers the rest of the -kernel and treats the project as a whole. - -The central thesis: **NT is already a database kernel in disguise**. It manages -named, typed, reference-counted objects; enforces capability-based access control; -schedules work across a pool of threads; routes requests through a layered -dispatch stack; and maintains a write-buffered, lazily-flushed cache in front of -physical storage. Every one of those responsibilities has a direct counterpart in -a relational database engine. - ---- - -## Subsystem Map - -| NT subsystem | DB kernel counterpart | -|---|---| -| **KE** — kernel scheduler, IRQL, APC/DPC, synchronization primitives | Query scheduler, latch manager, deferred execution | -| **PS** — process/thread lifecycle, job objects, quotas | Session manager, worker thread pool, resource groups | -| **IO** — driver model, IRP dispatch stack, completion ports | Storage engine interface, query operator pipeline, async execution | -| **MM** — virtual memory, page faults, working set, section objects | Buffer pool, page frame allocator, eviction policy | -| **CC** — cache manager, lazy writer, VACB, prefetcher | WAL buffer / dirty page flusher, sequential prefetch | -| **SE** — tokens, ACLs, DACL/SACL, privilege evaluation | User principal, role/privilege set, access control, audit | -| **EX** — events, work queues, lookaside lists, rundown refs | Synchronization utilities, worker dispatch, buffer allocation | -| **LPC** — port objects, request/reply messaging | Wire protocol layer, client connection, inter-session RPC | -| **FSRTL** — fast I/O bypass, MCB extent map, file byte-range locks | Index hot-path, extent/page mapping, record-level locks | -| **OB** — object manager | Object manager (covered in reactos-ob-comparison.md) | -| **HAL** — CPU, interrupt, DMA, timer abstraction | Storage media abstraction, CPU/NUMA topology | -| **KD** — kernel debugger transport | EXPLAIN / trace / diagnostic interface | -| **CONFIG** — registry hive manager | System catalog, configuration store | - ---- - -## 1. Subsystems as Client Protocols - -NT supports multiple *environment subsystems*: Win32 and POSIX both run on top of -the same kernel. Each subsystem is a user-mode personality layered above a common -native API (`ntdll.dll`). The kernel itself has no awareness of Win32 or POSIX; -it exposes only native NT objects (files, processes, events). The subsystem DLLs -translate environment-specific calls into native system calls. - -``` -Win32 application POSIX application - ↓ ↓ - kernel32.dll libc (POSIX layer) - ↓ ↓ - ntdll.dll (native NT API) - ↓ - ntoskrnl (kernel) -``` - -**Database analogue: wire protocols as subsystems.** - -The database kernel (RelationalNT) is the `ntoskrnl`. Each supported wire -protocol — PostgreSQL, MySQL, HTTP/JSON — is an environment subsystem. A thin -native client library is the `ntdll` equivalent: it translates wire-protocol -messages into kernel-level handle opens, cursor operations, and VM plan -evaluations. The kernel itself never sees SQL syntax or protocol framing. - -``` -psql client MySQL client HTTP client - ↓ ↓ ↓ - PG wire adapter MySQL wire adapter REST adapter - ↓ ↓ ↓ - native client library (ntdll equivalent) - ↓ - RelationalNT kernel -``` - -The subsystem boundary is where SQL parsing, result serialization, and -protocol-specific error codes live. The kernel boundary is where object paths, -handle allocation, cursor iteration, and capability checks live. Keeping these -boundaries clean means a new wire protocol never touches the kernel; it only -implements the native-to-protocol translation layer. - -`CSRSS` (the client-server runtime) is the service process that hosts -session-specific subsystem state on the NT side. The DB equivalent is a per- -protocol server daemon that owns wire connections and dispatches them to the -native API. - ---- - -## 2. IO Manager → Query Operator Pipeline - -The NT I/O manager's driver stack model is the most directly applicable pattern -for query execution. - -### NT Driver Stack - -``` -NtReadFile - ↓ -I/O Manager: allocates IRP, fills stack location [0] - ↓ IoCallDriver() -Filesystem driver (NTFS): interprets path, maps to block range - ↓ IoCallDriver() -Disk class driver: translates logical → physical sectors - ↓ IoCallDriver() -Disk port driver: issues SCSI/ATA commands - ↓ IoCallDriver() -Miniport: hardware-specific DMA -``` - -Each driver layer processes its stack location and either completes the IRP -inline (sync fast path) or pends it and calls the next driver. Completion fires -back up through registered completion routines — bottom to top — until the -original caller wakes. - -### Database Analogue: PlanNode as IRP - -The VM's `PlanNode` is an IRP. Each operator in the query plan is a driver layer -with a dispatch routine (`Next()`). The Volcano pull model is completion-routine -dispatch in reverse: instead of pushing results down-to-up on completion, the -caller pulls up-to-down via `Next()`. - -``` -VM::Next(root_plan_node) - ↓ Next() dispatch -JOIN operator: requests rows from left and right children - ↓ Next() -FILTER operator: requests rows, discards those failing predicate - ↓ Next() -PROJECT operator: strips unwanted attributes - ↓ Next() -SCAN operator: pulls raw tuples from CursorManager - ↓ -CursorManager::Next() → physical storage -``` - -NT's `IRP_STACK_LOCATION` (one per driver layer) maps to each `PlanNode` holding -its own operator-local state (join buffer, filter expression, projection map). -NT's `IRP_MJ_READ` / `IRP_MJ_WRITE` major function codes map to `Op::SCAN`, -`Op::JOIN`, `Op::FILTER`, `Op::PROJECT`. - -**Filter drivers.** NT allows filter drivers to insert between any two layers -without modifying either. The DB equivalent is transparent middleware: a -compression or encryption operator inserted between SCAN and PROJECT without -touching either. An audit operator inserted at the top of every plan without -touching the plan itself. - -**Async IRP / completion ports.** NT issues an IRP and gets a completion -notification later. For the DB, a query issued by a session does not block the -session thread if the operator tree must wait on I/O. A completion-port analogue -(a result queue per session) allows the session thread to yield and be notified -when the cursor has rows ready. This is relevant when the physical storage backend -is remote (etcd, S3) and latency is non-trivial. - ---- - -## 3. Drivers → Storage Backends - -A NT device driver is a self-contained module that satisfies read/write/control -requests for a physical or logical device. The kernel does not know whether the -device is a disk, a network socket, or a USB key; it only knows the driver -dispatch table. - -`CursorManager` is the equivalent of the I/O manager's dispatch layer. The mock -store (`unordered_map`) is the miniport. Replacing it with LMDB, RocksDB, etcd, -or an in-memory append log is equivalent to swapping a miniport driver without -changing the I/O manager or the filesystems above it. - -``` -CursorManager::Open / Next / Close - ↓ -Storage backend interface (the "driver dispatch table") - ↓ - ┌─────────────┬──────────────┬─────────────┐ - │ LMDB backend│ etcd backend │ memory backend│ - └─────────────┴──────────────┴─────────────┘ -``` - -The driver model implies that the storage backend interface should be stable and -narrow: `Open(path, snapshot_id)`, `Next()`, `Close()`. All backend-specific -concerns (transaction semantics, key encoding, compression) stay inside the -backend module. `CursorManager` holds snapshot pinning and buffering logic that -applies regardless of backend, exactly as the disk class driver holds caching -logic regardless of whether the miniport is SATA or NVMe. - -**Filter driver analogue.** A replication backend can be a filter: it intercepts -`Next()` calls after the underlying backend returns a row and ships a copy to a -replica. A row-level encryption backend decrypts inline before returning to the -caller. These compose without the operator pipeline or the caller knowing. - ---- - -## 4. MM → Buffer Pool - -NT's Memory Manager manages physical page frames and virtual address mappings. The -three-tier hierarchy is: - -``` -Process working set (recently used pages, trimmed under pressure) - ↓ -Cache Manager VACBs (256 KB mapped views of files in kernel VA space) - ↓ -Physical storage (disk, via filesystem IRP) -``` - -Page faults are demand-load: a page is only brought from disk when first accessed. -The working set trimmer evicts least-used pages under memory pressure. Section -objects allow multiple processes to map the same physical pages (shared memory). - -**Database buffer pool.** The same three tiers apply: - -``` -Query working set (pages referenced by active cursors, pinned) - ↓ -Buffer pool frames (fixed-size pages cached in memory) - ↓ -Physical storage backend -``` - -The NT page fault handler (`MmNotPresentFault`) maps to a buffer pool miss: -when a cursor requests a page not in the buffer pool, load it from the backend. -The NT working set trimmer maps to LRU eviction: under memory pressure, unpin -pages not referenced by any active cursor. NT section objects (shared physical -pages across processes) map to shared buffer pool pages accessible from multiple -sessions. - -Because this project uses immutable snapshot storage, the eviction policy is -simplified: a page belonging to a snapshot pinned by at least one cursor -(`reference_count > 0` on the snapshot registry entry) cannot be evicted. Pages -belonging to snapshots with no remaining cursors are candidates for eviction -regardless of recency. This is cleaner than NT's working-set model because there -is no dirty-page complexity — writes always produce new pages, never mutate -existing ones. - ---- - -## 5. CC → WAL and Dirty Page Flush - -NT's Cache Manager sits between the filesystem and MM. Its `VACB` (Virtual Address -Control Block) is a 256 KB view of a file in kernel virtual address space. The -lazy writer (`CcWorkerThread`) periodically scans `DirtyVacbListHead` and writes -modified pages back to disk. The prefetcher traces access patterns and pre-loads -pages before they are requested. - -**Database analogue: write-ahead log buffer and sequential prefetch.** - -Because storage is immutable here, the cache manager's dirty-write concern does -not apply directly. New snapshot pages are always appended; they are never -modifications of existing cached pages. However, the structural lessons hold: - -- **Append buffer.** New snapshot pages accumulate in an in-memory append buffer - before being flushed to the physical backend. The lazy writer pattern (flush - when the buffer exceeds a threshold, or periodically) applies directly. -- **Read-ahead prefetch.** Sequential scans access pages in order. A prefetch - mechanism that issues backend reads ahead of the cursor's current position - reduces latency. NT's prefetcher learns per-scenario patterns; a database - prefetcher can use the query plan to predict access order exactly. -- **VACBs as buffer frames.** Each VACB is a fixed-size view; the database - equivalent is a fixed-size buffer frame. Fixed-size frames simplify allocation - and eviction arithmetic. - ---- - -## 6. PS → Sessions and Worker Threads - -NT process = database session. NT thread = query worker thread. - -``` -PEPROCESS Session - ├─ Handle table ├─ Handle table (open cursors, relations) - ├─ Token (identity) ├─ Connection context (AUTH_CLAIM set) - ├─ Working set ├─ Buffer pool pinned pages - ├─ Quota (memory, CPU, I/O) ├─ Resource quota (memory, CPU, I/O) - └─ ThreadListHead └─ Worker thread set - -PETHREAD Query worker - ├─ APC queue ├─ Deferred plan evaluation queue - ├─ IRP queue ├─ Pending cursor operations - └─ Impersonation context └─ SECURITY DEFINER / SET ROLE context -``` - -NT job objects group processes with shared limits: NT's `NtAssignProcessToJobObject` -enforces memory, CPU time, and I/O quotas across a group. The DB equivalent is a -*resource group* or *tenant*: a set of sessions sharing a memory limit and a CPU -share. Multi-tenant databases need this to prevent one tenant's runaway query from -starving others. Job objects are the right model: assign sessions to resource -groups at connection time and enforce limits at the job-object level rather than -per-session. - -**Impersonation.** NT allows a thread to temporarily assume a different security -context (`SeImpersonateClient`). The DB equivalent is `SET ROLE` or `SECURITY -DEFINER` in stored procedures: the query worker temporarily adopts a different -access context without requiring the connection to re-authenticate. - ---- - -## 7. SE → Authorization Beyond the Object Manager - -NT's security subsystem extends what the object manager does. Where OB attaches a -security descriptor to an object and checks access at handle-open time, SE -provides the richer infrastructure underneath: - -- **Token structure.** A token carries the caller's SID (identity), group - memberships, privilege set, and mandatory integrity level. The DB equivalent - is the connection context: user identity, granted AUTH_CLAIMs, session-level - role, and a trust level (e.g., a connection from localhost vs. from the public - internet might carry different trust). -- **DACL / SACL split.** The DACL controls access; the SACL controls audit logging - (which accesses are recorded, on success or failure). For a database these are - different concerns: the permission check decides whether to allow the operation; - the audit policy decides whether to log it. Conflating them in a single - security descriptor is correct design; it keeps both concerns co-located with - the object rather than scattered. -- **Privilege evaluation.** NT privileges (SE_BACKUP_PRIVILEGE bypasses ACLs; - SE_DEBUG_PRIVILEGE allows opening any process) have a DB analogue in superuser - privileges: a DBA role that bypasses row-level security, or a replication user - that bypasses normal write contention checks. These are orthogonal to the - capability tree and should be modelled as privileges on the connection token, - not as explicit capabilities on every object. -- **Mandatory access control (integrity levels).** NT's integrity levels - (UNTRUSTED < LOW < MEDIUM < HIGH < SYSTEM) prevent low-integrity processes - from writing to high-integrity objects even if the DACL permits it. The DB - equivalent is a trust tier on connections: an externally-facing API connection - at LOW tier cannot write to audit or system catalog tables regardless of the - DACL, because those tables require HIGH tier. - ---- - -## 8. LPC → Wire Protocol and Inter-Session Messaging - -NT's Local Procedure Call provides synchronous request-reply messaging between -processes via named port objects. A server process creates a named connection port; -clients connect and receive private communication ports. This is the mechanism -through which Win32 applications communicate with CSRSS (console, shutdown) and -through which subsystem DLLs synchronize session state with the subsystem server. - -**Database analogue: wire protocol connection.** - -Each client connection to the database is an LPC communication port. The session -server daemon listens on a named port (the TCP socket); accepted connections -become private communication ports (per-client sessions). The session daemon is -CSRSS. - -LPC's fixed message size limit (`LPCP_MAX_MESSAGE_SIZE`) prevents a misbehaving -client from forcing unbounded allocation. The DB wire protocol layer should apply -the same discipline: a maximum query length, a maximum result frame size, and a -maximum number of concurrent open cursors per session. - -LPC ports are objects in the NT namespace. Database connection endpoints (the -listening socket, or a named pipe for local connections) should similarly be -registered as objects in the RelationalNT namespace, making them subject to the -same capability checks: a client must have explicit permission to connect to a -particular endpoint. - ---- - -## 9. FSRTL → Index Extent Management and Record Locks - -The File System Runtime Library is a set of utilities that filesystems use. The -most relevant pieces for a database are: - -- **MCB (Map Control Block).** Tracks the logical-to-physical block mapping for a - file that may be stored in non-contiguous extents on disk. The DB equivalent is - an index page map: a B-tree or extent map translating a logical page number in - an index to a physical storage location. The MCB API (`FsRtlAddLargeMcbEntry`, - `FsRtlLookupLargeMcbEntry`) is a model for an extent manager that handles - fragmentation without surfacing it to callers. -- **Fast I/O bypass.** `FAST_IO_DISPATCH` provides function pointers for - synchronous I/O that skip IRP allocation entirely when the requested data is - already in the cache. The DB equivalent is a buffer pool hot-path: if the - requested snapshot page is already pinned in the buffer pool, return it without - going through the full CursorManager dispatch chain. -- **Byte-range file locking.** `FILE_LOCK` tracks exclusive/shared locks on - sub-file ranges. The DB equivalent is record-level locking within a relation. - Since storage here is immutable, this concern is narrowed to locking mutable - references (branch HEADs) rather than individual records — but the MCB-style - range-tracking structure is still the right data structure for knowing which - parts of a namespace are currently locked by which writers. - ---- - -## 10. HAL → Storage Media Abstraction - -The Hardware Abstraction Layer isolates the kernel from CPU, interrupt controller, -and timer differences between x86 and ARM machines. It provides a stable set of -primitives (`HalAllocateAdapterChannel`, `HalReadDmaCounter`, `KeAcquireSpinLock`) -that the rest of the kernel calls without knowing the underlying hardware. - -**Database analogue: storage media and topology abstraction.** - -The equivalent boundary sits between `CursorManager` (the "kernel") and the -physical storage backend (the "hardware"). The HAL lessons: - -- **Platform-neutral primitives.** `CursorManager::Next()` and `Close()` should - never contain NVMe-specific or LMDB-specific code. Those specifics live in the - backend module, exactly as NVMe DMA specifics live in the miniport, not the HAL. -- **CPU/NUMA topology.** HAL exposes processor and memory node topology so the - scheduler can make NUMA-aware placement decisions. A database on a NUMA machine - benefits from binding buffer pool regions and worker threads to the same NUMA - node. This is a future concern but the right interface is at the HAL boundary: - a `platform_topology` structure that the scheduler queries without knowing - whether it is running on x86, ARM, or a cloud VM. -- **Timer abstraction.** HAL provides a system tick and a high-resolution - performance counter. The DB needs both: a coarse timer for transaction - timestamps and TTL-based expiry, and a high-resolution counter for query - latency measurement. - ---- - -## 11. KD → Diagnostic Interface - -NT's kernel debugger (`kd/`) provides a serial transport over which WinDBG can -inspect kernel state, set breakpoints, and walk data structures live. The -`!object`, `!handle`, and `!poolused` debugger extensions expose the object -manager, handle tables, and pool allocator without stopping the machine. - -**Database analogue: EXPLAIN and live diagnostic.** - -The equivalent is a diagnostic interface that can walk live runtime state: the -object registry, open handle table, active cursors, and lifecycle counters. -Implemented as a reserved namespace path (`/system/diagnostics/`), it exposes -read-only virtual objects whose `Next()` returns runtime state rather than stored -data. Queries against `/system/diagnostics/cursors` return a row per open cursor; -queries against `/system/diagnostics/objects` return a row per registry entry with -its handle and reference counts. This is `EXPLAIN ANALYZE` and -`pg_stat_activity` unified under the same object model, for free. - ---- - -## 12. Config Manager → System Catalog - -NT's configuration manager (`config/`) manages registry hives — persistent -key-value stores loaded at boot and kept consistent via transaction logs. The -registry is itself stored as a structured binary file that the kernel reads before -any filesystem driver is loaded. - -**Database analogue: system catalog.** - -The system catalog is a set of relations stored in a reserved multigroup -(`/system/catalog/`) that describes all other objects: their types, paths, -security descriptors, and capabilities. It is the registry of the database. It -must be readable before any user-defined relations are accessible, exactly as the -registry is readable before any device driver is loaded. - -Because storage is immutable here, the catalog is itself versioned: each schema -change produces a new catalog snapshot, and the kernel always reads the latest -committed catalog version on startup. Old catalog versions remain accessible for -historical schema reconstruction (e.g., reading data written under a previous -schema). This is more powerful than the NT registry, which has no built-in -history. - ---- - -## Architectural Summary - -The full NT kernel, mapped to a database, produces this layer diagram: - -``` -┌─────────────────────────────────────────────────────────────────┐ -│ Wire Protocol Subsystems (LPC / Env. Subsystems) │ -│ PostgreSQL wire MySQL wire HTTP/JSON native client lib │ -├─────────────────────────────────────────────────────────────────┤ -│ Session Manager (PS) │ -│ Sessions · Worker threads · Resource groups · Impersonation │ -├─────────────────────────────────────────────────────────────────┤ -│ Authorization Engine (SE + OB) │ -│ Tokens · Capabilities · DACL/SACL · Privilege evaluation │ -├─────────────────────────────────────────────────────────────────┤ -│ Query Operator Pipeline (IO / VM) │ -│ SCAN · FILTER · PROJECT · JOIN · SORT · AGGREGATE │ -│ Async execution · Filter-driver middleware · Plan nodes │ -├─────────────────────────────────────────────────────────────────┤ -│ Object Manager (OB) Namespace (NamespaceRefMgr) │ -│ Registry · Handles · Types Branch refs · View reparse │ -├─────────────────────────────────────────────────────────────────┤ -│ Buffer Pool (MM + CC) │ -│ Page frames · Working set · Prefetch · Append flusher │ -├─────────────────────────────────────────────────────────────────┤ -│ Storage Backend Interface (IO driver model) │ -│ CursorManager · Backend dispatch table · Filter backends │ -├─────────────────────────────────────────────────────────────────┤ -│ Physical Backends (HAL / miniport drivers) │ -│ LMDB · RocksDB · etcd · in-memory · S3 │ -└─────────────────────────────────────────────────────────────────┘ -``` - -The current RelationalNT codebase covers the Object Manager, parts of the -Operator Pipeline (SCAN only), and the authorization skeleton. The layers above -(session manager, wire protocols) and below (real buffer pool, real storage -backends) are the next frontier. The NT architecture shows that each layer has a -well-understood responsibility and a narrow interface to its neighbours — that -discipline is the reason the NT kernel scales from embedded devices to 1024-core -servers without architectural changes. diff --git a/docs/object-system.org b/docs/object-system.org new file mode 100644 index 0000000..a2f7929 --- /dev/null +++ b/docs/object-system.org @@ -0,0 +1,149 @@ +* Goals +The object manager: +- works as a uniform interface to the resources exposed by the system; +- provides a consistent way of tracking usage and managing access to parts of the system. + +* The Object System +An object is something that exists as a part of the RNT system. An object has a "type", which denotes what it represents, and "protocols", which denote what it can do. Programs do not interact with objects directly, but do so through a handle. An object keeps track of how many handles to it are currently open, this is its reference count. + +A "protocol"[fn:1] represents the ability of an object to perform a given set of operations. For instance, an object that has a directory protocol can be seen as one that exposes an operation, =list=, that enumerates its children, and another operator, =open=, that, given a key, returns a handle to a specific child. Just like objects, programs do not interact with protocols directly, but do so through an interface. A handle is itself an interface, that, among other things, exposes an operation to retrieve interfaces to additional protocols of the object it represents. + +As a convention, we can denote a protocol as an ML structure as follows: +#+begin_src ocaml + module Directory : sig + type t + + val from : Handle.t -> t option + + val list : t -> string list + val open : t -> string -> Handle.t option + end +#+end_src +In the example above, =Directory= is a protocol, and =Directory.t= is an interface. =list= is an operation that, given a =Directory= interface, enumerates the contents of the corresponding object. =open= is an operation that, given a =Directory= interface and a key, returns a =Handle= interface to the object associated with the given key, if it exists. + +=from= is not an operation of =Directory= per se. Rather, it can be seen as a polymorphic operation belonging to =Handle= that, given a handle and a protocol, returns an interface to that protocol iff it is supported by the corresponding object. + +It is convenient to refer to interfaces using the name of the protocol they belong to, so a "=Directory= interface" is simply a directory, and a "=Handle= interface" is simply a handle. + +What, more concretely, is a =Handle=? A =Handle= is the following protocol: +#+begin_src ocaml + module Handle : sig + type t + + val into : t -> (protocol -> 'a option) -> 'a option + + val copy : t -> t option + val release : t -> unit + end +#+end_src + +=copy= duplicates the handle, if it supports being duplicated. =release= releases the handle, decrementing the reference count of the object. No further operations may be called on a released handle. + +# Should this be inside `Handle`? +=into= deserves some explanation. First, =protocol=, the type, is defined as an extensible variant: +#+begin_src ocaml + type protocol = .. +#+end_src + +Suppose we are to implement the =Directory= module outlined above. We can add a variant to this record, and use =into= to implement =from= in the following manner: + +#+begin_src ocaml + module Directory = struct + type t = < list : string list; open : string -> Handle.t option > + + type protocol += Directory of t + + let from h = Handle.into h (function Directory o -> Some o | _ -> None) + + let list o = o#list + let open o k = o#open k + end +#+end_src + +This gives us a way of implementing interfaces out of a corresponding OCaml object[fn:2]. We are, however, still missing a way of implementing objects themselves. For this, we first need to define what an object is, concretely: + +#+begin_src ocaml + module Object = struct + type t = < reference : unit; release : unit; protocols : protocols list > + end +#+end_src + +How do we construct a =protocol=? Going back to our =Directory= structure, we may modify it slightly: + +#+begin_src ocaml + module Directory : sig + type t + + val from : Handle.t -> t option + + val list : t -> string list + val open : t -> string -> Handle.t option + + module Provider : sig + type provider = < list : string list; open : string -> Handle.t option > + + val make : provider -> protocol + end + end +#+end_src + +=Directory.Provider.make= provides a way of constructing a =Directory= interface out of an OCaml object. =Directory.Provider.provider= has the same structure as the concrete definition of =Directory.t= above, although the similarities should be treated as merely incidental. A handle can be instantiated out of an =Object.t= in the same way: + +#+begin_src ocaml + module Handle : sig + type t + + val into : t -> (protocol -> 'a option) -> 'a option + + val copy : t -> t option + val release : t -> unit + + module Provider : sig + val make : Object.t -> t + end + end +#+end_src + +We can then implement an object exposing a =Directory= protocol as follows: +#+begin_src ocaml + class empty_directory = object (self) + method reference = () + method release = () + + method protocols = [Directory.Provider.make self] + + method list = [] + method open _ = None + end +#+end_src + +[fn:1]: This was originally called a "capability", but represented something different than the term "capability" in "capability-based security". In the latter, an object in our sense could be considered a capability. +[fn:2]: This could just as well have been a record of functions - there is nothing specific to the OCaml object system here. + +* The Object Tree +RNT exposes its resources as a hierarchy of objects. The root of this tree is an object that implements, at least, the =Directory= and =Registry= protocols. A handle to the root of this tree can be obtained by calling =Kernel.ObjectManager.root=. =Registry= is declared as follows: +#+begin_src ocaml + module Registry : sig + type t + + val from : Handle.t -> t option + + val register : key -> Handle.t -> (unit, Concepts.Condition.condition) result + val unregister : key -> (unit, Concepts.Condition.condition) result + end +#+end_src +=register= and =unregister=, as implemented by the root of the hierarchy, allows components to register resources that can be retrieved by users of the system through the corresponding =Directory= interface. The handle passed as an argument to =register= must support being "copy"ed. + +As a convenience, a =path= represents a pattern of traversal the object tree. The path ="branch" @/ "master" @/ "multigroup" @/ "universe" @/ this= represents the object that can be retrieved by, from a given reference point, "open"ing the child denoted by ="branch"= on the given reference point, then "open"ing the child denoted ="master"= on the retrieved object, and so on. Every traversal assumes that the object in question has a =Directory= protocol. The ability to construct and manipulate paths is implemented by the =Path= module: +#+begin_src ocaml + module Path : sig + type path + + val this : path + val (@/) : string -> path -> path + + val lookup : Handle.t -> path -> Handle.t option + end +#+end_src + +=ObjectManager.lookup= is a convenience function that applies =Path.lookup= to the root of the object tree. diff --git a/docs/reactos-ob-comparison.md b/docs/reactos-ob-comparison.md deleted file mode 100644 index 2f0a391..0000000 --- a/docs/reactos-ob-comparison.md +++ /dev/null @@ -1,281 +0,0 @@ -# ReactOS Object Manager — Insights for RelationalNT - -A comparative study of the ReactOS kernel object manager (`ntoskrnl/ob`) against -the RelationalNT runtime, identifying structural patterns from the OS kernel that -translate directly into improvements for a database kernel. - -The ReactOS OB is roughly 8,000 lines across `oblife.c`, `obhandle.c`, `obref.c`, -`obdir.c`, `obname.c`, and `obsecure.c`. The notes below focus on the subset of -patterns that have a clear database analogue, with adjustments for the -immutable-storage model this project uses. - ---- - -## 1. Two-Level Reference Counting - -**ReactOS pattern.** Every object header carries two independent counters: -`PointerCount` (kernel-internal references, e.g. a driver holding a pointer) and -`HandleCount` (external user-visible handles). Object deletion only proceeds when -*both* reach zero. - -**Database analogue.** RelationalNT already has `reference_count` and -`handle_count` in `registry_head`, but `reference_count` is unimplemented (see -`ObjectManager.h` TODO). The two counters serve different purposes and must be -decremented by different paths: - -- `handle_count` — open sessions holding a cursor or handle on this object. - Managed by `LifecycleManager::Monitor` / `Unmonitor`. -- `reference_count` — structural dependencies: a view referencing its base - relations, an index depending on a relation's schema. Managed by a separate - `Pin` / `Unpin` pair. - -An object may only be garbage-collected when both counters reach zero. -`Unmonitor` should trigger GC only after checking `reference_count == 0`. -Without this, there is no safe way to remove a RELATION that still backs a view. - -**Important note on snapshots.** Snapshots in this system are *always immutable*. -Every insertion or deletion produces a new snapshot version of the multigroup -rather than mutating the existing one. A snapshot is therefore not a special -lifecycle category — it is just another registered object. Its `reference_count` -is non-zero while any cursor is pinned to it, and the snapshot is eligible for -removal only when that count drops to zero. The object flag classification -(permanent vs. non-permanent) applies to *schema objects*, not to snapshot -versions. - -**TODOs:** `LifecycleManager` — add `Pin(registry*)` / `Unpin(registry*)`. -`LifecycleManager::Unmonitor` — check both counters before triggering GC. - ---- - -## 2. Type Callbacks Instead of a Method Set - -**ReactOS pattern.** Object types register actual function pointers: -`OpenProcedure`, `CloseProcedure`, `DeleteProcedure`, `ParseProcedure`, -`SecurityProcedure`. The kernel calls into the type-specific callback rather than -branching on a type enum. - -**Database analogue.** `object_type::methods` is currently a `std::set<METHOD>` -that `IdentityManager::CanOpen` checks against but never acts on. Replacing the -set with typed callbacks eliminates the identity manager as a separate component -and makes object behaviour self-contained: - -| Callback | Database use | -|---|---| -| `OpenProcedure` | RELATION — acquire snapshot pin, register with LifecycleManager | -| `CloseProcedure` | TRANSACTION — auto-rollback if no explicit commit was issued | -| `DeleteProcedure` | MULTIGROUP — cascade to relations | -| `ParseProcedure` | View/alias entry — reparse to the physical relation's path (see §8) | - -**Debuggability concern.** Function pointers are harder to trace than a named -path through the identity manager. Mitigation: store the callback alongside a -`const char* name` label in `object_type` so that logs and assertions can -identify which callback fired. A `std::function` with a wrapper that records the -type label before dispatching also works. - -**Security constraint on ParseProcedure.** When a view (an ephemeral RELATION -whose `ParseProcedure` reparses to base relations) is resolved, the capability -check must be evaluated against the *view's* security descriptor, not the base -relations'. A caller who holds READ on the view must *not* gain the ability to -open handles directly on the underlying relations — those require explicit -permissions of their own. The ParseProcedure reparse mechanism navigates -internally through the namespace on behalf of the runtime; it does not grant the -caller a transitive handle on the base object. The resolved handle is bound to the -view, and the base relations are accessed only via the view's own type callbacks. - -**TODOs:** `ObjectManager::object_type` — replace `std::set<METHOD> methods` with -typed callback fields. `IdentityManager` — migrate to invoke `OpenProcedure` / -`CloseProcedure`; the manager becomes a thin dispatcher or is absorbed into -`HandlerManager`. - ---- - -## 3. Hash Directory / Trie for Object Lookup - -**ReactOS pattern.** Each `OBJECT_DIRECTORY` holds a 37-bucket hash table (37 is -prime, chosen to reduce clustering). Name resolution walks path components -one-by-one, locking each directory, hashing the component, and following -collision chains. A found entry is moved to the head of its bucket (MRU -optimisation). - -**Current state.** `ObjectManager::Find` is an O(n) linear scan of a linked list. -The code comment already says "treat as a list for now, but ideally it is a tree." - -**Recommended approach.** Replace the flat list with a trie whose nodes are -directories keyed by path segment. Each directory node holds a hash map from -segment string to child `registry*`. This matches the ReactOS structure naturally -because `object_path` is already a `std::vector<std::string>`. - -Rather than implementing the trie from scratch, consider pulling a suitable -container via the Nix flake (e.g. a radix tree or a well-tested associative structure). -The only hard requirement is that each directory level supports O(1) average -lookup by segment name and ordered iteration for namespace enumeration. - -**TODO:** `ObjectManager` — replace `std::unique_ptr<registry> entries` (linked -list) with a trie or per-level hash map. `ObjectManager::Find` and `Register` -both need to be updated. - ---- - -## 4. Per-Handle Access Mask - -**ReactOS pattern.** The handle table entry stores `GrantedAccess` per handle, not -per object. A single object can be opened read-only by one session and read-write -by another simultaneously; each handle's access mask is checked independently. - -**Database analogue.** `HandlerManager::handle` currently holds only `object*` -and `void* connection_context`. Adding `std::set<AUTH_CLAIM> granted_access` -enables the access mask to be evaluated once at `Open` time and cached in the -handle for the duration of the session. This resolves the open performance -question in `PermissionsManager` ("undecided whether to check on every access or -cache"). - -**Immutable storage note.** In this system, storage is append-only. A WRITE claim -does not mean mutating an existing tuple in-place; it means the session is -authorised to produce a new snapshot version of the relation. The access mask -semantics should be read accordingly: READ grants access to query an existing -snapshot; WRITE grants access to commit a new one. Two sessions holding WRITE -handles on the same relation produce independent snapshots — there is no conflict -at the storage level. - -**TODO:** `HandlerManager::handle` — add `std::set<AUTH_CLAIM> granted_access`. -`HandlerManager::Open` — populate it from `PermissionsManager::Firewall` / -`Access` and store in the handle. Subsequent checks read from the handle rather -than re-evaluating the security descriptor. - ---- - -## 5. Capability-Based Security, No Inheritance - -**ReactOS pattern.** ReactOS supports SD inheritance through directory traversal: -an object can inherit its parent directory's security descriptor if none is -explicitly set. - -**This project does not use SD inheritance.** Permissions here are strictly -capability-based and must be explicitly granted. There is no implicit flow of -access rights from a multigroup down to its constituent relations. A caller who -holds READ on `/multigroups/coffee_shop` does not thereby hold READ on -`/multigroups/coffee_shop/relations/user` — that is a separate, explicit -capability. - -This is a deliberate departure from the ReactOS model, and it is the correct -design for a database where row-level and column-level access policies are -common. The capability tree in `PermissionsManager` is the authoritative -source of truth; the namespace hierarchy is purely organisational. - -**Implication for the SD cache.** When a shared security descriptor cache is -added (see §7 of the original notes), descriptors must be deduplicated by -content, not by ancestry. Two unrelated relations that happen to have identical -ACLs may share a cached SD; that sharing is a performance optimisation, not a -statement about inheritance. - ---- - -## 6. Mutable Reference Contention (Branch HEAD) - -**ReactOS pattern.** `OB_FLAG_EXCLUSIVE` on an object header prevents more than -one handle from being open simultaneously. The flag is checked during -`ObpCreateHandle`; a second opener fails immediately. - -**Database analogue.** `LifecycleManager::Contention` is a stub that always -returns `true`. It needs to distinguish: - -- **Immutable objects (RELATION snapshots, MULTIGROUP snapshots, TRANSACTION)** — - contention is never raised. These are content-addressed and append-only; two - sessions opening the same snapshot independently is fine. -- **Mutable reference states (branch HEAD, namespace entries)** — contention must - be enforced. A branch HEAD is the only mutable pointer in the system; it needs - single-writer semantics. When a session holds a write handle on a HEAD, a second - writer must block or fail. - -The contention check belongs on the *reference object* (the HEAD pointer), not on -the snapshot object it points to. This maps cleanly to ReactOS's exclusive flag: -add an `exclusive` flag to `object_type` (or a dedicated flag on `registry_head`) -that Contention() checks. - -**Note on session parallelism.** Because storage is immutable, two sessions -writing to the same relation in parallel always produce separate, independent -snapshots. There is no write-write conflict at the data level. The only genuine -contention point is advancing a branch HEAD — the moment where one of the -competing snapshots must be chosen as the new tip. This is the correct and narrow -scope for Contention(). - -**TODOs:** `ObjectManager::registry_head` or `object_type` — add `bool exclusive` -flag. `LifecycleManager::Contention` — implement: return false immediately for -non-exclusive objects; for exclusive objects, return false if `handle_count > 0` -for a write-mode opener. - ---- - -## 7. Deferred Deletion / Asynchronous GC - -**ReactOS pattern.** When an object's pointer count reaches zero, ReactOS does not -delete it inline. It appends to a lock-free `NextToFree` linked list and posts a -work item to a reaper thread (`ObpReapObject`). This keeps deletion latency off -the hot path and prevents stack overflow in nested deletes. - -**Database relevance.** Snapshot compaction and history pruning are expensive -operations that should not run inline inside a client-facing `Close()`. The reaper -pattern maps to a background GC worker: `Unmonitor` enqueues the object when both -counters reach zero; the GC thread drains the queue and calls the type's -`DeleteProcedure`. - -This is noted for completeness. **Compaction is out of scope for the current -implementation phase.** Record it here so the architecture accommodates it: -`LifecycleManager::Unmonitor` should eventually enqueue rather than immediately -free. - ---- - -## 8. NamespaceReferenceManager as the Reparse Layer - -**ReactOS pattern.** `ParseProcedure` on a type can return `STATUS_REPARSE` with -a new path, causing the name resolver to restart from the new path. Symbolic links -use this. The resolver caps reparse at 30 iterations to detect cycles. - -**This is the right architecture for `NamespaceReferenceManager`.** The manager -currently has no implementation. It should be built around the same concept: - -- **Branch references** — a path like `/refs/branch/main` is a namespace entry - whose `ParseProcedure` returns a reparse pointing to the actual snapshot path - (e.g. `/snapshots/abc123`). The caller's handle lands on the snapshot, not on - the reference object itself, unless the caller explicitly opens the reference - object for writing (to advance the HEAD). - -- **View resolution** — a view's `ParseProcedure` reparses to its base relations - internally, subject to the capability security constraint in §2: the reparse - happens inside the runtime; the caller's handle and access mask stay bound to - the view. - -- **Atomic multi-reference updates** — pushing to both `main` and `audit_log` - must be all-or-nothing. The implementation should acquire exclusive locks on all - involved namespace entries before updating any of them. If a Contention() check - fails on any entry, release all locks and abort the batch. This preserves audit - consistency. - -- **Cycle guard** — view definitions may reference other views. Name resolution - must track reparse depth and fail with an error after a bounded number of - iterations (30 is the ReactOS figure; a similar constant is appropriate here). - -- **Audit branch** — audit is a write concern that spans all branches. It should - be modelled as an independent branch whose HEAD is the only contention point for - audit-affecting operations, dissociated from the data branch scope. - -**TODOs:** `NamespaceReferenceManager` — implement `Resolve(path)` with reparse -loop and cycle guard. Define the reference object type with an `exclusive` flag -and a `ParseProcedure` that rewrites the path. Define the batch-update API with -all-or-nothing semantics. - ---- - -## Priority Order - -| Priority | Item | Header(s) affected | -|---|---|---| -| 1 | Dual ref counting — implement `Pin` / `Unpin` | `LifecycleManager.h` | -| 2 | Type callbacks — replace `methods` set with function pointers | `ObjectManager.h`, `IdentityManager.h` | -| 3 | Per-handle access mask | `HandlerManager.h` | -| 4 | Exclusive flag → real `Contention()` for branch HEADs | `ObjectManager.h`, `LifecycleManager.h` | -| 5 | Trie / hash directory for `ObjectManager::Find` | `ObjectManager.h` | -| 6 | `NamespaceReferenceManager` reparse layer | `NamespaceReferenceManager.h` | -| 7 | Shared SD cache (no inheritance, content-addressed) | `PermissionsManager.h` | -| 8 | Deferred GC queue in `Unmonitor` | `LifecycleManager.h` | diff --git a/docs/tarski-sakura-separation.md b/docs/tarski-sakura-separation.md deleted file mode 100644 index a33e2e3..0000000 --- a/docs/tarski-sakura-separation.md +++ /dev/null @@ -1,98 +0,0 @@ -# Tarski / Sakura Separation of Concerns - -This document describes how query analysis responsibilities are divided between -the **Sakura** OCaml frontend and the **Tarski** FOL runtime inside the C++ VM. - -## The Two Runtimes - -The VM hosts two distinct execution cores: - -| Core | Language | Responsibility | -|---|---|---| -| **Tarski** | C++ (this repo) | Mechanical FOL plan execution via Volcano pull model | -| **Sakura** | OCaml | Query parsing, cardinality analysis, plan emission, physical storage | - -Sakura is the authoritative source of data and of query semantics. The SQLite -backend in this repository exists only for isolated testing; in production, -CursorManager streams data from Sakura over a well-defined interface. - -## What Sakura Is Responsible For - -### Cardinality analysis and constraint propagation - -Every relation in Sakura carries a cardinality tag: `Finite`, `ConstrainedFinite`, -`AlephZero`, or `Continuum`. When a query joins multiple relations, Sakura -propagates these tags through the plan to determine the cardinality of the result. - -This analysis is non-trivial. Consider: - -```karuta -natural[A], natural[B], natural[C], plus[A,B,C], eq[C, 10]. -``` - -Each of `natural`, `plus`, and `eq` is individually `AlephZero`. But Sakura can -determine that binding `C = 10` via `eq` constrains `plus[A,B,10]` to a finite -set of natural-number pairs, making the overall result finite. Replacing -`natural` with `integer` changes the result to infinite, because negative pairs -also satisfy `plus[A,B,10]`. - -Tarski does not repeat this analysis. It receives a plan that is already -annotated with cardinality metadata and executes it mechanically. - -### Termination guarantees - -If a query produces an infinite result set, Sakura adds a `TAKE` node to the -plan before emission. Tarski enforces the `TAKE` limit but makes no independent -judgement about whether a plan terminates. - -### Join ordering - -Sakura orders the children of each JOIN so that variables are bound from the -outer (left) side before the inner (right) side is probed. This ensures that -builtin relations — which may have `AlephZero` cardinality when arguments are -unbound — are always probed with fully or partially bound arguments, enabling -O(1) membership validation rather than unbounded enumeration. - -### Physical storage - -Sakura owns the physical storage layer. CursorManager pulls paginated tuple -streams from Sakura; the cursor abstraction hides whether the underlying data -comes from a stored relation or an ephemeral builtin generator. - -## What Tarski Is Responsible For - -### Mechanical plan execution - -Tarski receives a complete, annotated plan tree from Sakura and executes it via -the Volcano pull model: `VM::Next(PlanNode*)` propagates demand from the root -to the leaves, returning one tuple at a time. - -### Cardinality-aware execution strategy - -Each `PlanNode` carries the cardinality tag Sakura attached at plan time. Tarski -uses this tag only to choose an execution strategy — never to reason about -termination: - -- **Finite / ConstrainedFinite inner side** → safe to materialize for - nested-loop join. -- **AlephZero inner side, all args bound** → probe via `membership_criteria` - in O(1); the generator is never called. -- **AlephZero inner side, unbound args** → should not occur; Sakura must have - added a `TAKE` node or reordered the join. Tarski may assert in debug builds. - -### TAKE enforcement - -`TAKE` is a first-class node in the plan tree. When `VM::Next` passes through a -`TAKE` node it decrements a counter and returns `nullptr` once the limit is -reached, regardless of what the subtree would produce. - -## Why This Division Is Correct - -The cardinality analysis described above requires understanding the **semantics** -of each relation — what `plus` means over naturals versus integers, how `eq` -interacts with a functional relation, and so on. That knowledge lives in Sakura. -Duplicating it in Tarski would couple two layers that must remain independent and -would place type-level reasoning inside a mechanical executor. - -Tarski's contract is simple: given a safe plan, produce correct tuples. Sakura's -contract is: emit only safe plans. diff --git a/lib/Utilities.ml b/lib/Utilities.ml index a6b36c7..e4ee9c3 100644 --- a/lib/Utilities.ml +++ b/lib/Utilities.ml @@ -1,3 +1,9 @@ +module Ordering = struct + type t = Equal | Smaller | Greater + + let of_int x = if x < 0 then Smaller else if x > 0 then Greater else Equal +end + module Result = struct let ( let* ) = Result.bind let fmap f m = Result.bind m f @@ -69,3 +75,25 @@ module FingerTree = struct BatFingerTree.print ~first:"" ~last:"" ~sep:sep BatIO.nwrite |> Fun.flip BatIO.to_string ss end + +module Option = struct + let ( let* ) = Option.bind + let fmap f m = Option.bind m f +end + +module Atomic = struct + let rec swap atom f = + let v = Atomic.get atom in + let v' = f v in + if Atomic.compare_and_set atom v v' + then atom + else swap atom f + + let rec mswap atom f = + let open Result in + let v = Atomic.get atom in + let* v' = f v in + if Atomic.compare_and_set atom v v' + then Ok atom + else mswap atom f +end diff --git a/lib/Utilities.mli b/lib/Utilities.mli index 2735009..f149889 100644 --- a/lib/Utilities.mli +++ b/lib/Utilities.mli @@ -1,3 +1,9 @@ +module Ordering : sig + type t = Equal | Smaller | Greater + + val of_int : int -> t +end + module Result : sig val ( let* ) : ('a, 'e) result -> ('a -> ('b, 'e) result) -> ('b, 'e) result val fmap : ('a -> ('b, 'e) result) -> ('a, 'e) result -> ('b, 'e) result @@ -7,6 +13,17 @@ module List : sig val sequence : ('a, 'b) result list -> ('a list, 'b) result end +module Option : sig + val ( let* ) : 'a option -> ('a -> 'b option) -> 'b option + val fmap : ('a -> 'b option) -> 'a option -> 'b option +end + +module Atomic : sig + val swap : 'a Atomic.t -> ('a -> 'a) -> 'a Atomic.t + (* This is silly *) + val mswap : 'a Atomic.t -> ('a -> ('a, 'b) result) -> ('a Atomic.t, 'b) result +end + module FingerTree : sig val map2 : ('a -> 'b -> 'c) -> 'a BatFingerTree.t -> 'b BatFingerTree.t -> 'c BatFingerTree.t val zip : 'a BatFingerTree.t -> 'b BatFingerTree.t -> ('a * 'b) BatFingerTree.t diff --git a/lib/abstract/Storage.ml b/lib/abstract/Storage.ml index 5eaeba3..19d6c5c 100644 --- a/lib/abstract/Storage.ml +++ b/lib/abstract/Storage.ml @@ -7,6 +7,8 @@ module type STORAGE = sig type connection type transaction + type address = Label of string | Hash of Concepts.Hash.hash + val connect : Concepts.Configuration.term -> (connection, Concepts.Condition.condition) result (** begin a transaction within `connection` *) @@ -21,13 +23,13 @@ module type STORAGE = sig (** within a transaction, fetch a blob from disk *) val get : transaction -> - Concepts.Hash.hash -> - (Concepts.Representation.blob option, Concepts.Condition.condition) result + address -> + (Concepts.Blob.t option, Concepts.Condition.condition) result (** within a transaction, associate a hash with a blob on disk *) val put : transaction -> - Concepts.Hash.hash -> - Concepts.Representation.blob -> + address -> + Concepts.Blob.t -> (unit, Concepts.Condition.condition) result end diff --git a/lib/backend/execution/FOL.ml b/lib/backend/execution/FOL.ml deleted file mode 100644 index 7da890d..0000000 --- a/lib/backend/execution/FOL.ml +++ /dev/null @@ -1,110 +0,0 @@ -(* @uses Tuple -- project, rename, merge over result streams *) -(* @needs Value *) -(* @needs Path *) -(* @needs Condition *) - -module Plan = struct - type path_arg = Var of string | Const of Concepts.Value.value - - type t = - | Scan of {path: Concepts.Path.t; args: path_arg BatFingerTree.t} - | Natural of {left: t; right: t} - | Take of {limit: int; from: t} - | Project of {attrs: BatSet.String.t; from: t} - | Materialize of t - | Rename of {attrs: string BatMap.String.t; from: t} - | Union of t BatFingerTree.t -end - -type stream = (Concepts.Tuple.t, Concepts.Condition.condition) result BatSeq.t - -let singleton (x : ('a, 'e) result) : ('a, 'e) result BatSeq.t = - fun () -> BatSeq.Cons (x, BatSeq.empty) - -module Error = struct - open Concepts.Condition - - let unbound_variable name = - condition "unbound-variable" - (Printf.sprintf "path variable %S is not bound in the enclosing tuple" name) - ("variable" |=| Concepts.Value.String name) -end - -let resolve (args : Plan.path_arg BatFingerTree.t) (bindings : Concepts.Tuple.t) : - (Concepts.Value.value BatFingerTree.t, Concepts.Condition.condition) result = - let open Utilities.Result in - BatFingerTree.fold_left - (fun acc arg -> - let* acc = acc in - let* value = - match arg with - | Plan.Const value -> Ok value - | Plan.Var name -> - Option.to_result ~none:(Error.unbound_variable name) - (Concepts.Tuple.access name bindings) - in - Ok (BatFingerTree.snoc acc value) ) - (Ok BatFingerTree.empty) args - -module Make (Handler : Managers.Handle.HANDLER) = struct - let scan handler ~path ~args : stream = - let opened = - let open Utilities.Result in - let* handle = Handler.open_ handler ~path in - Handler.open_cursor handle ~args - in - match opened with - | Error condition -> singleton (Error condition) - | Ok cursor -> - let rec pull () = - match Handler.next cursor with - | Error condition -> BatSeq.Cons (Error condition, BatSeq.empty) - | Ok None -> BatSeq.Nil - | Ok (Some tuple) -> BatSeq.Cons (Ok tuple, pull) - in - pull - - let rec compile handler : Plan.t -> Concepts.Tuple.t -> stream = function - | Scan {path; args} -> ( - fun bindings -> - match resolve args bindings with - | Ok args -> scan handler ~path ~args - | Error condition -> singleton (Error condition) ) - | Project {attrs; from} -> - let from = compile handler from in - fun bindings -> BatSeq.map (Result.map (Concepts.Tuple.project attrs)) (from bindings) - | Rename {attrs; from} -> - let from = compile handler from in - fun bindings -> BatSeq.map (Result.map (Concepts.Tuple.rename attrs)) (from bindings) - | Take {limit; from} -> - let from = compile handler from in - fun bindings -> BatSeq.take limit (from bindings) - | Union plans -> - let compiled = BatFingerTree.map (compile handler) plans in - fun bindings -> - BatFingerTree.fold_right - (fun rest c -> BatSeq.append (c bindings) rest) - BatSeq.empty compiled - | Natural {left; right} -> - let left = compile handler left and right = compile handler right in - let matches l r = - BatMap.String.for_all - (fun name value -> - match Concepts.Tuple.access name r with Some value' -> value = value' | None -> true ) - l - in - fun bindings -> - left bindings - |> BatSeq.concat_map (function - | Error _ as error -> singleton error - | Ok l -> - right l - |> BatSeq.filter (function Ok r -> matches l r | Error _ -> true) - |> BatSeq.map (Result.map (Concepts.Tuple.merge l)) ) - | Materialize from -> - let cached = lazy (BatSeq.memoize (compile handler from Concepts.Tuple.empty)) in - fun _ -> Lazy.force cached - - (* TODO: This should produce ephemeral relations with support of the sublanguage to manage it. *) - let run handler plan : stream = compile handler plan Concepts.Tuple.empty -end diff --git a/lib/backend/managers/Cursor.ml b/lib/backend/managers/Cursor.ml deleted file mode 100644 index 7fdbb6f..0000000 --- a/lib/backend/managers/Cursor.ml +++ /dev/null @@ -1,24 +0,0 @@ -(* @composes Storage -- functor parameter *) -(* @needs Path *) -(* @needs Tuple *) -(* @needs Value *) -(* @needs Condition *) - -type descriptor = - | Stored of {merkle_root: string} - | Ephemeral of {merkle_root: string; dependencies: Concepts.Path.t BatFingerTree.t} - -module Make (Store : Abstract.Storage.STORAGE) = struct - type cursor = unit - - let open_ (_txn : Store.transaction) (descriptor : descriptor) - ~(args : Concepts.Value.value BatFingerTree.t) : (cursor, Concepts.Condition.condition) result - = - ignore (descriptor, args); - failwith "NOT IMPLEMENTED: open a cursor by paging the relation's Merkle tree over Store.get" - - let next (_cursor : cursor) : (Concepts.Tuple.t option, Concepts.Condition.condition) result = - failwith "NOT IMPLEMENTED: page the next tuple over Store.get" - - let close (_cursor : cursor) : unit = () -end diff --git a/lib/backend/managers/Cursor.mli b/lib/backend/managers/Cursor.mli deleted file mode 100644 index a4dec44..0000000 --- a/lib/backend/managers/Cursor.mli +++ /dev/null @@ -1,16 +0,0 @@ -type descriptor = - | Stored of {merkle_root: string} - | Ephemeral of {merkle_root: string; dependencies: Concepts.Path.t BatFingerTree.t} - -module Make (Store : Abstract.Storage.STORAGE) : sig - type cursor - - val open_ : - Store.transaction -> - descriptor -> - args:Concepts.Value.value BatFingerTree.t -> - (cursor, Concepts.Condition.condition) result - - val next : cursor -> (Concepts.Tuple.t option, Concepts.Condition.condition) result - val close : cursor -> unit -end diff --git a/lib/backend/managers/Handle.ml b/lib/backend/managers/Handle.ml deleted file mode 100644 index be84972..0000000 --- a/lib/backend/managers/Handle.ml +++ /dev/null @@ -1,64 +0,0 @@ -(* @composes Storage -- functor parameter *) -(* @composes Cursor -- applies Cursor.Make (Store) *) -(* @uses Object -- find, registry/kind inspection *) -(* @uses Condition -- builds not-a-relation / no-such-object errors *) -(* @needs Path *) -(* @needs Tuple *) -(* @needs Value *) - -module type HANDLER = sig - type t - type handle - type cursor - - val open_ : t -> path:Concepts.Path.t -> (handle, Concepts.Condition.condition) result - - val open_cursor : - handle -> - args:Concepts.Value.value BatFingerTree.t -> - (cursor, Concepts.Condition.condition) result - - val next : cursor -> (Concepts.Tuple.t option, Concepts.Condition.condition) result - val close : cursor -> unit -end - -let not_a_relation () : Concepts.Condition.condition = - Concepts.Condition.condition "not-a-relation" - "handle does not refer to a stored or ephemeral relation" Concepts.Condition.empty - -let no_such_object () : Concepts.Condition.condition = - Concepts.Condition.condition "no-such-object" "no object registered at the given path" - Concepts.Condition.empty - -module Make (Store : Abstract.Storage.STORAGE) = struct - module Cur = Cursor.Make (Store) - - type t = {objects: Object.rnt_object_tree; txn: Store.transaction} - type handle = {object_: Object.registry; txn: Store.transaction} - type cursor = Cur.cursor - - let create objects txn = {objects; txn} - - let open_ t ~path = - match Object.find path t.objects with - | Some object_ -> Ok {object_; txn= t.txn} - | None -> Error (no_such_object ()) - - let relation_descriptor (object_ : Object.registry) : - (Cursor.descriptor, Concepts.Condition.condition) result = - let {Object.entry; _} = object_ in - match entry.Object.kind with - | Object.Relation {merkle_root} -> Ok (Cursor.Stored {merkle_root}) - | Object.EphemeralRelation {merkle_root; dependencies} -> - Ok (Cursor.Ephemeral {merkle_root; dependencies}) - | _ -> Error (not_a_relation ()) - - let open_cursor handle ~args = - let open Utilities.Result in - let* descriptor = relation_descriptor handle.object_ in - Cur.open_ handle.txn descriptor ~args - - let next = Cur.next - let close = Cur.close - let object_ (handle : handle) = handle.object_ -end diff --git a/lib/backend/managers/Handle.mli b/lib/backend/managers/Handle.mli deleted file mode 100644 index 5fc82b8..0000000 --- a/lib/backend/managers/Handle.mli +++ /dev/null @@ -1,22 +0,0 @@ -module type HANDLER = sig - type t - type handle - type cursor - - val open_ : t -> path:Concepts.Path.t -> (handle, Concepts.Condition.condition) result - - val open_cursor : - handle -> - args:Concepts.Value.value BatFingerTree.t -> - (cursor, Concepts.Condition.condition) result - - val next : cursor -> (Concepts.Tuple.t option, Concepts.Condition.condition) result - val close : cursor -> unit -end - -module Make (Store : Abstract.Storage.STORAGE) : sig - include HANDLER - - val create : Object.rnt_object_tree -> Store.transaction -> t - val object_ : handle -> Object.registry -end diff --git a/lib/backend/managers/Identity.ml b/lib/backend/managers/Identity.ml deleted file mode 100644 index bfde226..0000000 --- a/lib/backend/managers/Identity.ml +++ /dev/null @@ -1,7 +0,0 @@ -(* @needs Object *) - -let permits (object_ : Object.registry) (method_ : Object.rnt_method) : bool = - BatSet.mem method_ object_.Object.entry.Object.methods - -let can_open (object_ : Object.registry) : bool = permits object_ Object.OPEN -let can_close (object_ : Object.registry) : bool = permits object_ Object.CLOSE diff --git a/lib/backend/managers/Identity.mli b/lib/backend/managers/Identity.mli deleted file mode 100644 index 589002e..0000000 --- a/lib/backend/managers/Identity.mli +++ /dev/null @@ -1,3 +0,0 @@ -val permits : Object.registry -> Object.rnt_method -> bool -val can_open : Object.registry -> bool -val can_close : Object.registry -> bool diff --git a/lib/backend/managers/Lifecycle.ml b/lib/backend/managers/Lifecycle.ml deleted file mode 100644 index d104249..0000000 --- a/lib/backend/managers/Lifecycle.ml +++ /dev/null @@ -1,110 +0,0 @@ -(* The lifecycle manager decides when a registered object may leave memory. - It works purely on the object tree and never touches storage: collection - here means dropping the in-memory registry entry, not deleting anything on - disk. Durable-backed objects (relations, multigroups, branch trees) can be - rebuilt from their encoded form on the next access, so evicting them is - safe and keeps memory bounded. Runtime-only objects (sessions, and later - transactions) have no durable form, so their collection is a real teardown; - the manager surfaces those to the caller as disposals rather than acting on - storage itself. *) - -(* @uses Object -- find/update, unregister, reference_edges, has_children *) -(* @needs Path *) -(* @needs Condition *) - -type tree = Object.rnt_object_tree - -(* A runtime object that was collected and now needs an external teardown the - lifecycle manager cannot perform on its own: closing a session, and later - rolling back a transaction. The caller drains these after a collect. *) -type disposal = {path: Concepts.Path.t; kind: Object.rnt_object_kind} - -let monitor (tree : tree) (path : Concepts.Path.t) : tree = - Object.update path (fun r -> {r with Object.handle_count= r.Object.handle_count + 1}) tree - -(* Pin is an explicit keep-alive that bypasses collection. It does not touch - reference_count: pinning is a decision, reference counting is bookkeeping of - real edges. Keeping them separate is what stops the two from being mistaken - for each other. *) -let pin (tree : tree) (path : Concepts.Path.t) : tree = - Object.update path (fun r -> {r with Object.pinned= true}) tree - -let unpin (tree : tree) (path : Concepts.Path.t) : tree = - Object.update path (fun r -> {r with Object.pinned= false}) tree - -(* An object may be collected only when nothing holds it open, nothing depends - on it, it has not been pinned, and its kind is not exempt (a branch). This - works on the registry record directly so callers that already hold it (the - cascade) need not walk the tree a second time. *) -let registry_eligible (r : Object.registry) : bool = - r.Object.handle_count = 0 - && r.Object.reference_count = 0 - && (not r.Object.pinned) - && not (Object.is_gc_exempt r.Object.entry.Object.kind) - -let is_eligible_for_gc (tree : tree) (path : Concepts.Path.t) : bool = - match Object.find path tree with Some r -> registry_eligible r | None -> false - -(* Contention reports whether a mutation must wait. An exclusive object with an - open handle, such as a branch head being read, cannot be modified until the - handle closes. This gates writers; it is not part of collection. *) -let contention (tree : tree) (path : Concepts.Path.t) : bool = - match Object.find path tree with - | Some r -> r.Object.entry.Object.exclusive && r.Object.handle_count > 0 - | None -> false - -(* Cascade the collection at path, threading the pruned tree and the disposals - gathered so far. Disposals are appended (snoc) as each object is torn down, - so the finger tree hands them back parent-first, left-to-right without any - reversal pass. - - Order of teardown falls out of the counts. Collecting an object drops the - reference_count of every input it depended on (Object.unregister undoes the - edges), which can make those inputs eligible in turn, so we recurse into - them. A populated namespace is kept, not collected and not an error: it is - scaffolding for the objects still living under it. *) -let rec cascade (tree : tree) (disposals : disposal BatFingerTree.t) (path : Concepts.Path.t) : - (tree * disposal BatFingerTree.t, Concepts.Condition.condition) result = - match Object.find path tree with - | None -> Ok (tree, disposals) - | Some r when not (registry_eligible r) -> Ok (tree, disposals) - | Some r -> - let kind = r.Object.entry.Object.kind in - begin match kind with - | Object.Namespace _ when Object.has_children path tree -> Ok (tree, disposals) - | _ -> - let edges = Object.reference_edges kind in - let disposals = - if Object.is_runtime kind then BatFingerTree.snoc disposals {path; kind} else disposals - in - Result.bind (Object.unregister path tree) (fun tree -> - BatFingerTree.fold_left - (fun acc dep -> Result.bind acc (fun (tree, disposals) -> cascade tree disposals dep)) - (Ok (tree, disposals)) - edges ) - end - -let try_collect (tree : tree) (path : Concepts.Path.t) : - (tree * disposal BatFingerTree.t, Concepts.Condition.condition) result = - cascade tree BatFingerTree.empty path - -(* Close a handle, then see whether the object can now go. *) -let unmonitor (tree : tree) (path : Concepts.Path.t) : - (tree * disposal BatFingerTree.t, Concepts.Condition.condition) result = - let tree = - Object.update path - (fun r -> - if r.Object.handle_count = 0 then r - else {r with Object.handle_count= r.Object.handle_count - 1} ) - tree - in - try_collect tree path - -(* Public entry point for an explicit collection request. *) -let collect (tree : tree) (path : Concepts.Path.t) : - (tree * disposal BatFingerTree.t, Concepts.Condition.condition) result = - try_collect tree path - -(* Session reaping is not built here yet. A lost connection is detected by a - per-session inactivity timer whose expiry drives collect on the session. - Design and tasks are tracked in issue #24. *) diff --git a/lib/backend/managers/Lifecycle.mli b/lib/backend/managers/Lifecycle.mli deleted file mode 100644 index f8cec1a..0000000 --- a/lib/backend/managers/Lifecycle.mli +++ /dev/null @@ -1,17 +0,0 @@ -type tree = Object.rnt_object_tree - -(* A collected runtime object that still needs an external teardown: a session - to close, and later a transaction to roll back. The caller drains these. *) -type disposal = {path: Concepts.Path.t; kind: Object.rnt_object_kind} - -val monitor : tree -> Concepts.Path.t -> tree -val pin : tree -> Concepts.Path.t -> tree -val unpin : tree -> Concepts.Path.t -> tree -val is_eligible_for_gc : tree -> Concepts.Path.t -> bool -val contention : tree -> Concepts.Path.t -> bool - -val unmonitor : - tree -> Concepts.Path.t -> (tree * disposal BatFingerTree.t, Concepts.Condition.condition) result - -val collect : - tree -> Concepts.Path.t -> (tree * disposal BatFingerTree.t, Concepts.Condition.condition) result diff --git a/lib/backend/managers/Namespace.ml b/lib/backend/managers/Namespace.ml deleted file mode 100644 index a48fef9..0000000 --- a/lib/backend/managers/Namespace.ml +++ /dev/null @@ -1,14 +0,0 @@ -(* @composes Storage -- functor parameter *) -(* @needs Object *) -(* @needs Path *) -(* @needs Condition *) - -module Make (Store : Abstract.Storage.STORAGE) = struct - type tree = Object.rnt_object_tree - - let resolve (_txn : Store.transaction) (_tree : tree) (_path : Concepts.Path.t) : - (Concepts.Path.t, Concepts.Condition.condition) result = - failwith - "NOT IMPLEMENTED: reparse loop with cycle guard; /system/branches/<n>/<sub> -> \ - /system/snapshots/<target_hash>/<sub> via Branch.target_hash" -end diff --git a/lib/backend/managers/Namespace.mli b/lib/backend/managers/Namespace.mli deleted file mode 100644 index 1ee9651..0000000 --- a/lib/backend/managers/Namespace.mli +++ /dev/null @@ -1,9 +0,0 @@ -module Make (Store : Abstract.Storage.STORAGE) : sig - type tree = Object.rnt_object_tree - - val resolve : - Store.transaction -> - tree -> - Concepts.Path.t -> - (Concepts.Path.t, Concepts.Condition.condition) result -end diff --git a/lib/backend/managers/Object.ml b/lib/backend/managers/Object.ml deleted file mode 100644 index ae5f5c1..0000000 --- a/lib/backend/managers/Object.ml +++ /dev/null @@ -1,241 +0,0 @@ -(* @uses Path -- snoc, to_string when building registry paths *) -(* @uses Condition -- builds registry-object/path errors *) -(* @needs Value *) - -type multigroup = {merkle_root: string} -type relation = {merkle_root: string} - -(* An ephemeral relation is a stored plan that reads other relations. Its - dependencies are the inputs that plan replays over. They are branch-local - symlink paths, not version-pinned paths: as the branch head advances the - inputs move with it, and Namespace.resolve turns the symlink into whatever - object is current on this branch hash. Keeping them as paths (not hashes) - is what lets an ephemeral relation behave like a view. *) -type ephemeral_relation = {merkle_root: string; dependencies: Concepts.Path.t BatFingerTree.t} -type transaction = unit -type session = {connection_context: unit; branch_overrides: string BatMap.String.t} -type branch = {name: string; target_hash: string} -type branch_tree = {merkle_root: string} - -type rnt_object_kind = - | Multigroup of multigroup - | Relation of relation - | EphemeralRelation of ephemeral_relation - | Session of session - | Branch of branch - | BranchTree of branch_tree - | Namespace of namespace - -and namespace = {label: string; predicate: rnt_object_kind -> bool} - -type rnt_method = OPEN | CLOSE - -type rnt_object = - {kind: rnt_object_kind; disposable: bool; methods: rnt_method BatSet.t; exclusive: bool} - -(* Three independent facts about a registered object, kept apart on purpose: - - - handle_count: how many handles are open on it right now (open/close). - - reference_count: how many other objects depend on it staying resident. - This is bookkeeping of real edges, nothing more. It goes up because a - dependency exists, not because someone asked to keep the object alive. - - pinned: an explicit override that bypasses collection regardless of the - counts. Used when something must not be evicted even though nothing - currently points at it or holds it open. This is deliberately separate - from reference_count so the two reasons never get confused. *) -type registry = {reference_count: int; handle_count: int; pinned: bool; entry: rnt_object} - -(* - /system/branch/branch1/multigrop/multigroup1/relation/relation1 - /system/branch1/multigrop/multigroup1/relation/relation2 - /system/branch1/multigrop/multigroup1/ephemeral_relation/ephemeral_relation1 - /system/transaction/xyz_txn - *) - -type rnt_object_tree = {data: registry; subsequent: rnt_object_tree BatMap.String.t} - -module Error = struct - open Concepts.Condition - - let registry_object_already_registered path = - let msg = "An object is already registered in the path" in - condition "registry-object-already-registered" msg - ("path" |=| Concepts.Value.String (Concepts.Path.to_string path)) - - let registry_path_not_found path = - let msg = "The provided path was not found" in - condition "registry-path-not-found" msg - ("path" |=| Concepts.Value.String (Concepts.Path.to_string path)) -end - -let make_object ?(disposable = false) ?(exclusive = false) ?(methods = BatSet.empty) - (kind : rnt_object_kind) : rnt_object = - {kind; disposable; methods; exclusive} - -(* The empty registry. The root node is the system namespace itself, and every - other object is registered under it. Path separators are only a string - rendering concern, so there is no distinct "/" node above system: system is - the root. It is exempt from collection for the same reason a branch is, it - is the way in to everything else. *) -let root : rnt_object_tree = - { data= - { reference_count= 0; - handle_count= 0; - pinned= false; - entry= make_object (Namespace {label= "system"; predicate= (fun _ -> true)}) }; - subsequent= BatMap.String.empty } - -let find (path : Concepts.Path.t) (tree : rnt_object_tree) : registry option = - let rec walk components node = - match BatFingerTree.front components with - | None -> Some node.data - | Some (tail, head) -> Option.bind (BatMap.String.find_opt head node.subsequent) (walk tail) - in - walk path tree - -let update (path : Concepts.Path.t) (f : registry -> registry) (tree : rnt_object_tree) : - rnt_object_tree = - let rec walk components node = - match BatFingerTree.front components with - | None -> {node with data= f node.data} - | Some (tail, head) -> - begin match BatMap.String.find_opt head node.subsequent with - | None -> node - | Some child -> - {node with subsequent= BatMap.String.add head (walk tail child) node.subsequent} - end - in - walk path tree - -(* The objects that must stay resident for this object to remain replayable. - Registering an object bumps the reference_count of each edge target and - unregistering drops it, so reference counts stay in step with the real - dependency graph. Only ephemeral relations carry edges today. Which kinds - grow edges is a per-kind decision, which is why this lives next to the - registry and not in the lifecycle manager: the object knows its own shape. *) -let reference_edges (kind : rnt_object_kind) : Concepts.Path.t BatFingerTree.t = - match kind with - | EphemeralRelation {dependencies; _} -> dependencies - | Multigroup _ | Relation _ | Session _ | Branch _ | BranchTree _ | Namespace _ -> - BatFingerTree.empty - -(* Adjust the reference_count of every edge target by delta. A target that is - not present is skipped: update leaves the tree untouched when the path is - missing. That is fine for a skeleton, but it hides a dangling dependency, - so registration will eventually want to fail loudly on a missing input. *) -let adjust_references (delta : int) (paths : Concepts.Path.t BatFingerTree.t) - (tree : rnt_object_tree) : rnt_object_tree = - BatFingerTree.fold_left - (fun tree path -> - update path (fun r -> {r with reference_count= r.reference_count + delta}) tree ) - tree paths - -(* A branch is exempt from collection because everything is reachable through - it: collecting a branch would orphan its whole subtree. Every other kind is - collectable, including sessions. A session is runtime-only state with no - durable encoding, so collecting one is a real teardown rather than an - eviction, but it still happens (see Lifecycle for how a dead session is - detected). *) -let is_gc_exempt (kind : rnt_object_kind) : bool = match kind with Branch _ -> true | _ -> false - -(* Runtime-only kinds have no durable encoding, so collecting them cannot be - undone by rehydrating from disk. The lifecycle manager surfaces these to - its caller as disposals to run (a session close, and later a transaction - rollback once transactions become objects in their own right). *) -let is_runtime (kind : rnt_object_kind) : bool = match kind with Session _ -> true | _ -> false - -let has_children (path : Concepts.Path.t) (tree : rnt_object_tree) : bool = - let rec walk components node = - match BatFingerTree.front components with - | None -> not (BatMap.String.is_empty node.subsequent) - | Some (tail, head) -> - begin match BatMap.String.find_opt head node.subsequent with - | None -> false - | Some child -> walk tail child - end - in - walk path tree - -(* TODO: This function is not tail call optimized. We ventured with - the idea of using CPS, but that's not going to solve anything here, - so the probable best course of action is relying on the growing map - to carry on the state. This is not a big deal as the structure is - expected to be small enough to live in memory and these operations - are relatively uncommon. *) -let register (path : Concepts.Path.t) (object' : rnt_object) (tree : rnt_object_tree) : - (rnt_object_tree, Concepts.Condition.condition) result = - let rec insert components node = - match BatFingerTree.front components with - | None -> Error (Error.registry_object_already_registered path) - | Some (tail, head) when BatFingerTree.is_empty tail -> - if BatMap.String.mem head node.subsequent then - Error (Error.registry_object_already_registered path) - else - let child = - { data= {reference_count= 0; handle_count= 0; pinned= false; entry= object'}; - subsequent= BatMap.String.empty } - in - Ok {node with subsequent= BatMap.String.add head child node.subsequent} - | Some (tail, head) -> - begin match BatMap.String.find_opt head node.subsequent with - | None -> Error (Error.registry_path_not_found path) - | Some child -> - Result.map (fun child' -> - {node with subsequent= BatMap.String.add head child' node.subsequent} ) - @@ insert tail child - end - in - (* On success, record the new object's dependency edges by bumping the - reference_count of each input it reads. This is the polymorphic part of - registration: the edge set comes from the object's own kind. *) - Result.map - (fun tree -> adjust_references 1 (reference_edges object'.kind) tree) - (insert path tree) - -let with_namespace (parent : Concepts.Path.t) (namespace_label : string) - (predicate : rnt_object_kind -> bool) (name : string) (object' : rnt_object) - (tree : rnt_object_tree) : (rnt_object_tree, Concepts.Condition.condition) result = - let namespace_path = Concepts.Path.snoc parent namespace_label in - let tree_with_namespace = - match find namespace_path tree with - | None -> - register namespace_path (make_object (Namespace {label= namespace_label; predicate})) tree - | Some _ -> Ok tree - in - Result.bind tree_with_namespace (fun tree -> - register (Concepts.Path.snoc namespace_path name) object' tree ) - -let construct_multigroup parent name (mg : multigroup) tree = - with_namespace parent "multigroup" - (function Multigroup _ -> true | _ -> false) - name (make_object (Multigroup mg)) tree - -let construct_relation parent name (rel : relation) tree = - with_namespace parent "relation" - (function Relation _ -> true | _ -> false) - name (make_object (Relation rel)) tree - -let unregister (path : Concepts.Path.t) (tree : rnt_object_tree) : - (rnt_object_tree, Concepts.Condition.condition) result = - (* Read the edges before removing the node so we can undo what register did: - dropping an object releases its hold on the inputs it depended on. *) - let edges = - match find path tree with Some r -> reference_edges r.entry.kind | None -> BatFingerTree.empty - in - let rec remove components node = - match BatFingerTree.front components with - | None -> Error (Error.registry_path_not_found path) - | Some (tail, head) when BatFingerTree.is_empty tail -> - if BatMap.String.mem head node.subsequent then - Ok {node with subsequent= BatMap.String.remove head node.subsequent} - else Error (Error.registry_path_not_found path) - | Some (tail, head) -> - begin match BatMap.String.find_opt head node.subsequent with - | None -> Error (Error.registry_path_not_found path) - | Some child -> - Result.map (fun child' -> - {node with subsequent= BatMap.String.add head child' node.subsequent} ) - @@ remove tail child - end - in - Result.map (fun tree -> adjust_references (-1) edges tree) (remove path tree) diff --git a/lib/backend/storage/LMDB.ml b/lib/backend/storage/LMDB.ml index ff5eb3d..0f65aaf 100644 --- a/lib/backend/storage/LMDB.ml +++ b/lib/backend/storage/LMDB.ml @@ -129,6 +129,8 @@ end type connection = {env: C.mdb_env_ptr; dbi: C.mdb_dbi} type transaction = {tx: C.mdb_txn_ptr; dbi: C.mdb_dbi} +type address = Label of string | Hash of Concepts.Hash.hash + let parse (c : Concepts.Configuration.term) = let open Concepts.Configuration in let open Utilities.Result in @@ -170,16 +172,20 @@ let abort ({tx; _} : transaction) = C.mdb_txn_abort tx |> Result.map_error Error * opens the path for avoiding a copy on the FFI boundary later on *) -let get ({tx; dbi} : transaction) (h : Concepts.Hash.hash) = - begin match C.mdb_get' tx dbi (Concepts.Hash.bytes_of_hash h) with - | Ok x -> Ok (Some (Concepts.Representation.blob_of_bytes x)) +let bytes_of_address = function + | Label s -> String.to_bytes s + | Hash h -> Concepts.Hash.bytes_of_hash h + +let get ({tx; dbi} : transaction) (addr : address) = + begin match C.mdb_get' tx dbi (bytes_of_address addr) with + | Ok x -> Ok (Some (Concepts.Blob.blob_of_bytes x)) | Error e when e = C.Errors.mdb_notfound -> Ok None | Error e -> Error e end |> Result.map_error Error.lmdb_error -let put ({tx; dbi} : transaction) (h : Concepts.Hash.hash) (b : Concepts.Representation.blob) = - C.mdb_put' tx dbi (Concepts.Hash.bytes_of_hash h) - (Concepts.Representation.bytes_of_blob b) +let put ({tx; dbi} : transaction) (addr : address) (b : Concepts.Blob.t) = + C.mdb_put' tx dbi (bytes_of_address addr) + (Concepts.Blob.bytes_of_blob b) Unsigned.UInt.zero |> Result.map_error Error.lmdb_error diff --git a/lib/concepts/Blob.ml b/lib/concepts/Blob.ml new file mode 100644 index 0000000..c5d7d5c --- /dev/null +++ b/lib/concepts/Blob.ml @@ -0,0 +1,17 @@ +(* @needs Value *) + +(* The intent of this being an abstract type is to allow for switching + the implementation to one backed by a C array later on, which would + let us avoid copying when passing it through FFI boundaries. *) +type t = bytes + +let blob_of_bytes (b : bytes) = b +let bytes_of_blob (b : t) = b +let create = Bytes.create +let set = Bytes.set +let set_int64_be = Bytes.set_int64_be +let blit_string = Bytes.blit_string +let length = Bytes.length +let get = Bytes.get +let sub_string = Bytes.sub_string +let get_int64_be = Bytes.get_int64_be diff --git a/lib/concepts/Blob.mli b/lib/concepts/Blob.mli new file mode 100644 index 0000000..b7c5da3 --- /dev/null +++ b/lib/concepts/Blob.mli @@ -0,0 +1,26 @@ +(** an abstract representation of an encoded value *) +type t + +(* TODO: see the comments on Backend.Storage.LMDB *) + +(** create a blob from the data represented by bytes *) +val blob_of_bytes : bytes -> t + +(** return a bytes containing the data underlying a blob *) +val bytes_of_blob : t -> bytes + +val create : int -> t + +val set : t -> int -> char -> unit + +val set_int64_be : t -> int -> int64 -> unit + +val blit_string : string -> int -> t -> int -> int -> unit + +val length : t -> int + +val get : t -> int -> char + +val sub_string : t -> int -> int -> string + +val get_int64_be : t -> int -> int64 diff --git a/lib/concepts/Branch.ml b/lib/concepts/Branch.ml deleted file mode 100644 index cd4213b..0000000 --- a/lib/concepts/Branch.ml +++ /dev/null @@ -1,49 +0,0 @@ -type address = Hash.hash - -type t = - { name: string; - target: address } - -module Field = struct - let name = "name" - let target = "target" -end - -module Error = struct - open Condition - - let malformed_branch () = - condition "branch-malformed" "A branch representation did not conform to what was expected" - empty - - let malformed_hash length = - condition "branch-malformed-hash" "A branch target root was not a valid hash" - ("length" |=| Value.Integer length) -end - -let make ~name ~target = {name; target} - -let name branch = branch.name -let target branch = branch.target - -module Body = struct - type nonrec t = t - - let tag = 'b' - let malformed = Error.malformed_branch - - let equal left right = - left.name = right.name && Hash.hash_equals left.target right.target - - let fields branch = - [ Field.name, Object.Field.string branch.name; - Field.target, Object.Field.address branch.target ] - - let of_fields data = - let open Utilities.Result in - let* name = Object.Field.require_string Field.name data in - let* target = Object.Field.require_address ~malformed:Error.malformed_hash Field.target data in - Ok {name; target} -end - -include (Object.Codec.Make (Body) : Object.S with type t := t) diff --git a/lib/concepts/Branch.mli b/lib/concepts/Branch.mli deleted file mode 100644 index 0e7e9f9..0000000 --- a/lib/concepts/Branch.mli +++ /dev/null @@ -1,9 +0,0 @@ -type t -type address = Hash.hash - -include Object.S with type t := t - -val make : name:string -> target:address -> t - -val name : t -> string -val target : t -> address diff --git a/lib/concepts/BranchState.ml b/lib/concepts/BranchState.ml deleted file mode 100644 index e8c6636..0000000 --- a/lib/concepts/BranchState.ml +++ /dev/null @@ -1,87 +0,0 @@ -type address = Hash.hash - -(* A branch state records durable branch data only. The runtime registry paths - mounted around it, such as /system/branches/master, are derived at - initialization and should not be persisted as part of [current]. *) -type t = {current: address; history: address; tip: address option} - -module Field = struct - let current = "current" - let history = "history" - let tip = "tip" -end - -module Error = struct - open Condition - - let malformed_branch_state () = - condition "branch-state-malformed" - "A branch state representation did not conform to what was expected" empty - - let malformed_hash length = - condition "branch-state-malformed-hash" "A branch state address was not a valid hash" - ("length" |=| Value.Integer length) -end - -let make ~current ~history ~tip = {current; history; tip} -let current branch_state = branch_state.current -let history branch_state = branch_state.history -let tip branch_state = branch_state.tip -let address_bencode address = Object.Field.address address - -let address_option_bencode = function - | None -> Codec.Bencode.List [] - | Some address -> Codec.Bencode.List [address_bencode address] - -let require_address_bencode = function - | Codec.Bencode.String raw -> - if String.length raw = Hash.size then Ok (Hash.of_raw_string raw) - else Error (Error.malformed_hash (String.length raw)) - | _ -> Error (Error.malformed_branch_state ()) - -let require_address_option key data = - let open Utilities.Result in - let* value = Codec.Bencode.field key data in - let* entries = Codec.Bencode.as_list value in - match entries with - | [] -> Ok None - | [value] -> - let* address = require_address_bencode value in - Ok (Some address) - | _ -> Error (Error.malformed_branch_state ()) - -let equal_address_option left right = - match left, right with - | None, None -> true - | Some left, Some right -> Hash.hash_equals left right - | _ -> false - -module Body = struct - type nonrec t = t - - let tag = 's' - let malformed = Error.malformed_branch_state - - let equal left right = - Hash.hash_equals left.current right.current - && Hash.hash_equals left.history right.history - && equal_address_option left.tip right.tip - - let fields branch_state = - [ Field.current, address_bencode branch_state.current; - Field.history, address_bencode branch_state.history; - Field.tip, address_option_bencode branch_state.tip ] - - let of_fields data = - let open Utilities.Result in - let* current = - Object.Field.require_address ~malformed:Error.malformed_hash Field.current data - in - let* history = - Object.Field.require_address ~malformed:Error.malformed_hash Field.history data - in - let* tip = require_address_option Field.tip data in - Ok {current; history; tip} -end - -include (Object.Codec.Make (Body) : Object.S with type t := t) diff --git a/lib/concepts/BranchState.mli b/lib/concepts/BranchState.mli deleted file mode 100644 index 45792cc..0000000 --- a/lib/concepts/BranchState.mli +++ /dev/null @@ -1,17 +0,0 @@ -type t -type address = Hash.hash - -include Object.S with type t := t - -(** Durable state of one branch head. - - [current] is the branch-visible catalog root, not the runtime namespace - rooted at [/system]. Runtime scaffolding is rebuilt during initialization. - [history] is the ordered commit-stream tree root. [tip] is absent until the - first real commit, so initialization does not create a synthetic commit just - to make the branch non-empty. *) -val make : current:address -> history:address -> tip:address option -> t - -val current : t -> address -val history : t -> address -val tip : t -> address option diff --git a/lib/concepts/Codec.ml b/lib/concepts/Encoding.ml index 758d718..121e98d 100644 --- a/lib/concepts/Codec.ml +++ b/lib/concepts/Encoding.ml @@ -1,3 +1,33 @@ +(* A blob is a one-byte constructor tag followed by its payload. The + tag makes the encoding self-describing so [value_of_blob] can + recover the constructor: + - String ['\000'] ++ raw utf-8 bytes + - Integer ['\001'] ++ 8-byte big-endian int64 *) +let tag_string = '\000' +let tag_integer = '\001' + +let blob_of_value = function + | Value.String s -> + let b = Blob.create (1 + String.length s) in + Blob.set b 0 tag_string; + Blob.blit_string s 0 b 1 (String.length s); + b + | Value.Integer n -> + let b = Blob.create 9 in + Blob.set b 0 tag_integer; + Blob.set_int64_be b 1 (Int64.of_int n); + b + +let value_of_blob (b : Blob.t) = + let n = Blob.length b in + if n = 0 then invalid_arg "value_of_blob: empty blob"; + match Blob.get b 0 with + | c when c = tag_string -> Value.String (Blob.sub_string b 1 (n - 1)) + | c when c = tag_integer -> + if n <> 9 then invalid_arg "value_of_blob: malformed integer payload"; + Value.Integer (Int64.to_int (Blob.get_int64_be b 1)) + | c -> invalid_arg (Printf.sprintf "value_of_blob: unknown tag %C" c) + module Error = struct open Condition @@ -162,8 +192,8 @@ module Bencode = struct if !pos <> n then Error Error.trailing_bytes else Ok value - let to_blob x = to_bytes x |> Representation.blob_of_bytes - let of_blob b = Representation.bytes_of_blob b |> of_bytes + let to_blob x = to_bytes x |> Blob.blob_of_bytes + let of_blob b = Blob.bytes_of_blob b |> of_bytes let with_tag t = function | Tagged (t', v) -> @@ -180,3 +210,62 @@ module Bencode = struct | None -> Error (Error.missing_field key) ) | _ -> Error (Error.type_mismatch ~expected:"dict") end + +module Field = struct + let string value = Bencode.String value + let address address = Bencode.String (Hash.to_raw_string address) + + let require_string key data = + Bencode.field key data |> Utilities.Result.fmap Bencode.as_string + + let require_address ~malformed key data = + let open Utilities.Result in + let* raw = require_string key data in + if String.length raw = Hash.size then Ok (Hash.of_raw_string raw) + else Error (malformed (String.length raw)) +end + +module Record = struct + module type S = sig + type t + + val equal : t -> t -> bool + + val to_bencode : t -> Bencode.t + val of_bencode : Bencode.t -> (t, Condition.condition) result + + val to_blob : t -> Blob.t + val of_blob : Blob.t -> (t, Condition.condition) result + + val to_bytes : t -> bytes + val of_bytes : bytes -> (t, Condition.condition) result + end + + module type BODY = sig + type t + + val tag : char + val malformed : unit -> Condition.condition + val equal : t -> t -> bool + val fields : t -> (string * Bencode.t) list + val of_fields : Bencode.t -> (t, Condition.condition) result + end + + module Make (B : BODY) = struct + type t = B.t + + let equal = B.equal + let to_bencode object_ = Bencode.Tagged (B.tag, Bencode.Dict (B.fields object_)) + + let of_bencode = function + | Bencode.Tagged (tag, (Bencode.Dict _ as data)) when Char.equal tag B.tag -> + B.of_fields data + | _ -> Error (B.malformed ()) + + let to_blob object_ = to_bencode object_ |> Bencode.to_blob + let of_blob blob = Bencode.of_blob blob |> Utilities.Result.fmap of_bencode + + let to_bytes object_ = to_blob object_ |> Blob.bytes_of_blob + let of_bytes bytes = Bencode.of_bytes bytes |> Utilities.Result.fmap of_bencode + end +end diff --git a/lib/concepts/Hash.ml b/lib/concepts/Hash.ml index aac7428..ae0a178 100644 --- a/lib/concepts/Hash.ml +++ b/lib/concepts/Hash.ml @@ -7,17 +7,16 @@ let size = 256/8 let compare h1 h2 = Digestif.SHA256.unsafe_compare h1 h2 |> Ordering.of_int -let hash_of_value (v : Value.value) = - Representation.(blob_of_value v |> bytes_of_blob) |> Digestif.SHA256.digest_bytes - let hash_of_bytes bytes = Digestif.SHA256.digest_bytes bytes -let hash_of_blob blob = Representation.bytes_of_blob blob |> Digestif.SHA256.digest_bytes +let hash_of_blob blob = Blob.bytes_of_blob blob |> Digestif.SHA256.digest_bytes let to_raw_string hash = Digestif.SHA256.to_raw_string hash let of_raw_string str = Digestif.SHA256.of_raw_string str +let to_hum_string hash = Digestif.SHA256.to_hex hash + let hash_equals = Digestif.SHA256.equal let bytes_of_hash (h : hash) = Bytes.of_string (Digestif.SHA256.to_raw_string h) diff --git a/lib/concepts/Hash.mli b/lib/concepts/Hash.mli index 44fb3d0..b3ae2dc 100644 --- a/lib/concepts/Hash.mli +++ b/lib/concepts/Hash.mli @@ -4,14 +4,11 @@ type hash (** the size of a hash, in bytes *) val size : int -(** given a value, compute it's hash *) -val hash_of_value : Value.value -> hash - (** given a bag of bytes, compute it's hash *) val hash_of_bytes : bytes -> hash (** given a blob, compute it's hash *) -val hash_of_blob : Representation.blob -> hash +val hash_of_blob : Blob.t -> hash (** given a hash, return a representation of it as a string (/not/ the usual hex representation!) *) val to_raw_string : hash -> string @@ -19,6 +16,9 @@ val to_raw_string : hash -> string (** given a string containing a representation of a hash (as per `to_raw_string`), return the corresponding hash *) val of_raw_string : string -> hash +(** given a hash, return a representation of it as a string suitable for being displayed to humans *) +val to_hum_string : hash -> string + (** compare two hashes lexicographically *) val compare : hash -> hash -> Ordering.ordering diff --git a/lib/concepts/Multigroup.ml b/lib/concepts/Multigroup.ml deleted file mode 100644 index 863cd26..0000000 --- a/lib/concepts/Multigroup.ml +++ /dev/null @@ -1,51 +0,0 @@ -type address = Hash.hash - -type t = - { name: string; - relations: address } - -module Field = struct - let name = "name" - let relations = "relations" -end - -module Error = struct - open Condition - - let malformed_multigroup () = - condition "multigroup-malformed" - "A multigroup representation did not conform to what was expected" empty - - let malformed_hash length = - condition "multigroup-malformed-hash" "A multigroup relation root was not a valid hash" - ("length" |=| Value.Integer length) -end - -let make ~name ~relations = {name; relations} - -let name multigroup = multigroup.name -let relations multigroup = multigroup.relations - -module Body = struct - type nonrec t = t - - let tag = 'm' - let malformed = Error.malformed_multigroup - - let equal left right = - left.name = right.name && Hash.hash_equals left.relations right.relations - - let fields multigroup = - [ Field.name, Object.Field.string multigroup.name; - Field.relations, Object.Field.address multigroup.relations ] - - let of_fields data = - let open Utilities.Result in - let* name = Object.Field.require_string Field.name data in - let* relations = - Object.Field.require_address ~malformed:Error.malformed_hash Field.relations data - in - Ok {name; relations} -end - -include (Object.Codec.Make (Body) : Object.S with type t := t) diff --git a/lib/concepts/Multigroup.mli b/lib/concepts/Multigroup.mli deleted file mode 100644 index 1a76dce..0000000 --- a/lib/concepts/Multigroup.mli +++ /dev/null @@ -1,9 +0,0 @@ -type t -type address = Hash.hash - -include Object.S with type t := t - -val make : name:string -> relations:address -> t - -val name : t -> string -val relations : t -> address diff --git a/lib/concepts/Object.ml b/lib/concepts/Object.ml deleted file mode 100644 index 22fb14a..0000000 --- a/lib/concepts/Object.ml +++ /dev/null @@ -1,64 +0,0 @@ -type bencode = Codec.Bencode.t - -module Bencode = Codec.Bencode - -module type S = sig - type t - - val equal : t -> t -> bool - - val to_bencode : t -> bencode - val of_bencode : bencode -> (t, Condition.condition) result - - val to_blob : t -> Representation.blob - val of_blob : Representation.blob -> (t, Condition.condition) result - - val to_bytes : t -> bytes - val of_bytes : bytes -> (t, Condition.condition) result -end - -module type OBJECT = S - -module Field = struct - let string value = Bencode.String value - let address address = Bencode.String (Hash.to_raw_string address) - - let require_string key data = - Codec.Bencode.field key data |> Utilities.Result.fmap Codec.Bencode.as_string - - let require_address ~malformed key data = - let open Utilities.Result in - let* raw = require_string key data in - if String.length raw = Hash.size then Ok (Hash.of_raw_string raw) - else Error (malformed (String.length raw)) -end - -module Codec = struct - module type BODY = sig - type t - - val tag : char - val malformed : unit -> Condition.condition - val equal : t -> t -> bool - val fields : t -> (string * bencode) list - val of_fields : bencode -> (t, Condition.condition) result - end - - module Make (B : BODY) = struct - type t = B.t - - let equal = B.equal - let to_bencode object_ = Bencode.Tagged (B.tag, Bencode.Dict (B.fields object_)) - - let of_bencode = function - | Bencode.Tagged (tag, (Bencode.Dict _ as data)) when Char.equal tag B.tag -> - B.of_fields data - | _ -> Error (B.malformed ()) - - let to_blob object_ = to_bencode object_ |> Bencode.to_blob - let of_blob blob = Bencode.of_blob blob |> Utilities.Result.fmap of_bencode - - let to_bytes object_ = to_blob object_ |> Representation.bytes_of_blob - let of_bytes bytes = Bencode.of_bytes bytes |> Utilities.Result.fmap of_bencode - end -end diff --git a/lib/concepts/Object.mli b/lib/concepts/Object.mli deleted file mode 100644 index e132673..0000000 --- a/lib/concepts/Object.mli +++ /dev/null @@ -1,45 +0,0 @@ -type bencode = Codec.Bencode.t - -module type S = sig - type t - - val equal : t -> t -> bool - - val to_bencode : t -> bencode - val of_bencode : bencode -> (t, Condition.condition) result - - val to_blob : t -> Representation.blob - val of_blob : Representation.blob -> (t, Condition.condition) result - - val to_bytes : t -> bytes - val of_bytes : bytes -> (t, Condition.condition) result -end - -module type OBJECT = S - -module Field : sig - val string : string -> bencode - val address : Hash.hash -> bencode - - val require_string : string -> bencode -> (string, Condition.condition) result - - val require_address : - malformed:(int -> Condition.condition) -> - string -> - bencode -> - (Hash.hash, Condition.condition) result -end - -module Codec : sig - module type BODY = sig - type t - - val tag : char - val malformed : unit -> Condition.condition - val equal : t -> t -> bool - val fields : t -> (string * bencode) list - val of_fields : bencode -> (t, Condition.condition) result - end - - module Make (B : BODY) : S with type t = B.t -end diff --git a/lib/concepts/Ordering.mli b/lib/concepts/Ordering.mli deleted file mode 100644 index ab8a3f4..0000000 --- a/lib/concepts/Ordering.mli +++ /dev/null @@ -1,3 +0,0 @@ -type ordering = Equal | Smaller | Greater - -val of_int : int -> ordering diff --git a/lib/concepts/Path.ml b/lib/concepts/Path.ml deleted file mode 100644 index c751301..0000000 --- a/lib/concepts/Path.ml +++ /dev/null @@ -1,16 +0,0 @@ -type t = string BatFingerTree.t - -let empty : t = BatFingerTree.empty -let of_list (components : string list) : t = BatFingerTree.of_list components -let to_list (path : t) : string list = BatFingerTree.to_list path -let snoc (path : t) (component : string) : t = BatFingerTree.snoc path component -let to_string (path : t) : string = String.concat "/" (to_list path) - -let is_prefix ~(prefix : t) (path : t) : bool = - let rec walk prefix path = - match prefix, path with - | [], _ -> true - | p :: prefix, x :: path -> p = x && walk prefix path - | _ :: _, [] -> false - in - walk (to_list prefix) (to_list path) diff --git a/lib/concepts/Path.mli b/lib/concepts/Path.mli deleted file mode 100644 index bec4221..0000000 --- a/lib/concepts/Path.mli +++ /dev/null @@ -1,8 +0,0 @@ -type t = string BatFingerTree.t - -val empty : t -val of_list : string list -> t -val to_list : t -> string list -val snoc : t -> string -> t -val to_string : t -> string -val is_prefix : prefix:t -> t -> bool diff --git a/lib/concepts/Relation.ml b/lib/concepts/Relation.ml deleted file mode 100644 index ef5ac12..0000000 --- a/lib/concepts/Relation.ml +++ /dev/null @@ -1,81 +0,0 @@ -type address = Hash.hash -type schema = string BatMap.String.t - -type t = - { name: string; - tuples: address; - schema: schema } - -module Field = struct - let name = "name" - let tuples = "tuples" - let schema = "schema" -end - -module Error = struct - open Condition - - let malformed_relation () = - condition "relation-malformed" "A relation representation did not conform to what was expected" - empty - - let malformed_hash length = - condition "relation-malformed-hash" "A relation tuple root was not a valid hash" - ("length" |=| Value.Integer length) -end - -let make ~name ~tuples ~schema = {name; tuples; schema} - -let name relation = relation.name -let tuples relation = relation.tuples -let schema relation = relation.schema - -let schema_empty = BatMap.String.empty - -let schema_of_list fields = - List.fold_left (fun acc (name, domain) -> BatMap.String.add name domain acc) schema_empty - fields - -let schema_to_list schema = BatMap.String.bindings schema - -let schema_to_bencode schema = - Codec.Bencode.Dict - (schema_to_list schema - |> List.map (fun (name, domain) -> name, Codec.Bencode.String domain) ) - -let schema_of_bencode value = - let open Utilities.Result in - let* fields = Codec.Bencode.as_dict value in - fields - |> List.map (fun (name, domain) -> - let* domain = Codec.Bencode.as_string domain in - Ok (name, domain) ) - |> Utilities.List.sequence - |> Result.map schema_of_list - -module Body = struct - type nonrec t = t - - let tag = 'r' - let malformed = Error.malformed_relation - - let equal left right = - left.name = right.name - && Hash.hash_equals left.tuples right.tuples - && BatMap.String.equal String.equal left.schema right.schema - - let fields relation = - [ Field.name, Object.Field.string relation.name; - Field.schema, schema_to_bencode relation.schema; - Field.tuples, Object.Field.address relation.tuples ] - - let of_fields data = - let open Utilities.Result in - let* name = Object.Field.require_string Field.name data in - let* tuples = Object.Field.require_address ~malformed:Error.malformed_hash Field.tuples data in - let* schema_data = Codec.Bencode.field Field.schema data in - let* schema = schema_of_bencode schema_data in - Ok {name; tuples; schema} -end - -include (Object.Codec.Make (Body) : Object.S with type t := t) diff --git a/lib/concepts/Relation.mli b/lib/concepts/Relation.mli deleted file mode 100644 index 5319a3d..0000000 --- a/lib/concepts/Relation.mli +++ /dev/null @@ -1,15 +0,0 @@ -type t -type address = Hash.hash -type schema - -include Object.S with type t := t - -val make : name:string -> tuples:address -> schema:schema -> t - -val name : t -> string -val tuples : t -> address -val schema : t -> schema - -val schema_empty : schema -val schema_of_list : (string * string) list -> schema -val schema_to_list : schema -> (string * string) list diff --git a/lib/concepts/Representation.ml b/lib/concepts/Representation.ml deleted file mode 100644 index 12c3624..0000000 --- a/lib/concepts/Representation.ml +++ /dev/null @@ -1,36 +0,0 @@ -(* @needs Value *) - -type blob = bytes - -let blob_of_bytes (b : bytes) = b -let bytes_of_blob (b : blob) = b - -(* A blob is a one-byte constructor tag followed by its payload. The - tag makes the encoding self-describing so [value_of_blob] can - recover the constructor: - - String ['\000'] ++ raw utf-8 bytes - - Integer ['\001'] ++ 8-byte big-endian int64 *) -let tag_string = '\000' -let tag_integer = '\001' - -let blob_of_value = function - | Value.String s -> - let b = Bytes.create (1 + String.length s) in - Bytes.set b 0 tag_string; - Bytes.blit_string s 0 b 1 (String.length s); - b - | Value.Integer n -> - let b = Bytes.create 9 in - Bytes.set b 0 tag_integer; - Bytes.set_int64_be b 1 (Int64.of_int n); - b - -let value_of_blob (b : blob) = - let n = Bytes.length b in - if n = 0 then invalid_arg "value_of_blob: empty blob"; - match Bytes.get b 0 with - | c when c = tag_string -> Value.String (Bytes.sub_string b 1 (n - 1)) - | c when c = tag_integer -> - if n <> 9 then invalid_arg "value_of_blob: malformed integer payload"; - Value.Integer (Int64.to_int (Bytes.get_int64_be b 1)) - | c -> invalid_arg (Printf.sprintf "value_of_blob: unknown tag %C" c) diff --git a/lib/concepts/Representation.mli b/lib/concepts/Representation.mli deleted file mode 100644 index 21c43a4..0000000 --- a/lib/concepts/Representation.mli +++ /dev/null @@ -1,16 +0,0 @@ -(** an abstract representation of an encoded value *) -type blob - -(** encode a blob into a value *) -val blob_of_value : Value.value -> blob - -(** decode a value from a blob *) -val value_of_blob : blob -> Value.value - -(* TODO: see the comments on Backend.Storage.LMDB *) - -(** create a blob from the data represented by bytes *) -val blob_of_bytes : bytes -> blob - -(** return a bytes containing the data underlying a blob *) -val bytes_of_blob : blob -> bytes diff --git a/lib/concepts/Tuple.ml b/lib/concepts/Tuple.ml deleted file mode 100644 index 8fac426..0000000 --- a/lib/concepts/Tuple.ml +++ /dev/null @@ -1,48 +0,0 @@ -(* @needs Value *) - -module AttributeMap = BatMap.String - -(** A tuple: a finite map from attribute name to attribute. *) -type t = Value.value AttributeMap.t - -(** [empty] The tuple with no attributes. *) -let empty : t = AttributeMap.empty - -(** [access name t] Looks up the attribute bound to [name] in [t]. - @param name attribute name to look up. - @param t tuple to search. - @return the attribute, or [None] when [name] is unbound. *) -let access (name : string) (t : t) : Value.value option = AttributeMap.find_opt name t - -(** [merge left right] Unions two tuples. Shared attributes take the - [left] value; one-sided attributes are kept. Precondition: shared - attributes agree (the natural-join matcher guarantees this), so the - [left] bias is never observable. - @param left first tuple. - @param right second tuple. - @return the merged tuple. *) -let merge (left : t) (right : t) : t = - let merger _ (left : Value.value option) (right : Value.value option) : Value.value option = - match left, right with (Some _ as v), _ | None, (Some _ as v) -> v | None, None -> None - in - AttributeMap.merge merger left right - -(** [project keep t] Keeps only the attributes of [t] whose names are - in [keep]. - @param keep set of attribute names to retain. - @param t tuple to project. - @return the projected tuple. *) -let project (keep : BatSet.String.t) (t : t) : t = - AttributeMap.filter (fun name _ -> BatSet.String.mem name keep) t - -(** [rename mapping t] Renames the attributes of [t] through - [mapping]; names absent from [mapping] are left unchanged. - @param mapping map from old name to new name. - @param t tuple to rename. - @return the renamed tuple. *) -let rename (mapping : string BatMap.String.t) (t : t) : t = - AttributeMap.fold - (fun name attr acc -> - let name = BatMap.String.find_default name name mapping in - AttributeMap.add name attr acc ) - t AttributeMap.empty diff --git a/lib/concepts/Tuple.mli b/lib/concepts/Tuple.mli deleted file mode 100644 index 07f7a24..0000000 --- a/lib/concepts/Tuple.mli +++ /dev/null @@ -1,9 +0,0 @@ -module AttributeMap = BatMap.String - -type t = Value.value AttributeMap.t - -val empty : t -val access : string -> t -> Value.value option -val merge : t -> t -> t -val project : BatSet.String.t -> t -> t -val rename : string BatMap.String.t -> t -> t diff --git a/lib/kernel/BranchIndex.ml b/lib/kernel/BranchIndex.ml deleted file mode 100644 index d1efa9a..0000000 --- a/lib/kernel/BranchIndex.ml +++ /dev/null @@ -1,29 +0,0 @@ -type address = Concepts.Hash.hash -type root = address -type branch_name = string -type branch_state_root = address - -let default_branch_name = "master" - -module Branch_name = struct - type t = branch_name - - let encode name = Concepts.Codec.Bencode.(String name |> to_blob) - let compare left right = Concepts.Ordering.of_int (String.compare left right) - - let decode blob = - Concepts.Codec.Bencode.of_blob blob |> Utilities.Result.fmap Concepts.Codec.Bencode.as_string -end - -module Make (Store : Abstract.Storage.STORAGE) = struct - module Tree = Merkle.Make (Store) (Branch_name) - - type tree = Tree.node - - let empty = Tree.empty - let hash_of = Tree.hash_of - let persist = Tree.persist - let find = Tree.find - let find_branch = Tree.lookup - let put_branch = Tree.insert -end diff --git a/lib/kernel/BranchIndex.mli b/lib/kernel/BranchIndex.mli deleted file mode 100644 index 5a867bf..0000000 --- a/lib/kernel/BranchIndex.mli +++ /dev/null @@ -1,28 +0,0 @@ -type address = Concepts.Hash.hash -type root = address -type branch_name = string -type branch_state_root = address - -val default_branch_name : branch_name - -module Make (Store : Abstract.Storage.STORAGE) : sig - type tree - - val empty : tree - val hash_of : tree -> root - val persist : Store.transaction -> tree -> (root, Concepts.Condition.condition) result - val find : Store.transaction -> root -> (tree option, Concepts.Condition.condition) result - - val find_branch : - Store.transaction -> - branch_name -> - tree -> - (branch_state_root option, Concepts.Condition.condition) result - - val put_branch : - Store.transaction -> - branch_name -> - branch_state_root -> - tree -> - (tree, Concepts.Condition.condition) result -end diff --git a/lib/kernel/BranchManager.ml b/lib/kernel/BranchManager.ml new file mode 100644 index 0000000..03a2765 --- /dev/null +++ b/lib/kernel/BranchManager.ml @@ -0,0 +1,63 @@ +module Error = struct + open Concepts.Condition + + let invalid_root head = + condition "invalid-root" "The root hash for the database state is missing from the backend. Either your storage is corrupted, or this is a bug in RNT!" + ("hash" |=| (Concepts.Value.String (Concepts.Hash.to_hum_string head))) + + let no_such_branch branch_name = + condition "no-such-branch" "A branch with the specified name was not found" + ("branch" |=| Concepts.Value.String branch_name) + + let comparison_failed branch_name reference head = + condition "comparison-failed" "The HEAD of the branch did not match what was expected" + ("branch" |=| Concepts.Value.String branch_name & + "reference" |=| Concepts.Value.String (Concepts.Hash.to_hum_string reference) & + "head" |=| Concepts.Value.String (Concepts.Hash.to_hum_string head)) +end + +module Make (S : Abstract.Storage.STORAGE) = struct + module M = Merkle.Make (S) (Merkle.StringKey) + module SI = Storage.Make (S) + + type manager = { storage: S.connection; + label : string; + head: M.node Atomic.t } + + let root_for tx label = + let open Utilities.Result in + let* label = S.get tx (S.Label label) in + let label = Option.map Concepts.Hash.hash_of_blob label in + Ok label + + let initialize storage label = + let open Utilities.Result in + SI.with_transaction storage (fun tx -> + let* addr = root_for tx label in + match addr with + | None -> failwith "TODO" + | Some addr -> + let* head = M.find tx addr in + let* head = Option.to_result ~none:(Error.invalid_root addr) head in + Ok { storage; label; head = Atomic.make head }) + + let fetch { storage; head; _ } branch_name = + SI.with_transaction storage (fun tx -> + let head = Atomic.get head in + M.lookup tx branch_name head) + + let update { storage; head; label } branch_name reference new_branch = + let open Utilities.Result in + let* _ = SI.with_transaction storage (fun tx -> + Utilities.Atomic.mswap head (fun head -> + let* branch = M.lookup tx branch_name head + |> Result.map (Option.to_result ~none:(Error.no_such_branch branch_name)) + |> Result.join in + if branch = reference then + let* new_head = M.insert tx label new_branch head in + Ok new_head + else + Error (Error.comparison_failed branch_name reference branch))) in + Ok () + +end diff --git a/lib/kernel/BranchManager.mli b/lib/kernel/BranchManager.mli new file mode 100644 index 0000000..052f9a1 --- /dev/null +++ b/lib/kernel/BranchManager.mli @@ -0,0 +1,9 @@ +module Make (S : Abstract.Storage.STORAGE) : sig + type manager + + val initialize : S.connection -> string -> (manager, Concepts.Condition.condition) result + val fetch : manager -> string -> (Concepts.Hash.hash option, Concepts.Condition.condition) result + val update : manager -> string -> Concepts.Hash.hash -> Concepts.Hash.hash -> (unit, Concepts.Condition.condition) result + + (* TODO: fork, join *) +end diff --git a/lib/kernel/Lifecycle.ml b/lib/kernel/Lifecycle.ml new file mode 100644 index 0000000..ff67ecf --- /dev/null +++ b/lib/kernel/Lifecycle.ml @@ -0,0 +1,29 @@ +class type lifecycle = object + method reference : bool + method release : unit +end + +class type virtual controlled_lifecycle = object + inherit lifecycle + method virtual destroy : unit +end + +class null = object + method reference = true + method release = () +end + +class virtual counted = object (self) + val references = Atomic.make 1 + + method virtual destroy : unit + + method reference = + Atomic.incr references; + true + + method release = + Atomic.decr references; + if Atomic.get references <= 0 then + self#destroy +end diff --git a/lib/kernel/Lifecycle.mli b/lib/kernel/Lifecycle.mli new file mode 100644 index 0000000..f110768 --- /dev/null +++ b/lib/kernel/Lifecycle.mli @@ -0,0 +1,12 @@ +class type lifecycle = object + method reference : bool + method release : unit +end + +class type virtual controlled_lifecycle = object + inherit lifecycle + method virtual destroy : unit +end + +class null : lifecycle +class virtual counted : controlled_lifecycle diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml index af703d7..ababb03 100644 --- a/lib/kernel/Merkle.ml +++ b/lib/kernel/Merkle.ml @@ -1,8 +1,8 @@ module type VALUE = sig type t - val encode : t -> Concepts.Representation.blob - val decode : Concepts.Representation.blob -> (t, Concepts.Condition.condition) result + val encode : t -> Concepts.Blob.t + val decode : Concepts.Blob.t -> (t, Concepts.Condition.condition) result end module type KEY = sig @@ -19,6 +19,7 @@ module type TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> sig val find : S.transaction -> address -> (node option, Concepts.Condition.condition) result val empty : node + val empty_under : S.transaction -> (address, Concepts.Condition.condition) result val hash_of : node -> address @@ -68,12 +69,12 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct | Trunk { keys; _ } -> keys let of_bencode = - let open Concepts.Codec.Bencode in + let open Concepts.Encoding.Bencode in let open Utilities.Result in (* This is terrible *) let decode_key t = as_string t |> Result.map String.to_bytes - |> Result.map Concepts.Representation.blob_of_bytes + |> Result.map Concepts.Blob.blob_of_bytes |> fmap K.decode in let decode_value t = as_string t |> Result.map Concepts.Hash.of_raw_string in let decode_list f data = data @@ -92,14 +93,14 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct Ok (Trunk { keys; children }) | _ -> Error (Error.malformed_node ()) - let from_blob blob = Concepts.Codec.Bencode.of_blob blob + let from_blob blob = Concepts.Encoding.Bencode.of_blob blob |> Utilities.Result.fmap of_bencode let to_bencode = - let open Concepts.Codec.Bencode in + let open Concepts.Encoding.Bencode in (* Ditto. *) let bencode_key k = K.encode k - |> Concepts.Representation.bytes_of_blob + |> Concepts.Blob.bytes_of_blob |> String.of_bytes |> (fun s -> String s) in let bencode_hash h = String (Concepts.Hash.to_raw_string h) in @@ -111,7 +112,7 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct Tagged ('#', Dict [("keys", List (BatFingerTree.to_list keys |> List.map bencode_key)); ("children", List (BatFingerTree.to_list children |> List.map bencode_hash))]) - let to_blob node = to_bencode node |> Concepts.Codec.Bencode.to_blob + let to_blob node = to_bencode node |> Concepts.Encoding.Bencode.to_blob (* TODO: we should probably cache this inside the node itself rather than recalculating it every time. We could also allow the user to @@ -121,7 +122,7 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct let find tx addr = let open Utilities.Result in - let* data = S.get tx addr in + let* data = S.get tx (S.Hash node) in match data with | None -> Ok None | Some data -> @@ -149,9 +150,11 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct let open Utilities.Result in let data = to_blob node in let addr = Concepts.Hash.hash_of_blob data in - let* () = S.put tx addr data in + let* () = S.put tx (S.Hash addr) data in Ok addr + let empty_under tx = persist tx empty + type op = Update of address * node | Split of address * K.t * address let emplace i v ft = @@ -217,7 +220,7 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct BatFingerTree.iter (fun k -> K.encode k - |> Concepts.Representation.bytes_of_blob + |> Concepts.Blob.bytes_of_blob |> Buffer.add_bytes buffer) ks; Concepts.Hash.hash_of_bytes (Buffer.to_bytes buffer) @@ -303,7 +306,7 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct end module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VALUE) -> sig - type address + type address = Concepts.Hash.hash type node val find : S.transaction -> address -> (node option, Concepts.Condition.condition) result @@ -332,11 +335,11 @@ module Interface : INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) let intern tx v = let data = V.encode v in let addr = Concepts.Hash.hash_of_blob data in - let* () = S.put tx addr data in + let* () = S.put tx (S.Hash addr) data in Ok addr let retrieve tx addr = - let* data = S.get tx addr in + let* data = S.get tx (S.Hash addr) in match data with | None -> Ok None | Some data -> @@ -379,3 +382,11 @@ module Interface : INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (fun _ k v -> f k v |> ignore) () node end + +module StringKey : KEY with type t = string = struct + type t = string + + let encode s = String.to_bytes s |> Concepts.Blob.blob_of_bytes + let compare s1 s2 = String.compare s1 s2 |> Concepts.Ordering.of_int + let decode b = Concepts.Blob.bytes_of_blob b |> String.of_bytes |> Result.ok +end diff --git a/lib/kernel/Namespace.ml b/lib/kernel/Namespace.ml new file mode 100644 index 0000000..7c9cd2b --- /dev/null +++ b/lib/kernel/Namespace.ml @@ -0,0 +1,49 @@ +module Errors = struct + include Concepts.Condition + + let key_already_exists key = + condition "key-already-exists" "The specified key already exists in the namespace" + ("key" |=| Concepts.Value.String key) + + let no_such_key key = + condition "no-such-key" "The specified key does not exist in the namespace" + ("key" |=| Concepts.Value.String key) +end + +class namespace = object (self) + inherit Lifecycle.null + + val entries : (string, Protocols.Handle.t) BatMap.t Atomic.t = + Atomic.make BatMap.empty + + method protocols = Protocols.[Directory.make self; Registry.make self] + + method register key value = + Utilities.Atomic.mswap entries + (fun e -> + match BatMap.find_opt key e with + | None -> Ok (BatMap.add key value e) + | Some _ -> Error (Errors.key_already_exists key)) + |> Result.map ignore + + method unregister key = + Utilities.Atomic.mswap entries + (fun e -> + try + Ok (BatMap.remove_exn key e) + with Not_found -> + Error (Errors.no_such_key key)) + |> Result.map ignore + + method list = + Atomic.get entries + |> BatMap.keys + |> BatList.of_enum + + method find key = + Atomic.get entries + |> BatMap.find_opt key + |> Utilities.Option.fmap Protocols.Handle.copy +end + +let make () = new namespace diff --git a/lib/kernel/Namespace.mli b/lib/kernel/Namespace.mli new file mode 100644 index 0000000..3ed64a3 --- /dev/null +++ b/lib/kernel/Namespace.mli @@ -0,0 +1,7 @@ +class namespace : object + inherit Protocols.Handle.obj + inherit Protocols.Directory.implementation + inherit Protocols.Registry.implementation +end + +val make : unit -> namespace diff --git a/lib/kernel/Storage.ml b/lib/kernel/Storage.ml new file mode 100644 index 0000000..376d839 --- /dev/null +++ b/lib/kernel/Storage.ml @@ -0,0 +1,22 @@ +module Make (S : Abstract.Storage.STORAGE) = struct + let finish tx = function + | Ok value -> + let open Utilities.Result in + let* () = S.commit tx in + Ok value + | Error condition -> + let _ = S.abort tx in + Error condition + + let with_transaction connection body = + let open Utilities.Result in + let* tx = S.start connection in + body tx |> finish tx + + let store_blob tx blob = + let open Utilities.Result in + let address = Concepts.Hash.hash_of_blob blob in + let* () = S.put tx (S.Hash address) blob in + Ok address + +end diff --git a/lib/kernel/Storage.mli b/lib/kernel/Storage.mli new file mode 100644 index 0000000..1148fba --- /dev/null +++ b/lib/kernel/Storage.mli @@ -0,0 +1,5 @@ +module Make : functor (S : Abstract.Storage.STORAGE) -> sig + val finish : S.transaction -> ('a, Concepts.Condition.condition) result -> ('a, Concepts.Condition.condition) result + val with_transaction : S.connection -> (S.transaction -> ('a, Concepts.Condition.condition) result) -> ('a, Concepts.Condition.condition) result + val store_blob : S.transaction -> Concepts.Blob.t -> (Concepts.Hash.hash, Concepts.Condition.condition) result +end diff --git a/lib/protocols/Directory.ml b/lib/protocols/Directory.ml new file mode 100644 index 0000000..5b21668 --- /dev/null +++ b/lib/protocols/Directory.ml @@ -0,0 +1,16 @@ +class type implementation = object + method list : string list + method find : string -> Handle.t option +end + +type Handle.protocol += Directory of implementation + +type t = implementation + +let make impl = Directory (impl :> implementation) + +let from handle = Handle.into handle (function Directory impl -> Some impl | _ -> None) + +let list i = Handle.invoke i (fun o -> o#list) + +let find i name = Handle.invoke i (fun o -> o#find name) diff --git a/lib/protocols/Directory.mli b/lib/protocols/Directory.mli new file mode 100644 index 0000000..5bf5277 --- /dev/null +++ b/lib/protocols/Directory.mli @@ -0,0 +1,13 @@ +type t + +class type implementation = object + method list : string list + method find : string -> Handle.t option +end + +val make : #implementation -> Handle.protocol + +val from : Handle.t -> t Handle.interface option + +val list : t Handle.interface -> string list +val find : t Handle.interface -> string -> Handle.t option diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml new file mode 100644 index 0000000..9fd1f29 --- /dev/null +++ b/lib/protocols/Handle.ml @@ -0,0 +1,41 @@ +type protocol = .. + +class type obj = object + method reference : bool + method release : unit + method protocols : protocol list +end + +type t = { valid : bool ref; refers_to : obj } + +type 'a interface = { handle : t; interface : 'a } + +let object_of { valid; refers_to } = + if !valid then + refers_to + else + failwith "Attempt to dereference an invalid handle!" + +let interface_of handle interface = { handle; interface } + +let make o = { valid = ref true; refers_to = (o :> obj) } + +let into handle f = + List.find_map f (object_of handle)#protocols + |> Option.map (interface_of handle) + +let invoke { handle; interface } f = + let _ = object_of handle in + f interface + +let copy handle = + let o = object_of handle in + if o#reference then + Some (make o) + else + None + +let release ({ valid; _ } as handle) = + let o = object_of handle in + valid := false; + o#release diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli new file mode 100644 index 0000000..099f563 --- /dev/null +++ b/lib/protocols/Handle.mli @@ -0,0 +1,20 @@ +type t + +type 'a interface + +type protocol = .. + +class type obj = object + method reference : bool + method release : unit + method protocols : protocol list +end + +val make : #obj -> t + +val into : t -> (protocol -> 'a option) -> 'a interface option + +val invoke : 'a interface -> ('a -> 'b) -> 'b + +val copy : t -> t option +val release : t -> unit diff --git a/lib/protocols/Registry.ml b/lib/protocols/Registry.ml new file mode 100644 index 0000000..4c47001 --- /dev/null +++ b/lib/protocols/Registry.ml @@ -0,0 +1,16 @@ +class type implementation = object + method register : string -> Handle.t -> (unit, Concepts.Condition.condition) result + method unregister : string -> (unit, Concepts.Condition.condition) result +end + +type Handle.protocol += Registry of implementation + +type t = implementation + +let make impl = Registry (impl :> implementation) + +let from handle = Handle.into handle (function Registry impl -> Some impl | _ -> None) + +let register i key value = Handle.invoke i (fun o -> o#register key value) + +let unregister i key = Handle.invoke i (fun o -> o#unregister key) diff --git a/lib/protocols/Registry.mli b/lib/protocols/Registry.mli new file mode 100644 index 0000000..175ebed --- /dev/null +++ b/lib/protocols/Registry.mli @@ -0,0 +1,13 @@ +type t + +class type implementation = object + method register : string -> Handle.t -> (unit, Concepts.Condition.condition) result + method unregister : string -> (unit, Concepts.Condition.condition) result +end + +val make : #implementation -> Handle.protocol + +val from : Handle.t -> t Handle.interface option + +val register : t Handle.interface -> string -> Handle.t -> (unit, Concepts.Condition.condition) result +val unregister : t Handle.interface -> string -> (unit, Concepts.Condition.condition) result diff --git a/test/test_rnt.ml b/test/test_rnt.ml index d46be1e..c4fbbaf 100644 --- a/test/test_rnt.ml +++ b/test/test_rnt.ml @@ -1,7 +1,4 @@ let all_suites = - Unit.Concepts.Serialization.suites () - @ Unit.Backend.Storage.suites () - @ Unit.Backend.Lifecycle.suites () - @ Unit.Kernel.Merkle.suites () + Unit.Backend.Storage.suites () let () = Alcotest.run "RNT" all_suites diff --git a/test/unit/backend/Lifecycle.ml b/test/unit/backend/Lifecycle.ml deleted file mode 100644 index 3e5b3e9..0000000 --- a/test/unit/backend/Lifecycle.ml +++ /dev/null @@ -1,147 +0,0 @@ -module Object = Rnt.Backend.Managers.Object -module Lifecycle = Rnt.Backend.Managers.Lifecycle -module Path = Rnt.Concepts.Path - -(* Small builders so the tests read like the invariants they check. *) - -let path segments = Path.of_list segments -let relation name = Object.make_object (Object.Relation {merkle_root= name}) - -let session () = - Object.make_object (Object.Session {connection_context= (); branch_overrides= BatMap.String.empty}) - -let branch name = Object.make_object (Object.Branch {name; target_hash= "hash"}) -let namespace label = Object.make_object (Object.Namespace {label; predicate= (fun _ -> true)}) -let dependencies paths = List.fold_left BatFingerTree.snoc BatFingerTree.empty paths - -let ephemeral name deps = - Object.make_object (Object.EphemeralRelation {merkle_root= name; dependencies= dependencies deps}) - -let register_exn tree p object' = Helpers.condition_as_failure (Object.register p object' tree) -let unregister_exn tree p = Helpers.condition_as_failure (Object.unregister p tree) -let collect_exn tree p = Helpers.condition_as_failure (Lifecycle.collect tree p) - -let reference_count tree p = - match Object.find p tree with Some r -> r.Object.reference_count | None -> -1 - -let present tree p = Object.find p tree <> None - -(* An ephemeral relation holds its inputs resident. Registering it raises the - input's reference_count; unregistering it lowers it again. This is the - distinction between reference counting (real edges) and pinning. *) -let test_edges_track_dependents () = - let tree = register_exn Object.root (path ["r1"]) (relation "r1") in - let tree = register_exn tree (path ["er1"]) (ephemeral "er1" [path ["r1"]]) in - Alcotest.(check int) - "dependent raises the input's reference count" 1 - (reference_count tree (path ["r1"])); - let tree = unregister_exn tree (path ["er1"]) in - Alcotest.(check int) - "removing the dependent releases the input" 0 - (reference_count tree (path ["r1"])) - -(* The four gates of eligibility, each shown to block on its own. *) -let test_eligibility_gates () = - let tree = register_exn Object.root (path ["r1"]) (relation "r1") in - Alcotest.(check bool) - "a fresh durable object is collectable" true - (Lifecycle.is_eligible_for_gc tree (path ["r1"])); - Alcotest.(check bool) - "an open handle blocks collection" false - (Lifecycle.is_eligible_for_gc (Lifecycle.monitor tree (path ["r1"])) (path ["r1"])); - Alcotest.(check bool) - "a pin blocks collection" false - (Lifecycle.is_eligible_for_gc (Lifecycle.pin tree (path ["r1"])) (path ["r1"])); - let with_branch = register_exn Object.root (path ["b1"]) (branch "b1") in - Alcotest.(check bool) - "a branch is exempt even with zero counts" false - (Lifecycle.is_eligible_for_gc with_branch (path ["b1"])) - -(* Collecting a dependent cascades into the inputs it releases, and the input - cannot be collected first while the dependent is alive. *) -let test_cascade_follows_edges () = - let tree = register_exn Object.root (path ["r1"]) (relation "r1") in - let tree = register_exn tree (path ["er1"]) (ephemeral "er1" [path ["r1"]]) in - Alcotest.(check bool) - "a live dependent keeps its input" false - (Lifecycle.is_eligible_for_gc tree (path ["r1"])); - let tree, disposals = collect_exn tree (path ["er1"]) in - Alcotest.(check bool) "the dependent is collected" false (present tree (path ["er1"])); - Alcotest.(check bool) "the released input is cascaded out" false (present tree (path ["r1"])); - Alcotest.(check int) "durable collection needs no disposal" 0 (BatFingerTree.size disposals) - -(* A pin overrides the cascade: the input stays even after its dependent goes. *) -let test_pin_survives_cascade () = - let tree = register_exn Object.root (path ["r1"]) (relation "r1") in - let tree = register_exn tree (path ["er1"]) (ephemeral "er1" [path ["r1"]]) in - let tree = Lifecycle.pin tree (path ["r1"]) in - let tree, _ = collect_exn tree (path ["er1"]) in - Alcotest.(check bool) "the dependent is still collected" false (present tree (path ["er1"])); - Alcotest.(check bool) "the pinned input survives" true (present tree (path ["r1"])) - -(* Collecting a runtime object surfaces a disposal for the caller to run, - because there is no durable form to rehydrate from. *) -let test_runtime_collection_surfaces_disposal () = - let tree = register_exn Object.root (path ["s1"]) (session ()) in - let tree, disposals = collect_exn tree (path ["s1"]) in - Alcotest.(check bool) "the session is removed" false (present tree (path ["s1"])); - match BatFingerTree.front disposals with - | Some (rest, {Lifecycle.kind= Object.Session _; _}) when BatFingerTree.is_empty rest -> () - | _ -> Alcotest.fail "expected exactly one session disposal" - -(* A namespace with objects under it is scaffolding, so it is kept rather than - collected, and this is not an error. *) -let test_populated_namespace_is_kept () = - let tree = register_exn Object.root (path ["ns"]) (namespace "ns") in - let tree = register_exn tree (path ["ns"; "r1"]) (relation "r1") in - let tree, _ = collect_exn tree (path ["ns"]) in - Alcotest.(check bool) "a populated namespace is kept" true (present tree (path ["ns"])) - -(* Property: pinning is a decision, reference counting is bookkeeping. No - sequence of pin/unpin may ever move the reference count. *) -let prop_pin_never_moves_reference_count = - QCheck.Test.make ~name:"pin/unpin never changes reference_count" ~count:200 - QCheck.(list bool) - (fun operations -> - let tree = register_exn Object.root (path ["r1"]) (relation "r1") in - let tree = - List.fold_left - (fun tree pin -> - if pin then Lifecycle.pin tree (path ["r1"]) else Lifecycle.unpin tree (path ["r1"]) ) - tree operations - in - reference_count tree (path ["r1"]) = 0 ) - -(* Property: reference edges are balanced. Registering an ephemeral relation - over any selection of inputs and then unregistering it returns every input - to its baseline count, whatever the selection or its duplicates. *) -let prop_edges_are_balanced = - QCheck.Test.make ~name:"register then unregister an ER restores input counts" ~count:200 - QCheck.(pair (int_range 1 5) (list (int_range 0 4))) - (fun (input_count, selection) -> - let inputs = List.init input_count (fun i -> path [Printf.sprintf "r%d" i]) in - let tree = - List.fold_left - (fun tree p -> register_exn tree p (relation (Path.to_string p))) - Object.root inputs - in - let chosen = - List.filter (fun i -> i < input_count) selection - |> List.map (fun i -> path [Printf.sprintf "r%d" i]) - in - let tree = register_exn tree (path ["er"]) (ephemeral "er" chosen) in - let tree = unregister_exn tree (path ["er"]) in - List.for_all (fun p -> reference_count tree p = 0) inputs ) - -let suites () = - [ ( "lifecycle/registry", - [ Alcotest.test_case "edges track dependents" `Quick test_edges_track_dependents; - Alcotest.test_case "eligibility gates" `Quick test_eligibility_gates; - Alcotest.test_case "cascade follows edges" `Quick test_cascade_follows_edges; - Alcotest.test_case "pin survives cascade" `Quick test_pin_survives_cascade; - Alcotest.test_case "runtime collection surfaces disposal" `Quick - test_runtime_collection_surfaces_disposal; - Alcotest.test_case "populated namespace is kept" `Quick test_populated_namespace_is_kept ] ); - ( "lifecycle/properties", - List.map QCheck_alcotest.to_alcotest - [prop_pin_never_moves_reference_count; prop_edges_are_balanced] ) ] diff --git a/test/unit/backend/Storage.ml b/test/unit/backend/Storage.ml index 76bda8b..a6765bf 100644 --- a/test/unit/backend/Storage.ml +++ b/test/unit/backend/Storage.ml @@ -6,17 +6,17 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = module H = Helpers.Storage.Make (S) (C) let storage_and_retrieval conn = - let key = Concepts.Hash.hash_of_value (Concepts.Value.String "value") in + let key = Concepts.Value.String "value" |> Concepts.Encoding.blob_of_value |> Concepts.Hash.hash_of_blob in let value = Concepts.Value.Integer 42 in - let blob = Concepts.Representation.blob_of_value value in + let blob = Concepts.Encoding.blob_of_value value in let v, v' = begin let open Utilities.Result in let* tx = S.start conn in - let* v = S.get tx key in - let* () = S.put tx key blob in - let* v' = S.get tx key in - Ok Concepts.Representation.(Option.map value_of_blob v, Option.map value_of_blob v') + let* v = S.get tx (S.Hash key) in + let* () = S.put tx (S.Hash key) blob in + let* v' = S.get tx (S.Hash key) in + Ok Concepts.Encoding.(Option.map value_of_blob v, Option.map value_of_blob v') end |> Helpers.condition_as_failure in diff --git a/test/unit/concepts/Serialization.ml b/test/unit/concepts/Serialization.ml deleted file mode 100644 index 9df8d26..0000000 --- a/test/unit/concepts/Serialization.ml +++ /dev/null @@ -1,45 +0,0 @@ -module Branch = Rnt.Concepts.Branch -module Hash = Rnt.Concepts.Hash -module Multigroup = Rnt.Concepts.Multigroup -module Relation = Rnt.Concepts.Relation - -let fail_condition c = Alcotest.fail (Rnt.Concepts.Condition.to_string_hum c) -let hash text = Hash.hash_of_bytes (Bytes.of_string text) - -let check_hash label expected actual = - Alcotest.(check bool) label true (Hash.hash_equals expected actual) - -let test_branch_round_trips () = - let expected = Branch.make ~name:"master" ~target:(hash "master-target") in - match Branch.(expected |> to_bytes |> of_bytes) with - | Ok actual -> - Alcotest.(check string) "name" (Branch.name expected) (Branch.name actual); - check_hash "target" (Branch.target expected) (Branch.target actual) - | Error c -> fail_condition c - -let test_multigroup_round_trips () = - let expected = Multigroup.make ~name:"public" ~relations:(hash "public-relations") in - match Multigroup.(expected |> to_bytes |> of_bytes) with - | Ok actual -> - Alcotest.(check string) "name" (Multigroup.name expected) (Multigroup.name actual); - check_hash "relations" (Multigroup.relations expected) (Multigroup.relations actual) - | Error c -> fail_condition c - -let test_relation_round_trips () = - let schema = Relation.schema_of_list ["tag", "string"; "name", "string"] in - let expected = Relation.make ~name:"users" ~tuples:(hash "users-tuples") ~schema in - match Relation.(expected |> to_bytes |> of_bytes) with - | Ok actual -> - Alcotest.(check string) "name" (Relation.name expected) (Relation.name actual); - check_hash "tuples" (Relation.tuples expected) (Relation.tuples actual); - Alcotest.(check (list (pair string string))) - "schema" - (Relation.schema expected |> Relation.schema_to_list) - (Relation.schema actual |> Relation.schema_to_list) - | Error c -> fail_condition c - -let suites () = - [ ( "concepts/serialization", - [ Alcotest.test_case "branch round-trips" `Quick test_branch_round_trips; - Alcotest.test_case "multigroup round-trips" `Quick test_multigroup_round_trips; - Alcotest.test_case "relation round-trips" `Quick test_relation_round_trips ] ) ] diff --git a/test/unit/kernel/Merkle.ml b/test/unit/kernel/Merkle.ml index 5c610bb..d5a075e 100644 --- a/test/unit/kernel/Merkle.ml +++ b/test/unit/kernel/Merkle.ml @@ -1,18 +1,10 @@ open Rnt -module StringKey : Rnt.Kernel.Merkle.KEY with type t = string = struct - type t = string - - let encode s = String.to_bytes s |> Concepts.Representation.blob_of_bytes - let compare s1 s2 = String.compare s1 s2 |> Concepts.Ordering.of_int - let decode b = Concepts.Representation.bytes_of_blob b |> String.of_bytes |> Result.ok -end - module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = struct open Alcotest module H = Helpers.Storage.Make (S) (C) - module T = Rnt.Kernel.Merkle.Interface (S) (StringKey) (StringKey) + module T = Rnt.Kernel.Merkle.Interface (S) (Rnt.Kernel.Merkle.StringKey) (Rnt.Kernel.Merkle.StringKey) (* TODO: be a bit more comprehensive (ideally, we want to test splits as well) *) let insert_and_lookup conn = |