From d5424c4813e63b6cdce400cb2367d8749fe48d9a Mon Sep 17 00:00:00 2001 From: rcmerci Date: Wed, 7 Oct 2026 13:12:43 +0800 Subject: [PATCH 1/4] Route sync asset execution through reducer-issued effects --- ...6-10-07-2026-10-07-sync-submit-boundary.md | 45 + .../lib/effect_runner/effect_runner.ml | 503 ++++-- logseq_db_worker/lib/logseq_db_worker.ml | 30 +- logseq_db_worker/lib/pure_reducer/core.ml | 34 +- .../lui/logseq_db_worker_lui_service.ml | 48 +- .../spec/effect_runner/effect_runner.mli | 48 +- logseq_db_worker/spec/pure_reducer/core.mli | 2 + logseq_db_worker/test/test_effect_runner.ml | 759 +++++++- logseq_db_worker/test/test_pure_reducer.ml | 125 ++ .../lib/effect_runner/effect_runner.ml | 744 +++++--- .../lib/effect_runner/storage/asset_cache.ml | 677 +------ .../lib/effect_runner/storage/bootstrap.ml | 691 +++++++ .../lib/effect_runner/storage/bootstrap.mli | 84 + logseq_sync/lib/pure_reducer/core.ml | 630 ++++++- .../spec/effect_runner/asset_cache.mli | 83 +- .../spec/effect_runner/effect_runner.mli | 136 +- logseq_sync/spec/pure_reducer/core.mli | 127 +- logseq_sync/test/asset_adapter_memory.ml | 102 +- logseq_sync/test/core_contract.ml | 582 +++++- logseq_sync/test/runner_contract.ml | 1203 +++++++++++-- logseq_sync/test/test_asset_cache.ml | 652 ++----- logseq_sync/test/test_sync.ml | 1 + logseq_sync/test/transport_contract.ml | 1604 ++++++++++++----- test/macos_mutation_runtime_test.ml | 30 +- test/source_boundary_test.ml | 30 +- 25 files changed, 6241 insertions(+), 2729 deletions(-) create mode 100644 docs/agent-guide/implemented/architecture/2026-10-07-2026-10-07-sync-submit-boundary.md diff --git a/docs/agent-guide/implemented/architecture/2026-10-07-2026-10-07-sync-submit-boundary.md b/docs/agent-guide/implemented/architecture/2026-10-07-2026-10-07-sync-submit-boundary.md new file mode 100644 index 0000000..d56bbf9 --- /dev/null +++ b/docs/agent-guide/implemented/architecture/2026-10-07-2026-10-07-sync-submit-boundary.md @@ -0,0 +1,45 @@ +# Sync Submit Boundary + +## Problem + +Asset execution bypassed the synchronization reducer through public runner methods. Callers received staging paths, cache handles and leases directly, splitting completion identity and stale-resource cleanup between adapters and business state owners. + +## Decision + +`Core.step` is the only public producer of `runner_effect`. The effect variant is private and its execution tickets are abstract. Callers can inspect, retain and submit an issued effect, but cannot reconstruct it, including with a ticket from another effect or through the visible compiled module alias. + +The public execution entry point is `Effect_runner.submit`. Dependency construction, `create` and `shutdown` remain lifecycle interfaces. Public asset execution, scoped callback execution, authentication execution and crypto execution helpers were removed. The cache implementation lives in the existing private Bootstrap module; the former public Asset_cache module exposes no execution values. No Dune change was needed. + +Asset execution follows `Asset_requested -> step -> Asset_io -> submit -> Asset_completion -> step -> Asset_finished` or reducer-issued cleanup. The request binds an operation, exact graph scope and action metadata; the opaque ticket also binds the captured execution context. Asset bytes never enter reducer state, events or business outputs. Downloads, PUT, staging, cache inspection, retain/release, path delivery, pruning, scope closure, deletion, retry waits and cancellation use this route. Protected graph-value crypto uses the same public event/completion/output boundary with a distinct ticket and request type. + +The state owners remain separate: + +- Worker Asset_upload owns durable intent, local attachment insertion, metadata mutation, publication acknowledgement, recovery and cancellation. Staging and intent persistence still precede graph mutation and PUT. A successful PUT does not complete import publication. +- Sync Core owns asset execution admission, pending identity, cancellation, completion acceptance and resource cleanup effects. Graph sync policy and Asset_transfer demand policy retain their existing independent reducers. +- Runner owns network, crypto, file and cache I/O plus execution resource budgets. It returns typed completions and does not mutate reducer state or run business retry loops. + +Cancelled pending tickets remain eligible for late resource cleanup. Duplicate and mismatched completions cannot publish another operation's success. Deletion cancellation matches the actual persistent origin/user/graph target across presentation and graph generations. Cleanup submitted before or after shutdown executes through submit; shutdown cannot retire queued cleanup without deleting its resource. Worker waiter reclamation covers cancelled callers and outputs already delivered but not yet accepted. + +Staging returns an independent physical `UUID.nonce.type` identity. A late completion cannot delete a replacement import using the same business UUID. Recovery pruning preserves exact durable intent file identities. Legacy `UUID.type` staging remains recoverable. Only durable save and required cleanup are protected from cancellation; staging completion waits are cancellable and their lock is released in finally. + +The existing download/upload/codec limits (3/1/1) and shared 64 MiB byte reservation remain. Partial reservation cancellation releases acquired capacity without poisoning the acquisition gate. Reservations exceeding the shared budget fail before asset bytes are read. Local store construction permits smaller budgets without increasing production defaults. + +## Verification + +- `dune runtest logseq_sync logseq_db_worker` passed: sync main suite 182, worker runner 16, worker Core 14, Asset_upload 11, Asset_transfer 12, asset protocol 4, codec 4, descriptor 3, and public negative compilation 1. Existing protocol, overlay and LUI package checks completed under their aliases. +- The public compile harness uses only exported spec interfaces through the existing test entry point. It rejects private constructor reconstruction, ticket forgery, visible Core alias construction, removed runner APIs and public/private Bootstrap access; holding and submitting effects compiles. +- Ownership regressions were reproduced before fixes: cross-generation deletion completion acceptance, replacement staging identity and queued graph I/O entering authentication after deletion. Pure acceptance defects are tested only through Core.step; filesystem and scheduler defects use the narrow runner boundary. Worker tests include cancellation of queued/resolved resource outputs and actual Db shutdown with physical staging deletion. +- Compiled native mutation fixtures passed all 9 cases through the migrated direct caller. +- Upstream Logseq/Apple crypto interoperability passed in both directions for 0, 1, 256, 4097, 131057 and 8388608 bytes. The production 8 MiB adapter allocated 86698576 OCaml bytes and peaked at 114049024 RSS bytes; native interoperability peaked at 130252800 RSS bytes, within existing limits. +- Failures and final evidence are retained only in ignored test-report directories. Tests used synthetic accounts, temporary files and localhost peers; no user graph, account or phone was tested. +- The full decision-document check has one existing baseline failure: `implemented/feature/2026-09-28-bottom-lui-capsules.md` lacks Problem, Alternatives considered and Consequences. This decision is validated separately. + +## Alternatives considered + +### Compatibility wrappers and merged ownership + +Compatibility wrappers were explicitly rejected because they preserve bypass paths. Moving durable import policy into sync or hiding business retry waits in the runner was rejected because those states have different owners. Stable per-operation staging filenames were rejected after the late-completion regression reproduced resource aliasing. + +## Consequences + +This is a breaking interface cutover: direct consumers must request operations through events and accept reducer outputs. Effect opacity is enforced without adding modules or changing Dune. Existing cache files and durable legacy staging remain usable. The isolated worktree reuses the installed toolchain and avoids a duplicate Journal/LUI application build. A separately reviewed shared compatibility commit fixes the repository LUI manifests to the validated revision; global opam state is unchanged and this does not claim compatibility with latest LUI. diff --git a/logseq_db_worker/lib/effect_runner/effect_runner.ml b/logseq_db_worker/lib/effect_runner/effect_runner.ml index db5e62e..ecada05 100644 --- a/logseq_db_worker/lib/effect_runner/effect_runner.ml +++ b/logseq_db_worker/lib/effect_runner/effect_runner.ml @@ -306,39 +306,8 @@ type runtime = } type sync_runner = - { stage_asset : - scope:Sync.graph_scope - -> operation:Graph.Uuid.t - -> file_type:string - -> source_file:string - -> (string * string * int64, string) result - ; put_upload : - context:Sync.asset_context - -> Logseq_db_types.Asset_upload_intent.t - -> current:(unit -> bool) - -> (unit, Upload.failure) result - ; prune_staging : - scope:Sync.graph_scope - -> keep:(Graph.Uuid.t -> (bool, string) result) - -> (int, string) result - ; release_staging : scope:Sync.graph_scope -> file:string -> (unit, string) result - ; submit_asset : - context:Sync.asset_context - -> current:(Logseq_sync_pure_reducer.Asset_transfer.ticket -> bool) - -> post:(Logseq_sync_pure_reducer.Asset_transfer.event -> unit) - -> Logseq_sync_pure_reducer.Asset_transfer.instruction - -> unit - ; delete_assets : Sync.mirror_deletion -> (unit, string) result - ; close_assets : Sync.graph_scope -> unit - ; retain_staged_file : scope:Sync.graph_scope -> file:string -> (string * string) option - ; retain_asset_file : - scope:Sync.graph_scope -> handle:string -> (string * string) option - ; release_asset_file : scope:Sync.graph_scope -> handle:string -> unit - ; submit : Sync.runner_effect -> unit + { submit : Sync.runner_effect -> unit ; shutdown : unit -> unit - ; decrypt_protected_value : Sync.graph_key_handle -> string -> (string, string) result - ; encrypt_protected_values : - Sync.graph_key_handle -> string list -> ((string * string) list, string) result } type dependencies = @@ -357,6 +326,19 @@ type waiter = ; resolve : Protocol.response Eio.Promise.u } +type asset_waiter = + { request : Sync.asset_request + ; resolve : Sync.asset_output Eio.Promise.u + ; mutable delivered : Sync.asset_output option + ; mutable accepted : bool + ; mutable reclaimed : bool + } + +type protected_waiter = + { protected_request : Sync.protected_request + ; protected_resolve : Sync.protected_output Eio.Promise.u + } + type change_window = { id : string ; predecessor : string @@ -380,6 +362,10 @@ type t = ; dependencies : dependencies ; post : Core.event -> unit ; upload_operations : (Upload.ticket, unit Eio.Promise.u) Hashtbl.t + ; protected_waiters : (string, protected_waiter) Hashtbl.t + ; asset_waiters : (string, asset_waiter) Hashtbl.t + ; asset_operations : (Logseq_sync_pure_reducer.Asset_transfer.ticket, string) Hashtbl.t + ; mutable next_asset_operation : int64 ; upload_staging_lock : Eio.Mutex.t ; mutable staging_reconciled : Sync.graph_scope option ; recovery_current : Core.upload_recovery_ticket -> bool @@ -395,47 +381,13 @@ type t = } let runtime ~fork ~sleep = Ok { fork; sleep } - -let sync_runner - ?(decrypt_protected_value = fun _ _ -> Error "sync decryption is unavailable") - ?(encrypt_protected_values = fun _ _ -> Error "sync encryption is unavailable") - ~stage_asset - ~put_upload - ~prune_staging - ~release_staging - ~submit_asset - ~delete_assets - ~close_assets - ~retain_staged_file - ~retain_asset_file - ~release_asset_file - ~submit - ~shutdown - () - = - { stage_asset - ; put_upload - ; release_staging - ; prune_staging - ; submit - ; shutdown - ; decrypt_protected_value - ; encrypt_protected_values - ; submit_asset - ; delete_assets - ; close_assets - ; retain_staged_file - ; retain_asset_file - ; release_asset_file - } -;; +let sync_runner ~submit ~shutdown () = { submit; shutdown } let dependencies ~runtime ~config ~overlay ~sync_runner ~publish = Ok { runtime; config; overlay; sync_runner; publish } ;; let create ~sw dependencies ~post ~recovery_current ~upload_current ~asset_current = - ignore dependencies.sync_runner.encrypt_protected_values; Ok { sw ; dependencies @@ -444,6 +396,10 @@ let create ~sw dependencies ~post ~recovery_current ~upload_current ~asset_curre ; upload_current ; recovery_current ; upload_operations = Hashtbl.create 32 + ; protected_waiters = Hashtbl.create 32 + ; asset_waiters = Hashtbl.create 32 + ; asset_operations = Hashtbl.create 8 + ; next_asset_operation = 0L ; upload_staging_lock = Eio.Mutex.create () ; staging_reconciled = None ; databases = Hashtbl.create 4 @@ -478,28 +434,184 @@ let with_upload_store t action = | exn -> Error (Printexc.to_string exn) ;; +let asset_request t ~scope action = + let operation = "worker-asset:" ^ Int64.to_string t.next_asset_operation in + t.next_asset_operation <- Int64.succ t.next_asset_operation; + { Sync.scope; operation; action } +;; + +let post_asset_request t request = t.post (Core.Sync_event (Sync.Asset_requested request)) + +let send_asset t ~scope action = + Eio.Cancel.protect (fun () -> post_asset_request t (asset_request t ~scope action)) +;; + +let reclaim_asset_output t (output : Sync.asset_output) = + let action = + match output.result with + | Ok (Sync.Asset_staged { file; _ }) -> Some (Sync.Release_staged_file file) + | Ok + ( Asset_retained (Some (handle, _)) + | Asset_cached (Some handle) + | Asset_downloaded handle ) -> Some (Sync.Release_asset_file handle) + | Ok _ | Error _ -> None + in + Option.iter (send_asset t ~scope:output.request.scope) action +;; + +let reclaim_waiter t waiter = + if (not waiter.accepted) && not waiter.reclaimed + then ( + waiter.reclaimed <- true; + Option.iter (reclaim_asset_output t) waiter.delivered) +;; + +let asset_call ?(started = fun _ -> ()) t ~scope action = + let request = asset_request t ~scope action in + let promise, resolve = Eio.Promise.create () in + let waiter = + { request; resolve; delivered = None; accepted = false; reclaimed = false } + in + Hashtbl.add t.asset_waiters request.operation waiter; + Fun.protect + ~finally:(fun () -> + Hashtbl.remove t.asset_waiters request.operation; + if not waiter.accepted + then ( + reclaim_waiter t waiter; + send_asset t ~scope (Sync.Cancel_asset_operation request.operation))) + (fun () -> + started request.operation; + post_asset_request t request; + let output = Eio.Promise.await promise in + waiter.accepted <- true; + output.Sync.result) +;; + +let protected_call t action = + let key = + match action with + | Sync.Encrypt_values (key, _) | Decrypt_value (key, _) -> key + in + let operation = "worker-protected:" ^ Int64.to_string t.next_asset_operation in + t.next_asset_operation <- Int64.succ t.next_asset_operation; + let request = + { Sync.protected_operation = operation + ; protected_scope = Sync.graph_key_handle_scope key + ; protected_action = action + } + in + let promise, resolve = Eio.Promise.create () in + Hashtbl.add + t.protected_waiters + operation + { protected_request = request; protected_resolve = resolve }; + Fun.protect + ~finally:(fun () -> Hashtbl.remove t.protected_waiters operation) + (fun () -> + t.post (Core.Sync_event (Sync.Protected_requested request)); + (Eio.Promise.await promise).Sync.protected_result) +;; + +let encrypt_protected_values t key plaintexts = + match protected_call t (Sync.Encrypt_values (key, plaintexts)) with + | Ok (Sync.Encrypted_values values) -> Ok values + | Ok _ -> Error "Unexpected protected encryption completion" + | Error (Sync.Effect_failed message | Crypto_failed (_, message)) -> Error message +;; + +let decrypt_protected_value t key source = + match protected_call t (Sync.Decrypt_value (key, source)) with + | Ok (Sync.Decrypted_value value) -> Ok value + | Ok _ -> Error "Unexpected protected decryption completion" + | Error (Sync.Effect_failed message | Crypto_failed (_, message)) -> Error message +;; + +let asset_failure_message = function + | Sync.Asset_invalid_content message -> message + | Asset_network -> "Asset network request failed" + | Asset_not_found | Asset_missing_source -> "Asset source is unavailable" + | Asset_checksum_mismatch -> "Asset checksum mismatch" + | Asset_authentication -> "Asset authentication failed" + | Asset_locked -> "Asset encryption key is unavailable" + | Asset_storage_full -> "Asset storage is full" + | Asset_size_rejected -> "Asset size exceeds the limit" + | Asset_revoked_access -> "Asset access was revoked" + | Asset_cancelled -> "Asset operation was cancelled" +;; + +let asset_unit t ~scope action = + match asset_call t ~scope action with + | Ok Sync.Asset_unit -> Ok () + | Error failure -> Error (asset_failure_message failure) + | Ok _ -> Error "Unexpected asset completion" +;; + +let with_staging_lock t action = + Eio.Mutex.lock t.upload_staging_lock; + Fun.protect + ~finally:(fun () -> Eio.Mutex.unlock t.upload_staging_lock) + (fun () -> + match action () with + | result -> + if Result.is_error result then t.staging_reconciled <- None; + result + | exception error -> + t.staging_reconciled <- None; + raise error) +;; + let reconcile_staging t (scope : Sync.graph_scope) ~current = if (not (current ())) || t.stopped then Error "Stale staging recovery" else if t.staging_reconciled = Some scope then Ok () - else - with_upload_store t (fun db -> - t.dependencies.sync_runner.prune_staging ~scope ~keep:(fun operation -> - if (not (current ())) || t.stopped - then Error "Stale staging recovery" - else - Result.bind (Logseq_db_storage.Asset_upload_store.read db ~operation) (function - | None -> Ok false - | Some intent - when intent.origin = Uri.to_string scope.account.managed_sync_origin - && intent.account = scope.account.user_id - && intent.graph = scope.graph_id - && intent.staged_file - = Graph.Uuid.to_string operation ^ "." ^ intent.version.file_type -> - Ok true - | Some _ -> Error "Staging checkpoint scope mismatch"))) - |> Result.map (fun _ -> t.staging_reconciled <- Some scope) + else ( + let keep = + with_upload_store t (fun db -> + let rec read after reversed = + if (not (current ())) || t.stopped + then Error "Stale staging recovery" + else + Result.bind + (Logseq_db_storage.Asset_upload_store.list + db + ~origin:(Uri.to_string scope.account.managed_sync_origin) + ~account:scope.account.user_id + ~graph:scope.graph_id + ~after + ~limit:128) + (fun intents -> + let reversed = + List.fold_left + (fun files intent -> + intent.Logseq_db_types.Asset_upload_intent.staged_file :: files) + reversed + intents + in + match List.rev intents with + | [] -> Ok (List.rev reversed) + | last :: _ when List.length intents = 128 -> + read + (Some last.Logseq_db_types.Asset_upload_intent.operation_id) + reversed + | _ -> Ok (List.rev reversed)) + in + read None []) + in + Result.bind keep (fun keep -> + if (not (current ())) || t.stopped + then Error "Stale staging recovery" + else ( + match asset_call t ~scope (Sync.Prune_asset_staging keep) with + | Ok (Sync.Asset_pruned _) -> + if current () + then ( + t.staging_reconciled <- Some scope; + Ok ()) + else Error "Stale staging recovery" + | Error failure -> Error (asset_failure_message failure) + | Ok _ -> Error "Unexpected staging recovery completion"))) ;; let save_upload t intent expected = @@ -1182,7 +1294,7 @@ let protect_request t key request = | Some key -> let plaintexts = Database.protection_plaintexts request in let raw = List.map snd plaintexts in - (match t.dependencies.sync_runner.encrypt_protected_values key raw with + (match encrypt_protected_values t key raw with | Error message -> Error (effect_error message) | Ok encrypted -> let encrypted = @@ -1201,7 +1313,7 @@ let unprotect_request t key request = let rec decrypt reversed = function | [] -> Ok (List.rev reversed) | (id, ciphertext) :: rest -> - (match t.dependencies.sync_runner.decrypt_protected_value key ciphertext with + (match decrypt_protected_value t key ciphertext with | Error message -> Error (effect_error message) | Ok plaintext -> decrypt ((id, plaintext) :: reversed) rest) in @@ -1291,11 +1403,7 @@ let handle_sync_worker_effect t = function let rec decrypt reversed = function | [] -> Ok (List.rev reversed) | (id, ciphertext) :: rest -> - (match - t.dependencies.sync_runner.decrypt_protected_value - graph_key - ciphertext - with + (match decrypt_protected_value t graph_key ciphertext with | Error message -> Error message | Ok plaintext -> decrypt ((id, plaintext) :: reversed) rest) in @@ -1338,7 +1446,15 @@ let handle_sync_worker_effect t = function ~origin:(Uri.to_string request.account.managed_sync_origin) ~account:request.account.user_id ~graph:request.graph_id)) - (fun () -> t.dependencies.sync_runner.delete_assets request) + (fun () -> + asset_unit + t + ~scope: + { Sync.account = request.account + ; graph_id = request.graph_id + ; graph_generation = 0 + } + Sync.Delete_graph_assets) |> Result.map_error (fun _ -> ())) (fun () -> Database.delete_mirror inspection |> Result.map_error (fun _ -> ())) @@ -1573,9 +1689,7 @@ let run_upload t (context : Sync.asset_context) instruction = | Upload.Cancel_operation _ -> () | Release_staging intent -> (match - t.dependencies.sync_runner.release_staging - ~scope:context.scope - ~file:intent.staged_file + asset_unit t ~scope:context.scope (Sync.Release_staged_file intent.staged_file) with | Ok () -> () | Error message -> t.dependencies.publish (Core.Diagnostic message)) @@ -1614,8 +1728,31 @@ let run_upload t (context : Sync.asset_context) instruction = then finish ticket - (t.dependencies.sync_runner.put_upload ~context intent ~current:(fun () -> - current ticket)) + (match + asset_call + t + ~scope:context.scope + (Sync.Put_asset_file + { asset = intent.asset + ; version = intent.version + ; file = intent.staged_file + ; maximum_plaintext_bytes = 8 * 1024 * 1024 + }) + with + | Ok Sync.Asset_unit -> Ok () + | Ok _ -> Error Upload.Invalid_content + | Error failure -> + Error + (match failure with + | Sync.Asset_network -> Upload.Network + | Asset_authentication | Asset_locked -> Authentication + | Asset_missing_source | Asset_not_found -> Missing_source + | Asset_size_rejected -> Size_rejected + | Asset_revoked_access -> Revoked_access + | Asset_checksum_mismatch + | Asset_storage_full + | Asset_cancelled + | Asset_invalid_content _ -> Invalid_content)) Upload.Put_succeeded | Await_publication (ticket, intent) -> let rec await () = @@ -1640,7 +1777,8 @@ let submit_upload t context instruction = Option.iter (fun resolver -> ignore (Eio.Promise.try_resolve resolver () : bool)) (Hashtbl.find_opt t.upload_operations ticket) - | Release_staging _ -> run_upload t context instruction + | Release_staging _ -> + t.dependencies.runtime.fork ~sw:t.sw (fun () -> run_upload t context instruction) | Persist (ticket, _, _) | Inspect (ticket, _) | Apply_local (ticket, _) @@ -1660,7 +1798,117 @@ let submit_upload t context instruction = (fun () -> Eio.Promise.await cancelled)))) ;; +let transfer_failure = function + | Sync.Asset_network -> Logseq_sync_pure_reducer.Asset_transfer.Network + | Asset_not_found | Asset_missing_source -> Not_found + | Asset_checksum_mismatch -> Checksum_mismatch + | Asset_authentication | Asset_revoked_access -> Authentication + | Asset_locked -> Locked + | Asset_storage_full -> Storage_full + | Asset_size_rejected -> Invalid_content "Asset size exceeds the limit" + | Asset_cancelled -> Invalid_content "Asset operation was cancelled" + | Asset_invalid_content message -> Invalid_content message +;; + +let run_asset t (context : Sync.asset_context) instruction = + let module Transfer = Logseq_sync_pure_reducer.Asset_transfer in + let perform ticket action success = + if + (not t.stopped) + && t.asset_current ticket + && not (Hashtbl.mem t.asset_operations ticket) + then ( + Hashtbl.add t.asset_operations ticket ""; + t.dependencies.runtime.fork ~sw:t.sw (fun () -> + Fun.protect + ~finally:(fun () -> Hashtbl.remove t.asset_operations ticket) + (fun () -> + let result = + if t.stopped || not (t.asset_current ticket) + then Error Sync.Asset_cancelled + else + asset_call + ~started:(fun operation -> + Hashtbl.replace t.asset_operations ticket operation) + t + ~scope:context.scope + action + in + if (not t.stopped) && t.asset_current ticket + then + t.post + (Core.Asset_completed + ( context.scope + , success + (match result with + | Ok value -> Ok value + | Error failure -> Error (transfer_failure failure)) )) + else ( + match result with + | Ok (Sync.Asset_cached (Some handle) | Asset_downloaded handle) -> + send_asset t ~scope:context.scope (Sync.Release_asset_file handle) + | Ok _ | Error _ -> ())))) + in + match instruction with + | Transfer.Check_cache ticket -> + perform + ticket + (Sync.Check_asset_cache (ticket.asset, ticket.version)) + (fun result -> + Transfer.Cache_checked + ( ticket + , Result.bind result (function + | Sync.Asset_cached handle -> Ok handle + | _ -> Error (Transfer.Invalid_content "Unexpected cache completion")) )) + | Fetch ticket -> + perform + ticket + (Sync.Fetch_asset + { asset = ticket.asset + ; version = ticket.version + ; maximum_plaintext_bytes = 8 * 1024 * 1024 + }) + (fun result -> + Transfer.Downloaded + ( ticket + , Result.bind result (function + | Sync.Asset_downloaded handle -> Ok handle + | _ -> Error (Transfer.Invalid_content "Unexpected download completion")) + )) + | Cancel ticket -> + Option.iter + (fun operation -> + if operation <> "" + then send_asset t ~scope:context.scope (Sync.Cancel_asset_operation operation)) + (Hashtbl.find_opt t.asset_operations ticket) + | Release_handle handle -> + send_asset t ~scope:context.scope (Sync.Release_asset_file handle) + | Retry_after { id; seconds } -> + t.dependencies.runtime.fork ~sw:t.sw (fun () -> + match asset_call t ~scope:context.scope (Sync.Asset_retry_after seconds) with + | Ok Sync.Asset_retry_elapsed when not t.stopped -> + t.post (Core.Asset_completed (context.scope, Transfer.Retry_elapsed id)) + | Ok _ | Error _ -> ()) + | Notify _ | Backpressure _ | Capacity_available -> () +;; + let submit t = function + | Core.Deliver_protected_result output -> + (match + Hashtbl.find_opt + t.protected_waiters + output.Sync.protected_request.protected_operation + with + | Some waiter when waiter.protected_request = output.protected_request -> + ignore (Eio.Promise.try_resolve waiter.protected_resolve output : bool) + | Some _ | None -> ()) + | Core.Deliver_asset_result output -> + (match Hashtbl.find_opt t.asset_waiters output.Sync.request.operation with + | Some waiter when waiter.request = output.request && waiter.delivered = None -> + waiter.delivered <- Some output; + if not (Eio.Promise.try_resolve waiter.resolve output) then reclaim_waiter t waiter + | Some waiter when waiter.request = output.request -> () + | Some _ | None -> reclaim_asset_output t output) | Core.Read_uploads ticket -> if (not t.stopped) && t.recovery_current ticket then @@ -1668,7 +1916,7 @@ let submit t = function if (not t.stopped) && t.recovery_current ticket then ( let result = - Eio.Mutex.use_rw ~protect:true t.upload_staging_lock (fun () -> + with_staging_lock t (fun () -> Result.bind (reconcile_staging t ticket.scope ~current:(fun () -> t.recovery_current ticket)) @@ -1687,15 +1935,8 @@ let submit t = function | Core.Run_upload (context, instruction) -> if not t.stopped then submit_upload t context instruction | Core.Run_asset (context, instruction) -> - if not t.stopped - then - t.dependencies.sync_runner.submit_asset - ~context - ~current:(fun ticket -> (not t.stopped) && t.asset_current ticket) - ~post:(fun event -> - if not t.stopped then t.post (Core.Asset_completed (context.scope, event))) - instruction - | Close_asset_scope scope -> t.dependencies.sync_runner.close_assets scope + if not t.stopped then run_asset t context instruction + | Close_asset_scope scope -> send_asset t ~scope Sync.Close_asset_scope | Core.Run_worker request -> if not t.stopped then t.dependencies.runtime.fork ~sw:t.sw (fun () -> complete t request) @@ -1716,6 +1957,8 @@ let submit t = function (Core.Sync_event (Sync.Runner_completed (Sync.Completion (ticket, Error (Sync.Effect_failed message)))))) + | Run_sync (Sync.Asset_io _ as sync_effect) -> + t.dependencies.sync_runner.submit sync_effect | Run_sync sync_effect -> if not t.stopped then t.dependencies.sync_runner.submit sync_effect | Publish output -> if not t.stopped then t.dependencies.publish output @@ -1746,6 +1989,7 @@ let submit t instruction = let shutdown t = if not t.stopped then ( + t.post (Core.Sync_event Sync.Shutdown); t.stopped <- true; Hashtbl.iter (fun _ resolve -> ignore (Eio.Promise.try_resolve resolve () : bool)) @@ -1755,7 +1999,7 @@ let shutdown t = t.dependencies.sync_runner.shutdown (); Eio.Mutex.use_rw ~protect:true t.waiter_lock (fun () -> Hashtbl.iter - (fun _ waiter -> + (fun _ (waiter : waiter) -> let response = failure waiter.request Closed_session "The Worker stopped." in Eio.Promise.resolve waiter.resolve response) t.waiters; @@ -1763,11 +2007,13 @@ let shutdown t = ;; let retain_asset_file t ~scope ~handle = - if t.stopped then None else t.dependencies.sync_runner.retain_asset_file ~scope ~handle + match asset_call t ~scope (Sync.Retain_asset_file handle) with + | Ok (Sync.Asset_retained file) -> file + | Ok _ | Error _ -> None ;; let release_asset_file t ~scope ~handle = - t.dependencies.sync_runner.release_asset_file ~scope ~handle + ignore (asset_unit t ~scope (Sync.Release_asset_file handle)) ;; let prepare_import_unlocked @@ -1820,11 +2066,19 @@ let prepare_import_unlocked | Some _ -> Error "This import identity is already in use" | None -> let* file, checksum, size = - t.dependencies.sync_runner.stage_asset - ~scope:context.scope - ~operation:request.operation - ~file_type:request.file_type - ~source_file:request.source_file + match + asset_call + t + ~scope:context.scope + (Sync.Stage_asset_file + { operation = request.operation + ; file_type = request.file_type + ; source_file = request.source_file + }) + with + | Ok (Sync.Asset_staged { file; checksum; size }) -> Ok (file, checksum, size) + | Error failure -> Error (asset_failure_message failure) + | Ok _ -> Error "Unexpected staging completion" in let persistence_attempted = ref false in let result = @@ -1835,24 +2089,23 @@ let prepare_import_unlocked else ( persistence_attempted := true; let* () = - with_upload_store t (fun db -> - Logseq_db_storage.Asset_upload_store.save db ~expected:None intent) + Eio.Cancel.protect (fun () -> + with_upload_store t (fun db -> + Logseq_db_storage.Asset_upload_store.save db ~expected:None intent)) in Ok intent) in (match result with | Ok _ -> () | Error _ when not !persistence_attempted -> - ignore (t.dependencies.sync_runner.release_staging ~scope:context.scope ~file) + Eio.Cancel.protect (fun () -> + ignore (asset_unit t ~scope:context.scope (Sync.Release_staged_file file))) | Error _ -> ()); result ;; let prepare_import t ~context request ~current = - Eio.Mutex.use_rw ~protect:true t.upload_staging_lock (fun () -> - let result = prepare_import_unlocked t ~context request ~current in - if Result.is_error result then t.staging_reconciled <- None; - result) + with_staging_lock t (fun () -> prepare_import_unlocked t ~context request ~current) ;; let retain_imported_file t ~(scope : Sync.graph_scope) ~operation = @@ -1868,6 +2121,8 @@ let retain_imported_file t ~(scope : Sync.graph_scope) ~operation = && intent.account = scope.account.user_id && intent.graph = scope.graph_id && intent.phase <> Logseq_db_types.Asset_upload_intent.Cancelled -> - t.dependencies.sync_runner.retain_staged_file ~scope ~file:intent.staged_file + (match asset_call t ~scope (Sync.Retain_staged_file intent.staged_file) with + | Ok (Sync.Asset_retained file) -> file + | Ok _ | Error _ -> None) | Ok _ | Error _ -> None) ;; diff --git a/logseq_db_worker/lib/logseq_db_worker.ml b/logseq_db_worker/lib/logseq_db_worker.ml index 8065efc..cc83c41 100644 --- a/logseq_db_worker/lib/logseq_db_worker.ml +++ b/logseq_db_worker/lib/logseq_db_worker.ml @@ -34,12 +34,27 @@ let dispatch t event = List.iter (Effect_runner.submit t.runner) transition.effects ;; +let accepts_after_shutdown = function + | Pure_reducer.Sync_event + ( Logseq_sync_pure_reducer.Core.Asset_requested _ | Protected_requested _ + | Runner_completed (Asset_completion _ | Protected_completion _) + | Shutdown ) -> true + | _ -> false +;; + +let route_event t event = + if t.stopped + then (if accepts_after_shutdown event then dispatch t event) + else Eio.Stream.add t.events event +;; + let create ~sw ~config ~runner_dependencies = match Pure_reducer.initial config with | Error (Pure_reducer.Invalid_create message) -> Error (Invalid_create message) | Ok state -> let events = Eio.Stream.create 256 in let state_ref = ref state in + let event_sink = ref (fun event -> Eio.Stream.add events event) in (match Effect_runner.create ~sw @@ -50,13 +65,14 @@ let create ~sw ~config ~runner_dependencies = Pure_reducer.upload_ticket_current !state_ref ticket) ~asset_current:(fun ticket -> Pure_reducer.asset_ticket_current !state_ref ticket) - ~post:(fun event -> Eio.Stream.add events event) + ~post:(fun event -> !event_sink event) with | Error (Effect_runner.Invalid_create message) -> Error (Invalid_create message) | Ok runner -> let t = { state = state_ref; runner; events; next_request_id = 0L; stopped = false } in + event_sink := route_event t; dispatch t Pure_reducer.Start; Eio.Fiber.fork ~sw (fun () -> while not t.stopped do @@ -65,7 +81,7 @@ let create ~sw ~config ~runner_dependencies = Ok t) ;; -let post t event = if not t.stopped then Eio.Stream.add t.events event +let post t event = route_event t event let view t = Pure_reducer.view !(t.state) let graph_state t = (view t).graph @@ -79,8 +95,16 @@ let request t request = let shutdown t = if not t.stopped then ( - dispatch t Pure_reducer.Shutdown; t.stopped <- true; + dispatch t Pure_reducer.Shutdown; + let rec drain () = + match Eio.Stream.take_nonblocking t.events with + | None -> () + | Some event -> + if accepts_after_shutdown event then dispatch t event; + drain () + in + drain (); Eio.Stream.add t.events Pure_reducer.Shutdown; Effect_runner.shutdown t.runner) ;; diff --git a/logseq_db_worker/lib/pure_reducer/core.ml b/logseq_db_worker/lib/pure_reducer/core.ml index 67ef3e5..ba71113 100644 --- a/logseq_db_worker/lib/pure_reducer/core.ml +++ b/logseq_db_worker/lib/pure_reducer/core.ml @@ -103,6 +103,8 @@ type upload_recovery_ticket = } type instruction = + | Deliver_protected_result of Logseq_sync_pure_reducer.Core.protected_output + | Deliver_asset_result of Logseq_sync_pure_reducer.Core.asset_output | Read_uploads of upload_recovery_ticket | Run_upload of Logseq_sync_pure_reducer.Core.asset_context * Asset_upload.instruction | Run_asset of @@ -116,6 +118,8 @@ type instruction = module Sync = Logseq_sync_pure_reducer.Core let instruction_diagnostic = function + | Deliver_protected_result _ -> "deliver-protected-result" + | Deliver_asset_result _ -> "deliver-asset-result" | Read_uploads _ -> "read-uploads" | Run_upload _ -> "run-upload" | Run_asset _ -> "run-asset" @@ -135,6 +139,8 @@ let instruction_diagnostic = function let equal_instruction left right = match left, right with + | Deliver_protected_result l, Deliver_protected_result r -> l = r + | Deliver_asset_result l, Deliver_asset_result r -> l = r | Read_uploads l, Read_uploads r -> l = r | Run_upload (lc, li), Run_upload (rc, ri) -> lc = rc && li = ri | Run_asset (lc, li), Run_asset (rc, ri) -> lc = rc && li = ri @@ -147,6 +153,8 @@ let equal_instruction left right = | Run_asset _ | Run_upload _ | Read_uploads _ + | Deliver_protected_result _ + | Deliver_asset_result _ | Close_asset_scope _ | Publish _ ) , _ ) -> false @@ -297,6 +305,10 @@ let translate_sync transition state = let rec loop state reversed = function | [] -> { next = state; effects = List.rev reversed } | Sync.Run sync_effect :: rest -> loop state (Run_sync sync_effect :: reversed) rest + | Sync.Publish (Sync.Protected_finished output) :: rest -> + loop state (Deliver_protected_result output :: reversed) rest + | Sync.Publish (Sync.Asset_finished output) :: rest -> + loop state (Deliver_asset_result output :: reversed) rest | Sync.Publish output :: rest -> loop state (Publish (Sync_output output) :: reversed) rest | Sync.Delegate (Sync.Detach_graph scope) :: rest -> @@ -372,7 +384,13 @@ let execute_completion state ticket result = let step state event = if state.shutdown - then no_effects state + then ( + match event with + | Sync_event + (( Sync.Asset_requested _ | Sync.Protected_requested _ | Sync.Shutdown + | Sync.Runner_completed (Sync.Asset_completion _ | Sync.Protected_completion _) + ) as event) -> translate_sync (Sync.step state.sync_core event) state + | _ -> no_effects state) else ( match event with | Uploads_loaded _ @@ -491,6 +509,8 @@ let step state event = in { next = transitioned.next; effects = lifecycle_effects @ transitioned.effects }) | Shutdown -> + let stopped_sync = translate_sync (Sync.step state.sync_core Sync.Shutdown) state in + let state = stopped_sync.next in let close_effects, state = match state.database with | None -> [], state @@ -505,7 +525,7 @@ let step state event = ; pending = [] ; graph = { state.graph with phase = Graph_closed; graph_id = None } } - ; effects = close_effects + ; effects = stopped_sync.effects @ close_effects }) ;; @@ -602,7 +622,7 @@ let asset_scope_current state scope = | _ -> false ;; -let apply_asset state context transfer event = +let apply_asset state (context : Sync.asset_context) transfer event = let transfer, instructions = Transfer.step transfer event in let accepted = match event with @@ -690,7 +710,7 @@ let step state event = let current = asset_scope transition.next in let retained, retired = List.partition - (fun (context, _, _) -> + (fun ((context : Sync.asset_context), _, _) -> match current with | Some active -> context.Sync.scope = active.scope | None -> false) @@ -698,14 +718,14 @@ let step state event = in let cancellations = List.concat_map - (fun (context, _, upload) -> + (fun ((context : Sync.asset_context), _, upload) -> let _, instructions = Asset_upload.step upload Shutdown in List.map (fun instruction -> Run_upload (context, instruction)) instructions) retired in let cache_closes = retired - |> List.map (fun (context, _, _) -> context.Sync.scope) + |> List.map (fun ((context : Sync.asset_context), _, _) -> context.Sync.scope) |> List.sort_uniq compare |> List.map (fun scope -> Close_asset_scope scope) in @@ -733,7 +753,7 @@ let step state event = List.rev uploads, instructions in let state = { transition.next with uploads = retained } in - let apply context operation upload upload_event = + let apply (context : Sync.asset_context) operation upload upload_event = let previous = upload in let upload, instructions = Asset_upload.step upload upload_event in let remaining = List.filter (fun (_, id, _) -> id <> operation) state.uploads in diff --git a/logseq_db_worker/lui/logseq_db_worker_lui_service.ml b/logseq_db_worker/lui/logseq_db_worker_lui_service.ml index 0c337cb..0d1925c 100644 --- a/logseq_db_worker/lui/logseq_db_worker_lui_service.ml +++ b/logseq_db_worker/lui/logseq_db_worker_lui_service.ml @@ -399,7 +399,8 @@ let publish context = function Journal_worker.Session_context.emit context ~topic:bootstrap_topic - (Bootstrap_progress (bootstrap_progress progress))) + (Bootstrap_progress (bootstrap_progress progress)) + | Asset_finished _ | Protected_finished _ -> ()) | Graph_state_changed state -> Journal_worker.Session_context.emit context @@ -434,7 +435,8 @@ let sync_dependencies dependencies context config id_token_provider = Result.bind (Sync_runner.local_store ~application_support_directory: - config.Db.Config.application_support_directory) + config.Db.Config.application_support_directory + ()) (fun local_store -> Result.bind (Sync_runner.artifact_store @@ -586,50 +588,8 @@ let create ~(dependencies : dependencies) = Ok ( sync_config , Worker_runner.sync_runner - ~stage_asset:(Sync_runner.stage_asset runner) - ~release_staging:(Sync_runner.release_staged_asset runner) - ~prune_staging:(Sync_runner.prune_staged_assets runner) - ~put_upload:(fun ~context intent ~current -> - match - Sync_runner.staged_asset_path - runner - ~scope:context.scope - ~file: - intent.Logseq_db_types.Asset_upload_intent.staged_file - with - | None -> - Error - Logseq_db_worker_pure_reducer.Asset_upload.Missing_source - | Some source_file -> - Sync_runner.upload_asset - runner - ~context - ~asset:intent.asset - ~version:intent.version - ~source_file - ~maximum_plaintext_bytes:(8 * 1024 * 1024) - ~current - |> Result.map_error (function - | Sync_runner.Upload_network -> - Logseq_db_worker_pure_reducer.Asset_upload.Network - | Upload_authentication | Upload_locked -> Authentication - | Upload_missing_source -> Missing_source - | Upload_size_rejected -> Size_rejected - | Upload_revoked_access -> Revoked_access - | Upload_invalid_content | Upload_cancelled -> - Invalid_content)) - ~submit_asset:(Sync_runner.run_scoped_asset runner) - ~delete_assets:(Sync_runner.delete_graph_assets runner) - ~close_assets:(Sync_runner.close_asset_scope runner) - ~retain_staged_file:(Sync_runner.retain_staged_file runner) - ~retain_asset_file:(Sync_runner.retain_asset_file runner) - ~release_asset_file:(Sync_runner.release_asset_file runner) ~submit:(Sync_runner.submit runner) ~shutdown:(fun () -> Sync_runner.shutdown runner) - ~decrypt_protected_value: - (Sync_runner.decrypt_protected_value runner) - ~encrypt_protected_values: - (Sync_runner.encrypt_protected_values runner) () )))) in match selected with diff --git a/logseq_db_worker/spec/effect_runner/effect_runner.mli b/logseq_db_worker/spec/effect_runner/effect_runner.mli index 1fc561b..3eda86a 100644 --- a/logseq_db_worker/spec/effect_runner/effect_runner.mli +++ b/logseq_db_worker/spec/effect_runner/effect_runner.mli @@ -40,53 +40,7 @@ val runtime -> (runtime, dependency_error) result val sync_runner - : ?decrypt_protected_value: - (Logseq_sync_pure_reducer.Core.graph_key_handle - -> string - -> (string, string) result) - -> ?encrypt_protected_values: - (Logseq_sync_pure_reducer.Core.graph_key_handle - -> string list - -> ((string * string) list, string) result) - -> stage_asset: - (scope:Logseq_sync_pure_reducer.Core.graph_scope - -> operation:Logseq_db_types.Graph_types.Uuid.t - -> file_type:string - -> source_file:string - -> (string * string * int64, string) result) - -> put_upload: - (context:Logseq_sync_pure_reducer.Core.asset_context - -> Logseq_db_types.Asset_upload_intent.t - -> current:(unit -> bool) - -> (unit, Logseq_db_worker_pure_reducer.Asset_upload.failure) result) - -> prune_staging: - (scope:Logseq_sync_pure_reducer.Core.graph_scope - -> keep:(Logseq_db_types.Graph_types.Uuid.t -> (bool, string) result) - -> (int, string) result) - -> release_staging: - (scope:Logseq_sync_pure_reducer.Core.graph_scope - -> file:string - -> (unit, string) result) - -> submit_asset: - (context:Logseq_sync_pure_reducer.Core.asset_context - -> current:(Logseq_sync_pure_reducer.Asset_transfer.ticket -> bool) - -> post:(Logseq_sync_pure_reducer.Asset_transfer.event -> unit) - -> Logseq_sync_pure_reducer.Asset_transfer.instruction - -> unit) - -> delete_assets: - (Logseq_sync_pure_reducer.Core.mirror_deletion -> (unit, string) result) - -> close_assets:(Logseq_sync_pure_reducer.Core.graph_scope -> unit) - -> retain_staged_file: - (scope:Logseq_sync_pure_reducer.Core.graph_scope - -> file:string - -> (string * string) option) - -> retain_asset_file: - (scope:Logseq_sync_pure_reducer.Core.graph_scope - -> handle:string - -> (string * string) option) - -> release_asset_file: - (scope:Logseq_sync_pure_reducer.Core.graph_scope -> handle:string -> unit) - -> submit:(Logseq_sync_pure_reducer.Core.runner_effect -> unit) + : submit:(Logseq_sync_pure_reducer.Core.runner_effect -> unit) -> shutdown:(unit -> unit) -> unit -> sync_runner diff --git a/logseq_db_worker/spec/pure_reducer/core.mli b/logseq_db_worker/spec/pure_reducer/core.mli index 3c892b8..1011907 100644 --- a/logseq_db_worker/spec/pure_reducer/core.mli +++ b/logseq_db_worker/spec/pure_reducer/core.mli @@ -101,6 +101,8 @@ type upload_recovery_ticket = private } type instruction = + | Deliver_protected_result of Logseq_sync_pure_reducer.Core.protected_output + | Deliver_asset_result of Logseq_sync_pure_reducer.Core.asset_output | Read_uploads of upload_recovery_ticket | Run_upload of Logseq_sync_pure_reducer.Core.asset_context * Asset_upload.instruction | Run_asset of diff --git a/logseq_db_worker/test/test_effect_runner.ml b/logseq_db_worker/test/test_effect_runner.ml index ac7d32c..8e68a90 100644 --- a/logseq_db_worker/test/test_effect_runner.ml +++ b/logseq_db_worker/test/test_effect_runner.ml @@ -12,6 +12,63 @@ let account ?(generation = 1) user_id : Sync.account_scope = } ;; +module Sync_runner = Logseq_sync_effect_runner.Effect_runner + +let asset_io_runner ~env ~sw ~support ~post = + let module R = Sync_runner in + let dependencies = + R.dependencies + ~runtime: + (R.runtime ~fork:(fun ~sw:_ task -> task ()) ~sleep:(fun _ -> ()) |> Result.get_ok) + ~transport: + (R.transport + ~tls_authenticator:(R.system_tls_authenticator () |> Result.get_ok) + ~network:(Eio.Stdenv.net env) + ~clock:(Eio.Stdenv.clock env) + ~websocket_liveness:R.Disabled + |> Result.get_ok) + ~local_store: + (R.local_store + ~asset_cache_budget_bytes:16L + ~asset_maximum_file_bytes:16 + ~asset_pending_budget_bytes:16L + ~application_support_directory:support + () + |> Result.get_ok) + ~artifact_store: + (R.artifact_store ~staging_directory:(Filename.concat support "snapshot-staging") + |> Result.get_ok) + ~secrets: + (R.secrets + ~unlock_private_key: + (fun + ~managed_sync_origin:_ ~user_id:_ ~password:_ ~private_key_package:_ -> + Error "unused") + ~unlock_graph_key: + (fun + ~managed_sync_origin:_ ~user_id:_ ~encrypted_graph_key:_ -> Error "unused") + ~load_wrapped_graph_key:(fun ~managed_sync_origin:_ ~user_id:_ ~graph_id:_ -> + Error (R.Wrapped_graph_key_unavailable "unused")) + ~verify_and_save_wrapped_graph_key: + (fun + ~managed_sync_origin:_ ~user_id:_ ~graph_id:_ ~encrypted_graph_key:_ -> + Error "unused") + ~delete_account_secrets:(fun ~managed_sync_origin:_ ~user_id:_ -> Ok ()) + |> Result.get_ok) + ~crypto: + (R.crypto + ~encrypt_aes_gcm:(fun ~key:_ ~plaintext:_ -> Error "unused") + ~decrypt_aes_gcm:(fun ~key:_ ~iv:_ ~ciphertext:_ -> Error "unused") + |> Result.get_ok) + ~id_token_provider: + (R.id_token_provider + ~acquire:(fun _ -> Error "test must not use network") + ~invalidate:(fun _ ~token:_ -> ())) + |> Result.get_ok + in + R.create ~sw dependencies ~post |> Result.get_ok +;; + let far_future_token = "header.eyJleHAiOjIwMDAwMDAwMDB9.signature" let two_hour_token = "header.eyJleHAiOjE3MDAwMDcyMDB9.signature" let one_hour_token = "header.eyJleHAiOjE3MDAwMDM2MDB9.signature" @@ -339,18 +396,6 @@ let test_sync_and_publish_instructions_are_not_reduced_recursively () = in let sync_runner = Runner.sync_runner - ~stage_asset:(fun ~scope:_ ~operation:_ ~file_type:_ ~source_file:_ -> - Error "unexpected staging") - ~put_upload:(fun ~context:_ _ ~current:_ -> failwith "unexpected upload") - ~prune_staging:(fun ~scope:_ ~keep:_ -> Ok 0) - ~release_staging:(fun ~scope:_ ~file:_ -> Ok ()) - ~submit_asset:(fun ~context:_ ~current:_ ~post:_ _ -> - failwith "unexpected asset IO") - ~delete_assets:(fun _ -> Ok ()) - ~close_assets:(fun _ -> ()) - ~retain_staged_file:(fun ~scope:_ ~file:_ -> None) - ~retain_asset_file:(fun ~scope:_ ~handle:_ -> None) - ~release_asset_file:(fun ~scope:_ ~handle:_ -> ()) ~submit:(fun runner_effect -> submitted := runner_effect :: !submitted) ~shutdown:(fun () -> ()) () @@ -402,19 +447,492 @@ let test_sync_and_publish_instructions_are_not_reduced_recursively () = Runner.shutdown runner))) ;; +let admitted_asset_state graph_id = + let limits = + Sync.limits + ~maximum_response_bytes:1024 + ~maximum_artifact_bytes:1024 + ~submission_batch_size:1 + |> Result.get_ok + in + let initial = + Sync.config ~managed_sync_origin:(Uri.of_string "https://api.logseq.io") ~limits + |> Result.get_ok + |> Sync.initial + |> Result.get_ok + in + let graph : Sync.graph = + { graph_id + ; name = "Upload checkpoint fixture" + ; schema = { major = 1; minor = 0; exact = true } + ; encrypted = false + } + in + let authenticated = + Sync.step initial (Sync.Account_authenticated { user_id = Some "user-1" }) + in + let catalog = + List.find_map + (function + | Sync.Run (Sync.Request (ticket, Sync.Fetch_catalog _)) -> + Some + (Sync.step + authenticated.next + (Sync.Runner_completed (Sync.Completion (ticket, Ok [ graph ])))) + | _ -> None) + authenticated.effects + |> Option.get + in + let selected = Sync.step catalog.next (Sync.Graph_selected graph.graph_id) in + let mirror = + List.find_map + (function + | Sync.Delegate (Sync.Inspect_mirror request) -> Some request + | _ -> None) + selected.effects + |> Option.get + in + let admitted = + Sync.step selected.next (Sync.Mirror_inspected (Sync.Mirror_available mirror)) + in + let context = Sync.asset_context admitted.next |> Option.get in + admitted.next, context +;; + +type asset_bridge_fixture = + { runner : Runner.t + ; context : Sync.asset_context + ; support : string + ; gate : (Sync.asset_output -> bool) -> deliver_first:bool -> unit Eio.Promise.t + ; deliver_held : unit -> unit + ; held_path : string option ref + ; actions : Sync.asset_action list ref + ; fixture_asset : Sync.asset_action -> Sync.asset_value + } + +let with_asset_bridge run = + T.with_managed (fun fixture -> + Eio_main.run (fun env -> + Eio.Switch.run (fun sw -> + let graph_id = + Logseq_db_types.Graph_types.Uuid.of_string + "22000000-0000-4000-8000-000000000001" + |> Result.get_ok + in + let admitted, context = admitted_asset_state graph_id in + let state = ref admitted in + let active_runner = ref None in + let io_runner = ref None in + let actions = ref [] in + let output_handler = ref (fun (_ : Sync.asset_output) -> false) in + let held = Queue.create () in + let held_path = ref None in + let fixture_output = ref None in + let post = function + | Core.Sync_event event -> + (match event with + | Sync.Asset_requested request -> actions := request.action :: !actions + | _ -> ()); + let transition = Sync.step !state event in + state := transition.next; + List.iter + (function + | Sync.Run runner_effect -> + Sync_runner.submit (Option.get !io_runner) runner_effect + | Sync.Publish (Sync.Asset_finished output) -> + if String.starts_with ~prefix:"fixture:" output.request.operation + then fixture_output := Some output.result + else if not (!output_handler output) + then + Runner.submit + (Option.get !active_runner) + (Core.Deliver_asset_result output) + | Sync.Publish _ -> () + | Sync.Delegate _ -> Alcotest.fail "unexpected bridge graph effect") + transition.effects + | _ -> () + in + io_runner + := Some + (asset_io_runner + ~env + ~sw + ~support:fixture.config.application_support_directory + ~post:(fun event -> post (Core.Sync_event event))); + let sync_runner = + Runner.sync_runner + ~submit:(fun runnable -> Sync_runner.submit (Option.get !io_runner) runnable) + ~shutdown:(fun () -> Sync_runner.shutdown (Option.get !io_runner)) + () + in + let dependencies = + Runner.dependencies + ~runtime: + (Runner.runtime ~fork:(fun ~sw:_ task -> task ()) ~sleep:(fun _ -> ()) + |> Result.get_ok) + ~config:fixture.config + ~overlay:fixture.overlay + ~sync_runner + ~publish:(fun _ -> ()) + |> Result.get_ok + in + let runner = + Runner.create + ~sw + dependencies + ~post + ~recovery_current:(fun _ -> false) + ~upload_current:(fun _ -> false) + ~asset_current:(fun _ -> false) + |> Result.get_ok + in + active_runner := Some runner; + let serial = ref 0 in + let fixture_asset action = + incr serial; + fixture_output := None; + post + (Core.Sync_event + (Sync.Asset_requested + { scope = context.scope + ; operation = "fixture:" ^ string_of_int !serial + ; action + })); + Option.get !fixture_output |> Result.get_ok + in + let path_of_output (output : Sync.asset_output) = + match output.result with + | Ok (Sync.Asset_staged { file; _ }) -> + (match fixture_asset (Sync.Retain_staged_file file) with + | Sync.Asset_retained (Some (lease, path)) -> + ignore (fixture_asset (Sync.Release_asset_file lease)); + Some path + | _ -> Alcotest.fail "gated staged resource unavailable") + | Ok (Sync.Asset_retained (Some (_, path))) -> Some path + | _ -> None + in + let gate predicate ~deliver_first = + let reached, resolve = Eio.Promise.create () in + let never, _ = Eio.Promise.create () in + (output_handler + := fun output -> + if not (predicate output) + then false + else ( + held_path := path_of_output output; + Queue.add (output, deliver_first) held; + if deliver_first + then Runner.submit runner (Core.Deliver_asset_result output); + Eio.Promise.resolve resolve (); + if deliver_first then Eio.Promise.await never; + true)); + reached + in + let deliver_held () = + (output_handler := fun _ -> false); + Queue.iter + (fun (output, delivered) -> + if not delivered + then Runner.submit runner (Core.Deliver_asset_result output)) + held; + Queue.clear held + in + Fun.protect + ~finally:(fun () -> Runner.shutdown runner) + (fun () -> + run + { runner + ; context + ; support = fixture.config.application_support_directory + ; gate + ; deliver_held + ; held_path + ; actions + ; fixture_asset + })))) +;; + +let picker_import support ordinal : Logseq_db_types.Asset_import.t = + let uuid n = + Logseq_db_types.Graph_types.Uuid.of_string + (Printf.sprintf "33000000-0000-4000-8000-%012d" n) + |> Result.get_ok + in + let source_file = + Filename.concat support ("picker-" ^ string_of_int ordinal ^ ".bin") + in + Out_channel.with_open_bin source_file (fun output -> output_string output "file"); + { operation = uuid ordinal + ; asset = uuid (ordinal + 1) + ; target = uuid (ordinal + 2) + ; local_mutation = uuid (ordinal + 3) + ; metadata_mutation = uuid (ordinal + 4) + ; replace_reference = None + ; source_file + ; title = "Cancellation fixture" + ; file_type = "bin" + } +;; + +let cancelled_stage_output deliver_first () = + with_asset_bridge (fun fixture -> + let source = picker_import fixture.support 10 in + let reached = + fixture.gate + (fun output -> + match output.Sync.request.action with + | Sync.Stage_asset_file _ -> true + | _ -> false) + ~deliver_first + in + Eio.Fiber.first + (fun () -> + ignore + (Runner.prepare_import + fixture.runner + ~context:fixture.context + source + ~current:(fun () -> true)); + Alcotest.fail "gated import unexpectedly finished") + (fun () -> Eio.Promise.await reached); + let path = Option.get !(fixture.held_path) in + if not deliver_first + then + Alcotest.(check bool) + "queued accepted staging still exists" + true + (Sys.file_exists path); + fixture.deliver_held (); + Alcotest.(check bool) + "canceled caller releases accepted staging" + false + (Sys.file_exists path); + Alcotest.(check bool) + "staging cleanup requested through reducer" + true + (List.exists + (function + | Sync.Release_staged_file _ -> true + | _ -> false) + !(fixture.actions)); + let db = + Sqlite3.db_open (Filename.concat fixture.support "asset-upload-intents.sqlite") + in + let durable = + Logseq_db_storage.Asset_upload_store.read db ~operation:source.operation + |> Result.get_ok + in + ignore (Sqlite3.db_close db); + Alcotest.(check bool) + "cancel before staging acceptance persists no import" + true + (durable = None)) +;; + +let test_cancelled_retained_output () = + with_asset_bridge (fun fixture -> + let source = picker_import fixture.support 20 in + let prepared = + Runner.prepare_import + fixture.runner + ~context:fixture.context + source + ~current:(fun () -> true) + |> Result.get_ok + in + let reached = + fixture.gate + (fun output -> + match output.Sync.request.action with + | Sync.Retain_staged_file _ -> true + | _ -> false) + ~deliver_first:false + in + Eio.Fiber.first + (fun () -> + ignore + (Runner.retain_imported_file + fixture.runner + ~scope:fixture.context.scope + ~operation:source.operation); + Alcotest.fail "gated lease acquisition unexpectedly finished") + (fun () -> Eio.Promise.await reached); + let path = Option.get !(fixture.held_path) in + fixture.deliver_held (); + Alcotest.(check bool) + "canceled lease acquisition requests release" + true + (List.exists + (function + | Sync.Release_asset_file _ -> true + | _ -> false) + !(fixture.actions)); + ignore (fixture.fixture_asset (Sync.Release_staged_file prepared.staged_file)); + Alcotest.(check bool) + "released lease no longer pins staged bytes" + false + (Sys.file_exists path)) +;; + +let test_db_shutdown_accepts_late_staging_completion () = + let module Db = Logseq_db_worker in + T.with_managed (fun fixture -> + Eio_main.run (fun env -> + Eio.Switch.run (fun sw -> + let support = fixture.config.application_support_directory in + let source = picker_import support 40 in + let graph : Sync.graph = + { graph_id = source.target + ; name = "Shutdown fixture" + ; schema = { major = 65; minor = 33; exact = true } + ; encrypted = false + } + in + let db = ref None in + let io_runner = ref None in + let catalog_ready, catalog_resolve = Eio.Promise.create () in + let scope_ready, scope_resolve = Eio.Promise.create () in + let stage_ready, stage_resolve = Eio.Promise.create () in + let path_ready, path_resolve = Eio.Promise.create () in + let stage_completion = ref None in + let cleanup_actions = ref [] in + let post event = + match event with + | Sync.Runner_completed (Sync.Asset_completion (_, Ok (Sync.Asset_staged _))) -> + stage_completion := Some event; + Eio.Promise.resolve stage_resolve () + | Sync.Runner_completed + (Sync.Asset_completion (_, Ok (Sync.Asset_retained (Some (_, path))))) -> + Eio.Promise.resolve path_resolve path; + Db.post (Option.get !db) (Core.Sync_event event) + | event -> Db.post (Option.get !db) (Core.Sync_event event) + in + io_runner := Some (asset_io_runner ~env ~sw ~support ~post); + let sync_runner = + Runner.sync_runner + ~submit:(function + | Sync.Request (ticket, Sync.Fetch_catalog _) -> + Db.post + (Option.get !db) + (Core.Sync_event + (Sync.Runner_completed (Sync.Completion (ticket, Ok [ graph ])))); + Eio.Promise.resolve catalog_resolve () + | Sync.Request (_, Sync.Fetch_snapshot_baseline scope) -> + Eio.Promise.resolve scope_resolve scope + | Sync.Request (_, Sync.Fetch_snapshot_metadata _) + | Sync.Request (_, Sync.Download_snapshot _) -> () + | Sync.Asset_io (_, request) as runnable -> + (match request.action with + | Sync.Release_staged_file _ -> + cleanup_actions := request.action :: !cleanup_actions + | _ -> ()); + Sync_runner.submit (Option.get !io_runner) runnable + | runnable -> Sync_runner.submit (Option.get !io_runner) runnable) + ~shutdown:(fun () -> Sync_runner.shutdown (Option.get !io_runner)) + () + in + let runner_dependencies = + Runner.dependencies + ~runtime: + (Runner.runtime ~fork:(fun ~sw:_ task -> task ()) ~sleep:(fun _ -> ()) + |> Result.get_ok) + ~config:fixture.config + ~overlay:fixture.overlay + ~sync_runner + ~publish:(fun _ -> ()) + |> Result.get_ok + in + let limits = + Sync.limits + ~maximum_response_bytes:1024 + ~maximum_artifact_bytes:1024 + ~submission_batch_size:1 + |> Result.get_ok + in + let sync = + Sync.config ~managed_sync_origin:(Uri.of_string "https://api.logseq.io") ~limits + |> Result.get_ok + in + let worker = + Db.create + ~sw + ~config:(Core.config ~worker:fixture.config ~sync) + ~runner_dependencies + |> Result.get_ok + in + db := Some worker; + Fun.protect + ~finally:(fun () -> Db.shutdown worker) + (fun () -> + Db.post + worker + (Core.Sync_event (Sync.Account_authenticated { user_id = Some "user-1" })); + Eio.Promise.await catalog_ready; + Db.post worker (Core.Sync_event (Sync.Graph_selected graph.graph_id)); + let scope = Eio.Promise.await scope_ready in + Db.post + worker + (Core.Sync_event + (Sync.Asset_requested + { scope + ; operation = "db-shutdown:stage" + ; action = + Sync.Stage_asset_file + { operation = source.operation + ; file_type = source.file_type + ; source_file = source.source_file + } + })); + Eio.Promise.await stage_ready; + let file = + match Option.get !stage_completion with + | Sync.Runner_completed + (Sync.Asset_completion (_, Ok (Sync.Asset_staged { file; _ }))) -> file + | _ -> Alcotest.fail "missing real staging completion" + in + Db.post + worker + (Core.Sync_event + (Sync.Asset_requested + { scope + ; operation = "db-shutdown:path" + ; action = Sync.Retain_staged_file file + })); + let path = Eio.Promise.await path_ready in + Alcotest.(check bool) + "actual runner staged file before shutdown" + true + (Sys.file_exists path); + Db.shutdown worker; + Alcotest.(check bool) "actual worker stopped" true (Db.view worker).shutdown; + Db.post worker (Core.Sync_event (Option.get !stage_completion)); + Alcotest.(check bool) + "late resource completion reaches cleanup submit" + true + (List.exists + (function + | Sync.Release_staged_file released -> released = file + | _ -> false) + !cleanup_actions); + Alcotest.(check bool) + "late completion leaves no staged orphan" + false + (Sys.file_exists path); + Eio.Fiber.yield ())))) +;; + let test_upload_checkpoint_io () = let module U = Logseq_db_worker_pure_reducer.Asset_upload in let module I = Logseq_db_types.Asset_upload_intent in - let module Cache = Logseq_sync_effect_runner.Asset_cache in let module Store = Logseq_db_storage.Asset_upload_store in let uuid n = Logseq_db_types.Graph_types.Uuid.of_string (Printf.sprintf "00000000-0000-4000-8000-%012d" n) |> Result.get_ok in - let scope : Sync.graph_scope = - { account = account "user-1"; graph_id = uuid 1; graph_generation = 1 } - in + let admitted, context = admitted_asset_state (uuid 1) in + let sync_state = ref admitted in + let scope = context.Sync.scope in let intent = I.prepare ~replace_reference:None @@ -439,31 +957,12 @@ let test_upload_checkpoint_io () = let state, instructions = U.step (U.create ~scope ~available:true) (Start intent) in let instruction = List.hd instructions in T.with_managed (fun fixture -> - Eio_main.run (fun _ -> + Eio_main.run (fun env -> Eio.Switch.run (fun sw -> - let create_cache () = - Cache.create - ~root:fixture.config.application_support_directory - ~scope - ~budget_bytes:16L - ~maximum_file_bytes:16 - |> Result.get_ok - in - let cache = ref (create_cache ()) in let source_file = Filename.concat fixture.config.application_support_directory "picker.bin" in Out_channel.with_open_bin source_file (fun output -> output_string output "file"); - let orphan = - Cache.stage - !cache - ~operation:(uuid 88) - ~file_type:"bin" - ~source_file - ~pending_budget_bytes:16L - |> Result.get_ok - in - let orphan_path = Option.get (Cache.staged_path !cache ~file:orphan.file) in let published = ref [] in let posted = ref [] in let current = ref true in @@ -474,43 +973,56 @@ let test_upload_checkpoint_io () = |> Result.get_ok in let stage_calls = ref 0 in + let active_runner = ref None in + let bridge_requests = ref 0 in + let bridge_outputs = ref 0 in + let io_runner = ref None in + let fixture_output = ref None in + let submit_sync = ref (fun _ -> failwith "sync interpreter not initialized") in + let post = function + | Core.Sync_event event -> + (match event with + | Sync.Asset_requested _ -> incr bridge_requests + | _ -> ()); + let transition = Sync.step !sync_state event in + sync_state := transition.next; + List.iter + (function + | Sync.Run runner_effect -> !submit_sync runner_effect + | Sync.Publish (Sync.Asset_finished output) -> + incr bridge_outputs; + if String.starts_with ~prefix:"fixture:" output.request.operation + then fixture_output := Some output.result + else + Runner.submit + (Option.get !active_runner) + (Core.Deliver_asset_result output) + | Sync.Publish _ -> () + | Sync.Delegate _ -> Alcotest.fail "unexpected graph work in asset bridge") + transition.effects + | event -> posted := event :: !posted + in + io_runner + := Some + (asset_io_runner + ~env + ~sw + ~support:fixture.config.application_support_directory + ~post:(fun event -> post (Core.Sync_event event))); let sync_runner = Runner.sync_runner - ~stage_asset:(fun ~scope:_ ~operation ~file_type ~source_file -> - incr stage_calls; - Cache.stage - !cache - ~operation - ~file_type - ~source_file - ~pending_budget_bytes:16L - |> Result.map (fun staged -> - staged.Cache.file, staged.checksum, staged.size) - |> Result.map_error (fun _ -> "stage failed")) - ~put_upload:(fun ~context:_ _ ~current:_ -> failwith "unexpected PUT") - ~prune_staging:(fun ~scope:_ ~keep -> - Cache.prune_staged !cache ~keep - |> Result.map_error (fun _ -> "prune failed")) - ~release_staging:(fun ~scope:release_scope ~file -> - Alcotest.(check bool) - "release uses the original scope" - true - (release_scope = scope); - Cache.release_staged !cache ~file - |> Result.map_error (fun _ -> "cache unavailable")) - ~submit_asset:(fun ~context:_ ~current:_ ~post:_ _ -> - failwith "unexpected GET") - ~delete_assets:(fun _ -> Ok ()) - ~close_assets:(fun _ -> ()) - ~retain_staged_file:(fun ~scope:_ ~file -> - Option.bind (Cache.retain_staged !cache ~file) (fun lease -> - Option.map (fun path -> lease, path) (Cache.path !cache lease))) - ~retain_asset_file:(fun ~scope:_ ~handle:_ -> None) - ~release_asset_file:(fun ~scope:_ ~handle -> Cache.release !cache handle) - ~submit:(fun _ -> ()) - ~shutdown:(fun () -> ()) + ~submit:(fun runner_effect -> + (match runner_effect with + | Sync.Asset_io (_, { action = Sync.Stage_asset_file _; _ }) -> + incr stage_calls + | _ -> ()); + Sync_runner.submit (Option.get !io_runner) runner_effect) + ~shutdown:(fun () -> Sync_runner.shutdown (Option.get !io_runner)) () in + (submit_sync + := fun runner_effect -> + Runner.submit (Option.get !active_runner) (Core.Run_sync runner_effect)); let dependencies = Runner.dependencies ~runtime @@ -524,12 +1036,44 @@ let test_upload_checkpoint_io () = Runner.create ~sw dependencies - ~post:(fun event -> posted := event :: !posted) + ~post ~recovery_current:(fun _ -> false) ~upload_current:(fun ticket -> !current && U.ticket_current state ticket) ~asset_current:(fun _ -> false) |> Result.get_ok in + active_runner := Some runner; + let fixture_serial = ref 0 in + let fixture_asset action = + incr fixture_serial; + fixture_output := None; + post + (Core.Sync_event + (Sync.Asset_requested + { scope + ; operation = "fixture:" ^ string_of_int !fixture_serial + ; action + })); + Option.get !fixture_output |> Result.get_ok + in + let staged_path file = + match fixture_asset (Sync.Retain_staged_file file) with + | Sync.Asset_retained (Some (lease, path)) -> + ignore (fixture_asset (Sync.Release_asset_file lease)); + path + | _ -> Alcotest.fail "staged resource unavailable" + in + let orphan_file = + match + fixture_asset + (Sync.Stage_asset_file + { operation = uuid 88; file_type = "bin"; source_file }) + with + | Sync.Asset_staged { file; _ } -> file + | _ -> Alcotest.fail "orphan staging failed" + in + let orphan_path = staged_path orphan_file in + stage_calls := 0; Runner.submit runner (Core.Run_upload ({ scope; encrypted = false; key = None }, instruction)); @@ -572,7 +1116,6 @@ let test_upload_checkpoint_io () = ; file_type = "png" } in - let context : Sync.asset_context = { scope; encrypted = false; key = None } in Alcotest.(check bool) "stale import does not stage" true @@ -654,9 +1197,7 @@ let test_upload_checkpoint_io () = ~context { source with asset = uuid 99 } ~current:(fun () -> true))); - let source_path = - Option.get (Cache.staged_path !cache ~file:prepared.staged_file) - in + let source_path = staged_path prepared.staged_file in Sys.remove source_file; let checkpoint_path = Filename.concat @@ -701,32 +1242,44 @@ let test_upload_checkpoint_io () = | [ (U.Release_staging _ as instruction) ] -> instruction | _ -> Alcotest.fail "terminal recovery attempted non-cleanup work" in - Cache.close !cache; - Runner.submit runner (Core.Run_upload (context, restore_terminal ())); - Alcotest.(check bool) - "unavailable cache retains pending source" - true - (Sys.file_exists source_path); - Alcotest.(check bool) - "failed cleanup is observable" - true - (List.exists - (function - | Core.Diagnostic "cache unavailable" -> true - | _ -> false) - !published); - Runner.shutdown runner; - cache := create_cache (); + let staging_directory = Filename.dirname source_path in + Unix.chmod staging_directory 0o500; + Fun.protect + ~finally:(fun () -> Unix.chmod staging_directory 0o700) + (fun () -> + Runner.submit runner (Core.Run_upload (context, restore_terminal ())); + Alcotest.(check bool) + "unavailable cache retains pending source" + true + (Sys.file_exists source_path); + Alcotest.(check bool) + "failed cleanup is observable" + true + (List.exists + (function + | Core.Diagnostic _ -> true + | _ -> false) + !published); + Runner.shutdown runner); + sync_state := admitted; + io_runner + := Some + (asset_io_runner + ~env + ~sw + ~support:fixture.config.application_support_directory + ~post:(fun event -> post (Core.Sync_event event))); let restarted = Runner.create ~sw dependencies - ~post:(fun event -> posted := event :: !posted) + ~post ~recovery_current:(fun _ -> false) ~upload_current:(fun _ -> false) ~asset_current:(fun _ -> false) |> Result.get_ok in + active_runner := Some restarted; let restored_import = Runner.prepare_import restarted ~context source ~current:(fun () -> true) |> Result.get_ok @@ -744,8 +1297,12 @@ let test_upload_checkpoint_io () = published := []; Runner.submit restarted (Core.Run_upload (context, restore_terminal ())); Alcotest.(check int) "repeated cleanup is idempotent" 0 (List.length !published); - Runner.shutdown restarted; - Cache.close !cache))) + Alcotest.(check int) + "every asset request returns through reducer output" + !bridge_requests + !bridge_outputs; + Alcotest.(check bool) "asset bridge exercised" true (!bridge_requests > 0); + Runner.shutdown restarted))) ;; let () = @@ -795,6 +1352,22 @@ let () = ] ) ; ( "contract" , [ Alcotest.test_case + "cancel queued staging output" + `Quick + (cancelled_stage_output false) + ; Alcotest.test_case + "cancel resolved staging output" + `Quick + (cancelled_stage_output true) + ; Alcotest.test_case + "cancel queued retained lease output" + `Quick + test_cancelled_retained_output + ; Alcotest.test_case + "actual Db shutdown late staging completion" + `Quick + test_db_shutdown_accepts_late_staging_completion + ; Alcotest.test_case "durable upload checkpoint IO" `Quick test_upload_checkpoint_io diff --git a/logseq_db_worker/test/test_pure_reducer.ml b/logseq_db_worker/test/test_pure_reducer.ml index e4905e7..8684fcd 100644 --- a/logseq_db_worker/test/test_pure_reducer.ml +++ b/logseq_db_worker/test/test_pure_reducer.ml @@ -66,6 +66,8 @@ let test_closed_graph_request_replies_once () = | Run_upload _ | Read_uploads _ | Close_asset_scope _ + | Deliver_asset_result _ + | Deliver_protected_result _ | Publish _ -> false) transition.effects in @@ -442,6 +444,121 @@ let test_asset_failure_is_independent () = Alcotest.(check int) "foreign demand rejected" 0 (List.length stale.effects) ;; +let test_asset_execution_completion_is_delivered () = + let state, scope = worker_open_graph () in + let request : Sync.asset_request = + { scope + ; operation = "worker-bridge:stage" + ; action = + Sync.Stage_asset_file + { operation = uuid "77000000-0000-4000-8000-000000000001" + ; file_type = "png" + ; source_file = "picker-reference" + } + } + in + let requested = Core.step state (Core.Sync_event (Sync.Asset_requested request)) in + let ticket = + List.find_map + (function + | Core.Run_sync (Sync.Asset_io (ticket, io)) -> + Alcotest.(check bool) + "worker preserves asset request" + true + (io.context.scope = request.scope && io.action = request.action); + Some ticket + | _ -> None) + requested.effects + |> Option.get + in + Alcotest.(check bool) + "request does not resolve its own waiter" + false + (List.exists + (function + | Core.Deliver_asset_result _ -> true + | _ -> false) + requested.effects); + let result = + Ok + (Sync.Asset_staged { file = "staging-reference"; checksum = "checksum"; size = 4L }) + in + let completed = + Core.step + requested.next + (Core.Sync_event (Sync.Runner_completed (Sync.Asset_completion (ticket, result)))) + in + Alcotest.(check bool) + "accepted completion resolves worker waiter" + true + (match completed.effects with + | [ Core.Deliver_asset_result output ] -> + output.request = request && output.result = result + | _ -> false) +;; + +let test_worker_shutdown_forwards_late_resource_cleanup () = + let state, scope = worker_open_graph () in + let request : Sync.asset_request = + { scope + ; operation = "worker-shutdown:stage" + ; action = + Sync.Stage_asset_file + { operation = uuid "77000000-0000-4000-8000-000000000007" + ; file_type = "bin" + ; source_file = "picker-reference" + } + } + in + let requested = Core.step state (Core.Sync_event (Sync.Asset_requested request)) in + let ticket = + List.find_map + (function + | Core.Run_sync (Sync.Asset_io (ticket, _)) -> Some ticket + | _ -> None) + requested.effects + |> Option.get + in + let stopped = Core.step requested.next Core.Shutdown in + Alcotest.(check bool) + "worker shutdown cancels pending requester" + true + (List.exists + (function + | Core.Deliver_asset_result output -> + output.request = request && output.result = Error Sync.Asset_cancelled + | _ -> false) + stopped.effects); + let late = + Core.step + stopped.next + (Core.Sync_event + (Sync.Runner_completed + (Sync.Asset_completion + ( ticket + , Ok + (Sync.Asset_staged + { file = "late-staging-reference" + ; checksum = "checksum" + ; size = 4L + }) )))) + in + Alcotest.(check bool) + "stopped worker keeps accepting cleanup completions" + true + (Core.view late.next).shutdown; + Alcotest.(check bool) + "late resource cleanup is forwarded to sync runner" + true + (List.exists + (function + | Core.Run_sync (Sync.Asset_io (_, io)) -> + io.context.scope = scope + && io.action = Sync.Release_staged_file "late-staging-reference" + | _ -> false) + late.effects) +;; + let test_upload_session () = let module U = Logseq_db_worker_pure_reducer.Asset_upload in let state, scope = worker_open_graph () in @@ -744,6 +861,14 @@ let () = test_upload_recovery_invalid_page ; Alcotest.test_case "upload recovery failure" `Quick test_upload_recovery_failure ; Alcotest.test_case "durable upload session" `Quick test_upload_session + ; Alcotest.test_case + "asset execution completion delivery" + `Quick + test_asset_execution_completion_is_delivered + ; Alcotest.test_case + "worker shutdown late resource forwarding" + `Quick + test_worker_shutdown_forwards_late_resource_cleanup ; Alcotest.test_case "demand lifecycle" `Quick test_asset_demand_lifecycle ; Alcotest.test_case "independent failure" diff --git a/logseq_sync/lib/effect_runner/effect_runner.ml b/logseq_sync/lib/effect_runner/effect_runner.ml index 552897d..f0e6617 100644 --- a/logseq_sync/lib/effect_runner/effect_runner.ml +++ b/logseq_sync/lib/effect_runner/effect_runner.ml @@ -1,5 +1,6 @@ module Core = Logseq_sync_pure_reducer.Core module Sync_protocol = Logseq_sync_pure_reducer.Sync_protocol +module Asset_cache = Bootstrap.Asset_cache type dependency_error = Invalid_dependency of string type create_error = Invalid_create of string @@ -139,15 +140,40 @@ let transport ~tls_authenticator ~network ~clock ~websocket_liveness = } ;; -type local_store = { application_support_directory : string } +type local_store = + { application_support_directory : string + ; asset_cache_budget_bytes : int64 + ; asset_maximum_file_bytes : int + ; asset_pending_budget_bytes : int64 + } let existing_directory path = String.length path > 0 && Sys.file_exists path && (Unix.stat path).st_kind = Unix.S_DIR ;; -let local_store ~application_support_directory = - if existing_directory application_support_directory - then Ok { application_support_directory } +let local_store + ?(asset_cache_budget_bytes = 268435456L) + ?(asset_maximum_file_bytes = 8 * 1024 * 1024) + ?(asset_pending_budget_bytes = 268435456L) + ~application_support_directory + () + = + if + asset_cache_budget_bytes <= 0L + || asset_cache_budget_bytes > 268435456L + || asset_maximum_file_bytes <= 0 + || asset_maximum_file_bytes > 8 * 1024 * 1024 + || asset_pending_budget_bytes <= 0L + || asset_pending_budget_bytes > 268435456L + then Error (Invalid_dependency "Asset storage limits exceed the supported bounds") + else if existing_directory application_support_directory + then + Ok + { application_support_directory + ; asset_cache_budget_bytes + ; asset_maximum_file_bytes + ; asset_pending_budget_bytes + } else Error (Invalid_dependency "application support directory does not exist") ;; @@ -268,6 +294,7 @@ let dependencies type operation = { scope : Core.effect_scope + ; asset_identity : (Core.graph_scope * string) option ; mutable cancelled : bool ; cancel : unit -> unit } @@ -290,12 +317,14 @@ type t = ; dependencies : dependencies ; post : Core.event -> unit ; operations : (string, operation) Hashtbl.t + ; submitted_operations : (string, unit) Hashtbl.t ; keys : (string, key_entry) Hashtbl.t ; websockets : (string, Core.connection_scope * Websocket_eio.t) Hashtbl.t ; asset_download_slots : Eio.Semaphore.t ; asset_upload_slots : Eio.Semaphore.t ; asset_codec_slot : Eio.Semaphore.t ; asset_byte_budget : Eio.Semaphore.t + ; asset_byte_reservation_lock : Eio.Semaphore.t ; secret_lock : Eio.Mutex.t ; asset_caches : (Core.graph_scope, Asset_cache.t) Hashtbl.t ; mutable closed : bool @@ -307,12 +336,14 @@ let create ~sw dependencies ~post = ; dependencies ; post ; operations = Hashtbl.create 32 + ; submitted_operations = Hashtbl.create 32 ; keys = Hashtbl.create 8 ; websockets = Hashtbl.create 4 ; asset_download_slots = Eio.Semaphore.make 3 ; asset_upload_slots = Eio.Semaphore.make 1 ; asset_codec_slot = Eio.Semaphore.make 1 ; asset_byte_budget = Eio.Semaphore.make asset_byte_budget_units + ; asset_byte_reservation_lock = Eio.Semaphore.make 1 ; secret_lock = Eio.Mutex.create () ; asset_caches = Hashtbl.create 4 ; closed = false @@ -325,7 +356,18 @@ let asset_root t = "logseq-db-worker/assets" ;; -let delete_account_assets t (account : Core.account_scope) = +let delete_account_assets ?except_id t (account : Core.account_scope) = + Hashtbl.iter + (fun id (operation : operation) -> + match operation.asset_identity with + | Some (scope, _) + when Some id <> except_id + && Uri.equal scope.account.managed_sync_origin account.managed_sync_origin + && String.equal scope.account.user_id account.user_id -> + operation.cancelled <- true; + operation.cancel () + | Some _ | None -> ()) + t.operations; Hashtbl.filter_map_inplace (fun (scope : Core.graph_scope) cache -> if @@ -753,7 +795,11 @@ let cancel_scope t scope = retire_websockets t (fun connection -> - scope_matches scope (Core.runner_effect_scope (Core.Close_websocket connection))) + scope_matches + scope + { (Core.effect_scope_of_graph connection.Core.graph) with + connection_generation = Some connection.connection_generation + }) t.dependencies.transport.abort_websocket ;; @@ -765,6 +811,7 @@ let submit_request : type a. t -> a Core.effect_ticket -> a Core.runner_request let cancelled, resolve_cancelled = Eio.Promise.create () in let operation = { scope = Core.effect_ticket_scope ticket + ; asset_identity = None ; cancelled = false ; cancel = (fun () -> ignore (Eio.Promise.try_resolve resolve_cancelled () : bool)) } @@ -791,10 +838,12 @@ let submit_request : type a. t -> a Core.effect_ticket -> a Core.runner_request | Some _ | None -> ()) ;; -let submit t instruction = +let submit_nonasset t instruction = if not t.closed then ( match instruction with + | Core.Asset_io _ | Core.Protected_io _ -> + invalid_arg "Effect requires its dedicated interpreter" | Core.Request (ticket, request) -> submit_request t ticket request | Cancel_effects scope -> cancel_scope t scope | Schedule_timer request -> @@ -802,6 +851,7 @@ let submit t instruction = let cancelled, resolve_cancelled = Eio.Promise.create () in let operation = { scope = request.scope + ; asset_identity = None ; cancelled = false ; cancel = (fun () -> ignore (Eio.Promise.try_resolve resolve_cancelled () : bool)) @@ -825,6 +875,7 @@ let submit t instruction = let cancelled, resolve_cancelled = Eio.Promise.create () in let operation = { scope = Core.runner_effect_scope instruction + ; asset_identity = None ; cancelled = false ; cancel = (fun () -> ignore (Eio.Promise.try_resolve resolve_cancelled () : bool)) @@ -957,25 +1008,23 @@ type asset_encryption = | Plaintext | Encrypted of Core.graph_key_handle option -module Asset_transfer = Logseq_sync_pure_reducer.Asset_transfer - let asset_cache_failure = function - | Asset_cache.Full -> Asset_transfer.Storage_full - | Checksum_mismatch -> Asset_transfer.Checksum_mismatch - | Stale -> Asset_transfer.Invalid_content "Asset scope is no longer current" - | Invalid message | Io message -> Asset_transfer.Invalid_content message + | Asset_cache.Full -> Core.Asset_storage_full + | Checksum_mismatch -> Core.Asset_checksum_mismatch + | Stale -> Core.Asset_invalid_content "Asset scope is no longer current" + | Invalid message | Io message -> Core.Asset_invalid_content message ;; let asset_graph_key t scope = function | Plaintext -> Ok None - | Encrypted None -> Error Asset_transfer.Locked + | Encrypted None -> Error Core.Asset_locked | Encrypted (Some handle) -> if Core.graph_key_handle_scope handle <> scope - then Error Asset_transfer.Locked + then Error Core.Asset_locked else key t handle |> Result.map Option.some - |> Result.map_error (fun _ -> Asset_transfer.Locked) + |> Result.map_error (fun _ -> Core.Asset_locked) ;; let with_asset_slot slots work = @@ -990,20 +1039,23 @@ let asset_wire_bytes ~maximum_plaintext_bytes encrypted = ;; let with_byte_reservation t bytes work = - let units = - min - asset_byte_budget_units - ((max bytes 0 + asset_byte_unit - 1) / asset_byte_unit) - in - for _ = 1 to units do - Eio.Semaphore.acquire t.asset_byte_budget - done; - Fun.protect - ~finally:(fun () -> - for _ = 1 to units do - Eio.Semaphore.release t.asset_byte_budget - done) - work + let units = (max bytes 0 + asset_byte_unit - 1) / asset_byte_unit in + if units > asset_byte_budget_units + then Error Core.Asset_size_rejected + else ( + let acquired = ref 0 in + Fun.protect + ~finally:(fun () -> + for _ = 1 to !acquired do + Eio.Semaphore.release t.asset_byte_budget + done) + (fun () -> + with_asset_slot t.asset_byte_reservation_lock (fun () -> + for _ = 1 to units do + Eio.Semaphore.acquire t.asset_byte_budget; + incr acquired + done); + work ())) ;; let fetch_asset_admitted @@ -1012,34 +1064,36 @@ let fetch_asset_admitted ~encryption ~maximum_plaintext_bytes ~current - (ticket : Asset_transfer.ticket) + ~(scope : Core.graph_scope) + ~asset + ~(version : Logseq_db_types.Asset_descriptor.version) = let ( let* ) = Result.bind in if maximum_plaintext_bytes < 0 || maximum_plaintext_bytes > 100 * 1024 * 1024 - then Error (Asset_transfer.Invalid_content "Invalid asset size limit") + then Error (Core.Asset_invalid_content "Invalid asset size limit") else - let* graph_key = asset_graph_key t ticket.scope encryption in - let base_url = ticket.scope.account.managed_sync_origin in + let* graph_key = asset_graph_key t scope encryption in + let base_url = scope.account.managed_sync_origin in let* () = Http.validate_base_url base_url - |> Result.map_error (fun message -> Asset_transfer.Invalid_content message) + |> Result.map_error (fun message -> Core.Asset_invalid_content message) in let path = Printf.sprintf "/assets/%s/%s.%s" - (Graph_types.Uuid.to_string ticket.scope.graph_id) - (Graph_types.Uuid.to_string ticket.asset) - ticket.version.file_type + (Graph_types.Uuid.to_string scope.graph_id) + (Graph_types.Uuid.to_string asset) + version.file_type in let uri = Uri.with_path base_url path in let maximum_response_bytes = asset_wire_bytes ~maximum_plaintext_bytes (Option.is_some graph_key) in - let last_failure = ref Asset_transfer.Authentication in + let last_failure = ref Core.Asset_authentication in let* response = authenticated_operation t.dependencies.id_token_provider - ~account:ticket.scope.account + ~account:scope.account ~perform:(fun token -> let request : Http.request = { operation = Get @@ -1051,13 +1105,13 @@ let fetch_asset_admitted in match t.dependencies.transport.perform_http ~sw:t.sw request with | Error message -> - last_failure := Asset_transfer.Network; + last_failure := Core.Asset_network; Error (Request_failed message) | Ok response when response.status = 401 -> - last_failure := Asset_transfer.Authentication; + last_failure := Core.Asset_authentication; Error Unauthorized | Ok response when response.status = 403 -> - last_failure := Asset_transfer.Invalid_content "Asset access revoked"; + last_failure := Core.Asset_revoked_access; Error Forbidden | Ok response -> Ok response) |> Result.map_error (fun _ -> !last_failure) @@ -1065,18 +1119,17 @@ let fetch_asset_admitted let* () = match response.status with | status when status >= 200 && status < 300 -> Ok () - | 404 -> Error Asset_transfer.Not_found - | 408 | 429 | 500 | 502 | 503 | 504 -> Error Asset_transfer.Network + | 404 -> Error Core.Asset_not_found + | 408 | 429 | 500 | 502 | 503 | 504 -> Error Core.Asset_network | status -> - Error - (Asset_transfer.Invalid_content (Printf.sprintf "Asset HTTP status %d" status)) + Error (Core.Asset_invalid_content (Printf.sprintf "Asset HTTP status %d" status)) in - if t.closed || not (current ticket) - then Error (Asset_transfer.Invalid_content "Asset request expired") + if t.closed || not (current ()) + then Error Core.Asset_cancelled else with_asset_slot t.asset_codec_slot (fun () -> - if t.closed || not (current ticket) - then Error (Asset_transfer.Invalid_content "Asset request expired") + if t.closed || not (current ()) + then Error Core.Asset_cancelled else ( let crypto : Asset_codec.crypto = { encrypt = t.dependencies.crypto.encrypt_aes_gcm @@ -1088,35 +1141,43 @@ let fetch_asset_admitted ~maximum_plaintext_bytes ~crypto ~key:graph_key - ~expected_checksum:ticket.version.checksum + ~expected_checksum:version.checksum response.body |> Result.map_error (fun message -> if message = "Asset checksum mismatch" - then Asset_transfer.Checksum_mismatch - else Asset_transfer.Invalid_content message) + then Core.Asset_checksum_mismatch + else Core.Asset_invalid_content message) in Asset_cache.publish cache - ~asset:ticket.asset - ~version:ticket.version - ~current:(fun () -> (not t.closed) && current ticket) + ~asset + ~version + ~current:(fun () -> (not t.closed) && current ()) ~plaintext |> Result.map_error asset_cache_failure)) ;; -let fetch_asset t ~cache ~encryption ~maximum_plaintext_bytes ~current ticket = +let fetch_asset + t + ~cache + ~encryption + ~maximum_plaintext_bytes + ~current + ~scope + ~asset + ~version + = with_asset_slot t.asset_download_slots (fun () -> - if t.closed || not (current ticket) - then Error (Asset_transfer.Invalid_content "Asset request expired") - else + if t.closed || not (current ()) + then Error Core.Asset_cancelled + else ( let encrypted = match encryption with | Plaintext -> false | Encrypted _ -> true in let reservation = - asset_wire_bytes ~maximum_plaintext_bytes encrypted - + maximum_plaintext_bytes + asset_wire_bytes ~maximum_plaintext_bytes encrypted + maximum_plaintext_bytes in with_byte_reservation t reservation (fun () -> fetch_asset_admitted @@ -1125,119 +1186,21 @@ let fetch_asset t ~cache ~encryption ~maximum_plaintext_bytes ~current ticket = ~encryption ~maximum_plaintext_bytes ~current - ticket)) -;; - -let asset_operation_id (scope : Core.graph_scope) suffix = - Printf.sprintf - "asset:%d:%d:%Ld:%s:%s" - scope.Core.account.account_generation - scope.graph_generation - scope.account.lifecycle_generation - (Graph_types.Uuid.to_string scope.graph_id) - suffix + ~scope + ~asset + ~version))) ;; -let submit_asset - t - ~scope - ~cache - ~encryption - ~maximum_plaintext_bytes - ~current - ~post - instruction - = - let fork ~id work deliver = - if (not t.closed) && not (Hashtbl.mem t.operations id) - then ( - let cancelled, resolve = Eio.Promise.create () in - let operation = - { scope = Core.effect_scope_of_graph scope - ; cancelled = false - ; cancel = (fun () -> ignore (Eio.Promise.try_resolve resolve () : bool)) - } - in - Hashtbl.add t.operations id operation; - t.dependencies.runtime.fork ~sw:t.sw (fun () -> - Fun.protect - ~finally:(fun () -> Hashtbl.remove t.operations id) - (fun () -> - let result = - try - Some - (Eio.Fiber.first - (fun () -> - if operation.cancelled || t.closed then raise Runner_cancelled; - work ()) - (fun () -> - Eio.Promise.await cancelled; - raise Runner_cancelled)) - with - | Runner_cancelled -> None - in - Option.iter - (fun result -> deliver ((not t.closed) && not operation.cancelled) result) - result))) - in - let execute (ticket : Asset_transfer.ticket) cache_only = - if ticket.scope = scope && current ticket - then - fork - ~id:(asset_operation_id scope (string_of_int ticket.id)) - (fun () -> - if cache_only - then - Asset_cache.lookup cache ~asset:ticket.asset ~version:ticket.version - |> Result.map_error asset_cache_failure - else - fetch_asset t ~cache ~encryption ~maximum_plaintext_bytes ~current ticket - |> Result.map Option.some) - (fun live result -> - if live && current ticket - then - post - (if cache_only - then Asset_transfer.Cache_checked (ticket, result) - else - Asset_transfer.Downloaded - ( ticket - , Result.bind result (function - | Some handle -> Ok handle - | None -> Error Asset_transfer.Not_found) )) - else ( - match result with - | Ok (Some handle) -> Asset_cache.release cache handle - | Ok None | Error _ -> ())) - in - match instruction with - | Asset_transfer.Check_cache ticket -> execute ticket true - | Fetch ticket -> execute ticket false - | Cancel ticket -> - if ticket.scope = scope - then - Option.iter - (fun (operation : operation) -> - operation.cancelled <- true; - operation.cancel ()) - (Hashtbl.find_opt - t.operations - (asset_operation_id scope (string_of_int ticket.id))) - | Release_handle handle -> Asset_cache.release cache handle - | Retry_after { id; seconds } -> - fork - ~id:(asset_operation_id scope ("timer:" ^ string_of_int id)) - (fun () -> t.dependencies.runtime.sleep seconds) - (fun live () -> if live then post (Asset_transfer.Retry_elapsed id)) - | Notify _ | Backpressure _ | Capacity_available -> () -;; - -let close_asset_scope t scope = +let close_asset_scope ?except_id t scope = Hashtbl.iter (fun id (operation : operation) -> if String.starts_with ~prefix:"asset:" id - && operation.scope = Core.effect_scope_of_graph scope + && Some id <> except_id + && Option.fold + ~none:false + ~some:(fun (actual, _) -> actual = scope) + operation.asset_identity then ( operation.cancelled <- true; operation.cancel ())) @@ -1254,46 +1217,13 @@ let scoped_asset_cache t scope = Asset_cache.create ~root ~scope - ~budget_bytes:268435456L - ~maximum_file_bytes:(8 * 1024 * 1024) + ~budget_bytes:t.dependencies.local_store.asset_cache_budget_bytes + ~maximum_file_bytes:t.dependencies.local_store.asset_maximum_file_bytes |> Result.map (fun cache -> Hashtbl.add t.asset_caches scope cache; cache) ;; -let run_scoped_asset t ~(context : Core.asset_context) ~current ~post instruction = - if not t.closed - then ( - let cache = - match instruction with - | Asset_transfer.Release_handle _ | Cancel _ -> - (match Hashtbl.find_opt t.asset_caches context.scope with - | Some cache -> Ok cache - | None -> Error Asset_cache.Stale) - | _ -> scoped_asset_cache t context.scope - in - match cache with - | Ok cache -> - let encryption = if context.encrypted then Encrypted context.key else Plaintext in - submit_asset - t - ~scope:context.scope - ~cache - ~encryption - ~maximum_plaintext_bytes:(8 * 1024 * 1024) - ~current - ~post - instruction - | Error error -> - let failure = asset_cache_failure error in - (match instruction with - | Asset_transfer.Check_cache ticket when current ticket -> - post (Asset_transfer.Cache_checked (ticket, Error failure)) - | Fetch ticket when current ticket -> - post (Asset_transfer.Downloaded (ticket, Error failure)) - | _ -> ())) -;; - let retain_asset_file t ~scope ~handle = if t.closed then None @@ -1313,7 +1243,21 @@ let release_asset_file t ~scope ~handle = (Hashtbl.find_opt t.asset_caches scope) ;; -let delete_graph_assets t (request : Core.mirror_deletion) = +let delete_graph_assets ?except_id t (request : Core.mirror_deletion) = + Hashtbl.iter + (fun id (operation : operation) -> + match operation.asset_identity with + | Some (scope, _) + when Some id <> except_id + && scope.graph_id = request.graph_id + && scope.account.user_id = request.account.user_id + && Uri.equal + scope.account.managed_sync_origin + request.account.managed_sync_origin -> + operation.cancelled <- true; + operation.cancel () + | Some _ | None -> ()) + t.operations; let scopes = Hashtbl.fold (fun (scope : Core.graph_scope) _ acc -> @@ -1328,7 +1272,7 @@ let delete_graph_assets t (request : Core.mirror_deletion) = t.asset_caches [] in - List.iter (close_asset_scope t) scopes; + List.iter (close_asset_scope ?except_id t) scopes; Asset_cache.delete_graph ~root:(asset_root t) ~account:request.account @@ -1336,16 +1280,6 @@ let delete_graph_assets t (request : Core.mirror_deletion) = |> Result.map_error (fun _ -> "The graph asset cache could not be removed.") ;; -type upload_failure = - | Upload_network - | Upload_authentication - | Upload_locked - | Upload_missing_source - | Upload_size_rejected - | Upload_revoked_access - | Upload_invalid_content - | Upload_cancelled - let read_upload_source ~maximum_plaintext_bytes source_file = try let input = open_in_bin source_file in @@ -1354,20 +1288,21 @@ let read_upload_source ~maximum_plaintext_bytes source_file = (fun () -> let stat = Unix.fstat (Unix.descr_of_in_channel input) in if stat.st_kind <> Unix.S_REG - then Error Upload_invalid_content + then Error (Core.Asset_invalid_content "Invalid upload content") else if stat.st_size > maximum_plaintext_bytes - then Error Upload_size_rejected + then Error Core.Asset_size_rejected else ( let bytes = really_input_string input stat.st_size in match input_char input with - | _ -> Error Upload_invalid_content + | _ -> Error (Core.Asset_invalid_content "Invalid upload content") | exception End_of_file -> Ok bytes)) with - | Sys_error _ | Unix.Unix_error (Unix.ENOENT, _, _) -> Error Upload_missing_source - | End_of_file | Unix.Unix_error _ -> Error Upload_invalid_content + | Sys_error _ | Unix.Unix_error (Unix.ENOENT, _, _) -> Error Core.Asset_missing_source + | End_of_file | Unix.Unix_error _ -> + Error (Core.Asset_invalid_content "Invalid upload content") ;; -let upload_asset_admitted +let put_asset_admitted t ~(context : Core.asset_context) ~asset @@ -1379,19 +1314,19 @@ let upload_asset_admitted let ( let* ) = Result.bind in let valid () = (not t.closed) && current () in if not (valid ()) - then Error Upload_cancelled + then Error Core.Asset_cancelled else if maximum_plaintext_bytes < 0 || maximum_plaintext_bytes > 100 * 1024 * 1024 - then Error Upload_size_rejected + then Error Core.Asset_size_rejected else ( let encryption = if context.encrypted then Encrypted context.key else Plaintext in let* graph_key = asset_graph_key t context.scope encryption - |> Result.map_error (fun _ -> Upload_locked) + |> Result.map_error (fun _ -> Core.Asset_locked) in let* body = with_asset_slot t.asset_codec_slot (fun () -> if not (valid ()) - then Error Upload_cancelled + then Error Core.Asset_cancelled else let* plaintext = read_upload_source ~maximum_plaintext_bytes source_file in if @@ -1399,7 +1334,7 @@ let upload_asset_admitted (String.equal (Asset_codec.checksum plaintext) version.Logseq_db_types.Asset_descriptor.checksum) - then Error Upload_invalid_content + then Error (Core.Asset_invalid_content "Invalid upload content") else ( let crypto : Asset_codec.crypto = { encrypt = t.dependencies.crypto.encrypt_aes_gcm @@ -1407,12 +1342,13 @@ let upload_asset_admitted } in Asset_codec.encode ~maximum_plaintext_bytes ~crypto ~key:graph_key plaintext - |> Result.map_error (fun _ -> Upload_invalid_content))) + |> Result.map_error (fun _ -> + Core.Asset_invalid_content "Invalid upload content"))) in let base_url = context.scope.account.managed_sync_origin in let* () = Http.validate_base_url base_url - |> Result.map_error (fun _ -> Upload_invalid_content) + |> Result.map_error (fun _ -> Core.Asset_invalid_content "Invalid upload content") in let path = Printf.sprintf @@ -1421,7 +1357,7 @@ let upload_asset_admitted (Graph_types.Uuid.to_string asset) version.file_type in - let failure = ref Upload_authentication in + let failure = ref Core.Asset_authentication in let* response = authenticated_operation t.dependencies.id_token_provider @@ -1429,7 +1365,7 @@ let upload_asset_admitted ~perform:(fun token -> if not (valid ()) then ( - failure := Upload_cancelled; + failure := Core.Asset_cancelled; Error (Request_failed "Asset upload expired")) else ( let request : Http.request = @@ -1447,28 +1383,28 @@ let upload_asset_admitted in match t.dependencies.transport.perform_http ~sw:t.sw request with | Error message -> - failure := Upload_network; + failure := Core.Asset_network; Error (Request_failed message) | Ok response when response.status = 401 -> - failure := Upload_authentication; + failure := Core.Asset_authentication; Error Unauthorized | Ok response when response.status = 403 -> - failure := Upload_revoked_access; + failure := Core.Asset_revoked_access; Error Forbidden | Ok response -> Ok response)) |> Result.map_error (fun _ -> !failure) in if not (valid ()) - then Error Upload_cancelled + then Error Core.Asset_cancelled else ( match response.status with | status when status >= 200 && status < 300 -> Ok () - | 413 -> Error Upload_size_rejected - | 408 | 429 | 500 | 502 | 503 | 504 -> Error Upload_network - | _ -> Error Upload_invalid_content)) + | 413 -> Error Core.Asset_size_rejected + | 408 | 429 | 500 | 502 | 503 | 504 -> Error Core.Asset_network + | _ -> Error (Core.Asset_invalid_content "Invalid upload content"))) ;; -let upload_asset +let put_asset t ~(context : Core.asset_context) ~asset @@ -1485,7 +1421,7 @@ let upload_asset + maximum_plaintext_bytes in with_byte_reservation t reservation (fun () -> - upload_asset_admitted + put_asset_admitted t ~context ~asset @@ -1505,46 +1441,23 @@ let staged_asset_path t ~scope ~file = ;; let release_staged_asset t ~scope ~file = - if t.closed - then Error "Asset storage is closed" - else ( - match scoped_asset_cache t scope with - | Error _ -> Error "Asset staging is unavailable" - | Ok cache -> - Result.map_error - (fun _ -> "Unable to release staged asset") - (Asset_cache.release_staged cache ~file)) -;; - -let stage_asset t ~scope ~operation ~file_type ~source_file = - if t.closed - then Error "Asset storage is closed" - else ( - match scoped_asset_cache t scope with - | Error _ -> Error "Asset staging is unavailable" - | Ok cache -> - Asset_cache.stage - cache - ~operation - ~file_type - ~source_file - ~pending_budget_bytes:268435456L - |> Result.map (fun staged -> staged.Asset_cache.file, staged.checksum, staged.size) - |> Result.map_error (function - | Asset_cache.Full -> "Pending attachments have reached the storage limit" - | Invalid message -> message - | Io _ | Stale | Checksum_mismatch -> "Unable to copy the selected attachment")) + match scoped_asset_cache t scope with + | Error _ -> Error "Asset staging is unavailable" + | Ok cache -> + Result.map_error + (fun _ -> "Unable to release staged asset") + (Asset_cache.release_staged cache ~file) ;; let prune_staged_assets t ~scope ~keep = if t.closed - then Error "Asset storage is closed" + then Error Core.Asset_cancelled else ( match scoped_asset_cache t scope with - | Error _ -> Error "Asset staging is unavailable" + | Error error -> Error (asset_cache_failure error) | Ok cache -> - Asset_cache.prune_staged cache ~keep - |> Result.map_error (fun _ -> "Unable to reconcile staged assets")) + Asset_cache.prune_staged cache ~keep:(fun operation -> Ok (List.mem operation keep)) + |> Result.map_error asset_cache_failure) ;; let retain_staged_file t ~scope ~file = @@ -1561,3 +1474,286 @@ let retain_staged_file t ~scope ~file = Asset_cache.release cache lease; None)) ;; + +let execute_asset ?except_id t (request : Core.asset_io_request) ~current = + let scope = request.context.scope in + let map_unit result = Result.map (fun () -> Core.Asset_unit) result in + let storage_result result = + Result.map_error (fun message -> Core.Asset_invalid_content message) result + in + let cache action = + Result.bind + (scoped_asset_cache t scope |> Result.map_error asset_cache_failure) + action + in + match request.action with + | Core.Check_asset_cache (asset, version) -> + cache (fun cache -> + Asset_cache.lookup cache ~asset ~version + |> Result.map (fun handle -> Core.Asset_cached handle) + |> Result.map_error asset_cache_failure) + | Fetch_asset { asset; version; maximum_plaintext_bytes } -> + cache (fun cache -> + let encryption = + if request.context.encrypted then Encrypted request.context.key else Plaintext + in + fetch_asset + t + ~cache + ~encryption + ~maximum_plaintext_bytes + ~current + ~scope + ~asset + ~version + |> Result.map (fun handle -> Core.Asset_downloaded handle)) + | Stage_asset_file { operation; file_type; source_file } -> + cache (fun cache -> + Asset_cache.stage + cache + ~operation + ~file_type + ~source_file + ~pending_budget_bytes:t.dependencies.local_store.asset_pending_budget_bytes + |> Result.map (fun staged -> + Core.Asset_staged + { file = staged.Asset_cache.file + ; checksum = staged.checksum + ; size = staged.size + }) + |> Result.map_error asset_cache_failure) + | Put_asset_file { asset; version; file; maximum_plaintext_bytes } -> + (match staged_asset_path t ~scope ~file with + | None -> Error Core.Asset_missing_source + | Some source_file -> + put_asset + t + ~context:request.context + ~asset + ~version + ~source_file + ~maximum_plaintext_bytes + ~current + |> map_unit) + | Retain_asset_file handle -> + Ok (Core.Asset_retained (retain_asset_file t ~scope ~handle)) + | Retain_staged_file file -> + Ok (Core.Asset_retained (retain_staged_file t ~scope ~file)) + | Release_asset_file handle -> + release_asset_file t ~scope ~handle; + Ok Core.Asset_unit + | Release_staged_file file -> + release_staged_asset t ~scope ~file |> storage_result |> map_unit + | Prune_asset_staging keep -> + prune_staged_assets t ~scope ~keep + |> Result.map (fun count -> Core.Asset_pruned count) + | Close_asset_scope -> + close_asset_scope ?except_id t scope; + Ok Core.Asset_unit + | Delete_graph_assets -> + let deletion : Core.mirror_deletion = + { account = scope.account + ; graph_id = scope.graph_id + ; scope = Core.effect_scope_of_graph scope + } + in + delete_graph_assets ?except_id t deletion |> storage_result |> map_unit + | Delete_account_assets -> + delete_account_assets ?except_id t scope.account + |> Result.map_error asset_cache_failure + |> map_unit + | Asset_retry_after seconds -> + t.dependencies.runtime.sleep seconds; + Ok Core.Asset_retry_elapsed + | Cancel_asset_operation target -> + Hashtbl.iter + (fun _ (pending : operation) -> + if pending.asset_identity = Some (scope, target) + then ( + pending.cancelled <- true; + pending.cancel ())) + t.operations; + Ok Core.Asset_unit +;; + +let scoped_operation_id kind (scope : Core.graph_scope) ticket = + Printf.sprintf + "%s:%S:%S:%d:%d:%Ld:%S:%d:%S" + kind + (Uri.to_string scope.account.managed_sync_origin) + scope.account.user_id + scope.account.account_generation + scope.account.presentation_generation + scope.account.lifecycle_generation + (Graph_types.Uuid.to_string scope.graph_id) + scope.graph_generation + ticket +;; + +let claim_operation t id = + if Hashtbl.mem t.submitted_operations id + then false + else ( + Hashtbl.add t.submitted_operations id (); + true) +;; + +let submit_asset_io t ticket (request : Core.asset_io_request) = + let id = + scoped_operation_id "asset" request.context.scope (Core.asset_ticket_id ticket) + in + if claim_operation t id + then ( + let cancelled, resolve_cancelled = Eio.Promise.create () in + let operation = + { scope = Core.effect_scope_of_graph request.context.scope + ; asset_identity = Some (request.context.scope, request.operation) + ; cancelled = false + ; cancel = (fun () -> ignore (Eio.Promise.try_resolve resolve_cancelled () : bool)) + } + in + Hashtbl.add t.operations id operation; + t.dependencies.runtime.fork ~sw:t.sw (fun () -> + let current () = (not t.closed) && not operation.cancelled in + let result = + Fun.protect + ~finally:(fun () -> Hashtbl.remove t.operations id) + (fun () -> + try + Eio.Fiber.first + (fun () -> + if not (current ()) then raise Runner_cancelled; + execute_asset ~except_id:id t request ~current) + (fun () -> + Eio.Promise.await cancelled; + raise Runner_cancelled) + with + | Runner_cancelled -> Error Core.Asset_cancelled + | error -> Error (Core.Asset_invalid_content (Printexc.to_string error))) + in + (* A completed resource must reach the reducer even after cancellation. + The reducer owns acceptance and issues cleanup for stale resources. *) + t.post (Core.Runner_completed (Core.Asset_completion (ticket, result))))) +;; + +let execute_protected t (request : Core.protected_request) = + let valid handle = Core.graph_key_handle_scope handle = request.protected_scope in + let run handle action = + if valid handle + then Result.map_error (fun message -> Core.Effect_failed message) (action ()) + else Error (Core.Effect_failed "Protected request graph key is out of scope") + in + match request.protected_action with + | Core.Encrypt_values (handle, values) -> + run handle (fun () -> encrypt_protected_values t handle values) + |> Result.map (fun values -> Core.Encrypted_values values) + | Decrypt_value (handle, source) -> + run handle (fun () -> decrypt_protected_value t handle source) + |> Result.map (fun value -> Core.Decrypted_value value) +;; + +let submit_protected t ticket (request : Core.protected_request) = + let id = + scoped_operation_id + "protected" + request.protected_scope + (Core.protected_ticket_id ticket) + in + if claim_operation t id + then ( + let cancelled, resolve_cancelled = Eio.Promise.create () in + let operation = + { scope = Core.effect_scope_of_graph request.protected_scope + ; asset_identity = None + ; cancelled = false + ; cancel = (fun () -> ignore (Eio.Promise.try_resolve resolve_cancelled () : bool)) + } + in + Hashtbl.add t.operations id operation; + t.dependencies.runtime.fork ~sw:t.sw (fun () -> + let result = + Fun.protect + ~finally:(fun () -> Hashtbl.remove t.operations id) + (fun () -> + try + Eio.Fiber.first + (fun () -> + if t.closed || operation.cancelled then raise Runner_cancelled; + execute_protected t request) + (fun () -> + Eio.Promise.await cancelled; + raise Runner_cancelled) + with + | Runner_cancelled -> + Error (Core.Effect_failed "Protected request cancelled") + | error -> Error (Core.Effect_failed (Printexc.to_string error))) + in + t.post (Core.Runner_completed (Core.Protected_completion (ticket, result))))) +;; + +let cleanup_asset_action = function + | Core.Release_asset_file _ + | Release_staged_file _ + | Close_asset_scope + | Delete_graph_assets + | Delete_account_assets + | Cancel_asset_operation _ -> true + | Check_asset_cache _ + | Fetch_asset _ + | Stage_asset_file _ + | Put_asset_file _ + | Retain_asset_file _ + | Retain_staged_file _ + | Prune_asset_staging _ + | Asset_retry_after _ -> false +;; + +let submit t instruction = + match instruction with + | Core.Asset_io (ticket, request) -> + if cleanup_asset_action request.action + then ( + let id = + scoped_operation_id "asset" request.context.scope (Core.asset_ticket_id ticket) + in + if claim_operation t id + then ( + let result = + try + Fun.protect + ~finally:(fun () -> + if t.closed then close_asset_scope t request.context.scope) + (fun () -> execute_asset t request ~current:(fun () -> false)) + with + | error -> Error (Core.Asset_invalid_content (Printexc.to_string error)) + in + t.post (Core.Runner_completed (Core.Asset_completion (ticket, result))))) + else if t.closed + then ( + let id = + scoped_operation_id "asset" request.context.scope (Core.asset_ticket_id ticket) + in + if claim_operation t id + then + t.post + (Core.Runner_completed + (Core.Asset_completion (ticket, Error Core.Asset_cancelled)))) + else submit_asset_io t ticket request + | Protected_io (ticket, request) -> + if t.closed + then ( + let id = + scoped_operation_id + "protected" + request.protected_scope + (Core.protected_ticket_id ticket) + in + if claim_operation t id + then + t.post + (Core.Runner_completed + (Core.Protected_completion + (ticket, Error (Core.Effect_failed "Protected request cancelled"))))) + else submit_protected t ticket request + | _ -> submit_nonasset t instruction +;; diff --git a/logseq_sync/lib/effect_runner/storage/asset_cache.ml b/logseq_sync/lib/effect_runner/storage/asset_cache.ml index 8738683..8485dca 100644 --- a/logseq_sync/lib/effect_runner/storage/asset_cache.ml +++ b/logseq_sync/lib/effect_runner/storage/asset_cache.ml @@ -1,671 +1,6 @@ -module Core = Logseq_sync_pure_reducer.Core -module Asset = Logseq_db_types.Asset_descriptor -module Uuid = Logseq_db_types.Graph_types.Uuid - -type handle = string - -type error = - | Invalid of string - | Io of string - | Full - | Stale - | Checksum_mismatch - -type record = - { name : string - ; file_type : string - ; checksum : string - ; size : int64 - ; mutable touched : float - ; mutable pins : int - } - -type staged_record = - { staged_name : string - ; staged_location : string - ; mutable staged_pins : int - ; mutable retired : bool - } - -type t = - { directory : string - ; budget : int64 - ; maximum_file_bytes : int - ; records : (string, record) Hashtbl.t - ; handles : (handle, record) Hashtbl.t - ; staged_records : (string, staged_record) Hashtbl.t - ; staged_handles : (handle, staged_record) Hashtbl.t - ; mutable closed : bool - } - -let next_handle = Atomic.make 0 -let ( let* ) = Result.bind - -let protect f = - try f () with - | Sys_error message -> Error (Io message) - | Unix.Unix_error (error, operation, _) -> - Error (Io (operation ^ ": " ^ Unix.error_message error)) -;; - -let rec mkdir path = - if not (Sys.file_exists path) - then ( - mkdir (Filename.dirname path); - Unix.mkdir path 0o700; - let parent = Unix.openfile (Filename.dirname path) [ Unix.O_RDONLY ] 0 in - Fun.protect ~finally:(fun () -> Unix.close parent) (fun () -> Unix.fsync parent)) -;; - -let unlink path = - try Unix.unlink path with - | Unix.Unix_error (Unix.ENOENT, _, _) -> () -;; - -(* Data files carry the validated attachment type so native presentation - (for example Quick Look) classifies them correctly. *) -let data_path t record = - Filename.concat t.directory (record.name ^ "." ^ record.file_type) -;; - -let manifest_path t name = Filename.concat t.directory (name ^ ".json") - -let name asset (version : Asset.version) = - Asset_codec.checksum - (Uuid.to_string asset ^ ":" ^ version.file_type ^ ":" ^ version.checksum) -;; - -let sync_directory t = - let fd = Unix.openfile t.directory [ Unix.O_RDONLY ] 0 in - Fun.protect ~finally:(fun () -> Unix.close fd) (fun () -> Unix.fsync fd) -;; - -let write path bytes = - let fd = Unix.openfile path [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in - Fun.protect - ~finally:(fun () -> Unix.close fd) - (fun () -> - let rec loop offset = - if offset < String.length bytes - then ( - let count = - Unix.write_substring fd bytes offset (String.length bytes - offset) - in - if count = 0 - then raise (Sys_error "Asset file write made no progress") - else loop (offset + count)) - in - loop 0; - Unix.fsync fd) -;; - -let checksum_file path = - let channel = open_in_bin path in - Fun.protect - ~finally:(fun () -> close_in channel) - (fun () -> - let buffer = Bytes.create 65536 in - let rec read context = - match input channel buffer 0 (Bytes.length buffer) with - | 0 -> Digestif.SHA256.(to_hex (get context)) - | length -> read (Digestif.SHA256.feed_bytes context ~off:0 ~len:length buffer) - in - read Digestif.SHA256.empty) -;; - -let remove_record t record = - unlink (manifest_path t record.name); - unlink (data_path t record); - Hashtbl.remove t.records record.name -;; - -let pin t record = - record.pins <- record.pins + 1; - record.touched <- Unix.gettimeofday (); - Unix.utimes (manifest_path t record.name) record.touched record.touched; - let handle = Printf.sprintf "asset:%d" (Atomic.fetch_and_add next_handle 1) in - Hashtbl.add t.handles handle record; - handle -;; - -let read_manifest directory file = - try - let path = Filename.concat directory file in - if (Unix.stat path).st_size > 1024 - then None - else ( - match Yojson.Safe.from_file path with - | `Assoc fields -> - (match - ( List.assoc_opt "asset" fields - , List.assoc_opt "type" fields - , List.assoc_opt "checksum" fields - , List.assoc_opt "size" fields ) - with - | ( Some (`String asset) - , Some (`String file_type) - , Some (`String checksum) - , Some (`String size) ) -> - (match - ( Uuid.of_string asset - , Asset.version ~checksum ~file_type - , Int64.of_string_opt size ) - with - | Ok asset, Ok version, Some size - when size >= 0L && name asset version ^ ".json" = file -> - let name = name asset version in - Some - { name - ; file_type = version.file_type - ; checksum - ; size - ; touched = (Unix.stat path).st_mtime - ; pins = 0 - } - | _ -> None) - | _ -> None) - | _ -> None) - with - | Sys_error _ | Unix.Unix_error _ | Yojson.Json_error _ -> None -;; - -let account_directory ~root (account : Core.account_scope) = - let name = - Asset_codec.checksum - (Yojson.Safe.to_string - (`List - [ `String (Uri.to_string account.managed_sync_origin) - ; `String account.user_id - ])) - in - Filename.concat root name -;; - -let create ~root ~(scope : Core.graph_scope) ~budget_bytes ~maximum_file_bytes = - protect (fun () -> - if - budget_bytes < 0L - || maximum_file_bytes < 0 - || maximum_file_bytes > 100 * 1024 * 1024 - then Error (Invalid "Invalid cache size limits") - else ( - let directory = - Filename.concat - (account_directory ~root scope.account) - (Uuid.to_string scope.graph_id) - in - mkdir directory; - let pending = Filename.concat directory "pending" in - if Sys.file_exists pending - then - Array.iter - (fun file -> - if Filename.check_suffix file ".part" - then unlink (Filename.concat pending file)) - (Sys.readdir pending); - let t = - { directory - ; budget = budget_bytes - ; maximum_file_bytes - ; records = Hashtbl.create 64 - ; handles = Hashtbl.create 64 - ; staged_records = Hashtbl.create 8 - ; staged_handles = Hashtbl.create 8 - ; closed = false - } - in - Array.iter - (fun file -> - if Filename.check_suffix file ".json" - then ( - match read_manifest directory file with - | Some record - when record.size <= Int64.of_int maximum_file_bytes - && Sys.file_exists (data_path t record) -> - Hashtbl.replace t.records record.name record - | _ -> unlink (Filename.concat directory file)) - else if Filename.check_suffix file ".part" - then unlink (Filename.concat directory file)) - (Sys.readdir directory); - let kept = Hashtbl.create (2 * Hashtbl.length t.records) in - Hashtbl.iter - (fun _ record -> - Hashtbl.replace kept (record.name ^ ".json") (); - Hashtbl.replace kept (record.name ^ "." ^ record.file_type) ()) - t.records; - Array.iter - (fun file -> - let path = Filename.concat directory file in - if (not (Hashtbl.mem kept file)) && not (Sys.is_directory path) - then unlink path) - (Sys.readdir directory); - Ok t)) -;; - -let lookup t ~asset ~version = - protect (fun () -> - if t.closed - then Error Stale - else ( - match Hashtbl.find_opt t.records (name asset version) with - | None -> Ok None - | Some record -> - let path = data_path t record in - let valid = - try - let stat = Unix.stat path in - stat.st_kind = Unix.S_REG - && Int64.of_int stat.st_size = record.size - && stat.st_size <= t.maximum_file_bytes - && checksum_file path = record.checksum - with - | Sys_error _ | Unix.Unix_error _ -> false - in - if valid - then Ok (Some (pin t record)) - else ( - if record.pins = 0 then remove_record t record; - Ok None))) -;; - -let reserve t needed = - let usage = - Hashtbl.fold (fun _ record total -> Int64.add total record.size) t.records 0L - in - let candidates = - Hashtbl.fold - (fun _ record acc -> if record.pins = 0 then record :: acc else acc) - t.records - [] - |> List.sort (fun a b -> Float.compare a.touched b.touched) - in - let rec evict usage = function - | _ when needed <= t.budget && usage <= Int64.sub t.budget needed -> Ok () - | [] -> Error Full - | record :: rest -> - remove_record t record; - evict (Int64.sub usage record.size) rest - in - if needed > t.budget then Error Full else evict usage candidates -;; - -let publish t ~asset ~(version : Asset.version) ~current ~plaintext = - protect (fun () -> - if t.closed || not (current ()) - then Error Stale - else if String.length plaintext > t.maximum_file_bytes - then Error (Invalid "Asset exceeds cache file limit") - else if Asset_codec.checksum plaintext <> version.checksum - then Error Checksum_mismatch - else - let* existing = lookup t ~asset ~version in - match existing with - | Some handle -> Ok handle - | None -> - let size = Int64.of_int (String.length plaintext) in - let* () = reserve t size in - let name = name asset version in - (* A corrupt pinned record cannot be replaced beneath a renderer. *) - if Hashtbl.mem t.records name - then Error Full - else ( - let record = - { name - ; file_type = version.file_type - ; checksum = version.checksum - ; size - ; touched = Unix.gettimeofday () - ; pins = 0 - } - in - let data = data_path t record - and manifest = manifest_path t name in - let temporary = data ^ ".part" - and temporary_manifest = manifest ^ ".part" in - Fun.protect - ~finally:(fun () -> - unlink temporary; - unlink temporary_manifest) - (fun () -> - write temporary plaintext; - write - temporary_manifest - (Yojson.Safe.to_string - (`Assoc - [ "asset", `String (Uuid.to_string asset) - ; "type", `String version.file_type - ; "checksum", `String version.checksum - ; "size", `String (Int64.to_string size) - ])); - if t.closed || not (current ()) - then Error Stale - else ( - Unix.rename temporary data; - Unix.rename temporary_manifest manifest; - sync_directory t; - Hashtbl.replace t.records name record; - Ok (pin t record))))) -;; - -let pin_staged t record = - record.staged_pins <- record.staged_pins + 1; - let handle = Printf.sprintf "staged:%d" (Atomic.fetch_and_add next_handle 1) in - Hashtbl.add t.staged_handles handle record; - handle -;; - -let clean_retired_staging t record = - if record.retired && record.staged_pins = 0 - then - protect (fun () -> - unlink record.staged_location; - let directory = Filename.dirname record.staged_location in - if Sys.file_exists directory - then ( - let fd = Unix.openfile directory [ Unix.O_RDONLY ] 0 in - Fun.protect ~finally:(fun () -> Unix.close fd) (fun () -> Unix.fsync fd)); - Hashtbl.remove t.staged_records record.staged_name; - Ok ()) - else Ok () -;; - -let path t handle = - if t.closed - then None - else ( - match Hashtbl.find_opt t.handles handle with - | Some record -> Some (data_path t record) - | None -> - Option.map - (fun record -> record.staged_location) - (Hashtbl.find_opt t.staged_handles handle)) -;; - -let retain t handle = - if t.closed - then None - else ( - match Hashtbl.find_opt t.handles handle with - | Some record -> Some (pin t record) - | None -> Option.map (pin_staged t) (Hashtbl.find_opt t.staged_handles handle)) -;; - -let release t handle = - match Hashtbl.find_opt t.handles handle with - | Some record -> - record.pins <- record.pins - 1; - Hashtbl.remove t.handles handle - | None -> - (match Hashtbl.find_opt t.staged_handles handle with - | None -> () - | Some record -> - record.staged_pins <- record.staged_pins - 1; - Hashtbl.remove t.staged_handles handle; - if record.retired - then ignore (clean_retired_staging t record) - else if record.staged_pins = 0 - then Hashtbl.remove t.staged_records record.staged_name) -;; - -let close t = - t.closed <- true; - Hashtbl.clear t.handles; - Hashtbl.iter (fun _ record -> record.pins <- 0) t.records; - Hashtbl.clear t.staged_handles; - Hashtbl.fold (fun _ record records -> record :: records) t.staged_records [] - |> List.iter (fun record -> - record.staged_pins <- 0; - ignore (clean_retired_staging t record)); - Hashtbl.clear t.staged_records -;; - -let remove_tree path = - let rec remove path = - match Unix.lstat path with - | { Unix.st_kind = Unix.S_DIR; _ } -> - Array.iter (fun name -> remove (Filename.concat path name)) (Sys.readdir path); - Unix.rmdir path - | _ -> Unix.unlink path - | exception Unix.Unix_error (Unix.ENOENT, _, _) -> () - in - protect (fun () -> - remove path; - Ok ()) -;; - -let delete t = - close t; - Result.map (fun () -> Hashtbl.clear t.records) (remove_tree t.directory) -;; - -let delete_account ~root ~account = remove_tree (account_directory ~root account) - -let delete_graph ~root ~account ~graph_id = - remove_tree - (Filename.concat (account_directory ~root account) (Uuid.to_string graph_id)) -;; - -type staged = - { file : string - ; checksum : string - ; size : int64 - } - -let pending_directory t = Filename.concat t.directory "pending" - -let valid_staged_type file_type = - Result.is_ok (Asset.version ~checksum:(String.make 64 '0') ~file_type) -;; - -let valid_staged_file file = - Filename.basename file = file - && - match String.rindex_opt file '.' with - | None -> false - | Some separator -> - Result.is_ok (Uuid.of_string (String.sub file 0 separator)) - && valid_staged_type - (String.sub file (separator + 1) (String.length file - separator - 1)) -;; - -let staged_path t ~file = - if t.closed || not (valid_staged_file file) - then None - else ( - let path = Filename.concat (pending_directory t) file in - match Unix.lstat path with - | { Unix.st_kind = Unix.S_REG; _ } -> Some path - | _ -> None - | exception Unix.Unix_error _ -> None) -;; - -let retain_staged t ~file = - Option.bind (staged_path t ~file) (fun location -> - match Hashtbl.find_opt t.staged_records file with - | Some record when record.retired -> None - | Some record -> Some (pin_staged t record) - | None -> - let record = - { staged_name = file - ; staged_location = location - ; staged_pins = 0 - ; retired = false - } - in - Hashtbl.add t.staged_records file record; - Some (pin_staged t record)) -;; - -let release_staged t ~file = - if t.closed - then Error Stale - else if not (valid_staged_file file) - then Error (Invalid "Invalid staged file") - else ( - let record = - match Hashtbl.find_opt t.staged_records file with - | Some record -> record - | None -> - { staged_name = file - ; staged_location = Filename.concat (pending_directory t) file - ; staged_pins = 0 - ; retired = true - } - in - record.retired <- true; - clean_retired_staging t record) -;; - -let stage t ~operation ~file_type ~source_file ~pending_budget_bytes = - if t.closed - then Error Stale - else if not (valid_staged_type file_type) - then Error (Invalid "Invalid staged file type") - else if pending_budget_bytes < 0L - then Error (Invalid "Invalid staging budget") - else - protect (fun () -> - let directory = pending_directory t in - mkdir directory; - let file = Uuid.to_string operation ^ "." ^ file_type in - let target = Filename.concat directory file in - let partial = target ^ ".part" in - if Sys.file_exists target - then Error (Invalid "Staged import already exists") - else ( - let source = - Unix.openfile source_file [ Unix.O_RDONLY; Unix.O_NONBLOCK; Unix.O_CLOEXEC ] 0 - in - Fun.protect - ~finally:(fun () -> Unix.close source) - (fun () -> - let metadata = Unix.fstat source in - if metadata.st_kind <> Unix.S_REG - then Error (Invalid "Import source must be a regular file") - else if metadata.st_size > t.maximum_file_bytes - then Error (Invalid "Import exceeds file size limit") - else ( - let files = Sys.readdir directory in - let used = - Array.fold_left - (fun total name -> - let size = (Unix.lstat (Filename.concat directory name)).st_size in - Int64.add total (Int64.of_int (max 1 size))) - 0L - files - in - let allocation = Int64.of_int (max 1 metadata.st_size) in - if - Array.length files >= 4096 - || used > Int64.sub pending_budget_bytes allocation - then Error Full - else ( - let output = - Unix.openfile - partial - [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_EXCL; Unix.O_CLOEXEC ] - 0o600 - in - Fun.protect - ~finally:(fun () -> - Unix.close output; - unlink partial) - (fun () -> - let buffer = Bytes.create 65536 in - let rec copy count digest = - match Unix.read source buffer 0 (Bytes.length buffer) with - | 0 -> Ok (count, digest) - | length -> - if count + length > metadata.st_size - then Error (Invalid "Import source changed during staging") - else ( - let rec write offset = - if offset < length - then ( - let written = - Unix.write output buffer offset (length - offset) - in - if written = 0 - then raise (Sys_error "Staging write made no progress") - else write (offset + written)) - in - write 0; - copy - (count + length) - (Digestif.SHA256.feed_bytes - digest - ~off:0 - ~len:length - buffer)) - in - let* size, digest = copy 0 Digestif.SHA256.empty in - let after = Unix.fstat source in - if - size <> metadata.st_size - || after.st_mtime <> metadata.st_mtime - || after.st_size <> metadata.st_size - then Error (Invalid "Import source changed during staging") - else ( - Unix.fsync output; - Unix.rename partial target; - let fd = Unix.openfile directory [ Unix.O_RDONLY ] 0 in - Fun.protect - ~finally:(fun () -> Unix.close fd) - (fun () -> Unix.fsync fd); - Ok - { file - ; checksum = Digestif.SHA256.to_hex (Digestif.SHA256.get digest) - ; size = Int64.of_int size - }))))))) -;; - -let prune_staged t ~keep = - if t.closed - then Error Stale - else - protect (fun () -> - let directory = pending_directory t in - if not (Sys.file_exists directory) - then Ok 0 - else ( - let stream = Unix.opendir directory in - let rec inspect count orphaned = - match Unix.readdir stream with - | "." | ".." -> inspect count orphaned - | _ when count >= 4096 -> Error Full - | file -> - let path = Filename.concat directory file in - if - (not (valid_staged_file file)) - || - match Hashtbl.find_opt t.staged_records file with - | Some record -> record.staged_pins > 0 - | None -> false - then inspect (count + 1) orphaned - else ( - match Unix.lstat path with - | { Unix.st_kind = Unix.S_REG; _ } -> - let operation = - Uuid.of_string (Filename.chop_extension file) |> Result.get_ok - in - (match keep operation with - | Error message -> Error (Io message) - | Ok true -> inspect (count + 1) orphaned - | Ok false -> inspect (count + 1) (file :: orphaned)) - | _ -> inspect (count + 1) orphaned - | exception Unix.Unix_error (Unix.ENOENT, _, _) -> - inspect (count + 1) orphaned) - | exception End_of_file -> Ok orphaned - in - match - Fun.protect ~finally:(fun () -> Unix.closedir stream) (fun () -> inspect 0 []) - with - | Error _ as error -> error - | Ok orphaned -> - List.iter (fun file -> unlink (Filename.concat directory file)) orphaned; - if orphaned <> [] - then ( - let fd = Unix.openfile directory [ Unix.O_RDONLY ] 0 in - Fun.protect ~finally:(fun () -> Unix.close fd) (fun () -> Unix.fsync fd)); - Ok (List.length orphaned))) -;; +(* This virtual-module implementation intentionally exposes no cache IO. + The implementation belongs to private [Bootstrap.Asset_cache]. *) +type t = unit +type handle = unit +type error = unit +type staged = unit diff --git a/logseq_sync/lib/effect_runner/storage/bootstrap.ml b/logseq_sync/lib/effect_runner/storage/bootstrap.ml index 48abfa8..d9c8480 100644 --- a/logseq_sync/lib/effect_runner/storage/bootstrap.ml +++ b/logseq_sync/lib/effect_runner/storage/bootstrap.ml @@ -140,3 +140,694 @@ let peel_gzip_layers ~decompress_gzip ~maximum_bytes ~source ~destination ~tempo | Sys_error message -> fail message)))))) | [] | [ _ ] -> Error "two private gzip staging paths are required") ;; + +(* Cache IO is private to the runner interpreter. *) +module Asset_cache = struct + module Core = Logseq_sync_pure_reducer.Core + module Asset = Logseq_db_types.Asset_descriptor + module Uuid = Logseq_db_types.Graph_types.Uuid + + type handle = string + + type error = + | Invalid of string + | Io of string + | Full + | Stale + | Checksum_mismatch + + type record = + { name : string + ; file_type : string + ; checksum : string + ; size : int64 + ; mutable touched : float + ; mutable pins : int + } + + type staged_record = + { staged_name : string + ; staged_location : string + ; mutable staged_pins : int + ; mutable retired : bool + } + + type t = + { directory : string + ; budget : int64 + ; maximum_file_bytes : int + ; records : (string, record) Hashtbl.t + ; handles : (handle, record) Hashtbl.t + ; staged_records : (string, staged_record) Hashtbl.t + ; staged_handles : (handle, staged_record) Hashtbl.t + ; mutable closed : bool + } + + let next_handle = Atomic.make 0 + let ( let* ) = Result.bind + + let protect f = + try f () with + | Sys_error message -> Error (Io message) + | Unix.Unix_error (error, operation, _) -> + Error (Io (operation ^ ": " ^ Unix.error_message error)) + ;; + + let rec mkdir path = + if not (Sys.file_exists path) + then ( + mkdir (Filename.dirname path); + Unix.mkdir path 0o700; + let parent = Unix.openfile (Filename.dirname path) [ Unix.O_RDONLY ] 0 in + Fun.protect ~finally:(fun () -> Unix.close parent) (fun () -> Unix.fsync parent)) + ;; + + let unlink path = + try Unix.unlink path with + | Unix.Unix_error (Unix.ENOENT, _, _) -> () + ;; + + (* Data files carry the validated attachment type so native presentation + (for example Quick Look) classifies them correctly. *) + let data_path t record = + Filename.concat t.directory (record.name ^ "." ^ record.file_type) + ;; + + let manifest_path t name = Filename.concat t.directory (name ^ ".json") + + let name asset (version : Asset.version) = + Asset_codec.checksum + (Uuid.to_string asset ^ ":" ^ version.file_type ^ ":" ^ version.checksum) + ;; + + let sync_directory t = + let fd = Unix.openfile t.directory [ Unix.O_RDONLY ] 0 in + Fun.protect ~finally:(fun () -> Unix.close fd) (fun () -> Unix.fsync fd) + ;; + + let write path bytes = + let fd = Unix.openfile path [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + Fun.protect + ~finally:(fun () -> Unix.close fd) + (fun () -> + let rec loop offset = + if offset < String.length bytes + then ( + let count = + Unix.write_substring fd bytes offset (String.length bytes - offset) + in + if count = 0 + then raise (Sys_error "Asset file write made no progress") + else loop (offset + count)) + in + loop 0; + Unix.fsync fd) + ;; + + let checksum_file path = + let channel = open_in_bin path in + Fun.protect + ~finally:(fun () -> close_in channel) + (fun () -> + let buffer = Bytes.create 65536 in + let rec read context = + match input channel buffer 0 (Bytes.length buffer) with + | 0 -> Digestif.SHA256.(to_hex (get context)) + | length -> read (Digestif.SHA256.feed_bytes context ~off:0 ~len:length buffer) + in + read Digestif.SHA256.empty) + ;; + + let remove_record t record = + unlink (manifest_path t record.name); + unlink (data_path t record); + Hashtbl.remove t.records record.name + ;; + + let pin t record = + record.pins <- record.pins + 1; + record.touched <- Unix.gettimeofday (); + Unix.utimes (manifest_path t record.name) record.touched record.touched; + let handle = Printf.sprintf "asset:%d" (Atomic.fetch_and_add next_handle 1) in + Hashtbl.add t.handles handle record; + handle + ;; + + let read_manifest directory file = + try + let path = Filename.concat directory file in + if (Unix.stat path).st_size > 1024 + then None + else ( + match Yojson.Safe.from_file path with + | `Assoc fields -> + (match + ( List.assoc_opt "asset" fields + , List.assoc_opt "type" fields + , List.assoc_opt "checksum" fields + , List.assoc_opt "size" fields ) + with + | ( Some (`String asset) + , Some (`String file_type) + , Some (`String checksum) + , Some (`String size) ) -> + (match + ( Uuid.of_string asset + , Asset.version ~checksum ~file_type + , Int64.of_string_opt size ) + with + | Ok asset, Ok version, Some size + when size >= 0L && name asset version ^ ".json" = file -> + let name = name asset version in + Some + { name + ; file_type = version.file_type + ; checksum + ; size + ; touched = (Unix.stat path).st_mtime + ; pins = 0 + } + | _ -> None) + | _ -> None) + | _ -> None) + with + | Sys_error _ | Unix.Unix_error _ | Yojson.Json_error _ -> None + ;; + + let account_directory ~root (account : Core.account_scope) = + let name = + Asset_codec.checksum + (Yojson.Safe.to_string + (`List + [ `String (Uri.to_string account.managed_sync_origin) + ; `String account.user_id + ])) + in + Filename.concat root name + ;; + + let create ~root ~(scope : Core.graph_scope) ~budget_bytes ~maximum_file_bytes = + protect (fun () -> + if + budget_bytes < 0L + || maximum_file_bytes < 0 + || maximum_file_bytes > 100 * 1024 * 1024 + then Error (Invalid "Invalid cache size limits") + else ( + let directory = + Filename.concat + (account_directory ~root scope.account) + (Uuid.to_string scope.graph_id) + in + mkdir directory; + let pending = Filename.concat directory "pending" in + if Sys.file_exists pending + then + Array.iter + (fun file -> + if Filename.check_suffix file ".part" + then unlink (Filename.concat pending file)) + (Sys.readdir pending); + let t = + { directory + ; budget = budget_bytes + ; maximum_file_bytes + ; records = Hashtbl.create 64 + ; handles = Hashtbl.create 64 + ; staged_records = Hashtbl.create 8 + ; staged_handles = Hashtbl.create 8 + ; closed = false + } + in + Array.iter + (fun file -> + if Filename.check_suffix file ".json" + then ( + match read_manifest directory file with + | Some record + when record.size <= Int64.of_int maximum_file_bytes + && Sys.file_exists (data_path t record) -> + Hashtbl.replace t.records record.name record + | _ -> unlink (Filename.concat directory file)) + else if Filename.check_suffix file ".part" + then unlink (Filename.concat directory file)) + (Sys.readdir directory); + let kept = Hashtbl.create (2 * Hashtbl.length t.records) in + Hashtbl.iter + (fun _ record -> + Hashtbl.replace kept (record.name ^ ".json") (); + Hashtbl.replace kept (record.name ^ "." ^ record.file_type) ()) + t.records; + Array.iter + (fun file -> + let path = Filename.concat directory file in + if (not (Hashtbl.mem kept file)) && not (Sys.is_directory path) + then unlink path) + (Sys.readdir directory); + Ok t)) + ;; + + let lookup t ~asset ~version = + protect (fun () -> + if t.closed + then Error Stale + else ( + match Hashtbl.find_opt t.records (name asset version) with + | None -> Ok None + | Some record -> + let path = data_path t record in + let valid = + try + let stat = Unix.stat path in + stat.st_kind = Unix.S_REG + && Int64.of_int stat.st_size = record.size + && stat.st_size <= t.maximum_file_bytes + && checksum_file path = record.checksum + with + | Sys_error _ | Unix.Unix_error _ -> false + in + if valid + then Ok (Some (pin t record)) + else ( + if record.pins = 0 then remove_record t record; + Ok None))) + ;; + + let reserve t needed = + let usage = + Hashtbl.fold (fun _ record total -> Int64.add total record.size) t.records 0L + in + let candidates = + Hashtbl.fold + (fun _ record acc -> if record.pins = 0 then record :: acc else acc) + t.records + [] + |> List.sort (fun a b -> Float.compare a.touched b.touched) + in + let rec evict usage = function + | _ when needed <= t.budget && usage <= Int64.sub t.budget needed -> Ok () + | [] -> Error Full + | record :: rest -> + remove_record t record; + evict (Int64.sub usage record.size) rest + in + if needed > t.budget then Error Full else evict usage candidates + ;; + + let publish t ~asset ~(version : Asset.version) ~current ~plaintext = + protect (fun () -> + if t.closed || not (current ()) + then Error Stale + else if String.length plaintext > t.maximum_file_bytes + then Error (Invalid "Asset exceeds cache file limit") + else if Asset_codec.checksum plaintext <> version.checksum + then Error Checksum_mismatch + else + let* existing = lookup t ~asset ~version in + match existing with + | Some handle -> Ok handle + | None -> + let size = Int64.of_int (String.length plaintext) in + let* () = reserve t size in + let name = name asset version in + (* A corrupt pinned record cannot be replaced beneath a renderer. *) + if Hashtbl.mem t.records name + then Error Full + else ( + let record = + { name + ; file_type = version.file_type + ; checksum = version.checksum + ; size + ; touched = Unix.gettimeofday () + ; pins = 0 + } + in + let data = data_path t record + and manifest = manifest_path t name in + let temporary = data ^ ".part" + and temporary_manifest = manifest ^ ".part" in + Fun.protect + ~finally:(fun () -> + unlink temporary; + unlink temporary_manifest) + (fun () -> + write temporary plaintext; + write + temporary_manifest + (Yojson.Safe.to_string + (`Assoc + [ "asset", `String (Uuid.to_string asset) + ; "type", `String version.file_type + ; "checksum", `String version.checksum + ; "size", `String (Int64.to_string size) + ])); + if t.closed || not (current ()) + then Error Stale + else ( + Unix.rename temporary data; + Unix.rename temporary_manifest manifest; + sync_directory t; + Hashtbl.replace t.records name record; + Ok (pin t record))))) + ;; + + let pin_staged t record = + record.staged_pins <- record.staged_pins + 1; + let handle = Printf.sprintf "staged:%d" (Atomic.fetch_and_add next_handle 1) in + Hashtbl.add t.staged_handles handle record; + handle + ;; + + let clean_retired_staging t record = + if record.retired && record.staged_pins = 0 + then + protect (fun () -> + unlink record.staged_location; + let directory = Filename.dirname record.staged_location in + if Sys.file_exists directory + then ( + let fd = Unix.openfile directory [ Unix.O_RDONLY ] 0 in + Fun.protect ~finally:(fun () -> Unix.close fd) (fun () -> Unix.fsync fd)); + Hashtbl.remove t.staged_records record.staged_name; + Ok ()) + else Ok () + ;; + + let path t handle = + if t.closed + then None + else ( + match Hashtbl.find_opt t.handles handle with + | Some record -> Some (data_path t record) + | None -> + Option.map + (fun record -> record.staged_location) + (Hashtbl.find_opt t.staged_handles handle)) + ;; + + let retain t handle = + if t.closed + then None + else ( + match Hashtbl.find_opt t.handles handle with + | Some record -> Some (pin t record) + | None -> Option.map (pin_staged t) (Hashtbl.find_opt t.staged_handles handle)) + ;; + + let release t handle = + match Hashtbl.find_opt t.handles handle with + | Some record -> + record.pins <- record.pins - 1; + Hashtbl.remove t.handles handle + | None -> + (match Hashtbl.find_opt t.staged_handles handle with + | None -> () + | Some record -> + record.staged_pins <- record.staged_pins - 1; + Hashtbl.remove t.staged_handles handle; + if record.retired + then ignore (clean_retired_staging t record) + else if record.staged_pins = 0 + then Hashtbl.remove t.staged_records record.staged_name) + ;; + + let close t = + t.closed <- true; + Hashtbl.clear t.handles; + Hashtbl.iter (fun _ record -> record.pins <- 0) t.records; + Hashtbl.clear t.staged_handles; + Hashtbl.fold (fun _ record records -> record :: records) t.staged_records [] + |> List.iter (fun record -> + record.staged_pins <- 0; + ignore (clean_retired_staging t record)); + Hashtbl.clear t.staged_records + ;; + + let remove_tree path = + let rec remove path = + match Unix.lstat path with + | { Unix.st_kind = Unix.S_DIR; _ } -> + Array.iter (fun name -> remove (Filename.concat path name)) (Sys.readdir path); + Unix.rmdir path + | _ -> Unix.unlink path + | exception Unix.Unix_error (Unix.ENOENT, _, _) -> () + in + protect (fun () -> + remove path; + Ok ()) + ;; + + let delete t = + close t; + Result.map (fun () -> Hashtbl.clear t.records) (remove_tree t.directory) + ;; + + let delete_account ~root ~account = remove_tree (account_directory ~root account) + + let delete_graph ~root ~account ~graph_id = + remove_tree + (Filename.concat (account_directory ~root account) (Uuid.to_string graph_id)) + ;; + + type staged = + { file : string + ; checksum : string + ; size : int64 + } + + let pending_directory t = Filename.concat t.directory "pending" + + let valid_staged_type file_type = + Result.is_ok (Asset.version ~checksum:(String.make 64 '0') ~file_type) + ;; + + let valid_staged_nonce nonce = + String.length nonce = 64 + && String.for_all + (function + | '0' .. '9' | 'a' .. 'f' -> true + | _ -> false) + nonce + ;; + + let valid_staged_file file = + Filename.basename file = file + && + match String.split_on_char '.' file with + | [ operation; file_type ] -> + Result.is_ok (Uuid.of_string operation) && valid_staged_type file_type + | [ operation; nonce; file_type ] -> + Result.is_ok (Uuid.of_string operation) + && valid_staged_nonce nonce + && valid_staged_type file_type + | _ -> false + ;; + + let staged_path t ~file = + if t.closed || not (valid_staged_file file) + then None + else ( + let path = Filename.concat (pending_directory t) file in + match Unix.lstat path with + | { Unix.st_kind = Unix.S_REG; _ } -> Some path + | _ -> None + | exception Unix.Unix_error _ -> None) + ;; + + let retain_staged t ~file = + Option.bind (staged_path t ~file) (fun location -> + match Hashtbl.find_opt t.staged_records file with + | Some record when record.retired -> None + | Some record -> Some (pin_staged t record) + | None -> + let record = + { staged_name = file + ; staged_location = location + ; staged_pins = 0 + ; retired = false + } + in + Hashtbl.add t.staged_records file record; + Some (pin_staged t record)) + ;; + + let release_staged t ~file = + if t.closed + then Error Stale + else if not (valid_staged_file file) + then Error (Invalid "Invalid staged file") + else ( + let record = + match Hashtbl.find_opt t.staged_records file with + | Some record -> record + | None -> + { staged_name = file + ; staged_location = Filename.concat (pending_directory t) file + ; staged_pins = 0 + ; retired = true + } + in + record.retired <- true; + clean_retired_staging t record) + ;; + + let stage t ~operation ~file_type ~source_file ~pending_budget_bytes = + if t.closed + then Error Stale + else if not (valid_staged_type file_type) + then Error (Invalid "Invalid staged file type") + else if pending_budget_bytes < 0L + then Error (Invalid "Invalid staging budget") + else + protect (fun () -> + let directory = pending_directory t in + mkdir directory; + (* A delayed completion must name this physical instance, even if its + business operation is staged again after pruning or recovery. *) + let nonce = Asset_codec.checksum (Mirage_crypto_rng_unix.getrandom 16) in + let file = Uuid.to_string operation ^ "." ^ nonce ^ "." ^ file_type in + let target = Filename.concat directory file in + let partial = target ^ ".part" in + if Sys.file_exists target + then Error (Invalid "Staged import already exists") + else ( + let source = + Unix.openfile source_file [ Unix.O_RDONLY; Unix.O_NONBLOCK; Unix.O_CLOEXEC ] 0 + in + Fun.protect + ~finally:(fun () -> Unix.close source) + (fun () -> + let metadata = Unix.fstat source in + if metadata.st_kind <> Unix.S_REG + then Error (Invalid "Import source must be a regular file") + else if metadata.st_size > t.maximum_file_bytes + then Error (Invalid "Import exceeds file size limit") + else ( + let files = Sys.readdir directory in + let used = + Array.fold_left + (fun total name -> + let size = + (Unix.lstat (Filename.concat directory name)).st_size + in + Int64.add total (Int64.of_int (max 1 size))) + 0L + files + in + let allocation = Int64.of_int (max 1 metadata.st_size) in + if + Array.length files >= 4096 + || used > Int64.sub pending_budget_bytes allocation + then Error Full + else ( + let output = + Unix.openfile + partial + [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_EXCL; Unix.O_CLOEXEC ] + 0o600 + in + Fun.protect + ~finally:(fun () -> + Unix.close output; + unlink partial) + (fun () -> + let buffer = Bytes.create 65536 in + let rec copy count digest = + match Unix.read source buffer 0 (Bytes.length buffer) with + | 0 -> Ok (count, digest) + | length -> + if count + length > metadata.st_size + then Error (Invalid "Import source changed during staging") + else ( + let rec write offset = + if offset < length + then ( + let written = + Unix.write output buffer offset (length - offset) + in + if written = 0 + then raise (Sys_error "Staging write made no progress") + else write (offset + written)) + in + write 0; + copy + (count + length) + (Digestif.SHA256.feed_bytes + digest + ~off:0 + ~len:length + buffer)) + in + let* size, digest = copy 0 Digestif.SHA256.empty in + let after = Unix.fstat source in + if + size <> metadata.st_size + || after.st_mtime <> metadata.st_mtime + || after.st_size <> metadata.st_size + then Error (Invalid "Import source changed during staging") + else ( + Unix.fsync output; + (* Publish without replacing another physical instance. *) + Unix.link partial target; + unlink partial; + let fd = Unix.openfile directory [ Unix.O_RDONLY ] 0 in + Fun.protect + ~finally:(fun () -> Unix.close fd) + (fun () -> Unix.fsync fd); + Ok + { file + ; checksum = + Digestif.SHA256.to_hex (Digestif.SHA256.get digest) + ; size = Int64.of_int size + }))))))) + ;; + + let prune_staged t ~keep = + if t.closed + then Error Stale + else + protect (fun () -> + let directory = pending_directory t in + if not (Sys.file_exists directory) + then Ok 0 + else ( + let stream = Unix.opendir directory in + let rec inspect count orphaned = + match Unix.readdir stream with + | "." | ".." -> inspect count orphaned + | _ when count >= 4096 -> Error Full + | file -> + let path = Filename.concat directory file in + if + (not (valid_staged_file file)) + || + match Hashtbl.find_opt t.staged_records file with + | Some record -> record.staged_pins > 0 + | None -> false + then inspect (count + 1) orphaned + else ( + match Unix.lstat path with + | { Unix.st_kind = Unix.S_REG; _ } -> + (match keep file with + | Error message -> Error (Io message) + | Ok true -> inspect (count + 1) orphaned + | Ok false -> inspect (count + 1) (file :: orphaned)) + | _ -> inspect (count + 1) orphaned + | exception Unix.Unix_error (Unix.ENOENT, _, _) -> + inspect (count + 1) orphaned) + | exception End_of_file -> Ok orphaned + in + match + Fun.protect ~finally:(fun () -> Unix.closedir stream) (fun () -> inspect 0 []) + with + | Error _ as error -> error + | Ok orphaned -> + List.iter (fun file -> unlink (Filename.concat directory file)) orphaned; + if orphaned <> [] + then ( + let fd = Unix.openfile directory [ Unix.O_RDONLY ] 0 in + Fun.protect ~finally:(fun () -> Unix.close fd) (fun () -> Unix.fsync fd)); + Ok (List.length orphaned))) + ;; +end diff --git a/logseq_sync/lib/effect_runner/storage/bootstrap.mli b/logseq_sync/lib/effect_runner/storage/bootstrap.mli index 6451758..4b0c528 100644 --- a/logseq_sync/lib/effect_runner/storage/bootstrap.mli +++ b/logseq_sync/lib/effect_runner/storage/bootstrap.mli @@ -15,3 +15,87 @@ val peel_gzip_layers -> (unit, string) result val cleanup : string list -> unit + +(** Private storage implementation, interpreted only by runner submission. *) +module Asset_cache : sig + (** Verified files are local state, scoped by origin, account and graph. Calls are + serialized by the effect runner; handles pin files until explicitly released. *) + type t + + type handle = string + + type error = + | Invalid of string + | Io of string + | Full + | Stale + | Checksum_mismatch + + val create + : root:string + -> scope:Logseq_sync_pure_reducer.Core.graph_scope + -> budget_bytes:int64 + -> maximum_file_bytes:int + -> (t, error) result + + val lookup + : t + -> asset:Logseq_db_types.Graph_types.Uuid.t + -> version:Logseq_db_types.Asset_descriptor.version + -> (handle option, error) result + + val publish + : t + -> asset:Logseq_db_types.Graph_types.Uuid.t + -> version:Logseq_db_types.Asset_descriptor.version + -> current:(unit -> bool) + -> plaintext:string + -> (handle, error) result + + val path : t -> handle -> string option + val retain : t -> handle -> handle option + val release : t -> handle -> unit + val close : t -> unit + val delete : t -> (unit, error) result + + (** Remove durable files for one origin/account after its live caches are closed. *) + val delete_account + : root:string + -> account:Logseq_sync_pure_reducer.Core.account_scope + -> (unit, error) result + + val delete_graph + : root:string + -> account:Logseq_sync_pure_reducer.Core.account_scope + -> graph_id:Logseq_db_types.Graph_types.Uuid.t + -> (unit, error) result + + type staged = private + { file : string + ; checksum : string + ; size : int64 + } + + (** Copy an explicit import into the durable, non-evictable pending namespace. + Each copy has a distinct physical file identity, including copies of the + same operation. Legacy operation-only filenames remain readable. + The caller persists the returned identity before graph mutation or upload. *) + val stage + : t + -> operation:Logseq_db_types.Graph_types.Uuid.t + -> file_type:string + -> source_file:string + -> pending_budget_bytes:int64 + -> (staged, error) result + + (** Retain a staged file for a local preview. Completion cleanup waits for all leases. *) + val retain_staged : t -> file:string -> handle option + + val staged_path : t -> file:string -> string option + val release_staged : t -> file:string -> (unit, error) result + + (** Remove recognized orphan staging files only after all ownership checks succeed. + Ownership checks receive the exact physical file identity, including legacy + filenames. The caller must serialize this with staging and intent persistence. *) + val prune_staged : t -> keep:(string -> (bool, string) result) -> (int, error) result +end diff --git a/logseq_sync/lib/pure_reducer/core.ml b/logseq_sync/lib/pure_reducer/core.ml index cc5c83c..410de21 100644 --- a/logseq_sync/lib/pure_reducer/core.ml +++ b/logseq_sync/lib/pure_reducer/core.ml @@ -318,6 +318,121 @@ type private_key_unlock = ; private_key_package : string } +type asset_context = + { scope : graph_scope + ; encrypted : bool + ; key : graph_key_handle option + } + +type asset_action = + | Check_asset_cache of graph_id * Logseq_db_types.Asset_descriptor.version + | Fetch_asset of + { asset : graph_id + ; version : Logseq_db_types.Asset_descriptor.version + ; maximum_plaintext_bytes : int + } + | Stage_asset_file of + { operation : graph_id + ; file_type : string + ; source_file : string + } + | Put_asset_file of + { asset : graph_id + ; version : Logseq_db_types.Asset_descriptor.version + ; file : string + ; maximum_plaintext_bytes : int + } + | Retain_asset_file of string + | Retain_staged_file of string + | Release_asset_file of string + | Release_staged_file of string + | Prune_asset_staging of string list + | Close_asset_scope + | Delete_graph_assets + | Delete_account_assets + | Asset_retry_after of float + | Cancel_asset_operation of string + +type asset_failure = + | Asset_network + | Asset_not_found + | Asset_checksum_mismatch + | Asset_authentication + | Asset_locked + | Asset_storage_full + | Asset_missing_source + | Asset_size_rejected + | Asset_revoked_access + | Asset_cancelled + | Asset_invalid_content of string + +type asset_value = + | Asset_unit + | Asset_cached of string option + | Asset_downloaded of string + | Asset_staged of + { file : string + ; checksum : string + ; size : int64 + } + | Asset_retained of (string * string) option + | Asset_pruned of int + | Asset_retry_elapsed + +type asset_result = (asset_value, asset_failure) result + +type asset_request = + { scope : graph_scope + ; operation : string + ; action : asset_action + } + +type asset_io_request = + { context : asset_context + ; operation : string + ; action : asset_action + } + +type asset_ticket = + { asset_serial : int + ; asset_request : asset_io_request + } + +let asset_ticket_id ticket = "asset:" ^ string_of_int ticket.asset_serial + +type asset_output = + { request : asset_request + ; result : asset_result + } + +type protected_action = + | Encrypt_values of graph_key_handle * string list + | Decrypt_value of graph_key_handle * string + +type protected_request = + { protected_operation : string + ; protected_scope : graph_scope + ; protected_action : protected_action + } + +type protected_value = + | Encrypted_values of (string * string) list + | Decrypted_value of string + +type protected_result = (protected_value, effect_error) result + +type protected_output = + { protected_request : protected_request + ; protected_result : protected_result + } + +type protected_ticket = + { protected_serial : int + ; protected_input : protected_request + } + +let protected_ticket_id ticket = "protected:" ^ string_of_int ticket.protected_serial + type _ runner_request = | Load_catalog : account_scope -> catalog_cache option runner_request | Save_catalog : @@ -383,6 +498,8 @@ type timer_request = } type runner_effect = + | Asset_io of asset_ticket * asset_io_request + | Protected_io of protected_ticket * protected_request | Request : 'a effect_ticket * 'a runner_request -> runner_effect | Start_websocket of websocket_request | Send_websocket of websocket_send @@ -391,6 +508,8 @@ type runner_effect = | Cancel_effects of effect_scope type runner_completion = + | Asset_completion of asset_ticket * asset_result + | Protected_completion of protected_ticket * protected_result | Completion : 'a effect_ticket * ('a, effect_error) result -> runner_completion let scope_of_request : type a. a runner_request -> effect_scope = function @@ -410,6 +529,8 @@ let scope_of_request : type a. a runner_request -> effect_scope = function ;; let runner_effect_scope = function + | Protected_io (_, request) -> effect_scope_of_graph request.protected_scope + | Asset_io (_, request) -> effect_scope_of_graph request.context.scope | Request (ticket, _) -> ticket.scope | Start_websocket value -> effect_scope_of_connection value.scope | Send_websocket value -> effect_scope_of_connection value.scope @@ -419,6 +540,8 @@ let runner_effect_scope = function ;; let runner_effect_diagnostic = function + | Protected_io (ticket, _) -> protected_ticket_id ticket + | Asset_io (ticket, _) -> asset_ticket_id ticket | Request (ticket, _) -> Printf.sprintf "request:%d" ticket.id | Start_websocket _ -> "start-websocket" | Send_websocket _ -> "send-websocket" @@ -483,6 +606,8 @@ type worker_effect = | Apply_authoritative_batch of authoritative_batch type output = + | Asset_finished of asset_output + | Protected_finished of protected_output | State_changed of state | Bootstrap_progressed of bootstrap_progress @@ -529,6 +654,8 @@ type outbox_transition_result = type snapshot_activation = { scope : graph_scope } type event = + | Asset_requested of asset_request + | Protected_requested of protected_request | Restore_local_account of { user_id : string } | Account_authenticated of { user_id : string option } | Local_feed_acknowledged @@ -576,8 +703,17 @@ type submission_owner = ; response_timer : timer_id option } +type pending_asset = + { asset_ticket : asset_ticket + ; asset_cancelled : bool + ; asset_notify : bool + } + type t = - { config : config + { asset_known_scopes : graph_scope list + ; protected_pending : protected_ticket list + ; assets_pending : pending_asset list + ; config : config ; public_state : state ; user_id : string option ; lifecycle_generation : lifecycle_generation @@ -639,7 +775,10 @@ let initial config = } in Ok - { config + { asset_known_scopes = [] + ; protected_pending = [] + ; assets_pending = [] + ; config ; public_state = { snapshot; diagnostics = { groups = [] } } ; user_id = None ; lifecycle_generation = 0L @@ -676,12 +815,6 @@ let initial config = let state core = core.public_state let admitted_graph_scope core = core.current_graph_scope -type asset_context = - { scope : graph_scope - ; encrypted : bool - ; key : graph_key_handle option - } - let asset_context core = match core.current_graph_scope, core.selected_graph_value with | Some scope, Some graph -> @@ -2163,61 +2296,63 @@ let complete_runner : type a. t -> a effect_ticket -> a -> transition = | Decrypt_protected_values_kind -> unchanged core ;; -let consume_completion core (Completion (ticket, result)) = - match consume_ticket core ticket with - | None -> unchanged core - | Some core -> - (match result with - | Ok value -> complete_runner core ticket value - | Error (Effect_failed message | Crypto_failed (_, message)) -> - let core = - match ticket.kind with - | Download_snapshot_kind -> { core with active_snapshot_download = None } - | _ -> core - in - (match ticket.kind with - | Save_catalog_kind -> - (match core.public_state.snapshot.local_deletion with - | Some (Deletion_in_progress Clearing_selection) -> - deletion_failed core Clearing_selection - | None | Some _ -> unchanged core) - | Load_catalog_kind -> - fail - { core with - catalog_cache_loading = false - ; deferred_catalog_reconciliation = false - } - During_catalog - message - | Load_and_unlock_graph_key_kind -> fail core During_local_restore message - | Unlock_private_key_kind -> - (* A rejected password leaves the encrypted challenge available for - another attempt. No password or unlocked key is retained. *) - let failed = fail core During_e2ee message in - let startup = - { failed.next.public_state.snapshot.startup with - awaiting_e2ee_password = true - } +let consume_completion core = function + | Asset_completion _ | Protected_completion _ -> unchanged core + | Completion (ticket, result) -> + (match consume_ticket core ticket with + | None -> unchanged core + | Some core -> + (match result with + | Ok value -> complete_runner core ticket value + | Error (Effect_failed message | Crypto_failed (_, message)) -> + let core = + match ticket.kind with + | Download_snapshot_kind -> { core with active_snapshot_download = None } + | _ -> core in - let next = - set_snapshot - { failed.next with - snapshot_scope = core.snapshot_scope - ; pending_encrypted_graph_key = core.pending_encrypted_graph_key - ; pending_private_key_package = core.pending_private_key_package - } - { failed.next.public_state.snapshot with startup } - in - { next; effects = [ publish next ] } - | Fetch_e2ee_graph_key_kind - | Fetch_e2ee_user_keys_kind - | Fetch_and_unlock_graph_key_kind -> fail core During_e2ee message - | Delete_account_secrets_kind -> - cleanup_failed core "account secret cleanup failed" - | Fetch_snapshot_baseline_kind - | Fetch_snapshot_metadata_kind - | Download_snapshot_kind -> fail core During_bootstrap message - | _ -> fail core During_catalog message)) + (match ticket.kind with + | Save_catalog_kind -> + (match core.public_state.snapshot.local_deletion with + | Some (Deletion_in_progress Clearing_selection) -> + deletion_failed core Clearing_selection + | None | Some _ -> unchanged core) + | Load_catalog_kind -> + fail + { core with + catalog_cache_loading = false + ; deferred_catalog_reconciliation = false + } + During_catalog + message + | Load_and_unlock_graph_key_kind -> fail core During_local_restore message + | Unlock_private_key_kind -> + (* A rejected password leaves the encrypted challenge available for + another attempt. No password or unlocked key is retained. *) + let failed = fail core During_e2ee message in + let startup = + { failed.next.public_state.snapshot.startup with + awaiting_e2ee_password = true + } + in + let next = + set_snapshot + { failed.next with + snapshot_scope = core.snapshot_scope + ; pending_encrypted_graph_key = core.pending_encrypted_graph_key + ; pending_private_key_package = core.pending_private_key_package + } + { failed.next.public_state.snapshot with startup } + in + { next; effects = [ publish next ] } + | Fetch_e2ee_graph_key_kind + | Fetch_e2ee_user_keys_kind + | Fetch_and_unlock_graph_key_kind -> fail core During_e2ee message + | Delete_account_secrets_kind -> + cleanup_failed core "account secret cleanup failed" + | Fetch_snapshot_baseline_kind + | Fetch_snapshot_metadata_kind + | Download_snapshot_kind -> fail core During_bootstrap message + | _ -> fail core During_catalog message))) ;; let websocket_closed core connection message = @@ -2621,6 +2756,7 @@ let step core event = effects = Run (Close_websocket owner.connection) :: restarted.effects } | _ -> unchanged core) + | Asset_requested _ | Protected_requested _ -> unchanged core | Local_feed_acknowledged -> unchanged core | Shutdown -> let scope = @@ -2649,3 +2785,373 @@ let step core event = ; effects = [ Run (Cancel_effects scope) ] }) ;; + +(* Asset execution is a separate identity/acceptance owner. Download demand and + durable import publication remain in their respective policy reducers. *) +let asset_public_request (request : asset_io_request) : asset_request = + { scope = request.context.scope + ; operation = request.operation + ; action = request.action + } +;; + +let asset_output request result = Publish (Asset_finished { request; result }) + +let issue_asset ?(notify = true) core (request : asset_io_request) = + let ticket = { asset_serial = core.next_effect_id; asset_request = request } in + { next = + { core with + next_effect_id = core.next_effect_id + 1 + ; assets_pending = + { asset_ticket = ticket; asset_cancelled = false; asset_notify = notify } + :: core.assets_pending + } + ; effects = [ Run (Asset_io (ticket, request)) ] + } +;; + +let asset_cleanup_action = function + | Release_asset_file _ + | Release_staged_file _ + | Close_asset_scope + | Delete_graph_assets + | Delete_account_assets + | Cancel_asset_operation _ -> true + | Check_asset_cache _ + | Fetch_asset _ + | Stage_asset_file _ + | Put_asset_file _ + | Retain_asset_file _ + | Retain_staged_file _ + | Prune_asset_staging _ + | Asset_retry_after _ -> false +;; + +let asset_cleanup core (request : asset_io_request) result = + let action = + match result with + | Ok (Asset_cached (Some handle) | Asset_downloaded handle) -> + Some (Release_asset_file handle) + | Ok (Asset_retained (Some (lease, _))) -> Some (Release_asset_file lease) + | Ok (Asset_staged { file; _ }) -> Some (Release_staged_file file) + | Ok + ( Asset_cached None + | Asset_retained None + | Asset_unit | Asset_pruned _ | Asset_retry_elapsed ) + | Error _ -> None + in + match action with + | None -> unchanged core + | Some action -> + issue_asset + ~notify:false + core + { request with operation = "cleanup:" ^ string_of_int core.next_effect_id; action } +;; + +let asset_result_matches action = function + | Error _ -> true + | Ok value -> + (match action, value with + | Check_asset_cache _, Asset_cached _ + | Fetch_asset _, Asset_downloaded _ + | Stage_asset_file _, Asset_staged _ + | Put_asset_file _, Asset_unit + | Retain_asset_file _, Asset_retained _ + | Retain_staged_file _, Asset_retained _ + | Release_asset_file _, Asset_unit + | Release_staged_file _, Asset_unit + | Prune_asset_staging _, Asset_pruned _ + | Close_asset_scope, Asset_unit + | Delete_graph_assets, Asset_unit + | Delete_account_assets, Asset_unit + | Asset_retry_after _, Asset_retry_elapsed + | Cancel_asset_operation _, Asset_unit -> true + | _ -> false) +;; + +let complete_asset core ticket result = + match + List.find_opt (fun pending -> pending.asset_ticket = ticket) core.assets_pending + with + | None -> unchanged core + | Some pending -> + let core = + { core with + assets_pending = + List.filter (fun item -> item.asset_ticket <> ticket) core.assets_pending + } + in + let request = ticket.asset_request in + if pending.asset_cancelled + then asset_cleanup core request result + else if not (asset_result_matches request.action result) + then ( + let cleaned = asset_cleanup core request result in + { cleaned with + effects = + (if pending.asset_notify + then + [ asset_output + (asset_public_request request) + (Error (Asset_invalid_content "Asset completion kind mismatch")) + ] + else []) + @ cleaned.effects + }) + else + { next = core + ; effects = + (if pending.asset_notify + then [ asset_output (asset_public_request request) result ] + else []) + } +;; + +let cancel_asset_pending core matches = + let assets_pending, outputs = + List.fold_right + (fun pending (retained, outputs) -> + if pending.asset_cancelled || not (matches pending.asset_ticket.asset_request) + then pending :: retained, outputs + else + ( { pending with asset_cancelled = true } :: retained + , if pending.asset_notify + then + asset_output + (asset_public_request pending.asset_ticket.asset_request) + (Error Asset_cancelled) + :: outputs + else outputs )) + core.assets_pending + ([], []) + in + { core with assets_pending }, outputs +;; + +let same_asset_account (left : account_scope) (right : account_scope) = + Uri.equal left.managed_sync_origin right.managed_sync_origin + && String.equal left.user_id right.user_id +;; + +let request_asset core (request : asset_request) = + let cleanup = asset_cleanup_action request.action in + let context = + match asset_context core with + | Some context when context.scope = request.scope -> Some context + | _ when cleanup -> + let known = + match request.action with + | Delete_account_assets -> + List.exists + (fun (scope : graph_scope) -> scope.account = request.scope.account) + core.asset_known_scopes + | Delete_graph_assets -> + List.exists + (fun (scope : graph_scope) -> + scope.account = request.scope.account + && scope.graph_id = request.scope.graph_id) + core.asset_known_scopes + | _ -> List.mem request.scope core.asset_known_scopes + in + if known + then Some { scope = request.scope; encrypted = false; key = None } + else None + | _ -> None + in + let duplicate = + List.exists + (fun pending -> + let previous = pending.asset_ticket.asset_request in + (not pending.asset_cancelled) + && previous.context.scope = request.scope + && previous.operation = request.operation) + core.assets_pending + in + let valid = + request.operation <> "" + && + match request.action with + | Fetch_asset { maximum_plaintext_bytes; _ } + | Put_asset_file { maximum_plaintext_bytes; _ } -> + maximum_plaintext_bytes >= 0 && maximum_plaintext_bytes <= 100 * 1024 * 1024 + | Asset_retry_after seconds -> Float.is_finite seconds && seconds >= 0. + | _ -> true + in + if duplicate + then unchanged core + else if (core.closed && not cleanup) || context = None || not valid + then { next = core; effects = [ asset_output request (Error Asset_cancelled) ] } + else ( + let core, cancelled = + match request.action with + | Cancel_asset_operation operation -> + cancel_asset_pending core (fun previous -> + previous.context.scope = request.scope && previous.operation = operation) + | Close_asset_scope -> + cancel_asset_pending core (fun previous -> previous.context.scope = request.scope) + | Delete_graph_assets -> + cancel_asset_pending core (fun previous -> + same_asset_account previous.context.scope.account request.scope.account + && previous.context.scope.graph_id = request.scope.graph_id) + | Delete_account_assets -> + cancel_asset_pending core (fun previous -> + same_asset_account previous.context.scope.account request.scope.account) + | _ -> core, [] + in + let issued = + issue_asset + core + { context = Option.get context + ; operation = request.operation + ; action = request.action + } + in + { issued with effects = cancelled @ issued.effects }) +;; + +let graph_step = step + +let step core event = + let transition = + match event with + | Asset_requested request -> request_asset core request + | Runner_completed (Asset_completion (ticket, result)) -> + complete_asset core ticket result + | _ -> graph_step core event + in + let current = if transition.next.closed then None else asset_context transition.next in + let transition = + match current with + | Some context when not (List.mem context.scope transition.next.asset_known_scopes) -> + { transition with + next = + { transition.next with + asset_known_scopes = context.scope :: transition.next.asset_known_scopes + } + } + | Some _ | None -> transition + in + let retired = + transition.next.assets_pending + |> List.filter_map (fun pending -> + let context = pending.asset_ticket.asset_request.context in + if + pending.asset_cancelled + || asset_cleanup_action pending.asset_ticket.asset_request.action + || + match current with + | Some active -> active.scope = context.scope + | None -> false + then None + else Some context) + |> List.sort_uniq compare + in + List.fold_left + (fun transition (context : asset_context) -> + let next, cancelled = + cancel_asset_pending transition.next (fun request -> + request.context.scope = context.scope + && not (asset_cleanup_action request.action)) + in + let closed = + issue_asset + ~notify:false + next + { context + ; operation = "close:" ^ string_of_int next.next_effect_id + ; action = Close_asset_scope + } + in + { closed with effects = transition.effects @ cancelled @ closed.effects }) + transition + retired +;; + +let asset_step = step + +let protected_output request result = + Publish (Protected_finished { protected_request = request; protected_result = result }) +;; + +let protected_current core request = + (not core.closed) + && core.current_graph_scope = Some request.protected_scope + && + match request.protected_action with + | Encrypt_values (key, _) | Decrypt_value (key, _) -> + graph_key_handle_scope key = request.protected_scope +;; + +let step core event = + let transition = + match event with + | Protected_requested request -> + if + List.exists + (fun ticket -> + ticket.protected_input.protected_operation = request.protected_operation + && ticket.protected_input.protected_scope = request.protected_scope) + core.protected_pending + then unchanged core + else if not (protected_current core request) + then + { next = core + ; effects = + [ protected_output + request + (Error (Effect_failed "Protected-value request expired")) + ] + } + else ( + let ticket = + { protected_serial = core.next_effect_id; protected_input = request } + in + { next = + { core with + next_effect_id = core.next_effect_id + 1 + ; protected_pending = ticket :: core.protected_pending + } + ; effects = [ Run (Protected_io (ticket, request)) ] + }) + | Runner_completed (Protected_completion (ticket, result)) -> + if not (List.mem ticket core.protected_pending) + then unchanged core + else ( + let next = + { core with + protected_pending = + List.filter (fun pending -> pending <> ticket) core.protected_pending + } + in + let valid = + match ticket.protected_input.protected_action, result with + | _, Error _ + | Encrypt_values _, Ok (Encrypted_values _) + | Decrypt_value _, Ok (Decrypted_value _) -> true + | _ -> false + in + let result = + if not valid + then Error (Effect_failed "Protected completion kind mismatch") + else result + in + { next; effects = [ protected_output ticket.protected_input result ] }) + | _ -> asset_step core event + in + let active, retired = + List.partition + (fun ticket -> protected_current transition.next ticket.protected_input) + transition.next.protected_pending + in + { next = { transition.next with protected_pending = active } + ; effects = + transition.effects + @ List.map + (fun ticket -> + protected_output + ticket.protected_input + (Error (Effect_failed "Protected-value request expired"))) + retired + } +;; diff --git a/logseq_sync/spec/effect_runner/asset_cache.mli b/logseq_sync/spec/effect_runner/asset_cache.mli index 423d6b9..2809235 100644 --- a/logseq_sync/spec/effect_runner/asset_cache.mli +++ b/logseq_sync/spec/effect_runner/asset_cache.mli @@ -1,80 +1,7 @@ -(** Verified files are local state, scoped by origin, account and graph. Calls are - serialized by the effect runner; handles pin files until explicitly released. *) +(** Cache resources have no public execution interface. Business requests enter + [Core.step]; the resulting effect is submitted to [Effect_runner.submit]. *) type t -type handle = string - -type error = - | Invalid of string - | Io of string - | Full - | Stale - | Checksum_mismatch - -val create - : root:string - -> scope:Logseq_sync_pure_reducer.Core.graph_scope - -> budget_bytes:int64 - -> maximum_file_bytes:int - -> (t, error) result - -val lookup - : t - -> asset:Logseq_db_types.Graph_types.Uuid.t - -> version:Logseq_db_types.Asset_descriptor.version - -> (handle option, error) result - -val publish - : t - -> asset:Logseq_db_types.Graph_types.Uuid.t - -> version:Logseq_db_types.Asset_descriptor.version - -> current:(unit -> bool) - -> plaintext:string - -> (handle, error) result - -val path : t -> handle -> string option -val retain : t -> handle -> handle option -val release : t -> handle -> unit -val close : t -> unit -val delete : t -> (unit, error) result - -(** Remove durable files for one origin/account after its live caches are closed. *) -val delete_account - : root:string - -> account:Logseq_sync_pure_reducer.Core.account_scope - -> (unit, error) result - -val delete_graph - : root:string - -> account:Logseq_sync_pure_reducer.Core.account_scope - -> graph_id:Logseq_db_types.Graph_types.Uuid.t - -> (unit, error) result - -type staged = private - { file : string - ; checksum : string - ; size : int64 - } - -(** Copy an explicit import into the durable, non-evictable pending namespace. - The caller persists the returned identity before graph mutation or upload. *) -val stage - : t - -> operation:Logseq_db_types.Graph_types.Uuid.t - -> file_type:string - -> source_file:string - -> pending_budget_bytes:int64 - -> (staged, error) result - -(** Retain a staged file for a local preview. Completion cleanup waits for all leases. *) -val retain_staged : t -> file:string -> handle option - -val staged_path : t -> file:string -> string option -val release_staged : t -> file:string -> (unit, error) result - -(** Remove recognized orphan staging files only after all ownership checks succeed. - The caller must serialize this operation with staging and intent persistence. *) -val prune_staged - : t - -> keep:(Logseq_db_types.Graph_types.Uuid.t -> (bool, string) result) - -> (int, error) result +type handle +type error +type staged diff --git a/logseq_sync/spec/effect_runner/effect_runner.mli b/logseq_sync/spec/effect_runner/effect_runner.mli index 619bcc4..13b280e 100644 --- a/logseq_sync/spec/effect_runner/effect_runner.mli +++ b/logseq_sync/spec/effect_runner/effect_runner.mli @@ -24,12 +24,6 @@ type authenticated_failure = | Forbidden | Request_failed of string -val authenticated_operation - : id_token_provider - -> account:Logseq_sync_pure_reducer.Core.account_scope - -> perform:(string -> ('a, authenticated_failure) result) - -> ('a, string) result - val tls_authenticator : X509.Authenticator.t -> tls_authenticator val system_tls_authenticator : unit -> (tls_authenticator, dependency_error) result @@ -50,7 +44,11 @@ val transport type local_store val local_store - : application_support_directory:string + : ?asset_cache_budget_bytes:int64 + -> ?asset_maximum_file_bytes:int + -> ?asset_pending_budget_bytes:int64 + -> application_support_directory:string + -> unit -> (local_store, dependency_error) result type artifact_store @@ -119,128 +117,8 @@ val create -> post:(Logseq_sync_pure_reducer.Core.event -> unit) -> (t, create_error) result +(** Asset and protected-value tickets execute at most once for the runner's lifetime. + Replaying an already submitted ticket does not execute I/O or post a second completion. *) val submit : t -> Logseq_sync_pure_reducer.Core.runner_effect -> unit -val decrypt_protected_value - : t - -> Logseq_sync_pure_reducer.Core.graph_key_handle - -> string - -> (string, string) result - -val encrypt_protected_values - : t - -> Logseq_sync_pure_reducer.Core.graph_key_handle - -> string list - -> ((string * string) list, string) result - val shutdown : t -> unit - -type asset_encryption = - | Plaintext - | Encrypted of Logseq_sync_pure_reducer.Core.graph_key_handle option - -(** Executes explicit asset instructions with the existing authentication/key owner. - [current] must check the exact scope, version and request identity immediately; - it is rechecked before atomic publication and before delivering a result. - A runner admits at most three binary downloads, including response decoding - and publication, across all graph scopes. Cache-only checks bypass this gate. - GET decoding/publication and PUT source reading/encoding share one codec permit; - network requests retain their independent transfer permits. Every admitted - transfer also reserves its worst-case wire plus plaintext footprint against one - shared 64 MiB byte budget, bounding total in-flight asset memory across lanes. *) -val submit_asset - : t - -> scope:Logseq_sync_pure_reducer.Core.graph_scope - -> cache:Asset_cache.t - -> encryption:asset_encryption - -> maximum_plaintext_bytes:int - -> current:(Logseq_sync_pure_reducer.Asset_transfer.ticket -> bool) - -> post:(Logseq_sync_pure_reducer.Asset_transfer.event -> unit) - -> Logseq_sync_pure_reducer.Asset_transfer.instruction - -> unit - -(** Scoped cache adapter for the worker's live asset session. *) -val run_scoped_asset - : t - -> context:Logseq_sync_pure_reducer.Core.asset_context - -> current:(Logseq_sync_pure_reducer.Asset_transfer.ticket -> bool) - -> post:(Logseq_sync_pure_reducer.Asset_transfer.event -> unit) - -> Logseq_sync_pure_reducer.Asset_transfer.instruction - -> unit - -val close_asset_scope : t -> Logseq_sync_pure_reducer.Core.graph_scope -> unit - -val retain_asset_file - : t - -> scope:Logseq_sync_pure_reducer.Core.graph_scope - -> handle:string - -> (string * string) option - -val release_asset_file - : t - -> scope:Logseq_sync_pure_reducer.Core.graph_scope - -> handle:string - -> unit - -val delete_graph_assets - : t - -> Logseq_sync_pure_reducer.Core.mirror_deletion - -> (unit, string) result - -type upload_failure = - | Upload_network - | Upload_authentication - | Upload_locked - | Upload_missing_source - | Upload_size_rejected - | Upload_revoked_access - | Upload_invalid_content - | Upload_cancelled - -(** Upload an explicit, immutable staged file. Graph publication belongs to the worker. - A runner reserves one upload permit alongside its three download permits. - Admission precedes source reads and encoding; cancellation or failure releases - the permit. The upload reserves its wire plus plaintext footprint against the - shared 64 MiB byte budget before encoding. Waiting callers must supply a live - [current] predicate. *) -val upload_asset - : t - -> context:Logseq_sync_pure_reducer.Core.asset_context - -> asset:Logseq_db_types.Graph_types.Uuid.t - -> version:Logseq_db_types.Asset_descriptor.version - -> source_file:string - -> maximum_plaintext_bytes:int - -> current:(unit -> bool) - -> (unit, upload_failure) result - -val staged_asset_path - : t - -> scope:Logseq_sync_pure_reducer.Core.graph_scope - -> file:string - -> string option - -val release_staged_asset - : t - -> scope:Logseq_sync_pure_reducer.Core.graph_scope - -> file:string - -> (unit, string) result - -val stage_asset - : t - -> scope:Logseq_sync_pure_reducer.Core.graph_scope - -> operation:Logseq_db_types.Graph_types.Uuid.t - -> file_type:string - -> source_file:string - -> (string * string * int64, string) result - -val prune_staged_assets - : t - -> scope:Logseq_sync_pure_reducer.Core.graph_scope - -> keep:(Logseq_db_types.Graph_types.Uuid.t -> (bool, string) result) - -> (int, string) result - -val retain_staged_file - : t - -> scope:Logseq_sync_pure_reducer.Core.graph_scope - -> file:string - -> (string * string) option diff --git a/logseq_sync/spec/pure_reducer/core.mli b/logseq_sync/spec/pure_reducer/core.mli index 19cd9e8..a488764 100644 --- a/logseq_sync/spec/pure_reducer/core.mli +++ b/logseq_sync/spec/pure_reducer/core.mli @@ -200,6 +200,116 @@ type private_key_unlock = ; private_key_package : string } +type asset_context = + { scope : graph_scope + ; encrypted : bool + ; key : graph_key_handle option + } + +(** Business inputs carry identities and resource references, never asset bytes. *) +type asset_action = + | Check_asset_cache of graph_id * Logseq_db_types.Asset_descriptor.version + | Fetch_asset of + { asset : graph_id + ; version : Logseq_db_types.Asset_descriptor.version + ; maximum_plaintext_bytes : int + } + | Stage_asset_file of + { operation : graph_id + ; file_type : string + ; source_file : string + } + | Put_asset_file of + { asset : graph_id + ; version : Logseq_db_types.Asset_descriptor.version + ; file : string + ; maximum_plaintext_bytes : int + } + | Retain_asset_file of string + | Retain_staged_file of string + | Release_asset_file of string + | Release_staged_file of string + | Prune_asset_staging of string list + | Close_asset_scope + | Delete_graph_assets + | Delete_account_assets + | Asset_retry_after of float + | Cancel_asset_operation of string + +type asset_failure = + | Asset_network + | Asset_not_found + | Asset_checksum_mismatch + | Asset_authentication + | Asset_locked + | Asset_storage_full + | Asset_missing_source + | Asset_size_rejected + | Asset_revoked_access + | Asset_cancelled + | Asset_invalid_content of string + +type asset_value = + | Asset_unit + | Asset_cached of string option + | Asset_downloaded of string + | Asset_staged of + { file : string + ; checksum : string + ; size : int64 + } + | Asset_retained of (string * string) option + | Asset_pruned of int + | Asset_retry_elapsed + +type asset_result = (asset_value, asset_failure) result + +type asset_request = + { scope : graph_scope + ; operation : string + ; action : asset_action + } + +type asset_io_request = + { context : asset_context + ; operation : string + ; action : asset_action + } + +type asset_ticket + +val asset_ticket_id : asset_ticket -> string + +type asset_output = + { request : asset_request + ; result : asset_result + } + +type protected_action = + | Encrypt_values of graph_key_handle * string list + | Decrypt_value of graph_key_handle * string + +type protected_request = + { protected_operation : string + ; protected_scope : graph_scope + ; protected_action : protected_action + } + +type protected_value = + | Encrypted_values of (string * string) list + | Decrypted_value of string + +type protected_result = (protected_value, effect_error) result + +type protected_output = + { protected_request : protected_request + ; protected_result : protected_result + } + +type protected_ticket + +val protected_ticket_id : protected_ticket -> string + type _ runner_request = | Load_catalog : account_scope -> catalog_cache option runner_request | Save_catalog : @@ -244,7 +354,9 @@ type timer_request = ; delay_seconds : float } -type runner_effect = +type runner_effect = private + | Asset_io of asset_ticket * asset_io_request + | Protected_io of protected_ticket * protected_request | Request : 'a effect_ticket * 'a runner_request -> runner_effect | Start_websocket of websocket_request | Send_websocket of websocket_send @@ -253,6 +365,8 @@ type runner_effect = | Cancel_effects of effect_scope type runner_completion = + | Asset_completion of asset_ticket * asset_result + | Protected_completion of protected_ticket * protected_result | Completion : 'a effect_ticket * ('a, effect_error) result -> runner_completion val runner_effect_scope : runner_effect -> effect_scope @@ -315,6 +429,8 @@ type worker_effect = | Apply_authoritative_batch of authoritative_batch type output = + | Asset_finished of asset_output + | Protected_finished of protected_output | State_changed of state | Bootstrap_progressed of bootstrap_progress @@ -361,6 +477,8 @@ type outbox_transition_result = type snapshot_activation = { scope : graph_scope } type event = + | Asset_requested of asset_request + | Protected_requested of protected_request | Restore_local_account of { user_id : string } | Account_authenticated of { user_id : string option } | Local_feed_acknowledged @@ -407,13 +525,6 @@ type create_error = Invalid_create of string val initial : config -> (t, create_error) result val state : t -> state val admitted_graph_scope : t -> graph_scope option - -type asset_context = - { scope : graph_scope - ; encrypted : bool - ; key : graph_key_handle option - } - val asset_context : t -> asset_context option type transition = diff --git a/logseq_sync/test/asset_adapter_memory.ml b/logseq_sync/test/asset_adapter_memory.ml index 085f4c5..f27414f 100644 --- a/logseq_sync/test/asset_adapter_memory.ml +++ b/logseq_sync/test/asset_adapter_memory.ml @@ -99,7 +99,7 @@ let () = ~network:(Eio.Stdenv.net env) ~clock:(Eio.Stdenv.clock env) ~websocket_liveness:R.Disabled)) - ~local_store:(get (R.local_store ~application_support_directory:support)) + ~local_store:(get (R.local_store ~application_support_directory:support ())) ~artifact_store: (get (R.artifact_store @@ -126,6 +126,33 @@ let () = in let context = C.asset_context unlocked |> Option.get in let handle = context.key |> Option.get in + let owner = ref unlocked in + let protected operation action = + posted := []; + let requested = + C.step + !owner + (C.Protected_requested + { protected_operation = operation + ; protected_scope = context.scope + ; protected_action = action + }) + in + List.iter + (function + | C.Run runnable -> R.submit runner runnable + | _ -> ()) + requested.effects; + let completed = C.step requested.next (List.hd !posted) in + owner := completed.next; + List.find_map + (function + | C.Publish (C.Protected_finished output) -> Some output.protected_result + | _ -> None) + completed.effects + |> Option.get + |> get + in List.iter (fun size -> let value = String.init size (fun i -> Char.chr (i mod 128)) in @@ -133,15 +160,21 @@ let () = Transit_native.Transit.Json.to_string (Transit_core.Json.String value) in let iv, ciphertext = - match get (R.encrypt_protected_values runner handle [ plaintext ]) with - | [ pair ] -> pair + match + protected + ("encrypt-" ^ string_of_int size) + (C.Encrypt_values (handle, [ plaintext ])) + with + | C.Encrypted_values [ pair ] -> pair | _ -> failwith "missing encrypted value" in let wire = Transit_native.Transit.Json.to_string (Transit_core.Json.Array [ Binary iv; Binary ciphertext ]) in - if get (R.decrypt_protected_value runner handle wire) <> value + if + protected ("decrypt-" ^ string_of_int size) (C.Decrypt_value (handle, wire)) + <> C.Decrypted_value value then failwith "production adapter roundtrip changed bytes") [ 0; 1; 256; 4097; 131057 ]; let size = 8 * 1024 * 1024 in @@ -152,19 +185,62 @@ let () = get (A.version ~checksum:(Codec.checksum plaintext) ~file_type:"bin") in Gc.full_major (); + let staged = + C.step + !owner + (C.Asset_requested + { scope = context.scope + ; operation = "stage" + ; action = + C.Stage_asset_file + { operation = graph_id; file_type = "bin"; source_file } + }) + in + posted := []; + List.iter + (function + | C.Run runnable -> R.submit runner runnable + | _ -> ()) + staged.effects; + let staged_done = C.step staged.next (List.hd !posted) in + let file = + List.find_map + (function + | C.Publish (C.Asset_finished { result = Ok (C.Asset_staged { file; _ }); _ }) + -> Some file + | _ -> None) + staged_done.effects + |> Option.get + in let before = Gc.allocated_bytes () in + let upload = + C.step + staged_done.next + (C.Asset_requested + { scope = context.scope + ; operation = "upload" + ; action = + C.Put_asset_file + { asset = graph_id; version; file; maximum_plaintext_bytes = size } + }) + in + posted := []; + List.iter + (function + | C.Run runnable -> R.submit runner runnable + | _ -> ()) + upload.effects; + let finished = C.step upload.next (List.hd !posted) in let outcome = - R.upload_asset - runner - ~context - ~asset:graph_id - ~version - ~source_file - ~maximum_plaintext_bytes:size - ~current:(fun () -> true) + List.find_map + (function + | C.Publish (C.Asset_finished output) -> Some output.result + | _ -> None) + finished.effects + |> Option.get in let allocated = Gc.allocated_bytes () -. before in - if outcome <> Error R.Upload_authentication || !auth_calls <> 1 + if outcome <> Error C.Asset_authentication || !auth_calls <> 1 then failwith "production adapter did not encode the maximum-size asset"; Printf.printf "Production upload OCaml allocation bytes: %.0f\n%!" allocated; if allocated > 128. *. 1024. *. 1024. diff --git a/logseq_sync/test/core_contract.ml b/logseq_sync/test/core_contract.ml index ba67aee..be470d9 100644 --- a/logseq_sync/test/core_contract.ml +++ b/logseq_sync/test/core_contract.ml @@ -1452,12 +1452,14 @@ let canonical_overlay_happy_path () = in let hp01_event = Core.Account_authenticated { user_id = Some "user" } in let hp01_preview = preview_step "HP01" origin hp01_event in - let catalog_ticket : Core.graph list Core.effect_ticket = + let (catalog_ticket, catalog_scope) + : Core.graph list Core.effect_ticket * Core.account_scope + = match hp01_preview.effects with | [ Core.Publish (Core.State_changed state) ; Core.Run (Core.Request (ticket, Core.Fetch_catalog scope)) ] - when state = authenticated_state && scope.user_id = "user" -> ticket + when state = authenticated_state && scope.user_id = "user" -> ticket, scope | _ -> Alcotest.fail "HP01 unexpected instruction shape" in let account_scope : Core.account_scope = @@ -1468,15 +1470,9 @@ let canonical_overlay_happy_path () = ; lifecycle_generation = 0L } in + Alcotest.(check bool) "HP01 full account scope" true (catalog_scope = account_scope); let hp01 = - check_step - "HP01" - origin - hp01_event - authenticated_observed - [ Core.Publish (Core.State_changed authenticated_state) - ; Core.Run (Core.Request (catalog_ticket, Core.Fetch_catalog account_scope)) - ] + check_step "HP01" origin hp01_event authenticated_observed hp01_preview.effects in let hp02 = hp01 in let catalogued_startup = @@ -1499,15 +1495,13 @@ let canonical_overlay_happy_path () = let save_catalog_effect = match hp03_preview.effects with | [ Core.Publish (Core.State_changed state) - ; Core.Run (Core.Request (ticket, Core.Save_catalog { account; cache })) + ; (Core.Run (Core.Request (_, Core.Save_catalog { account; cache })) as save_effect) ] when state = catalogued_state && account = account_scope && Core.catalog_cache_user_id cache = "user" && Core.catalog_cache_graphs cache = [ graph ] - && Core.catalog_cache_selected_graph cache = None -> - Core.Run - (Core.Request (ticket, Core.Save_catalog { account = account_scope; cache })) + && Core.catalog_cache_selected_graph cache = None -> save_effect | _ -> Alcotest.fail "HP03 unexpected instruction shape" in let hp03 = @@ -1546,7 +1540,7 @@ let canonical_overlay_happy_path () = match hp04_preview.effects with | [ Core.Delegate (Core.Inspect_mirror request) ; Core.Publish (Core.State_changed state) - ; Core.Run (Core.Request (ticket, Core.Save_catalog { account; cache })) + ; (Core.Run (Core.Request (_, Core.Save_catalog { account; cache })) as save_effect) ] when (request = Core.{ graph; scope = graph_scope }) && state = selected_state @@ -1554,9 +1548,7 @@ let canonical_overlay_happy_path () = && Core.catalog_cache_user_id cache = "user" && Core.catalog_cache_graphs cache = [ graph ] && Core.catalog_cache_selected_graph cache = Some graph_id -> - ( request - , Core.Run - (Core.Request (ticket, Core.Save_catalog { account = account_scope; cache })) ) + request, save_effect | _ -> Alcotest.fail "HP04 unexpected instruction shape" in let hp04 = @@ -1617,15 +1609,13 @@ let canonical_overlay_happy_path () = ; uri = Uri.of_string "wss://api.logseq.io/sync/11111111-1111-4111-8111-111111111111" } in + let hp06_preview = preview_step "HP06" hp05.next hp06_event in + (match hp06_preview.effects with + | [ Core.Publish (Core.State_changed state); Core.Run (Core.Start_websocket request) ] + when state = connecting_state && request = websocket_request -> () + | _ -> Alcotest.fail "HP06 unexpected instruction shape"); let hp06 = - check_step - "HP06" - hp05.next - hp06_event - connecting_observed - [ Core.Publish (Core.State_changed connecting_state) - ; Core.Run (Core.Start_websocket websocket_request) - ] + check_step "HP06" hp05.next hp06_event connecting_observed hp06_preview.effects in let hp07 = hp06 in let pulling0_state = @@ -1636,19 +1626,18 @@ let canonical_overlay_happy_path () = let pulling0_observed = { state = pulling0_state; admitted_graph_scope = Some graph_scope } in - let pull0 = - Core.Run - (Core.Send_websocket - { scope = connection; message = Protocol.Client.Pull { since = Some 0 } }) - in let hp08_event = Core.Websocket_opened connection in + let hp08_preview = preview_step "HP08" hp07.next hp08_event in + (match hp08_preview.effects with + | [ Core.Publish (Core.State_changed state) + ; Core.Run (Core.Send_websocket { scope; message }) + ] + when state = pulling0_state + && scope = connection + && message = Protocol.Client.Pull { since = Some 0 } -> () + | _ -> Alcotest.fail "HP08 unexpected instruction shape"); let hp08 = - check_step - "HP08" - hp07.next - hp08_event - pulling0_observed - [ Core.Publish (Core.State_changed pulling0_state); pull0 ] + check_step "HP08" hp07.next hp08_event pulling0_observed hp08_preview.effects in let remote_tx : Protocol.Server.pull_transaction = { t = 1; tx = "[]"; outliner_op = Some "save-block" } @@ -1833,23 +1822,19 @@ let canonical_overlay_happy_path () = Core.Outbox_transition_applied { scope = submit_request.scope; commit = submit_commit; sync = submitted_sync } in + let hp13_preview = preview_step "HP13" hp12.next hp13_event in let hp13 = - let timer = - match (Core.step hp12.next hp13_event).effects with - | [ Core.Run (Core.Send_websocket _); Core.Run (Core.Schedule_timer timer) ] - when timer.delay_seconds = 30. - && timer.scope.connection_generation = Some connection.connection_generation - -> timer - | _ -> Alcotest.fail "HP13 submission omitted its scoped response timeout" - in - check_step - "HP13" - hp12.next - hp13_event - submitting_observed - [ Core.Run (Core.Send_websocket { scope = connection; message = tx_message }) - ; Core.Run (Core.Schedule_timer timer) - ] + (match hp13_preview.effects with + | [ Core.Run (Core.Send_websocket { scope; message }) + ; Core.Run (Core.Schedule_timer timer) + ] + when scope = connection + && message = tx_message + && timer.delay_seconds = 30. + && timer.scope.connection_generation = Some connection.connection_generation + -> () + | _ -> Alcotest.fail "HP13 submission omitted its scoped response timeout"); + check_step "HP13" hp12.next hp13_event submitting_observed hp13_preview.effects in let hp14_event = Core.Websocket_message @@ -1916,17 +1901,17 @@ let canonical_overlay_happy_path () = Core.Outbox_transition_applied { scope = accept_request.scope; commit = accept_commit; sync = accepted_sync } in + let hp15_preview = preview_step "HP15" hp14.next hp15_event in + (match hp15_preview.effects with + | [ Core.Publish (Core.State_changed state) + ; Core.Run (Core.Send_websocket { scope; message }) + ] + when state = pulling1_state + && scope = connection + && message = Protocol.Client.Pull { since = Some 1 } -> () + | _ -> Alcotest.fail "HP15 unexpected instruction shape"); let hp15 = - check_step - "HP15" - hp14.next - hp15_event - pulling1_observed - [ Core.Publish (Core.State_changed pulling1_state) - ; Core.Run - (Core.Send_websocket - { scope = connection; message = Protocol.Client.Pull { since = Some 1 } }) - ] + check_step "HP15" hp14.next hp15_event pulling1_observed hp15_preview.effects in let incorporated_tx : Protocol.Server.pull_transaction = { t = 2; tx = "[]"; outliner_op = Some "save-block" } @@ -3625,3 +3610,474 @@ let scenarios = whole_batch_invalid_tx_partitions_every_member ] ;; + +(* Core owns admission and acceptance; filesystem execution is tested by the runner. *) +let asset_version = + Logseq_db_types.Asset_descriptor.version ~checksum:(String.make 64 'a') ~file_type:"bin" + |> Result.get_ok +;; + +let asset_fixture () = + let selected, scope = selected_graph graph in + selected.next, scope +;; + +let asset_issue core scope operation action = + let request : Core.asset_request = { scope; operation; action } in + let transition = Core.step core (Core.Asset_requested request) in + let ticket = + List.find_map + (function + | Core.Run (Core.Asset_io (ticket, io)) when io.operation = operation -> + Some ticket + | _ -> None) + transition.effects + |> Option.get + in + transition, ticket, request +;; + +let asset_outputs effects = + List.filter_map + (function + | Core.Publish (Core.Asset_finished output) -> Some output + | _ -> None) + effects +;; + +let asset_complete core ticket result = + Core.step core (Core.Runner_completed (Core.Asset_completion (ticket, result))) +;; + +let asset_accepts_exact_identity_once () = + let core, scope = asset_fixture () in + let first, ticket, request = + asset_issue core scope "cache-1" (Core.Check_asset_cache (graph_id, asset_version)) + in + Alcotest.(check int) + "request emits no premature result" + 0 + (List.length (asset_outputs first.effects)); + let second, other, other_request = + asset_issue + first.next + scope + "cache-2" + (Core.Check_asset_cache (graph_id, asset_version)) + in + let completed = asset_complete second.next other (Ok (Core.Asset_cached None)) in + Alcotest.(check bool) + "second ticket resolves only second operation" + true + (asset_outputs completed.effects + = [ { Core.request = other_request; result = Ok (Core.Asset_cached None) } ]); + let first_done = asset_complete completed.next ticket (Ok (Core.Asset_cached None)) in + Alcotest.(check bool) + "first ticket remains pending" + true + (asset_outputs first_done.effects + = [ { Core.request; result = Ok (Core.Asset_cached None) } ]); + let repeated = asset_complete first_done.next ticket (Ok (Core.Asset_cached None)) in + check_instructions "asset completion replay" [] repeated.effects +;; + +let asset_rejects_foreign_scope_and_duplicate_request () = + let core, scope = asset_fixture () in + let pending, _, _ = + asset_issue + core + scope + "same" + (Core.Fetch_asset + { asset = graph_id; version = asset_version; maximum_plaintext_bytes = 32 }) + in + let duplicate = + Core.step + pending.next + (Core.Asset_requested + { scope + ; operation = "same" + ; action = + Core.Fetch_asset + { asset = graph_id; version = asset_version; maximum_plaintext_bytes = 32 } + }) + in + Alcotest.(check bool) + "duplicate request does not execute twice" + false + (List.exists + (function + | Core.Run (Core.Asset_io _) -> true + | _ -> false) + duplicate.effects); + let foreign_scopes = + [ { scope with graph_generation = scope.graph_generation + 1 } + ; { scope with graph_id = other_graph_id } + ; { scope with + account = + { scope.account with account_generation = scope.account.account_generation + 1 } + } + ; { scope with + account = + { scope.account with + presentation_generation = scope.account.presentation_generation + 1 + } + } + ; { scope with + account = + { scope.account with + lifecycle_generation = Int64.succ scope.account.lifecycle_generation + } + } + ; { scope with account = { scope.account with user_id = "other-account" } } + ; { scope with + account = + { scope.account with + managed_sync_origin = Uri.of_string "https://other-origin.invalid" + } + } + ] + in + List.iter + (fun foreign_scope -> + let rejected = + Core.step + duplicate.next + (Core.Asset_requested + { scope = foreign_scope + ; operation = "foreign" + ; action = + Core.Fetch_asset + { asset = graph_id + ; version = asset_version + ; maximum_plaintext_bytes = 32 + } + }) + in + Alcotest.(check bool) + "foreign scope identity cannot execute IO" + false + (List.exists + (function + | Core.Run (Core.Asset_io _) -> true + | _ -> false) + rejected.effects)) + foreign_scopes +;; + +let asset_failure_is_published_once () = + let core, scope = asset_fixture () in + let pending, ticket, request = + asset_issue + core + scope + "failed" + (Core.Put_asset_file + { asset = graph_id + ; version = asset_version + ; file = "resource" + ; maximum_plaintext_bytes = 32 + }) + in + let failed = asset_complete pending.next ticket (Error Core.Asset_network) in + Alcotest.(check bool) + "typed failure preserves request identity" + true + (asset_outputs failed.effects + = [ { Core.request; result = Error Core.Asset_network } ]); + let repeated = asset_complete failed.next ticket (Error Core.Asset_network) in + check_instructions "asset failure replay" [] repeated.effects +;; + +let asset_cancelled_completion_cleans_resources () = + List.iter + (fun (action, value, cleanup) -> + let core, scope = asset_fixture () in + let pending, ticket, _ = asset_issue core scope "cancelled" action in + let cancelled, _, _ = + asset_issue pending.next scope "cancel" (Core.Cancel_asset_operation "cancelled") + in + let late = asset_complete cancelled.next ticket (Ok value) in + Alcotest.(check int) + "cancelled work never publishes success" + 0 + (List.length (asset_outputs late.effects)); + Alcotest.(check bool) + "cancelled completion releases its resource" + true + (List.exists + (function + | Core.Run (Core.Asset_io (_, io)) -> io.action = cleanup + | _ -> false) + late.effects)) + [ ( Core.Fetch_asset + { asset = graph_id; version = asset_version; maximum_plaintext_bytes = 32 } + , Core.Asset_downloaded "file" + , Core.Release_asset_file "file" ) + ; ( Core.Stage_asset_file + { operation = graph_id; file_type = "bin"; source_file = "source" } + , Core.Asset_staged { file = "stage"; checksum = String.make 64 'a'; size = 4L } + , Core.Release_staged_file "stage" ) + ; ( Core.Retain_asset_file "file" + , Core.Asset_retained (Some ("lease", "path")) + , Core.Release_asset_file "lease" ) + ] +;; + +let asset_scope_switch_cleans_late_resources () = + List.iter + (fun (action, result, cleanup) -> + let core, scope = asset_fixture () in + let pending, ticket, _ = asset_issue core scope "old-resource" action in + let picker = Core.step pending.next Core.Graph_picker_requested in + let late = asset_complete picker.next ticket (Ok result) in + Alcotest.(check int) + "old graph publishes no resource" + 0 + (List.length (asset_outputs late.effects)); + Alcotest.(check bool) + "old graph resource is released via runner effect" + true + (List.exists + (function + | Core.Run (Core.Asset_io (_, io)) -> io.action = cleanup + | _ -> false) + late.effects)) + [ ( Core.Fetch_asset + { asset = graph_id; version = asset_version; maximum_plaintext_bytes = 32 } + , Core.Asset_downloaded "late-file" + , Core.Release_asset_file "late-file" ) + ; ( Core.Stage_asset_file + { operation = graph_id; file_type = "bin"; source_file = "source" } + , Core.Asset_staged + { file = "late-stage"; checksum = String.make 64 'a'; size = 4L } + , Core.Release_staged_file "late-stage" ) + ; ( Core.Retain_asset_file "file" + , Core.Asset_retained (Some ("late-lease", "path")) + , Core.Release_asset_file "late-lease" ) + ] +;; + +let asset_mismatched_completion_cleans_resource () = + let core, scope = asset_fixture () in + let pending, ticket, _ = + asset_issue core scope "cache" (Core.Check_asset_cache (graph_id, asset_version)) + in + let wrong = + asset_complete + pending.next + ticket + (Ok + (Core.Asset_staged + { file = "unexpected-stage"; checksum = String.make 64 'a'; size = 4L })) + in + Alcotest.(check bool) + "wrong resource kind is not accepted" + true + (match asset_outputs wrong.effects with + | [ { result = Error (Core.Asset_invalid_content _); _ } ] -> true + | _ -> false); + Alcotest.(check bool) + "wrong resource is cleaned through runner" + true + (List.exists + (function + | Core.Run (Core.Asset_io (_, io)) -> + io.action = Core.Release_staged_file "unexpected-stage" + | _ -> false) + wrong.effects) +;; + +let asset_retry_completion_is_consumed_once () = + let core, scope = asset_fixture () in + let pending, ticket, request = + asset_issue core scope "retry" (Core.Asset_retry_after 0.1) + in + let elapsed = asset_complete pending.next ticket (Ok Core.Asset_retry_elapsed) in + Alcotest.(check bool) + "timer returns to requesting owner" + true + (asset_outputs elapsed.effects + = [ { Core.request; result = Ok Core.Asset_retry_elapsed } ]); + let duplicate = asset_complete elapsed.next ticket (Ok Core.Asset_retry_elapsed) in + check_instructions "asset timer replay" [] duplicate.effects +;; + +let asset_cleanup_requires_admitted_scope () = + let core, scope = asset_fixture () in + let foreign = + { scope with account = { scope.account with user_id = "forged-account" } } + in + List.iter + (fun action -> + let rejected = + Core.step + core + (Core.Asset_requested { scope = foreign; operation = "forged-cleanup"; action }) + in + Alcotest.(check bool) + "foreign account cannot execute destructive or resource cleanup" + false + (List.exists + (function + | Core.Run (Core.Asset_io _) -> true + | _ -> false) + rejected.effects); + Alcotest.(check bool) + "rejected cleanup reports its own cancelled identity" + true + (match asset_outputs rejected.effects with + | [ output ] -> + output.request.scope = foreign && output.result = Error Core.Asset_cancelled + | _ -> false)) + [ Core.Release_asset_file "resource" + ; Core.Release_staged_file "stage" + ; Core.Close_asset_scope + ; Core.Delete_graph_assets + ; Core.Delete_account_assets + ; Core.Cancel_asset_operation "pending" + ]; + let picker = Core.step core Core.Graph_picker_requested in + List.iter + (fun action -> + let accepted = + Core.step + picker.next + (Core.Asset_requested { scope; operation = "known-cleanup"; action }) + in + Alcotest.(check bool) + "previously admitted scope still permits required cleanup" + true + (List.exists + (function + | Core.Run (Core.Asset_io (_, io)) -> + io.context.scope = scope && io.action = action + | _ -> false) + accepted.effects)) + [ Core.Release_asset_file "resource" + ; Core.Release_staged_file "stage" + ; Core.Close_asset_scope + ] +;; + +let asset_deletion_cancels_stage core scope deletion_scope action = + let pending, ticket, request = + asset_issue + core + scope + "stage-before-deletion" + (Core.Stage_asset_file + { operation = graph_id; file_type = "bin"; source_file = "source" }) + in + let deleting, _, _ = asset_issue pending.next deletion_scope "delete-assets" action in + let late = + asset_complete + deleting.next + ticket + (Ok + (Core.Asset_staged + { file = "late-deleted-stage"; checksum = String.make 64 'a'; size = 4L })) + in + Alcotest.(check int) + "deleted asset operation cannot publish late staging success" + 0 + (List.length (asset_outputs late.effects)); + Alcotest.(check bool) + "deletion cancels the exact pending staging request" + true + (asset_outputs deleting.effects + = [ { Core.request; result = Error Core.Asset_cancelled } ]); + Alcotest.(check bool) + "late staging completion cleans through the original resource scope" + true + (List.exists + (function + | Core.Run (Core.Asset_io (_, io)) -> + io.context.scope = scope + && io.action = Core.Release_staged_file "late-deleted-stage" + | _ -> false) + late.effects); + let repeated = + asset_complete + late.next + ticket + (Ok + (Core.Asset_staged + { file = "late-deleted-stage"; checksum = String.make 64 'a'; size = 4L })) + in + check_instructions "deleted staging completion replay" [] repeated.effects +;; + +let asset_graph_deletion_cancels_other_generation () = + let core, scope = asset_fixture () in + asset_deletion_cancels_stage + core + scope + { scope with graph_generation = 0 } + Core.Delete_graph_assets +;; + +let asset_account_deletion_cancels_other_known_graph () = + let core, old_scope = asset_fixture () in + let catalogued = refresh_catalog core [ graph; other_graph ] in + let picker = Core.step catalogued.next Core.Graph_picker_requested in + let selected = Core.step picker.next (Core.Graph_selected other_graph_id) in + let current_scope = Core.admitted_graph_scope selected.next |> Option.get in + Alcotest.(check bool) + "account deletion fixture keeps the same account across graph selection" + true + (Uri.equal + current_scope.account.managed_sync_origin + old_scope.account.managed_sync_origin + && String.equal current_scope.account.user_id old_scope.account.user_id + && current_scope.graph_id <> old_scope.graph_id); + asset_deletion_cancels_stage + selected.next + current_scope + old_scope + Core.Delete_account_assets +;; + +let asset_scenarios = + [ Alcotest.test_case + "graph asset deletion cancels pending work across generations" + `Quick + asset_graph_deletion_cancels_other_generation + ; Alcotest.test_case + "account asset deletion cancels pending work on another known graph" + `Quick + asset_account_deletion_cancels_other_known_graph + ; Alcotest.test_case + "asset cleanup rejects foreign account and accepts retired known scope" + `Quick + asset_cleanup_requires_admitted_scope + ; Alcotest.test_case + "asset exact completion identity and replay" + `Quick + asset_accepts_exact_identity_once + ; Alcotest.test_case + "asset foreign scope and duplicate admission" + `Quick + asset_rejects_foreign_scope_and_duplicate_request + ; Alcotest.test_case + "asset failure resolves once" + `Quick + asset_failure_is_published_once + ; Alcotest.test_case + "asset cancellation cleans file staging and lease" + `Quick + asset_cancelled_completion_cleans_resources + ; Alcotest.test_case + "asset scope switch cleans stale resources" + `Quick + asset_scope_switch_cleans_late_resources + ; Alcotest.test_case + "asset mismatched completion cleans resource" + `Quick + asset_mismatched_completion_cleans_resource + ; Alcotest.test_case + "asset retry completion resolves once" + `Quick + asset_retry_completion_is_consumed_once + ] +;; diff --git a/logseq_sync/test/runner_contract.ml b/logseq_sync/test/runner_contract.ml index df221a2..78f18a6 100644 --- a/logseq_sync/test/runner_contract.ml +++ b/logseq_sync/test/runner_contract.ml @@ -61,6 +61,21 @@ let core ?(origin = Uri.of_string "https://api.logseq.io") () = |> Result.get_ok ;; +let load_catalog_transition () = + Core.step (core ()) (Restore_local_account { user_id = "user-1" }) +;; + +let cancellation_effect () = + let restoring = load_catalog_transition () in + let cancelled = Core.step restoring.next Core.Shutdown in + List.find_map + (function + | Core.Run (Core.Cancel_effects _ as runnable) -> Some runnable + | _ -> None) + cancelled.effects + |> Option.get +;; + let load_catalog_effect () = Core.step (core ()) (Restore_local_account { user_id = "user-1" }) |> fun transition -> @@ -73,7 +88,15 @@ let load_catalog_effect () = |> Option.get ;; -let dependencies ?secrets_dependency ?crypto_dependency ~environment ~support ~fork () = +let dependencies + ?secrets_dependency + ?crypto_dependency + ?id_token_dependency + ~environment + ~support + ~fork + () + = let runtime = Runner.runtime ~fork ~sleep:(fun _ -> ()) |> Result.get_ok in let transport = Runner.transport @@ -84,7 +107,7 @@ let dependencies ?secrets_dependency ?crypto_dependency ~environment ~support ~f |> Result.get_ok in let local_store = - Runner.local_store ~application_support_directory:support |> Result.get_ok + Runner.local_store ~application_support_directory:support () |> Result.get_ok in let artifact_store = Runner.artifact_store ~staging_directory:(Filename.concat support "staging") @@ -98,9 +121,12 @@ let dependencies ?secrets_dependency ?crypto_dependency ~environment ~support ~f ~secrets:(Option.value secrets_dependency ~default:(secrets ())) ~crypto:(Option.value crypto_dependency ~default:(crypto ())) ~id_token_provider: - (Runner.id_token_provider - ~acquire:(fun _ -> Ok "test-id-token") - ~invalidate:(fun _ ~token:_ -> ())) + (Option.value + id_token_dependency + ~default: + (Runner.id_token_provider + ~acquire:(fun _ -> Ok "test-id-token") + ~invalidate:(fun _ ~token:_ -> ()))) |> Result.get_ok ;; @@ -214,7 +240,7 @@ let test_cancelled_queued_catalog_save_does_not_write () = |> Option.get in Runner.submit runner save; - Runner.submit runner (Core.Cancel_effects (Core.runner_effect_scope save)); + Runner.submit runner (cancellation_effect ()); List.iter (fun task -> task ()) (List.rev !tasks); Alcotest.(check bool) "cancelled save has no durable side effects" @@ -275,7 +301,7 @@ let test_dependency_constructors_validate_owned_resources () = Alcotest.bool "missing application support directory is rejected" true - (Result.is_error (Runner.local_store ~application_support_directory:missing))) + (Result.is_error (Runner.local_store ~application_support_directory:missing ()))) ;; let test_submit_is_async_and_posts_a_typed_completion () = @@ -323,7 +349,7 @@ let test_cancellation_suppresses_late_completion () = in let instruction = load_catalog_effect () in Runner.submit runner instruction; - Runner.submit runner (Core.Cancel_effects (Core.runner_effect_scope instruction)); + Runner.submit runner (cancellation_effect ()); List.iter (fun task -> task ()) (List.rev !tasks); Alcotest.(check int) "cancelled work posts no late completion" @@ -335,6 +361,47 @@ let test_cancellation_suppresses_late_completion () = Alcotest.(check int) "shutdown rejects new work" 0 (List.length !posted)))) ;; +let protected_run runner ~tasks ~posted core operation scope action = + tasks := []; + posted := []; + let transition = + Core.step + core + (Core.Protected_requested + { protected_operation = operation + ; protected_scope = scope + ; protected_action = action + }) + in + List.iter + (function + | Core.Run runnable -> Runner.submit runner runnable + | _ -> ()) + transition.effects; + let queued = List.rev !tasks in + tasks := []; + List.iter (fun task -> task ()) queued; + let finished = + List.fold_left (fun core event -> (Core.step core event).next) transition.next !posted + in + let outputs = + List.concat_map + (fun event -> + let completed = Core.step transition.next event in + List.filter_map + (function + | Core.Publish (Core.Protected_finished output) -> + Some output.protected_result + | _ -> None) + completed.effects) + !posted + in + ignore finished; + match outputs with + | [ result ] -> result + | _ -> fail "protected request did not resolve through Core output" +;; + let test_cached_wrapped_key_is_unlocked_before_protected_value_decryption () = with_support (fun support -> Eio_main.run (fun environment -> @@ -392,13 +459,15 @@ let test_cached_wrapped_key_is_unlocked_before_protected_value_decryption () = Runner.create ~sw dependencies ~post:(fun event -> posted := event :: !posted) |> Result.get_ok in - let _, instruction = cached_key_effect () in + let before, instruction = cached_key_effect () in let handle = match instruction with | Core.Request (ticket, Core.Load_and_unlock_graph_key scope) -> Core.graph_key_handle ~id:("graph-key-" ^ Core.effect_id_to_string (Core.effect_ticket_id ticket)) ~scope + | Asset_io _ + | Protected_io _ | Request _ | Start_websocket _ | Send_websocket _ @@ -420,10 +489,23 @@ let test_cached_wrapped_key_is_unlocked_before_protected_value_decryption () = ; Transit_core.Json.Binary "ciphertext-and-tag" ]) in - Alcotest.(check (result string string)) + let unlocked = + match !posted with + | [ event ] -> (Core.step before.next event).next + | _ -> fail "missing key completion" + in + Alcotest.(check bool) "returned handle decrypts with the raw graph key" - (Ok "plaintext") - (Runner.decrypt_protected_value runner handle ciphertext)))) + true + (protected_run + runner + ~tasks + ~posted + unlocked + "decrypt-cached" + (Core.graph_key_handle_scope handle) + (Core.Decrypt_value (handle, ciphertext)) + = Ok (Core.Decrypted_value "plaintext"))))) ;; let test_cached_wrapped_key_unlock_failure_is_fail_closed () = @@ -470,6 +552,8 @@ let test_cached_wrapped_key_unlock_failure_is_fail_closed () = Core.graph_key_handle ~id:("graph-key-" ^ Core.effect_id_to_string (Core.effect_ticket_id ticket)) ~scope + | Asset_io _ + | Protected_io _ | Request _ | Start_websocket _ | Send_websocket _ @@ -502,10 +586,21 @@ let test_cached_wrapped_key_unlock_failure_is_fail_closed () = | Core.Run (Core.Request (_, Core.Fetch_e2ee_graph_key _)) -> true | Run _ | Delegate _ | Publish _ -> false) recovery.effects); - Alcotest.(check (result string string)) + Alcotest.(check bool) "failed cached key is not stored as a usable handle" - (Error "graph key handle is unavailable or out of scope") - (Runner.decrypt_protected_value runner handle "plaintext")))) + true + (match + protected_run + runner + ~tasks + ~posted + failed.next + "decrypt-failed" + (Core.graph_key_handle_scope handle) + (Core.Decrypt_value (handle, "plaintext")) + with + | Error (Core.Effect_failed _) -> true + | _ -> false)))) ;; let account_deletion_effect () = @@ -517,8 +612,8 @@ let account_deletion_effect () = in List.find_map (function - | Core.Run (Core.Request (ticket, Core.Delete_account_secrets account)) -> - Some (Core.Request (ticket, Core.Delete_account_secrets account)) + | Core.Run (Core.Request (_, Core.Delete_account_secrets _) as runnable) -> + Some runnable | Run _ | Delegate _ | Publish _ -> None) signed_out.effects |> Option.get @@ -687,8 +782,8 @@ let private_key_unlock_and_sign_out () = let unlock = List.find_map (function - | Core.Run (Core.Request (ticket, Core.Unlock_private_key request)) -> - Some (Core.Request (ticket, Core.Unlock_private_key request)) + | Core.Run (Core.Request (_, Core.Unlock_private_key _) as runnable) -> + Some runnable | Run _ | Delegate _ | Publish _ -> None) unlocking.effects |> Option.get @@ -764,89 +859,6 @@ let test_secret_cleanup_is_serialized_after_an_older_write () = (List.rev !order)))) ;; -let authentication_policy_provider tokens invalidated = - Runner.id_token_provider - ~acquire:(fun _ -> - match Queue.take_opt tokens with - | Some token -> Ok token - | None -> Error "no token") - ~invalidate:(fun _ ~token -> invalidated := token :: !invalidated) -;; - -let authentication_policy_account : Core.account_scope = - { managed_sync_origin = Uri.of_string "https://api.logseq.io" - ; user_id = "user-1" - ; account_generation = 1 - ; presentation_generation = 1 - ; lifecycle_generation = 1L - } -;; - -let test_authenticated_operation_retries_one_unauthorized_response () = - let tokens = Queue.create () in - Queue.add "token-1" tokens; - Queue.add "token-2" tokens; - let invalidated = ref [] in - let attempts = ref [] in - let result = - Runner.authenticated_operation - (authentication_policy_provider tokens invalidated) - ~account:authentication_policy_account - ~perform:(fun token -> - attempts := token :: !attempts; - if String.equal token "token-1" then Error Runner.Unauthorized else Ok "done") - in - Alcotest.(check (result string string)) "retry succeeds" (Ok "done") result; - Alcotest.(check (list string)) - "one refreshed attempt" - [ "token-1"; "token-2" ] - (List.rev !attempts); - Alcotest.(check (list string)) "used token invalidated" [ "token-1" ] !invalidated -;; - -let test_authenticated_operation_surfaces_second_unauthorized_response () = - let tokens = Queue.create () in - Queue.add "token-1" tokens; - Queue.add "token-2" tokens; - let invalidated = ref [] in - let attempts = ref 0 in - let result = - Runner.authenticated_operation - (authentication_policy_provider tokens invalidated) - ~account:authentication_policy_account - ~perform:(fun _ -> - incr attempts; - Error Runner.Unauthorized) - in - Alcotest.(check (result string string)) - "second unauthorized is terminal" - (Error "Authentication failed.") - result; - Alcotest.check Alcotest.int "at most two attempts" 2 !attempts; - Alcotest.(check (list string)) "only first token invalidated" [ "token-1" ] !invalidated -;; - -let test_authenticated_operation_does_not_retry_forbidden_response () = - let tokens = Queue.create () in - Queue.add "token-1" tokens; - let invalidated = ref [] in - let attempts = ref 0 in - let result = - Runner.authenticated_operation - (authentication_policy_provider tokens invalidated) - ~account:authentication_policy_account - ~perform:(fun _ -> - incr attempts; - Error Runner.Forbidden) - in - Alcotest.(check (result string string)) - "forbidden is terminal" - (Error "Authorization failed.") - result; - Alcotest.check Alcotest.int "one attempt" 1 !attempts; - Alcotest.(check (list string)) "token remains reusable" [] !invalidated -;; - let source_contents relative alternatives = let candidates = relative :: alternatives in match List.find_opt Sys.file_exists candidates with @@ -928,21 +940,984 @@ let scenarios = "secret cleanup is serialized after older writes" `Quick test_secret_cleanup_is_serialized_after_an_older_write - ; Alcotest.test_case - "authenticated operation retries one unauthorized response" - `Quick - test_authenticated_operation_retries_one_unauthorized_response - ; Alcotest.test_case - "authenticated operation surfaces a second unauthorized response" - `Quick - test_authenticated_operation_surfaces_second_unauthorized_response - ; Alcotest.test_case - "authenticated operation does not retry forbidden response" - `Quick - test_authenticated_operation_does_not_retry_forbidden_response ; Alcotest.test_case "runner source has no placeholder capabilities" `Quick test_runner_source_has_no_placeholder_capabilities ] ;; + +(* These assertions execute staging/lease filesystem ownership, which pure Core + cannot reproduce; policy acceptance itself is covered by Core_contract. *) +let test_asset_local_lifecycle_uses_completion_outputs () = + with_support (fun support -> + Eio_main.run (fun environment -> + Eio.Switch.run (fun sw -> + let tasks = ref [] + and posted = ref [] in + let deps = + dependencies + ~environment + ~support + ~fork:(fun ~sw:_ task -> tasks := task :: !tasks) + () + in + let runner = + Runner.create ~sw deps ~post:(fun event -> posted := event :: !posted) + |> Result.get_ok + in + let selected, scope = Core_contract.selected_graph Core_contract.graph in + let core = ref selected.next in + let rec pump outputs = + match !tasks, !posted with + | [], [] -> List.rev outputs + | task :: rest, _ -> + tasks := rest; + task (); + pump outputs + | [], event :: rest -> + posted := rest; + let transition = Core.step !core event in + core := transition.next; + let outputs = + List.fold_left + (fun outputs -> function + | Core.Run runnable -> + Runner.submit runner runnable; + outputs + | Core.Publish (Core.Asset_finished output) -> output :: outputs + | _ -> outputs) + outputs + transition.effects + in + pump outputs + in + let request operation action = + let transition = + Core.step !core (Core.Asset_requested { scope; operation; action }) + in + core := transition.next; + List.iter + (function + | Core.Run runnable -> Runner.submit runner runnable + | _ -> ()) + transition.effects; + match pump [] with + | [ output ] -> output.Core.result + | _ -> fail "local asset action did not resolve through Core" + in + let source_file = Filename.concat support "import-source.bin" in + Out_channel.with_open_bin source_file (fun out -> output_string out "local asset"); + let file, checksum = + match + request + "stage" + (Core.Stage_asset_file + { operation = graph_id (); file_type = "bin"; source_file }) + with + | Ok (Core.Asset_staged { file; checksum; size }) -> + Alcotest.(check int64) "staging returns metadata" 11L size; + file, checksum + | _ -> fail "staging did not complete" + in + let lease, path = + match request "retain" (Core.Retain_staged_file file) with + | Ok (Core.Asset_retained (Some (lease, path))) -> lease, path + | _ -> fail "staging lease did not complete" + in + Alcotest.(check bool) + "controlled lease resolves existing path" + true + (Sys.file_exists path); + Alcotest.(check bool) + "release lease completes" + true + (request "release-lease" (Core.Release_asset_file lease) = Ok Core.Asset_unit); + Alcotest.(check bool) + "release staging completes" + true + (request "release-stage" (Core.Release_staged_file file) = Ok Core.Asset_unit); + Alcotest.(check bool) "released staging is removed" false (Sys.file_exists path); + let version = + Logseq_db_types.Asset_descriptor.version ~checksum ~file_type:"bin" + |> Result.get_ok + in + Alcotest.(check bool) + "cache miss passes through Core output" + true + (request "cache" (Core.Check_asset_cache (graph_id (), version)) + = Ok (Core.Asset_cached None)); + Alcotest.(check bool) + "prune passes through Core output" + true + (match request "prune" (Core.Prune_asset_staging []) with + | Ok (Core.Asset_pruned _) -> true + | _ -> false); + Alcotest.(check bool) + "retry timer passes through Core output" + true + (request "timer" (Core.Asset_retry_after 0.25) = Ok Core.Asset_retry_elapsed); + Alcotest.(check bool) + "scope close completes" + true + (request "close" Core.Close_asset_scope = Ok Core.Asset_unit); + Alcotest.(check bool) + "graph deletion completes" + true + (request "delete-graph" Core.Delete_graph_assets = Ok Core.Asset_unit); + Alcotest.(check bool) + "account deletion completes" + true + (request "delete-account" Core.Delete_account_assets = Ok Core.Asset_unit); + Runner.shutdown runner))) +;; + +let scenarios = + scenarios + @ [ Alcotest.test_case + "asset local IO resolves through Core outputs" + `Quick + test_asset_local_lifecycle_uses_completion_outputs + ] +;; + +(* Core cannot prevent a runner from executing the same submitted capability twice. + Re-execution of Retain would mint an unaccepted lease and strand staging cleanup. *) +let test_asset_submit_replay_does_not_mint_a_second_lease () = + with_support (fun support -> + Eio_main.run (fun environment -> + Eio.Switch.run (fun sw -> + let tasks = ref [] + and posted = ref [] in + let deps = + dependencies + ~environment + ~support + ~fork:(fun ~sw:_ task -> tasks := task :: !tasks) + () + in + let runner = + Runner.create ~sw deps ~post:(fun event -> posted := event :: !posted) + |> Result.get_ok + in + let selected, scope = Core_contract.selected_graph Core_contract.graph in + let run_tasks () = + while !tasks <> [] do + let batch = List.rev !tasks in + tasks := []; + List.iter (fun task -> task ()) batch + done + in + let complete transition = + posted := []; + List.iter + (function + | Core.Run runnable -> Runner.submit runner runnable + | _ -> ()) + transition.Core.effects; + run_tasks (); + match List.rev !posted with + | [ event ] -> Core.step transition.next event + | _ -> fail "resource command did not post one completion" + in + let source_file = Filename.concat support "replay-source.bin" in + Out_channel.with_open_bin source_file (fun out -> output_string out "replay"); + let stage = + complete + (Core.step + selected.next + (Core.Asset_requested + { scope + ; operation = "replay-stage" + ; action = + Core.Stage_asset_file + { operation = graph_id (); file_type = "bin"; source_file } + })) + in + let file = + List.find_map + (function + | Core.Publish + (Core.Asset_finished { result = Ok (Core.Asset_staged { file; _ }); _ }) + -> Some file + | _ -> None) + stage.effects + |> Option.get + in + let retaining = + Core.step + stage.next + (Core.Asset_requested + { scope + ; operation = "replay-retain" + ; action = Core.Retain_staged_file file + }) + in + let runnable = + List.find_map + (function + | Core.Run (Core.Asset_io _ as runnable) -> Some runnable + | _ -> None) + retaining.effects + |> Option.get + in + let retained = complete retaining in + let lease, path = + List.find_map + (function + | Core.Publish + (Core.Asset_finished + { result = Ok (Core.Asset_retained (Some retained)); _ }) -> + Some retained + | _ -> None) + retained.effects + |> Option.get + in + posted := []; + Runner.submit runner runnable; + run_tasks (); + Alcotest.(check int) + "accepted effect replay creates no new completion or lease" + 0 + (List.length !posted); + let released = + complete + (Core.step + retained.next + (Core.Asset_requested + { scope + ; operation = "replay-release-lease" + ; action = Core.Release_asset_file lease + })) + in + ignore + (complete + (Core.step + released.next + (Core.Asset_requested + { scope + ; operation = "replay-release-stage" + ; action = Core.Release_staged_file file + }))); + Alcotest.(check bool) + "original lease release permits final staging cleanup" + false + (Sys.file_exists path); + Runner.shutdown runner))) +;; + +let scenarios = + scenarios + @ [ Alcotest.test_case + "asset submit replay cannot mint a second lease" + `Quick + test_asset_submit_replay_does_not_mint_a_second_lease + ] +;; + +let test_asset_cleanup_survives_shutdown_before_queued_fork () = + with_support (fun support -> + Eio_main.run (fun environment -> + Eio.Switch.run (fun sw -> + let tasks = ref [] + and posted = ref [] in + let deps = + dependencies + ~environment + ~support + ~fork:(fun ~sw:_ task -> tasks := task :: !tasks) + () + in + let runner = + Runner.create ~sw deps ~post:(fun event -> posted := event :: !posted) + |> Result.get_ok + in + let selected, scope = Core_contract.selected_graph Core_contract.graph in + let core = ref selected.next in + let drain () = + while !tasks <> [] do + let batch = List.rev !tasks in + tasks := []; + List.iter (fun task -> task ()) batch + done + in + let request operation action = + posted := []; + let transition = + Core.step !core (Core.Asset_requested { scope; operation; action }) + in + core := transition.next; + List.iter + (function + | Core.Run runnable -> Runner.submit runner runnable + | _ -> ()) + transition.effects; + drain (); + match List.rev !posted with + | [ event ] -> + let completed = Core.step !core event in + core := completed.next; + List.find_map + (function + | Core.Publish (Core.Asset_finished output) -> Some output.result + | _ -> None) + completed.effects + |> Option.get + | _ -> fail "cleanup fixture command did not complete" + in + let source_file = Filename.concat support "shutdown-source.bin" in + Out_channel.with_open_bin source_file (fun out -> output_string out "shutdown"); + let file = + match + request + "shutdown-stage" + (Core.Stage_asset_file + { operation = graph_id (); file_type = "bin"; source_file }) + with + | Ok (Core.Asset_staged { file; _ }) -> file + | _ -> fail "shutdown fixture staging failed" + in + let lease, path = + match request "shutdown-retain" (Core.Retain_staged_file file) with + | Ok (Core.Asset_retained (Some retained)) -> retained + | _ -> fail "shutdown fixture retention failed" + in + ignore (request "shutdown-release-lease" (Core.Release_asset_file lease)); + posted := []; + let cleanup = + Core.step + !core + (Core.Asset_requested + { scope + ; operation = "shutdown-release-stage" + ; action = Core.Release_staged_file file + }) + in + List.iter + (function + | Core.Run runnable -> Runner.submit runner runnable + | _ -> ()) + cleanup.effects; + Runner.shutdown runner; + drain (); + Alcotest.(check bool) + "submitted staging cleanup survives shutdown before queued tasks" + false + (Sys.file_exists path); + let completed = + match List.rev !posted with + | [ event ] -> Core.step cleanup.next event + | _ -> fail "submitted cleanup did not post exactly one completion" + in + Alcotest.(check bool) + "cleanup completion reaches its reducer output" + true + (List.exists + (function + | Core.Publish (Core.Asset_finished output) -> + output.request.operation = "shutdown-release-stage" + && output.result = Ok Core.Asset_unit + | _ -> false) + completed.effects)))) +;; + +let scenarios = + scenarios + @ [ Alcotest.test_case + "asset queued cleanup survives runner shutdown" + `Quick + test_asset_cleanup_survives_shutdown_before_queued_fork + ] +;; + +(* Migrated asset cache public runner scenarios. *) +let with_local_asset_cache ?(budget = 8L) ?(pending_budget = 8L) test = + with_support (fun support -> + Eio_main.run (fun environment -> + Eio.Switch.run (fun sw -> + let tasks = Queue.create () + and posted = Queue.create () in + let deps = + let transport = + Runner.transport + ~websocket_liveness:Runner.Disabled + ~tls_authenticator:(Runner.system_tls_authenticator () |> Result.get_ok) + ~network:(Eio.Stdenv.net environment) + ~clock:(Eio.Stdenv.clock environment) + |> Result.get_ok + in + Runner.dependencies + ~runtime: + (Runner.runtime + ~fork:(fun ~sw:_ task -> Queue.add task tasks) + ~sleep:(fun _ -> ()) + |> Result.get_ok) + ~transport + ~local_store: + (Runner.local_store + ~asset_cache_budget_bytes:budget + ~asset_maximum_file_bytes:8 + ~asset_pending_budget_bytes:pending_budget + ~application_support_directory:support + () + |> Result.get_ok) + ~artifact_store: + (Runner.artifact_store + ~staging_directory:(Filename.concat support "staging") + |> Result.get_ok) + ~secrets:(secrets ()) + ~crypto:(crypto ()) + ~id_token_provider: + (Runner.id_token_provider + ~acquire:(fun _ -> Ok "token") + ~invalidate:(fun _ ~token:_ -> ())) + |> Result.get_ok + in + let runner = + Runner.create ~sw deps ~post:(fun event -> Queue.add event posted) + |> Result.get_ok + in + Fun.protect + ~finally:(fun () -> Runner.shutdown runner) + (fun () -> + let selected, scope = Core_contract.selected_graph Core_contract.graph in + let state = ref selected.next + and sequence = ref 0 in + let rec consume outputs effects = + List.fold_left + (fun outputs -> function + | Core.Run runner_effect -> + Runner.submit runner runner_effect; + outputs + | Core.Publish (Core.Asset_finished output) -> output :: outputs + | _ -> outputs) + outputs + effects + and pump outputs = + match Queue.take_opt tasks with + | Some task -> + task (); + pump outputs + | None -> + (match Queue.take_opt posted with + | None -> List.rev outputs + | Some event -> + let transition = Core.step !state event in + state := transition.next; + pump (consume outputs transition.effects)) + in + let request action = + incr sequence; + let transition = + Core.step + !state + (Core.Asset_requested + { scope; operation = "cache-" ^ string_of_int !sequence; action }) + in + state := transition.next; + match pump (consume [] transition.effects) with + | [ output ] -> output.Core.result + | _ -> fail "cache operation did not resolve through reducer output" + in + test support request)))) +;; + +let staged_value = function + | Ok (Core.Asset_staged { file; checksum; size }) -> file, checksum, size + | _ -> fail "expected staged resource metadata" +;; + +let retained_value = function + | Ok (Core.Asset_retained (Some resource)) -> resource + | _ -> fail "expected retained resource output" +;; + +let cache_unit result = + Alcotest.(check bool) "cleanup completed" true (result = Ok Core.Asset_unit) +;; + +let cache_bool = Alcotest.check Alcotest.bool + +let cache_stage + request + ?(operation = Core_contract.graph_id) + ?(file_type = "bin") + source_file + = + request (Core.Stage_asset_file { operation; file_type; source_file }) |> staged_value +;; + +let test_cache_durable_staging () = + with_local_asset_cache (fun support request -> + let source = Filename.concat support "picker.bin" in + Out_channel.with_open_bin source (fun output -> output_string output "source"); + let file, checksum, size = cache_stage request source in + Alcotest.(check string) + "staging checksum" + (Logseq_sync_effect_runner.Asset_codec.checksum "source") + checksum; + Alcotest.(check int64) "staging size" 6L size; + Sys.remove source; + let lease, path = request (Core.Retain_staged_file file) |> retained_value in + Alcotest.(check string) + "picker is no longer needed" + "source" + (In_channel.with_open_bin path In_channel.input_all); + cache_unit (request (Core.Release_asset_file lease)); + let interrupted = path ^ ".part" in + Out_channel.with_open_bin interrupted (fun output -> output_string output "partial"); + cache_unit (request Core.Close_asset_scope); + let lease, restored = request (Core.Retain_staged_file file) |> retained_value in + cache_bool "restart preserves pending source" true (String.equal restored path); + cache_bool "interrupted staging discarded" false (Sys.file_exists interrupted); + cache_bool + "path traversal rejected" + true + (request (Core.Retain_staged_file "../picker.bin") = Ok (Core.Asset_retained None)); + cache_unit (request (Core.Release_asset_file lease)); + cache_unit (request (Core.Release_staged_file file)); + cache_unit (request (Core.Release_staged_file file)); + cache_bool + "completion releases pending source" + true + (request (Core.Retain_staged_file file) = Ok (Core.Asset_retained None))) +;; + +let test_cache_staging_limits () = + with_local_asset_cache ~pending_budget:4L (fun support request -> + let source = Filename.concat support "picker.bin" in + let write bytes = + Out_channel.with_open_bin source (fun output -> output_string output bytes) + in + write "large-file"; + cache_bool + "oversize staging rejected" + true + (Result.is_error + (request + (Core.Stage_asset_file + { operation = Core_contract.graph_id + ; file_type = "bin" + ; source_file = source + }))); + write "file"; + let file, _, _ = cache_stage request source in + cache_bool + "duplicate cannot overwrite immutable staging" + true + (Result.is_error + (request + (Core.Stage_asset_file + { operation = Core_contract.graph_id + ; file_type = "bin" + ; source_file = source + }))); + cache_bool + "pending namespace has a separate budget" + true + (request + (Core.Stage_asset_file + { operation = Core_contract.other_graph_id + ; file_type = "bin" + ; source_file = source + }) + = Error Core.Asset_storage_full); + let lease, path = request (Core.Retain_staged_file file) |> retained_value in + cache_bool "failed staging leaves original intact" true (Sys.file_exists path); + cache_unit (request (Core.Release_asset_file lease)); + cache_unit (request Core.Delete_graph_assets); + cache_bool "graph deletion removes staging" false (Sys.file_exists path)) +;; + +let test_cache_orphan_staging () = + with_local_asset_cache ~pending_budget:16L (fun support request -> + let source = Filename.concat support "picker.bin" in + Out_channel.with_open_bin source (fun output -> output_string output "file"); + let retained, _, _ = cache_stage request source in + let orphan, _, _ = + cache_stage request ~operation:Core_contract.other_graph_id source + in + let first_lease, retained_path = + request (Core.Retain_staged_file retained) |> retained_value + in + let second_lease, orphan_path = + request (Core.Retain_staged_file orphan) |> retained_value + in + cache_unit (request (Core.Release_asset_file first_lease)); + cache_unit (request (Core.Release_asset_file second_lease)); + let directory = Filename.dirname orphan_path in + let stranger = Filename.concat directory "unrecognized.txt" in + Out_channel.with_open_bin stranger (fun output -> output_string output "preserve"); + let link = Filename.concat directory "00000000-0000-4000-8000-000000000003.bin" in + Unix.symlink source link; + Alcotest.(check bool) + "only orphan removed" + true + (request (Core.Prune_asset_staging [ retained ]) = Ok (Core.Asset_pruned 1)); + cache_bool "durable staging retained" true (Sys.file_exists retained_path); + cache_bool "orphan gone" false (Sys.file_exists orphan_path); + cache_bool "unknown file retained" true (Sys.file_exists stranger); + cache_bool + "symlink not followed or removed" + true + ((Unix.lstat link).st_kind = Unix.S_LNK && Sys.file_exists source); + cache_bool + "repeat cleanup" + true + (request (Core.Prune_asset_staging [ retained ]) = Ok (Core.Asset_pruned 0)); + for index = 1 to 4096 do + Out_channel.with_open_bin + (Filename.concat directory ("unknown-" ^ string_of_int index)) + (fun _ -> ()) + done; + cache_bool + "oversized directory fails closed" + true + (request (Core.Prune_asset_staging []) = Error Core.Asset_storage_full); + cache_bool + "capacity failure preserves staged data" + true + (Sys.file_exists retained_path)) +;; + +let test_cache_staged_preview () = + with_local_asset_cache (fun support request -> + let source = Filename.concat support "picker.bin" in + Out_channel.with_open_bin source (fun output -> output_string output "file"); + let file, _, _ = cache_stage request ~file_type:"pdf" source in + let lease, path = request (Core.Retain_staged_file file) |> retained_value in + cache_bool + "native preview retains document extension" + true + (Filename.check_suffix path ".pdf"); + List.iter + (fun file_type -> + cache_bool + "unsafe file types are rejected" + true + (Result.is_error + (request + (Core.Stage_asset_file + { operation = Core_contract.graph_id + ; file_type + ; source_file = source + })))) + [ ""; "../pdf"; "x.pdf"; String.make 33 'a' ]; + let second, _ = request (Core.Retain_asset_file lease) |> retained_value in + cache_bool + "orphan cleanup preserves active previews" + true + (request (Core.Prune_asset_staging []) = Ok (Core.Asset_pruned 0)); + cache_unit (request (Core.Release_staged_file file)); + cache_bool "completion keeps preview bytes" true (Sys.file_exists path); + cache_bool + "completed staging refuses new preview" + true + (request (Core.Retain_staged_file file) = Ok (Core.Asset_retained None)); + cache_unit (request (Core.Release_asset_file lease)); + cache_bool "one remaining lease keeps file" true (Sys.file_exists path); + cache_unit (request (Core.Release_asset_file second)); + cache_bool "last lease finishes cleanup" false (Sys.file_exists path); + cache_unit (request (Core.Release_asset_file second)); + cache_unit (request (Core.Release_staged_file file)); + let file, _, _ = cache_stage request ~file_type:"pdf" source in + let lease, path = request (Core.Retain_staged_file file) |> retained_value in + cache_unit (request (Core.Release_staged_file file)); + cache_unit (request Core.Close_asset_scope); + cache_bool + "close invalidates preview lease" + true + (request (Core.Retain_asset_file lease) = Ok (Core.Asset_retained None)); + cache_bool "close finishes deferred cleanup" false (Sys.file_exists path); + let file, _, _ = cache_stage request ~file_type:"pdf" source in + let _, path = request (Core.Retain_staged_file file) |> retained_value in + cache_unit (request Core.Close_asset_scope); + cache_bool "close preserves nonterminal staging" true (Sys.file_exists path)) +;; + +let scenarios = + scenarios + @ List.map + (fun (name, test) -> Alcotest.test_case name `Quick test) + [ "cache durable staging via submit", test_cache_durable_staging + ; "cache staging limits via submit", test_cache_staging_limits + ; "cache orphan staging via submit", test_cache_orphan_staging + ; "cache staged preview lifetime via submit", test_cache_staged_preview + ] +;; + +(* The runner owns distinct physical staging instances; Core only fences the + cancelled completion and asks to release that exact resource reference. *) +let test_late_stage_cleanup_cannot_delete_a_replacement () = + with_support (fun support -> + Eio_main.run (fun environment -> + Eio.Switch.run (fun sw -> + let tasks = ref [] + and posted = ref [] in + let deps = + dependencies + ~environment + ~support + ~fork:(fun ~sw:_ task -> tasks := task :: !tasks) + () + in + let runner = + Runner.create ~sw deps ~post:(fun event -> posted := event :: !posted) + |> Result.get_ok + in + let selected, scope = Core_contract.selected_graph Core_contract.graph in + let core = ref selected.next in + let drain () = + while !tasks <> [] do + let batch = List.rev !tasks in + tasks := []; + List.iter (fun task -> task ()) batch + done + in + let submit operation action = + posted := []; + let transition = + Core.step !core (Core.Asset_requested { scope; operation; action }) + in + core := transition.next; + List.iter + (function + | Core.Run runnable -> Runner.submit runner runnable + | _ -> ()) + transition.effects; + drain (); + List.rev !posted + in + let request operation action = + match submit operation action with + | [ event ] -> + let completed = Core.step !core event in + core := completed.next; + List.find_map + (function + | Core.Publish (Core.Asset_finished output) -> Some output.result + | _ -> None) + completed.effects + |> Option.get + | _ -> fail "stage instance fixture did not complete" + in + let source_file = Filename.concat support "instance-source.bin" in + let write bytes = + Out_channel.with_open_bin source_file (fun out -> output_string out bytes) + in + let stage = + Core.Stage_asset_file + { operation = graph_id (); file_type = "bin"; source_file } + in + write "old"; + let old_event, old_file = + match submit "old-instance" stage with + | [ (Core.Runner_completed + (Core.Asset_completion (_, Ok (Core.Asset_staged { file; _ }))) as event) + ] -> event, file + | _ -> fail "old stage did not produce a resource completion" + in + Alcotest.(check bool) + "prune removes old unaccepted staging instance" + true + (request "prune-old-instance" (Core.Prune_asset_staging []) + = Ok (Core.Asset_pruned 1)); + write "new"; + let new_file = + match request "new-instance" stage with + | Ok (Core.Asset_staged { file; _ }) -> file + | _ -> fail "replacement staging failed" + in + Alcotest.(check bool) + "same import operation gets a distinct physical resource" + false + (String.equal old_file new_file); + ignore + (request "cancel-old-instance" (Core.Cancel_asset_operation "old-instance")); + let late = Core.step !core old_event in + core := late.next; + Alcotest.(check bool) + "cancelled completion releases the original exact reference" + true + (List.exists + (function + | Core.Run (Core.Asset_io (_, io)) -> + io.action = Core.Release_staged_file old_file + | _ -> false) + late.effects); + posted := []; + List.iter + (function + | Core.Run runnable -> Runner.submit runner runnable + | _ -> ()) + late.effects; + drain (); + List.iter (fun event -> core := (Core.step !core event).next) (List.rev !posted); + let lease, path = + match request "retain-replacement" (Core.Retain_staged_file new_file) with + | Ok (Core.Asset_retained (Some retained)) -> retained + | _ -> fail "old cleanup deleted or completed replacement" + in + Alcotest.(check string) + "replacement bytes survive old cleanup" + "new" + (In_channel.with_open_bin path In_channel.input_all); + ignore (request "release-replacement-lease" (Core.Release_asset_file lease)); + ignore (request "release-replacement-stage" (Core.Release_staged_file new_file)); + Runner.shutdown runner))) +;; + +let test_cache_prune_keeps_exact_staging_instance_and_legacy_files () = + with_local_asset_cache ~pending_budget:16L (fun support request -> + let source = Filename.concat support "exact-source.bin" in + Out_channel.with_open_bin source (fun out -> output_string out "file"); + let older, _, _ = cache_stage request source in + let newest, _, _ = cache_stage request source in + cache_bool + "same operation can stage a fresh instance without replacing old bytes" + false + (String.equal older newest); + cache_bool + "prune preserves exact durable instance only" + true + (request (Core.Prune_asset_staging [ newest ]) = Ok (Core.Asset_pruned 1)); + cache_bool + "older instance removed" + true + (request (Core.Retain_staged_file older) = Ok (Core.Asset_retained None)); + let lease, path = request (Core.Retain_staged_file newest) |> retained_value in + cache_bool "new durable instance survives prune" true (Sys.file_exists path); + let legacy = + Logseq_db_types.Graph_types.Uuid.to_string Core_contract.other_graph_id ^ ".bin" + in + let legacy_path = Filename.concat (Filename.dirname path) legacy in + Out_channel.with_open_bin legacy_path (fun out -> output_string out "legacy"); + let legacy_lease, restored = + request (Core.Retain_staged_file legacy) |> retained_value + in + Alcotest.(check string) + "legacy UUID.type resource remains recoverable" + "legacy" + (In_channel.with_open_bin restored In_channel.input_all); + cache_unit (request (Core.Release_asset_file legacy_lease)); + cache_unit (request (Core.Release_staged_file legacy)); + cache_unit (request (Core.Release_asset_file lease)); + cache_unit (request (Core.Release_staged_file newest))) +;; + +let scenarios = + scenarios + @ [ Alcotest.test_case + "late staging cleanup cannot delete replacement" + `Quick + test_late_stage_cleanup_cannot_delete_a_replacement + ; Alcotest.test_case + "staging prune keeps exact instance and legacy recovery" + `Quick + test_cache_prune_keeps_exact_staging_instance_and_legacy_files + ] +;; + +(* Deletion must cancel registered work before any cache instance exists; Core's + cancelled pending state alone cannot stop a queued callback from doing I/O. *) +let test_graph_asset_deletion_cancels_queued_fetch_before_cache_open () = + with_support (fun support -> + Eio_main.run (fun environment -> + Eio.Switch.run (fun sw -> + let tasks = ref [] + and posted = ref [] + and acquisitions = ref 0 in + let deps = + dependencies + ~environment + ~support + ~fork:(fun ~sw:_ task -> tasks := task :: !tasks) + ~id_token_dependency: + (Runner.id_token_provider + ~acquire:(fun _ -> + incr acquisitions; + Error "network must not be entered") + ~invalidate:(fun _ ~token:_ -> ())) + () + in + let runner = + Runner.create ~sw deps ~post:(fun event -> posted := event :: !posted) + |> Result.get_ok + in + let selected, scope = Core_contract.selected_graph Core_contract.graph in + let version = + Logseq_db_types.Asset_descriptor.version + ~checksum:(String.make 64 'a') + ~file_type:"bin" + |> Result.get_ok + in + let fetching = + Core.step + selected.next + (Core.Asset_requested + { scope + ; operation = "queued-fetch-before-cache" + ; action = + Core.Fetch_asset + { asset = graph_id (); version; maximum_plaintext_bytes = 8 } + }) + in + let expected_ticket = + List.find_map + (function + | Core.Run (Core.Asset_io (ticket, _) as runnable) -> + Runner.submit runner runnable; + Some ticket + | _ -> None) + fetching.effects + |> Option.get + in + Alcotest.(check int) + "fetch has not entered authentication before queued work starts" + 0 + !acquisitions; + let deleting = + Core.step + fetching.next + (Core.Asset_requested + { scope + ; operation = "delete-before-cache" + ; action = Core.Delete_graph_assets + }) + in + List.iter + (function + | Core.Run runnable -> Runner.submit runner runnable + | _ -> ()) + deleting.effects; + while !tasks <> [] do + let batch = List.rev !tasks in + tasks := []; + List.iter (fun task -> task ()) batch + done; + Alcotest.(check int) + "deleted graph's queued fetch never enters authentication or network" + 0 + !acquisitions; + Alcotest.(check bool) + "queued callback reports its own cancelled completion" + true + (List.exists + (function + | Core.Runner_completed + (Core.Asset_completion (ticket, Error Core.Asset_cancelled)) -> + ticket = expected_ticket + | _ -> false) + !posted); + List.iter (fun event -> ignore (Core.step deleting.next event)) (List.rev !posted); + Runner.shutdown runner))) +;; + +let scenarios = + scenarios + @ [ Alcotest.test_case + "asset graph deletion cancels queued fetch before cache opens" + `Quick + test_graph_asset_deletion_cancels_queued_fetch_before_cache_open + ] +;; diff --git a/logseq_sync/test/test_asset_cache.ml b/logseq_sync/test/test_asset_cache.ml index b11da00..ff3ff59 100644 --- a/logseq_sync/test/test_asset_cache.ml +++ b/logseq_sync/test/test_asset_cache.ml @@ -1,512 +1,152 @@ -module S = Logseq_sync_effect_runner.Asset_cache -module Codec = Logseq_sync_effect_runner.Asset_codec -module A = Logseq_db_types.Asset_descriptor -module C = Logseq_sync_pure_reducer.Core -module U = Logseq_db_types.Graph_types.Uuid - -let get = function - | Ok x -> x - | Error _ -> failwith "unexpected error" -;; - -let uuid = get (U.of_string "00000000-0000-4000-8000-000000000001") - -let scope : C.graph_scope = - { account = - { managed_sync_origin = Uri.of_string "https://sync.example" - ; user_id = "user" - ; account_generation = 1 - ; presentation_generation = 1 - ; lifecycle_generation = 1L - } - ; graph_id = uuid - ; graph_generation = 1 - } -;; - -let version bytes = get (A.version ~checksum:(Codec.checksum bytes) ~file_type:"png") - -let rec remove path = - if Sys.is_directory path - then ( - Array.iter (fun n -> remove (Filename.concat path n)) (Sys.readdir path); - Unix.rmdir path) - else Sys.remove path -;; - -let fixture test = - let root = Filename.temp_file "asset-cache" "" in - Sys.remove root; - Unix.mkdir root 0o700; - Fun.protect ~finally:(fun () -> remove root) (fun () -> test root) -;; - -let create ?(budget = 8L) ?(scope = scope) root = - get (S.create ~root ~scope ~budget_bytes:budget ~maximum_file_bytes:8) -;; - -let put cache bytes = - S.publish - cache - ~asset:uuid - ~version:(version bytes) - ~current:(fun () -> true) - ~plaintext:bytes -;; - -let lookup cache bytes = get (S.lookup cache ~asset:uuid ~version:(version bytes)) -let exists cache bytes = Option.is_some (lookup cache bytes) -let bool = Alcotest.check Alcotest.bool - -let roundtrip () = - fixture (fun root -> - let cache = create root in - let handle = get (put cache "file") in - let path = Option.get (S.path cache handle) in - let channel = open_in_bin path in - let bytes = really_input_string channel 4 in - close_in channel; - Alcotest.(check string) "published bytes" "file" bytes; - S.close cache; - let cache = create root in - bool "restart restores verified file" true (exists cache "file"); - S.close cache) -;; - -let corrupt () = - fixture (fun root -> - let cache = create root in - let h = get (put cache "file") in - let path = Option.get (S.path cache h) in - S.close cache; - let out = open_out_bin path in - output_string out "bad!"; - close_out out; - let cache = create root in - bool "corrupt file not ready" false (exists cache "file"); - S.close cache) -;; - -let stale () = - fixture (fun root -> - let cache = create root in - bool - "stale publish rejected" - true - (S.publish - cache - ~asset:uuid - ~version:(version "file") - ~current:(fun () -> false) - ~plaintext:"file" - = Error S.Stale); - bool "no stale record" false (exists cache "file"); - bool - "checksum verified" - true - (S.publish - cache - ~asset:uuid - ~version:(version "file") - ~current:(fun () -> true) - ~plaintext:"bad!" - = Error S.Checksum_mismatch); - bool "no corrupt record" false (exists cache "file"); - S.close cache) -;; - -let leases () = - fixture (fun root -> - let cache = create ~budget:4L root in - let h = get (put cache "file") in - let renderer = Option.get (S.retain cache h) in - S.release cache h; - bool "live renderer pins file" true (put cache "next" = Error S.Full); - bool "renderer path remains" true (Option.is_some (S.path cache renderer)); - S.release cache renderer; - let _ = get (put cache "next") in - bool "unpinned LRU evicted" false (exists cache "file"); - S.close cache) -;; - -let filename_extension () = - fixture (fun root -> - let cache = create root in - let handle = get (put cache "file") in - let path = Option.get (S.path cache handle) in - bool "downloaded file carries its type" true (Filename.check_suffix path ".png"); - S.release cache handle; - S.close cache; - let cache = create root in - let handle = Option.get (lookup cache "file") in - let path = Option.get (S.path cache handle) in - bool "restart preserves typed filename" true (Filename.check_suffix path ".png"); - S.release cache handle; - S.close cache) -;; - -let legacy_bin_cleanup () = - fixture (fun root -> - let cache = create root in - let handle = get (put cache "file") in - let path = Option.get (S.path cache handle) in - let legacy = Filename.chop_extension path ^ ".bin" in - Sys.rename path legacy; - S.release cache handle; - S.close cache; - let cache = create root in - bool "untyped data file evicted" false (Sys.file_exists legacy); - bool "manifest without typed data removed" false (exists cache "file"); - S.close cache) -;; - -let isolation () = - fixture (fun root -> - let first = create root in - let _ = get (put first "file") in - let scope = { scope with account = { scope.account with user_id = "another" } } in - let second = create ~scope root in - bool "accounts isolated" false (exists second "file"); - let _ = get (put second "next") in - let _ = get (S.delete first) in - bool "deletion leaves other account" true (exists second "next"); - S.close second) -;; - -let account_cleanup () = - fixture (fun root -> - let another_graph = - { scope with graph_id = get (U.of_string "00000000-0000-4000-8000-000000000002") } - in - let other_user = { scope with account = { scope.account with user_id = "other" } } in - let other_origin = - { scope with - account = - { scope.account with - managed_sync_origin = Uri.of_string "https://other.example" - } - } - in - List.iter - (fun scope -> - let cache = create ~scope root in - ignore (get (put cache "file")); - S.close cache) - [ scope; another_graph; other_user; other_origin ]; - get (S.delete_account ~root ~account:scope.account); - get (S.delete_account ~root ~account:scope.account); - List.iter - (fun scope -> - let cache = create ~scope root in - bool "all account graphs removed" false (exists cache "file"); - S.close cache) - [ scope; another_graph ]; - List.iter - (fun scope -> - let cache = create ~scope root in - bool "other namespace preserved" true (exists cache "file"); - S.close cache) - [ other_user; other_origin ]) -;; - -let graph_cleanup () = - fixture (fun root -> - let another_graph = - { scope with graph_id = get (U.of_string "00000000-0000-4000-8000-000000000002") } - in - List.iter - (fun scope -> - let cache = create ~scope root in - ignore (get (put cache "file")); - S.close cache) - [ scope; another_graph ]; - get (S.delete_graph ~root ~account:scope.account ~graph_id:scope.graph_id); - get (S.delete_graph ~root ~account:scope.account ~graph_id:scope.graph_id); - let removed = create root in - bool "selected graph removed" false (exists removed "file"); - S.close removed; - let kept = create ~scope:another_graph root in - bool "other graph retained" true (exists kept "file"); - S.close kept) -;; - -let staging () = - fixture (fun root -> - let source_file = Filename.concat root "picker.bin" in - let out = open_out_bin source_file in - output_string out "source"; - close_out out; - let cache = create ~budget:4L root in - let staged = - get - (S.stage - cache - ~file_type:"bin" - ~operation:uuid - ~source_file - ~pending_budget_bytes:8L) - in - bool - "staging checksum" - true - (staged.checksum = Codec.checksum "source" && staged.size = 6L); - Sys.remove source_file; - let path = Option.get (S.staged_path cache ~file:staged.file) in - let input = open_in_bin path in - let bytes = really_input_string input 6 in - close_in input; - Alcotest.(check string) "picker is no longer needed" "source" bytes; - S.release cache (get (put cache "file")); - ignore (get (put cache "next")); - bool "LRU does not evict pending import" true (Sys.file_exists path); - let interrupted = path ^ ".part" in - let out = open_out_bin interrupted in - output_string out "partial"; - close_out out; - S.close cache; - let cache = create root in - bool "interrupted staging discarded" false (Sys.file_exists interrupted); - bool - "pending source survives restart" - true - (Option.is_some (S.staged_path cache ~file:staged.file)); - bool "path traversal rejected" true (S.staged_path cache ~file:"../picker.bin" = None); - get (S.release_staged cache ~file:staged.file); - get (S.release_staged cache ~file:staged.file); - bool - "completion releases pending source" - true - (S.staged_path cache ~file:staged.file = None); - S.close cache) -;; - -let staging_bounds () = - fixture (fun root -> - let source_file = Filename.concat root "picker.bin" in - let write bytes = - let out = open_out_bin source_file in - output_string out bytes; - close_out out - in - write "large-file"; - let cache = create root in - bool - "oversize staging rejected" - true - (Result.is_error - (S.stage - cache - ~file_type:"bin" - ~operation:uuid - ~source_file - ~pending_budget_bytes:32L)); - write "file"; - let staged = - get - (S.stage - cache - ~file_type:"bin" - ~operation:uuid - ~source_file - ~pending_budget_bytes:4L) - in - bool - "duplicate cannot overwrite immutable staging" - true - (Result.is_error - (S.stage - cache - ~file_type:"bin" - ~operation:uuid - ~source_file - ~pending_budget_bytes:32L)); - let other = get (U.of_string "00000000-0000-4000-8000-000000000003") in - bool - "pending namespace has a separate budget" - true - (S.stage - cache - ~file_type:"bin" - ~operation:other - ~source_file - ~pending_budget_bytes:4L - = Error S.Full); - bool - "failed staging leaves original intact" - true - (Option.is_some (S.staged_path cache ~file:staged.file)); - let staged_path = Option.get (S.staged_path cache ~file:staged.file) in - get (S.delete cache); - bool "graph deletion removes staging" false (Sys.file_exists staged_path)) -;; - -let prune_orphans () = - fixture (fun root -> - let source_file = Filename.concat root "picker.bin" in - Out_channel.with_open_bin source_file (fun output -> output_string output "file"); - let other = get (U.of_string "00000000-0000-4000-8000-000000000002") in - let cache = create root in - let staged operation = - get - (S.stage cache ~file_type:"bin" ~operation ~source_file ~pending_budget_bytes:16L) - in - let retained = staged uuid in - let orphan = staged other in - let retained_path = Option.get (S.staged_path cache ~file:retained.file) in - let orphan_path = Option.get (S.staged_path cache ~file:orphan.file) in - let stranger = Filename.concat (Filename.dirname orphan_path) "unrecognized.txt" in - Out_channel.with_open_bin stranger (fun output -> output_string output "preserve"); - let link = - Filename.concat - (Filename.dirname orphan_path) - "00000000-0000-4000-8000-000000000003.bin" - in - Unix.symlink source_file link; - bool - "failed ownership check fails closed" - true - (Result.is_error - (S.prune_staged cache ~keep:(fun operation -> - if U.equal operation uuid then Error "database unavailable" else Ok false))); - bool - "no partial cleanup on owner failure" - true - (Sys.file_exists retained_path && Sys.file_exists orphan_path); - Alcotest.(check int) - "only orphan removed" - 1 - (get (S.prune_staged cache ~keep:(fun operation -> Ok (U.equal operation uuid)))); - bool "durable staging retained" true (Sys.file_exists retained_path); - bool "orphan gone" false (Sys.file_exists orphan_path); - bool "unknown file retained" true (Sys.file_exists stranger); - bool - "symlink not followed or removed" - true - ((Unix.lstat link).st_kind = Unix.S_LNK && Sys.file_exists source_file); - Alcotest.(check int) - "repeat cleanup" - 0 - (get (S.prune_staged cache ~keep:(fun _ -> Ok true))); - for index = 1 to 4096 do - let path = - Filename.concat (Filename.dirname orphan_path) ("unknown-" ^ string_of_int index) - in - Out_channel.with_open_bin path (fun _ -> ()) - done; - bool - "oversized directory fails closed" - true - (S.prune_staged cache ~keep:(fun _ -> Ok false) = Error S.Full); - bool "capacity failure preserves staged data" true (Sys.file_exists retained_path); - S.close cache; - bool - "closed scope refuses cleanup" - true - (Result.is_error (S.prune_staged cache ~keep:(fun _ -> Ok false)))) -;; - -let staged_preview () = - fixture (fun root -> - let source_file = Filename.concat root "picker.bin" in - Out_channel.with_open_bin source_file (fun out -> output_string out "file"); - let cache = create root in - let staged = - get - (S.stage - cache - ~file_type:"pdf" - ~operation:uuid - ~source_file - ~pending_budget_bytes:8L) - in - let lease = - match S.retain_staged cache ~file:staged.file with - | Some lease -> lease - | None -> Alcotest.fail "staged preview unavailable" - in - let preview = Option.get (S.path cache lease) in - bool - "native preview retains document extension" - true - (Filename.check_suffix preview ".pdf"); - List.iter - (fun file_type -> - bool - "unsafe file types are rejected" - true - (Result.is_error - (S.stage - cache - ~file_type - ~operation:uuid - ~source_file - ~pending_budget_bytes:8L))) - [ ""; "../pdf"; "x.pdf"; String.make 33 'a' ]; - let second = Option.get (S.retain cache lease) in - Alcotest.(check int) - "orphan cleanup preserves active previews" - 0 - (get (S.prune_staged cache ~keep:(fun _ -> Ok false))); - get (S.release_staged cache ~file:staged.file); - bool "completion keeps preview bytes" true (Sys.file_exists preview); - bool - "completed staging refuses new preview" - true - (S.retain_staged cache ~file:staged.file = None); - S.release cache lease; - bool "one remaining lease keeps file" true (Sys.file_exists preview); - S.release cache second; - bool "last lease finishes cleanup" false (Sys.file_exists preview); - S.release cache second; - get (S.release_staged cache ~file:staged.file); - let staged = - get - (S.stage - cache - ~file_type:"pdf" - ~operation:uuid - ~source_file - ~pending_budget_bytes:8L) - in - let lease = Option.get (S.retain_staged cache ~file:staged.file) in - get (S.release_staged cache ~file:staged.file); - S.close cache; - bool "close invalidates preview lease" true (S.path cache lease = None); - bool "close finishes deferred cleanup" false (Sys.file_exists preview); - let reopened = create root in - let staged = - get - (S.stage - reopened - ~file_type:"pdf" - ~operation:uuid - ~source_file - ~pending_budget_bytes:8L) - in - ignore (Option.get (S.retain_staged reopened ~file:staged.file)); - S.close reopened; - bool "close preserves nonterminal staging" true (Sys.file_exists preview)) +(* Cache filesystem scenarios run through Core.step/Effect_runner.submit in + runner_contract and transport_contract. This existing test entry checks the + public compiler boundary, without including implementation/private CMIs. *) +let rec repository_root directory = + if Sys.file_exists (Filename.concat directory ".git") + then directory + else ( + let parent = Filename.dirname directory in + if parent = directory + then failwith "repository root not found" + else repository_root parent) +;; + +let read_file path = In_channel.with_open_bin path In_channel.input_all + +let contains text part = + let rec loop offset = + offset + String.length part <= String.length text + && (String.sub text offset (String.length part) = part || loop (offset + 1)) + in + loop 0 +;; + +let compile root source = + let filename = Filename.temp_file "sync-public-boundary" ".ml" in + let log = filename ^ ".log" in + let output = filename ^ ".cmo" in + let interface = filename ^ ".cmi" in + Fun.protect + ~finally:(fun () -> + List.iter + (fun file -> if Sys.file_exists file then Sys.remove file) + [ filename; log; output; interface ]) + (fun () -> + Out_channel.with_open_bin filename (fun channel -> output_string channel source); + let directories = + [ "logseq_sync/spec/pure_reducer/.logseq_sync_pure_reducer.objs/byte" + ; "logseq_sync/spec/effect_runner/.logseq_sync_effect_runner.objs/byte" + ; "logseq_db_types/lib/.logseq_db_types.objs/byte" + ] + |> List.map (Filename.concat (Filename.concat root "_build/default")) + in + let arguments = + Array.of_list + (("ocamlc" + :: "-c" + :: "-o" + :: output + :: List.concat_map (fun directory -> [ "-I"; directory ]) directories) + @ [ filename ]) + in + let fd = Unix.openfile log [ Unix.O_CREAT; Unix.O_TRUNC; Unix.O_WRONLY ] 0o600 in + let process = Unix.create_process "ocamlc" arguments Unix.stdin fd fd in + Unix.close fd; + let _, status = Unix.waitpid [] process in + status, read_file log) +;; + +let positive root source = + let status, diagnostics = compile root source in + Alcotest.(check bool) diagnostics true (status = Unix.WEXITED 0) +;; + +let negative root source reason = + let status, diagnostics = compile root source in + Alcotest.(check bool) ("must fail: " ^ source) false (status = Unix.WEXITED 0); + Alcotest.(check bool) + ("rejected at intended boundary: " ^ diagnostics) + true + (contains diagnostics reason) +;; + +let sealed_public_interface () = + let root = repository_root (Sys.getcwd ()) in + let prefix = "module C = Logseq_sync_pure_reducer.Core\n" in + positive + root + (prefix + ^ "let carry (x : C.runner_effect) = x\n\ + let inspect = C.runner_effect_diagnostic\n\ + let submit = Logseq_sync_effect_runner.Effect_runner.submit\n"); + positive + root + "module C = Logseq_sync_pure_reducer__Core\nlet carry (x : C.runner_effect) = x\n"; + negative root (prefix ^ "let forge scope = C.Cancel_effects scope\n") "private type"; + negative + root + (prefix + ^ "let forge x = match x with C.Asset_io (ticket, request) -> C.Asset_io (ticket, \ + request) | _ -> x\n") + "private type"; + negative + root + (prefix + ^ "type alias = C.runner_effect\nlet forge scope : alias = C.Cancel_effects scope\n" + ) + "private type"; + negative + root + "module C = Logseq_sync_pure_reducer__Core\n\ + let forge scope = C.Cancel_effects scope\n" + "private type"; + negative + root + (prefix ^ "let forge : C.asset_ticket = { asset_serial = 1; asset_request = () }\n") + "Unbound record field"; + negative + root + (prefix ^ "let forge : unit C.effect_ticket = { id = 1; scope = (); kind = () }\n") + "Unbound record field"; + negative + root + "let bypass = Logseq_sync_effect_runner.Asset_cache.create\n" + "Unbound value"; + negative root "module B = Logseq_sync_effect_runner.Bootstrap\n" "Unbound module"; + negative + root + "module B = Logseq_sync_effect_runner__logseq_sync_effect_runner_impl__Bootstrap\n" + "Unbound module"; + negative root "module B = Logseq_sync_effect_runner_impl.Bootstrap\n" "Unbound module"; + List.iter + (fun operation -> + negative + root + ("let bypass = Logseq_sync_effect_runner.Effect_runner." ^ operation ^ "\n") + "Unbound value") + [ "submit_asset" + ; "run_scoped_asset" + ; "upload_asset" + ; "stage_asset" + ; "retain_asset_file" + ; "release_asset_file" + ; "staged_asset_path" + ; "close_asset_scope" + ; "delete_graph_assets" + ; "release_staged_asset" + ; "prune_staged_assets" + ; "retain_staged_file" + ; "encrypt_protected_values" + ; "decrypt_protected_value" + ; "authenticated_operation" + ] ;; let () = Alcotest.run - "asset cache" - [ ( "filesystem" - , List.map - (fun (n, f) -> Alcotest.test_case n `Quick f) - [ "staged preview lifetime", staged_preview - ; "orphan staging", prune_orphans - ; "durable staging", staging - ; "staging limits", staging_bounds - ; "graph cleanup", graph_cleanup - ; "account cleanup", account_cleanup - ; "downloaded filename", filename_extension - ; "legacy bin cleanup", legacy_bin_cleanup - ; "restart", roundtrip - ; "corruption", corrupt - ; "atomic eligibility", stale - ; "leases and budget", leases - ; "account isolation", isolation - ] ) + "sync public interface" + [ ( "external compilation" + , [ Alcotest.test_case "sealed execution and cache" `Quick sealed_public_interface ] + ) ] ;; diff --git a/logseq_sync/test/test_sync.ml b/logseq_sync/test/test_sync.ml index 4246a9b..f7321e5 100644 --- a/logseq_sync/test/test_sync.ml +++ b/logseq_sync/test/test_sync.ml @@ -5,6 +5,7 @@ let () = ; ( "pure core" , Core_contract.scenarios @ [ Local_restore_failure_reconciliation.scenario ] ) ; "sync recovery reproductions", Core_contract.sync_recovery_reproductions + ; "asset execution core", Core_contract.asset_scenarios ; "effect runner", Runner_contract.scenarios ; "transport", Transport_contract.scenarios ] diff --git a/logseq_sync/test/transport_contract.ml b/logseq_sync/test/transport_contract.ml index 9ecc131..b74dfbe 100644 --- a/logseq_sync/test/transport_contract.ml +++ b/logseq_sync/test/transport_contract.ml @@ -174,16 +174,14 @@ let with_peer cases f = let graph = { Core_contract.graph with name = "Transport fixture" } -let bootstrap origin = +let bootstrap ?(mirror_absent = true) ?(user_id = "fixture") origin = let initial = Core.config ~managed_sync_origin:origin ~limits:(Core_contract.limits ()) |> Result.get_ok |> Core.initial |> Result.get_ok in - let auth = - Core.step initial (Core.Account_authenticated { user_id = Some "fixture" }) - in + let auth = Core.step initial (Core.Account_authenticated { user_id = Some user_id }) in let catalog = List.find_map (function @@ -205,11 +203,14 @@ let bootstrap origin = selected.effects |> Option.get in - Core.step selected.next (Core.Mirror_inspected (Core.Mirror_absent scope)), scope + ( (if mirror_absent + then Core.step selected.next (Core.Mirror_inspected (Core.Mirror_absent scope)) + else selected) + , scope ) ;; -let operation ~download origin = - let transition, scope = bootstrap origin in +let operation ?artifact_uri ~download origin = + let transition, _scope = bootstrap origin in if not download then List.find_map @@ -232,7 +233,11 @@ let operation ~download origin = transition.effects |> Option.get in - let artifact_uri = Uri.with_path origin "/artifact" |> Uri.to_string in + let artifact_uri = + Option.value + artifact_uri + ~default:(Uri.with_path origin "/artifact" |> Uri.to_string) + in let response = Yojson.Basic.to_string (`Assoc [ "ok", `Bool true; "url", `String artifact_uri ]) in @@ -250,19 +255,216 @@ let operation ~download origin = in List.find_map (function - | Core.Run (Core.Request (ticket, Core.Download_snapshot request)) -> - Some (Core.Request (ticket, Core.Download_snapshot { request with scope })) + | Core.Run (Core.Request (_, Core.Download_snapshot _) as runnable) -> + Some runnable | _ -> None) downloading.effects |> Option.get) ;; +let websocket_cores = ref [] + +let websocket_start ?(checkpoint = 0) origin = + let selected, scope = bootstrap ~mirror_absent:false origin in + let inspected = + Core.step + selected.next + (Core.Mirror_inspected (Core.Mirror_available { graph; scope })) + in + let sync = + Logseq_overlay_db.Types.sync_view + ~token: + (Logseq_overlay_db.Types.sync_token_of_string "sync-token:v1:transport" + |> Result.get_ok) + ~checkpoint: + (Logseq_overlay_db.Types.Server_cursor.of_string + ("server-cursor:v1:" ^ string_of_int checkpoint) + |> Result.get_ok) + ~submissions:[] + in + let attached = Core.step inspected.next (Core.Graph_attached { scope; sync }) in + let runnable, connection = + List.find_map + (function + | Core.Run (Core.Start_websocket request as runnable) -> + Some (runnable, request.scope) + | _ -> None) + attached.effects + |> Option.get + in + websocket_cores := (connection, attached.next) :: !websocket_cores; + runnable +;; + +let websocket_core (scope : Core.connection_scope) = List.assoc scope !websocket_cores + +let websocket_close (scope : Core.connection_scope) = + let opened = Core.step (websocket_core scope) (Core.Websocket_opened scope) in + Core.step + opened.next + (Core.Foreground_changed + { foreground = false + ; lifecycle_generation = scope.graph.account.lifecycle_generation + }) + |> fun transition -> + List.find_map + (function + | Core.Run (Core.Close_websocket _ as runnable) -> Some runnable + | _ -> None) + transition.effects + |> Option.get +;; + +let websocket_send (scope : Core.connection_scope) checkpoint = + let _ = websocket_start ~checkpoint scope.Core.graph.account.managed_sync_origin in + Core.step (websocket_core scope) (Core.Websocket_opened scope) + |> fun transition -> + List.find_map + (function + | Core.Run (Core.Send_websocket _ as runnable) -> Some runnable + | _ -> None) + transition.effects + |> Option.get +;; + +let cancellation_effect scope = + let core = + Core.config + ~managed_sync_origin:(Uri.of_string "https://localhost") + ~limits:(Core_contract.limits ()) + |> Result.get_ok + |> Core.initial + |> Result.get_ok + in + let core = + (Core.step core (Core.Account_authenticated { user_id = Some "fixture" })).next + in + let transition = Core.step core Core.Shutdown in + ignore scope; + List.find_map + (function + | Core.Run (Core.Cancel_effects _ as runnable) -> Some runnable + | _ -> None) + transition.effects + |> Option.get +;; + +(* Keep the fixture's real reducer owner across sequential commands. Each accepted + completion consumes a ticket; starting from its old snapshot would replay it. *) +let asset_fixture_owners = ref [] + +let asset_owner t = + match List.find_opt (fun (runner, _) -> runner == t) !asset_fixture_owners with + | Some (_, scopes) -> scopes + | None -> + let scopes = Hashtbl.create 8 in + asset_fixture_owners := (t, scopes) :: !asset_fixture_owners; + scopes +;; + +let asset_current_core t core scope = + if Core.admitted_graph_scope core <> Some scope + then core + else Option.value (Hashtbl.find_opt (asset_owner t) scope) ~default:core +;; + +let asset_remember_core t scope core = Hashtbl.replace (asset_owner t) scope core + +let asset_submit t core scope operation action = + let core = asset_current_core t core scope in + let transition = Core.step core (Core.Asset_requested { scope; operation; action }) in + List.iter + (function + | Core.Run runnable -> Runner.submit t runnable + | _ -> ()) + transition.effects; + asset_remember_core t scope transition.next; + transition.next +;; + +let asset_collect t core posted = + let rec collect core outputs = function + | [] -> + Option.iter + (fun scope -> asset_remember_core t scope core) + (Core.admitted_graph_scope core); + core, List.rev outputs + | event :: events -> + let transition = Core.step core event in + let outputs = + List.fold_left + (fun outputs -> function + | Core.Publish (Core.Asset_finished result) -> result :: outputs + | Core.Run runnable -> + Runner.submit t runnable; + outputs + | _ -> outputs) + outputs + transition.effects + in + collect transition.next outputs events + in + collect core [] posted +;; + +let asset_run t ~clock ~posted core scope operation action = + let core = asset_current_core t core scope in + posted := []; + let transition = Core.step core (Core.Asset_requested { scope; operation; action }) in + let immediate = + List.filter_map + (function + | Core.Publish (Core.Asset_finished output) -> Some output + | _ -> None) + transition.effects + in + List.iter + (function + | Core.Run runnable -> Runner.submit t runnable + | _ -> ()) + transition.effects; + let outputs = + if immediate <> [] + then ( + asset_remember_core t scope transition.next; + immediate) + else ( + wait clock (fun () -> !posted <> []); + let completed, outputs = asset_collect t transition.next !posted in + asset_remember_core t scope completed; + outputs) + in + match outputs with + | [ output ] -> output.Core.result + | _ -> Alcotest.fail "asset request did not publish exactly one typed outcome" +;; + +let asset_stage t ~clock ~posted core scope source_file = + match + asset_run + t + ~clock + ~posted + core + scope + "stage" + (Core.Stage_asset_file + { operation = graph.graph_id; file_type = "bin"; source_file }) + with + | Ok (Core.Asset_staged { file; _ }) -> file + | _ -> Alcotest.fail "source staging failed" +;; + let runner ?(websocket_liveness = Runner.Disabled) ?network ?secrets_dependency ?crypto_dependency ?(acquire = fun _ -> Ok "fixture-token") + ?(on_invalidate = fun _ -> ()) + ?asset_cache_budget_bytes + ?asset_maximum_file_bytes + ?asset_pending_budget_bytes ~environment ~sw ~support @@ -287,15 +489,22 @@ let runner |> Result.get_ok) ~transport ~local_store: - (Runner.local_store ~application_support_directory:support |> Result.get_ok) + (Runner.local_store + ?asset_cache_budget_bytes + ?asset_maximum_file_bytes + ?asset_pending_budget_bytes + ~application_support_directory:support + () + |> Result.get_ok) ~artifact_store: (Runner.artifact_store ~staging_directory:(Filename.concat support "staging") |> Result.get_ok) ~secrets:(Option.value secrets_dependency ~default:(secrets ())) ~crypto:(Option.value crypto_dependency ~default:(crypto ())) ~id_token_provider: - (Runner.id_token_provider ~acquire ~invalidate:(fun _ ~token:_ -> - incr invalidations)) + (Runner.id_token_provider ~acquire ~invalidate:(fun _ ~token -> + incr invalidations; + on_invalidate token)) |> Result.get_ok in Runner.create ~sw dependencies ~post:(fun event -> posted := !posted @ [ event ]) @@ -427,10 +636,7 @@ let ws_test ?(extra = "") ?(segment = 16384) ~messages ~terminal wire () = let t = runner ~environment ~sw ~support ~posted ~invalidations () in let _, graph = bootstrap origin in let scope = Core.{ graph; connection_generation = 1 } in - Runner.submit - t - (Core.Start_websocket - { scope; uri = Uri.with_scheme (Uri.with_path origin "/ws") (Some "wss") }); + Runner.submit t (websocket_start origin); let clock = Eio.Stdenv.clock environment in let message_count () = List.length @@ -464,7 +670,7 @@ let ws_test ?(extra = "") ?(segment = 16384) ~messages ~terminal wire () = ordered false !posted; if not terminal then ( - Runner.submit t (Core.Close_websocket scope); + Runner.submit t (websocket_close scope); wait clock closed); Alcotest.(check int) "one terminal notification" @@ -610,7 +816,7 @@ let test_cancelled_attempt ~download () = Runner.submit t op; let clock = Eio.Stdenv.clock environment in wait clock (fun () -> Sys.file_exists (Filename.concat support "sent")); - Runner.submit t (Core.Cancel_effects (Core.runner_effect_scope op)); + Runner.submit t (cancellation_effect (Core.runner_effect_scope op)); Eio.Time.sleep clock 0.05; let event_count = List.length !posted in Eio.Time.sleep clock 0.05; @@ -711,9 +917,7 @@ let test_ws_cancellation ~during_close () = let t = runner ~environment ~sw ~support ~posted ~invalidations () in let _, graph = bootstrap origin in let scope = Core.{ graph; connection_generation = 1 } in - Runner.submit - t - (Core.Start_websocket { scope; uri = Uri.with_scheme origin (Some "wss") }); + Runner.submit t (websocket_start origin); let clock = Eio.Stdenv.clock environment in wait clock (fun () -> List.exists @@ -721,9 +925,9 @@ let test_ws_cancellation ~during_close () = | Core.Websocket_opened _ -> true | _ -> false) !posted); - if during_close then Runner.submit t (Core.Close_websocket scope); + if during_close then Runner.submit t (websocket_close scope); let start = Eio.Time.now clock in - Runner.submit t (Core.Cancel_effects (Core.effect_scope_of_graph graph)); + Runner.submit t (cancellation_effect (Core.effect_scope_of_graph graph)); Runner.shutdown t; Alcotest.(check bool) "abort dispatch does not await grace" @@ -795,15 +999,11 @@ let test_artifact_credentials ~status () = and invalidations = ref 0 in let t = runner ~environment ~sw ~support ~posted ~invalidations () in let op = - match operation ~download:true (Uri.with_port origin (Some 1)) with - | Core.Request (ticket, Core.Download_snapshot request) -> - Core.Request - ( ticket - , Core.Download_snapshot - { request with - uri = Uri.with_path origin "/signed-artifact?signature=fixture" - } ) - | _ -> assert false + operation + ~download:true + ~artifact_uri: + (Uri.with_path origin "/signed-artifact?signature=fixture" |> Uri.to_string) + (Uri.with_port origin (Some 1)) in Runner.submit t op; wait (Eio.Stdenv.clock environment) (fun () -> @@ -868,9 +1068,7 @@ let test_liveness ~reply () = in let _, graph = bootstrap origin in let scope = Core.{ graph; connection_generation = 1 } in - Runner.submit - t - (Core.Start_websocket { scope; uri = Uri.with_scheme origin (Some "wss") }); + Runner.submit t (websocket_start origin); let clock = Eio.Stdenv.clock environment in wait clock (fun () -> List.exists @@ -889,7 +1087,7 @@ let test_liveness ~reply () = Alcotest.(check bool) "correlated Pong determines liveness" (not reply) (closed ()); if reply then ( - Runner.submit t (Core.Close_websocket scope); + Runner.submit t (websocket_close scope); wait clock closed); Runner.shutdown t) in @@ -928,9 +1126,7 @@ let test_control_output () = in let _, graph = bootstrap origin in let scope = Core.{ graph; connection_generation = 1 } in - Runner.submit - t - (Core.Start_websocket { scope; uri = Uri.with_scheme origin (Some "wss") }); + Runner.submit t (websocket_start origin); let clock = Eio.Stdenv.clock environment in wait clock (fun () -> List.exists @@ -938,16 +1134,9 @@ let test_control_output () = | Core.Websocket_opened _ -> true | _ -> false) !posted); - Runner.submit - t - (Core.Send_websocket - { scope - ; message = - Logseq_sync_pure_reducer.Sync_protocol.Client.Hello - { client = "mask-fixture" } - }); + Runner.submit t (websocket_send scope 0); Eio.Time.sleep clock 0.15; - Runner.submit t (Core.Close_websocket scope); + Runner.submit t (websocket_close scope); wait clock (fun () -> List.exists (function @@ -1029,9 +1218,7 @@ let test_output_admission () = let t = runner ~environment ~sw ~support ~posted ~invalidations () in let _, graph = bootstrap origin in let scope = Core.{ graph; connection_generation = 1 } in - Runner.submit - t - (Core.Start_websocket { scope; uri = Uri.with_scheme origin (Some "wss") }); + Runner.submit t (websocket_start origin); let clock = Eio.Stdenv.clock environment in wait clock (fun () -> List.exists @@ -1040,28 +1227,14 @@ let test_output_admission () = | _ -> false) !posted); for index = 0 to 1999 do - Runner.submit - t - (Core.Send_websocket - { scope - ; message = - Logseq_sync_pure_reducer.Sync_protocol.Client.Hello - { client = string_of_int index } - }) + Runner.submit t (websocket_send scope index) done; let count_path = Filename.concat support "frame-count" in wait clock (fun () -> Sys.file_exists count_path && Option.value (int_of_string_opt (read_file count_path)) ~default:0 >= 128); - Runner.submit - t - (Core.Send_websocket - { scope - ; message = - Logseq_sync_pure_reducer.Sync_protocol.Client.Hello - { client = "after-drain" } - }); - Runner.submit t (Core.Close_websocket scope); + Runner.submit t (websocket_send scope 2000); + Runner.submit t (websocket_close scope); wait clock (fun () -> List.exists (function @@ -1084,9 +1257,10 @@ let test_output_admission () = (List.length data); List.iteri (fun index frame -> - let client = if index = 128 then "after-drain" else string_of_int index in + let since = if index = 128 then 2000 else index in let expected = - Logseq_sync_pure_reducer.Sync_protocol.encode_client_message (Hello { client }) + Logseq_sync_pure_reducer.Sync_protocol.encode_client_message + (Pull { since = Some since }) |> Result.get_ok |> hex in @@ -1113,18 +1287,11 @@ let test_setup_cancel ~websocket ~dns () = and invalidations = ref 0 in let t = runner ~environment ~sw ~support ~posted ~invalidations () in let op = - if websocket - then ( - let _, graph = bootstrap origin in - Core.Start_websocket - { scope = { graph; connection_generation = 1 } - ; uri = Uri.with_scheme origin (Some "wss") - }) - else operation ~download:false origin + if websocket then websocket_start origin else operation ~download:false origin in Runner.submit t op; Eio.Time.sleep (Eio.Stdenv.clock environment) 0.03; - Runner.submit t (Core.Cancel_effects (Core.runner_effect_scope op)); + Runner.submit t (cancellation_effect (Core.runner_effect_scope op)); Runner.shutdown t in let started = Unix.gettimeofday () in @@ -1173,9 +1340,7 @@ let test_alternate_address ~websocket () = then ( let _, graph = bootstrap origin in let scope = Core.{ graph; connection_generation = 1 } in - Runner.submit - t - (Core.Start_websocket { scope; uri = Uri.with_scheme origin (Some "wss") }); + Runner.submit t (websocket_start origin); wait (Eio.Stdenv.clock environment) (fun () -> List.exists (function @@ -1190,7 +1355,7 @@ let test_alternate_address ~websocket () = | Core.Websocket_opened _ -> true | _ -> false) !posted); - Runner.submit t (Core.Close_websocket scope); + Runner.submit t (websocket_close scope); wait (Eio.Stdenv.clock environment) (fun () -> List.exists (function @@ -1242,9 +1407,7 @@ let test_upgrade_authentication ~status () = let t = runner ~environment ~sw ~support ~posted ~invalidations () in let _, graph = bootstrap origin in let scope = Core.{ graph; connection_generation = 1 } in - Runner.submit - t - (Core.Start_websocket { scope; uri = Uri.with_scheme origin (Some "wss") }); + Runner.submit t (websocket_start origin); let clock = Eio.Stdenv.clock environment in let closed () = List.exists @@ -1271,7 +1434,7 @@ let test_upgrade_authentication ~status () = !invalidations; if opened () then ( - Runner.submit t (Core.Close_websocket scope); + Runner.submit t (websocket_close scope); wait clock closed); Runner.shutdown t) in @@ -1344,7 +1507,7 @@ let test_stalled_tcp ~cancel () = let started = Eio.Time.now clock in if cancel then ( - Runner.submit t (Core.Cancel_effects (Core.runner_effect_scope op)); + Runner.submit t (cancellation_effect (Core.runner_effect_scope op)); wait clock (fun () -> !released); Alcotest.(check bool) "TCP cancellation is prompt" @@ -1472,14 +1635,12 @@ let test_close_with_pending_pong ~reply () = let _, graph = bootstrap origin in let scope = Core.{ graph; connection_generation = 1 } in let clock = Eio.Stdenv.clock environment in - Runner.submit - t - (Core.Start_websocket { scope; uri = Uri.with_scheme origin (Some "wss") }); + Runner.submit t (websocket_start origin); (* The peer records a Ping only after receiving the complete frame, and deliberately never answers it. Close starts with a Pong outstanding. *) wait clock (fun () -> Sys.file_exists (Filename.concat support "frame-count")); let started = Eio.Time.now clock in - Runner.submit t (Core.Close_websocket scope); + Runner.submit t (websocket_close scope); let closures () = List.filter_map (function @@ -1539,9 +1700,7 @@ let scenarios = ;; let asset_download ~mismatch ~refresh () = - let module Transfer = Logseq_sync_pure_reducer.Asset_transfer in let module Asset = Logseq_db_types.Asset_descriptor in - let module Cache = Logseq_sync_effect_runner.Asset_cache in let module Codec = Logseq_sync_effect_runner.Asset_codec in let bytes = "\000\255file\128" in let checksum = Codec.checksum (if mismatch then "different" else bytes) in @@ -1559,82 +1718,76 @@ let asset_download ~mismatch ~refresh () = let posted = ref [] and invalidations = ref 0 in let t = runner ~environment ~sw ~support ~posted ~invalidations () in - let _, scope = bootstrap origin in - let cache = - Cache.create - ~root:(Filename.concat support "assets") - ~scope - ~budget_bytes:1024L - ~maximum_file_bytes:32 - |> Result.get_ok - in - let descriptor = - Asset.create - ~uuid:scope.graph_id - ~source:(Managed (Some version)) - ~current_checksum:None - ~size:None - ~dimensions:None - |> Result.get_ok - in - let state = - Transfer.create - (Transfer.config ~active:2 ~foreground_reserved:1 ~pending:4 ~retries:1 - |> Result.get_ok) - ~scope - ~online:true - ~unlocked:true - in - let state, instructions = - Transfer.step - state - (Replace - { consumer = "visible"; priority = Foreground; assets = [ descriptor ] }) - in - let lookup = - List.find_map - (function - | Transfer.Check_cache ticket -> Some ticket - | _ -> None) - instructions - |> Option.get - in - let _, instructions = Transfer.step state (Cache_checked (lookup, Ok None)) in - let instruction = - List.find - (function - | Transfer.Fetch _ -> true - | _ -> false) - instructions + let selected, scope = bootstrap ~mirror_absent:false origin in + let clock = Eio.Stdenv.clock environment in + let result = + asset_run + t + ~clock + ~posted + selected.next + scope + "download" + (Core.Fetch_asset + { asset = scope.graph_id; version; maximum_plaintext_bytes = 32 }) in - let events = ref [] in - Runner.submit_asset - t - ~scope - ~cache - ~encryption:Plaintext - ~maximum_plaintext_bytes:32 - ~current:(fun _ -> true) - ~post:(fun event -> events := event :: !events) - instruction; - wait (Eio.Stdenv.clock environment) (fun () -> !events <> []); - (match !events with - | [ Transfer.Downloaded (_, Ok handle) ] when not mismatch -> - Alcotest.(check string) - "verified binary bytes" - bytes - (read_file (Cache.path cache handle |> Option.get)) - | [ Transfer.Downloaded (_, Error Transfer.Checksum_mismatch) ] when mismatch -> + (match result with + | Ok (Core.Asset_downloaded file) when not mismatch -> + let retained = + asset_run + t + ~clock + ~posted + selected.next + scope + "retain" + (Core.Retain_asset_file file) + in + (match retained with + | Ok (Core.Asset_retained (Some (lease, path))) -> + Alcotest.(check string) "verified binary bytes" bytes (read_file path); + ignore + (asset_run + t + ~clock + ~posted + selected.next + scope + "release" + (Core.Release_asset_file lease)); + Alcotest.(check bool) + "download handle releases through completion" + true + (asset_run + t + ~clock + ~posted + selected.next + scope + "release-download" + (Core.Release_asset_file file) + = Ok Core.Asset_unit) + | _ -> Alcotest.fail "downloaded resource could not be retained") + | Error Core.Asset_checksum_mismatch when mismatch -> + let checked = + asset_run + t + ~clock + ~posted + selected.next + scope + "check" + (Core.Check_asset_cache (scope.graph_id, version)) + in Alcotest.(check bool) "bad object not published" true - (Cache.lookup cache ~asset:scope.graph_id ~version = Ok None) + (checked = Ok (Core.Asset_cached None)) | _ -> Alcotest.fail "unexpected asset download outcome"); Alcotest.(check int) "same token refresh owner" (if refresh then 1 else 0) !invalidations; - Cache.close cache; Runner.shutdown t) in check_retired report; @@ -1685,33 +1838,46 @@ let asset_upload ~status ~refresh () = let posted = ref [] and invalidations = ref 0 in let runner = runner ~environment ~sw ~support ~posted ~invalidations () in - let _, scope = bootstrap origin in + let selected, scope = bootstrap ~mirror_absent:false origin in let source_file = Filename.concat support "staged.bin" in - let out = open_out_bin source_file in - output_string out bytes; - close_out out; + Out_channel.with_open_bin source_file (fun out -> output_string out bytes); + let clock = Eio.Stdenv.clock environment in + let file = asset_stage runner ~clock ~posted selected.next scope source_file in let result = - Runner.upload_asset + asset_run runner - ~context:Core.{ scope; encrypted = false; key = None } - ~asset:scope.graph_id - ~version - ~source_file - ~maximum_plaintext_bytes:32 - ~current:(fun () -> true) + ~clock + ~posted + selected.next + scope + "upload" + (Core.Put_asset_file + { asset = scope.graph_id; version; file; maximum_plaintext_bytes = 32 }) in let expected = match status with - | 200 -> Ok () - | 403 -> Error Runner.Upload_revoked_access - | 413 -> Error Runner.Upload_size_rejected - | _ -> Error Runner.Upload_network + | 200 -> Ok Core.Asset_unit + | 403 -> Error Core.Asset_revoked_access + | 413 -> Error Core.Asset_size_rejected + | _ -> Error Core.Asset_network in Alcotest.(check bool) "explicit upload result" true (result = expected); Alcotest.(check int) "upload token refresh" (if refresh then 1 else 0) !invalidations; + Alcotest.(check bool) + "upload staging cleanup completes" + true + (asset_run + runner + ~clock + ~posted + selected.next + scope + "release-upload-stage" + (Core.Release_staged_file file) + = Ok Core.Asset_unit); Runner.shutdown runner) in check_retired report; @@ -1753,54 +1919,122 @@ let asset_upload_source () = let posted = ref [] and invalidations = ref 0 in let runner = runner ~environment ~sw ~support ~posted ~invalidations () in - let _, scope = bootstrap (Uri.of_string "https://localhost:1") in + let selected, scope = + bootstrap ~mirror_absent:false (Uri.of_string "https://localhost:1") + in + let clock = Eio.Stdenv.clock environment in let version = Logseq_db_types.Asset_descriptor.version ~checksum:(Logseq_sync_effect_runner.Asset_codec.checksum "file") - ~file_type:"png" + ~file_type:"bin" |> Result.get_ok in let source_file = Filename.concat support "source.bin" in - let upload ~limit ~current ~encrypted = - Runner.upload_asset + let missing = + asset_run runner - ~context:Core.{ scope; encrypted; key = None } - ~asset:scope.graph_id - ~version - ~source_file - ~maximum_plaintext_bytes:limit - ~current:(fun () -> current) + ~clock + ~posted + selected.next + scope + "missing" + (Core.Put_asset_file + { asset = scope.graph_id + ; version + ; file = "unavailable-stage" + ; maximum_plaintext_bytes = 32 + }) in Alcotest.(check bool) "missing staging file" true - (upload ~limit:32 ~current:true ~encrypted:false - = Error Runner.Upload_missing_source); - let out = open_out_bin source_file in - output_string out "file"; - close_out out; + (missing = Error Core.Asset_missing_source); + Out_channel.with_open_bin source_file (fun out -> output_string out "file"); + let file = asset_stage runner ~clock ~posted selected.next scope source_file in + let put core scope operation maximum_plaintext_bytes version = + asset_run + runner + ~clock + ~posted + core + scope + operation + (Core.Put_asset_file + { asset = scope.Core.graph_id; version; file; maximum_plaintext_bytes }) + in Alcotest.(check bool) "size bound before network" true - (upload ~limit:3 ~current:true ~encrypted:false - = Error Runner.Upload_size_rejected); + (put selected.next scope "size" 3 version = Error Core.Asset_size_rejected); + let locked, locked_scope = + Core_contract.selected_graph Core_contract.encrypted_graph + in + let locked_file = + asset_stage runner ~clock ~posted locked.next locked_scope source_file + in Alcotest.(check bool) "locked graph never sends plaintext" true - (upload ~limit:32 ~current:true ~encrypted:true = Error Runner.Upload_locked); + (asset_run + runner + ~clock + ~posted + locked.next + locked_scope + "locked" + (Core.Put_asset_file + { asset = locked_scope.graph_id + ; version + ; file = locked_file + ; maximum_plaintext_bytes = 32 + }) + = Error Core.Asset_locked); + let requested = + Core.step + selected.next + (Core.Asset_requested + { scope + ; operation = "cancelled" + ; action = + Core.Put_asset_file + { asset = scope.graph_id + ; version + ; file + ; maximum_plaintext_bytes = 32 + } + }) + in + let cancelled = + Core.step + requested.next + (Core.Asset_requested + { scope + ; operation = "cancel" + ; action = Core.Cancel_asset_operation "cancelled" + }) + in Alcotest.(check bool) "cancelled intent never uploads" true - (upload ~limit:32 ~current:false ~encrypted:false - = Error Runner.Upload_cancelled); - let out = open_out_bin source_file in - output_string out "oops"; - close_out out; + (List.exists + (function + | Core.Publish (Core.Asset_finished output) -> + output.request.operation = "cancelled" + && output.result = Error Core.Asset_cancelled + | _ -> false) + cancelled.effects); + let incorrect = + Logseq_db_types.Asset_descriptor.version + ~checksum:(Logseq_sync_effect_runner.Asset_codec.checksum "oops") + ~file_type:"bin" + |> Result.get_ok + in Alcotest.(check bool) "changed source rejected" true - (upload ~limit:32 ~current:true ~encrypted:false - = Error Runner.Upload_invalid_content); + (match put selected.next scope "changed" 32 incorrect with + | Error (Core.Asset_invalid_content _) -> true + | _ -> false); Runner.shutdown runner))) ;; @@ -1843,43 +2077,45 @@ let asset_upload_admission () = decr active; Error "offline" in + let posted = ref [] in let t = - runner - ~acquire - ~environment - ~sw - ~support - ~posted:(ref []) - ~invalidations:(ref 0) - () + runner ~acquire ~environment ~sw ~support ~posted ~invalidations:(ref 0) () + in + let selected, scope = + bootstrap ~mirror_absent:false (Uri.of_string "https://localhost") in - let _, scope = bootstrap (Uri.of_string "https://localhost") in + let clock = Eio.Stdenv.clock environment in let source_file = Filename.concat support "pending.bin" in Out_channel.with_open_bin source_file (fun out -> output_string out "file"); + let file = asset_stage t ~clock ~posted selected.next scope source_file in let version = Logseq_db_types.Asset_descriptor.version ~checksum:(Logseq_sync_effect_runner.Asset_codec.checksum "file") ~file_type:"bin" |> Result.get_ok in - let results = - Eio.Fiber.List.map - (fun _ -> - Runner.upload_asset + posted := []; + let core = + List.fold_left + (fun core index -> + asset_submit t - ~context:Core.{ scope; encrypted = false; key = None } - ~asset:scope.graph_id - ~version - ~source_file - ~maximum_plaintext_bytes:4 - ~current:(fun () -> true)) + core + scope + ("upload-" ^ string_of_int index) + (Core.Put_asset_file + { asset = scope.graph_id; version; file; maximum_plaintext_bytes = 4 })) + selected.next [ 1; 2; 3 ] in + wait clock (fun () -> List.length !posted = 3); + let _, outputs = asset_collect t core !posted in Alcotest.(check int) "one upload holds source and wire buffers" 1 !maximum; Alcotest.(check bool) "failed transfer releases admission" true - (List.length results = 3 && List.for_all Result.is_error results); + (List.length outputs = 3 + && List.for_all (fun output -> Result.is_error output.Core.result) outputs); Runner.shutdown t))) ;; @@ -1888,101 +2124,64 @@ let scenarios = @ [ Alcotest.test_case "asset upload resource admission" `Quick asset_upload_admission ] ;; -let asset_download_admission () = - let module Transfer = Logseq_sync_pure_reducer.Asset_transfer in +let asset_download_budget maximum_plaintext_bytes expected_entered () = let module Asset = Logseq_db_types.Asset_descriptor in - let module Cache = Logseq_sync_effect_runner.Asset_cache in with_support (fun support -> Eio_main.run (fun environment -> Eio.Switch.run (fun sw -> - let entered = ref 0 - and completed = ref 0 in + let entered = ref 0 in let gate, release = Eio.Promise.create () in let acquire _ = incr entered; Eio.Promise.await gate; Error "offline" in + let posted = ref [] in let t = - runner - ~acquire - ~environment - ~sw - ~support - ~posted:(ref []) - ~invalidations:(ref 0) - () + runner ~acquire ~environment ~sw ~support ~posted ~invalidations:(ref 0) () in - let _, base = bootstrap (Uri.of_string "https://localhost") in let version = Asset.version ~checksum:(String.make 64 '0') ~file_type:"bin" |> Result.get_ok in - let caches = - List.init 5 (fun generation -> - let scope = Core.{ base with graph_generation = generation } in - let cache = - Cache.create ~root:support ~scope ~budget_bytes:32L ~maximum_file_bytes:4 - |> Result.get_ok + let cores = + List.init 5 (fun index -> + let selected, scope = + bootstrap + ~mirror_absent:false + ~user_id:("fixture-" ^ string_of_int index) + (Uri.of_string "https://localhost") in - let asset = - Asset.create - ~uuid:scope.graph_id - ~source:(Managed (Some version)) - ~current_checksum:None - ~size:None - ~dimensions:None - |> Result.get_ok - in - let state = - Transfer.create - (Transfer.config ~active:1 ~foreground_reserved:0 ~pending:1 ~retries:0 - |> Result.get_ok) - ~scope - ~online:true - ~unlocked:true - in - let state, effects = - Transfer.step - state - (Replace { consumer = "test"; priority = Foreground; assets = [ asset ] }) - in - let ticket = - List.find_map - (function - | Transfer.Check_cache t -> Some t - | _ -> None) - effects - |> Option.get - in - let _, effects = Transfer.step state (Cache_checked (ticket, Ok None)) in - List.iter - (function - | Transfer.Fetch _ as instruction -> - Runner.submit_asset - t - ~scope - ~cache - ~encryption:Plaintext - ~maximum_plaintext_bytes:4 - ~current:(fun _ -> true) - ~post:(fun _ -> incr completed) - instruction - | _ -> ()) - effects; - cache) + asset_submit + t + selected.next + scope + ("download-" ^ string_of_int index) + (Core.Fetch_asset + { asset = scope.graph_id; version; maximum_plaintext_bytes })) in for _ = 1 to 10 do Eio.Fiber.yield () done; let initial = !entered in Eio.Promise.resolve release (); - wait (Eio.Stdenv.clock environment) (fun () -> !completed = 5); - Alcotest.(check int) "downloads share three permits across scopes" 3 initial; - Alcotest.(check int) "all failed requests release their permit" 5 !entered; - Runner.shutdown t; - List.iter Cache.close caches))) + wait (Eio.Stdenv.clock environment) (fun () -> List.length !posted = 5); + let outputs = + List.concat_map (fun core -> snd (asset_collect t core !posted)) cores + in + Alcotest.(check int) + "scopes share bounded download and byte permits" + expected_entered + initial; + Alcotest.(check int) "all failed requests release admission" 5 !entered; + Alcotest.(check int) + "all completions pass through reducer outputs" + 5 + (List.length outputs); + Runner.shutdown t))) ;; +let asset_download_admission = asset_download_budget 4 3 + let scenarios = scenarios @ [ Alcotest.test_case @@ -1992,120 +2191,15 @@ let scenarios = ] ;; -let shared_asset_byte_budget () = - let module Transfer = Logseq_sync_pure_reducer.Asset_transfer in - let module Asset = Logseq_db_types.Asset_descriptor in - let module Cache = Logseq_sync_effect_runner.Asset_cache in - with_support (fun support -> - Eio_main.run (fun environment -> - Eio.Switch.run (fun sw -> - let entered = ref 0 - and completed = ref 0 in - let gate, release = Eio.Promise.create () in - let acquire _ = - incr entered; - Eio.Promise.await gate; - Error "offline" - in - let t = - runner - ~acquire - ~environment - ~sw - ~support - ~posted:(ref []) - ~invalidations:(ref 0) - () - in - let _, base = bootstrap (Uri.of_string "https://localhost") in - let version = - Asset.version ~checksum:(String.make 64 '0') ~file_type:"bin" |> Result.get_ok - in - let caches = - List.init 5 (fun generation -> - let scope = Core.{ base with graph_generation = generation } in - let cache = - Cache.create - ~root:support - ~scope - ~budget_bytes:32L - ~maximum_file_bytes:16777216 - |> Result.get_ok - in - let asset = - Asset.create - ~uuid:scope.graph_id - ~source:(Managed (Some version)) - ~current_checksum:None - ~size:None - ~dimensions:None - |> Result.get_ok - in - let state = - Transfer.create - (Transfer.config ~active:1 ~foreground_reserved:0 ~pending:1 ~retries:0 - |> Result.get_ok) - ~scope - ~online:true - ~unlocked:true - in - let state, effects = - Transfer.step - state - (Replace { consumer = "test"; priority = Foreground; assets = [ asset ] }) - in - let ticket = - List.find_map - (function - | Transfer.Check_cache t -> Some t - | _ -> None) - effects - |> Option.get - in - let _, effects = Transfer.step state (Cache_checked (ticket, Ok None)) in - List.iter - (function - | Transfer.Fetch _ as instruction -> - Runner.submit_asset - t - ~scope - ~cache - ~encryption:Plaintext - ~maximum_plaintext_bytes:16777216 - ~current:(fun _ -> true) - ~post:(fun _ -> incr completed) - instruction - | _ -> ()) - effects; - cache) - in - for _ = 1 to 10 do - Eio.Fiber.yield () - done; - let initial = !entered in - Eio.Promise.resolve release (); - wait (Eio.Stdenv.clock environment) (fun () -> !completed = 5); - (* Each 16 MiB request reserves 32 MiB of wire plus plaintext footprint, - so only two of the three download permits admit work concurrently. *) - Alcotest.(check int) "byte budget admits two large downloads" 2 initial; - Alcotest.(check int) "all failed requests release their bytes" 5 !entered; - Runner.shutdown t; - List.iter Cache.close caches))) -;; +let shared_asset_byte_budget = asset_download_budget 16777216 2 let scenarios = scenarios - @ [ Alcotest.test_case - "shared asset byte budget" - `Quick - shared_asset_byte_budget - ] + @ [ Alcotest.test_case "shared asset byte budget" `Quick shared_asset_byte_budget ] ;; let shared_asset_codec_admission () = - let module Transfer = Logseq_sync_pure_reducer.Asset_transfer in let module Asset = Logseq_db_types.Asset_descriptor in - let module Cache = Logseq_sync_effect_runner.Asset_cache in let plaintext = "file" in let version = Asset.version @@ -2179,96 +2273,51 @@ let shared_asset_codec_admission () = ~invalidations:(ref 0) () in - let _, instruction = Runner_contract.cached_key_effect ~origin () in - let scope, key = - match instruction with - | Core.Request (ticket, Core.Load_and_unlock_graph_key scope) -> - ( scope - , Core.graph_key_handle - ~scope - ~id: - ("graph-key-" ^ Core.effect_id_to_string (Core.effect_ticket_id ticket)) - ) - | _ -> Alcotest.fail "missing key request" - in + let before, instruction = Runner_contract.cached_key_effect ~origin () in Runner.submit t instruction; wait (Eio.Stdenv.clock environment) (fun () -> !posted <> []); + let unlocked = (Core.step before.next (List.hd !posted)).next in + let context = Core.asset_context unlocked |> Option.get in + let scope = context.scope in let source_file = Filename.concat support "pending.bin" in Out_channel.with_open_bin source_file (fun out -> output_string out plaintext); - let upload = ref None in - Eio.Fiber.fork ~sw (fun () -> - upload - := Some - (Runner.upload_asset - t - ~context:Core.{ scope; encrypted = true; key = Some key } - ~asset:scope.graph_id - ~version - ~source_file - ~maximum_plaintext_bytes:4 - ~current:(fun () -> true))); - wait (Eio.Stdenv.clock environment) (fun () -> !encrypted); - let cache = - Cache.create ~root:support ~scope ~budget_bytes:32L ~maximum_file_bytes:4 - |> Result.get_ok - in - let asset = - Asset.create - ~uuid:scope.graph_id - ~source:(Managed (Some version)) - ~current_checksum:None - ~size:None - ~dimensions:None - |> Result.get_ok - in - let state = - Transfer.create - (Transfer.config ~active:1 ~foreground_reserved:0 ~pending:1 ~retries:0 - |> Result.get_ok) - ~scope - ~online:true - ~unlocked:true - in - let state, effects = - Transfer.step - state - (Replace { consumer = "codec"; priority = Foreground; assets = [ asset ] }) + let clock = Eio.Stdenv.clock environment in + let file = asset_stage t ~clock ~posted unlocked scope source_file in + posted := []; + let uploading = + asset_submit + t + unlocked + scope + "codec-upload" + (Core.Put_asset_file + { asset = scope.graph_id; version; file; maximum_plaintext_bytes = 4 }) in - let ticket = - List.find_map - (function - | Transfer.Check_cache t -> Some t - | _ -> None) - effects - |> Option.get + wait clock (fun () -> !encrypted); + let downloading = + asset_submit + t + uploading + scope + "codec-download" + (Core.Fetch_asset + { asset = scope.graph_id; version; maximum_plaintext_bytes = 4 }) in - let _, effects = Transfer.step state (Cache_checked (ticket, Ok None)) in - let downloaded = ref false in - List.iter - (function - | Transfer.Fetch _ as instruction -> - Runner.submit_asset - t - ~scope - ~cache - ~encryption:(Encrypted (Some key)) - ~maximum_plaintext_bytes:4 - ~current:(fun _ -> true) - ~post:(fun _ -> downloaded := true) - instruction - | _ -> ()) - effects; wait (Eio.Stdenv.clock environment) (fun () -> Sys.file_exists (Filename.concat support "report")); Eio.Promise.resolve release (); - wait (Eio.Stdenv.clock environment) (fun () -> !downloaded && !upload <> None); + wait (Eio.Stdenv.clock environment) (fun () -> List.length !posted = 2); + let _, outputs = asset_collect t downloading !posted in + Alcotest.(check int) + "both codec completions reach reducer" + 2 + (List.length outputs); Alcotest.(check int) "GET and PUT share one codec permit" 1 !maximum; Alcotest.(check bool) "failed encoding releases the permit for decoding" true !decrypted; - Runner.shutdown t; - Cache.close cache) + Runner.shutdown t) in check_retired report ;; @@ -2281,3 +2330,606 @@ let scenarios = shared_asset_codec_admission ] ;; + +(* Provider refresh contracts execute through reducer-created HTTP operations. *) +let submitted_authentication_policy + statuses + expected_result + expected_tokens + expected_invalidated + () + = + let acquired = ref [] + and invalidated = ref [] in + let tokens = Queue.create () in + Queue.add "token-1" tokens; + Queue.add "token-2" tokens; + let report = + with_peer + (List.map (fun status -> case (response ~status "x")) statuses) + (fun ~environment ~sw ~support ~origin -> + let posted = ref [] in + let acquire _ = + match Queue.take_opt tokens with + | Some token -> + acquired := token :: !acquired; + Ok token + | None -> Error "no token" + in + let t = + runner + ~acquire + ~on_invalidate:(fun token -> invalidated := token :: !invalidated) + ~environment + ~sw + ~support + ~posted + ~invalidations:(ref 0) + () + in + let requested, _ = bootstrap origin in + let runnable = + List.find_map + (function + | Core.Run (Core.Request (_, Core.Fetch_snapshot_baseline _) as runnable) + -> Some runnable + | _ -> None) + requested.effects + |> Option.get + in + Runner.submit t runnable; + wait (Eio.Stdenv.clock environment) (fun () -> completed !posted <> None); + Alcotest.(check bool) + "typed authentication outcome" + true + (match completed !posted, expected_result with + | Some (Ok ()), None -> true + | Some (Error (Core.Effect_failed message)), Some expected -> + String.equal message expected + | _ -> false); + List.iter (fun event -> ignore (Core.step requested.next event)) !posted; + Runner.shutdown t) + in + Alcotest.(check (list string)) + "bounded acquired token attempts" + expected_tokens + (List.rev !acquired); + Alcotest.(check (list string)) + "only first unauthorized token invalidated" + expected_invalidated + (List.rev !invalidated); + check_retired report +;; + +let scenarios = + scenarios + @ [ Alcotest.test_case + "authenticated operation retries one unauthorized response" + `Quick + (submitted_authentication_policy + [ 401; 200 ] + None + [ "token-1"; "token-2" ] + [ "token-1" ]) + ; Alcotest.test_case + "authenticated operation surfaces second unauthorized response" + `Quick + (submitted_authentication_policy + [ 401; 401 ] + (Some "Authentication failed.") + [ "token-1"; "token-2" ] + [ "token-1" ]) + ; Alcotest.test_case + "authenticated operation does not retry forbidden response" + `Quick + (submitted_authentication_policy + [ 403 ] + (Some "Authorization failed.") + [ "token-1" ] + []) + ] +;; + +(* Semaphore ownership belongs to runner I/O: cancellation while a reservation is + incomplete must release the units already acquired, before the first request ends. *) +let cancelled_asset_byte_wait_releases_partial_reservation () = + with_support (fun support -> + Eio_main.run (fun environment -> + Eio.Switch.run (fun sw -> + let entered = ref 0 in + let gate, release = Eio.Promise.create () in + let acquire _ = + incr entered; + Eio.Promise.await gate; + Error "offline" + in + let posted = ref [] in + let t = + runner ~acquire ~environment ~sw ~support ~posted ~invalidations:(ref 0) () + in + let selected, scope = + bootstrap ~mirror_absent:false (Uri.of_string "https://localhost") + in + let version = + Logseq_db_types.Asset_descriptor.version + ~checksum:(String.make 64 'a') + ~file_type:"bin" + |> Result.get_ok + in + let action maximum_plaintext_bytes = + Core.Fetch_asset { asset = scope.graph_id; version; maximum_plaintext_bytes } + in + let first = + asset_submit t selected.next scope "holding-48MiB" (action (24 * 1024 * 1024)) + in + wait (Eio.Stdenv.clock environment) (fun () -> !entered = 1); + let waiting = + asset_submit t first scope "waiting-for-48MiB" (action (24 * 1024 * 1024)) + in + for _ = 1 to 10 do + Eio.Fiber.yield () + done; + let cancelled = + asset_submit + t + waiting + scope + "cancel-waiter" + (Core.Cancel_asset_operation "waiting-for-48MiB") + in + wait (Eio.Stdenv.clock environment) (fun () -> List.length !posted >= 2); + let admitted = + asset_submit t cancelled scope "using-returned-16MiB" (action (8 * 1024 * 1024)) + in + wait (Eio.Stdenv.clock environment) (fun () -> !entered = 2); + Alcotest.(check int) + "cancelled partial reservation immediately admits another request" + 2 + !entered; + Eio.Promise.resolve release (); + wait (Eio.Stdenv.clock environment) (fun () -> List.length !posted = 4); + ignore (asset_collect t admitted !posted); + Runner.shutdown t))) +;; + +let scenarios = + scenarios + @ [ Alcotest.test_case + "asset cancellation releases partial byte reservation" + `Quick + cancelled_asset_byte_wait_releases_partial_reservation + ] +;; + +(* Two legal 40 MiB reservations must not divide the 64 MiB pool and deadlock. *) +let weighted_asset_reservations_make_progress () = + let bytes = "file" in + let version = + Logseq_db_types.Asset_descriptor.version + ~checksum:(Logseq_sync_effect_runner.Asset_codec.checksum bytes) + ~file_type:"bin" + |> Result.get_ok + in + let headers = "Content-Length: 4\r\n" in + let report = + with_peer + [ case (response ~headers bytes); case (response ~headers bytes) ] + (fun ~environment ~sw ~support ~origin -> + let entered = ref 0 in + let gate, release = Eio.Promise.create () in + let acquire _ = + incr entered; + Eio.Promise.await gate; + Ok "fixture-token" + in + let posted = ref [] in + let t = + runner ~acquire ~environment ~sw ~support ~posted ~invalidations:(ref 0) () + in + let selected, scope = bootstrap ~mirror_absent:false origin in + let action = + Core.Fetch_asset + { asset = scope.graph_id + ; version + ; maximum_plaintext_bytes = 20 * 1024 * 1024 + } + in + let first = asset_submit t selected.next scope "weighted-first" action in + wait (Eio.Stdenv.clock environment) (fun () -> !entered = 1); + let second = asset_submit t first scope "weighted-second" action in + for _ = 1 to 10 do + Eio.Fiber.yield () + done; + Alcotest.(check int) + "one entire reservation enters while the second waits" + 1 + !entered; + Eio.Promise.resolve release (); + wait (Eio.Stdenv.clock environment) (fun () -> List.length !posted = 2); + let _, outputs = asset_collect t second !posted in + Alcotest.(check int) + "both weighted TLS downloads complete" + 2 + (List.length outputs); + Alcotest.(check bool) + "weighted reservations release for the next request" + true + (List.for_all + (fun output -> + match output.Core.result with + | Ok (Core.Asset_downloaded _) -> true + | _ -> false) + outputs); + Alcotest.(check int) "second request proceeds after the first" 2 !entered; + Runner.shutdown t) + in + check_retired report +;; + +let scenarios = + scenarios + @ [ Alcotest.test_case + "weighted asset reservations make TLS progress" + `Quick + weighted_asset_reservations_make_progress + ] +;; + +(* Migrated downloaded cache scenarios. *) +module Cache_asset = Logseq_db_types.Asset_descriptor +module Cache_codec = Logseq_sync_effect_runner.Asset_codec + +let cache_version bytes = + Cache_asset.version ~checksum:(Cache_codec.checksum bytes) ~file_type:"png" + |> Result.get_ok +;; + +let cache_response bytes = + case + (response + ~headers:(Printf.sprintf "Content-Length: %d\r\n" (String.length bytes)) + bytes) +;; + +let cache_selection ?(user = "fixture") ?(selected_graph : Core.graph = graph) origin = + let initial = + Core.config ~managed_sync_origin:origin ~limits:(Core_contract.limits ()) + |> Result.get_ok + |> Core.initial + |> Result.get_ok + in + let authenticated = + Core.step initial (Core.Account_authenticated { user_id = Some user }) + in + let catalog = + List.find_map + (function + | Core.Run (Core.Request (ticket, Core.Fetch_catalog _)) -> + Some + (Core.step + authenticated.next + (Core.Runner_completed (Core.Completion (ticket, Ok [ selected_graph ])))) + | _ -> None) + authenticated.effects + |> Option.get + in + let selected = Core.step catalog.next (Core.Graph_selected selected_graph.graph_id) in + selected.next, Core.admitted_graph_scope selected.next |> Option.get +;; + +let with_downloaded_cache ?(budget = 8L) ?(pending_budget = 8L) cases test = + let report = + with_peer cases (fun ~environment ~sw ~support ~origin -> + let posted = ref [] + and invalidations = ref 0 in + let create () = + runner + ~asset_cache_budget_bytes:budget + ~asset_maximum_file_bytes:8 + ~asset_pending_budget_bytes:pending_budget + ~environment + ~sw + ~support + ~posted + ~invalidations + () + in + let active = ref (create ()) in + Fun.protect + ~finally:(fun () -> Runner.shutdown !active) + (fun () -> + let sequence = ref 0 in + let request core scope action = + incr sequence; + asset_run + !active + ~clock:(Eio.Stdenv.clock environment) + ~posted + core + scope + ("cache-" ^ string_of_int !sequence) + action + in + let reopen () = + Runner.shutdown !active; + active := create () + in + test support origin request reopen)) + in + check_retired report +;; + +let cache_download request core (scope : Core.graph_scope) bytes = + match + request + core + scope + (Core.Fetch_asset + { asset = scope.graph_id + ; version = cache_version bytes + ; maximum_plaintext_bytes = 8 + }) + with + | Ok (Core.Asset_downloaded handle) -> handle + | _ -> Alcotest.fail "cache download did not produce a controlled resource" +;; + +let cache_lookup request core (scope : Core.graph_scope) bytes = + match + request core scope (Core.Check_asset_cache (scope.graph_id, cache_version bytes)) + with + | Ok (Core.Asset_cached handle) -> handle + | _ -> Alcotest.fail "cache lookup did not resolve through reducer output" +;; + +let cache_retain request core scope handle = + match request core scope (Core.Retain_asset_file handle) with + | Ok (Core.Asset_retained (Some resource)) -> resource + | _ -> Alcotest.fail "cache resource retention failed" +;; + +let cache_release request core scope handle = + Runner_contract.cache_unit (request core scope (Core.Release_asset_file handle)) +;; + +let test_downloaded_cache_restart () = + with_downloaded_cache + [ cache_response "file" ] + (fun _ origin request reopen -> + let core, scope = cache_selection origin in + let handle = cache_download request core scope "file" in + let lease, path = cache_retain request core scope handle in + Alcotest.(check string) "published bytes" "file" (read_file path); + cache_release request core scope lease; + reopen (); + Alcotest.(check bool) + "restart restores verified file" + true + (Option.is_some (cache_lookup request core scope "file"))) +;; + +let test_downloaded_cache_corruption () = + with_downloaded_cache + [ cache_response "file" ] + (fun _ origin request reopen -> + let core, scope = cache_selection origin in + let handle = cache_download request core scope "file" in + let _, path = cache_retain request core scope handle in + Runner_contract.cache_unit (request core scope Core.Close_asset_scope); + Out_channel.with_open_bin path (fun output -> output_string output "bad!"); + reopen (); + Alcotest.(check bool) + "corrupt file not ready" + true + (cache_lookup request core scope "file" = None)) +;; + +let test_downloaded_cache_eligibility () = + with_downloaded_cache + [ cache_response "bad!" ] + (fun _ origin request _ -> + let core, scope = cache_selection origin in + Alcotest.(check bool) + "checksum verified before publication" + true + (request + core + scope + (Core.Fetch_asset + { asset = scope.graph_id + ; version = cache_version "file" + ; maximum_plaintext_bytes = 8 + }) + = Error Core.Asset_checksum_mismatch); + Alcotest.(check bool) + "no corrupt record" + true + (cache_lookup request core scope "file" = None)) +;; + +let test_downloaded_cache_leases () = + with_downloaded_cache + ~budget:4L + [ cache_response "file"; cache_response "next"; cache_response "next" ] + (fun support origin request _ -> + let core, scope = cache_selection origin in + let source = Filename.concat support "picker.bin" in + Out_channel.with_open_bin source (fun output -> output_string output "source"); + let staged, _, _ = Runner_contract.cache_stage (request core scope) source in + let stage_lease, staged_path = + request core scope (Core.Retain_staged_file staged) + |> Runner_contract.retained_value + in + cache_release request core scope stage_lease; + let handle = cache_download request core scope "file" in + let lease, path = cache_retain request core scope handle in + cache_release request core scope handle; + Alcotest.(check bool) + "live renderer pins file" + true + (request + core + scope + (Core.Fetch_asset + { asset = scope.graph_id + ; version = cache_version "next" + ; maximum_plaintext_bytes = 8 + }) + = Error Core.Asset_storage_full); + Alcotest.(check bool) "renderer path remains" true (Sys.file_exists path); + cache_release request core scope lease; + ignore (cache_download request core scope "next"); + Alcotest.(check bool) + "unpinned LRU evicted" + true + (cache_lookup request core scope "file" = None); + Alcotest.(check bool) + "LRU does not evict pending import" + true + (Sys.file_exists staged_path)) +;; + +let test_downloaded_cache_filename () = + with_downloaded_cache + [ cache_response "file" ] + (fun _ origin request reopen -> + let core, scope = cache_selection origin in + let handle = cache_download request core scope "file" in + let lease, path = cache_retain request core scope handle in + Alcotest.(check bool) + "download carries its type" + true + (Filename.check_suffix path ".png"); + cache_release request core scope lease; + cache_release request core scope handle; + reopen (); + let handle = cache_lookup request core scope "file" |> Option.get in + let lease, path = cache_retain request core scope handle in + Alcotest.(check bool) + "restart preserves typed filename" + true + (Filename.check_suffix path ".png"); + cache_release request core scope lease; + cache_release request core scope handle) +;; + +let test_downloaded_cache_legacy_cleanup () = + with_downloaded_cache + [ cache_response "file" ] + (fun _ origin request reopen -> + let core, scope = cache_selection origin in + let handle = cache_download request core scope "file" in + let _, path = cache_retain request core scope handle in + let legacy = Filename.chop_extension path ^ ".bin" in + Sys.rename path legacy; + Runner_contract.cache_unit (request core scope Core.Close_asset_scope); + reopen (); + let restored = cache_lookup request core scope "file" in + Alcotest.(check bool) "untyped data file evicted" false (Sys.file_exists legacy); + Alcotest.(check bool) "manifest without typed data removed" true (restored = None)) +;; + +let test_downloaded_cache_isolation () = + with_downloaded_cache + [ cache_response "file"; cache_response "next" ] + (fun _ origin request _ -> + let first, first_scope = cache_selection origin in + let second, second_scope = cache_selection ~user:"another" origin in + ignore (cache_download request first first_scope "file"); + Alcotest.(check bool) + "accounts isolated" + true + (cache_lookup request second second_scope "file" = None); + ignore (cache_download request second second_scope "next"); + Runner_contract.cache_unit (request first first_scope Core.Delete_graph_assets); + Alcotest.(check bool) + "deletion leaves other account" + true + (Option.is_some (cache_lookup request second second_scope "next"))) +;; + +let test_downloaded_cache_account_cleanup () = + with_downloaded_cache + [ cache_response "file"; cache_response "file"; cache_response "file" ] + (fun _ origin request _ -> + let other_report = + with_peer + [ cache_response "file" ] + (fun ~environment:_ ~sw:_ ~support:_ ~origin:other_origin -> + let first = cache_selection origin in + let another_graph = + cache_selection + ~selected_graph:{ graph with graph_id = Core_contract.other_graph_id } + origin + in + let other_user = cache_selection ~user:"other" origin in + let other_origin = cache_selection other_origin in + List.iter + (fun (core, scope) -> + let handle = cache_download request core scope "file" in + cache_release request core scope handle; + Runner_contract.cache_unit (request core scope Core.Close_asset_scope)) + [ first; another_graph; other_user; other_origin ]; + let first_core, first_scope = first in + Runner_contract.cache_unit + (request first_core first_scope Core.Delete_account_assets); + Runner_contract.cache_unit + (request first_core first_scope Core.Delete_account_assets); + List.iter + (fun (core, scope) -> + Alcotest.(check bool) + "all account graphs removed" + true + (cache_lookup request core scope "file" = None)) + [ first; another_graph ]; + List.iter + (fun (core, scope) -> + Alcotest.(check bool) + "other namespace preserved" + true + (Option.is_some (cache_lookup request core scope "file"))) + [ other_user; other_origin ]) + in + check_retired other_report) +;; + +let test_downloaded_cache_graph_cleanup () = + with_downloaded_cache + [ cache_response "file"; cache_response "file" ] + (fun _ origin request _ -> + let first, scope = cache_selection origin in + let another, another_scope = + cache_selection + ~selected_graph:{ graph with graph_id = Core_contract.other_graph_id } + origin + in + List.iter + (fun (core, scope) -> ignore (cache_download request core scope "file")) + [ first, scope; another, another_scope ]; + Runner_contract.cache_unit (request first scope Core.Delete_graph_assets); + Runner_contract.cache_unit (request first scope Core.Delete_graph_assets); + Alcotest.(check bool) + "selected graph removed" + true + (cache_lookup request first scope "file" = None); + Alcotest.(check bool) + "other graph retained" + true + (Option.is_some (cache_lookup request another another_scope "file"))) +;; + +let scenarios = + scenarios + @ List.map + (fun (name, test) -> Alcotest.test_case name `Quick test) + [ "cache restart via submit", test_downloaded_cache_restart + ; "cache corruption via submit", test_downloaded_cache_corruption + ; "cache publication eligibility via submit", test_downloaded_cache_eligibility + ; "cache leases and budget via submit", test_downloaded_cache_leases + ; "cache downloaded filename via submit", test_downloaded_cache_filename + ; "cache legacy bin cleanup via submit", test_downloaded_cache_legacy_cleanup + ; "cache account isolation via submit", test_downloaded_cache_isolation + ; "cache account cleanup via submit", test_downloaded_cache_account_cleanup + ; "cache graph cleanup via submit", test_downloaded_cache_graph_cleanup + ] +;; diff --git a/test/macos_mutation_runtime_test.ml b/test/macos_mutation_runtime_test.ml index f127bf2..18d54b1 100644 --- a/test/macos_mutation_runtime_test.ml +++ b/test/macos_mutation_runtime_test.ml @@ -69,21 +69,6 @@ let with_worker in let sync_runner = Runner.sync_runner - ~stage_asset:(fun ~scope:_ ~operation:_ ~file_type:_ ~source_file:_ -> - Error "unexpected staging") - ~put_upload:(fun ~context:_ _ ~current:_ -> failwith "unexpected upload") - ~prune_staging:(fun ~scope:_ ~keep:_ -> Ok 0) - ~release_staging:(fun ~scope:_ ~file:_ -> Ok ()) - ~submit_asset:(fun ~context:_ ~current:_ ~post:_ _ -> - failwith "unexpected asset IO") - ~delete_assets:(fun _ -> Ok ()) - ~close_assets:(fun _ -> ()) - ~retain_staged_file:(fun ~scope:_ ~file:_ -> - failwith "unexpected staged preview") - ~retain_asset_file:(fun ~scope:_ ~handle:_ -> - failwith "unexpected asset preview") - ~release_asset_file:(fun ~scope:_ ~handle:_ -> - failwith "unexpected preview release") ~submit:(function | Sync.Request (ticket, Sync.Load_catalog _) -> let cache = @@ -99,6 +84,19 @@ let with_worker post (Core.Sync_event (Sync.Runner_completed (Sync.Completion (ticket, Ok ())))) + | Sync.Asset_io (ticket, request) -> + let result = + match request.Sync.action with + | Sync.Prune_asset_staging _ -> Ok (Sync.Asset_pruned 0) + | Close_asset_scope + | Release_asset_file _ + | Release_staged_file _ + | Cancel_asset_operation _ -> Ok Sync.Asset_unit + | _ -> failwith "unexpected fixture asset operation" + in + post + (Core.Sync_event + (Sync.Runner_completed (Sync.Asset_completion (ticket, result)))) | Cancel_effects _ | Start_websocket _ | Close_websocket _ -> () | effect_ -> failwith @@ -111,7 +109,7 @@ let with_worker ~runtime: (Runner.runtime ~sleep:(fun _ -> failwith "unexpected wait") - ~fork:(fun ~sw:_ task -> task ()) + ~fork:(fun ~sw task -> Eio.Fiber.fork ~sw task) |> Result.get_ok) ~config ~overlay: diff --git a/test/source_boundary_test.ml b/test/source_boundary_test.ml index 97d6b3b..3b66714 100644 --- a/test/source_boundary_test.ml +++ b/test/source_boundary_test.ml @@ -209,7 +209,15 @@ let test_public_api_only_test_boundaries root = in List.iter (fun relative -> - if contains_dune_internal_module_path (read_file (path root relative)) + (* The external negative compiler test intentionally names inaccessible + paths in rejected source strings, using only public spec CMIs. *) + if relative = "logseq_sync/test/test_asset_cache.ml" + then + forbid_text + root + relative + [ "logseq_sync/lib/effect_runner/."; "logseq_sync/lib/pure_reducer/." ] + else if contains_dune_internal_module_path (read_file (path root relative)) then fail "test source names an unexposed Dune module: %s" relative) ocaml_files; List.concat_map @@ -1971,6 +1979,26 @@ let () = root "app/application.ml" [ "Journal_calendar.Sampler.sample"; "Journal_calendar.present_journal_day" ]; + require_text + root + "logseq_sync/spec/pure_reducer/core.mli" + [ "type runner_effect = private"; "Asset_requested"; "Asset_finished" ]; + forbid_text + root + "logseq_sync/spec/effect_runner/effect_runner.mli" + [ "val submit_asset" + ; "val run_scoped_asset" + ; "val upload_asset" + ; "val stage_asset" + ; "val retain_asset_file" + ; "val release_asset_file" + ; "val close_asset_scope" + ; "val delete_graph_assets" + ; "val staged_asset_path" + ; "val release_staged_asset" + ; "val prune_staged_assets" + ; "val retain_staged_file" + ]; match List.rev !failures with | [] -> print_endline "source boundary is clean" | failures -> From ef62c92ede89fdd4c4cd50c63336624c334d8c70 Mon Sep 17 00:00:00 2001 From: rcmerci Date: Wed, 7 Oct 2026 13:17:42 +0800 Subject: [PATCH 2/4] Record full repository validation for sync refactor --- .../architecture/2026-10-07-2026-10-07-sync-submit-boundary.md | 1 + 1 file changed, 1 insertion(+) diff --git a/docs/agent-guide/implemented/architecture/2026-10-07-2026-10-07-sync-submit-boundary.md b/docs/agent-guide/implemented/architecture/2026-10-07-2026-10-07-sync-submit-boundary.md index d56bbf9..4c0657f 100644 --- a/docs/agent-guide/implemented/architecture/2026-10-07-2026-10-07-sync-submit-boundary.md +++ b/docs/agent-guide/implemented/architecture/2026-10-07-2026-10-07-sync-submit-boundary.md @@ -26,6 +26,7 @@ The existing download/upload/codec limits (3/1/1) and shared 64 MiB byte reserva ## Verification +- Follow-up CI-equivalent repository validation on frozen implementation `dd9488bd74f5cac47cf4495e008578d698852c70` passed: `dune build @all app/native_embed.exe.o` and `dune runtest --force` both exited 0. The full run includes 588 named Alcotest cases across 21 suites plus the remaining assertion/script regressions. Source-boundary checks, including both generated installation manifests, passed. No further interface migration omissions were found. The existing installed switch and worktree build were reused; no Dune or product changes were needed for this follow-up. Evidence is ignored under `docs/test-reports/repository-build-29.log` and `repository-runtest-30.log`. - `dune runtest logseq_sync logseq_db_worker` passed: sync main suite 182, worker runner 16, worker Core 14, Asset_upload 11, Asset_transfer 12, asset protocol 4, codec 4, descriptor 3, and public negative compilation 1. Existing protocol, overlay and LUI package checks completed under their aliases. - The public compile harness uses only exported spec interfaces through the existing test entry point. It rejects private constructor reconstruction, ticket forgery, visible Core alias construction, removed runner APIs and public/private Bootstrap access; holding and submitting effects compiles. - Ownership regressions were reproduced before fixes: cross-generation deletion completion acceptance, replacement staging identity and queued graph I/O entering authentication after deletion. Pure acceptance defects are tested only through Core.step; filesystem and scheduler defects use the narrow runner boundary. Worker tests include cancellation of queued/resolved resource outputs and actual Db shutdown with physical staging deletion. From 49b05d8dd9cd5d59cbcc53e4ee2fcf237f8ceda2 Mon Sep 17 00:00:00 2001 From: rcmerci Date: Wed, 7 Oct 2026 14:32:03 +0800 Subject: [PATCH 3/4] Record sync integration validation on merged main --- .../architecture/2026-10-07-2026-10-07-sync-submit-boundary.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/docs/agent-guide/implemented/architecture/2026-10-07-2026-10-07-sync-submit-boundary.md b/docs/agent-guide/implemented/architecture/2026-10-07-2026-10-07-sync-submit-boundary.md index 4c0657f..9d6e843 100644 --- a/docs/agent-guide/implemented/architecture/2026-10-07-2026-10-07-sync-submit-boundary.md +++ b/docs/agent-guide/implemented/architecture/2026-10-07-2026-10-07-sync-submit-boundary.md @@ -26,6 +26,7 @@ The existing download/upload/codec limits (3/1/1) and shared 64 MiB byte reserva ## Verification +- PR integration was revalidated after rebasing onto final main `6810edcce353c04449e4e27262b26b1c9ea431ed` (PR50/51). Both full CI build and forced repository tests exited 0 on integrated head `ef62c92ede89fdd4c4cd50c63336624c334d8c70`: 21 Alcotest suites and 592 named cases, plus the remaining assertion/script regressions. Source-boundary and both installation manifests passed. The 9 native caller cases and Apple/upstream interoperability were rerun successfully; production adapter RSS was 112427008 bytes, allocation 86698576 bytes, and native interop RSS 130105344 bytes. The old 588-case result below remains evidence for its frozen implementation only. Shared pin commits were dropped from this PR; final main's token control lane, soft-scroll code and two-manifest pin contract were retained. Independent integration review found no new concrete bug. Existing tests separately cover control-lane saturation and actual worker/Db asset cancellation; current Service DI cannot selectively hold an asset completion while keeping its control coordinator running, so no synthetic combined test or new test API was added. New evidence is ignored under `docs/test-reports/rebased-*`. - Follow-up CI-equivalent repository validation on frozen implementation `dd9488bd74f5cac47cf4495e008578d698852c70` passed: `dune build @all app/native_embed.exe.o` and `dune runtest --force` both exited 0. The full run includes 588 named Alcotest cases across 21 suites plus the remaining assertion/script regressions. Source-boundary checks, including both generated installation manifests, passed. No further interface migration omissions were found. The existing installed switch and worktree build were reused; no Dune or product changes were needed for this follow-up. Evidence is ignored under `docs/test-reports/repository-build-29.log` and `repository-runtest-30.log`. - `dune runtest logseq_sync logseq_db_worker` passed: sync main suite 182, worker runner 16, worker Core 14, Asset_upload 11, Asset_transfer 12, asset protocol 4, codec 4, descriptor 3, and public negative compilation 1. Existing protocol, overlay and LUI package checks completed under their aliases. - The public compile harness uses only exported spec interfaces through the existing test entry point. It rejects private constructor reconstruction, ticket forgery, visible Core alias construction, removed runner APIs and public/private Bootstrap access; holding and submitting effects compiles. @@ -33,7 +34,7 @@ The existing download/upload/codec limits (3/1/1) and shared 64 MiB byte reserva - Compiled native mutation fixtures passed all 9 cases through the migrated direct caller. - Upstream Logseq/Apple crypto interoperability passed in both directions for 0, 1, 256, 4097, 131057 and 8388608 bytes. The production 8 MiB adapter allocated 86698576 OCaml bytes and peaked at 114049024 RSS bytes; native interoperability peaked at 130252800 RSS bytes, within existing limits. - Failures and final evidence are retained only in ignored test-report directories. Tests used synthetic accounts, temporary files and localhost peers; no user graph, account or phone was tested. -- The full decision-document check has one existing baseline failure: `implemented/feature/2026-09-28-bottom-lui-capsules.md` lacks Problem, Alternatives considered and Consequences. This decision is validated separately. +- Full decision-document checks remain blocked by baseline documents: `implemented/feature/2026-09-28-bottom-lui-capsules.md` lacks Problem, Alternatives considered and Consequences; final main's `implemented/bugfix/2026-10-06-timeline-soft-scroll-edge.md` lacks Alternatives considered and Consequences. This decision is validated separately. ## Alternatives considered From 4e5f55350671fe63165ae2d4e74d7bd590bdc21a Mon Sep 17 00:00:00 2001 From: rcmerci Date: Wed, 7 Oct 2026 15:04:51 +0800 Subject: [PATCH 4/4] Reclaim completed replay records and index staged filenames --- ...6-10-07-2026-10-07-sync-submit-boundary.md | 3 + .../lib/effect_runner/effect_runner.ml | 54 +++++++------- logseq_sync/test/runner_contract.ml | 72 +++++++++++++++++++ 3 files changed, 102 insertions(+), 27 deletions(-) diff --git a/docs/agent-guide/implemented/architecture/2026-10-07-2026-10-07-sync-submit-boundary.md b/docs/agent-guide/implemented/architecture/2026-10-07-2026-10-07-sync-submit-boundary.md index 9d6e843..30993a4 100644 --- a/docs/agent-guide/implemented/architecture/2026-10-07-2026-10-07-sync-submit-boundary.md +++ b/docs/agent-guide/implemented/architecture/2026-10-07-2026-10-07-sync-submit-boundary.md @@ -24,8 +24,11 @@ Staging returns an independent physical `UUID.nonce.type` identity. A late compl The existing download/upload/codec limits (3/1/1) and shared 64 MiB byte reservation remain. Partial reservation cancellation releases acquired capacity without poisoning the acquisition gate. Reservations exceeding the shared budget fail before asset bytes are read. Local store construction permits smaller budgets without increasing production defaults. +Staging reconciliation builds a hash index of exact durable filenames once, avoiding a historical-intent scan for every directory entry. Runner replay protection weakly tracks the identity of reducer-issued private effects: a caller-held effect remains protected across GC, while an unreachable effect cannot be reconstructed through the public interface and its replay entry is reclaimable. Historical scope strings and completed requests are not retained for the runner lifetime. This changes runner execution bookkeeping only, without adding public constructors or changing reducer state ownership. + ## Verification +- PR52 automated review identified staging membership complexity and permanent replay bookkeeping. The latter is a runner-owned allocation defect that cannot be reproduced through pure Core alone. A public runner regression reproduces 154888 retained live words over 8192 completed requests before the fix and passes after it; the existing lease-replay regression also passes across a full major collection. All 22 effect-runner cases pass. Existing exact-file staging reconciliation coverage validates the membership change without duplicating policy tests. Read-only independent review found no concrete regression in weak identity lookup, held-capability GC behavior or filename indexing. The full repository build and forced tests passed again after these changes: 21 Alcotest suites, 593 named cases and the remaining assertion/script checks, including source-boundary validation. An initial sandboxed full-suite attempt denied localhost peer binding and was stopped; permission evidence was preserved and the approved rerun exited 0. Initial harness syntax and liveness corrections, the failing allocation evidence and final results remain ignored in `docs/test-reports/pr52-*`. The first PR CI run on `49b05d8` also passed; that is evidence for its earlier head only. - PR integration was revalidated after rebasing onto final main `6810edcce353c04449e4e27262b26b1c9ea431ed` (PR50/51). Both full CI build and forced repository tests exited 0 on integrated head `ef62c92ede89fdd4c4cd50c63336624c334d8c70`: 21 Alcotest suites and 592 named cases, plus the remaining assertion/script regressions. Source-boundary and both installation manifests passed. The 9 native caller cases and Apple/upstream interoperability were rerun successfully; production adapter RSS was 112427008 bytes, allocation 86698576 bytes, and native interop RSS 130105344 bytes. The old 588-case result below remains evidence for its frozen implementation only. Shared pin commits were dropped from this PR; final main's token control lane, soft-scroll code and two-manifest pin contract were retained. Independent integration review found no new concrete bug. Existing tests separately cover control-lane saturation and actual worker/Db asset cancellation; current Service DI cannot selectively hold an asset completion while keeping its control coordinator running, so no synthetic combined test or new test API was added. New evidence is ignored under `docs/test-reports/rebased-*`. - Follow-up CI-equivalent repository validation on frozen implementation `dd9488bd74f5cac47cf4495e008578d698852c70` passed: `dune build @all app/native_embed.exe.o` and `dune runtest --force` both exited 0. The full run includes 588 named Alcotest cases across 21 suites plus the remaining assertion/script regressions. Source-boundary checks, including both generated installation manifests, passed. No further interface migration omissions were found. The existing installed switch and worktree build were reused; no Dune or product changes were needed for this follow-up. Evidence is ignored under `docs/test-reports/repository-build-29.log` and `repository-runtest-30.log`. - `dune runtest logseq_sync logseq_db_worker` passed: sync main suite 182, worker runner 16, worker Core 14, Asset_upload 11, Asset_transfer 12, asset protocol 4, codec 4, descriptor 3, and public negative compilation 1. Existing protocol, overlay and LUI package checks completed under their aliases. diff --git a/logseq_sync/lib/effect_runner/effect_runner.ml b/logseq_sync/lib/effect_runner/effect_runner.ml index f0e6617..7309515 100644 --- a/logseq_sync/lib/effect_runner/effect_runner.ml +++ b/logseq_sync/lib/effect_runner/effect_runner.ml @@ -312,12 +312,22 @@ type key_entry = let asset_byte_unit = 65536 let asset_byte_budget_units = 1024 +(* The private effect cannot be reconstructed by callers. Its identity must + stay replay-protected for as long as a caller can retain and resubmit it, + without retaining historical effects (or their scope strings) ourselves. *) +module Submitted_effects = Weak.Make (struct + type t = Core.runner_effect + + let equal = ( == ) + let hash instruction = Hashtbl.hash (Core.runner_effect_diagnostic instruction) + end) + type t = { sw : Eio.Switch.t ; dependencies : dependencies ; post : Core.event -> unit ; operations : (string, operation) Hashtbl.t - ; submitted_operations : (string, unit) Hashtbl.t + ; submitted_operations : Submitted_effects.t ; keys : (string, key_entry) Hashtbl.t ; websockets : (string, Core.connection_scope * Websocket_eio.t) Hashtbl.t ; asset_download_slots : Eio.Semaphore.t @@ -336,7 +346,7 @@ let create ~sw dependencies ~post = ; dependencies ; post ; operations = Hashtbl.create 32 - ; submitted_operations = Hashtbl.create 32 + ; submitted_operations = Submitted_effects.create 32 ; keys = Hashtbl.create 8 ; websockets = Hashtbl.create 4 ; asset_download_slots = Eio.Semaphore.make 3 @@ -1456,7 +1466,9 @@ let prune_staged_assets t ~scope ~keep = match scoped_asset_cache t scope with | Error error -> Error (asset_cache_failure error) | Ok cache -> - Asset_cache.prune_staged cache ~keep:(fun operation -> Ok (List.mem operation keep)) + let retained = Hashtbl.create (List.length keep) in + List.iter (fun file -> Hashtbl.replace retained file ()) keep; + Asset_cache.prune_staged cache ~keep:(fun file -> Ok (Hashtbl.mem retained file)) |> Result.map_error asset_cache_failure) ;; @@ -1590,19 +1602,19 @@ let scoped_operation_id kind (scope : Core.graph_scope) ticket = ticket ;; -let claim_operation t id = - if Hashtbl.mem t.submitted_operations id +let claim_operation t instruction = + if Submitted_effects.mem t.submitted_operations instruction then false else ( - Hashtbl.add t.submitted_operations id (); + Submitted_effects.add t.submitted_operations instruction; true) ;; -let submit_asset_io t ticket (request : Core.asset_io_request) = +let submit_asset_io t instruction ticket (request : Core.asset_io_request) = let id = scoped_operation_id "asset" request.context.scope (Core.asset_ticket_id ticket) in - if claim_operation t id + if claim_operation t instruction then ( let cancelled, resolve_cancelled = Eio.Promise.create () in let operation = @@ -1652,14 +1664,14 @@ let execute_protected t (request : Core.protected_request) = |> Result.map (fun value -> Core.Decrypted_value value) ;; -let submit_protected t ticket (request : Core.protected_request) = +let submit_protected t instruction ticket (request : Core.protected_request) = let id = scoped_operation_id "protected" request.protected_scope (Core.protected_ticket_id ticket) in - if claim_operation t id + if claim_operation t instruction then ( let cancelled, resolve_cancelled = Eio.Promise.create () in let operation = @@ -1713,10 +1725,7 @@ let submit t instruction = | Core.Asset_io (ticket, request) -> if cleanup_asset_action request.action then ( - let id = - scoped_operation_id "asset" request.context.scope (Core.asset_ticket_id ticket) - in - if claim_operation t id + if claim_operation t instruction then ( let result = try @@ -1730,30 +1739,21 @@ let submit t instruction = t.post (Core.Runner_completed (Core.Asset_completion (ticket, result))))) else if t.closed then ( - let id = - scoped_operation_id "asset" request.context.scope (Core.asset_ticket_id ticket) - in - if claim_operation t id + if claim_operation t instruction then t.post (Core.Runner_completed (Core.Asset_completion (ticket, Error Core.Asset_cancelled)))) - else submit_asset_io t ticket request + else submit_asset_io t instruction ticket request | Protected_io (ticket, request) -> if t.closed then ( - let id = - scoped_operation_id - "protected" - request.protected_scope - (Core.protected_ticket_id ticket) - in - if claim_operation t id + if claim_operation t instruction then t.post (Core.Runner_completed (Core.Protected_completion (ticket, Error (Core.Effect_failed "Protected request cancelled"))))) - else submit_protected t ticket request + else submit_protected t instruction ticket request | _ -> submit_nonasset t instruction ;; diff --git a/logseq_sync/test/runner_contract.ml b/logseq_sync/test/runner_contract.ml index 78f18a6..2a8f2bc 100644 --- a/logseq_sync/test/runner_contract.ml +++ b/logseq_sync/test/runner_contract.ml @@ -1174,6 +1174,7 @@ let test_asset_submit_replay_does_not_mint_a_second_lease () = |> Option.get in posted := []; + Gc.full_major (); Runner.submit runner runnable; run_tasks (); Alcotest.(check int) @@ -1921,3 +1922,74 @@ let scenarios = test_graph_asset_deletion_cancels_queued_fetch_before_cache_open ] ;; + +(* Replay bookkeeping belongs to the runner, and Core cannot reproduce retained + runner allocations. Drive issued effects and their real completions through + the public boundary, retaining only the current reducer state. *) +let test_asset_submission_history_does_not_retain_completed_effects () = + with_support (fun support -> + Eio_main.run (fun environment -> + Eio.Switch.run (fun sw -> + let selected, scope = Core_contract.selected_graph Core_contract.graph in + let state = ref selected.next in + let completions = ref 0 in + let deps = + dependencies + ~environment + ~support + ~fork:(fun ~sw:_ _ -> fail "closed runner must not fork") + () + in + let runner = + Runner.create ~sw deps ~post:(fun event -> + incr completions; + state := (Core.step !state event).next) + |> Result.get_ok + in + Runner.shutdown runner; + let version = + Logseq_db_types.Asset_descriptor.version + ~checksum:(String.make 64 'a') + ~file_type:"bin" + |> Result.get_ok + in + let run count = + for index = 1 to count do + let requested = + Core.step + !state + (Core.Asset_requested + { scope + ; operation = "submission-memory-history" + ; action = Core.Check_asset_cache (graph_id (), version) + }) + in + state := requested.next; + List.iter + (function + | Core.Run runnable -> Runner.submit runner runnable + | _ -> ()) + requested.effects; + if index mod 256 = 0 then Gc.full_major () + done + in + run 512; + Gc.full_major (); + let before = (Gc.stat ()).live_words in + run 8192; + Gc.full_major (); + let growth = (Gc.stat ()).live_words - before in + Runner.shutdown runner; + Alcotest.(check int) "every issued request completed" 8704 !completions; + if growth > 32768 + then fail "completed submission history retained %d live words" growth))) +;; + +let scenarios = + scenarios + @ [ Alcotest.test_case + "completed asset submission history stays compact" + `Quick + test_asset_submission_history_does_not_retain_completed_effects + ] +;;