feat: restore the typed Haskell domain model

bindings/haskell/event-sorcery.cabal

@@ -34,6 +34,7 @@ common strict
     TypeFamilies
     TypeFamilyDependencies
     UndecidableInstances
+    UndecidableSuperClasses
 
   ghc-options:
     -Wall -Wcompat -Werror -Widentities -Wincomplete-record-updates
@@ -50,14 +51,17 @@ library
   import:          strict
   hs-source-dirs:  src
   exposed-modules:
+    EventSorcery.Aggregate
     EventSorcery.Engine
     EventSorcery.Engine.Internal.FFI
     EventSorcery.Job
+    EventSorcery.Store
     EventSorcery.Stream
 
   other-modules:
     EventSorcery.Engine.Acquisition
     EventSorcery.Engine.Internal
+    EventSorcery.Job.Definition
 
   extra-libraries: event_sorcery_ffi
   build-depends:
@@ -111,4 +115,26 @@ test-suite job-spec
     , linear-base    >=0.5   && <0.6
     , tasty          >=1.5   && <1.6
     , tasty-hunit    >=0.10  && <0.11
+    , text           >=2.0   && <2.2
     , transformers   >=0.6   && <0.7
+
+test-suite domain-spec
+  import:         strict
+  type:           exitcode-stdio-1.0
+  hs-source-dirs: test
+  main-is:        DomainSpec.hs
+  build-depends:
+    , base           >=4.18 && <5
+    , bytestring     >=0.11 && <0.13
+    , event-sorcery
+
+test-suite store-spec
+  import:         strict
+  type:           exitcode-stdio-1.0
+  hs-source-dirs: test
+  main-is:        StoreSpec.hs
+  build-depends:
+    , base           >=4.18 && <5
+    , bytestring     >=0.11 && <0.13
+    , event-sorcery
+    , text           >=2.0  && <2.2

bindings/haskell/src/EventSorcery/Aggregate.hs

@@ -0,0 +1,98 @@
+module EventSorcery.Aggregate (
+  DecodeCause (..),
+  DispatchIntent,
+  Dispatches (..),
+  Effect (..),
+  EventSourced (..),
+  EventVersion (..),
+  Member,
+  SchemaVersion (..),
+  dispatchIntent,
+  dispatchJobId,
+) where
+
+import Data.ByteString (ByteString)
+import Data.Kind (Type)
+import Data.List.NonEmpty (NonEmpty)
+import Data.Proxy (Proxy)
+import Data.Text (Text)
+import Data.Type.Equality (type (~))
+import Data.Word (Word16)
+import EventSorcery.Job.Definition (
+  Job (..),
+  JobId,
+  jobType,
+ )
+import Prelude (Bool (..), Either, Eq, Ord, Show)
+
+
+newtype EventVersion = EventVersion Text
+  deriving stock (Eq, Ord, Show)
+
+
+newtype SchemaVersion = SchemaVersion Word16
+  deriving stock (Eq, Ord, Show)
+
+
+newtype DecodeCause = DecodeCause Text
+  deriving stock (Eq, Show)
+
+
+data DispatchIntent job = DispatchIntent JobId Text ByteString
+
+
+class Dispatches entity job where
+  injectDispatchIntent :: DispatchIntent job -> Event entity
+
+
+type Member item items = Elem item items ~ 'True
+
+
+type family Elem (item :: Type) (items :: [Type]) :: Bool where
+  Elem item '[] = 'False
+  Elem item (item ': items) = 'True
+  Elem item (other ': items) = Elem item items
+
+
+data Effect entity where
+  Events :: NonEmpty (Event entity) -> Effect entity
+  Dispatch
+    :: (Job job, Member job (Jobs entity), Dispatches entity job)
+    => job
+    -> Effect entity
+
+
+class EventSourced entity where
+  type EntityId entity = (identifier :: Type) | identifier -> entity
+  type Command entity :: Type
+  type Event entity = (event :: Type) | event -> entity
+  type CommandError entity :: Type
+  type ApplyError entity :: Type
+  type Jobs entity :: [Type]
+
+
+  aggregateType :: Proxy entity -> Text
+  encodeEntityId :: EntityId entity -> Text
+  eventType :: Event entity -> Text
+  eventVersion :: Event entity -> EventVersion
+  schemaVersion :: Proxy entity -> SchemaVersion
+  encodeEvent :: Event entity -> ByteString
+  decodeEvent :: ByteString -> Either DecodeCause (Event entity)
+  encodeSnapshot :: entity -> ByteString
+  decodeSnapshot :: ByteString -> Either DecodeCause entity
+  originate :: Event entity -> Either (ApplyError entity) entity
+  evolve :: entity -> Event entity -> Either (ApplyError entity) entity
+  initialize :: Command entity -> Either (CommandError entity) (Effect entity)
+  transition
+    :: entity
+    -> Command entity
+    -> Either (CommandError entity) (Effect entity)
+
+
+dispatchIntent :: forall job. Job job => JobId -> job -> DispatchIntent job
+dispatchIntent identifier job =
+  DispatchIntent identifier (jobType @job) (encodeJob job)
+
+
+dispatchJobId :: DispatchIntent job -> JobId
+dispatchJobId (DispatchIntent identifier _ _) = identifier

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

@@ -79,6 +79,7 @@ import EventSorcery.Engine.Internal.FFI (
   esClose,
   esOpen,
  )
+import EventSorcery.Job.Definition (JobId (..))
 import Foreign.C.Types (CInt, CSize)
 import Foreign.Concurrent qualified as Foreign
 import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
@@ -199,11 +200,6 @@ data ConflictDetail = ConflictDetail
   deriving stock (Eq, Show)
 
 
--- | Identity of a durable job -- a ULID minted when the job is enqueued.
-newtype JobId = JobId Text
-  deriving newtype (Eq, Show)
-
-
 -- | Why one job refused the request made of it.
 --
 -- The engine renders each reason as fixed ABI text, so the reason is a closed

bindings/haskell/src/EventSorcery/Job.hs

@@ -21,11 +21,13 @@ module EventSorcery.Job (
   DeadReason (..),
   EngineError (..),
   EngineErrorDecodeDetail (..),
+  Job (..),
   JobClaimDetails (..),
   JobClaimReference (..),
   JobClaimResult (..),
+  JobDecodeError (..),
   JobExecutionRoute (..),
-  JobId (..),
+  JobId,
   JobInstant (..),
   JobKind (..),
   JobLeaseResult (..),
@@ -53,6 +55,9 @@ module EventSorcery.Job (
   encodePoll,
   encodeRenew,
   enqueueJob,
+  jobIdText,
+  jobType,
+  mkJobId,
   pollJobs,
   renewJob,
   retryJob,
@@ -131,6 +136,13 @@ import EventSorcery.Engine.Internal.FFI (
   esJobRenew,
   esJobRetry,
  )
+import EventSorcery.Job.Definition (
+  Job (..),
+  JobDecodeError (..),
+  jobIdText,
+  jobType,
+  mkJobId,
+ )
 import EventSorcery.Stream (
   ProposedEvent,
   StreamIdentity,

bindings/haskell/src/EventSorcery/Job/Definition.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
+module EventSorcery.Job.Definition (
+  Job (..),
+  JobDecodeError (..),
+  JobId (..),
+  jobIdText,
+  jobType,
+  mkJobId,
+) where
+
+import Data.ByteString (ByteString)
+import Data.Maybe (Maybe (..))
+import Data.Proxy (Proxy (Proxy))
+import Data.Text (Text)
+import Data.Text qualified as Text
+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
+import Prelude (Either, Eq, Ord, Show, otherwise, (==))
+
+
+newtype JobId = JobId Text
+  deriving stock (Eq, Ord, Show)
+
+
+newtype JobDecodeError = JobDecodeError Text
+  deriving stock (Eq, Show)
+
+
+class KnownSymbol (JobType job) => Job job where
+  type JobType job :: Symbol
+
+
+  encodeJob :: job -> ByteString
+  decodeJob :: ByteString -> Either JobDecodeError job
+
+
+mkJobId :: Text -> Maybe JobId
+mkJobId value
+  | value == "" = Nothing
+  | otherwise = Just (JobId value)
+
+
+jobIdText :: JobId -> Text
+jobIdText (JobId value) = value
+
+
+jobType :: forall job. Job job => Text
+jobType = Text.pack (symbolVal (Proxy @(JobType job)))