moonlight-delta 0.1.0.0 → 0.1.0.1
raw patch · 11 files changed
+2595/−605 lines, 11 filesdep +bytestringdep +cborg
Dependencies added: bytestring, cborg
Files
- CHANGELOG.md +44/−0
- bench/patch/PatchBench.hs +143/−12
- moonlight-delta.cabal +53/−37
- src-patch-public/Moonlight/Delta/Patch.hs +30/−4
- src-patch/Moonlight/Delta/Patch/Internal/IncrementalDigest.hs +381/−30
- src-patch/Moonlight/Delta/Patch/Internal/MerkleDeltaHash.hs +95/−54
- src-patch/Moonlight/Delta/Patch/Internal/MultisetDeltaHash.hs +65/−23
- src-patch/Moonlight/Delta/Patch/Internal/NodeCommitment.hs +26/−23
- test/patch/DeltaHashGoldenOracle.hs +326/−0
- test/patch/DeltaHashSpec.hs +1413/−422
- test/patch/DeltaHashTypeErrors.hs +19/−0
CHANGELOG.md view
@@ -1,5 +1,49 @@ # Changelog +## 0.1.0.1 - 2026-07-21++- DeltaHash protocol v3 (`deltaHashEncodingVersion`) replaces v2. Merkle leaves+ now commit complete length-framed key and value encodings on both 64-bit lanes,+ forming a 128-bit commitment; empty, leaf, branch, flat, and multiset framing+ share the protocol version. The Merkle trie uses two folds, retiring removed+ paths before admitting additions, so admitted updates agree with the final+ authoritative state. This is a deliberate wire-format break: published+ 0.1.0.0 digest bytes are not reproduced.+- DeltaHash digests are indexed by strategy and encoder. In particular,+ `merkleDeltaHashDigest` returns `MerkleDeltaHashDigest` and+ `multisetDeltaHashDigest` returns `MultisetDeltaHashDigest`; comparing the+ two is now a type error. Builders require an explicit+ `DeltaHashEncoderVersion`, and complete digests retain strategy, protocol,+ encoder, and lanes.+- Digest, identity, and lane constructors are opaque, with nominal strategy+ indices and no public raw-lane projection. `encodeDeltaHashDigest` is the+ canonical CBOR serialization of the complete identity. Concrete decoders+ reject malformed, trailing, and identity-mismatched bytes (including+ cross-strategy and cross-encoder inputs) as typed+ `DeltaHashDigestDecodeError` values.+- `composeMerkleDeltaHash` and `composeMultisetDeltaHash` are contextual:+ composing against a state succeeds exactly when sequential application does,+ preserving the resulting authoritative state and indexed digest. Success+ values, definedness, and underlying failures compose associatively; the+ `Older`/`Newer` failure-stage labels describe only the immediate binary+ operation. Contextual composition costs O(|state|); callers composing many+ small patches should fold them first and apply once. Generic `Patch.compose`+ remains endpoint composition and does not reconstruct encoder-sensitive+ intermediate representability.+- A checked-in 64-vector SipHash-2-4 oracle fixes the protocol reference values;+ incremental checked-apply and contextual-composition receipts are documented+ in `docs/BENCHMARKS-m4-pro.md`.+- Lifted the `cborg` bound to `cborg >= 0.2`: the patch implementation imports+ only public `Codec.CBOR.Decoding`, `.Encoding`, `.Read`, and `.Write` modules,+ so no `.Internal` import justifies an upper cap. The `containers` cap remains+ deliberate because this sublibrary imports `Data.Map.Internal`.+- Public named sublibraries drop the redundant package prefix:+ `moonlight-delta-core` becomes `core`, `moonlight-delta-patch` becomes+ `patch`, `moonlight-delta-epoch` becomes `epoch`, and+ `moonlight-delta-repair` becomes `repair`. Depend on them as+ `moonlight-delta:core`, `moonlight-delta:patch`, `moonlight-delta:epoch`,+ and `moonlight-delta:repair`. Every exposed module is unchanged.+ ## 0.1.0.0 - 2026-07-12 - Initial release of the boundary-aware delta calculus layered over
bench/patch/PatchBench.hs view
@@ -38,6 +38,7 @@ ( evaluate, throwIO, )+import Data.ByteString qualified as ByteString import Data.Map.Strict ( Map, )@@ -86,6 +87,7 @@ "patch" ( (patchDeltaSizes >>= patchBenchmarksForSize stateScale) <> (deltaHashStateSizes >>= deltaHash128BitRebaselineBenchmarksForSize)+ <> [deltaHashContextualCompositionBenchmarks] ) deltaHashStateSizes :: [Int]@@ -126,7 +128,7 @@ rnf fixture = rnfPatch (merkleDeltaHashFixturePatch fixture) `seq` rnf (Patch.merkleDeltaHashState (merkleDeltaHashFixtureValue fixture))- `seq` rnfDigest128 (Patch.merkleDeltaHashDigest (merkleDeltaHashFixtureValue fixture))+ `seq` rnfDeltaHashDigest (Patch.merkleDeltaHashDigest (merkleDeltaHashFixtureValue fixture)) prepareMerkleDeltaHashFixture :: Int -> IO MerkleDeltaHashFixture prepareMerkleDeltaHashFixture stateSize = do@@ -135,6 +137,7 @@ (PatchApplyFixture (initialPatchState stateSize) (sparsePatch stateSize)) case Patch.buildMerkleDeltaHash+ benchmarkEncoderVersion stableHashIntEncoding stableHashIntEncoding (pafState fixture)@@ -142,7 +145,7 @@ Left err -> throwIO (BenchmarkFixtureFailure "merkle delta hash fixture" (show err)) Right merkleDeltaHash -> do- _ <- evaluate (rnfDigest128 (Patch.merkleDeltaHashDigest merkleDeltaHash))+ _ <- evaluate (rnfDeltaHashDigest (Patch.merkleDeltaHashDigest merkleDeltaHash)) pure MerkleDeltaHashFixture { merkleDeltaHashFixturePatch = pafPatch fixture,@@ -158,7 +161,7 @@ rnf fixture = rnfPatch (multisetDeltaHashFixturePatch fixture) `seq` rnf (Patch.multisetDeltaHashState (multisetDeltaHashFixtureValue fixture))- `seq` rnfDigest128 (Patch.multisetDeltaHashDigest (multisetDeltaHashFixtureValue fixture))+ `seq` rnfDeltaHashDigest (Patch.multisetDeltaHashDigest (multisetDeltaHashFixtureValue fixture)) prepareMultisetDeltaHashFixture :: Int -> IO MultisetDeltaHashFixture prepareMultisetDeltaHashFixture stateSize = do@@ -167,10 +170,11 @@ (PatchApplyFixture (initialPatchState stateSize) (sparsePatch stateSize)) let multisetDeltaHash = Patch.buildMultisetDeltaHash+ benchmarkEncoderVersion stableHashIntEncoding stableHashIntEncoding (pafState fixture) :: Patch.MultisetDeltaHash Int Int- _ <- evaluate (rnfDigest128 (Patch.multisetDeltaHashDigest multisetDeltaHash))+ _ <- evaluate (rnfDeltaHashDigest (Patch.multisetDeltaHashDigest multisetDeltaHash)) pure MultisetDeltaHashFixture { multisetDeltaHashFixturePatch = pafPatch fixture,@@ -206,7 +210,7 @@ Left err -> benchFailure "merkle delta hash incremental apply" err Right updatedMerkleDeltaHash ->- digest128Weight (Patch.merkleDeltaHashDigest updatedMerkleDeltaHash)+ deltaHashDigestEncodingWeight (Patch.merkleDeltaHashDigest updatedMerkleDeltaHash) multisetDeltaHashWeight :: MultisetDeltaHashFixture -> (Int, Int) multisetDeltaHashWeight fixture =@@ -218,15 +222,142 @@ Left err -> benchFailure "multiset delta hash apply" err Right updatedMultisetDeltaHash ->- digest128Weight (Patch.multisetDeltaHashDigest updatedMultisetDeltaHash)+ deltaHashDigestEncodingWeight (Patch.multisetDeltaHashDigest updatedMultisetDeltaHash) -rnfDigest128 :: Patch.Digest128 -> ()-rnfDigest128 (Patch.DeltaHashDigest lane0 lane1) =- rnf lane0 `seq` rnf lane1+rnfDeltaHashDigest :: Patch.DeltaHashDigest strategy -> ()+rnfDeltaHashDigest =+ rnf . Patch.encodeDeltaHashDigest -digest128Weight :: Patch.Digest128 -> (Int, Int)-digest128Weight (Patch.DeltaHashDigest lane0 lane1) =- (fromIntegral lane0, fromIntegral lane1)+deltaHashDigestEncodingWeight :: Patch.DeltaHashDigest strategy -> (Int, Int)+deltaHashDigestEncodingWeight digestValue =+ let encodedDigest = Patch.encodeDeltaHashDigest digestValue+ in ( ByteString.length encodedDigest,+ ByteString.foldl' (\total byte -> total + fromIntegral byte) 0 encodedDigest+ )++data MerkleContextualCompositionFixture = MerkleContextualCompositionFixture+ { merkleContextualNewer :: !(Patch Int Int),+ merkleContextualOlder :: !(Patch Int Int),+ merkleContextualInitial :: !(Patch.MerkleDeltaHash Int Int)+ }++instance NFData MerkleContextualCompositionFixture where+ rnf fixture =+ rnfPatch (merkleContextualNewer fixture)+ `seq` rnfPatch (merkleContextualOlder fixture)+ `seq` rnf (Patch.merkleDeltaHashState (merkleContextualInitial fixture))+ `seq` rnfDeltaHashDigest (Patch.merkleDeltaHashDigest (merkleContextualInitial fixture))++data MultisetContextualCompositionFixture = MultisetContextualCompositionFixture+ { multisetContextualNewer :: !(Patch Int Int),+ multisetContextualOlder :: !(Patch Int Int),+ multisetContextualInitial :: !(Patch.MultisetDeltaHash Int Int)+ }++instance NFData MultisetContextualCompositionFixture where+ rnf fixture =+ rnfPatch (multisetContextualNewer fixture)+ `seq` rnfPatch (multisetContextualOlder fixture)+ `seq` rnf (Patch.multisetDeltaHashState (multisetContextualInitial fixture))+ `seq` rnfDeltaHashDigest (Patch.multisetDeltaHashDigest (multisetContextualInitial fixture))++deltaHashContextualCompositionBenchmarks :: Benchmark+deltaHashContextualCompositionBenchmarks =+ bgroup+ (caseLabel "delta hash contextual composition of two 2-row patches" contextualCompositionStateSize)+ [ env+ prepareMerkleContextualCompositionFixture+ (\fixture -> bench "Merkle" (nf merkleContextualCompositionWeight fixture)),+ env+ prepareMultisetContextualCompositionFixture+ (\fixture -> bench "multiset" (nf multisetContextualCompositionWeight fixture))+ ]++contextualCompositionStateSize :: Int+contextualCompositionStateSize =+ 4096++contextualCompositionInitialState :: Map Int Int+contextualCompositionInitialState =+ Map.fromDistinctAscList+ (fmap (\key -> (key, key)) [0 .. contextualCompositionStateSize - 1])++contextualCompositionOlderPatch :: Patch Int Int+contextualCompositionOlderPatch =+ Patch.fromAscList+ [ (0, Patch.replace 0 4096),+ (1, Patch.replace 1 4097)+ ]++contextualCompositionNewerPatch :: Patch Int Int+contextualCompositionNewerPatch =+ Patch.fromAscList+ [ (2, Patch.replace 2 4098),+ (3, Patch.replace 3 4099)+ ]++prepareMerkleContextualCompositionFixture :: IO MerkleContextualCompositionFixture+prepareMerkleContextualCompositionFixture =+ case+ Patch.buildMerkleDeltaHash+ benchmarkEncoderVersion+ stableHashIntEncoding+ stableHashIntEncoding+ contextualCompositionInitialState+ of+ Left err ->+ throwIO (BenchmarkFixtureFailure "Merkle contextual composition fixture" (show err))+ Right initialDeltaHash ->+ forceBenchmarkFixture+ MerkleContextualCompositionFixture+ { merkleContextualNewer = contextualCompositionNewerPatch,+ merkleContextualOlder = contextualCompositionOlderPatch,+ merkleContextualInitial = initialDeltaHash+ }++prepareMultisetContextualCompositionFixture :: IO MultisetContextualCompositionFixture+prepareMultisetContextualCompositionFixture =+ forceBenchmarkFixture+ MultisetContextualCompositionFixture+ { multisetContextualNewer = contextualCompositionNewerPatch,+ multisetContextualOlder = contextualCompositionOlderPatch,+ multisetContextualInitial =+ Patch.buildMultisetDeltaHash+ benchmarkEncoderVersion+ stableHashIntEncoding+ stableHashIntEncoding+ contextualCompositionInitialState+ }++merkleContextualCompositionWeight :: MerkleContextualCompositionFixture -> Int+merkleContextualCompositionWeight fixture =+ case+ Patch.composeMerkleDeltaHash+ (merkleContextualNewer fixture)+ (merkleContextualOlder fixture)+ (merkleContextualInitial fixture)+ of+ Left err ->+ benchFailure "Merkle contextual composition" err+ Right composed ->+ rnfPatch composed `seq` Patch.size composed++multisetContextualCompositionWeight :: MultisetContextualCompositionFixture -> Int+multisetContextualCompositionWeight fixture =+ case+ Patch.composeMultisetDeltaHash+ (multisetContextualNewer fixture)+ (multisetContextualOlder fixture)+ (multisetContextualInitial fixture)+ of+ Left err ->+ benchFailure "multiset contextual composition" err+ Right composed ->+ rnfPatch composed `seq` Patch.size composed++benchmarkEncoderVersion :: Patch.DeltaHashEncoderVersion+benchmarkEncoderVersion =+ Patch.DeltaHashEncoderVersion 1 patchBenchmarksForSize :: Int -> Int -> [Benchmark] patchBenchmarksForSize stateScale size =
moonlight-delta.cabal view
@@ -1,12 +1,13 @@ cabal-version: 3.0 name: moonlight-delta-version: 0.1.0.0+version: 0.1.0.1 synopsis: Boundary-aware delta calculus for Moonlight. description: Categorical and state-change delta vocabulary layered over moonlight-core. license: MIT license-file: LICENSE author: Blue Rose maintainer: rosaliafialkova@gmail.com+copyright: (c) 2026 Blue Rose category: Math homepage: https://github.com/PaleRoses/moonlight bug-reports: https://github.com/PaleRoses/moonlight/issues@@ -37,7 +38,7 @@ TypeFamilies UndecidableInstances -library moonlight-delta-core+library core import: shared-properties visibility: public hs-source-dirs: src-core@@ -56,7 +57,7 @@ , moonlight-core >= 0.1 && < 0.2 , vector >= 0.13 && < 0.14 -library moonlight-delta-patch-internal+library patch-internal import: shared-properties visibility: private hs-source-dirs: src-patch@@ -81,14 +82,16 @@ Moonlight.Delta.Patch.Internal.Page build-depends: base >= 4.22 && < 5+ , bytestring >= 0.11 && < 0.13+ , cborg >= 0.2 , containers >= 0.8 && < 0.9 , moonlight-algebra:abstract >= 0.1 && < 0.2 , moonlight-core >= 0.1 && < 0.2- , moonlight-delta:moonlight-delta-core+ , moonlight-delta:core , primitive >= 0.9 && < 0.10 , vector >= 0.13 && < 0.14 -library moonlight-delta-patch+library patch import: shared-properties visibility: public hs-source-dirs: src-patch-public@@ -96,9 +99,10 @@ Moonlight.Delta.Patch build-depends: base >= 4.22 && < 5- , moonlight-delta:moonlight-delta-patch-internal+ , bytestring >= 0.11 && < 0.13+ , moonlight-delta:patch-internal -library moonlight-delta-epoch+library epoch import: shared-properties visibility: public hs-source-dirs: src-epoch@@ -115,9 +119,9 @@ build-depends: base >= 4.22 && < 5 , moonlight-core >= 0.1 && < 0.2- , moonlight-delta:moonlight-delta-core+ , moonlight-delta:core -library moonlight-delta-repair+library repair import: shared-properties visibility: public hs-source-dirs: src-repair@@ -149,7 +153,7 @@ build-depends: containers >= 0.8 && < 0.9 , moonlight-core >= 0.1 && < 0.2- , moonlight-delta:moonlight-delta-core+ , moonlight-delta:core , tasty-hunit >= 0.10 , tasty-quickcheck >= 0.10 , QuickCheck >= 2.14@@ -163,6 +167,7 @@ main-is: Main.hs other-modules: CodecSpec+ DeltaHashGoldenOracle DeltaLaws LawManifest LawsSpec@@ -174,12 +179,16 @@ ReplaySpec SemanticsSpec DeltaHashSpec+ DeltaHashTypeErrors build-depends:- containers >= 0.8 && < 0.9+ bytestring >= 0.11 && < 0.13+ , containers >= 0.8 && < 0.9+ , moonlight-algebra:abstract >= 0.1 && < 0.2 , moonlight-core >= 0.1 && < 0.2- , moonlight-delta:moonlight-delta-core- , moonlight-delta:moonlight-delta-patch-internal- , moonlight-delta:moonlight-delta-patch+ , moonlight-delta:core+ , moonlight-delta:patch-internal+ , moonlight-delta:patch+ , vector >= 0.13 && < 0.14 , tasty-hunit >= 0.10 , tasty-quickcheck >= 0.10 , QuickCheck >= 2.14@@ -209,8 +218,8 @@ build-depends: containers >= 0.8 && < 0.9 , moonlight-core >= 0.1 && < 0.2- , moonlight-delta:moonlight-delta-core- , moonlight-delta:moonlight-delta-epoch+ , moonlight-delta:core+ , moonlight-delta:epoch , tasty-hunit >= 0.10 , tasty-quickcheck >= 0.10 , QuickCheck >= 2.14@@ -223,7 +232,7 @@ other-modules: RepairTests build-depends:- moonlight-delta:moonlight-delta-repair+ moonlight-delta:repair , tasty-hunit >= 0.10 test-suite moonlight-delta-laws-test@@ -246,9 +255,9 @@ build-depends: containers >= 0.8 && < 0.9 , moonlight-core >= 0.1 && < 0.2- , moonlight-delta:moonlight-delta-core- , moonlight-delta:moonlight-delta-epoch- , moonlight-delta:moonlight-delta-patch+ , moonlight-delta:core+ , moonlight-delta:epoch+ , moonlight-delta:patch , tasty-hunit >= 0.10 , tasty-quickcheck >= 0.10 , QuickCheck >= 2.14@@ -291,17 +300,22 @@ ReplaySpec SemanticsSpec DeltaHashSpec+ DeltaHashGoldenOracle+ DeltaHashTypeErrors TransportSpec VersionSpec ViewSpec build-depends:- containers >= 0.8 && < 0.9+ bytestring >= 0.11 && < 0.13+ , containers >= 0.8 && < 0.9+ , moonlight-algebra:abstract >= 0.1 && < 0.2 , moonlight-core >= 0.1 && < 0.2- , moonlight-delta:moonlight-delta-core- , moonlight-delta:moonlight-delta-epoch- , moonlight-delta:moonlight-delta-patch-internal- , moonlight-delta:moonlight-delta-patch- , moonlight-delta:moonlight-delta-repair+ , moonlight-delta:core+ , moonlight-delta:epoch+ , moonlight-delta:patch-internal+ , moonlight-delta:patch+ , moonlight-delta:repair+ , vector >= 0.13 && < 0.14 , tasty-hunit >= 0.10 , tasty-quickcheck >= 0.10 , QuickCheck >= 2.14@@ -328,7 +342,7 @@ build-depends: containers >= 0.8 && < 0.9 , deepseq >= 1.4- , moonlight-delta:moonlight-delta-core+ , moonlight-delta:core benchmark moonlight-delta-patch-bench import: moonlight-delta-benchmark-properties@@ -347,11 +361,12 @@ PatchBench PatchReference build-depends:- containers >= 0.8 && < 0.9+ bytestring >= 0.11 && < 0.13+ , containers >= 0.8 && < 0.9 , deepseq >= 1.4 , moonlight-core >= 0.1 && < 0.2- , moonlight-delta:moonlight-delta-core- , moonlight-delta:moonlight-delta-patch+ , moonlight-delta:core+ , moonlight-delta:patch benchmark moonlight-delta-epoch-bench import: moonlight-delta-benchmark-properties@@ -366,7 +381,7 @@ build-depends: containers >= 0.8 && < 0.9 , deepseq >= 1.4- , moonlight-delta:moonlight-delta-epoch+ , moonlight-delta:epoch benchmark moonlight-delta-repair-bench import: moonlight-delta-benchmark-properties@@ -381,7 +396,7 @@ build-depends: containers >= 0.8 && < 0.9 , deepseq >= 1.4- , moonlight-delta:moonlight-delta-repair+ , moonlight-delta:repair benchmark moonlight-delta-bench import: moonlight-delta-benchmark-properties@@ -407,10 +422,11 @@ PatchReference RepairBench build-depends:- containers >= 0.8 && < 0.9+ bytestring >= 0.11 && < 0.13+ , containers >= 0.8 && < 0.9 , deepseq >= 1.4 , moonlight-core >= 0.1 && < 0.2- , moonlight-delta:moonlight-delta-core- , moonlight-delta:moonlight-delta-epoch- , moonlight-delta:moonlight-delta-patch- , moonlight-delta:moonlight-delta-repair+ , moonlight-delta:core+ , moonlight-delta:epoch+ , moonlight-delta:patch+ , moonlight-delta:repair
src-patch-public/Moonlight/Delta/Patch.hs view
@@ -8,10 +8,21 @@ ReplayError (..), MerkleDeltaHash, MultisetDeltaHash,- Digest128,- DeltaHashDigest (..),+ DeltaHashStrategy (..),+ DeltaHashEncoderVersion (..),+ DeltaHashDigest,+ DeltaHashDigestIdentity,+ DeltaHashDigestLanes,+ MerkleDeltaHashDigest,+ MultisetDeltaHashDigest,+ deltaHashDigestIdentity,+ DeltaHashDigestDecodeError (..),+ encodeDeltaHashDigest,+ decodeMerkleDeltaHashDigest,+ decodeMultisetDeltaHashDigest, DeltaHashBuildError (..), DeltaHashApplyError (..),+ DeltaHashComposeError (..), assertAbsent, insert, delete,@@ -64,10 +75,12 @@ merkleDeltaHashState, merkleDeltaHashDigest, applyMerkleDeltaHash,+ composeMerkleDeltaHash, buildMultisetDeltaHash, multisetDeltaHashState, multisetDeltaHashDigest, applyMultisetDeltaHash,+ composeMultisetDeltaHash, ) where @@ -113,13 +126,25 @@ import Moonlight.Delta.Patch.Internal.IncrementalDigest ( DeltaHashApplyError (..), DeltaHashBuildError (..),- DeltaHashDigest (..),- Digest128,+ DeltaHashComposeError (..),+ DeltaHashDigest,+ DeltaHashDigestDecodeError (..),+ DeltaHashDigestIdentity,+ DeltaHashDigestLanes,+ DeltaHashEncoderVersion (..),+ DeltaHashStrategy (..),+ MerkleDeltaHashDigest,+ MultisetDeltaHashDigest,+ decodeMerkleDeltaHashDigest,+ decodeMultisetDeltaHashDigest,+ deltaHashDigestIdentity,+ encodeDeltaHashDigest, ) import Moonlight.Delta.Patch.Internal.MerkleDeltaHash ( MerkleDeltaHash, applyMerkleDeltaHash, buildMerkleDeltaHash,+ composeMerkleDeltaHash, merkleDeltaHashDigest, merkleDeltaHashState, )@@ -127,6 +152,7 @@ ( MultisetDeltaHash, applyMultisetDeltaHash, buildMultisetDeltaHash,+ composeMultisetDeltaHash, multisetDeltaHashDigest, multisetDeltaHashState, )
src-patch/Moonlight/Delta/Patch/Internal/IncrementalDigest.hs view
@@ -1,21 +1,53 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-} module Moonlight.Delta.Patch.Internal.IncrementalDigest- ( Digest128,+ ( DeltaHashStrategy (..),+ DigestStrategy (..),+ KnownDigestStrategy (..),+ DeltaHashEncoderVersion (..), DeltaHashDigest (..),+ DeltaHashDigestIdentity (..),+ DeltaHashDigestLanes (..),+ MerkleDeltaHashDigest,+ MultisetDeltaHashDigest,+ deltaHashDigestIdentity,+ deltaHashDigestLanes,+ DeltaHashDigestDecodeError (..),+ encodeDeltaHashDigest,+ decodeMerkleDeltaHashDigest,+ decodeMultisetDeltaHashDigest,+ RawDigest128 (..), DeltaHashBuildError (..), DeltaHashApplyError (..),+ DeltaHashComposeError (..), IncrementalDigest (..),+ composeDeltaHashPatches, deltaHashEncodingVersion,- digest128Encoding,- digest128EncodingChunks,+ sealMerkleDigest,+ sealMultisetDigest,+ rawDigestEncoding,+ rawDigestEncodingChunks, ) where +import Codec.CBOR.Decoding qualified as CBOR+import Codec.CBOR.Encoding qualified as CBOR+import Codec.CBOR.Read qualified as CBOR+import Codec.CBOR.Write qualified as CBOR import Data.Bits (Bits (shiftR, (.&.), (.|.)))+import Data.ByteString (ByteString)+import Data.ByteString.Lazy qualified as LazyByteString import Data.Foldable qualified as Foldable-import Data.Kind (Type)+import Data.Kind (Constraint, Type)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Proxy (Proxy (..)) import Data.Word (Word64) import GHC.Generics (Generic) import Moonlight.Core@@ -25,25 +57,233 @@ StableHashEncoding, stableHashEncodingDigest, stableHashEncodingLength,- stableHashEncodingVersion, stableHashUpdateEncoding, sipHashFinalize, sipHashInit, sipHashUpdateWord8, sipHashUpdateWord64LE, )-import Moonlight.Delta.Patch.Internal.Types (ApplyError, Patch)+import Moonlight.Delta.Patch.Internal.Cell (cellFromEndpoints)+import Moonlight.Delta.Patch.Internal.Construction qualified as PatchConstruction+import Moonlight.Delta.Patch.Internal.Types (ApplyError, Patch, PatchKey, PatchValue) import Prelude -data DeltaHashDigest = DeltaHashDigest- { deltaHashDigestLane0 :: {-# UNPACK #-} !Word64,- deltaHashDigestLane1 :: {-# UNPACK #-} !Word64- }+-- | The closed runtime vocabulary of digest strategies. A projected digest+-- stores exactly one of these so that a persisted value identifies the scheme+-- that produced it; verification under the wrong scheme is then a visible tag+-- mismatch rather than a silent false negative.+type DeltaHashStrategy :: Type+data DeltaHashStrategy+ = MerkleDeltaHashStrategy+ | MultisetDeltaHashStrategy deriving stock (Eq, Ord, Show, Read, Generic) -type Digest128 :: Type-type Digest128 = DeltaHashDigest+-- | The type-level counterpart of 'DeltaHashStrategy'. It indexes+-- 'DeltaHashDigest' so that comparing a Merkle digest with a multiset digest is+-- a type error, not a runtime coincidence.+type DigestStrategy :: Type+data DigestStrategy+ = MerkleDigestStrategy+ | MultisetDigestStrategy +-- | Recover the runtime strategy tag from its type-level index. This is the one+-- bridge from phantom to value, so the stored tag can never drift from the+-- phantom that a projection carries.+type KnownDigestStrategy :: DigestStrategy -> Constraint+class KnownDigestStrategy (strategy :: DigestStrategy) where+ digestStrategyValue :: proxy strategy -> DeltaHashStrategy++instance KnownDigestStrategy 'MerkleDigestStrategy where+ digestStrategyValue _proxy = MerkleDeltaHashStrategy++instance KnownDigestStrategy 'MultisetDigestStrategy where+ digestStrategyValue _proxy = MultisetDeltaHashStrategy++type DeltaHashEncoderVersion :: Type+newtype DeltaHashEncoderVersion = DeltaHashEncoderVersion Word64+ deriving stock (Eq, Ord, Show, Read, Generic)++-- | Runtime interpretation metadata for a complete digest. Its constructor is+-- internal; public values come only from sealed digests or typed decode errors.+type DeltaHashDigestIdentity :: Type+data DeltaHashDigestIdentity+ = DeltaHashDigestIdentity+ !DeltaHashStrategy+ {-# UNPACK #-} !Word64+ !DeltaHashEncoderVersion+ deriving stock (Eq, Ord, Show)++-- | The raw commitment words under a nominal strategy index. The public facade+-- exports only this type name: construction and projection remain internal, so+-- persisted consumers use 'encodeDeltaHashDigest' instead of raw words.+type DeltaHashDigestLanes :: DigestStrategy -> Type+type role DeltaHashDigestLanes nominal+data DeltaHashDigestLanes (strategy :: DigestStrategy)+ = DeltaHashDigestLanes+ {-# UNPACK #-} !Word64+ {-# UNPACK #-} !Word64+ deriving stock (Eq, Ord, Show)++-- | A self-identifying 128-bit commitment. The phantom index makes cross-scheme+-- comparison ill-typed; the stored strategy tag, protocol version, and caller-+-- supplied encoder version make a persisted digest self-describing. The public+-- facade hides the constructor: a projection may only be minted through+-- 'sealMerkleDigest' or 'sealMultisetDigest', which stamp the matching identity+-- by construction.+type DeltaHashDigest :: DigestStrategy -> Type+type role DeltaHashDigest nominal+data DeltaHashDigest (strategy :: DigestStrategy) = DeltaHashDigest+ !DeltaHashDigestIdentity+ !(DeltaHashDigestLanes strategy)+ deriving stock (Eq, Ord, Show)++deltaHashDigestIdentity :: DeltaHashDigest strategy -> DeltaHashDigestIdentity+deltaHashDigestIdentity (DeltaHashDigest identity _lanes) =+ identity++deltaHashDigestLanes :: DeltaHashDigest strategy -> DeltaHashDigestLanes strategy+deltaHashDigestLanes (DeltaHashDigest _identity lanes) =+ lanes++type MerkleDeltaHashDigest :: Type+type MerkleDeltaHashDigest = DeltaHashDigest 'MerkleDigestStrategy++type MultisetDeltaHashDigest :: Type+type MultisetDeltaHashDigest = DeltaHashDigest 'MultisetDigestStrategy++-- | A typed refusal to reinterpret persisted digest bytes under the wrong+-- strategy, protocol version, or caller-declared encoder version.+data DeltaHashDigestDecodeError+ = DeltaHashDigestMalformed !String+ | DeltaHashDigestTrailingBytes {-# UNPACK #-} !Word64+ | DeltaHashDigestUnknownStrategyTag {-# UNPACK #-} !Word64+ | DeltaHashDigestIdentityMismatch+ { deltaHashExpectedIdentity :: !DeltaHashDigestIdentity,+ deltaHashEncodedIdentity :: !DeltaHashDigestIdentity+ }+ deriving stock (Eq, Ord, Show)++-- | Canonical CBOR serialization of the complete digest identity and both+-- commitment lanes. The five fields are, in order, strategy, DeltaHash+-- protocol version, caller encoder version, lane zero, and lane one.+encodeDeltaHashDigest :: DeltaHashDigest strategy -> ByteString+encodeDeltaHashDigest+ ( DeltaHashDigest+ (DeltaHashDigestIdentity strategy protocolVersion (DeltaHashEncoderVersion encoderVersion))+ (DeltaHashDigestLanes lane0 lane1)+ ) =+ CBOR.toStrictByteString+ ( CBOR.encodeListLen 5+ <> CBOR.encodeWord64 (deltaHashStrategyTag strategy)+ <> CBOR.encodeWord64 protocolVersion+ <> CBOR.encodeWord64 encoderVersion+ <> CBOR.encodeWord64 lane0+ <> CBOR.encodeWord64 lane1+ )++decodeMerkleDeltaHashDigest ::+ DeltaHashEncoderVersion ->+ ByteString ->+ Either DeltaHashDigestDecodeError MerkleDeltaHashDigest+decodeMerkleDeltaHashDigest =+ decodeDeltaHashDigestFor (Proxy :: Proxy 'MerkleDigestStrategy)++decodeMultisetDeltaHashDigest ::+ DeltaHashEncoderVersion ->+ ByteString ->+ Either DeltaHashDigestDecodeError MultisetDeltaHashDigest+decodeMultisetDeltaHashDigest =+ decodeDeltaHashDigestFor (Proxy :: Proxy 'MultisetDigestStrategy)++decodeDeltaHashDigestFor ::+ KnownDigestStrategy strategy =>+ proxy strategy ->+ DeltaHashEncoderVersion ->+ ByteString ->+ Either DeltaHashDigestDecodeError (DeltaHashDigest strategy)+decodeDeltaHashDigestFor strategyProxy expectedEncoderVersion bytes = do+ (strategyTag, protocolVersion, encodedEncoderVersion, lane0, lane1) <-+ decodeDeltaHashDigestFields bytes+ encodedStrategy <-+ deltaHashStrategyFromTag strategyTag+ let expectedIdentity =+ deltaHashIdentityFor strategyProxy expectedEncoderVersion+ encodedIdentity =+ DeltaHashDigestIdentity+ encodedStrategy+ protocolVersion+ (DeltaHashEncoderVersion encodedEncoderVersion)+ if encodedIdentity == expectedIdentity+ then+ Right+ ( DeltaHashDigest+ encodedIdentity+ (DeltaHashDigestLanes lane0 lane1)+ )+ else+ Left+ DeltaHashDigestIdentityMismatch+ { deltaHashExpectedIdentity = expectedIdentity,+ deltaHashEncodedIdentity = encodedIdentity+ }++decodeDeltaHashDigestFields ::+ ByteString ->+ Either DeltaHashDigestDecodeError (Word64, Word64, Word64, Word64, Word64)+decodeDeltaHashDigestFields bytes =+ case CBOR.deserialiseFromBytes decodeFields (LazyByteString.fromStrict bytes) of+ Left failure ->+ Left (DeltaHashDigestMalformed (show failure))+ Right (trailingBytes, fields)+ | LazyByteString.null trailingBytes -> Right fields+ | otherwise ->+ Left+ ( DeltaHashDigestTrailingBytes+ (fromIntegral (LazyByteString.length trailingBytes))+ )+ where+ decodeFields = do+ fieldCount <- CBOR.decodeListLenCanonical+ if fieldCount == 5+ then+ (,,,,)+ <$> CBOR.decodeWord64Canonical+ <*> CBOR.decodeWord64Canonical+ <*> CBOR.decodeWord64Canonical+ <*> CBOR.decodeWord64Canonical+ <*> CBOR.decodeWord64Canonical+ else+ fail+ ( "expected DeltaHash digest field count 5, received "+ <> show fieldCount+ )++deltaHashStrategyTag :: DeltaHashStrategy -> Word64+deltaHashStrategyTag strategy =+ case strategy of+ MerkleDeltaHashStrategy -> 0+ MultisetDeltaHashStrategy -> 1++deltaHashStrategyFromTag ::+ Word64 ->+ Either DeltaHashDigestDecodeError DeltaHashStrategy+deltaHashStrategyFromTag strategyTag =+ case strategyTag of+ 0 -> Right MerkleDeltaHashStrategy+ 1 -> Right MultisetDeltaHashStrategy+ _ -> Left (DeltaHashDigestUnknownStrategyTag strategyTag)++-- | The raw two-lane commitment used to compose Merkle nodes and to compress the+-- multiset accumulator. It carries no identity because it is never compared or+-- persisted directly; identity is stamped only when a raw value is sealed into a+-- projection.+type RawDigest128 :: Type+data RawDigest128 = RawDigest128+ { rawDigestLane0 :: {-# UNPACK #-} !Word64,+ rawDigestLane1 :: {-# UNPACK #-} !Word64+ }+ deriving stock (Eq, Ord, Show)+ data DeltaHashBuildError key = DeltaHashKeyCollision { deltaHashCollisionDigest :: !StableHashDigest, deltaHashExistingKey :: !key,@@ -56,50 +296,161 @@ | DeltaHashUpdateRejected !(DeltaHashBuildError key) deriving stock (Eq, Ord, Show) +-- | Failure from one binary contextual composition. 'DeltaHashOlderPatchRejected'+-- and 'DeltaHashNewerPatchRejected' identify the failing immediate operand of+-- that binary call only. Successful glued transitions associate, and failure+-- definedness plus the enclosed 'DeltaHashApplyError' associate, but this+-- binary-local stage tag is deliberately excluded because reassociation changes+-- which immediate operand surfaces the same sequential obstruction.+data DeltaHashComposeError key value+ = DeltaHashOlderPatchRejected !(DeltaHashApplyError key value)+ | DeltaHashNewerPatchRejected !(DeltaHashApplyError key value)+ deriving stock (Eq, Ord, Show)+ class IncrementalDigest (derived :: Type -> Type -> Type) where type IncrementalDigestError derived key value :: Type- empty :: (key -> StableHashEncoding) -> (value -> StableHashEncoding) -> derived key value+ type IncrementalDigestStrategy derived :: DigestStrategy+ empty :: DeltaHashEncoderVersion -> (key -> StableHashEncoding) -> (value -> StableHashEncoding) -> derived key value applyPatch :: (Ord key, Eq value) => Patch key value -> derived key value -> Either (IncrementalDigestError derived key value) (derived key value)- digest :: derived key value -> Digest128+ incrementalDigestState :: derived key value -> Map key value+ digest :: derived key value -> DeltaHashDigest (IncrementalDigestStrategy derived) +-- | Contextually compose two patches by descending through the authoritative+-- intermediate state and gluing the exact initial-to-final transition.+--+-- Successful results associate as exact glued transitions. Failure definedness+-- and the underlying 'DeltaHashApplyError' also associate. The 'Older'/'Newer'+-- refinement in 'DeltaHashComposeError' is not associative: it names the+-- failing immediate operand of the binary call that surfaced the obstruction.+-- Cost is linear in the final state because the glued transition is constructed+-- from the authoritative initial and final maps.+composeDeltaHashPatches ::+ ( PatchKey key,+ PatchValue value,+ IncrementalDigest derived,+ IncrementalDigestError derived key value ~ DeltaHashApplyError key value+ ) =>+ Patch key value ->+ Patch key value ->+ derived key value ->+ Either (DeltaHashComposeError key value) (Patch key value)+composeDeltaHashPatches newer older initial = do+ intermediate <-+ either+ (Left . DeltaHashOlderPatchRejected)+ Right+ (applyPatch older initial)+ final <-+ either+ (Left . DeltaHashNewerPatchRejected)+ Right+ (applyPatch newer intermediate)+ pure+ ( exactStateTransition+ (incrementalDigestState initial)+ (incrementalDigestState final)+ )++exactStateTransition ::+ (PatchKey key, PatchValue value) =>+ Map key value ->+ Map key value ->+ Patch key value+exactStateTransition before after =+ PatchConstruction.fromAscList+ ( fmap+ (\(key, (beforeValue, afterValue)) -> (key, cellFromEndpoints beforeValue afterValue))+ ( Map.toAscList+ ( Map.unionWith+ combineEndpoints+ (Map.map (\afterValue -> (Nothing, Just afterValue)) after)+ (Map.map (\beforeValue -> (Just beforeValue, Nothing)) before)+ )+ )+ )++combineEndpoints ::+ (Maybe value, Maybe value) ->+ (Maybe value, Maybe value) ->+ (Maybe value, Maybe value)+combineEndpoints (leftBefore, leftAfter) (rightBefore, rightAfter) =+ (firstPresent leftBefore rightBefore, firstPresent leftAfter rightAfter)++firstPresent :: Maybe value -> Maybe value -> Maybe value+firstPresent left right =+ case left of+ Just value -> Just value+ Nothing -> right++-- | The DeltaHash protocol encoding version. Every DeltaHash node — empty, leaf,+-- branch, flat framing, and multiset framing — is bound to this single constant,+-- so the whole seam shares one protocol authority. Bumping it is a deliberate+-- wire-format break; 0.1.0.1 raises it to 3 to admit the true 128-bit leaf. deltaHashEncodingVersion :: Word64-deltaHashEncodingVersion = 2+deltaHashEncodingVersion = 3 -digest128Encoding :: SipKey -> SipKey -> StableHashEncoding -> Digest128-digest128Encoding lane0Key lane1Key encoding =- DeltaHashDigest (stableHashDigestWord lane0Key encoding) (stableHashDigestWord lane1Key encoding)+sealDigest ::+ forall strategy.+ KnownDigestStrategy strategy =>+ DeltaHashEncoderVersion ->+ RawDigest128 ->+ DeltaHashDigest strategy+sealDigest encoderVersion (RawDigest128 lane0 lane1) =+ DeltaHashDigest+ (deltaHashIdentityFor (Proxy :: Proxy strategy) encoderVersion)+ (DeltaHashDigestLanes lane0 lane1) -digest128EncodingChunks ::+deltaHashIdentityFor ::+ KnownDigestStrategy strategy =>+ proxy strategy ->+ DeltaHashEncoderVersion ->+ DeltaHashDigestIdentity+deltaHashIdentityFor strategyProxy =+ DeltaHashDigestIdentity+ (digestStrategyValue strategyProxy)+ deltaHashEncodingVersion++sealMerkleDigest :: DeltaHashEncoderVersion -> RawDigest128 -> MerkleDeltaHashDigest+sealMerkleDigest = sealDigest++sealMultisetDigest :: DeltaHashEncoderVersion -> RawDigest128 -> MultisetDeltaHashDigest+sealMultisetDigest = sealDigest++rawDigestEncoding :: SipKey -> SipKey -> StableHashEncoding -> RawDigest128+rawDigestEncoding lane0Key lane1Key encoding =+ RawDigest128 (stableHashDigestWord lane0Key encoding) (stableHashDigestWord lane1Key encoding)++rawDigestEncodingChunks :: Foldable values => SipKey -> SipKey -> (value -> StableHashEncoding) -> values value ->- Digest128-digest128EncodingChunks lane0Key lane1Key project values =- finalizeDigest128State (Foldable.foldl' absorbEncoding initialState values)+ RawDigest128+rawDigestEncodingChunks lane0Key lane1Key project values =+ finalizeRawDigestState (Foldable.foldl' absorbEncoding initialState values) where !chunkCount = fromIntegral (Foldable.length values) !initialState =- Digest128HashState+ RawDigestHashState (framedChunksSeed lane0Key chunkCount) (framedChunksSeed lane1Key chunkCount)- absorbEncoding (Digest128HashState lane0 lane1) value =+ absorbEncoding (RawDigestHashState lane0 lane1) value = let !encoding = project value !encodedLength = fromIntegral (stableHashEncodingLength encoding)- in Digest128HashState+ in RawDigestHashState (stableHashUpdateEncoding (sipHashUpdateCompactWord64 lane0 encodedLength) encoding) (stableHashUpdateEncoding (sipHashUpdateCompactWord64 lane1 encodedLength) encoding) -data Digest128HashState = Digest128HashState !SipHashState !SipHashState+data RawDigestHashState = RawDigestHashState !SipHashState !SipHashState -finalizeDigest128State :: Digest128HashState -> Digest128-finalizeDigest128State (Digest128HashState lane0 lane1) =- DeltaHashDigest (sipHashFinalize lane0) (sipHashFinalize lane1)+finalizeRawDigestState :: RawDigestHashState -> RawDigest128+finalizeRawDigestState (RawDigestHashState lane0 lane1) =+ RawDigest128 (sipHashFinalize lane0) (sipHashFinalize lane1) stableHashDigestWord :: SipKey -> StableHashEncoding -> Word64 stableHashDigestWord sipKey encoding =@@ -109,7 +460,7 @@ framedChunksSeed :: SipKey -> Word64 -> SipHashState framedChunksSeed sipKey = sipHashUpdateCompactWord64- (sipHashUpdateWord64LE (sipHashInit sipKey) stableHashEncodingVersion)+ (sipHashUpdateWord64LE (sipHashInit sipKey) deltaHashEncodingVersion) sipHashUpdateCompactWord64 :: SipHashState -> Word64 -> SipHashState sipHashUpdateCompactWord64 state wordValue =
src-patch/Moonlight/Delta/Patch/Internal/MerkleDeltaHash.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-} module Moonlight.Delta.Patch.Internal.MerkleDeltaHash ( MerkleDeltaHash,@@ -6,6 +7,7 @@ merkleDeltaHashState, merkleDeltaHashDigest, applyMerkleDeltaHash,+ composeMerkleDeltaHash, deltaHashFlatMaximumSize, ) where@@ -28,53 +30,70 @@ import Moonlight.Delta.Patch.Internal.IncrementalDigest ( DeltaHashApplyError (..), DeltaHashBuildError (..),- DeltaHashDigest,+ DeltaHashComposeError,+ DeltaHashEncoderVersion,+ DigestStrategy (..),+ MerkleDeltaHashDigest,+ RawDigest128, IncrementalDigest (..),- digest128EncodingChunks,+ composeDeltaHashPatches,+ rawDigestEncodingChunks,+ sealMerkleDigest, ) import Moonlight.Delta.Patch.Internal.NodeCommitment qualified as Node-import Moonlight.Delta.Patch.Internal.Types (Patch)+import Moonlight.Delta.Patch.Internal.Types (Patch, PatchKey, PatchValue) import Prelude data MerkleDeltaHash key value = MerkleDeltaHash- { merkleDeltaHashKeyEncoding :: !(key -> StableHashEncoding),+ { merkleDeltaHashEncoderVersion :: !DeltaHashEncoderVersion,+ merkleDeltaHashKeyEncoding :: !(key -> StableHashEncoding), merkleDeltaHashValueEncoding :: !(value -> StableHashEncoding), merkleDeltaHashAuthoritativeState :: !(Map key value), merkleDeltaHashDerivedView :: !(MerkleDeltaHashView key) } data MerkleDeltaHashView key- = FlatStableHash !DeltaHashDigest+ = FlatStableHash !RawDigest128 | IncrementalMerkleHash !(MerkleTrie key) data MerkleTrie key = MerkleEmpty- | MerkleLeaf {-# UNPACK #-} !Word64 !key !DeltaHashDigest+ | MerkleLeaf {-# UNPACK #-} !Word64 !key !RawDigest128 | MerkleBranch {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 !(MerkleTrie key) !(MerkleTrie key)- !DeltaHashDigest+ !RawDigest128 buildMerkleDeltaHash :: Eq key =>+ DeltaHashEncoderVersion -> (key -> StableHashEncoding) -> (value -> StableHashEncoding) -> Map key value -> Either (DeltaHashBuildError key) (MerkleDeltaHash key value)-buildMerkleDeltaHash encodeKey encodeValue authoritativeState =+buildMerkleDeltaHash encoderVersion encodeKey encodeValue authoritativeState = fmap- (MerkleDeltaHash encodeKey encodeValue authoritativeState)+ (MerkleDeltaHash encoderVersion encodeKey encodeValue authoritativeState) (buildMerkleDeltaHashView encodeKey encodeValue authoritativeState) merkleDeltaHashState :: MerkleDeltaHash key value -> Map key value merkleDeltaHashState = merkleDeltaHashAuthoritativeState -merkleDeltaHashDigest :: MerkleDeltaHash key value -> DeltaHashDigest-merkleDeltaHashDigest =- merkleDeltaHashViewDigest . merkleDeltaHashDerivedView+-- | The Merkle commitment to the caller-encoded __current map state__. It is a+-- state commitment, not a history commitment: two different edit histories that+-- reach the same encoded map deliberately produce the same digest. It is not a+-- provenance record or a MAC — the SipHash keys are fixed and public — and its+-- collision resistance is only as strong as the caller's key and value+-- encoders. The result is strategy-indexed, so it cannot be compared with a+-- 'MultisetDeltaHashDigest'.+merkleDeltaHashDigest :: MerkleDeltaHash key value -> MerkleDeltaHashDigest+merkleDeltaHashDigest deltaHashValue =+ sealMerkleDigest+ (merkleDeltaHashEncoderVersion deltaHashValue)+ (merkleDeltaHashViewDigest (merkleDeltaHashDerivedView deltaHashValue)) applyMerkleDeltaHash :: (Ord key, Eq value) =>@@ -101,12 +120,24 @@ ) pure MerkleDeltaHash- { merkleDeltaHashKeyEncoding = merkleDeltaHashKeyEncoding currentMerkleDeltaHash,+ { merkleDeltaHashEncoderVersion = merkleDeltaHashEncoderVersion currentMerkleDeltaHash,+ merkleDeltaHashKeyEncoding = merkleDeltaHashKeyEncoding currentMerkleDeltaHash, merkleDeltaHashValueEncoding = merkleDeltaHashValueEncoding currentMerkleDeltaHash, merkleDeltaHashAuthoritativeState = updatedState, merkleDeltaHashDerivedView = updatedView } +-- | Contextual composition costs @O(|state|)@ regardless of patch size; fold+-- many small patches first and apply once rather than composing pairwise.+composeMerkleDeltaHash ::+ (PatchKey key, PatchValue value) =>+ Patch key value ->+ Patch key value ->+ MerkleDeltaHash key value ->+ Either (DeltaHashComposeError key value) (Patch key value)+composeMerkleDeltaHash =+ composeDeltaHashPatches+ buildMerkleDeltaHashView :: Eq key => (key -> StableHashEncoding) ->@@ -138,7 +169,7 @@ IncrementalMerkleHash trie -> fmap IncrementalMerkleHash (applyPatchToTrie encodeKey encodeValue authoritativeState patchValue trie) -merkleDeltaHashViewDigest :: MerkleDeltaHashView key -> DeltaHashDigest+merkleDeltaHashViewDigest :: MerkleDeltaHashView key -> RawDigest128 merkleDeltaHashViewDigest view = case view of FlatStableHash digestValue -> digestValue@@ -152,9 +183,9 @@ (key -> StableHashEncoding) -> (value -> StableHashEncoding) -> Map key value ->- DeltaHashDigest+ RawDigest128 flatStateDigest encodeKey encodeValue authoritativeState =- digest128EncodingChunks+ rawDigestEncodingChunks defaultStableHashKey flatSipKeyLane1 (either encodeKey encodeValue)@@ -188,12 +219,9 @@ Patch.foldWithKey' const (\accumulated key after -> accumulated >>= insertEncodedValue encodeKey encodeValue key after)- (\accumulated key _before -> fmap (deleteAuthoritativeKey encodeKey authoritativeState key) accumulated)- ( \accumulated key _before after ->- accumulated- >>= replaceAuthoritativeKey encodeKey encodeValue authoritativeState key after- )- (Right initialTrie)+ (\accumulated _key _before -> accumulated)+ (\accumulated key _before after -> accumulated >>= insertEncodedValue encodeKey encodeValue key after)+ (Right (retirePatchPaths encodeKey authoritativeState patchValue initialTrie)) patchValue insertEncodedValue ::@@ -205,10 +233,11 @@ MerkleTrie key -> Either (DeltaHashBuildError key) (MerkleTrie key) insertEncodedValue encodeKey encodeValue key value =- insertMerkleLeaf- (stableHashPathWord (encodeKey key))- key- (stableHashValueWord (encodeValue value))+ let !keyEncoding = encodeKey key+ !path = Node.localizePath Node.sipHashNodeCommitment keyEncoding+ !leafCommitment =+ Node.leafDigest Node.sipHashNodeCommitment path keyEncoding (encodeValue value)+ in insertMerkleLeaf path key leafCommitment deleteEncodedKey :: Eq key =>@@ -219,6 +248,22 @@ deleteEncodedKey encodeKey key = deleteMerkleLeaf (stableHashPathWord (encodeKey key)) key +retirePatchPaths ::+ Ord key =>+ (key -> StableHashEncoding) ->+ Map key value ->+ Patch key value ->+ MerkleTrie key ->+ MerkleTrie key+retirePatchPaths encodeKey authoritativeState patchValue initialTrie =+ Patch.foldWithKey'+ const+ (\trie _key _after -> trie)+ (\trie key _before -> deleteAuthoritativeKey encodeKey authoritativeState key trie)+ (\trie key _before _after -> deleteMovedAuthoritativeKey encodeKey authoritativeState key trie)+ initialTrie+ patchValue+ deleteAuthoritativeKey :: Ord key => (key -> StableHashEncoding) ->@@ -232,43 +277,39 @@ | compare storedKey patchKey == EQ -> deleteEncodedKey encodeKey storedKey trie _ -> trie -replaceAuthoritativeKey ::+deleteMovedAuthoritativeKey :: Ord key => (key -> StableHashEncoding) ->- (value -> StableHashEncoding) -> Map key value -> key ->- value -> MerkleTrie key ->- Either (DeltaHashBuildError key) (MerkleTrie key)-replaceAuthoritativeKey encodeKey encodeValue authoritativeState patchKey after trie =+ MerkleTrie key+deleteMovedAuthoritativeKey encodeKey authoritativeState patchKey trie = case Map.lookupGE patchKey authoritativeState of Just (storedKey, _value) | compare storedKey patchKey == EQ -> let !storedPath = stableHashPathWord (encodeKey storedKey) !patchPath = stableHashPathWord (encodeKey patchKey)- !withoutStoredRepresentative =- if storedPath == patchPath- then trie- else deleteMerkleLeaf storedPath storedKey trie- in insertMerkleLeaf patchPath patchKey (stableHashValueWord (encodeValue after)) withoutStoredRepresentative- _ -> insertEncodedValue encodeKey encodeValue patchKey after trie+ in if storedPath == patchPath+ then trie+ else deleteMerkleLeaf storedPath storedKey trie+ _ -> trie insertMerkleLeaf :: Eq key => Word64 -> key ->- Word64 ->+ RawDigest128 -> MerkleTrie key -> Either (DeltaHashBuildError key) (MerkleTrie key)-insertMerkleLeaf path key valueDigest trie =+insertMerkleLeaf path key leafCommitment trie = case trie of MerkleEmpty ->- Right (merkleLeaf path key valueDigest)+ Right (merkleLeaf path key leafCommitment) MerkleLeaf existingPath existingKey _existingDigest | path == existingPath -> if key == existingKey- then Right (merkleLeaf path key valueDigest)+ then Right (merkleLeaf path key leafCommitment) else Left DeltaHashKeyCollision@@ -277,18 +318,18 @@ deltaHashIncomingKey = key } | otherwise ->- Right (linkMerkleTries path (merkleLeaf path key valueDigest) existingPath trie)+ Right (linkMerkleTries path (merkleLeaf path key leafCommitment) existingPath trie) branch@(MerkleBranch prefix branchingBit left right _branchDigest) | not (matchesPrefix path prefix branchingBit) ->- Right (linkMerkleTries path (merkleLeaf path key valueDigest) prefix branch)+ Right (linkMerkleTries path (merkleLeaf path key leafCommitment) prefix branch) | zeroAtBit path branchingBit -> fmap (\updatedLeft -> merkleBranch prefix branchingBit updatedLeft right)- (insertMerkleLeaf path key valueDigest left)+ (insertMerkleLeaf path key leafCommitment left) | otherwise -> fmap (\updatedRight -> merkleBranch prefix branchingBit left updatedRight)- (insertMerkleLeaf path key valueDigest right)+ (insertMerkleLeaf path key leafCommitment right) deleteMerkleLeaf :: Eq key =>@@ -333,9 +374,9 @@ (remaining, MerkleEmpty) -> remaining _ -> merkleBranch prefix branchingBit left right -merkleLeaf :: Word64 -> key -> Word64 -> MerkleTrie key-merkleLeaf path key valueDigest =- MerkleLeaf path key (Node.leafDigest Node.sipHashNodeCommitment path valueDigest)+merkleLeaf :: Word64 -> key -> RawDigest128 -> MerkleTrie key+merkleLeaf path key leafCommitment =+ MerkleLeaf path key leafCommitment merkleBranch :: Word64 ->@@ -351,7 +392,7 @@ right (Node.branchDigest Node.sipHashNodeCommitment prefix branchingBit (merkleTrieDigest left) (merkleTrieDigest right)) -merkleTrieDigest :: MerkleTrie key -> DeltaHashDigest+merkleTrieDigest :: MerkleTrie key -> RawDigest128 merkleTrieDigest trie = case trie of MerkleEmpty -> Node.emptyDigest Node.sipHashNodeCommitment@@ -362,9 +403,6 @@ stableHashPathWord = Node.localizePath Node.sipHashNodeCommitment -stableHashValueWord :: StableHashEncoding -> Word64-stableHashValueWord =- Node.commitValue Node.sipHashNodeCommitment deltaHashFlatMaximumSize :: Int deltaHashFlatMaximumSize =@@ -393,14 +431,17 @@ in 1 `shiftL` highestIndex emptyMerkleDeltaHash ::+ DeltaHashEncoderVersion -> (key -> StableHashEncoding) -> (value -> StableHashEncoding) -> MerkleDeltaHash key value-emptyMerkleDeltaHash encodeKey encodeValue =- MerkleDeltaHash encodeKey encodeValue Map.empty (FlatStableHash (flatStateDigest encodeKey encodeValue Map.empty))+emptyMerkleDeltaHash encoderVersion encodeKey encodeValue =+ MerkleDeltaHash encoderVersion encodeKey encodeValue Map.empty (FlatStableHash (flatStateDigest encodeKey encodeValue Map.empty)) instance IncrementalDigest MerkleDeltaHash where type IncrementalDigestError MerkleDeltaHash key value = DeltaHashApplyError key value+ type IncrementalDigestStrategy MerkleDeltaHash = 'MerkleDigestStrategy empty = emptyMerkleDeltaHash applyPatch = applyMerkleDeltaHash+ incrementalDigestState = merkleDeltaHashState digest = merkleDeltaHashDigest
src-patch/Moonlight/Delta/Patch/Internal/MultisetDeltaHash.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-} module Moonlight.Delta.Patch.Internal.MultisetDeltaHash ( MultisetDeltaHash,@@ -6,6 +7,7 @@ multisetDeltaHashState, multisetDeltaHashDigest, applyMultisetDeltaHash,+ composeMultisetDeltaHash, ) where @@ -35,29 +37,37 @@ import Moonlight.Delta.Patch.Internal.Construction qualified as Patch import Moonlight.Delta.Patch.Internal.IncrementalDigest ( DeltaHashApplyError (..),- Digest128,+ DeltaHashComposeError,+ DeltaHashEncoderVersion,+ DigestStrategy (..),+ MultisetDeltaHashDigest, IncrementalDigest (..),+ composeDeltaHashPatches, deltaHashEncodingVersion,- digest128Encoding,+ rawDigestEncoding,+ sealMultisetDigest, )-import Moonlight.Delta.Patch.Internal.Types (Patch)+import Moonlight.Delta.Patch.Internal.Types (Patch, PatchKey, PatchValue) import Prelude data MultisetDeltaHash key value = MultisetDeltaHash- { multisetDeltaHashKeyEncoding :: !(key -> StableHashEncoding),+ { multisetDeltaHashEncoderVersion :: !DeltaHashEncoderVersion,+ multisetDeltaHashKeyEncoding :: !(key -> StableHashEncoding), multisetDeltaHashValueEncoding :: !(value -> StableHashEncoding), multisetDeltaHashAuthoritativeState :: !(Map key value), multisetDeltaHashAccumulator :: !LaneVector } buildMultisetDeltaHash ::+ DeltaHashEncoderVersion -> (key -> StableHashEncoding) -> (value -> StableHashEncoding) -> Map key value -> MultisetDeltaHash key value-buildMultisetDeltaHash encodeKey encodeValue authoritativeState =+buildMultisetDeltaHash encoderVersion encodeKey encodeValue authoritativeState = MultisetDeltaHash- { multisetDeltaHashKeyEncoding = encodeKey,+ { multisetDeltaHashEncoderVersion = encoderVersion,+ multisetDeltaHashKeyEncoding = encodeKey, multisetDeltaHashValueEncoding = encodeValue, multisetDeltaHashAuthoritativeState = authoritativeState, multisetDeltaHashAccumulator =@@ -71,9 +81,25 @@ multisetDeltaHashState = multisetDeltaHashAuthoritativeState -multisetDeltaHashDigest :: MultisetDeltaHash key value -> Digest128-multisetDeltaHashDigest =- digestLaneVector . multisetDeltaHashAccumulator+-- | The homomorphic multiset commitment to the caller-encoded __current map+-- state__, compressed from a 16-lane accumulator in @(Z / 2^64 Z)^16@. Like the+-- Merkle digest it is a state commitment, not a history commitment, and not a+-- provenance record or MAC (the SipHash keys are fixed and public). Because the+-- accumulator is exactly additive, a non-injective value encoder collapses+-- distinct logical states to one digest: a replacement that subtracts and+-- re-adds an identical lane vector leaves the digest unchanged. Multiplicity is+-- modulo @2^64@ in every lane, so @2^64@ distinct keys with identical encodings+-- also contribute zero. The 1024-bit accumulator is compressed to 128 bits by+-- two fixed-key SipHash evaluations. Under the unproved ideal-independent-lane+-- assumption, generic collision work is about @2^64@ and preimage or second-+-- preimage work about @2^128@. The caller-supplied encoder version identifies+-- the encoding protocol; it does not prove encoder injectivity. The result is+-- strategy-indexed, so it cannot be compared with a 'MerkleDeltaHashDigest'.+multisetDeltaHashDigest :: MultisetDeltaHash key value -> MultisetDeltaHashDigest+multisetDeltaHashDigest deltaHashValue =+ digestLaneVector+ (multisetDeltaHashEncoderVersion deltaHashValue)+ (multisetDeltaHashAccumulator deltaHashValue) applyMultisetDeltaHash :: (Ord key, Eq value) =>@@ -112,12 +138,24 @@ patchValue pure MultisetDeltaHash- { multisetDeltaHashKeyEncoding = encodeKey,+ { multisetDeltaHashEncoderVersion = multisetDeltaHashEncoderVersion currentMultisetDeltaHash,+ multisetDeltaHashKeyEncoding = encodeKey, multisetDeltaHashValueEncoding = encodeValue, multisetDeltaHashAuthoritativeState = updatedState, multisetDeltaHashAccumulator = updatedAccumulator } +-- | Contextual composition costs @O(|state|)@ regardless of patch size; fold+-- many small patches first and apply once rather than composing pairwise.+composeMultisetDeltaHash ::+ (PatchKey key, PatchValue value) =>+ Patch key value ->+ Patch key value ->+ MultisetDeltaHash key value ->+ Either (DeltaHashComposeError key value) (Patch key value)+composeMultisetDeltaHash =+ composeDeltaHashPatches+ addEncodedEntry :: (key -> StableHashEncoding) -> (value -> StableHashEncoding) ->@@ -164,18 +202,20 @@ <> valueEncoding <> stableHashEncodingWord64LE (fromIntegral laneIndex) -digestLaneVector :: LaneVector -> Digest128-digestLaneVector laneVector =- digest128Encoding- multisetDigestSipKeyLane0- multisetDigestSipKeyLane1- ( stableHashEncodingWord8 4- <> stableHashEncodingWord64LE deltaHashEncodingVersion- <> stableHashEncodingWord64LE (fromIntegral laneCount)- <> UVector.foldl'- (\encoding lane -> encoding <> stableHashEncodingWord64LE lane)- mempty- (laneVectorLanes laneVector)+digestLaneVector :: DeltaHashEncoderVersion -> LaneVector -> MultisetDeltaHashDigest+digestLaneVector encoderVersion laneVector =+ sealMultisetDigest encoderVersion+ ( rawDigestEncoding+ multisetDigestSipKeyLane0+ multisetDigestSipKeyLane1+ ( stableHashEncodingWord8 4+ <> stableHashEncodingWord64LE deltaHashEncodingVersion+ <> stableHashEncodingWord64LE (fromIntegral laneCount)+ <> UVector.foldl'+ (\encoding lane -> encoding <> stableHashEncodingWord64LE lane)+ mempty+ (laneVectorLanes laneVector)+ ) ) storedEntryRepresentative :: Ord key => Map key value -> key -> value -> (key, value)@@ -204,6 +244,8 @@ instance IncrementalDigest MultisetDeltaHash where type IncrementalDigestError MultisetDeltaHash key value = DeltaHashApplyError key value- empty encodeKey encodeValue = buildMultisetDeltaHash encodeKey encodeValue Map.empty+ type IncrementalDigestStrategy MultisetDeltaHash = 'MultisetDigestStrategy+ empty encoderVersion encodeKey encodeValue = buildMultisetDeltaHash encoderVersion encodeKey encodeValue Map.empty applyPatch = applyMultisetDeltaHash+ incrementalDigestState = multisetDeltaHashState digest = multisetDeltaHashDigest
src-patch/Moonlight/Delta/Patch/Internal/NodeCommitment.hs view
@@ -12,14 +12,14 @@ StableHashDigest (..), StableHashEncoding, stableHashEncodingDigest,+ stableHashEncodingLength, stableHashEncodingWord8, stableHashEncodingWord64LE, ) import Moonlight.Delta.Patch.Internal.IncrementalDigest- ( DeltaHashDigest (..),- Digest128,+ ( RawDigest128 (..), deltaHashEncodingVersion,- digest128Encoding,+ rawDigestEncoding, ) import Prelude @@ -27,36 +27,42 @@ class NodeCommitment commitment where pathSipKey :: commitment -> SipKey- valueSipKey :: commitment -> SipKey emptySipKey :: commitment -> DigestSipKeys leafSipKey :: commitment -> DigestSipKeys branchSipKey :: commitment -> DigestSipKeys + -- | Deterministically localize a key encoding to a 64-bit Patricia route.+ -- This word only chooses trie branches and detects co-resident collisions; it+ -- is no longer the key commitment. The leaf binds the complete key encoding. localizePath :: commitment -> StableHashEncoding -> Word64 localizePath commitment = stableHashDigestWord (pathSipKey commitment) - commitValue :: commitment -> StableHashEncoding -> Word64- commitValue commitment =- stableHashDigestWord (valueSipKey commitment)-- emptyDigest :: commitment -> Digest128+ emptyDigest :: commitment -> RawDigest128 emptyDigest commitment = digestWithKeys (emptySipKey commitment)- (stableHashEncodingWord8 0)+ ( stableHashEncodingWord8 0+ <> stableHashEncodingWord64LE deltaHashEncodingVersion+ ) - leafDigest :: commitment -> Word64 -> Word64 -> Digest128- leafDigest commitment path valueDigest =+ -- | Commit a leaf. Both digest lanes absorb the node tag, protocol version,+ -- routing path, and the length-framed complete key and value encodings, so a+ -- 64-bit path or value collision no longer yields equal leaves.+ leafDigest :: commitment -> Word64 -> StableHashEncoding -> StableHashEncoding -> RawDigest128+ leafDigest commitment path keyEncoding valueEncoding = digestWithKeys (leafSipKey commitment) ( stableHashEncodingWord8 1 <> stableHashEncodingWord64LE deltaHashEncodingVersion <> stableHashEncodingWord64LE path- <> stableHashEncodingWord64LE valueDigest+ <> stableHashEncodingWord64LE (fromIntegral (stableHashEncodingLength keyEncoding))+ <> keyEncoding+ <> stableHashEncodingWord64LE (fromIntegral (stableHashEncodingLength valueEncoding))+ <> valueEncoding ) - branchDigest :: commitment -> Word64 -> Word64 -> Digest128 -> Digest128 -> Digest128+ branchDigest :: commitment -> Word64 -> Word64 -> RawDigest128 -> RawDigest128 -> RawDigest128 branchDigest commitment prefix branchingBit leftDigest rightDigest = digestWithKeys (branchSipKey commitment)@@ -64,10 +70,10 @@ <> stableHashEncodingWord64LE deltaHashEncodingVersion <> stableHashEncodingWord64LE prefix <> stableHashEncodingWord64LE branchingBit- <> stableHashEncodingWord64LE (deltaHashDigestLane0 leftDigest)- <> stableHashEncodingWord64LE (deltaHashDigestLane1 leftDigest)- <> stableHashEncodingWord64LE (deltaHashDigestLane0 rightDigest)- <> stableHashEncodingWord64LE (deltaHashDigestLane1 rightDigest)+ <> stableHashEncodingWord64LE (rawDigestLane0 leftDigest)+ <> stableHashEncodingWord64LE (rawDigestLane1 leftDigest)+ <> stableHashEncodingWord64LE (rawDigestLane0 rightDigest)+ <> stableHashEncodingWord64LE (rawDigestLane1 rightDigest) ) data SipHashNodeCommitment = SipHashNodeCommitment@@ -79,9 +85,6 @@ pathSipKey _commitment = SipKey 0x6d6c2d64656c7461 0x706174682d763031 - valueSipKey _commitment =- SipKey 0x6d6c2d64656c7461 0x76616c752d763031- emptySipKey _commitment = DigestSipKeys (SipKey 0x6d6c2d64656c7461 0x656d70742d763031)@@ -97,9 +100,9 @@ (SipKey 0x6d6c2d64656c7461 0x6272616e2d763031) (SipKey 0x6d6c2d64656c7461 0x6272616e2d763032) -digestWithKeys :: DigestSipKeys -> StableHashEncoding -> Digest128+digestWithKeys :: DigestSipKeys -> StableHashEncoding -> RawDigest128 digestWithKeys (DigestSipKeys lane0Key lane1Key) =- digest128Encoding lane0Key lane1Key+ rawDigestEncoding lane0Key lane1Key stableHashDigestWord :: SipKey -> StableHashEncoding -> Word64 stableHashDigestWord sipKey encoding =
+ test/patch/DeltaHashGoldenOracle.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE DerivingStrategies #-}++module DeltaHashGoldenOracle+ ( OracleDigest (..),+ oracleEmptyNodeDigest,+ oracleFlatDigest,+ oracleMultisetDigest,+ oracleSipHashReferenceVectors,+ oracleTrieDigest,+ )+where++import Control.Monad (foldM)+import Data.Bits+ ( Bits (complement, rotateL, shiftL, shiftR, xor, (.&.), (.|.)),+ FiniteBits (countLeadingZeros, finiteBitSize),+ )+import Data.List (foldl', unfoldr)+import Data.Word (Word8, Word64)+import Prelude++data OracleDigest = OracleDigest !Word64 !Word64+ deriving stock (Eq, Ord, Show)++data SipState = SipState !Word64 !Word64 !Word64 !Word64++data OracleTrie+ = OracleEmpty+ | OracleLeaf !Word64 !OracleDigest+ | OracleBranch !Word64 !Word64 !OracleTrie !OracleTrie !OracleDigest++oracleFlatDigest :: OracleDigest+oracleFlatDigest =+ digestWithKeys+ defaultLane0Key+ defaultLane1Key+ (word64LE deltaHashProtocolVersion <> compactWord64 4 <> foldMap frameChunk [word64LE 1, word64LE 10, word64LE 2, word64LE 20])++oracleEmptyNodeDigest :: OracleDigest+oracleEmptyNodeDigest =+ digestWithKeys+ emptyLane0Key+ emptyLane1Key+ (0 : word64LE deltaHashProtocolVersion)++oracleTrieDigest :: Maybe OracleDigest+oracleTrieDigest =+ fmap trieDigest+ (foldM insertEntry OracleEmpty [(key, key) | key <- [0 .. 256]])+ where+ insertEntry trie (key, value) =+ insertLeaf+ (sipHash pathKey (word64LE key))+ (leafDigest key value)+ trie++oracleMultisetDigest :: OracleDigest+oracleMultisetDigest =+ digestWithKeys+ multisetLane0Key+ multisetLane1Key+ ( 4+ : word64LE deltaHashProtocolVersion+ <> word64LE 16+ <> foldMap word64LE accumulatedLanes+ )+ where+ accumulatedLanes =+ foldl'+ (zipWith (+))+ (replicate 16 0)+ [expandedEntry 1 10, expandedEntry 2 20]++oracleSipHashReferenceVectors :: [Word64]+oracleSipHashReferenceVectors =+ fmap+ ( \messageLength ->+ sipHash+ (0x0706050403020100, 0x0f0e0d0c0b0a0908)+ (take messageLength [0 ..])+ )+ [0 .. 63]++expandedEntry :: Word64 -> Word64 -> [Word64]+expandedEntry key value =+ fmap+ ( \laneIndex ->+ sipHash+ multisetExpansionKey+ ( 3+ : word64LE deltaHashProtocolVersion+ <> word64LE 8+ <> word64LE key+ <> word64LE 8+ <> word64LE value+ <> word64LE laneIndex+ )+ )+ [0 .. 15]++leafDigest :: Word64 -> Word64 -> OracleDigest+leafDigest key value =+ digestWithKeys+ leafLane0Key+ leafLane1Key+ ( 1+ : word64LE deltaHashProtocolVersion+ <> word64LE path+ <> word64LE 8+ <> word64LE key+ <> word64LE 8+ <> word64LE value+ )+ where+ path = sipHash pathKey (word64LE key)++branchDigest :: Word64 -> Word64 -> OracleTrie -> OracleTrie -> OracleDigest+branchDigest prefix branchingBit left right =+ digestWithKeys+ branchLane0Key+ branchLane1Key+ ( 2+ : word64LE deltaHashProtocolVersion+ <> word64LE prefix+ <> word64LE branchingBit+ <> digestBytes (trieDigest left)+ <> digestBytes (trieDigest right)+ )++insertLeaf :: Word64 -> OracleDigest -> OracleTrie -> Maybe OracleTrie+insertLeaf path digestValue trie =+ case trie of+ OracleEmpty ->+ Just (OracleLeaf path digestValue)+ OracleLeaf existingPath _existingDigest+ | path == existingPath ->+ Nothing+ | otherwise ->+ linkTries path (OracleLeaf path digestValue) existingPath trie+ OracleBranch prefix branchingBit left right _branchDigest+ | maskPrefix path branchingBit /= prefix ->+ linkTries path (OracleLeaf path digestValue) prefix trie+ | zeroAtBit path branchingBit ->+ fmap (\updatedLeft -> oracleBranch prefix branchingBit updatedLeft right) (insertLeaf path digestValue left)+ | otherwise ->+ fmap (oracleBranch prefix branchingBit left) (insertLeaf path digestValue right)++linkTries :: Word64 -> OracleTrie -> Word64 -> OracleTrie -> Maybe OracleTrie+linkTries leftPath leftTrie rightPath rightTrie = do+ branchingBit <- highestDifferingBit leftPath rightPath+ let prefix = maskPrefix leftPath branchingBit+ pure+ ( if zeroAtBit leftPath branchingBit+ then oracleBranch prefix branchingBit leftTrie rightTrie+ else oracleBranch prefix branchingBit rightTrie leftTrie+ )++oracleBranch :: Word64 -> Word64 -> OracleTrie -> OracleTrie -> OracleTrie+oracleBranch prefix branchingBit left right =+ OracleBranch prefix branchingBit left right (branchDigest prefix branchingBit left right)++trieDigest :: OracleTrie -> OracleDigest+trieDigest trie =+ case trie of+ OracleEmpty -> oracleEmptyNodeDigest+ OracleLeaf _path digestValue -> digestValue+ OracleBranch _prefix _branchingBit _left _right digestValue -> digestValue++highestDifferingBit :: Word64 -> Word64 -> Maybe Word64+highestDifferingBit leftPath rightPath =+ let differentBits = leftPath `xor` rightPath+ in if differentBits == 0+ then Nothing+ else+ Just+ ( 1+ `shiftL` (finiteBitSize differentBits - countLeadingZeros differentBits - 1)+ )++maskPrefix :: Word64 -> Word64 -> Word64+maskPrefix path branchingBit =+ path .&. complement (branchingBit .|. (branchingBit - 1))++zeroAtBit :: Word64 -> Word64 -> Bool+zeroAtBit path branchingBit =+ path .&. branchingBit == 0++digestWithKeys :: (Word64, Word64) -> (Word64, Word64) -> [Word8] -> OracleDigest+digestWithKeys lane0Key lane1Key bytes =+ OracleDigest (sipHash lane0Key bytes) (sipHash lane1Key bytes)++digestBytes :: OracleDigest -> [Word8]+digestBytes (OracleDigest lane0 lane1) =+ word64LE lane0 <> word64LE lane1++frameChunk :: [Word8] -> [Word8]+frameChunk bytes =+ compactWord64 (fromIntegral (length bytes)) <> bytes++word64LE :: Word64 -> [Word8]+word64LE word =+ fmap (fromIntegral . (word `shiftR`) . (* 8)) [0 .. 7]++packWord64 :: [Word8] -> Word64+packWord64 bytes =+ foldl'+ (.|.)+ 0+ (zipWith (\shift byte -> fromIntegral byte `shiftL` shift) [0, 8 ..] bytes)++compactWord64 :: Word64 -> [Word8]+compactWord64 =+ unfoldr+ ( \maybeWord ->+ case maybeWord of+ Nothing -> Nothing+ Just word ->+ let byte = fromIntegral (word .&. 0x7f)+ remaining = word `shiftR` 7+ in Just+ ( if remaining == 0 then byte else byte .|. 0x80,+ if remaining == 0 then Nothing else Just remaining+ )+ )+ . Just++sipHash :: (Word64, Word64) -> [Word8] -> Word64+sipHash (key0, key1) bytes =+ finalizeSipState+ (applySipRounds 4 (xorSecondStateWord 0xff absorbedFinalBlock))+ where+ initialState =+ SipState+ (key0 `xor` 0x736f6d6570736575)+ (key1 `xor` 0x646f72616e646f6d)+ (key0 `xor` 0x6c7967656e657261)+ (key1 `xor` 0x7465646279746573)+ chunks =+ unfoldr+ ( \remaining ->+ case remaining of+ [] -> Nothing+ _ -> Just (splitAt 8 remaining)+ )+ bytes+ fullBlocks = filter ((== 8) . length) chunks+ trailingBytes = foldMap (\chunk -> if length chunk < 8 then chunk else []) chunks+ absorbedBlocks = foldl' absorbBlock initialState (fmap packWord64 fullBlocks)+ finalBlock =+ (fromIntegral (length bytes) `shiftL` 56)+ .|. packWord64 trailingBytes+ absorbedFinalBlock = absorbBlock absorbedBlocks finalBlock++absorbBlock :: SipState -> Word64 -> SipState+absorbBlock (SipState v0 v1 v2 v3) block =+ case applySipRounds 2 (SipState v0 v1 v2 (v3 `xor` block)) of+ SipState r0 r1 r2 r3 -> SipState (r0 `xor` block) r1 r2 r3++applySipRounds :: Int -> SipState -> SipState+applySipRounds count initialState =+ foldl' (\state _round -> sipRound state) initialState [1 .. count]++sipRound :: SipState -> SipState+sipRound (SipState v0 v1 v2 v3) =+ SipState i0 i1 i2 i3+ where+ a0 = v0 + v1+ a1 = rotateL v1 13 `xor` a0+ a2 = rotateL a0 32+ b2 = v2 + v3+ b3 = rotateL v3 16 `xor` b2+ c0 = a2 + b3+ c3 = rotateL b3 21 `xor` c0+ d2 = b2 + a1+ d1 = rotateL a1 17 `xor` d2+ i0 = c0+ i1 = d1+ i2 = rotateL d2 32+ i3 = c3++xorSecondStateWord :: Word64 -> SipState -> SipState+xorSecondStateWord word (SipState v0 v1 v2 v3) =+ SipState v0 v1 (v2 `xor` word) v3++finalizeSipState :: SipState -> Word64+finalizeSipState (SipState v0 v1 v2 v3) =+ v0 `xor` v1 `xor` v2 `xor` v3++deltaHashProtocolVersion :: Word64+deltaHashProtocolVersion = 3++defaultLane0Key :: (Word64, Word64)+defaultLane0Key = (0x6d6f6f6e6c696768, 0x742d636f72652d31)++defaultLane1Key :: (Word64, Word64)+defaultLane1Key = (0x6d6f6f6e6c696768, 0x742d636f72652d32)++pathKey :: (Word64, Word64)+pathKey = (0x6d6c2d64656c7461, 0x706174682d763031)++emptyLane0Key :: (Word64, Word64)+emptyLane0Key = (0x6d6c2d64656c7461, 0x656d70742d763031)++emptyLane1Key :: (Word64, Word64)+emptyLane1Key = (0x6d6c2d64656c7461, 0x656d70742d763032)++leafLane0Key :: (Word64, Word64)+leafLane0Key = (0x6d6c2d64656c7461, 0x6c6561662d763031)++leafLane1Key :: (Word64, Word64)+leafLane1Key = (0x6d6c2d64656c7461, 0x6c6561662d763032)++branchLane0Key :: (Word64, Word64)+branchLane0Key = (0x6d6c2d64656c7461, 0x6272616e2d763031)++branchLane1Key :: (Word64, Word64)+branchLane1Key = (0x6d6c2d64656c7461, 0x6272616e2d763032)++multisetExpansionKey :: (Word64, Word64)+multisetExpansionKey = (0x6d6c2d64656c7461, 0x6d756c74692d7632)++multisetLane0Key :: (Word64, Word64)+multisetLane0Key = (0x6d6c2d64656c7461, 0x6d7365742d763031)++multisetLane1Key :: (Word64, Word64)+multisetLane1Key = (0x6d6c2d64656c7461, 0x6d7365742d763032)
test/patch/DeltaHashSpec.hs view
@@ -5,428 +5,1419 @@ ) where -import Data.Map.Strict (Map)-import Data.Map.Strict qualified as Map-import Moonlight.Core- ( StableHashEncoding,- stableHashEncodingWord64LE,- )-import Moonlight.Delta.Patch- ( ApplyError (..),- DeltaHashApplyError (..),- DeltaHashBuildError (..),- DeltaHashDigest (..),- Digest128,- MerkleDeltaHash,- MultisetDeltaHash,- )-import Moonlight.Delta.Patch qualified as Patch-import Test.QuickCheck- ( Gen,- Property,- chooseInt,- counterexample,- forAll,- listOf,- (===),- )-import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit ((@?=), assertFailure, testCase)-import Test.Tasty.QuickCheck (testProperty)--deltaHashTests :: TestTree-deltaHashTests =- testGroup- "delta hash"- [ testProperty "Merkle patch agrees with rebuild" merklePatchAgreesWithRebuild,- testProperty "Merkle edit history descends to one root" merkleHistoryDescendsToCanonicalRoot,- testProperty "multiset patch agrees with rebuild" multisetPatchAgreesWithRebuild,- testProperty "multiset disjoint union composes through the patch action" multisetDisjointUnionHomomorphism,- testProperty "multiset insertion and deletion are additive inverses" multisetAdditiveInverse,- testProperty "multiset disjoint edit order is history-independent" multisetOrderIndependence,- testCase "Merkle crosses the adaptive boundary in both directions" adaptiveBoundaryCase,- testCase "all four cell edits update both strategies" cellEditsCase,- testCase "stale patch rejection is preserved on both strategies" stalePatchCase,- testCase "equal key representatives rebuild on both strategies" representativeRewriteCase,- testCase "equal value representatives rebuild on both strategies" valueRepresentativeRewriteCase,- testCase "flat mode admits localized path collisions" flatModeCollisionCase,- testCase "Merkle construction reports one localized path collision" constructionCollisionCase,- testCase "Merkle insertion reports a localized path collision atomically" updateCollisionCase,- testCase "128-bit digest construction matches protocol goldens" digestGoldenCase- ]--merklePatchAgreesWithRebuild :: Property-merklePatchAgreesWithRebuild =- forAll smallMapGen $ \beforeState ->- forAll smallMapGen $ \afterState ->- case (buildTestMerkleDeltaHash beforeState, buildTestMerkleDeltaHash afterState) of- (Right beforeDeltaHash, Right rebuiltDeltaHash) ->- fmap- merkleObservation- (Patch.applyMerkleDeltaHash (Patch.diff beforeState afterState) beforeDeltaHash)- === Right (merkleObservation rebuiltDeltaHash)- (Left obstruction, _) ->- counterexample ("unexpected initial key collision: " <> show obstruction) False- (_, Left obstruction) ->- counterexample ("unexpected rebuilt key collision: " <> show obstruction) False--merkleHistoryDescendsToCanonicalRoot :: Property-merkleHistoryDescendsToCanonicalRoot =- forAll smallMapGen $ \middleState ->- forAll smallMapGen $ \finalState ->- case (buildTestMerkleDeltaHash Map.empty, buildTestMerkleDeltaHash finalState) of- (Right emptyDeltaHash, Right rebuiltDeltaHash) ->- let descended = do- middleDeltaHash <-- Patch.applyMerkleDeltaHash- (Patch.diff Map.empty middleState)- emptyDeltaHash- Patch.applyMerkleDeltaHash- (Patch.diff middleState finalState)- middleDeltaHash- in fmap merkleObservation descended- === Right (merkleObservation rebuiltDeltaHash)- (Left obstruction, _) ->- counterexample ("unexpected empty Merkle failure: " <> show obstruction) False- (_, Left obstruction) ->- counterexample ("unexpected final key collision: " <> show obstruction) False--multisetPatchAgreesWithRebuild :: Property-multisetPatchAgreesWithRebuild =- forAll smallMapGen $ \beforeState ->- forAll smallMapGen $ \afterState ->- let beforeDeltaHash = buildTestMultisetDeltaHash beforeState- rebuiltDeltaHash = buildTestMultisetDeltaHash afterState- in fmap- multisetObservation- (Patch.applyMultisetDeltaHash (Patch.diff beforeState afterState) beforeDeltaHash)- === Right (multisetObservation rebuiltDeltaHash)--multisetDisjointUnionHomomorphism :: Property-multisetDisjointUnionHomomorphism =- forAll smallMapGen $ \authoritativeState ->- let (leftState, rightState) =- Map.partitionWithKey (\key _value -> even key) authoritativeState- combinedState = Map.union leftState rightState- combinedByAction =- Patch.applyMultisetDeltaHash- (Patch.diff Map.empty rightState)- (buildTestMultisetDeltaHash leftState)- in fmap multisetObservation combinedByAction- === Right (multisetObservation (buildTestMultisetDeltaHash combinedState))--multisetAdditiveInverse :: Property-multisetAdditiveInverse =- forAll smallMapGen $ \authoritativeState ->- let freshKey = 4096- freshValue = 17- initialDeltaHash = buildTestMultisetDeltaHash authoritativeState- roundTrip = do- insertedDeltaHash <-- Patch.applyMultisetDeltaHash- (Patch.singleton freshKey (Patch.insert freshValue))- initialDeltaHash- Patch.applyMultisetDeltaHash- (Patch.singleton freshKey (Patch.delete freshValue))- insertedDeltaHash- in fmap multisetObservation roundTrip- === Right (multisetObservation initialDeltaHash)--multisetOrderIndependence :: Property-multisetOrderIndependence =- forAll smallMapGen $ \authoritativeState ->- let (leftState, rightState) =- Map.partitionWithKey (\key _value -> even key) authoritativeState- leftPatch = Patch.diff Map.empty leftState- rightPatch = Patch.diff Map.empty rightState- emptyDeltaHash = buildTestMultisetDeltaHash Map.empty- leftThenRight = do- leftDeltaHash <- Patch.applyMultisetDeltaHash leftPatch emptyDeltaHash- Patch.applyMultisetDeltaHash rightPatch leftDeltaHash- rightThenLeft = do- rightDeltaHash <- Patch.applyMultisetDeltaHash rightPatch emptyDeltaHash- Patch.applyMultisetDeltaHash leftPatch rightDeltaHash- expectedObservation =- multisetObservation (buildTestMultisetDeltaHash authoritativeState)- in (fmap multisetObservation leftThenRight, fmap multisetObservation rightThenLeft)- === (Right expectedObservation, Right expectedObservation)--adaptiveBoundaryCase :: IO ()-adaptiveBoundaryCase = do- let boundaryState = sequentialState deltaHashFlatBoundarySize- insertedKey = deltaHashFlatBoundarySize- expandedState = Map.insert insertedKey insertedKey boundaryState- boundaryDeltaHash <- requireRight (buildTestMerkleDeltaHash boundaryState)- expandedDeltaHash <-- requireRight- ( Patch.applyMerkleDeltaHash- (Patch.singleton insertedKey (Patch.insert insertedKey))- boundaryDeltaHash- )- rebuiltExpandedDeltaHash <- requireRight (buildTestMerkleDeltaHash expandedState)- merkleObservation expandedDeltaHash- @?= merkleObservation rebuiltExpandedDeltaHash- contractedDeltaHash <-- requireRight- ( Patch.applyMerkleDeltaHash- (Patch.singleton insertedKey (Patch.delete insertedKey))- expandedDeltaHash- )- merkleObservation contractedDeltaHash- @?= merkleObservation boundaryDeltaHash--cellEditsCase :: IO ()-cellEditsCase = do- let initialState = Map.fromList [(1, 10), (2, 20)]- expectedState = Map.fromList [(1, 11), (3, 30)]- patchValue =- Patch.fromList- [ (1, Patch.replace 10 11),- (2, Patch.delete 20),- (3, Patch.insert 30),- (4, Patch.assertAbsent)- ]- initialMerkleDeltaHash <- requireRight (buildTestMerkleDeltaHash initialState)- updatedMerkleDeltaHash <-- requireRight (Patch.applyMerkleDeltaHash patchValue initialMerkleDeltaHash)- rebuiltMerkleDeltaHash <- requireRight (buildTestMerkleDeltaHash expectedState)- merkleObservation updatedMerkleDeltaHash- @?= merkleObservation rebuiltMerkleDeltaHash- updatedMultisetDeltaHash <-- requireRight- ( Patch.applyMultisetDeltaHash- patchValue- (buildTestMultisetDeltaHash initialState)- )- multisetObservation updatedMultisetDeltaHash- @?= multisetObservation (buildTestMultisetDeltaHash expectedState)--stalePatchCase :: IO ()-stalePatchCase = do- let initialState = Map.singleton 1 10- patchValue = Patch.singleton 1 (Patch.replace 9 11)- expectedObstruction =- DeltaHashPatchRejected- ApplyBeforeMismatch- { mismatchKey = 1,- expectedBefore = Just 9,- actualBefore = Just 10- }- initialMerkleDeltaHash <- requireRight (buildTestMerkleDeltaHash initialState)- case Patch.applyMerkleDeltaHash patchValue initialMerkleDeltaHash of- Left obstruction ->- obstruction @?= expectedObstruction- Right _deltaHash ->- assertFailure "expected stale Merkle patch to be rejected"- case Patch.applyMultisetDeltaHash patchValue (buildTestMultisetDeltaHash initialState) of- Left obstruction ->- obstruction @?= expectedObstruction- Right _deltaHash ->- assertFailure "expected stale multiset patch to be rejected"--representativeRewriteCase :: IO ()-representativeRewriteCase = do- let stateEntry key =- (RepresentativeKey key StateRepresentative, key * 10)- expectedEntry key- | key == 1 = (RepresentativeKey key PatchRepresentative, 11)- | otherwise = stateEntry key- keys = [1 .. deltaHashFlatBoundarySize + 1]- initialState = Map.fromDistinctAscList (fmap stateEntry keys)- expectedState = Map.fromDistinctAscList (fmap expectedEntry keys)- patchKey = RepresentativeKey 1 PatchRepresentative- patchValue = Patch.singleton patchKey (Patch.replace 10 11)- initialMerkleDeltaHash <-- requireRight- (Patch.buildMerkleDeltaHash representativeKeyEncoding intEncoding initialState)- updatedMerkleDeltaHash <-- requireRight (Patch.applyMerkleDeltaHash patchValue initialMerkleDeltaHash)- rebuiltMerkleDeltaHash <-- requireRight- (Patch.buildMerkleDeltaHash representativeKeyEncoding intEncoding expectedState)- Patch.merkleDeltaHashDigest updatedMerkleDeltaHash- @?= Patch.merkleDeltaHashDigest rebuiltMerkleDeltaHash- fmap (representativeKind . fst) (Map.lookupGE patchKey (Patch.merkleDeltaHashState updatedMerkleDeltaHash))- @?= Just PatchRepresentative- let initialMultisetDeltaHash =- Patch.buildMultisetDeltaHash representativeKeyEncoding intEncoding initialState- rebuiltMultisetDeltaHash =- Patch.buildMultisetDeltaHash representativeKeyEncoding intEncoding expectedState- updatedMultisetDeltaHash <-- requireRight (Patch.applyMultisetDeltaHash patchValue initialMultisetDeltaHash)- Patch.multisetDeltaHashDigest updatedMultisetDeltaHash- @?= Patch.multisetDeltaHashDigest rebuiltMultisetDeltaHash- fmap (representativeKind . fst) (Map.lookupGE patchKey (Patch.multisetDeltaHashState updatedMultisetDeltaHash))- @?= Just PatchRepresentative--valueRepresentativeRewriteCase :: IO ()-valueRepresentativeRewriteCase = do- let stateValue = RepresentativeValue 10 StateRepresentative- patchBefore = RepresentativeValue 10 PatchRepresentative- patchAfter = RepresentativeValue 11 PatchRepresentative- initialState = Map.singleton 1 stateValue- expectedState = Map.singleton 1 patchAfter- patchValue = Patch.singleton 1 (Patch.replace patchBefore patchAfter)- initialMerkleDeltaHash <-- requireRight- (Patch.buildMerkleDeltaHash intEncoding representativeValueEncoding initialState)- updatedMerkleDeltaHash <-- requireRight (Patch.applyMerkleDeltaHash patchValue initialMerkleDeltaHash)- rebuiltMerkleDeltaHash <-- requireRight- (Patch.buildMerkleDeltaHash intEncoding representativeValueEncoding expectedState)- Patch.merkleDeltaHashDigest updatedMerkleDeltaHash- @?= Patch.merkleDeltaHashDigest rebuiltMerkleDeltaHash- let initialMultisetDeltaHash =- Patch.buildMultisetDeltaHash intEncoding representativeValueEncoding initialState- rebuiltMultisetDeltaHash =- Patch.buildMultisetDeltaHash intEncoding representativeValueEncoding expectedState- updatedMultisetDeltaHash <-- requireRight (Patch.applyMultisetDeltaHash patchValue initialMultisetDeltaHash)- Patch.multisetDeltaHashDigest updatedMultisetDeltaHash- @?= Patch.multisetDeltaHashDigest rebuiltMultisetDeltaHash--flatModeCollisionCase :: IO ()-flatModeCollisionCase = do- let authoritativeState = Map.fromList [(1, 10), (2, 20)]- deltaHashValue <-- requireRight- (Patch.buildMerkleDeltaHash constantEncoding intEncoding authoritativeState)- Patch.merkleDeltaHashState deltaHashValue @?= authoritativeState--constructionCollisionCase :: IO ()-constructionCollisionCase =- case- Patch.buildMerkleDeltaHash- boundaryCollisionEncoding- intEncoding- (sequentialState (deltaHashFlatBoundarySize + 1))- of- Left DeltaHashKeyCollision {deltaHashExistingKey, deltaHashIncomingKey} ->- (deltaHashExistingKey, deltaHashIncomingKey)- @?= (0, deltaHashFlatBoundarySize)- Right _deltaHash ->- assertFailure "expected distinct keys with one digest path to be rejected"--updateCollisionCase :: IO ()-updateCollisionCase = do- let authoritativeState = sequentialState deltaHashFlatBoundarySize- incomingKey = deltaHashFlatBoundarySize- initialDeltaHash <-- requireRight- (Patch.buildMerkleDeltaHash boundaryCollisionEncoding intEncoding authoritativeState)- case- Patch.applyMerkleDeltaHash- (Patch.singleton incomingKey (Patch.insert incomingKey))- initialDeltaHash- of- Left (DeltaHashUpdateRejected DeltaHashKeyCollision {}) ->- Patch.merkleDeltaHashState initialDeltaHash @?= authoritativeState- Left obstruction ->- assertFailure ("expected collision obstruction, received: " <> show obstruction)- Right _deltaHash ->- assertFailure "expected insertion collision to be rejected"--digestGoldenCase :: IO ()-digestGoldenCase = do- flatDeltaHash <-- requireRight (buildTestMerkleDeltaHash (Map.fromList [(1, 10), (2, 20)]))- Patch.merkleDeltaHashDigest flatDeltaHash- @?= DeltaHashDigest 0x897d1ee3ac05ae2f 0x24244b4e097f0dd5- merkleDeltaHash <-- requireRight- (buildTestMerkleDeltaHash (sequentialState (deltaHashFlatBoundarySize + 1)))- Patch.merkleDeltaHashDigest merkleDeltaHash- @?= DeltaHashDigest 0x34c7f2a72e9f90b2 0xd725d3dd1caef993- Patch.multisetDeltaHashDigest- (buildTestMultisetDeltaHash (Map.fromList [(1, 10), (2, 20)]))- @?= DeltaHashDigest 0xa3b63bd3bb34ff9e 0x2e36babb08d75d1e--merkleObservation :: MerkleDeltaHash Int Int -> (Map Int Int, Digest128)-merkleObservation deltaHashValue =- (Patch.merkleDeltaHashState deltaHashValue, Patch.merkleDeltaHashDigest deltaHashValue)--multisetObservation :: MultisetDeltaHash Int Int -> (Map Int Int, Digest128)-multisetObservation deltaHashValue =- (Patch.multisetDeltaHashState deltaHashValue, Patch.multisetDeltaHashDigest deltaHashValue)--buildTestMerkleDeltaHash ::- Map Int Int ->- Either (DeltaHashBuildError Int) (MerkleDeltaHash Int Int)-buildTestMerkleDeltaHash =- Patch.buildMerkleDeltaHash intEncoding intEncoding--buildTestMultisetDeltaHash :: Map Int Int -> MultisetDeltaHash Int Int-buildTestMultisetDeltaHash =- Patch.buildMultisetDeltaHash intEncoding intEncoding--sequentialState :: Int -> Map Int Int-sequentialState stateSize =- Map.fromDistinctAscList (fmap (\key -> (key, key)) [0 .. stateSize - 1])--intEncoding :: Int -> StableHashEncoding-intEncoding =- stableHashEncodingWord64LE . fromIntegral--boundaryCollisionEncoding :: Int -> StableHashEncoding-boundaryCollisionEncoding key- | key == deltaHashFlatBoundarySize = intEncoding 0- | otherwise = intEncoding key--constantEncoding :: Int -> StableHashEncoding-constantEncoding _value =- stableHashEncodingWord64LE 0--data RepresentativeKind- = StateRepresentative- | PatchRepresentative- deriving stock (Eq, Ord, Show)--data RepresentativeKey = RepresentativeKey- { representativeId :: !Int,- representativeKind :: !RepresentativeKind- }- deriving stock (Show)--instance Eq RepresentativeKey where- left == right =- representativeId left == representativeId right--instance Ord RepresentativeKey where- compare left right =- compare (representativeId left) (representativeId right)--representativeKeyEncoding :: RepresentativeKey -> StableHashEncoding-representativeKeyEncoding representative =- intEncoding (representativeId representative)- <> representativeKindEncoding (representativeKind representative)--data RepresentativeValue = RepresentativeValue- { representativeValueId :: !Int,- representativeValueKind :: !RepresentativeKind- }- deriving stock (Show)--instance Eq RepresentativeValue where- left == right =- representativeValueId left == representativeValueId right--representativeValueEncoding :: RepresentativeValue -> StableHashEncoding-representativeValueEncoding representative =- intEncoding (representativeValueId representative)- <> representativeKindEncoding (representativeValueKind representative)--representativeKindEncoding :: RepresentativeKind -> StableHashEncoding-representativeKindEncoding representative =- stableHashEncodingWord64LE- ( case representative of- StateRepresentative -> 0- PatchRepresentative -> 1- )--smallMapGen :: Gen (Map Int Int)-smallMapGen =- Map.fromList <$> listOf ((,) <$> chooseInt (-32, 32) <*> chooseInt (-1000, 1000))+import Control.Exception (TypeError, evaluate, try)+import Control.Monad (foldM, void)+import Data.ByteString qualified as ByteString+import Data.Foldable (traverse_)+import Data.List (isInfixOf)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Vector.Unboxed qualified as UVector+import Data.Word (Word64)+import DeltaHashGoldenOracle+ ( OracleDigest (..),+ oracleEmptyNodeDigest,+ oracleFlatDigest,+ oracleMultisetDigest,+ oracleSipHashReferenceVectors,+ oracleTrieDigest,+ )+import DeltaHashTypeErrors+ ( crossStrategyDigestComparison,+ )+import Moonlight.Algebra.Pure.LaneVector+ ( laneCount,+ laneVectorFromLanes,+ laneVectorLanes,+ laneVectorZero,+ )+import Moonlight.Core+ ( AdditiveGroup (sub),+ AdditiveMonoid (add),+ StableHashEncoding,+ stableHashEncodingWord8,+ stableHashEncodingWord64LE,+ )+import Moonlight.Delta.Patch+ ( ApplyError (..),+ DeltaHashApplyError (..),+ DeltaHashBuildError (..),+ DeltaHashComposeError (..),+ DeltaHashDigestDecodeError (..),+ DeltaHashEncoderVersion (..),+ MerkleDeltaHash,+ MerkleDeltaHashDigest,+ MultisetDeltaHash,+ MultisetDeltaHashDigest,+ )+import Moonlight.Delta.Patch qualified as Patch+import Moonlight.Delta.Patch.Internal.IncrementalDigest+ ( DeltaHashDigestLanes (..),+ RawDigest128 (..),+ deltaHashDigestLanes,+ )+import Moonlight.Delta.Patch.Internal.NodeCommitment qualified as Node+import Moonlight.Delta.Patch.Internal.Types (CodecStats (..), debugCodecStats)+import Prelude+import Test.QuickCheck+ ( Gen,+ Property,+ chooseInt,+ counterexample,+ forAll,+ listOf,+ vectorOf,+ withMaxSuccess,+ (.&&.),+ (===),+ )+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@?=), assertBool, assertFailure, testCase)+import Test.Tasty.QuickCheck (testProperty)++deltaHashTests :: TestTree+deltaHashTests =+ testGroup+ "delta hash"+ [ testProperty "Merkle flat patch agrees with rebuild" merklePatchAgreesWithRebuild,+ testProperty "Merkle edit history descends to one root" merkleHistoryDescendsToCanonicalRoot,+ testProperty "Merkle trie patch agrees with rebuild above the flat boundary" merkleTriePatchAgreesWithRebuild,+ testCase "Merkle large multi-row path reassignment agrees with rebuild" largeMultiRowRebuildCase,+ testProperty "Merkle composed action equals sequential action" merkleComposedEqualsSequential,+ testProperty "contextual composition associates on values, definedness, and underlying failure" contextualCompositionAssociativity,+ testCase "reassociation exposes the documented binary-local stage divergence" contextualCompositionStageDivergenceCase,+ testProperty "multiset patch agrees with rebuild" multisetPatchAgreesWithRebuild,+ testProperty "multiset composed action equals sequential action" multisetComposedEqualsSequential,+ testProperty "multiset disjoint union composes through the patch action" multisetDisjointUnionHomomorphism,+ testProperty "multiset insertion and deletion are additive inverses" multisetAdditiveInverse,+ testProperty "multiset disjoint edit order is history-independent" multisetOrderIndependence,+ testCase "Merkle crosses the adaptive boundary in both directions" adaptiveBoundaryCase,+ testCase "Merkle digest is stable across the 63/64/65 and 255/256/257 boundaries" boundaryDigestCase,+ testCase "Merkle admits insertion into a path freed by a later deletion" pathFreedByDeletionCase,+ testCase "Merkle contextual composition rejects the insert-delete mirror at the first obstruction" mirrorPathCollisionCase,+ testCase "contextual composition preserves exact failure stage and cause under both strategies" contextualCompositionFailureRefinementCase,+ testCase "Merkle admits a multi-key path cycle in one patch" pathCycleCase,+ testCase "contextual composition preserves a same-path key representative under both strategies" samePathRepresentativeCompositionCase,+ testCase "empty patch is a digest identity in flat, trie, and multiset modes" emptyPatchIdentityCase,+ testCase "inverse composition returns to the original digest on both strategies" inverseCompositionCase,+ testCase "digesting replay's final map agrees with sequential digest replay" replayDigestAgreesCase,+ testCase "all four cell edits update both strategies" cellEditsCase,+ testCase "stale patch rejection is preserved on both strategies" stalePatchCase,+ testCase "equal key representatives rebuild on both strategies" representativeRewriteCase,+ testCase "equal value representatives rebuild on both strategies" valueRepresentativeRewriteCase,+ testCase "flat mode admits localized path collisions" flatModeCollisionCase,+ testCase "Merkle construction reports one localized path collision" constructionCollisionCase,+ testCase "Merkle insertion reports a localized path collision atomically" updateCollisionCase,+ testCase "digest action agrees with rebuild across mixed page encodings" mixedPageEncodingCase,+ testCase "non-injective value encoder collapses distinct states to one digest" multisetNonInjectiveCollapseCase,+ testCase "constructed additive cancellation matches the reduced state" multisetCancellationCase,+ testCase "modular additive inverse restores a trie-scale digest" multisetModularInverseCase,+ testCase "the multiset accumulator wraps modulo 2^64 per lane" laneVectorModularWraparoundCase,+ testCase "digests carry self-identifying strategy and encoder identity" crossIdentityCase,+ testProperty "complete digest serialization round-trips" digestSerializationRoundTrip,+ testCase "cross-strategy digest comparison is rejected by the type checker" crossStrategyCompileNegativeCase,+ testCase "oracle SipHash-2-4 matches all 64 canonical vectors" sipHashReferenceVectorCase,+ testCase "128-bit digest construction matches protocol goldens" digestGoldenCase+ ]++merklePatchAgreesWithRebuild :: Property+merklePatchAgreesWithRebuild =+ forAll smallMapGen $ \beforeState ->+ forAll smallMapGen $ \afterState ->+ case (buildTestMerkleDeltaHash beforeState, buildTestMerkleDeltaHash afterState) of+ (Right beforeDeltaHash, Right rebuiltDeltaHash) ->+ fmap+ merkleObservation+ (Patch.applyMerkleDeltaHash (Patch.diff beforeState afterState) beforeDeltaHash)+ === Right (merkleObservation rebuiltDeltaHash)+ (Left obstruction, _) ->+ counterexample ("unexpected initial key collision: " <> show obstruction) False+ (_, Left obstruction) ->+ counterexample ("unexpected rebuilt key collision: " <> show obstruction) False++merkleHistoryDescendsToCanonicalRoot :: Property+merkleHistoryDescendsToCanonicalRoot =+ forAll smallMapGen $ \middleState ->+ forAll smallMapGen $ \finalState ->+ case (buildTestMerkleDeltaHash Map.empty, buildTestMerkleDeltaHash finalState) of+ (Right emptyDeltaHash, Right rebuiltDeltaHash) ->+ let descended = do+ middleDeltaHash <-+ Patch.applyMerkleDeltaHash+ (Patch.diff Map.empty middleState)+ emptyDeltaHash+ Patch.applyMerkleDeltaHash+ (Patch.diff middleState finalState)+ middleDeltaHash+ in fmap merkleObservation descended+ === Right (merkleObservation rebuiltDeltaHash)+ (Left obstruction, _) ->+ counterexample ("unexpected empty Merkle failure: " <> show obstruction) False+ (_, Left obstruction) ->+ counterexample ("unexpected final key collision: " <> show obstruction) False++-- | The two states straddle the trie mode (>256 entries), so this law exercises+-- genuine multi-row Patricia insertion and deletion, not the flat hash.+merkleTriePatchAgreesWithRebuild :: Property+merkleTriePatchAgreesWithRebuild =+ withMaxSuccess 40 $+ forAll largeMapGen $ \beforeState ->+ forAll largeMapGen $ \afterState ->+ case (buildTestMerkleDeltaHash beforeState, buildTestMerkleDeltaHash afterState) of+ (Right beforeDeltaHash, Right rebuiltDeltaHash) ->+ fmap+ merkleObservation+ (Patch.applyMerkleDeltaHash (Patch.diff beforeState afterState) beforeDeltaHash)+ === Right (merkleObservation rebuiltDeltaHash)+ (Left obstruction, _) ->+ counterexample ("unexpected initial key collision: " <> show obstruction) False+ (_, Left obstruction) ->+ counterexample ("unexpected rebuilt key collision: " <> show obstruction) False++-- | @apply (compose p2 p1) == apply p2 <=< apply p1@ over trie-mode states.+merkleComposedEqualsSequential :: Property+merkleComposedEqualsSequential =+ withMaxSuccess 25 $+ forAll largeMapGen $ \state0 ->+ forAll largeMapGen $ \state1 ->+ forAll largeMapGen $ \state2 ->+ composedEqualsSequential+ buildTestMerkleDeltaHash+ Patch.composeMerkleDeltaHash+ Patch.applyMerkleDeltaHash+ merkleObservation+ state0+ state1+ state2++multisetComposedEqualsSequential :: Property+multisetComposedEqualsSequential =+ withMaxSuccess 25 $+ forAll largeMapGen $ \state0 ->+ forAll largeMapGen $ \state1 ->+ forAll largeMapGen $ \state2 ->+ composedEqualsSequential+ buildTestMultisetForComposition+ Patch.composeMultisetDeltaHash+ Patch.applyMultisetDeltaHash+ multisetObservation+ state0+ state1+ state2++composedEqualsSequential ::+ (Show obstruction, Show composeError, Eq applyError, Show applyError, Eq observation, Show observation) =>+ (Map Int Int -> Either obstruction carrier) ->+ (Patch.Patch Int Int -> Patch.Patch Int Int -> carrier -> Either composeError (Patch.Patch Int Int)) ->+ (Patch.Patch Int Int -> carrier -> Either applyError carrier) ->+ (carrier -> observation) ->+ Map Int Int ->+ Map Int Int ->+ Map Int Int ->+ Property+composedEqualsSequential build composeFor apply observe state0 state1 state2 =+ case (build state0, build state2) of+ (Right base, Right rebuilt) ->+ let patch1 = Patch.diff state0 state1+ patch2 = Patch.diff state1 state2+ in case composeFor patch2 patch1 base of+ Left composeError ->+ counterexample ("compose refused a valid chain: " <> show composeError) False+ Right composed ->+ let sequentialResult = apply patch1 base >>= apply patch2+ composedResult = apply composed base+ in ( fmap observe sequentialResult,+ fmap observe composedResult+ )+ === (Right (observe rebuilt), Right (observe rebuilt))+ (Left obstruction, _) ->+ counterexample ("unexpected initial obstruction: " <> show obstruction) False+ (_, Left obstruction) ->+ counterexample ("unexpected final obstruction: " <> show obstruction) False++contextualCompositionAssociativity :: Property+contextualCompositionAssociativity =+ forAll smallMapGen $ \initialState ->+ forAll arbitraryPatchGen $ \patch1 ->+ forAll arbitraryPatchGen $ \patch2 ->+ forAll arbitraryPatchGen $ \patch3 ->+ case buildTestMerkleDeltaHash initialState of+ Left obstruction ->+ counterexample ("unexpected Merkle construction obstruction: " <> show obstruction) False+ Right initialMerkleDeltaHash ->+ contextualAssociativityFor+ "Merkle"+ Patch.composeMerkleDeltaHash+ Patch.applyMerkleDeltaHash+ initialMerkleDeltaHash+ patch1+ patch2+ patch3+ .&&. contextualAssociativityFor+ "multiset"+ Patch.composeMultisetDeltaHash+ Patch.applyMultisetDeltaHash+ (buildTestMultisetDeltaHash initialState)+ patch1+ patch2+ patch3++arbitraryPatchGen :: Gen (Patch.Patch Int Int)+arbitraryPatchGen =+ Patch.diff <$> smallMapGen <*> smallMapGen++contextualAssociativityFor ::+ String ->+ (Patch.Patch Int Int -> Patch.Patch Int Int -> carrier -> Either (DeltaHashComposeError Int Int) (Patch.Patch Int Int)) ->+ (Patch.Patch Int Int -> carrier -> Either (DeltaHashApplyError Int Int) carrier) ->+ carrier ->+ Patch.Patch Int Int ->+ Patch.Patch Int Int ->+ Patch.Patch Int Int ->+ Property+contextualAssociativityFor strategyName composeFor applyFor initial patch1 patch2 patch3 =+ let leftAssociated =+ composeFor patch2 patch1 initial+ >>= \patch21 -> composeFor patch3 patch21 initial+ rightAssociated =+ rightAssociatedComposition composeFor applyFor patch3 patch2 patch1 initial+ sequential =+ applyFor patch1 initial+ >>= applyFor patch2+ >>= applyFor patch3+ leftProjection = projectCompositionOutcome leftAssociated+ rightProjection = projectCompositionOutcome rightAssociated+ sequentialDefinedness = void sequential+ in counterexample+ (strategyName <> " contextual composition reassociation")+ ( leftProjection === rightProjection+ .&&. void leftProjection === sequentialDefinedness+ .&&. void rightProjection === sequentialDefinedness+ )++rightAssociatedComposition ::+ (Patch.Patch Int Int -> Patch.Patch Int Int -> carrier -> Either (DeltaHashComposeError Int Int) (Patch.Patch Int Int)) ->+ (Patch.Patch Int Int -> carrier -> Either (DeltaHashApplyError Int Int) carrier) ->+ Patch.Patch Int Int ->+ Patch.Patch Int Int ->+ Patch.Patch Int Int ->+ carrier ->+ Either (DeltaHashComposeError Int Int) (Patch.Patch Int Int)+rightAssociatedComposition composeFor applyFor patch3 patch2 patch1 initial =+ case applyFor patch1 initial of+ Left obstruction ->+ Left (DeltaHashOlderPatchRejected obstruction)+ Right afterPatch1 -> do+ patch32 <- composeFor patch3 patch2 afterPatch1+ composeFor patch32 patch1 initial++projectCompositionOutcome ::+ Either (DeltaHashComposeError key value) result ->+ Either (DeltaHashApplyError key value) result+projectCompositionOutcome =+ either (Left . compositionUnderlyingError) Right++compositionUnderlyingError ::+ DeltaHashComposeError key value ->+ DeltaHashApplyError key value+compositionUnderlyingError composeError =+ case composeError of+ DeltaHashOlderPatchRejected obstruction -> obstruction+ DeltaHashNewerPatchRejected obstruction -> obstruction++contextualCompositionStageDivergenceCase :: IO ()+contextualCompositionStageDivergenceCase = do+ let initialState = Map.singleton 1 10+ patch1 = Patch.singleton 1 (Patch.replace 10 11)+ patch2 = Patch.singleton 1 (Patch.replace 10 12)+ patch3 = Patch.empty+ underlyingFailure =+ DeltaHashPatchRejected+ ApplyBeforeMismatch+ { mismatchKey = 1,+ expectedBefore = Just 10,+ actualBefore = Just 11+ }+ initialMerkleDeltaHash <- requireRight (buildTestMerkleDeltaHash initialState)+ assertBinaryLocalStageDivergence+ Patch.composeMerkleDeltaHash+ Patch.applyMerkleDeltaHash+ initialMerkleDeltaHash+ patch1+ patch2+ patch3+ underlyingFailure+ assertBinaryLocalStageDivergence+ Patch.composeMultisetDeltaHash+ Patch.applyMultisetDeltaHash+ (buildTestMultisetDeltaHash initialState)+ patch1+ patch2+ patch3+ underlyingFailure++assertBinaryLocalStageDivergence ::+ (Patch.Patch Int Int -> Patch.Patch Int Int -> carrier -> Either (DeltaHashComposeError Int Int) (Patch.Patch Int Int)) ->+ (Patch.Patch Int Int -> carrier -> Either (DeltaHashApplyError Int Int) carrier) ->+ carrier ->+ Patch.Patch Int Int ->+ Patch.Patch Int Int ->+ Patch.Patch Int Int ->+ DeltaHashApplyError Int Int ->+ IO ()+assertBinaryLocalStageDivergence composeFor applyFor initial patch1 patch2 patch3 underlyingFailure = do+ let leftAssociated =+ composeFor patch2 patch1 initial+ >>= \patch21 -> composeFor patch3 patch21 initial+ rightAssociated =+ rightAssociatedComposition composeFor applyFor patch3 patch2 patch1 initial+ leftAssociated @?= Left (DeltaHashNewerPatchRejected underlyingFailure)+ rightAssociated @?= Left (DeltaHashOlderPatchRejected underlyingFailure)+ projectCompositionOutcome leftAssociated+ @?= projectCompositionOutcome rightAssociated++multisetPatchAgreesWithRebuild :: Property+multisetPatchAgreesWithRebuild =+ forAll smallMapGen $ \beforeState ->+ forAll smallMapGen $ \afterState ->+ let beforeDeltaHash = buildTestMultisetDeltaHash beforeState+ rebuiltDeltaHash = buildTestMultisetDeltaHash afterState+ in fmap+ multisetObservation+ (Patch.applyMultisetDeltaHash (Patch.diff beforeState afterState) beforeDeltaHash)+ === Right (multisetObservation rebuiltDeltaHash)++multisetDisjointUnionHomomorphism :: Property+multisetDisjointUnionHomomorphism =+ forAll smallMapGen $ \authoritativeState ->+ let (leftState, rightState) =+ Map.partitionWithKey (\key _value -> even key) authoritativeState+ combinedState = Map.union leftState rightState+ combinedByAction =+ Patch.applyMultisetDeltaHash+ (Patch.diff Map.empty rightState)+ (buildTestMultisetDeltaHash leftState)+ in fmap multisetObservation combinedByAction+ === Right (multisetObservation (buildTestMultisetDeltaHash combinedState))++multisetAdditiveInverse :: Property+multisetAdditiveInverse =+ forAll smallMapGen $ \authoritativeState ->+ let freshKey = 4096+ freshValue = 17+ initialDeltaHash = buildTestMultisetDeltaHash authoritativeState+ roundTrip = do+ insertedDeltaHash <-+ Patch.applyMultisetDeltaHash+ (Patch.singleton freshKey (Patch.insert freshValue))+ initialDeltaHash+ Patch.applyMultisetDeltaHash+ (Patch.singleton freshKey (Patch.delete freshValue))+ insertedDeltaHash+ in fmap multisetObservation roundTrip+ === Right (multisetObservation initialDeltaHash)++multisetOrderIndependence :: Property+multisetOrderIndependence =+ forAll smallMapGen $ \authoritativeState ->+ let (leftState, rightState) =+ Map.partitionWithKey (\key _value -> even key) authoritativeState+ leftPatch = Patch.diff Map.empty leftState+ rightPatch = Patch.diff Map.empty rightState+ emptyDeltaHash = buildTestMultisetDeltaHash Map.empty+ leftThenRight = do+ leftDeltaHash <- Patch.applyMultisetDeltaHash leftPatch emptyDeltaHash+ Patch.applyMultisetDeltaHash rightPatch leftDeltaHash+ rightThenLeft = do+ rightDeltaHash <- Patch.applyMultisetDeltaHash rightPatch emptyDeltaHash+ Patch.applyMultisetDeltaHash leftPatch rightDeltaHash+ expectedObservation =+ multisetObservation (buildTestMultisetDeltaHash authoritativeState)+ in (fmap multisetObservation leftThenRight, fmap multisetObservation rightThenLeft)+ === (Right expectedObservation, Right expectedObservation)++adaptiveBoundaryCase :: IO ()+adaptiveBoundaryCase = do+ let boundaryState = sequentialState deltaHashFlatBoundarySize+ insertedKey = deltaHashFlatBoundarySize+ expandedState = Map.insert insertedKey insertedKey boundaryState+ boundaryDeltaHash <- requireRight (buildTestMerkleDeltaHash boundaryState)+ expandedDeltaHash <-+ requireRight+ ( Patch.applyMerkleDeltaHash+ (Patch.singleton insertedKey (Patch.insert insertedKey))+ boundaryDeltaHash+ )+ rebuiltExpandedDeltaHash <- requireRight (buildTestMerkleDeltaHash expandedState)+ merkleObservation expandedDeltaHash+ @?= merkleObservation rebuiltExpandedDeltaHash+ contractedDeltaHash <-+ requireRight+ ( Patch.applyMerkleDeltaHash+ (Patch.singleton insertedKey (Patch.delete insertedKey))+ expandedDeltaHash+ )+ merkleObservation contractedDeltaHash+ @?= merkleObservation boundaryDeltaHash++-- | Forced digest cases at the 64-row page capacity (63/64/65) and at the flat+-- adaptive threshold (255/256/257): a single insert crossing each boundary must+-- agree with a fresh rebuild under both strategies.+boundaryDigestCase :: IO ()+boundaryDigestCase =+ traverse_ checkBoundary [63, 64, 65, 255, 256, 257]+ where+ checkBoundary stateSize = do+ let baseState = sequentialState stateSize+ insertedKey = stateSize+ expandedState = Map.insert insertedKey insertedKey baseState+ baseMerkle <- requireRight (buildTestMerkleDeltaHash baseState)+ expandedMerkle <-+ requireRight+ ( Patch.applyMerkleDeltaHash+ (Patch.singleton insertedKey (Patch.insert insertedKey))+ baseMerkle+ )+ rebuiltMerkle <- requireRight (buildTestMerkleDeltaHash expandedState)+ merkleObservation expandedMerkle @?= merkleObservation rebuiltMerkle+ assertMerkleIdentity (Patch.merkleDeltaHashDigest expandedMerkle)+ let baseMultiset = buildTestMultisetDeltaHash baseState+ expandedMultiset <-+ requireRight+ ( Patch.applyMultisetDeltaHash+ (Patch.singleton insertedKey (Patch.insert insertedKey))+ baseMultiset+ )+ multisetObservation expandedMultiset+ @?= multisetObservation (buildTestMultisetDeltaHash expandedState)+ assertMultisetIdentity (Patch.multisetDeltaHashDigest expandedMultiset)++-- | In a trie-mode state, delete one key and then insert a distinct key on the+-- freed localized path. Contextual composition, sequential action, and rebuild+-- must agree.+pathFreedByDeletionCase :: IO ()+pathFreedByDeletionCase = do+ let beforeState = Map.fromList [(key, key * 10) | key <- [1 .. deltaHashFlatBoundarySize + 1]]+ collidingKey = deltaHashFlatBoundarySize+ freedKey = 0+ afterState = Map.insert freedKey 5 (Map.delete collidingKey beforeState)+ deletePatch = Patch.singleton collidingKey (Patch.delete (collidingKey * 10))+ insertPatch = Patch.singleton freedKey (Patch.insert 5)+ beforeDeltaHash <-+ requireRight (Patch.buildMerkleDeltaHash testEncoderVersion boundaryCollisionEncoding intEncoding beforeState)+ composed <-+ requireRight (Patch.composeMerkleDeltaHash insertPatch deletePatch beforeDeltaHash)+ rebuiltDeltaHash <-+ requireRight (Patch.buildMerkleDeltaHash testEncoderVersion boundaryCollisionEncoding intEncoding afterState)+ composedResult <-+ requireRight (Patch.applyMerkleDeltaHash composed beforeDeltaHash)+ sequentialResult <-+ requireRight+ (Patch.applyMerkleDeltaHash deletePatch beforeDeltaHash >>= Patch.applyMerkleDeltaHash insertPatch)+ merkleObservationOn composedResult @?= merkleObservationOn rebuiltDeltaHash+ merkleObservationOn sequentialResult @?= merkleObservationOn rebuiltDeltaHash++mirrorPathCollisionCase :: IO ()+mirrorPathCollisionCase = do+ let beforeState = Map.fromList [(key, key * 10) | key <- [1 .. deltaHashFlatBoundarySize + 1]]+ collidingKey = deltaHashFlatBoundarySize+ incomingKey = 0+ insertPatch = Patch.singleton incomingKey (Patch.insert 5)+ deletePatch = Patch.singleton collidingKey (Patch.delete (collidingKey * 10))+ afterState = Map.insert incomingKey 5 (Map.delete collidingKey beforeState)+ beforeDeltaHash <-+ requireRight (Patch.buildMerkleDeltaHash testEncoderVersion boundaryCollisionEncoding intEncoding beforeState)+ case Patch.applyMerkleDeltaHash insertPatch beforeDeltaHash of+ Left sequentialFailure -> do+ Patch.composeMerkleDeltaHash deletePatch insertPatch beforeDeltaHash+ @?= Left (DeltaHashOlderPatchRejected sequentialFailure)+ Patch.composeMerkleDeltaHash insertPatch Patch.empty beforeDeltaHash+ @?= Left (DeltaHashNewerPatchRejected sequentialFailure)+ Right _intermediate ->+ assertFailure "expected the older insertion to reject its occupied path"+ extensionalPatch <- requireRight (Patch.compose deletePatch insertPatch)+ extensionalResult <- requireRight (Patch.applyMerkleDeltaHash extensionalPatch beforeDeltaHash)+ Patch.merkleDeltaHashState extensionalResult @?= afterState++contextualCompositionFailureRefinementCase :: IO ()+contextualCompositionFailureRefinementCase = do+ let authoritativeState = Map.singleton 1 10+ rejectedOlder = Patch.singleton 1 (Patch.replace 9 11)+ admittedOlder = Patch.singleton 1 (Patch.replace 10 11)+ rejectedNewer = Patch.singleton 1 (Patch.replace 10 12)+ olderFailure =+ DeltaHashPatchRejected+ ApplyBeforeMismatch+ { mismatchKey = 1,+ expectedBefore = Just 9,+ actualBefore = Just 10+ }+ newerFailure =+ DeltaHashPatchRejected+ ApplyBeforeMismatch+ { mismatchKey = 1,+ expectedBefore = Just 10,+ actualBefore = Just 11+ }+ merkleDeltaHash <- requireRight (buildTestMerkleDeltaHash authoritativeState)+ Patch.composeMerkleDeltaHash Patch.empty rejectedOlder merkleDeltaHash+ @?= Left (DeltaHashOlderPatchRejected olderFailure)+ Patch.composeMerkleDeltaHash rejectedNewer admittedOlder merkleDeltaHash+ @?= Left (DeltaHashNewerPatchRejected newerFailure)+ let multisetDeltaHash = buildTestMultisetDeltaHash authoritativeState+ Patch.composeMultisetDeltaHash Patch.empty rejectedOlder multisetDeltaHash+ @?= Left (DeltaHashOlderPatchRejected olderFailure)+ Patch.composeMultisetDeltaHash rejectedNewer admittedOlder multisetDeltaHash+ @?= Left (DeltaHashNewerPatchRejected newerFailure)++largeMultiRowRebuildCase :: IO ()+largeMultiRowRebuildCase = do+ let buckets = [0 .. 64]+ paddingEntries =+ [ (PathBucketKey ident ident, ident)+ | ident <- [1000 .. 1000 + deltaHashFlatBoundarySize]+ ]+ oldEntries =+ [ (PathBucketKey (100 + bucket) bucket, bucket)+ | bucket <- buckets+ ]+ newEntries =+ [ (PathBucketKey bucket bucket, bucket + 1000)+ | bucket <- buckets+ ]+ beforeState = Map.fromList (paddingEntries <> oldEntries)+ afterState = Map.fromList (paddingEntries <> newEntries)+ reassignmentPatch = Patch.diff beforeState afterState+ beforeDeltaHash <-+ requireRight (Patch.buildMerkleDeltaHash testEncoderVersion pathBucketEncoding intEncoding beforeState)+ updatedDeltaHash <-+ requireRight (Patch.applyMerkleDeltaHash reassignmentPatch beforeDeltaHash)+ rebuiltDeltaHash <-+ requireRight (Patch.buildMerkleDeltaHash testEncoderVersion pathBucketEncoding intEncoding afterState)+ merkleObservationOn updatedDeltaHash @?= merkleObservationOn rebuiltDeltaHash++-- | A three-key localized-path cycle inside one trie-mode patch must agree with+-- rebuilding the final map.+pathCycleCase :: IO ()+pathCycleCase = do+ let paddingKeys = [1000 .. 1000 + deltaHashFlatBoundarySize + 16]+ paddingEntries = [(PathBucketKey ident ident, ident) | ident <- paddingKeys]+ oldEntries =+ [ (PathBucketKey 100 bucketX, 100),+ (PathBucketKey 101 bucketY, 101),+ (PathBucketKey 102 bucketZ, 102)+ ]+ beforeState = Map.fromList (paddingEntries <> oldEntries)+ cyclePatch =+ Patch.fromList+ [ (PathBucketKey 1 bucketY, Patch.insert 1),+ (PathBucketKey 2 bucketZ, Patch.insert 2),+ (PathBucketKey 3 bucketX, Patch.insert 3),+ (PathBucketKey 100 bucketX, Patch.delete 100),+ (PathBucketKey 101 bucketY, Patch.delete 101),+ (PathBucketKey 102 bucketZ, Patch.delete 102)+ ]+ afterState =+ Map.fromList+ ( paddingEntries+ <> [ (PathBucketKey 1 bucketY, 1),+ (PathBucketKey 2 bucketZ, 2),+ (PathBucketKey 3 bucketX, 3)+ ]+ )+ bucketX = 10+ bucketY = 20+ bucketZ = 30+ beforeDeltaHash <-+ requireRight (Patch.buildMerkleDeltaHash testEncoderVersion pathBucketEncoding intEncoding beforeState)+ rebuiltDeltaHash <-+ requireRight (Patch.buildMerkleDeltaHash testEncoderVersion pathBucketEncoding intEncoding afterState)+ cycledDeltaHash <-+ requireRight (Patch.applyMerkleDeltaHash cyclePatch beforeDeltaHash)+ ( Patch.merkleDeltaHashState cycledDeltaHash,+ Patch.merkleDeltaHashDigest cycledDeltaHash+ )+ @?= ( Patch.merkleDeltaHashState rebuiltDeltaHash,+ Patch.merkleDeltaHashDigest rebuiltDeltaHash+ )++samePathRepresentativeCompositionCase :: IO ()+samePathRepresentativeCompositionCase = do+ let stateEntry key =+ (RepresentativeKey key StateRepresentative, key * 10)+ finalEntry key+ | key == 1 = (RepresentativeKey key FinalRepresentative, key * 10)+ | otherwise = stateEntry key+ keys = [1 .. deltaHashFlatBoundarySize + 1]+ initialState = Map.fromDistinctAscList (fmap stateEntry keys)+ finalState = Map.fromDistinctAscList (fmap finalEntry keys)+ olderPatch =+ Patch.singleton+ (RepresentativeKey 1 PatchRepresentative)+ (Patch.replace 10 10)+ newerPatch =+ Patch.singleton+ (RepresentativeKey 1 FinalRepresentative)+ (Patch.replace 10 10)+ initialDeltaHash <-+ requireRight+ (Patch.buildMerkleDeltaHash testEncoderVersion representativeSamePathEncoding intEncoding initialState)+ admittedPatch <-+ requireRight (Patch.composeMerkleDeltaHash newerPatch olderPatch initialDeltaHash)+ sequentialResult <-+ requireRight+ ( Patch.applyMerkleDeltaHash olderPatch initialDeltaHash+ >>= Patch.applyMerkleDeltaHash newerPatch+ )+ admittedResult <- requireRight (Patch.applyMerkleDeltaHash admittedPatch initialDeltaHash)+ rebuiltResult <-+ requireRight+ (Patch.buildMerkleDeltaHash testEncoderVersion representativeSamePathEncoding intEncoding finalState)+ merkleObservationOn sequentialResult @?= merkleObservationOn rebuiltResult+ merkleObservationOn admittedResult @?= merkleObservationOn rebuiltResult+ fmap (representativeKind . fst) (Map.lookupGE (RepresentativeKey 1 FinalRepresentative) (Patch.merkleDeltaHashState sequentialResult))+ @?= Just FinalRepresentative+ fmap (representativeKind . fst) (Map.lookupGE (RepresentativeKey 1 FinalRepresentative) (Patch.merkleDeltaHashState admittedResult))+ @?= Just FinalRepresentative+ let initialMultiset =+ Patch.buildMultisetDeltaHash+ testEncoderVersion+ representativeSamePathEncoding+ intEncoding+ initialState+ admittedMultisetPatch <-+ requireRight (Patch.composeMultisetDeltaHash newerPatch olderPatch initialMultiset)+ sequentialMultiset <-+ requireRight+ ( Patch.applyMultisetDeltaHash olderPatch initialMultiset+ >>= Patch.applyMultisetDeltaHash newerPatch+ )+ admittedMultiset <-+ requireRight (Patch.applyMultisetDeltaHash admittedMultisetPatch initialMultiset)+ fmap (representativeKind . fst) (Map.lookupGE (RepresentativeKey 1 FinalRepresentative) (Patch.multisetDeltaHashState sequentialMultiset))+ @?= Just FinalRepresentative+ fmap (representativeKind . fst) (Map.lookupGE (RepresentativeKey 1 FinalRepresentative) (Patch.multisetDeltaHashState admittedMultiset))+ @?= Just FinalRepresentative++emptyPatchIdentityCase :: IO ()+emptyPatchIdentityCase = do+ let flatState = Map.fromList [(1, 10), (2, 20)]+ trieState = sequentialState (deltaHashFlatBoundarySize + 32)+ flatMerkle <- requireRight (buildTestMerkleDeltaHash flatState)+ flatIdentity <- requireRight (Patch.applyMerkleDeltaHash Patch.empty flatMerkle)+ merkleObservation flatIdentity @?= merkleObservation flatMerkle+ assertMerkleIdentity (Patch.merkleDeltaHashDigest flatIdentity)+ trieMerkle <- requireRight (buildTestMerkleDeltaHash trieState)+ trieIdentity <- requireRight (Patch.applyMerkleDeltaHash Patch.empty trieMerkle)+ merkleObservation trieIdentity @?= merkleObservation trieMerkle+ assertMerkleIdentity (Patch.merkleDeltaHashDigest trieIdentity)+ let multiset = buildTestMultisetDeltaHash trieState+ multisetIdentity <- requireRight (Patch.applyMultisetDeltaHash Patch.empty multiset)+ multisetObservation multisetIdentity @?= multisetObservation multiset+ assertMultisetIdentity (Patch.multisetDeltaHashDigest multisetIdentity)++-- | @compose (invert p) p@ is the identity on @p@'s source and @compose p+-- (invert p)@ is the identity on its target, under both strategies and in trie+-- mode.+inverseCompositionCase :: IO ()+inverseCompositionCase = do+ let sourceState = trieStateA+ targetState = trieStateB+ forward = Patch.diff sourceState targetState+ backward = Patch.invert forward+ sourceMerkle <- requireRight (buildTestMerkleDeltaHash sourceState)+ targetMerkle <- requireRight (buildTestMerkleDeltaHash targetState)+ forwardThenBack <-+ requireRight (Patch.composeMerkleDeltaHash backward forward sourceMerkle)+ backThenForward <-+ requireRight (Patch.composeMerkleDeltaHash forward backward targetMerkle)+ restoredSource <- requireRight (Patch.applyMerkleDeltaHash forwardThenBack sourceMerkle)+ merkleObservation restoredSource @?= merkleObservation sourceMerkle+ restoredTarget <- requireRight (Patch.applyMerkleDeltaHash backThenForward targetMerkle)+ merkleObservation restoredTarget @?= merkleObservation targetMerkle+ let sourceMultiset = buildTestMultisetDeltaHash sourceState+ targetMultiset = buildTestMultisetDeltaHash targetState+ multisetForwardThenBack <-+ requireRight (Patch.composeMultisetDeltaHash backward forward sourceMultiset)+ multisetBackThenForward <-+ requireRight (Patch.composeMultisetDeltaHash forward backward targetMultiset)+ restoredSourceMultiset <- requireRight (Patch.applyMultisetDeltaHash multisetForwardThenBack sourceMultiset)+ multisetObservation restoredSourceMultiset @?= multisetObservation sourceMultiset+ restoredTargetMultiset <- requireRight (Patch.applyMultisetDeltaHash multisetBackThenForward targetMultiset)+ multisetObservation restoredTargetMultiset @?= multisetObservation targetMultiset++-- | Replay reduces a patch chain to a final @Map@; digesting that map must equal+-- folding the same patches through the incremental digest. This glues the+-- replay decoder to the digest action across strategies.+replayDigestAgreesCase :: IO ()+replayDigestAgreesCase = do+ let state0 = trieStateA+ state1 = trieStateB+ state2 = trieStateC+ patches =+ [ Patch.diff state0 state1,+ Patch.diff state1 state2+ ]+ replayedState <- requireRight (Patch.replay patches state0)+ merkleBase <- requireRight (buildTestMerkleDeltaHash state0)+ sequentialMerkle <-+ requireRight (foldM (flip Patch.applyMerkleDeltaHash) merkleBase patches)+ rebuiltMerkle <- requireRight (buildTestMerkleDeltaHash replayedState)+ merkleObservation sequentialMerkle @?= merkleObservation rebuiltMerkle+ assertMerkleIdentity (Patch.merkleDeltaHashDigest sequentialMerkle)+ let multisetBase = buildTestMultisetDeltaHash state0+ sequentialMultiset <-+ requireRight (foldM (flip Patch.applyMultisetDeltaHash) multisetBase patches)+ multisetObservation sequentialMultiset+ @?= multisetObservation (buildTestMultisetDeltaHash replayedState)+ assertMultisetIdentity (Patch.multisetDeltaHashDigest sequentialMultiset)++cellEditsCase :: IO ()+cellEditsCase = do+ let initialState = Map.fromList [(1, 10), (2, 20)]+ expectedState = Map.fromList [(1, 11), (3, 30)]+ patchValue =+ Patch.fromList+ [ (1, Patch.replace 10 11),+ (2, Patch.delete 20),+ (3, Patch.insert 30),+ (4, Patch.assertAbsent)+ ]+ initialMerkleDeltaHash <- requireRight (buildTestMerkleDeltaHash initialState)+ updatedMerkleDeltaHash <-+ requireRight (Patch.applyMerkleDeltaHash patchValue initialMerkleDeltaHash)+ rebuiltMerkleDeltaHash <- requireRight (buildTestMerkleDeltaHash expectedState)+ merkleObservation updatedMerkleDeltaHash+ @?= merkleObservation rebuiltMerkleDeltaHash+ updatedMultisetDeltaHash <-+ requireRight+ ( Patch.applyMultisetDeltaHash+ patchValue+ (buildTestMultisetDeltaHash initialState)+ )+ multisetObservation updatedMultisetDeltaHash+ @?= multisetObservation (buildTestMultisetDeltaHash expectedState)++stalePatchCase :: IO ()+stalePatchCase = do+ let initialState = Map.singleton 1 10+ patchValue = Patch.singleton 1 (Patch.replace 9 11)+ expectedObstruction =+ DeltaHashPatchRejected+ ApplyBeforeMismatch+ { mismatchKey = 1,+ expectedBefore = Just 9,+ actualBefore = Just 10+ }+ initialMerkleDeltaHash <- requireRight (buildTestMerkleDeltaHash initialState)+ case Patch.applyMerkleDeltaHash patchValue initialMerkleDeltaHash of+ Left obstruction ->+ obstruction @?= expectedObstruction+ Right _deltaHash ->+ assertFailure "expected stale Merkle patch to be rejected"+ case Patch.applyMultisetDeltaHash patchValue (buildTestMultisetDeltaHash initialState) of+ Left obstruction ->+ obstruction @?= expectedObstruction+ Right _deltaHash ->+ assertFailure "expected stale multiset patch to be rejected"++representativeRewriteCase :: IO ()+representativeRewriteCase = do+ let stateEntry key =+ (RepresentativeKey key StateRepresentative, key * 10)+ expectedEntry key+ | key == 1 = (RepresentativeKey key PatchRepresentative, 11)+ | otherwise = stateEntry key+ keys = [1 .. deltaHashFlatBoundarySize + 1]+ initialState = Map.fromDistinctAscList (fmap stateEntry keys)+ expectedState = Map.fromDistinctAscList (fmap expectedEntry keys)+ patchKey = RepresentativeKey 1 PatchRepresentative+ patchValue = Patch.singleton patchKey (Patch.replace 10 11)+ initialMerkleDeltaHash <-+ requireRight+ (Patch.buildMerkleDeltaHash testEncoderVersion representativeKeyEncoding intEncoding initialState)+ updatedMerkleDeltaHash <-+ requireRight (Patch.applyMerkleDeltaHash patchValue initialMerkleDeltaHash)+ rebuiltMerkleDeltaHash <-+ requireRight+ (Patch.buildMerkleDeltaHash testEncoderVersion representativeKeyEncoding intEncoding expectedState)+ Patch.merkleDeltaHashDigest updatedMerkleDeltaHash+ @?= Patch.merkleDeltaHashDigest rebuiltMerkleDeltaHash+ fmap (representativeKind . fst) (Map.lookupGE patchKey (Patch.merkleDeltaHashState updatedMerkleDeltaHash))+ @?= Just PatchRepresentative+ let initialMultisetDeltaHash =+ Patch.buildMultisetDeltaHash testEncoderVersion representativeKeyEncoding intEncoding initialState+ rebuiltMultisetDeltaHash =+ Patch.buildMultisetDeltaHash testEncoderVersion representativeKeyEncoding intEncoding expectedState+ updatedMultisetDeltaHash <-+ requireRight (Patch.applyMultisetDeltaHash patchValue initialMultisetDeltaHash)+ Patch.multisetDeltaHashDigest updatedMultisetDeltaHash+ @?= Patch.multisetDeltaHashDigest rebuiltMultisetDeltaHash+ fmap (representativeKind . fst) (Map.lookupGE patchKey (Patch.multisetDeltaHashState updatedMultisetDeltaHash))+ @?= Just PatchRepresentative++valueRepresentativeRewriteCase :: IO ()+valueRepresentativeRewriteCase = do+ let stateValue = RepresentativeValue 10 StateRepresentative+ patchBefore = RepresentativeValue 10 PatchRepresentative+ patchAfter = RepresentativeValue 11 PatchRepresentative+ initialState = Map.singleton 1 stateValue+ expectedState = Map.singleton 1 patchAfter+ patchValue = Patch.singleton 1 (Patch.replace patchBefore patchAfter)+ initialMerkleDeltaHash <-+ requireRight+ (Patch.buildMerkleDeltaHash testEncoderVersion intEncoding representativeValueEncoding initialState)+ updatedMerkleDeltaHash <-+ requireRight (Patch.applyMerkleDeltaHash patchValue initialMerkleDeltaHash)+ rebuiltMerkleDeltaHash <-+ requireRight+ (Patch.buildMerkleDeltaHash testEncoderVersion intEncoding representativeValueEncoding expectedState)+ Patch.merkleDeltaHashDigest updatedMerkleDeltaHash+ @?= Patch.merkleDeltaHashDigest rebuiltMerkleDeltaHash+ let initialMultisetDeltaHash =+ Patch.buildMultisetDeltaHash testEncoderVersion intEncoding representativeValueEncoding initialState+ rebuiltMultisetDeltaHash =+ Patch.buildMultisetDeltaHash testEncoderVersion intEncoding representativeValueEncoding expectedState+ updatedMultisetDeltaHash <-+ requireRight (Patch.applyMultisetDeltaHash patchValue initialMultisetDeltaHash)+ Patch.multisetDeltaHashDigest updatedMultisetDeltaHash+ @?= Patch.multisetDeltaHashDigest rebuiltMultisetDeltaHash++flatModeCollisionCase :: IO ()+flatModeCollisionCase = do+ let authoritativeState = Map.fromList [(1, 10), (2, 20)]+ deltaHashValue <-+ requireRight+ (Patch.buildMerkleDeltaHash testEncoderVersion constantEncoding intEncoding authoritativeState)+ Patch.merkleDeltaHashState deltaHashValue @?= authoritativeState++constructionCollisionCase :: IO ()+constructionCollisionCase =+ case+ Patch.buildMerkleDeltaHash+ testEncoderVersion+ boundaryCollisionEncoding+ intEncoding+ (sequentialState (deltaHashFlatBoundarySize + 1))+ of+ Left DeltaHashKeyCollision {deltaHashExistingKey, deltaHashIncomingKey} ->+ (deltaHashExistingKey, deltaHashIncomingKey)+ @?= (0, deltaHashFlatBoundarySize)+ Right _deltaHash ->+ assertFailure "expected distinct keys with one digest path to be rejected"++updateCollisionCase :: IO ()+updateCollisionCase = do+ let authoritativeState = sequentialState deltaHashFlatBoundarySize+ incomingKey = deltaHashFlatBoundarySize+ initialDeltaHash <-+ requireRight+ (Patch.buildMerkleDeltaHash testEncoderVersion boundaryCollisionEncoding intEncoding authoritativeState)+ case+ Patch.applyMerkleDeltaHash+ (Patch.singleton incomingKey (Patch.insert incomingKey))+ initialDeltaHash+ of+ Left (DeltaHashUpdateRejected DeltaHashKeyCollision {}) ->+ Patch.merkleDeltaHashState initialDeltaHash @?= authoritativeState+ Left obstruction ->+ assertFailure ("expected collision obstruction, received: " <> show obstruction)+ Right _deltaHash ->+ assertFailure "expected insertion collision to be rejected"++-- | A paged patch that exercises the constant, run, affine, and dense value+-- column encodings plus absent presence columns. The digest action decodes it+-- through the same page fold as construction, so its result must equal the+-- rebuild of the final map.+mixedPageEncodingCase :: IO ()+mixedPageEncodingCase = do+ let stats = debugCodecStats mixedFormPatch+ exercisesEveryForm =+ codecConstantColumns stats >= 1+ && codecRunColumns stats >= 1+ && codecAffineValueColumns stats >= 1+ && codecDenseColumns stats >= 1+ && codecAbsentColumns stats >= 1+ exercisesEveryForm @?= True+ replayedState <- requireRight (Patch.replay [mixedFormPatch] mixedFormInitialMap)+ replayedState @?= mixedFormMap+ initialMerkle <- requireRight (buildTestMerkleDeltaHash mixedFormInitialMap)+ updatedMerkle <-+ requireRight (Patch.applyMerkleDeltaHash mixedFormPatch initialMerkle)+ rebuiltMerkle <- requireRight (buildTestMerkleDeltaHash replayedState)+ merkleObservation updatedMerkle @?= merkleObservation rebuiltMerkle+ assertMerkleIdentity (Patch.merkleDeltaHashDigest updatedMerkle)+ updatedMultiset <-+ requireRight (Patch.applyMultisetDeltaHash mixedFormPatch (buildTestMultisetDeltaHash mixedFormInitialMap))+ multisetObservation updatedMultiset+ @?= multisetObservation (buildTestMultisetDeltaHash replayedState)+ assertMultisetIdentity (Patch.multisetDeltaHashDigest updatedMultiset)++-- | With a constant value encoder, a valid replacement subtracts and re-adds the+-- same lane vector: the authoritative state changes while the digest does not.+-- This is the multiset scheme's documented non-injectivity, made explicit.+multisetNonInjectiveCollapseCase :: IO ()+multisetNonInjectiveCollapseCase = do+ let initialState = Map.singleton 1 (10 :: Int)+ collapsed = Patch.buildMultisetDeltaHash testEncoderVersion intEncoding constantEncoding initialState+ distinctEncoderIdentity = Patch.buildMultisetDeltaHash shiftedEncoderVersion intEncoding constantEncoding initialState+ patchValue = Patch.singleton 1 (Patch.replace 10 99)+ updated <- requireRight (Patch.applyMultisetDeltaHash patchValue collapsed)+ Patch.multisetDeltaHashState updated @?= Map.singleton 1 99+ Patch.multisetDeltaHashDigest updated @?= Patch.multisetDeltaHashDigest collapsed+ (Patch.multisetDeltaHashDigest distinctEncoderIdentity == Patch.multisetDeltaHashDigest collapsed)+ @?= False++-- | Inserting A, inserting B, then deleting A cancels A's contribution exactly:+-- the digest equals a fresh build of the reduced state.+multisetCancellationCase :: IO ()+multisetCancellationCase = do+ let program = do+ withA <-+ Patch.applyMultisetDeltaHash+ (Patch.singleton 1 (Patch.insert 100))+ (buildTestMultisetDeltaHash Map.empty)+ withAB <-+ Patch.applyMultisetDeltaHash (Patch.singleton 2 (Patch.insert 200)) withA+ Patch.applyMultisetDeltaHash (Patch.singleton 1 (Patch.delete 100)) withAB+ result <- requireRight program+ multisetObservation result+ @?= multisetObservation (buildTestMultisetDeltaHash (Map.singleton 2 200))++-- | Wrapping addition and subtraction are exact inverses on the 16-lane group,+-- so inserting then deleting a fresh key restores a trie-scale digest bit for+-- bit — the modular-group law the accumulator relies on at any scale.+multisetModularInverseCase :: IO ()+multisetModularInverseCase = do+ let baseState = sequentialState (deltaHashFlatBoundarySize + 64)+ freshKey = deltaHashFlatBoundarySize + 4096+ base = buildTestMultisetDeltaHash baseState+ roundTrip <-+ requireRight+ ( Patch.applyMultisetDeltaHash (Patch.singleton freshKey (Patch.insert 7)) base+ >>= Patch.applyMultisetDeltaHash (Patch.singleton freshKey (Patch.delete 7))+ )+ multisetObservation roundTrip @?= multisetObservation base++-- | The accumulator lives in @(Z / 2^64 Z)^16@: each lane is a 'Word64' with+-- wrapping addition. Adding one past the maximum returns to zero and+-- subtracting below zero returns to the maximum, so the digest's finite-group+-- collision structure is exactly modular, not saturating.+laneVectorModularWraparoundCase :: IO ()+laneVectorModularWraparoundCase = do+ let laneAt index value =+ laneVectorFromLanes+ (UVector.generate laneCount (\lane -> if lane == index then value else 0))+ wrappedForward = add (laneAt 0 maxBound) (laneAt 0 1)+ wrappedBackward = sub laneVectorZero (laneAt 0 1)+ (laneVectorLanes wrappedForward UVector.! 0) @?= (0 :: Word64)+ (laneVectorLanes wrappedBackward UVector.! 0) @?= (maxBound :: Word64)++-- | Digests self-identify: each carries its runtime strategy and encoding+-- version, and equal maps under different encoders produce different digests, so+-- verifying under the wrong scheme or encoder is a detectable mismatch. The+-- cross-strategy comparison @merkleDigest == multisetDigest@ is rejected by the+-- type checker and cannot be written here.+crossIdentityCase :: IO ()+crossIdentityCase = do+ let state = sequentialState (deltaHashFlatBoundarySize + 8)+ merkleDeltaHash <- requireRight (buildTestMerkleDeltaHash state)+ let merkleDigest = Patch.merkleDeltaHashDigest merkleDeltaHash+ multisetDigest = Patch.multisetDeltaHashDigest (buildTestMultisetDeltaHash state)+ merkleIdentity = Patch.deltaHashDigestIdentity merkleDigest+ multisetIdentity = Patch.deltaHashDigestIdentity multisetDigest+ encodedMerkleDigest = Patch.encodeDeltaHashDigest merkleDigest+ encodedMultisetDigest = Patch.encodeDeltaHashDigest multisetDigest+ Patch.decodeMerkleDeltaHashDigest testEncoderVersion encodedMerkleDigest+ @?= Right merkleDigest+ Patch.decodeMultisetDeltaHashDigest testEncoderVersion encodedMultisetDigest+ @?= Right multisetDigest+ Patch.decodeMultisetDeltaHashDigest testEncoderVersion encodedMerkleDigest+ @?= Left+ DeltaHashDigestIdentityMismatch+ { deltaHashExpectedIdentity = multisetIdentity,+ deltaHashEncodedIdentity = merkleIdentity+ }+ Patch.decodeMerkleDeltaHashDigest testEncoderVersion encodedMultisetDigest+ @?= Left+ DeltaHashDigestIdentityMismatch+ { deltaHashExpectedIdentity = merkleIdentity,+ deltaHashEncodedIdentity = multisetIdentity+ }+ Patch.decodeMerkleDeltaHashDigest testEncoderVersion (encodedMerkleDigest <> ByteString.singleton 0)+ @?= Left (DeltaHashDigestTrailingBytes 1)+ versionedMerkle <- requireRight (Patch.buildMerkleDeltaHash shiftedEncoderVersion intEncoding intEncoding state)+ let versionedMerkleDigest = Patch.merkleDeltaHashDigest versionedMerkle+ versionedMultisetDigest =+ Patch.multisetDeltaHashDigest+ (Patch.buildMultisetDeltaHash shiftedEncoderVersion intEncoding intEncoding state)+ versionedMerkleIdentity = Patch.deltaHashDigestIdentity versionedMerkleDigest+ Patch.decodeMerkleDeltaHashDigest shiftedEncoderVersion encodedMerkleDigest+ @?= Left+ DeltaHashDigestIdentityMismatch+ { deltaHashExpectedIdentity = versionedMerkleIdentity,+ deltaHashEncodedIdentity = merkleIdentity+ }+ (versionedMerkleDigest == merkleDigest) @?= False+ (versionedMultisetDigest == multisetDigest) @?= False+ shiftedMerkle <- requireRight (Patch.buildMerkleDeltaHash shiftedEncoderVersion shiftedEncoding intEncoding state)+ (merkleDigest == Patch.merkleDeltaHashDigest shiftedMerkle) @?= False+ let shiftedMultiset = Patch.buildMultisetDeltaHash shiftedEncoderVersion shiftedEncoding intEncoding state+ (multisetDigest == Patch.multisetDeltaHashDigest shiftedMultiset) @?= False++digestSerializationRoundTrip :: Property+digestSerializationRoundTrip =+ forAll smallMapGen $ \state ->+ case buildTestMerkleDeltaHash state of+ Left obstruction ->+ counterexample ("unexpected Merkle construction obstruction: " <> show obstruction) False+ Right merkleDeltaHash ->+ let merkleDigest = Patch.merkleDeltaHashDigest merkleDeltaHash+ multisetDigest = Patch.multisetDeltaHashDigest (buildTestMultisetDeltaHash state)+ in ( Patch.decodeMerkleDeltaHashDigest+ testEncoderVersion+ (Patch.encodeDeltaHashDigest merkleDigest),+ Patch.decodeMultisetDeltaHashDigest+ testEncoderVersion+ (Patch.encodeDeltaHashDigest multisetDigest)+ )+ === (Right merkleDigest, Right multisetDigest)++crossStrategyCompileNegativeCase :: IO ()+crossStrategyCompileNegativeCase = do+ merkleDeltaHash <- requireRight (buildTestMerkleDeltaHash Map.empty)+ let merkleDigest = Patch.merkleDeltaHashDigest merkleDeltaHash+ multisetDigest = Patch.multisetDeltaHashDigest (buildTestMultisetDeltaHash Map.empty)+ comparison <-+ try (evaluate (crossStrategyDigestComparison merkleDigest multisetDigest)) :: IO (Either TypeError Bool)+ case comparison of+ Left typeError -> do+ let typeErrorMessage = show typeError+ assertBool+ ("deferred type error did not name the digest-strategy mismatch: " <> typeErrorMessage)+ ( "Couldn't match type" `isInfixOf` typeErrorMessage+ && "MerkleDigestStrategy" `isInfixOf` typeErrorMessage+ && "MultisetDigestStrategy" `isInfixOf` typeErrorMessage+ )+ Right _comparisonResult ->+ assertFailure "complete digest cross-strategy comparison unexpectedly typechecked"++sipHashReferenceVectorCase :: IO ()+sipHashReferenceVectorCase =+ oracleSipHashReferenceVectors @?= canonicalSipHash24ReferenceVectors++-- SipHash reference implementation vectors.h for messages of length 0 through+-- 63 under key bytes 00..0f: https://github.com/veorq/SipHash/blob/master/vectors.h+canonicalSipHash24ReferenceVectors :: [Word64]+canonicalSipHash24ReferenceVectors =+ [ 0x726fdb47dd0e0e31,+ 0x74f839c593dc67fd,+ 0x0d6c8009d9a94f5a,+ 0x85676696d7fb7e2d,+ 0xcf2794e0277187b7,+ 0x18765564cd99a68d,+ 0xcbc9466e58fee3ce,+ 0xab0200f58b01d137,+ 0x93f5f5799a932462,+ 0x9e0082df0ba9e4b0,+ 0x7a5dbbc594ddb9f3,+ 0xf4b32f46226bada7,+ 0x751e8fbc860ee5fb,+ 0x14ea5627c0843d90,+ 0xf723ca908e7af2ee,+ 0xa129ca6149be45e5,+ 0x3f2acc7f57c29bdb,+ 0x699ae9f52cbe4794,+ 0x4bc1b3f0968dd39c,+ 0xbb6dc91da77961bd,+ 0xbed65cf21aa2ee98,+ 0xd0f2cbb02e3b67c7,+ 0x93536795e3a33e88,+ 0xa80c038ccd5ccec8,+ 0xb8ad50c6f649af94,+ 0xbce192de8a85b8ea,+ 0x17d835b85bbb15f3,+ 0x2f2e6163076bcfad,+ 0xde4daaaca71dc9a5,+ 0xa6a2506687956571,+ 0xad87a3535c49ef28,+ 0x32d892fad841c342,+ 0x7127512f72f27cce,+ 0xa7f32346f95978e3,+ 0x12e0b01abb051238,+ 0x15e034d40fa197ae,+ 0x314dffbe0815a3b4,+ 0x027990f029623981,+ 0xcadcd4e59ef40c4d,+ 0x9abfd8766a33735c,+ 0x0e3ea96b5304a7d0,+ 0xad0c42d6fc585992,+ 0x187306c89bc215a9,+ 0xd4a60abcf3792b95,+ 0xf935451de4f21df2,+ 0xa9538f0419755787,+ 0xdb9acddff56ca510,+ 0xd06c98cd5c0975eb,+ 0xe612a3cb9ecba951,+ 0xc766e62cfcadaf96,+ 0xee64435a9752fe72,+ 0xa192d576b245165a,+ 0x0a8787bf8ecb74b2,+ 0x81b3e73d20b49b6f,+ 0x7fa8220ba3b2ecea,+ 0x245731c13ca42499,+ 0xb78dbfaf3a8d83bd,+ 0xea1ad565322a1a0b,+ 0x60e61c23a3795013,+ 0x6606d7e446282b93,+ 0x6ca4ecb15c5f91e1,+ 0x9f626da15c9625f3,+ 0xe51b38608ef25f57,+ 0x958a324ceb064572+ ]++-- | Protocol vectors for encoding version 3. These are the DeltaHash wire image,+-- not behavioral assertions; they change only on a deliberate version bump.+digestGoldenCase :: IO ()+digestGoldenCase = do+ let emptyNodeGolden = OracleDigest 0x86f54b9300a90465 0x63a57136d0551b36+ flatGolden = DeltaHashDigestLanes 0xa655a16f5418af01 0xcd90c77a2dfa851c+ trieGolden = DeltaHashDigestLanes 0xb33b70f78e117412 0x613fb19ab70e2378+ multisetGolden = DeltaHashDigestLanes 0x8cfd047cf5fb3aca 0x27f3f7852d13d309+ oracleEmptyNodeDigest @?= emptyNodeGolden+ Node.emptyDigest Node.sipHashNodeCommitment+ @?= RawDigest128 0x86f54b9300a90465 0x63a57136d0551b36+ flatDeltaHash <-+ requireRight (buildTestMerkleDeltaHash (Map.fromList [(1, 10), (2, 20)]))+ let flatDigest = Patch.merkleDeltaHashDigest flatDeltaHash+ oracleDigestLanes oracleFlatDigest @?= flatGolden+ internalDigestLanes flatDigest @?= flatGolden+ assertMerkleIdentity flatDigest+ merkleDeltaHash <-+ requireRight+ (buildTestMerkleDeltaHash (sequentialState (deltaHashFlatBoundarySize + 1)))+ let trieDigest = Patch.merkleDeltaHashDigest merkleDeltaHash+ fmap oracleDigestLanes oracleTrieDigest @?= Just trieGolden+ internalDigestLanes trieDigest @?= trieGolden+ assertMerkleIdentity trieDigest+ let multisetDigest =+ Patch.multisetDeltaHashDigest+ (buildTestMultisetDeltaHash (Map.fromList [(1, 10), (2, 20)]))+ oracleDigestLanes oracleMultisetDigest @?= multisetGolden+ internalDigestLanes multisetDigest @?= multisetGolden+ assertMultisetIdentity multisetDigest++testEncoderVersion :: DeltaHashEncoderVersion+testEncoderVersion = DeltaHashEncoderVersion 1++shiftedEncoderVersion :: DeltaHashEncoderVersion+shiftedEncoderVersion = DeltaHashEncoderVersion 2++internalDigestLanes :: Patch.DeltaHashDigest strategy -> DeltaHashDigestLanes strategy+internalDigestLanes =+ deltaHashDigestLanes++oracleDigestLanes :: OracleDigest -> DeltaHashDigestLanes strategy+oracleDigestLanes (OracleDigest lane0 lane1) =+ DeltaHashDigestLanes lane0 lane1++assertMerkleIdentity :: MerkleDeltaHashDigest -> IO ()+assertMerkleIdentity digestValue =+ Patch.decodeMerkleDeltaHashDigest testEncoderVersion (Patch.encodeDeltaHashDigest digestValue)+ @?= Right digestValue++assertMultisetIdentity :: MultisetDeltaHashDigest -> IO ()+assertMultisetIdentity digestValue =+ Patch.decodeMultisetDeltaHashDigest testEncoderVersion (Patch.encodeDeltaHashDigest digestValue)+ @?= Right digestValue++merkleObservation :: MerkleDeltaHash Int Int -> (Map Int Int, MerkleDeltaHashDigest)+merkleObservation = merkleObservationOn++merkleObservationOn ::+ Ord key =>+ MerkleDeltaHash key value ->+ (Map key value, MerkleDeltaHashDigest)+merkleObservationOn deltaHashValue =+ (Patch.merkleDeltaHashState deltaHashValue, Patch.merkleDeltaHashDigest deltaHashValue)++multisetObservation :: MultisetDeltaHash Int Int -> (Map Int Int, MultisetDeltaHashDigest)+multisetObservation deltaHashValue =+ (Patch.multisetDeltaHashState deltaHashValue, Patch.multisetDeltaHashDigest deltaHashValue)++buildTestMerkleDeltaHash ::+ Map Int Int ->+ Either (DeltaHashBuildError Int) (MerkleDeltaHash Int Int)+buildTestMerkleDeltaHash =+ Patch.buildMerkleDeltaHash testEncoderVersion intEncoding intEncoding++buildTestMultisetDeltaHash :: Map Int Int -> MultisetDeltaHash Int Int+buildTestMultisetDeltaHash =+ Patch.buildMultisetDeltaHash testEncoderVersion intEncoding intEncoding++buildTestMultisetForComposition ::+ Map Int Int ->+ Either (DeltaHashBuildError Int) (MultisetDeltaHash Int Int)+buildTestMultisetForComposition =+ Right . buildTestMultisetDeltaHash++sequentialState :: Int -> Map Int Int+sequentialState stateSize =+ Map.fromDistinctAscList (fmap (\key -> (key, key)) [0 .. stateSize - 1])++intEncoding :: Int -> StableHashEncoding+intEncoding =+ stableHashEncodingWord64LE . fromIntegral++shiftedEncoding :: Int -> StableHashEncoding+shiftedEncoding key =+ stableHashEncodingWord8 7 <> intEncoding key++boundaryCollisionEncoding :: Int -> StableHashEncoding+boundaryCollisionEncoding key+ | key == deltaHashFlatBoundarySize = intEncoding 0+ | otherwise = intEncoding key++constantEncoding :: Int -> StableHashEncoding+constantEncoding _value =+ stableHashEncodingWord64LE 0++data RepresentativeKind+ = StateRepresentative+ | PatchRepresentative+ | FinalRepresentative+ deriving stock (Eq, Ord, Show)++data RepresentativeKey = RepresentativeKey+ { representativeId :: !Int,+ representativeKind :: !RepresentativeKind+ }+ deriving stock (Show)++instance Eq RepresentativeKey where+ left == right =+ representativeId left == representativeId right++instance Ord RepresentativeKey where+ compare left right =+ compare (representativeId left) (representativeId right)++representativeKeyEncoding :: RepresentativeKey -> StableHashEncoding+representativeKeyEncoding representative =+ intEncoding (representativeId representative)+ <> representativeKindEncoding (representativeKind representative)++representativeSamePathEncoding :: RepresentativeKey -> StableHashEncoding+representativeSamePathEncoding =+ intEncoding . representativeId++data RepresentativeValue = RepresentativeValue+ { representativeValueId :: !Int,+ representativeValueKind :: !RepresentativeKind+ }+ deriving stock (Show)++instance Eq RepresentativeValue where+ left == right =+ representativeValueId left == representativeValueId right++representativeValueEncoding :: RepresentativeValue -> StableHashEncoding+representativeValueEncoding representative =+ intEncoding (representativeValueId representative)+ <> representativeKindEncoding (representativeValueKind representative)++representativeKindEncoding :: RepresentativeKind -> StableHashEncoding+representativeKindEncoding representative =+ stableHashEncodingWord64LE+ ( case representative of+ StateRepresentative -> 0+ PatchRepresentative -> 1+ FinalRepresentative -> 2+ )++-- | A key whose Patricia path is fixed by an explicit bucket while its identity+-- is a separate ordinal, letting a test route several distinct keys onto a+-- controlled cycle of shared paths.+data PathBucketKey = PathBucketKey+ { pathBucketIdent :: !Int,+ pathBucketBucket :: !Int+ }+ deriving stock (Show)++instance Eq PathBucketKey where+ left == right =+ pathBucketIdent left == pathBucketIdent right++instance Ord PathBucketKey where+ compare left right =+ compare (pathBucketIdent left) (pathBucketIdent right)++pathBucketEncoding :: PathBucketKey -> StableHashEncoding+pathBucketEncoding =+ intEncoding . pathBucketBucket++trieStateA :: Map Int Int+trieStateA =+ Map.fromList [(key, key) | key <- [0 .. deltaHashFlatBoundarySize + 64]]++trieStateB :: Map Int Int+trieStateB =+ Map.insert 9001 42 (Map.delete 5 (Map.map (+ 1) trieStateA))++trieStateC :: Map Int Int+trieStateC =+ Map.insert 9002 7 (Map.delete 10 trieStateB)++mixedFormPatch :: Patch.Patch Int Int+mixedFormPatch =+ Patch.fromAscList [(key, mixedFormCell key) | key <- [0 .. 319]]++mixedFormInitialMap :: Map Int Int+mixedFormInitialMap =+ Map.fromList+ ( [(key, mixedFormBeforeValue key) | key <- [64 .. 255]]+ <> [(key, key) | key <- [1000 .. 1000 + deltaHashFlatBoundarySize]]+ )++mixedFormMap :: Map Int Int+mixedFormMap =+ Map.fromList+ ( [(key, mixedFormAfterValue key) | key <- [0 .. 63] <> [128 .. 255]]+ <> [(key, key) | key <- [1000 .. 1000 + deltaHashFlatBoundarySize]]+ )++mixedFormCell :: Int -> Patch.CellPatch Int+mixedFormCell key+ | key < 64 = Patch.insert (mixedFormAfterValue key)+ | key < 128 = Patch.delete (mixedFormBeforeValue key)+ | key < 256 = Patch.replace (mixedFormBeforeValue key) (mixedFormAfterValue key)+ | otherwise = Patch.assertAbsent++mixedFormBeforeValue :: Int -> Int+mixedFormBeforeValue key+ | key < 128 = if key < 96 then 100 else 200+ | key < 192 = key+ | otherwise = (key * 2654435761) `mod` 4096++mixedFormAfterValue :: Int -> Int+mixedFormAfterValue key+ | key < 64 = 777+ | key < 192 = key + 1+ | otherwise = (key * 40503 + 17) `mod` 8192++smallMapGen :: Gen (Map Int Int)+smallMapGen =+ Map.fromList <$> listOf ((,) <$> chooseInt (-32, 32) <*> chooseInt (-1000, 1000))++-- | Generates maps strictly larger than the flat boundary, so every property+-- using it exercises trie mode. Strictly increasing keys guarantee the size.+largeMapGen :: Gen (Map Int Int)+largeMapGen = do+ entryCount <- chooseInt (deltaHashFlatBoundarySize + 1, deltaHashFlatBoundarySize + 128)+ gaps <- vectorOf entryCount (chooseInt (1, 7))+ values <- vectorOf entryCount (chooseInt (-4096, 4096))+ let keys = scanl1 (+) gaps+ pure (Map.fromList (zip keys values)) deltaHashFlatBoundarySize :: Int deltaHashFlatBoundarySize =
+ test/patch/DeltaHashTypeErrors.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -fdefer-type-errors -Wno-deferred-type-errors #-}++module DeltaHashTypeErrors+ ( crossStrategyDigestComparison,+ )+where++import Moonlight.Delta.Patch+ ( MerkleDeltaHashDigest,+ MultisetDeltaHashDigest,+ )+import Prelude++-- Identity and lane re-indexing fixtures no longer exist: the public facade+-- exposes neither raw-lane construction/projection nor a 'Read' path. Their+-- unrepresentability is stronger than a deferred-error witness.+crossStrategyDigestComparison :: MerkleDeltaHashDigest -> MultisetDeltaHashDigest -> Bool+crossStrategyDigestComparison merkleDigest multisetDigest =+ merkleDigest == multisetDigest