diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/bench/patch/PatchBench.hs b/bench/patch/PatchBench.hs --- a/bench/patch/PatchBench.hs +++ b/bench/patch/PatchBench.hs @@ -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 = diff --git a/moonlight-delta.cabal b/moonlight-delta.cabal --- a/moonlight-delta.cabal +++ b/moonlight-delta.cabal @@ -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 diff --git a/src-patch-public/Moonlight/Delta/Patch.hs b/src-patch-public/Moonlight/Delta/Patch.hs --- a/src-patch-public/Moonlight/Delta/Patch.hs +++ b/src-patch-public/Moonlight/Delta/Patch.hs @@ -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, ) diff --git a/src-patch/Moonlight/Delta/Patch/Internal/IncrementalDigest.hs b/src-patch/Moonlight/Delta/Patch/Internal/IncrementalDigest.hs --- a/src-patch/Moonlight/Delta/Patch/Internal/IncrementalDigest.hs +++ b/src-patch/Moonlight/Delta/Patch/Internal/IncrementalDigest.hs @@ -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 = diff --git a/src-patch/Moonlight/Delta/Patch/Internal/MerkleDeltaHash.hs b/src-patch/Moonlight/Delta/Patch/Internal/MerkleDeltaHash.hs --- a/src-patch/Moonlight/Delta/Patch/Internal/MerkleDeltaHash.hs +++ b/src-patch/Moonlight/Delta/Patch/Internal/MerkleDeltaHash.hs @@ -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 diff --git a/src-patch/Moonlight/Delta/Patch/Internal/MultisetDeltaHash.hs b/src-patch/Moonlight/Delta/Patch/Internal/MultisetDeltaHash.hs --- a/src-patch/Moonlight/Delta/Patch/Internal/MultisetDeltaHash.hs +++ b/src-patch/Moonlight/Delta/Patch/Internal/MultisetDeltaHash.hs @@ -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 diff --git a/src-patch/Moonlight/Delta/Patch/Internal/NodeCommitment.hs b/src-patch/Moonlight/Delta/Patch/Internal/NodeCommitment.hs --- a/src-patch/Moonlight/Delta/Patch/Internal/NodeCommitment.hs +++ b/src-patch/Moonlight/Delta/Patch/Internal/NodeCommitment.hs @@ -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 = diff --git a/test/patch/DeltaHashGoldenOracle.hs b/test/patch/DeltaHashGoldenOracle.hs new file mode 100644 --- /dev/null +++ b/test/patch/DeltaHashGoldenOracle.hs @@ -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) diff --git a/test/patch/DeltaHashSpec.hs b/test/patch/DeltaHashSpec.hs --- a/test/patch/DeltaHashSpec.hs +++ b/test/patch/DeltaHashSpec.hs @@ -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 = diff --git a/test/patch/DeltaHashTypeErrors.hs b/test/patch/DeltaHashTypeErrors.hs new file mode 100644 --- /dev/null +++ b/test/patch/DeltaHashTypeErrors.hs @@ -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