Repository navigation
feat: load Haskell entities from snapshots #36
There are no files selected for viewing
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,198 @@ | ||
| module EventSorcery.Snapshot ( | ||
| SnapshotVersion (..), | ||
| SnapshotWrite, | ||
| StoredSnapshot (..), | ||
| discardSnapshot, | ||
| loadSnapshot, | ||
| snapshotWrite, | ||
| storeSnapshot, | ||
| ) where | ||
|
|
||
| import Codec.CBOR.Decoding ( | ||
| Decoder, | ||
| TokenType (TypeNull), | ||
| decodeBytes, | ||
| decodeListLen, | ||
| decodeNull, | ||
| decodeWord, | ||
| decodeWord64, | ||
| peekTokenType, | ||
| ) | ||
| import Codec.CBOR.Encoding ( | ||
| encodeBytes, | ||
| encodeListLen, | ||
| encodeString, | ||
| encodeWord, | ||
| encodeWord64, | ||
| ) | ||
| import Codec.CBOR.Read (deserialiseFromBytes) | ||
| import Codec.CBOR.Write (toStrictByteString) | ||
| import Data.ByteString (ByteString) | ||
| import Data.ByteString.Lazy qualified as LazyByteString | ||
| import Data.Unrestricted.Linear (Ur (Ur)) | ||
| import Data.Word (Word64) | ||
| import EventSorcery.Engine (EngineError) | ||
| import EventSorcery.Engine qualified as Engine | ||
| import EventSorcery.Engine.Internal ( | ||
| callWithOutput, | ||
| callWithoutOutput, | ||
| decodeResponse, | ||
| withInputBuffer, | ||
| withOpenStore, | ||
| ) | ||
| import EventSorcery.Engine.Internal.FFI ( | ||
| esSnapshotDiscard, | ||
| esSnapshotLoad, | ||
| esSnapshotStore, | ||
| ) | ||
| import EventSorcery.Stream ( | ||
| AggregateId (AggregateId), | ||
| AggregateType (AggregateType), | ||
| StreamIdentity (StreamIdentity), | ||
| ) | ||
| import Foreign.Marshal.Alloc (alloca) | ||
| import Foreign.Storable (peek, poke) | ||
| import Prelude ( | ||
| Either (..), | ||
| Eq, | ||
| IO, | ||
| Int, | ||
| Maybe (..), | ||
| Show, | ||
| String, | ||
| fail, | ||
| otherwise, | ||
| pure, | ||
| show, | ||
| ($), | ||
| (.), | ||
| (<$), | ||
| (<$>), | ||
| (<>), | ||
| (==), | ||
| (>>=), | ||
| ) | ||
|
|
||
|
|
||
| newtype SnapshotVersion = SnapshotVersion Word64 | ||
| deriving stock (Eq, Show) | ||
|
|
||
|
|
||
| data StoredSnapshot = StoredSnapshot Word64 SnapshotVersion ByteString | ||
| deriving stock (Eq, Show) | ||
|
|
||
|
|
||
| data SnapshotWrite where | ||
| SnapshotWrite | ||
| :: Ur (StreamIdentity, Word64, ByteString) | ||
| %1 -> SnapshotWrite | ||
|
|
||
|
|
||
| snapshotWrite :: StreamIdentity -> Word64 -> ByteString -> SnapshotWrite | ||
| snapshotWrite identity sequence payload = | ||
| SnapshotWrite (Ur (identity, sequence, payload)) | ||
|
Comment on lines
+85
to
+93
There was a problem hiding this comment. 📐 Maintainability & Code Quality | 🔵 Trivial | ⚖️ Poor tradeoff The linear
Two consistent options:
Option 1 matches the surrounding modules. If the linear signature is a deliberate architectural choice for the binding, record the rationale as an ADR. Otherwise the type surface suggests a guarantee that the implementation does not provide. Also applies to: 107-119 🤖 Prompt for AI AgentsSource: Path instructions |
||
|
|
||
|
|
||
| loadSnapshot | ||
| :: Engine.Store | ||
| -> StreamIdentity | ||
| -> IO (Either EngineError (Maybe StoredSnapshot)) | ||
| loadSnapshot store identity = | ||
| withOpenStore store $ \handle -> | ||
| withInputBuffer (encodeIdentity identity) $ \request -> do | ||
| response <- callWithOutput (esSnapshotLoad handle request) | ||
| pure (response >>= decodeResponse decodeStoredSnapshot) | ||
|
|
||
|
|
||
| storeSnapshot | ||
| :: Engine.Store | ||
| -> SnapshotWrite | ||
| %1 -> IO (Either EngineError SnapshotVersion) | ||
| storeSnapshot store (SnapshotWrite (Ur (identity, sequence, payload))) = | ||
| withOpenStore store $ \handle -> | ||
| withInputBuffer (encodeWrite identity sequence payload) $ \request -> | ||
| alloca $ \outVersion -> do | ||
| poke outVersion 0 | ||
| stored <- callWithoutOutput (esSnapshotStore handle request outVersion) | ||
| case stored of | ||
| Left failure -> pure (Left failure) | ||
| Right () -> Right . SnapshotVersion <$> peek outVersion | ||
|
|
||
|
|
||
| discardSnapshot | ||
| :: Engine.Store | ||
| -> StreamIdentity | ||
| -> IO (Either EngineError ()) | ||
| discardSnapshot store identity = | ||
| withOpenStore store $ \handle -> | ||
| withInputBuffer | ||
| (encodeIdentity identity) | ||
| (callWithoutOutput . esSnapshotDiscard handle) | ||
|
|
||
|
|
||
| encodeIdentity :: StreamIdentity -> ByteString | ||
| encodeIdentity identity = | ||
| let StreamIdentity (AggregateType aggregateType) (AggregateId aggregateId) = | ||
| identity | ||
| in toStrictByteString $ | ||
| encodeListLen 3 | ||
| <> encodeWord 1 | ||
| <> encodeString aggregateType | ||
| <> encodeString aggregateId | ||
|
|
||
|
|
||
| encodeWrite :: StreamIdentity -> Word64 -> ByteString -> ByteString | ||
| encodeWrite identity sequence payload = | ||
| let StreamIdentity (AggregateType aggregateType) (AggregateId aggregateId) = | ||
| identity | ||
| in toStrictByteString $ | ||
| encodeListLen 5 | ||
| <> encodeWord 1 | ||
| <> encodeString aggregateType | ||
| <> encodeString aggregateId | ||
| <> encodeWord64 sequence | ||
| <> encodeBytes payload | ||
|
|
||
|
|
||
| decodeStoredSnapshot :: ByteString -> Either String (Maybe StoredSnapshot) | ||
| decodeStoredSnapshot bytes = | ||
| case deserialiseFromBytes | ||
| decodeStoredSnapshotWire | ||
| (LazyByteString.fromStrict bytes) of | ||
| Left failure -> Left (show failure) | ||
| Right (remaining, snapshot) | ||
| | LazyByteString.null remaining -> Right snapshot | ||
| | otherwise -> Left "trailing bytes after stored snapshot" | ||
|
|
||
|
|
||
| decodeStoredSnapshotWire :: Decoder s (Maybe StoredSnapshot) | ||
| decodeStoredSnapshotWire = do | ||
| expectListLength 2 | ||
| expectFormatVersion | ||
| token <- peekTokenType | ||
|
|
||
| case token of | ||
| TypeNull -> Nothing <$ decodeNull | ||
| _ -> do | ||
| expectListLength 3 | ||
| sequence <- decodeWord64 | ||
| version <- SnapshotVersion <$> decodeWord64 | ||
| Just . StoredSnapshot sequence version <$> decodeBytes | ||
|
|
||
|
|
||
| expectFormatVersion :: Decoder s () | ||
| expectFormatVersion = do | ||
| version <- decodeWord | ||
|
|
||
| if version == 1 | ||
| then pure () | ||
| else fail "unsupported snapshot format version" | ||
|
|
||
|
|
||
| expectListLength :: Int -> Decoder s () | ||
| expectListLength expected = do | ||
| actual <- decodeListLen | ||
|
|
||
| if actual == expected | ||
| then pure () | ||
| else fail "unexpected CBOR list length" | ||
|
Comment on lines
+157
to
+198
There was a problem hiding this comment. 📐 Maintainability & Code Quality | 🟡 Minor | ⚡ Quick win 🧩 Analysis chain🏁 Script executed: #!/bin/bash
# Check for existing snapshot codec coverage in the Haskell test suites.
fd -t f -e hs . bindings/haskell/test --exec rg -n 'Snapshot|snapshotWrite|decodeStoredSnapshot|StoredSnapshot' {}
# Show which modules WireSpec currently covers.
fd -t f 'WireSpec.hs' --exec rg -n '^import|testCase' {}Repository: dataclique/event-sorcery Length of output: 3334 🏁 Script executed: #!/bin/bash
set -e
printf '%s\n' '--- documentation files ---'
fd -t f 'SPEC.md' 'domain.md' . | sort
for f in $(fd -t f 'SPEC.md' 'domain.md' . | sort); do
printf '\n--- %s ---\n' "$f"
sed -n '1,220p' "$f"
done
printf '%s\n' '--- Snapshot module ---'
wc -l bindings/haskell/src/EventSorcery/Snapshot.hs
sed -n '1,220p' bindings/haskell/src/EventSorcery/Snapshot.hs
printf '%s\n' '--- WireSpec snapshot-related context ---'
WIRE=$(fd -t f 'WireSpec.hs' . | head -n 1)
printf 'file=%s\n' "$WIRE"
sed -n '1,240p' "$WIRE"
printf '%s\n' '--- all codec test references ---'
rg -n -C 3 'encodeIdentity|encodeWrite|decodeStoredSnapshot|stored snapshot|snapshot' bindings/haskell/test bindings/haskell/srcRepository: dataclique/event-sorcery Length of output: 39821 🏁 Script executed: #!/bin/bash
set -e
printf '%s\n' '--- domain documentation ---'
sed -n '1,220p' docs/domain.md
printf '%s\n' '--- snapshot specification references ---'
rg -n -C 4 'snapshot|Serialization tests|literal|wire-level|CBOR' SPEC.md docs bindings/haskell
printf '%s\n' '--- Haskell test configuration ---'
fd -t f . bindings/haskell | rg '(cabal|package|Makefile|flake|nix)$' | sort
for f in $(fd -t f . bindings/haskell | rg '(cabal|package|Makefile|flake|nix)$' | sort); do
printf '\n--- %s ---\n' "$f"
rg -n -C 3 'WireSpec|StoreSpec|test-suite|exposed-modules|other-modules' "$f" || true
done
printf '%s\n' '--- Rust snapshot wire tests ---'
rg -n -C 8 'StoredSnapshotWire|snapshot.*(None|Some)|snapshot_load|snapshot_store|snapshot wire' crates bindingsRepository: dataclique/event-sorcery Length of output: 50382 🏁 Script executed: #!/bin/bash
set -e
printf '%s\n' '--- Haskell package and test-suite declarations ---'
for f in $(fd -t f . bindings/haskell | rg '\.(cabal|yaml|yml|mk|nix)$|Makefile$' | sort); do
rg -n -C 5 'WireSpec|StoreSpec|test-suite|hs-source-dirs|other-modules|EventSorcery.Snapshot' "$f" || true
done
printf '%s\n' '--- Rust snapshot test matches only ---'
rg -n 'StoredSnapshotWire|snapshot_load|snapshot_store|snapshot.*None|snapshot.*Some' crates bindings --glob '*.rs' --glob '*.hs' | head -n 120
printf '%s\n' '--- Rust snapshot test region ---'
MATCH=$(rg -l 'StoredSnapshotWire' crates bindings --glob '*.rs' | head -n 1 || true)
if [ -n "$MATCH" ]; then
printf 'file=%s\n' "$MATCH"
LINE=$(rg -n 'StoredSnapshotWire' "$MATCH" | head -n 1 | cut -d: -f1)
START=$((LINE-30)); [ "$START" -lt 1 ] && START=1
END=$((LINE+100))
sed -n "${START},${END}p" "$MATCH"
fi
printf '%s\n' '--- Snapshot exports and test imports ---'
rg -n -C 2 'import EventSorcery.Snapshot|module EventSorcery.Snapshot|decodeStoredSnapshot|encodeIdentity|encodeWrite' bindings/haskell --glob '*.hs'Repository: dataclique/event-sorcery Length of output: 15650 Add independent-literal tests for the snapshot wire codec. The Haskell tests cover snapshots only through the store. They do not cover 🤖 Prompt for AI AgentsSource: Coding guidelines |
||
Oops, something went wrong.
Add this suggestion to a batch that can be applied as a single commit.
This suggestion is invalid because no changes were made to the code.
Suggestions cannot be applied while the pull request is closed.
Suggestions cannot be applied while viewing a subset of changes.
Only one suggestion per line can be applied in a batch.
Add this suggestion to a batch that can be applied as a single commit.
Applying suggestions on deleted lines is not supported.
You must change the existing code in this line in order to create a valid suggestion.
Outdated suggestions cannot be applied.
This suggestion has been applied or marked resolved.
Suggestions cannot be applied from pending reviews.
Suggestions cannot be applied on multi-line comments.
Suggestions cannot be applied while the pull request is queued to merge.
Suggestion cannot be applied right now. Please check back later.
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
📐 Maintainability & Code Quality | 🔵 Trivial | ⚡ Quick win
Use named fields for
StoredSnapshotto remove the positional swap hazard.StoredSnapshot Word64 SnapshotVersion ByteStringcarries a sequence and a version next to each other. The sequence stays a bareWord64while the version is a newtype. A caller that swaps the two numeric concepts gets no type error once both are unwrapped.EventSorcery.Stream.ProposedEventuses record syntax, and the package enablesNoFieldSelectorsandOverloadedRecordDot. Follow that convention here. Consider aStreamSequencenewtype as well, so the sequence and the version cannot be confused at any call site.♻️ Proposed record form
EventSorcery.Store.resumeSnapshotat line 200 then binds by field name instead of by position.📝 Committable suggestion
🤖 Prompt for AI Agents
Source: Path instructions