feat: add deterministic Haskell engine codecs

bindings/haskell/event-sorcery.cabal

@@ -41,5 +41,27 @@ common strict
     -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
 
 library
-  import:        strict
-  build-depends: base >=4.18 && <5
+  import:          strict
+  hs-source-dirs:  src
+  exposed-modules:
+    EventSorcery.Engine.Codec
+    EventSorcery.Engine.Protocol
+
+  build-depends:
+    , base        >=4.18   && <5
+    , bytestring  >=0.11   && <0.13
+    , cborg       >=0.2.10 && <0.3
+    , text        >=2.0    && <2.2
+
+test-suite codec-spec
+  import:         strict
+  type:           exitcode-stdio-1.0
+  hs-source-dirs: test
+  main-is:        CodecSpec.hs
+  build-depends:
+    , base           >=4.18 && <5
+    , bytestring     >=0.11 && <0.13
+    , event-sorcery
+    , tasty          >=1.5  && <1.6
+    , tasty-hunit    >=0.10 && <0.11
+    , text           >=2.0  && <2.2

bindings/haskell/src/EventSorcery/Engine/Codec.hs

@@ -0,0 +1,154 @@
+module EventSorcery.Engine.Codec (
+  decodeStoredEvents,
+  encodeCommit,
+  encodeLoadStream,
+  encodeOpenOptions,
+) where
+
+import Codec.CBOR.Decoding (
+  Decoder,
+  decodeBytes,
+  decodeListLen,
+  decodeString,
+  decodeWord,
+  decodeWord64,
+ )
+import Codec.CBOR.Encoding (
+  Encoding,
+  encodeBytes,
+  encodeListLen,
+  encodeNull,
+  encodeString,
+  encodeWord,
+  encodeWord32,
+  encodeWord64,
+ )
+import Codec.CBOR.Read (deserialiseFromBytes)
+import Codec.CBOR.Write (toStrictByteString)
+import Control.Monad (replicateM)
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy qualified as LazyByteString
+import Data.Foldable (foldMap)
+import Data.Maybe (maybe)
+import Data.Word (Word64)
+import EventSorcery.Engine.Protocol (
+  AggregateId (..),
+  AggregateType (..),
+  EventType (..),
+  EventVersion (..),
+  OpenOptions (..),
+  ProposedEvent (..),
+  StoredEvent (..),
+  StreamIdentity (..),
+ )
+import Prelude (
+  Either (..),
+  Int,
+  Maybe,
+  String,
+  fail,
+  fromIntegral,
+  length,
+  otherwise,
+  pure,
+  show,
+  ($),
+  (<$>),
+  (<>),
+  (==),
+ )
+
+
+encodeOpenOptions :: OpenOptions -> ByteString
+encodeOpenOptions options =
+  toStrictByteString $
+    encodeListLen 5
+      <> encodeWord 1
+      <> encodeString options.path
+      <> encodeWord64 options.busyTimeoutMilliseconds
+      <> encodeWord32 options.poolSize
+      <> encodeWord32 options.runtimeThreads
+
+
+encodeLoadStream :: StreamIdentity -> Maybe Word64 -> ByteString
+encodeLoadStream stream after =
+  toStrictByteString $
+    encodeListLen 4
+      <> encodeWord 1
+      <> encodeAggregateType stream.aggregateType
+      <> encodeAggregateId stream.aggregateId
+      <> maybe encodeNull encodeWord64 after
+
+
+encodeCommit :: StreamIdentity -> Word64 -> [ProposedEvent] -> ByteString
+encodeCommit stream expected events =
+  toStrictByteString $
+    encodeListLen 5
+      <> encodeWord 1
+      <> encodeAggregateType stream.aggregateType
+      <> encodeAggregateId stream.aggregateId
+      <> encodeWord64 expected
+      <> encodeListLen (fromIntegral (length events))
+      <> foldMap encodeProposedEvent events
+
+
+encodeProposedEvent :: ProposedEvent -> Encoding
+encodeProposedEvent event =
+  encodeListLen 3
+    <> encodeEventType event.eventType
+    <> encodeEventVersion event.eventVersion
+    <> encodeBytes event.payload
+
+
+decodeStoredEvents :: ByteString -> Either String [StoredEvent]
+decodeStoredEvents bytes =
+  case deserialiseFromBytes decodeStoredEventsWire (LazyByteString.fromStrict bytes) of
+    Left failure -> Left (show failure)
+    Right (remaining, events)
+      | LazyByteString.null remaining -> Right events
+      | otherwise -> Left "trailing bytes after stored events"
+
+
+decodeStoredEventsWire :: Decoder s [StoredEvent]
+decodeStoredEventsWire = do
+  expectListLength 2
+  version <- decodeWord
+  if version == 1
+    then do
+      count <- decodeListLen
+      replicateM count decodeStoredEvent
+    else fail "unsupported stored-events format version"
+
+
+decodeStoredEvent :: Decoder s StoredEvent
+decodeStoredEvent = do
+  expectListLength 4
+  sequence <- decodeWord64
+  eventType <- EventType <$> decodeString
+  eventVersion <- EventVersion <$> decodeString
+  payload <- decodeBytes
+  pure StoredEvent {sequence, eventType, eventVersion, payload}
+
+
+encodeAggregateType :: AggregateType -> Encoding
+encodeAggregateType (AggregateType value) = encodeString value
+
+
+encodeAggregateId :: AggregateId -> Encoding
+encodeAggregateId (AggregateId value) = encodeString value
+
+
+encodeEventType :: EventType -> Encoding
+encodeEventType (EventType value) = encodeString value
+
+
+encodeEventVersion :: EventVersion -> Encoding
+encodeEventVersion (EventVersion value) = encodeString value
+
+
+expectListLength :: Int -> Decoder s ()
+expectListLength expected = do
+  actual <- decodeListLen
+  if actual == expected
+    then pure ()
+    else fail "unexpected CBOR list length"

bindings/haskell/src/EventSorcery/Engine/Protocol.hs

@@ -0,0 +1,64 @@
+module EventSorcery.Engine.Protocol (
+  AggregateId (..),
+  AggregateType (..),
+  EventType (..),
+  EventVersion (..),
+  OpenOptions (..),
+  ProposedEvent (..),
+  StoredEvent (..),
+  StreamIdentity (..),
+) where
+
+import Data.ByteString (ByteString)
+import Data.Text (Text)
+import Data.Word (Word32, Word64)
+import Prelude (Eq, Show)
+
+
+newtype AggregateType = AggregateType Text
+  deriving newtype (Eq, Show)
+
+
+newtype AggregateId = AggregateId Text
+  deriving newtype (Eq, Show)
+
+
+newtype EventType = EventType Text
+  deriving newtype (Eq, Show)
+
+
+newtype EventVersion = EventVersion Text
+  deriving newtype (Eq, Show)
+
+
+data OpenOptions = OpenOptions
+  { path :: Text
+  , busyTimeoutMilliseconds :: Word64
+  , poolSize :: Word32
+  , runtimeThreads :: Word32
+  }
+  deriving stock (Eq, Show)
+
+
+data StreamIdentity = StreamIdentity
+  { aggregateType :: AggregateType
+  , aggregateId :: AggregateId
+  }
+  deriving stock (Eq, Show)
+
+
+data ProposedEvent = ProposedEvent
+  { eventType :: EventType
+  , eventVersion :: EventVersion
+  , payload :: ByteString
+  }
+  deriving stock (Eq, Show)
+
+
+data StoredEvent = StoredEvent
+  { sequence :: Word64
+  , eventType :: EventType
+  , eventVersion :: EventVersion
+  , payload :: ByteString
+  }
+  deriving stock (Eq, Show)